@@ -80,12 +80,54 @@ obRunImports = [ "import qualified Obelisk.Run"
8080 , "import qualified Frontend"
8181 , "import qualified Backend" ]
8282
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+
83127run
84128 :: MonadObelisk m
85− => Bool
86− -- ^ Whether to enable profiling in the current project
87− -> m ()
88−run profiled = withProjectRoot "." $ \root -> do
129+ => m ()
130+run = withProjectRoot "." $ \root -> do
89131 pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
90132 freePort <- getFreePort
91133 assets <- findProjectAssets root
@@ -97,40 +139,8 @@ run profiled = withProjectRoot "." $ \root -> do
97139 , "Backend.backend"
98140 , "Frontend.frontend"
99141 ]
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
133− runGhcid root True dotGhciPath pkgs $ Just obRunExpr
142+ withGhciScript pkgs root $ \dotGhciPath -> do
143+ runGhcid root True dotGhciPath pkgs $ Just obRunExpr
134144
135145runRepl :: MonadObelisk m => m ()
136146runRepl = withProjectRoot "." $ \root -> do