git.iko.soy/obelisk
on master help sign in
Move ob profile to own command
7a58b16Matthew Bauer
lib/command/src/Obelisk/Command.hs+2−2
compare with master
unifiedsplit
@@ -367,8 +367,8 @@ ob = \case
367 Just RemoteBuilder_ObeliskVM -> (:[]) <$> VmBuilder.getNixBuildersArg
367 Just RemoteBuilder_ObeliskVM -> (:[]) <$> VmBuilder.getNixBuildersArg
368 DeployCommand_Update -> deployUpdate "."
368 DeployCommand_Update -> deployUpdate "."
369 DeployCommand_Test (platform, extraArgs) -> deployMobile platform extraArgs
369 DeployCommand_Test (platform, extraArgs) -> deployMobile platform extraArgs
370− ObCommand_Run -> run False
370+ ObCommand_Run -> run
371− ObCommand_Profile -> run True
371+ ObCommand_Profile -> profile
372 ObCommand_Thunk tc -> case tc of
372 ObCommand_Thunk tc -> case tc of
373 ThunkCommand_Update thunks config -> for_ thunks (updateThunkToLatest config)
373 ThunkCommand_Update thunks config -> for_ thunks (updateThunkToLatest config)
374 ThunkCommand_Unpack thunks -> for_ thunks unpackThunk
374 ThunkCommand_Unpack thunks -> for_ thunks unpackThunk
lib/command/src/Obelisk/Command/Run.hs+48−38
@@ -80,12 +80,54 @@ obRunImports = [ "import qualified Obelisk.Run"
80 , "import qualified Frontend"
80 , "import qualified Frontend"
81 , "import qualified Backend" ]
81 , "import qualified Backend" ]
82
82
83+profile
84+ :: MonadObelisk m
85+ => m ()
86+profile = withProjectRoot "." $ \root -> do
87+ freePort <- getFreePort
88+ assets <- findProjectAssets root
89+ putLog Debug $ "Assets impurely loaded from: " <> assets
90+ let obRunExpr = unwords
91+ [ "Obelisk.Run.run"
92+ , show freePort
93+ , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
94+ , "Backend.backend"
95+ , "Frontend.frontend"
96+ ]
97+ putLog Debug "Using profiled build of project."
98+ time <- liftIO $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" <$> getCurrentTime
99+ let exeSource =
100+ unlines $
101+ [ "module Main where"
102+ , "import Control.Exception"
103+ , "import Reflex.Profiled" ]
104+ <> obRunImports <>
105+ [ "main :: IO ()"
106+ , "main = (" <> obRunExpr <> ") `finally` writeProfilingData \"" <> profileBaseName <> ".rprof\"" ]
107+ -- Sane flags to enable by default, enable time profiling +
108+ -- closure heap profiling.
109+ rtsFlags = [ "+RTS", "-p", "-po" <> profileBaseName, "-hc", "-RTS" ]
110+ profileDirectory = root </> "profile"
111+ profileBaseName = profileDirectory </> time
112+ liftIO $ createDirectoryIfMissing False profileDirectory
113+ withSystemTempFile "ob-run-profiled.hs" $ \hsFname hsHandle -> withSystemTempFile "ob-run" $ \exeFname exeHandle -> do
114+ liftIO $ hPutStr hsHandle exeSource
115+ liftIO $ hFlush hsHandle
116+ (_, _, _, 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 ] ]
117+ code <- liftIO $ waitForProcess ph1
118+ case code of
119+ ExitSuccess -> do
120+ liftIO $ hClose exeHandle
121+ (_, _, _, ph2) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc exeFname rtsFlags
122+ _ <- liftIO $ waitForProcess ph2
123+ pure ()
124+ ExitFailure _ -> do
125+ pure ()
126+
83run
127run
84 :: MonadObelisk m
128 :: MonadObelisk m
85− => Bool
86− -- ^ Whether to enable profiling in the current project
87− -> m ()
129+ => m ()
88−run profiled = withProjectRoot "." $ \root -> do
130+run = withProjectRoot "." $ \root -> do
89 pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
131 pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
90 freePort <- getFreePort
132 freePort <- getFreePort
91 assets <- findProjectAssets root
133 assets <- findProjectAssets root
@@ -97,40 +139,8 @@ run profiled = withProjectRoot "." $ \root -> do
97 , "Backend.backend"
139 , "Backend.backend"
98 , "Frontend.frontend"
140 , "Frontend.frontend"
99 ]
141 ]
100− case profiled of
101− True -> do
102− putLog Debug "Using profiled build of project."
103− time <- liftIO $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" <$> getCurrentTime
104− let exeSource =
105− unlines $
106− [ "module Main where"
107− , "import Control.Exception"
108− , "import Reflex.Profiled" ]
109− <> obRunImports <>
110− [ "main :: IO ()"
111− , "main = (" <> obRunExpr <> ") `finally` writeProfilingData \"" <> profileBaseName <> ".rprof\"" ]
112− -- Sane flags to enable by default, enable time profiling +
113− -- closure heap profiling.
114− rtsFlags = [ "+RTS", "-p", "-po" <> profileBaseName, "-hc", "-RTS" ]
115− profileDirectory = root </> "profile"
116− profileBaseName = profileDirectory </> time
117− liftIO $ createDirectoryIfMissing False profileDirectory
118− withSystemTempFile "ob-run-profiled.hs" $ \hsFname hsHandle -> withSystemTempFile "ob-run" $ \exeFname exeHandle -> do
119− liftIO $ hPutStr hsHandle exeSource
120− liftIO $ hFlush hsHandle
121− (_, _, _, 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 ] ]
122− code <- liftIO $ waitForProcess ph1
123− case code of
124− ExitSuccess -> do
125− liftIO $ hClose exeHandle
126− (_, _, _, ph2) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc exeFname rtsFlags
127− _ <- liftIO $ waitForProcess ph2
128− pure ()
129− ExitFailure _ -> do
130− pure ()
131− False ->
132− withGhciScript pkgs root $ \dotGhciPath -> do
142+ withGhciScript pkgs root $ \dotGhciPath -> do
133− runGhcid root True dotGhciPath pkgs $ Just obRunExpr
143+ runGhcid root True dotGhciPath pkgs $ Just obRunExpr
134
144
135runRepl :: MonadObelisk m => m ()
145runRepl :: MonadObelisk m => m ()
136runRepl = withProjectRoot "." $ \root -> do
146runRepl = withProjectRoot "." $ \root -> do