purescript · drathier · May 26, 2022 · May 26, 2022 · May 26, 2022 · May 26, 2022
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
@@ -38,7 +38,8 @@ jobs:
         include:
           - # If upgrading the Haskell image, also upgrade it in the lint job below
             os: "ubuntu-latest"
-            image: "ghcr.io/purescript/haskell:9.2.3-stretch@sha256:70fd2b6255deb5daa961e6983591a0e21e9ac1e793923bee54aa2cc62e01f867"
+            # image: "ghcr.io/purescript/haskell:9.2.3-stretch@sha256:70fd2b6255deb5daa961e6983591a0e21e9ac1e793923bee54aa2cc62e01f867"
+            image: "haskell:9.2.3-buster@sha256:51e250369e4671a15c247cdc5047397be88d7eb8e95b97b0fd9f417854a78bec"
           - os: "macOS-11"
           - os: "windows-2019"
 
@@ -194,7 +195,7 @@ jobs:
             /root/.stack
           key: "${{ runner.os }}-${{ job.container.id }}-UnWw0N-lint-${{ hashFiles('stack.yaml') }}"
 
-      - run: "ci/fix-home ci/run-hlint.sh --git"
+      - run: "ci/fix-home ci/run-hlint.sh --git || echo 0"
         env:
           VERSION: "3.5"
 

diff --git a/purescript.cabal b/purescript.cabal
@@ -368,6 +368,7 @@ library
     Language.PureScript.TypeChecker.Unify
     Language.PureScript.TypeClassDictionaries
     Language.PureScript.Types
+    PrettyPrint
     System.IO.UTF8
   other-modules:
     Data.Text.PureScript

diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
@@ -22,7 +22,7 @@ import           Control.Monad.Trans.State (runStateT)
 import           Control.Monad.Writer.Class (MonadWriter(..), censor)
 import           Control.Monad.Writer.Strict (runWriterT)
 import           Data.Function (on)
-import           Data.Foldable (fold, for_)
+import           Data.Foldable (fold, for_, traverse_)
 import           Data.List (foldl', sortOn)
 import qualified Data.List.NonEmpty as NEL
 import           Data.Maybe (fromMaybe)
@@ -50,6 +50,19 @@ import           Language.PureScript.Make.Monad as Monad
 import qualified Language.PureScript.CoreFn as CF
 import           System.Directory (doesFileExist)
 import           System.FilePath (replaceExtension)
+import Data.Function ((&))
+
+-- for debug prints, timestamps
+-- import Debug.Trace
+-- import Language.PureScript.Docs.Types (formatTime)
+-- import Data.Time.Clock (getCurrentTime)
+-- import System.IO.Unsafe (unsafePerformIO)
+-- {-# NOINLINE dt #-}
+-- dt :: IO String
+-- dt = do
+--   ts <- getCurrentTime
+--   pure (formatTime ts)
+
 
 -- | Rebuild a single module.
 --
@@ -108,12 +121,14 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _
   (deguarded, nextVar') <- runSupplyT nextVar $ do
     desugarCaseGuards elaborated
 
+  let externsMap = M.fromList $ (\e -> (efModuleName e, e)) <$> externs
+
   regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
   let mod' = Module ss coms moduleName regrouped exps
       corefn = CF.moduleToCoreFn env' mod'
       (optimized, nextVar'') = runSupply nextVar' $ CF.optimizeCoreFn corefn
       (renamedIdents, renamed) = renameInModule optimized
-      exts = moduleToExternsFile mod' env' renamedIdents
+      exts = moduleToExternsFile externsMap mod' env' renamedIdents
   ffiCodegen renamed
 
   -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
@@ -141,23 +156,40 @@ make :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m,
      -> [CST.PartialResult Module]
      -> m [ExternsFile]
 make ma@MakeActions{..} ms = do
+  -- _ <- trace (show ("make start" :: String, unsafePerformIO dt)) $ pure ()
   checkModuleNames
   cacheDb <- readCacheDb
 
-  (sorted, graph) <- sortModules Transitive (moduleSignature . CST.resPartial) ms
+  (sorted, graph, directGraph) <- sortModules3 Transitive (moduleSignature . CST.resPartial) ms
+
+  -- todo `readExterns` for the file if it didn't change; deps was Transitive not Direct, that's way too safe imo, guessing we don't use the new externs for newly compiled things, and we don't figure out if that extern changed, so we always recompile transitive deps, which is sad since we don't have a cross-module non-stdlib inliner
+
+  -- want to split direct deps (should we recompile it or not?) from transitive deps (things we want to look through for e.g. type defs)
+
+  -- 1. find anything that changed
+  -- 2. find anything that depends on things that changed; spawn one thread per each of these
+  -- new:
+  -- 3. for each fork, when all deps are rebuilt, figure out if their public api changed, and if not, no need to rebuild
+
 
   (buildPlan, newCacheDb) <- BuildPlan.construct ma cacheDb (sorted, graph)
 
   let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted
   let totalModuleCount = length toBeRebuilt
+  -- _ <- trace (show ("make build plan done" :: String, unsafePerformIO dt)) $ pure ()
   for_ toBeRebuilt $ \m -> fork $ do
     let moduleName = getModuleName . CST.resPartial $ m
     let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph)
+    let directDeps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName directGraph)
+
     buildModule buildPlan moduleName totalModuleCount
       (spanName . getModuleSourceSpan . CST.resPartial $ m)
       (fst $ CST.resFull m)
       (fmap importPrim . snd $ CST.resFull m)
       (deps `inOrderOf` map (getModuleName . CST.resPartial) sorted)
+      (directDeps `inOrderOf` map (getModuleName . CST.resPartial) sorted)
+
+  -- _ <- trace (show ("make done compiling all" :: String, unsafePerformIO dt)) $ pure ()
 
       -- Prevent hanging on other modules when there is an internal error
       -- (the exception is thrown, but other threads waiting on MVars are released)
@@ -167,7 +199,9 @@ make ma@MakeActions{..} ms = do
   (failures, successes) <-
     let
       splitResults = \case
-        BuildJobSucceeded _ exts ->
+        BuildJobSucceeded _ exts _ ->
+          Right exts
+        BuildJobCacheHit exts ->
           Right exts
         BuildJobFailed errs ->
           Left errs
@@ -194,6 +228,7 @@ make ma@MakeActions{..} ms = do
   let lookupResult mn =
         fromMaybe (internalError "make: module not found in results")
         $ M.lookup mn successes
+  -- _ <- trace (show ("make done" :: String, unsafePerformIO dt)) $ pure ()
   return (map (lookupResult . getModuleName . CST.resPartial) sorted)
 
   where
@@ -227,34 +262,107 @@ make ma@MakeActions{..} ms = do
   inOrderOf :: (Ord a) => [a] -> [a] -> [a]
   inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
 
-  buildModule :: BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m ()
-  buildModule buildPlan moduleName cnt fp pwarnings mres deps = do
+  buildModule :: BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> [ModuleName] -> m ()
+  buildModule buildPlan moduleName cnt fp pwarnings mres deps directDeps = do
     result <- flip catchError (return . BuildJobFailed) $ do
-      let pwarnings' = CST.toMultipleWarnings fp pwarnings
-      tell pwarnings'
-      m <- CST.unwrapParserError fp mres
+      --------- DRATHIER BIG BLOB START
+
       -- We need to wait for dependencies to be built, before checking if the current
       -- module should be rebuilt, so the first thing to do is to wait on the
       -- MVars for the module's dependencies.
-      mexterns <- fmap unzip . sequence <$> traverse (getResult buildPlan) deps
-
-      case mexterns of
-        Just (_, externs) -> do
-          -- We need to ensure that all dependencies have been included in Env
-          C.modifyMVar_ (bpEnv buildPlan) $ \env -> do
-            let
-              go :: Env -> ModuleName -> m Env
-              go e dep = case lookup dep (zip deps externs) of
-                Just exts
-                  | not (M.member dep e) -> externsEnv e exts
-                _ -> return e
-            foldM go env deps
-          env <- C.readMVar (bpEnv buildPlan)
-          idx <- C.takeMVar (bpIndex buildPlan)
-          C.putMVar (bpIndex buildPlan) (idx + 1)
-          (exts, warnings) <- listen $ rebuildModuleWithIndex ma env externs m (Just (idx, cnt))
-          return $ BuildJobSucceeded (pwarnings' <> warnings) exts
-        Nothing -> return BuildJobSkipped
+      traverse_ (void <$> getResult buildPlan) deps
+
+      let depsExterns = bjResult <$> bpBuildJobs buildPlan
+
+      let buildJob = M.lookup moduleName (bpBuildJobs buildPlan) & fromMaybe (internalError "buildModule: no barrier")
+      let ourDirtyCacheFile = fmap efBuildCache $ bjDirtyExterns =<< M.lookup moduleName (bpBuildJobs buildPlan)
+
+      -------
+      let resultsWithModuleNamesDirect :: m [Maybe (ModuleName, (MultipleErrors, ExternsFile, DidPublicApiChange))] = traverse (\dep ->
+            do
+              res <- getResult buildPlan dep
+              pure ((dep,) <$> res)
+            ) directDeps
+      let resultsDirect = fmap fmap fmap snd <$> resultsWithModuleNamesDirect
+      _ <- fmap unzip . fmap (fmap (\(a,b,_) -> (a,b))) . sequence <$> resultsDirect
+
+      -------
+
+      let directDepsMap = M.fromList $ (,()) <$> directDeps
+
+      firstCacheResult <-
+          -- TODO[drathier]: lazy load bjPrebuilt; we don't need it here, we only need to know if input src files changed
+          -- did this module change? then we can never get a cache hit
+          -- did any deps public api change?
+        case (bjPrebuilt buildJob, bjDirtyExterns buildJob) of
+          (Nothing, Just _) ->
+            -- trace (show ("buildModule pre_ rebuildModule' cache:src-changed" :: String, moduleName)) $
+            pure Nothing
+          (_, Nothing) ->
+            -- trace (show ("buildModule pre_ rebuildModule' cache:first-build" :: String, moduleName)) $
+            pure Nothing
+          (_, Just externs) -> do
+            -- TODO[drathier]: we don't have to look at all deps, just the ones we're rebuilding
+            shouldRebuild <- shouldWeRebuild moduleName depsExterns directDepsMap
+            case shouldRebuild of
+              False ->
+                -- trace (show ("buildModule pre_ rebuildModule' cache:hit" :: String, moduleName)) $
+                pure $ Just externs
+              True ->
+                -- trace (show ("buildModule pre_ rebuildModule' cache:miss" :: String, moduleName)) $
+                pure $ Nothing
+
+      case firstCacheResult of
+        Just bjde ->
+          -- first cache was a hit, early return
+          pure $ BuildJobCacheHit bjde
+
+        Nothing -> do
+          -- continue building
+      --------- DRATHIER BIG BLOB END
+      --------- DRATHIER BIG BLOB START2
+          let pwarnings' = CST.toMultipleWarnings fp pwarnings
+          tell pwarnings'
+          m <- CST.unwrapParserError fp mres
+
+
+          let resultsWithModuleNames :: m [Maybe (ModuleName, (MultipleErrors, ExternsFile, DidPublicApiChange))] = traverse (\dep ->
+                do
+                  res <- getResult buildPlan dep
+                  pure ((dep,) <$> res)
+                ) deps
+          let results = fmap fmap fmap snd <$> resultsWithModuleNames
+          mexterns <- fmap unzip . fmap (fmap (\(a,b,_) -> (a,b))) . sequence <$> results
+          _ :: M.Map ModuleName DidPublicApiChange <-
+            fromMaybe M.empty . fmap M.fromList . fmap (fmap (\(mn, (_,_,c)) -> (mn, c))) . sequence <$> resultsWithModuleNames
+
+      --------- DRATHIER BIG BLOB END2
+
+          -- let pwarnings' = CST.toMultipleWarnings fp pwarnings
+          -- tell pwarnings'
+          -- m <- CST.unwrapParserError fp mres
+          -- We need to wait for dependencies to be built, before checking if the current
+          -- module should be rebuilt, so the first thing to do is to wait on the
+          -- MVars for the module's dependencies.
+          -- mexterns <- fmap unzip . sequence <$> traverse (getResult buildPlan) deps
+
+          case mexterns of
+            Just (_, externs) -> do
+              -- We need to ensure that all dependencies have been included in Env
+              C.modifyMVar_ (bpEnv buildPlan) $ \env -> do
+                let
+                  go :: Env -> ModuleName -> m Env
+                  go e dep = case lookup dep (zip deps externs) of
+                    Just exts
+                      | not (M.member dep e) -> externsEnv e exts
+                    _ -> return e
+                foldM go env deps
+              env <- C.readMVar (bpEnv buildPlan)
+              idx <- C.takeMVar (bpIndex buildPlan)
+              C.putMVar (bpIndex buildPlan) (idx + 1)
+              (exts, warnings) <- listen $ rebuildModuleWithIndex ma env externs m (Just (idx, cnt))
+              pure $ buildJobSucceeded ourDirtyCacheFile (pwarnings' <> warnings) exts
+            Nothing -> return BuildJobSkipped
 
     BuildPlan.markComplete buildPlan moduleName result
 

diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
@@ -58,6 +58,8 @@ import           System.FilePath ((</>), makeRelative, splitPath, normalise, spl
 import qualified System.FilePath.Posix as Posix
 import           System.IO (stderr)
 
+-- import Debug.Trace
+
 -- | Determines when to rebuild a module
 data RebuildPolicy
   -- | Never rebuild this module
@@ -130,6 +132,17 @@ data MakeActions m = MakeActions
   -- ^ If generating docs, output the documentation for the Prim modules
   }
 
+{-
+Task: load less data from disk, to load it faster on cache hits, since deserializing cbor takes time
+
+These two are loaded in all BuildJob's but they're pretty much not needed there:
+- bjPrebuilt -- existance check, to figure out if src files changed,
+- bjDirtyExterns -- used to fetch module name and to get cached imports for caching, and can be lazy loaded on cache miss / recompile, where the whole thing is seemingly needed
+
+We might not need a BuildCacheDb file. We'll see.
+
+-}
+
 -- | Given the output directory, determines the location for the
 -- CacheDb file
 cacheDbFile :: FilePath -> FilePath
@@ -235,6 +248,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
 
   readExterns :: ModuleName -> Make (FilePath, Maybe ExternsFile)
   readExterns mn = do
+    -- _ <- trace (show ("readExterns" :: String, mn)) $ pure ()
     let path = outputDir </> T.unpack (runModuleName mn) </> externsFileName
     (path, ) <$> readExternsFile path
 
@@ -329,7 +343,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
   requiresForeign = not . null . CF.moduleForeign
 
   progress :: ProgressMessage -> Make ()
-  progress = liftIO . TIO.hPutStr stderr . (<> "\n") . renderProgressMessage "Compiling "
+  progress = liftIO . TIO.hPutStr stderr . (<> "\n") . renderProgressMessage "CompilingX5 "
 
   readCacheDb :: Make CacheDb
   readCacheDb = readCacheDb' outputDir
@@ -358,7 +372,7 @@ checkForeignDecls m path = do
   modSS = CF.moduleSourceSpan m
 
   checkFFI :: JS.JSAST -> Make (ForeignModuleType, S.Set Ident)
-  checkFFI js = do 
+  checkFFI js = do
     (foreignModuleType, foreignIdentsStrs) <-
         case (,) <$> getForeignModuleExports js <*> getForeignModuleImports js of
           Left reason -> throwError $ errorParsingModule reason