Add obelisk profiling feature

ChangeLog.md

@@ -14,6 +14,9 @@ This project's release branch is `master`. This log is written from the perspect
 * `ob thunk pack` will now attempt to automatically detect if the thunk is a private or public repo. To avoid this detection, specify `--private` or `--public` manually. ([#607](https://github.com/obsidiansystems/obelisk/pull/607))
 * Fix a bug in the plain git thunk loader for thunks marked as 'private' when the revision is not in the default branch. ([#648](https://github.com/obsidiansystems/obelisk/pull/648))
 * Improve handling of runtime nix dependencies. This may fix some issues encountered particularly by users on systems other than NixOS.
+* Add `ob profile` command to run Obelisk project with profiling. `ob
+profile` works like ob run, but instead of using ghci, it builds an
+executable that is built with profiling enabled.
 
 ## v0.4.0.0 - 2020-01-10
 

default.nix

@@ -17,10 +17,8 @@ let
     openssh
   ];
 
-  getReflexPlatform = sys: reflex-platform-func {
-    inherit iosSdkVersion config;
-    system = sys;
-    enableLibraryProfiling = profiling;
+  getReflexPlatform = { system, enableLibraryProfiling ? profiling }: reflex-platform-func {
+    inherit iosSdkVersion config system enableLibraryProfiling;
 
     nixpkgsOverlays = [
       (self: super: {
@@ -102,7 +100,7 @@ let
     ];
   };
 
-  reflex-platform = getReflexPlatform system;
+  reflex-platform = getReflexPlatform { inherit system; };
   inherit (reflex-platform) hackGet nixpkgs;
   pkgs = nixpkgs;
 
@@ -261,7 +259,7 @@ in rec {
   # An Obelisk project is a reflex-platform project with a predefined layout and role for each component
   project = base': projectDefinition:
     let
-      projectOut = sys: let reflexPlatformProject = (getReflexPlatform sys).project; in reflexPlatformProject (args@{ nixpkgs, ... }:
+      projectOut = { system, enableLibraryProfiling ? profiling }: let reflexPlatformProject = (getReflexPlatform { inherit system enableLibraryProfiling; }).project; in reflexPlatformProject (args@{ nixpkgs, ... }:
         let
           inherit (lib.strings) hasPrefix;
           mkProject =
@@ -366,7 +364,7 @@ in rec {
               });
             in allConfig;
         in (mkProject (projectDefinition args)).projectConfig);
-      mainProjectOut = projectOut system;
+      mainProjectOut = projectOut { inherit system; };
       serverOn = projectInst: version: serverExe
         projectInst.ghc.backend
         mainProjectOut.ghcjs.frontend
@@ -376,6 +374,7 @@ in rec {
       linuxExe = serverOn (projectOut "x86_64-linux");
       dummyVersion = "Version number is only available for deployments";
     in mainProjectOut // {
+      profiled = projectOut { inherit system; enableLibraryProfiling = true; };
       linuxExeConfigurable = linuxExe;
       linuxExe = linuxExe dummyVersion;
       exe = serverOn mainProjectOut dummyVersion;

lib/command/src/Obelisk/Command.hs

@@ -87,6 +87,7 @@ data ObCommand
    = ObCommand_Init InitSource Bool
    | ObCommand_Deploy DeployCommand
    | ObCommand_Run
+   | ObCommand_Profile
    | ObCommand_Thunk ThunkCommand
    | ObCommand_Repl
    | ObCommand_Watch
@@ -108,6 +109,7 @@ obCommand cfg = hsubparser
     [ command "init" $ info (ObCommand_Init <$> initSource <*> initForce) $ progDesc "Initialize an Obelisk project"
     , command "deploy" $ info (ObCommand_Deploy <$> deployCommand cfg) $ progDesc "Prepare a deployment for an Obelisk project"
     , command "run" $ info (pure ObCommand_Run) $ progDesc "Run current project in development mode"
+    , command "profile" $ info (pure ObCommand_Profile) $ progDesc "Run current project with profiling enabled"
     , command "thunk" $ info (ObCommand_Thunk <$> thunkCommand) $ progDesc "Manipulate thunk directories"
     , command "repl" $ info (pure ObCommand_Repl) $ progDesc "Open an interactive interpreter"
     , command "watch" $ info (pure ObCommand_Watch) $ progDesc "Watch current project for errors and warnings"
@@ -365,7 +367,8 @@ ob = \case
         Just RemoteBuilder_ObeliskVM -> (:[]) <$> VmBuilder.getNixBuildersArg
     DeployCommand_Update -> deployUpdate "."
     DeployCommand_Test (platform, extraArgs) -> deployMobile platform extraArgs
-  ObCommand_Run -> run
+  ObCommand_Run -> run False
+  ObCommand_Profile -> run True
   ObCommand_Thunk tc -> case tc of
     ThunkCommand_Update thunks config -> for_ thunks (updateThunkToLatest config)
     ThunkCommand_Unpack thunks -> for_ thunks unpackThunk

lib/command/src/Obelisk/Command/Project.hs

@@ -5,6 +5,7 @@ module Obelisk.Command.Project
   ( InitSource (..)
   , findProjectObeliskCommand
   , findProjectRoot
+  , findProjectAssets
   , initProject
   , nixShellRunConfig
   , nixShellRunProc
@@ -50,7 +51,7 @@ import Obelisk.App (MonadObelisk)
 import Obelisk.CliApp
 import Obelisk.Command.Nix
 import Obelisk.Command.Thunk
-import Obelisk.Command.Utils (nixExePath)
+import Obelisk.Command.Utils (nixExePath, nixBuildExePath)
 
 --TODO: Make this module resilient to random exceptions
 
@@ -307,3 +308,24 @@ projectShell root isPure shellName command = do
     & nixShellConfig_common . nixCmdConfig_target . target_path ?~ "default.nix"
     & nixShellConfig_common . nixCmdConfig_target . target_attr ?~ ("shells." <> shellName)
   void $ liftIO $ waitForProcess ph
+
+findProjectAssets :: MonadObelisk m => FilePath -> m Text
+findProjectAssets root = do
+  let importableRoot = toNixPath root
+  isDerivation <- readProcessAndLogStderr Debug $
+    proc nixExePath
+      [ "eval"
+      , "(let a = import " <> importableRoot <> " {}; in toString (a.reflex.nixpkgs.lib.isDerivation a.passthru.staticFilesImpure))"
+      , "--raw"
+      -- `--raw` is not available with old nix-instantiate. It drops quotation
+      -- marks and trailing newline, so is very convenient for shelling out.
+      ]
+  -- Check whether the impure static files are a derivation (and so must be built)
+  if isDerivation == "1"
+    then fmap T.strip $ readProcessAndLogStderr Debug $ -- Strip whitespace here because nix-build has no --raw option
+      proc nixBuildExePath
+        [ "--no-out-link"
+        , "-E", "(import " <> importableRoot <> "{}).passthru.staticFilesImpure"
+        ]
+    else readProcessAndLogStderr Debug $
+      proc nixExePath ["eval", "-f", root, "passthru.staticFilesImpure", "--raw"]

lib/command/src/Obelisk/Command/Run.hs

@@ -22,6 +22,8 @@ import Data.Maybe
 import qualified Data.Set as Set
 import Data.Text (Text)
 import qualified Data.Text as T
+import Data.Time (getCurrentTime)
+import Data.Time.Format (formatTime, defaultTimeLocale)
 import Data.Traversable (for)
 import Debug.Trace (trace)
 import Distribution.Compiler (CompilerFlavor(..))
@@ -41,14 +43,17 @@ import Language.Haskell.Extension
 import Network.Socket hiding (Debug)
 import System.Directory
 import System.Environment (getExecutablePath)
+import System.Exit (ExitCode (ExitSuccess, ExitFailure))
 import System.FilePath
 import qualified System.Info
-import System.IO.Temp (withSystemTempDirectory)
+import System.IO (hPutStr, hFlush, hClose)
+import System.IO.Temp (withSystemTempDirectory, withSystemTempFile)
+import System.Process (waitForProcess)
 
 import Obelisk.App (MonadObelisk)
-import Obelisk.CliApp (Severity (..) , failWith, putLog, proc, readCreateProcessWithExitCode, readProcessAndLogStderr)
-import Obelisk.Command.Project (withProjectRoot, nixShellWithPkgs, toNixPath)
-import Obelisk.Command.Utils (findExePath, ghcidExePath, nixBuildExePath, nixExePath)
+import Obelisk.CliApp (Severity (..) , failWith, putLog, proc, readCreateProcessWithExitCode, setCwd, setDelegateCtlc, createProcess_)
+import Obelisk.Command.Project (withProjectRoot, nixShellWithPkgs, findProjectAssets)
+import Obelisk.Command.Utils (findExePath, ghcidExePath)
 
 data CabalPackageInfo = CabalPackageInfo
   { _cabalPackageInfo_packageFile :: FilePath
@@ -69,40 +74,63 @@ data CabalPackageInfo = CabalPackageInfo
 preprocessorIdentifier :: String
 preprocessorIdentifier = "__preprocessor-apply-packages"
 
-run :: MonadObelisk m => m ()
-run = withProjectRoot "." $ \root -> do
+-- | Imports needed to use Obelisk.Run
+obRunImports :: [String]
+obRunImports = [ "import qualified Obelisk.Run"
+               , "import qualified Frontend"
+               , "import qualified Backend" ]
+
+run
+  :: MonadObelisk m
+  => Bool
+  -- ^ Whether to enable profiling in the current project
+  -> m ()
+run profiled = withProjectRoot "." $ \root -> do
   pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
-  withGhciScript pkgs root $ \dotGhciPath -> do
-    freePort <- getFreePort
-    assets <- do
-      let importableRoot = toNixPath root
-      isDerivation <- readProcessAndLogStderr Debug $
-        proc nixExePath
-          [ "eval"
-          , "-f"
-          , root
-          , "(let a = import " <> importableRoot <> " {}; in toString (a.reflex.nixpkgs.lib.isDerivation a.passthru.staticFilesImpure))"
-          , "--raw"
-          -- `--raw` is not available with old nix-instantiate. It drops quotation
-          -- marks and trailing newline, so is very convenient for shelling out.
+  freePort <- getFreePort
+  assets <- findProjectAssets root
+  putLog Debug $ "Assets impurely loaded from: " <> assets
+  let obRunExpr = unwords
+          [ "Obelisk.Run.run"
+          , show freePort
+          , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
+          , "Backend.backend"
+          , "Frontend.frontend"
           ]
-      -- Check whether the impure static files are a derivation (and so must be built)
-      if isDerivation == "1"
-        then fmap T.strip $ readProcessAndLogStderr Debug $ -- Strip whitespace here because nix-build has no --raw option
-          proc nixBuildExePath
-            [ "--no-out-link"
-            , "-E", "(import " <> importableRoot <> "{}).passthru.staticFilesImpure"
-            ]
-        else readProcessAndLogStderr Debug $
-          proc nixExePath ["eval", "-f", root, "passthru.staticFilesImpure", "--raw"]
-    putLog Debug $ "Assets impurely loaded from: " <> assets
-    runGhcid root True dotGhciPath pkgs $ Just $ unwords
-      [ "Obelisk.Run.run"
-      , show freePort
-      , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
-      , "Backend.backend"
-      , "Frontend.frontend"
-      ]
+  case profiled of
+    True -> do
+      putLog Debug "Using profiled build of project."
+      time <- liftIO $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" <$> getCurrentTime
+      let exeSource =
+            unlines $
+              [ "module Main where"
+              , "import Control.Exception"
+              , "import Reflex.Profiled" ]
+              <> obRunImports <>
+              [ "main :: IO ()"
+              , "main = " <> obRunExpr <> " `finally` writeProfilingData \"" <> profileBaseName <> ".rprof\"" ]
+          -- Sane flags to enable by default, enable time profiling +
+          -- closure heap profiling.
+          rtsFlags = [ "+RTS", "-p", "-po" <> profileBaseName, "-hc", "-RTS" ]
+          profileDirectory = root </> "profile"
+          profileBaseName = profileDirectory </> time
+      liftIO $ createDirectoryIfMissing False profileDirectory
+      withSystemTempFile "ob-run-profiled.hs" $ \hsFname hsHandle -> withSystemTempFile "ob-run" $ \exeFname exeHandle -> do
+        liftIO $ hPutStr hsHandle exeSource
+        liftIO $ hFlush hsHandle
+        (_, _, _, ph1) <- createProcess_ "nixGhcWithProfiling" $ setCwd (Just root) $ proc "nix-shell" [ "-p", "((import ./. {}).profiled.ghc.ghcWithPackages (p: [ p.backend p.frontend]))", "--run", unwords [ "ghc", "-x", "hs", "-prof", "-fno-prof-auto", hsFname, "-o", exeFname ] ]
+        code <- liftIO $ waitForProcess ph1
+        case code of
+          ExitSuccess -> do
+            liftIO $ hClose exeHandle
+            (_, _, _, ph2) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc exeFname rtsFlags
+            _ <- liftIO $ waitForProcess ph2
+            pure ()
+          ExitFailure _ -> do
+            pure ()
+    False ->
+      withGhciScript pkgs root $ \dotGhciPath -> do
+        runGhcid root True dotGhciPath pkgs $ Just obRunExpr
 
 runRepl :: MonadObelisk m => m ()
 runRepl = withProjectRoot "." $ \root -> do
@@ -273,15 +301,12 @@ withGhciScript packageInfos pathBase f = do
       , [ "Backend" | "backend" `Set.member` packageNames ]
       , [ "Frontend" | "frontend" `Set.member` packageNames ]
       ]
-    dotGhci = unlines
+    dotGhci = unlines $
       -- TODO: Shell escape
       [ ":set -F -pgmF " <> selfExe <> " -optF " <> preprocessorIdentifier <> " " <> unwords (map (("-optF " <>) . makeRelative pathBase . _cabalPackageInfo_packageFile) packageInfos)
       , ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
       , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
-      , "import qualified Obelisk.Run"
-      , "import qualified Frontend"
-      , "import qualified Backend"
-      ]
+      ] <> obRunImports
   withSystemTempDirectory "ob-ghci" $ \fp -> do
     let dotGhciPath = fp </> ".ghci"
     liftIO $ writeFile dotGhciPath dotGhci

skeleton/.gitignore

@@ -6,3 +6,4 @@ result-ios
 result-exe
 .attr-cache
 ghcid-output.txt
+profile/