diff --git a/purescript.cabal b/purescript.cabal index bf438578c1..45a1fb546d 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -155,6 +155,7 @@ common defaults -- specific version. aeson >=2.0.3.0 && <2.2, aeson-better-errors >=0.9.1.3 && <0.10, + async >=2.2.4 && <2.3, ansi-terminal >=0.11.3 && <1.1, array >=0.5.4.0 && <0.6, base >=4.16.2.0 && <4.19, @@ -166,9 +167,8 @@ common defaults cborg >=0.2.7.0 && <0.3, cheapskate >=0.1.1.2 && <0.2, clock >=0.8.3 && <0.9, + constraints-extras >=0.4.0 && <0.5, containers >=0.6.5.1 && <0.7, - -- unordered-containers, - -- hashable, cryptonite ==0.30.*, data-ordlist >=0.4.7.0 && <0.5, deepseq >=1.4.6.1 && <1.5, @@ -178,6 +178,7 @@ common defaults file-embed >=0.0.15.0 && <0.1, filepath >=1.4.2.2 && <1.5, Glob >=0.10.2 && <0.11, + hashable >=1.4.3 && <1.5, haskeline ==0.8.2, language-javascript ==0.7.0.0, lens >=5.1.1 && <5.3, @@ -193,11 +194,13 @@ common defaults process >=1.6.19.0 && <1.7, protolude >=0.3.1 && <0.4, regex-tdfa >=1.3.1.2 && <1.4, + rock, safe >=0.3.19 && <0.4, scientific >=0.3.7.0 && <0.4, semialign >=1.2.0.1 && <1.4, semigroups ==0.20.*, serialise >=0.2.5.0 && <0.3, + some >=1.0.4 && <1.1, sourcemap >=0.1.7 && <0.2, stm >=2.5.0.2 && <2.6, stringsearch >=0.3.6.6 && <0.4, @@ -340,6 +343,9 @@ library Language.PureScript.Make.Cache Language.PureScript.Make.ExternsDiff Language.PureScript.Make.Monad + Language.PureScript.Make.Query + Language.PureScript.Make.Rules + Language.PureScript.Make.Traces Language.PureScript.ModuleDependencies Language.PureScript.Names Language.PureScript.Options diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 8da8a90d73..4da133f02c 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -10,45 +10,39 @@ module Language.PureScript.Make import Prelude -import Control.Concurrent.Lifted as C -import Control.DeepSeq (force) -import Control.Exception.Lifted (onException, bracket_, evaluate) -import Control.Monad (foldM, unless, void, when, (<=<)) -import Control.Monad.Base (MonadBase(liftBase)) +import Control.Concurrent.Async (forConcurrently) +import Control.Exception (SomeException, fromException, throwIO, try) +import Control.Monad (foldM, void, when) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Reader (ask) import Control.Monad.Supply (evalSupplyT, runSupply, runSupplyT) -import Control.Monad.Trans.Control (MonadBaseControl(..)) 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.IORef (newIORef, readIORef) import Data.List (foldl', sortOn) +import Data.Maybe (isJust, mapMaybe) import Data.List.NonEmpty qualified as NEL -import Data.Maybe (fromMaybe, mapMaybe) import Data.Map qualified as M import Data.Set qualified as S import Data.Text qualified as T -import Debug.Trace (traceMarkerIO) -import Language.PureScript.AST (ErrorMessageHint(..), Module(..), SourceSpan(..), getModuleName, getModuleSourceSpan, importPrim) +import Language.PureScript.AST (ErrorMessageHint(..), Module(..), getModuleName, getModuleSourceSpan, importPrim) import Language.PureScript.Crash (internalError) import Language.PureScript.CST qualified as CST import Language.PureScript.Docs.Convert qualified as Docs import Language.PureScript.Environment (initEnvironment) -import Language.PureScript.Errors (MultipleErrors(..), SimpleErrorMessage(..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors) +import Language.PureScript.Errors (MultipleErrors(..), SimpleErrorMessage(..), addHint, defaultPPEOptions, errorMessage', errorMessage'', errorModule, prettyPrintMultipleErrors) import Language.PureScript.Externs (ExternsFile, applyExternsFileToEnvironment, moduleToExternsFile) import Language.PureScript.Linter (Name(..), lint, lintImports) -import Language.PureScript.ModuleDependencies (DependencyDepth(..), moduleSignature, sortModules) import Language.PureScript.Names (ModuleName(..), isBuiltinModuleName, runModuleName) import Language.PureScript.Renamer (renameInModule) import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv) import Language.PureScript.TypeChecker (CheckState(..), emptyCheckState, typeCheckModule) -import Language.PureScript.Make.BuildPlan (BuildJobResult(..), BuildPlan(..), getResult, isUpToDate) -import Language.PureScript.Make.BuildPlan qualified as BuildPlan -import Language.PureScript.Make.ExternsDiff (checkDiffs, emptyDiff, diffExterns) -import Language.PureScript.Make.Cache qualified as Cache import Language.PureScript.Make.Actions as Actions +import Language.PureScript.Make.Cache qualified as Cache import Language.PureScript.Make.Monad as Monad ( Make(..), writeTextFile, @@ -69,9 +63,14 @@ import Language.PureScript.Make.Monad as Monad getTimestamp, getCurrentTime, copyFile ) +import Language.PureScript.Options (Options) +import Language.PureScript.Make.Query (Query(..)) +import Language.PureScript.Make.Rules (makeRules, MakeError(..)) +import Language.PureScript.Make.Traces qualified as Traces import Language.PureScript.CoreFn qualified as CF -import System.Directory (doesFileExist) -import System.FilePath (replaceExtension) +import Rock qualified +import System.Directory (doesFileExist, getCurrentDirectory) +import System.FilePath (replaceExtension, ()) import Language.PureScript.TypeChecker.Monad (liftTypeCheckM) -- | Rebuild a single module. @@ -145,7 +144,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ -- a bug in the compiler, which should be reported as such. -- 2. We do not want to perform any extra work generating docs unless the -- user has asked for docs to be generated. - let docs = case Docs.convertModule externs exEnv env' m of + let docs = case Docs.convertModule externs exEnv env' withPrim of Left errs -> internalError $ "Failed to produce docs for " ++ T.unpack (runModuleName moduleName) ++ "; details:\n" ++ prettyPrintMultipleErrors defaultPPEOptions errs @@ -154,114 +153,127 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _ evalSupplyT nextVar'' $ codegen renamed docs exts return exts -data MakeOptions = MakeOptions - { moCollectAllExterns :: Bool - } - --- | Compiles in "make" mode, compiling each module separately to a @.js@ file --- and an @externs.cbor@ file. --- --- If timestamps or hashes have not changed, existing externs files can be used --- to provide upstream modules' types without having to typecheck those modules --- again. --- --- It collects and returns externs for all modules passed. -make :: forall m. (MonadIO m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => MakeActions m - -> [CST.PartialResult Module] - -> m [ExternsFile] -make = make' (MakeOptions {moCollectAllExterns = True}) - --- | Compiles in "make" mode, compiling each module separately to a @.js@ file --- and an @externs.cbor@ file. +-- | Compiles in "make" mode using rock for demand-driven incremental compilation. +-- Each module is compiled separately to a @.js@ file and an @externs.cbor@ file. +-- Rock automatically memoizes query results within a build to avoid redundant work. -- --- This version of make returns nothing. -make_ :: forall m. (MonadIO m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => MakeActions m - -> [CST.PartialResult Module] - -> m () -make_ ma ms = void $ make' (MakeOptions {moCollectAllExterns = False}) ma ms - -make' :: forall m. (MonadIO m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => MakeOptions - -> MakeActions m +-- It collects and returns externs for all modules passed, in topological order. +make :: MakeActions Make -> [CST.PartialResult Module] - -> m [ExternsFile] -make' MakeOptions{..} ma@MakeActions{..} ms = do - checkModuleNames + -> Make [ExternsFile] +make ma ms = makeIncremental ma ms + +-- | Like 'make' but discards the result. +-- Uses a fast path to skip the rock pipeline when all modules are cached. +make_ :: MakeActions Make + -> [CST.PartialResult Module] + -> Make () +make_ ma@MakeActions{..} ms = do + -- Fast path: if all modules are cached, skip rock entirely. + -- This avoids the overhead of dependency resolution, memoization, + -- and reading externs from disk when nothing needs to compile. + opts <- ask cacheDb <- readCacheDb + let moduleNames = map (getModuleName . CST.resPartial) ms + let currentModules = S.fromList moduleNames + let graphFile = getOutputDir "module-graph.json" + cachedGraph <- liftIO $ Traces.readCachedGraph graphFile cacheDb currentModules + case cachedGraph of + Just _ -> do + allCached <- liftIO $ allModulesCached opts ma cacheDb moduleNames + if allCached then do + writeCacheDb cacheDb + writePackageJson + outputPrimDocs + else void $ makeIncremental ma ms + Nothing -> void $ makeIncremental ma ms + +-- | Rock-based incremental compilation. +-- Defines queries for each compilation phase and lets rock handle +-- memoization and dependency tracking. +makeIncremental + :: MakeActions Make + -> [CST.PartialResult Module] + -> Make [ExternsFile] +makeIncremental ma@MakeActions{..} ms = do + -- Validate module names (no Prim redefinitions, no duplicates) + checkModuleNames - (sorted, graph) <- sortModules Transitive (moduleSignature . CST.resPartial) ms - let opts = BuildPlan.Options {optPreloadAllExterns = moCollectAllExterns} - (buildPlan, newCacheDb) <- BuildPlan.construct opts ma cacheDb (sorted, graph) - - -- Limit concurrent module builds to the number of capabilities as - -- (by default) inferred from `+RTS -N -RTS` or set explicitly like `-N4`. - -- This is to ensure that modules complete fully before moving on, to avoid - -- holding excess memory during compilation from modules that were paused - -- by the Haskell runtime. - capabilities <- getNumCapabilities - let concurrency = max 1 capabilities - lock <- C.newQSem concurrency - - let sortedModuleNames = getModuleName . CST.resPartial <$> sorted - let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted - let totalModuleCount = length toBeRebuilt - 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) - buildModule lock buildPlan moduleName totalModuleCount - (spanName . getModuleSourceSpan . CST.resPartial $ m) - (fst $ CST.resFull m) - (fmap importPrim . snd $ CST.resFull m) - (deps `inOrderOf` sortedModuleNames) - - -- Prevent hanging on other modules when there is an internal error - -- (the exception is thrown, but other threads waiting on MVars are released) - `onException` BuildPlan.markComplete buildPlan moduleName (BuildJobFailed mempty) - - -- Wait for all threads to complete, and collect results (and errors). - (failures, successes) <- - let - splitResults = \case - BuildJobSucceeded _ exts _ -> - Right exts - BuildJobFailed errs -> - Left errs - BuildJobSkipped -> - Left mempty - in - M.mapEither splitResults <$> BuildPlan.collectResults buildPlan - - -- Write the updated build cache database to disk - writeCacheDb $ Cache.removeModules (M.keysSet failures) newCacheDb - - writePackageJson + -- Get compiler options from the Make monad's Reader environment + opts <- ask - -- If generating docs, also generate them for the Prim modules - outputPrimDocs - -- All threads have completed, rethrow any caught errors. - let errors = M.elems failures - unless (null errors) $ throwError (mconcat errors) + -- Build the module map for the rules to close over + let moduleMap = M.fromList + [ (getModuleName (CST.resPartial pr), pr) | pr <- ms ] - -- Here we return all the ExternsFile in the ordering of the topological sort, - -- so they can be folded into an Environment. This result is used in the tests - -- and in PSCI. - let lookupResult mn@(ModuleName name) = - fromMaybe (internalError $ "make: module not found in results: " <> T.unpack name) - $ M.lookup mn successes + -- Read cache database for incremental build support + cacheDb <- readCacheDb - pure $ - if moCollectAllExterns then - map lookupResult sortedModuleNames - else - mapMaybe (flip M.lookup successes) sortedModuleNames + -- Try to load cached module graph from previous build. + -- If valid (all input hashes match), we skip the expensive sortModules call. + let graphFile = getOutputDir "module-graph.json" + let currentModules = S.fromList $ M.keys moduleMap + cachedGraph <- liftIO $ Traces.readCachedGraph graphFile cacheDb currentModules + + -- IORefs for state accumulated during the rock build + warningsRef <- liftIO $ newIORef mempty + memoVar <- liftIO $ newIORef mempty + diffsRef <- liftIO $ newIORef M.empty + sharedEnvRef <- liftIO $ newIORef primEnv + newCacheDbRef <- liftIO $ newIORef cacheDb + timestampsRef <- liftIO $ newIORef M.empty + compiledRef <- liftIO $ newIORef S.empty + -- Captured graph data for persistence + graphRef <- liftIO $ newIORef (Nothing :: Maybe ([ModuleName], [(ModuleName, [ModuleName])])) + + let compileFn = rebuildModule' ma + + let rules :: Rock.Rules Query + rules = Rock.memoise memoVar + $ makeRules moduleMap opts ma warningsRef compileFn cacheDb diffsRef sharedEnvRef newCacheDbRef timestampsRef compiledRef cachedGraph graphRef + + -- Run the rock task: sort modules, then compile all in parallel. + -- Rock's memoise handles synchronization: if module B depends on A, + -- B's thread blocks on A's MVar until A completes. This gives us + -- natural parallelism bounded by the dependency graph. + let rockTask = Rock.runTask rules $ do + sorted <- Rock.fetch SortedModules + liftIO $ forConcurrently sorted $ \mn -> + Rock.runTask rules $ Rock.fetch (CompileModule mn) + result <- liftIO (try rockTask) :: Make (Either SomeException [ExternsFile]) + + -- Collect warnings accumulated during rock execution and emit them + extraWarnings <- liftIO $ readIORef warningsRef + tell extraWarnings + + case result of + Left exc + | Just (MakeError errs) <- fromException exc -> do + -- On failure, remove ONLY the failed modules from CacheDb. + newCacheDb <- liftIO $ readIORef newCacheDbRef + let failedModules = S.fromList $ mapMaybe errorModule (runMultipleErrors errs) + writeCacheDb $ Cache.removeModules failedModules newCacheDb + throwError errs + | otherwise -> liftIO $ throwIO exc + Right externs -> do + -- Write updated cache database + newCacheDb <- liftIO $ readIORef newCacheDbRef + writeCacheDb newCacheDb + -- Save module graph for next build + mbGraph <- liftIO $ readIORef graphRef + case mbGraph of + Just (sorted, graph) -> + liftIO $ Traces.writeCachedGraph graphFile sorted graph newCacheDb + Nothing -> pure () + writePackageJson + outputPrimDocs + pure externs where - checkModuleNames :: m () + checkModuleNames :: Make () checkModuleNames = checkNoPrim *> checkModuleNamesAreUnique - checkNoPrim :: m () + checkNoPrim :: Make () checkNoPrim = for_ ms $ \m -> let mn = getModuleName $ CST.resPartial m @@ -270,7 +282,7 @@ make' MakeOptions{..} ma@MakeActions{..} ms = do . errorMessage' (getModuleSourceSpan $ CST.resPartial m) $ CannotDefinePrimModules mn - checkModuleNamesAreUnique :: m () + checkModuleNamesAreUnique :: Make () checkModuleNamesAreUnique = for_ (findDuplicates (getModuleName . CST.resPartial) ms) $ \mss -> throwError . flip foldMap mss $ \ms' -> @@ -284,87 +296,36 @@ make' MakeOptions{..} ma@MakeActions{..} ms = do [] -> Nothing xss -> Just xss - -- Sort a list so its elements appear in the same order as in another list. - inOrderOf :: (Ord a) => [a] -> [a] -> [a] - inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys - - buildModule :: QSem -> BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m () - buildModule lock buildPlan moduleName cnt fp pwarnings mres deps = do - result <- flip catchError (return . BuildJobFailed) $ do - 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 (_, depsDiffExterns) -> do - let externs = fst <$> depsDiffExterns - let prevResult = BuildPlan.getPrevResult buildPlan moduleName - let depsDiffs = traverse snd depsDiffExterns - let maySkipBuild moduleIndex - -- We may skip built only for up-to-date modules. - | Just (status, exts) <- prevResult - , isUpToDate status - -- Check if no dep's externs have changed. If any of the diffs - -- is Nothing means we can not check and need to rebuild. - , Just False <- checkDiffs m <$> depsDiffs = do - -- We should update modification times to mark existing - -- compilation results as actual. If it fails to update timestamp - -- on any of exiting codegen targets, it will run the build process. - updated <- updateOutputTimestamp moduleName - if updated then do - progress $ SkippingModule moduleName moduleIndex - pure $ Just (exts, MultipleErrors [], Just (emptyDiff moduleName)) - else - pure Nothing - | otherwise = pure Nothing - - -- 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, diff) <- do - let doBuild = do - -- Bracket all of the per-module work behind the semaphore, including - -- forcing the result. This is done to limit concurrency and keep - -- memory usage down; see comments above. - (exts, warnings) <- bracket_ (C.waitQSem lock) (C.signalQSem lock) $ do - -- Eventlog markers for profiling; see debug/eventlog.js - liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " start" - -- Force the externs and warnings to avoid retaining excess module - -- data after the module is finished compiling. - extsAndWarnings <- evaluate . force <=< listen $ do - rebuildModuleWithIndex ma env externs m (Just (idx, cnt)) - liftBase $ traceMarkerIO $ T.unpack (runModuleName moduleName) <> " end" - return extsAndWarnings - let diff = diffExterns exts <$> (snd <$> prevResult) <*> depsDiffs - pure (exts, warnings, diff) - maySkipBuild (Just (idx, cnt)) >>= maybe doBuild pure - return $ BuildJobSucceeded (pwarnings' <> warnings) exts diff - - -- If we got Nothing for deps externs, that means one of the deps failed - -- to compile. Though if we have a previous built result we will keep to - -- avoid potentially unnecessary recompilation next time. - Nothing -> return $ - case BuildPlan.getPrevResult buildPlan moduleName of - Just (_, exts) -> - BuildJobSucceeded (MultipleErrors []) exts (Just (emptyDiff moduleName)) - Nothing -> - BuildJobSkipped - - BuildPlan.markComplete buildPlan moduleName result +-- | Quick check: are all modules cached? Checks timestamps + hashes against +-- CacheDb and verifies output exists. No externs are read. +-- Runs all checks concurrently for speed. +allModulesCached + :: Options + -> MakeActions Make + -> Cache.CacheDb + -> [ModuleName] + -> IO Bool +allModulesCached opts MakeActions{..} cacheDb moduleNames = do + cwd <- getCurrentDirectory + results <- forConcurrently moduleNames $ \mn -> do + (result, _) <- runMake opts $ do + inputInfo <- getInputTimestampsAndHashes mn + case inputInfo of + Left RebuildAlways -> pure False + Left RebuildNever -> do + -- Assume RebuildNever modules are always up to date + outputTs <- getOutputTimestamp mn + pure (isJust outputTs) + Right timestamps -> do + (_, upToDate) <- Cache.checkChanged cacheDb mn cwd timestamps + if upToDate then do + outputTs <- getOutputTimestamp mn + pure (isJust outputTs) + else pure False + pure $ case result of + Right True -> True + _ -> False + pure (and results) -- | Infer the module name for a module by looking for the same filename with -- a .js extension. diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index 26e5fcccce..063930dacc 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -142,6 +142,8 @@ data MakeActions m = MakeActions -- load .js files as ES modules. , outputPrimDocs :: m () -- ^ If generating docs, output the documentation for the Prim modules + , getOutputDir :: FilePath + -- ^ The output directory path (for auxiliary cache files) } -- | Given the output directory, determines the location for the @@ -203,6 +205,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = writeCacheDb writePackageJson outputPrimDocs + outputDir where getInputTimestampsAndHashes diff --git a/src/Language/PureScript/Make/Query.hs b/src/Language/PureScript/Make/Query.hs new file mode 100644 index 0000000000..6845824efe --- /dev/null +++ b/src/Language/PureScript/Make/Query.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Language.PureScript.Make.Query + ( Query(..) + ) where + +import Prelude + +import Data.Constraint.Extras.TH (deriveArgDict) +import Data.GADT.Compare (GEq(..), GCompare(..), GOrdering(..)) +import Data.GADT.Show (GShow(..)) +import Data.Hashable (Hashable(..)) +import Data.Map qualified as M +import Data.Some (Some(..)) +import Data.Type.Equality ((:~:)(..)) + +import Language.PureScript.AST (Module) +import Language.PureScript.Environment (Environment) +import Language.PureScript.Externs (ExternsFile) +import Language.PureScript.Names (ModuleName(..)) +import Language.PureScript.Sugar.Names.Env (Env) + +-- | Queries for the rock-based incremental compilation pipeline. +-- +-- Each constructor represents a computation that can depend on other queries +-- via @fetch@. Rock automatically tracks these dependencies for memoization +-- and incremental recomputation. +data Query a where + -- | Input query: the pre-parsed module provided by the caller. + -- In rock's verifyTraces, this would be marked as 'Input' (can change between builds). + InputModule :: ModuleName -> Query Module + + -- | Dependency graph: maps each module to its (transitively) sorted dependencies. + ModuleGraph :: Query (M.Map ModuleName [ModuleName]) + + -- | Sorted module names in topological order (leaves first). + SortedModules :: Query [ModuleName] + + -- | Build the sugar names Env for a module from its dependencies' externs. + ModuleSugarEnv :: ModuleName -> Query Env + + -- | Build the typechecker Environment from dependency externs. + ModuleTypeEnv :: ModuleName -> Query Environment + + -- | Full per-module compilation: desugar, typecheck, corefn, codegen. + -- Returns the module's ExternsFile. + CompileModule :: ModuleName -> Query ExternsFile + +deriving instance Show (Query a) + +instance Eq (Query a) where + InputModule a == InputModule b = a == b + ModuleGraph == ModuleGraph = True + SortedModules == SortedModules = True + ModuleSugarEnv a == ModuleSugarEnv b = a == b + ModuleTypeEnv a == ModuleTypeEnv b = a == b + CompileModule a == CompileModule b = a == b + +instance GShow Query where + gshowsPrec = showsPrec + +-- | GEq instance: structural equality on the query key, returning type-level +-- proof (Refl) when two queries are identical. +instance GEq Query where + geq (InputModule a) (InputModule b) + | a == b = Just Refl + geq ModuleGraph ModuleGraph = Just Refl + geq SortedModules SortedModules = Just Refl + geq (ModuleSugarEnv a) (ModuleSugarEnv b) + | a == b = Just Refl + geq (ModuleTypeEnv a) (ModuleTypeEnv b) + | a == b = Just Refl + geq (CompileModule a) (CompileModule b) + | a == b = Just Refl + geq _ _ = Nothing + +-- | GCompare instance required by some rock operations. +instance GCompare Query where + gcompare (InputModule a) (InputModule b) = case compare a b of + EQ -> GEQ; LT -> GLT; GT -> GGT + gcompare (InputModule _) _ = GLT + gcompare _ (InputModule _) = GGT + + gcompare ModuleGraph ModuleGraph = GEQ + gcompare ModuleGraph _ = GLT + gcompare _ ModuleGraph = GGT + + gcompare SortedModules SortedModules = GEQ + gcompare SortedModules _ = GLT + gcompare _ SortedModules = GGT + + gcompare (ModuleSugarEnv a) (ModuleSugarEnv b) = case compare a b of + EQ -> GEQ; LT -> GLT; GT -> GGT + gcompare (ModuleSugarEnv _) _ = GLT + gcompare _ (ModuleSugarEnv _) = GGT + + gcompare (ModuleTypeEnv a) (ModuleTypeEnv b) = case compare a b of + EQ -> GEQ; LT -> GLT; GT -> GGT + gcompare (ModuleTypeEnv _) _ = GLT + gcompare _ (ModuleTypeEnv _) = GGT + + gcompare (CompileModule a) (CompileModule b) = case compare a b of + EQ -> GEQ; LT -> GLT; GT -> GGT + +-- | Hashable instance for individual queries. +instance Hashable (Query a) where + hashWithSalt salt = \case + InputModule mn -> hashWithSalt salt (0 :: Int, mn) + ModuleGraph -> hashWithSalt salt (1 :: Int) + SortedModules -> hashWithSalt salt (2 :: Int) + ModuleSugarEnv mn -> hashWithSalt salt (3 :: Int, mn) + ModuleTypeEnv mn -> hashWithSalt salt (4 :: Int, mn) + CompileModule mn -> hashWithSalt salt (5 :: Int, mn) + +-- | Hashable for existentially-wrapped queries (required by rock's memoise). +instance Hashable (Some Query) where + hashWithSalt salt (Some q) = hashWithSalt salt q + +-- | ArgDict derivation for constraints-extras (needed for verifyTraces). +deriveArgDict ''Query diff --git a/src/Language/PureScript/Make/Rules.hs b/src/Language/PureScript/Make/Rules.hs new file mode 100644 index 0000000000..0b46aaa1bc --- /dev/null +++ b/src/Language/PureScript/Make/Rules.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE GADTs #-} + +module Language.PureScript.Make.Rules + ( makeRules + , MakeError(..) + ) where + +import Prelude + +import Control.Exception (Exception, throwIO) +import Control.Monad (foldM) +import Data.Foldable (traverse_) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Writer.Class (tell) +import Data.IORef (IORef, atomicModifyIORef', readIORef) +import Data.List (foldl') +import Data.Map qualified as M +import Data.Maybe (fromMaybe) +import Data.Set qualified as S + +import Rock qualified + +import Language.PureScript.AST (Module(..), getModuleName, getModuleSourceSpan) +import Language.PureScript.AST.SourcePos (spanName) +import Language.PureScript.Crash (internalError) +import Language.PureScript.CST qualified as CST +import Language.PureScript.Environment (initEnvironment) +import Language.PureScript.Errors (MultipleErrors) +import Language.PureScript.Externs (ExternsFile, applyExternsFileToEnvironment) +import Language.PureScript.Make.Actions (MakeActions(..), ProgressMessage(..), RebuildPolicy(..)) +import Language.PureScript.Make.Cache (CacheDb) +import Language.PureScript.Make.Cache qualified as Cache +import Language.PureScript.Make.ExternsDiff (ExternsDiff, checkDiffs, diffExterns, emptyDiff) +import Language.PureScript.Make.Monad (Make, runMake) +import Language.PureScript.Make.Query (Query(..)) +import Language.PureScript.ModuleDependencies (DependencyDepth(..), moduleSignature, sortModules) +import Language.PureScript.Names (ModuleName, runModuleName) +import Language.PureScript.Options (Options) +import Language.PureScript.Make.Traces qualified as Traces +import Language.PureScript.Sugar (Env, externsEnv) + +import Control.Monad.Writer.Strict (runWriterT) +import Data.Time.Clock (UTCTime(..)) +import System.Directory (getCurrentDirectory) + +-- | Exception wrapper for compilation errors. +newtype MakeError = MakeError MultipleErrors + deriving (Show) + +instance Exception MakeError + +-- | Run a 'Make' action inside rock's 'Task' monad. +liftMake :: Options -> IORef MultipleErrors -> Make a -> Rock.Task Query a +liftMake opts warningsRef action = liftIO $ do + (result, warnings) <- runMake opts action + atomicModifyIORef' warningsRef (\w -> (w <> warnings, ())) + case result of + Left errs -> throwIO (MakeError errs) + Right a -> pure a + +-- | The type of a single-module compilation function. +type CompileFn = Env -> [ExternsFile] -> Module -> Make ExternsFile + +-- | Per-module cache info, computed lazily on demand. +data CacheInfo = CacheInfo + { ciCacheStatus :: !CacheStatus + , ciOldExterns :: !(Maybe ExternsFile) + -- ^ Old externs for ExternsDiff (loaded even for changed modules) + } + +-- | Whether a module's build artifacts are up to date. +data CacheStatus + = CacheHit !UTCTime + -- ^ Source unchanged, output exists at this timestamp + | CacheMiss + -- ^ Needs rebuild (source changed or output missing) + +-- | Define the rock rules for the incremental compilation pipeline. +makeRules + :: M.Map ModuleName (CST.PartialResult Module) + -> Options + -> MakeActions Make + -> IORef MultipleErrors + -> CompileFn + -> CacheDb + -> IORef (M.Map ModuleName ExternsDiff) + -> IORef Env + -> IORef CacheDb + -> IORef (M.Map ModuleName UTCTime) + -> IORef (S.Set ModuleName) + -- ^ Modules actually compiled (not skipped) in this build + -> Maybe Traces.CachedGraph + -- ^ Cached module graph from previous build (if valid) + -> IORef (Maybe ([ModuleName], [(ModuleName, [ModuleName])])) + -- ^ Captures computed graph for persistence + -> Rock.Rules Query +makeRules modules opts actions warningsRef compileFn cacheDb diffsRef sharedEnvRef newCacheDbRef timestampsRef compiledRef cachedGraph graphRef = \case + + InputModule mn -> + case M.lookup mn modules of + Just pr -> pure (CST.resPartial pr) + Nothing -> liftIO . throwIO . MakeError $ internalError + ("makeRules: InputModule: module not found: " <> show (runModuleName mn)) + + SortedModules -> case cachedGraph of + Just cg | M.keysSet modules == S.fromList (Traces.cgSorted cg) -> pure (Traces.cgSorted cg) + _ -> do + let allNames = M.keys modules + traverse_ (\mn -> Rock.fetch (InputModule mn)) allNames + liftMake opts warningsRef $ do + let prs = M.elems modules + -- Use Direct deps for sorting (cheaper than Transitive). + -- Transitive closure is computed on demand in ModuleGraph. + (sorted, directGraph) <- sortModules Direct (moduleSignature . CST.resPartial) prs + let result = map (getModuleName . CST.resPartial) sorted + -- Capture direct graph for persistence (compact on disk) + liftIO $ atomicModifyIORef' graphRef (const (Just (result, directGraph), ())) + pure result + + ModuleGraph -> case cachedGraph of + Just cg | M.keysSet modules == S.fromList (Traces.cgSorted cg) -> + pure $ transitiveClosure (M.fromList (Traces.cgGraph cg)) + _ -> do + -- Ensure SortedModules has run (which populates graphRef) + _ <- Rock.fetch SortedModules + directGraph <- liftIO $ readIORef graphRef + case directGraph of + Just (_sorted, graph) -> pure $ transitiveClosure (M.fromList graph) + Nothing -> liftIO . throwIO . MakeError $ internalError + "makeRules: ModuleGraph: graphRef not populated" + + ModuleSugarEnv _mn -> liftIO $ readIORef sharedEnvRef + ModuleTypeEnv mn -> do + graph <- Rock.fetch ModuleGraph + let deps = fromMaybe [] $ M.lookup mn graph + depExterns <- traverse (\dep -> Rock.fetch (CompileModule dep)) deps + pure $ foldl' (flip applyExternsFileToEnvironment) initEnvironment depExterns + + CompileModule mn -> do + _inputModule <- Rock.fetch (InputModule mn) + graph <- Rock.fetch ModuleGraph + sorted <- Rock.fetch SortedModules + let deps = fromMaybe [] $ M.lookup mn graph + depsSet = S.fromList deps + sortedDeps = filter (`S.member` depsSet) sorted + depExterns <- traverse (\dep -> Rock.fetch (CompileModule dep)) sortedDeps + + -- Lazy cache check: only done when this module is actually demanded + cache <- checkModuleCache mn + + case ciCacheStatus cache of + CacheHit myTimestamp -> do + -- Source unchanged. Check if any dep was rebuilt externally (not + -- in this build) by comparing output timestamps. For deps rebuilt + -- in THIS build, ExternsDiff tells us if the interface changed. + diffs <- liftIO $ readIORef diffsRef + timestamps <- liftIO $ readIORef timestampsRef + compiled <- liftIO $ readIORef compiledRef + let depDiffs = map (\dep -> fromMaybe (emptyDiff dep) (M.lookup dep diffs)) sortedDeps + pr = fromMaybe (internalError "makeRules: missing module") + (M.lookup mn modules) + fullModule = case snd (CST.resFull pr) of + Right m -> m + Left _ -> CST.resPartial pr + -- A dep rebuilt externally (in a previous build, not this one) + -- has newer output. We must recompile since ExternsDiff can't + -- tell us what changed in its externs across builds. + hasExternallyRebuiltDep = any (\dep -> + not (S.member dep compiled) && depHasNewerOutput timestamps dep myTimestamp) sortedDeps + needsRebuild = hasExternallyRebuiltDep || checkDiffs fullModule depDiffs + + if needsRebuild then do + -- Load cached externs for diff computation + mbCached <- loadExterns mn + exts <- doCompile mn sortedDeps depExterns + let diff = case mbCached of + Just old -> diffExterns exts old depDiffs + Nothing -> emptyDiff mn + liftIO $ atomicModifyIORef' diffsRef (\d -> (M.insert mn diff d, ())) + pure exts + else do + -- Skip: deps' externs haven't meaningfully changed. + -- Don't call updateSharedEnv here — doCompile handles + -- missing env entries if a downstream module needs compilation. + liftMake opts warningsRef $ + progress actions $ SkippingModule mn Nothing + liftIO $ atomicModifyIORef' diffsRef (\d -> (M.insert mn (emptyDiff mn) d, ())) + -- Load externs only now (deferred from cache check) + mbCached <- loadExterns mn + case mbCached of + Just cached -> pure cached + Nothing -> do + -- Externs missing on disk even though cache says up to date. + -- Fall back to recompilation. + exts <- doCompile mn sortedDeps depExterns + recordDiff mn exts Nothing sortedDeps + pure exts + + CacheMiss -> do + exts <- doCompile mn sortedDeps depExterns + recordDiff mn exts (ciOldExterns cache) sortedDeps + pure exts + + where + -- | Check if a dependency's output is newer than a given timestamp. + -- Used to detect deps rebuilt in a previous build (not in this one). + depHasNewerOutput :: M.Map ModuleName UTCTime -> ModuleName -> UTCTime -> Bool + depHasNewerOutput timestamps dep myTimestamp = + maybe False (> myTimestamp) (M.lookup dep timestamps) + + -- | Lazily check a single module's cache status. + -- This is the key difference from the eager approach: only called + -- when rock actually demands this module. + checkModuleCache :: ModuleName -> Rock.Task Query CacheInfo + checkModuleCache mn = liftIO $ do + -- Run the cache check directly in IO via runMake, avoiding + -- the overhead of accumulating into warningsRef (cache checks + -- don't produce warnings). + -- Note: does NOT read externs here — deferred to loadExterns + -- to avoid reading .cbor files for modules that don't need them. + (result, _warnings) <- runMake opts $ do + inputInfo <- getInputTimestampsAndHashes actions mn + case inputInfo of + Left RebuildAlways -> do + (_, mbOld) <- readExterns actions mn + pure $ CacheInfo CacheMiss mbOld + Left RebuildNever -> do + let epoch = UTCTime (toEnum 0) 0 + pure $ CacheInfo (CacheHit epoch) Nothing + Right timestamps -> do + cwd <- liftIO getCurrentDirectory + (newCacheInfo, upToDate) <- Cache.checkChanged cacheDb mn cwd timestamps + liftIO $ atomicModifyIORef' newCacheDbRef (\db -> (M.insert mn newCacheInfo db, ())) + if upToDate then do + outputTs <- getOutputTimestamp actions mn + case outputTs of + Nothing -> pure $ CacheInfo CacheMiss Nothing + Just ts -> do + liftIO $ atomicModifyIORef' timestampsRef (\m -> (M.insert mn ts m, ())) + pure $ CacheInfo (CacheHit ts) Nothing + else do + (_, mbOld) <- readExterns actions mn + pure $ CacheInfo CacheMiss mbOld + case result of + Left _errs -> pure $ CacheInfo CacheMiss Nothing + Right info -> pure info + + -- | Load cached externs from disk. Only called when externs are + -- actually needed (for compilation or to return as a result). + loadExterns :: ModuleName -> Rock.Task Query (Maybe ExternsFile) + loadExterns mn = liftIO $ do + (result, _) <- runMake opts $ do + (_, mbExterns) <- readExterns actions mn + pure mbExterns + case result of + Right ext -> pure ext + Left _ -> pure Nothing + + doCompile :: ModuleName -> [ModuleName] -> [ExternsFile] -> Rock.Task Query ExternsFile + doCompile mn sortedDeps depExterns = do + liftIO $ atomicModifyIORef' compiledRef (\s -> (S.insert mn s, ())) + currentEnv <- liftIO $ readIORef sharedEnvRef + let pr = fromMaybe (internalError $ "makeRules: CompileModule: module not found: " <> show (runModuleName mn)) + (M.lookup mn modules) + fp = spanName . getModuleSourceSpan . CST.resPartial $ pr + (pwarnings, mres) = CST.resFull pr + missingExterns = [ exts + | (dep, exts) <- zip sortedDeps depExterns + , not (M.member dep currentEnv) + ] + liftMake opts warningsRef $ do + sugarEnv <- fmap fst . runWriterT $ foldM externsEnv currentEnv missingExterns + liftIO $ atomicModifyIORef' sharedEnvRef (const (sugarEnv, ())) + tell $ CST.toMultipleWarnings fp pwarnings + m <- CST.unwrapParserError fp mres + compileFn sugarEnv depExterns m + + recordDiff :: ModuleName -> ExternsFile -> Maybe ExternsFile -> [ModuleName] -> Rock.Task Query () + recordDiff mn exts mbOldExterns sortedDeps = do + diffs <- liftIO $ readIORef diffsRef + let depDiffs = map (\dep -> fromMaybe (emptyDiff dep) (M.lookup dep diffs)) sortedDeps + diff = case mbOldExterns of + Just old -> diffExterns exts old depDiffs + Nothing -> emptyDiff mn + liftIO $ atomicModifyIORef' diffsRef (\d -> (M.insert mn diff d, ())) + +-- | Compute transitive closure of a direct dependency graph. +-- For each module, find all modules reachable via dependencies. +transitiveClosure :: M.Map ModuleName [ModuleName] -> M.Map ModuleName [ModuleName] +transitiveClosure directGraph = M.mapWithKey (\mn _ -> S.toList (go S.empty (directDeps mn))) directGraph + where + directDeps :: ModuleName -> [ModuleName] + directDeps mn = fromMaybe [] (M.lookup mn directGraph) + go :: S.Set ModuleName -> [ModuleName] -> S.Set ModuleName + go visited [] = visited + go visited (dep:deps) + | S.member dep visited = go visited deps + | otherwise = go (S.insert dep visited) (directDeps dep ++ deps) diff --git a/src/Language/PureScript/Make/Traces.hs b/src/Language/PureScript/Make/Traces.hs new file mode 100644 index 0000000000..02f242ed3a --- /dev/null +++ b/src/Language/PureScript/Make/Traces.hs @@ -0,0 +1,93 @@ +-- | Cached module graph for cross-build incrementality. +-- Persisted to disk alongside cache-db.json. Invalidated when +-- any input module's content hash changes. +module Language.PureScript.Make.Traces + ( CachedGraph(..) + , readCachedGraph + , writeCachedGraph + ) where + +import Prelude + +import Data.Aeson qualified as Aeson +import Data.Aeson ((.=), (.:)) +import Data.ByteString.Lazy qualified as LBS +import Data.Map qualified as M +import Data.Set qualified as S +import Data.Version (showVersion) +import Language.PureScript.Make.Cache (CacheDb, ContentHash, hash) +import Language.PureScript.Names (ModuleName) +import Paths_purescript qualified as Paths +import System.Directory (doesFileExist) +import System.IO.Error (tryIOError) + +-- | Cached module graph: sorted module list and dependency graph. +-- Only valid when all input module hashes match the CacheDb. +data CachedGraph = CachedGraph + { cgVersion :: String + , cgSorted :: [ModuleName] + , cgGraph :: [(ModuleName, [ModuleName])] + , cgCacheDbHash :: ContentHash + -- ^ Hash of the serialized CacheDb when graph was computed. + -- If current CacheDb hashes the same, graph is still valid. + } deriving (Show) + +instance Aeson.ToJSON CachedGraph where + toJSON CachedGraph{..} = Aeson.object + [ "version" .= cgVersion + , "sorted" .= cgSorted + , "graph" .= cgGraph + , "cacheDbHash" .= cgCacheDbHash + ] + +instance Aeson.FromJSON CachedGraph where + parseJSON = Aeson.withObject "CachedGraph" $ \v -> + CachedGraph + <$> v .: "version" + <*> v .: "sorted" + <*> v .: "graph" + <*> v .: "cacheDbHash" + +-- | Compute a hash of the CacheDb for comparison purposes. +hashCacheDb :: CacheDb -> ContentHash +hashCacheDb = hash . LBS.toStrict . Aeson.encode + +-- | Try to read a cached graph. Returns Nothing if: +-- - File doesn't exist +-- - File can't be parsed +-- - Compiler version differs +-- - The set of module names differs from the current compilation +-- - The CacheDb hash differs (some input changed) +-- - The CacheDb lacks entries for some current modules (can't verify content) +readCachedGraph :: FilePath -> CacheDb -> S.Set ModuleName -> IO (Maybe CachedGraph) +readCachedGraph path currentCacheDb currentModules = do + exists <- doesFileExist path + if not exists then pure Nothing + else do + result <- tryIOError $ LBS.readFile path + case result of + Left _ -> pure Nothing + Right bs -> case Aeson.decode bs of + Nothing -> pure Nothing + Just cg + | cgVersion cg /= showVersion Paths.version -> pure Nothing + | S.fromList (cgSorted cg) /= currentModules -> pure Nothing + -- Require that the CacheDb has entries for all current modules. + -- Without content hashes for every module, we can't verify the + -- dependency graph is still valid (e.g. when modules use + -- RebuildAlways/RebuildNever, their hashes are not tracked). + | not (currentModules `S.isSubsetOf` M.keysSet currentCacheDb) -> pure Nothing + | cgCacheDbHash cg /= hashCacheDb currentCacheDb -> pure Nothing + | otherwise -> pure (Just cg) + +-- | Write cached graph to disk. +writeCachedGraph :: FilePath -> [ModuleName] -> [(ModuleName, [ModuleName])] -> CacheDb -> IO () +writeCachedGraph path sorted graph cacheDb = do + let cg = CachedGraph + { cgVersion = showVersion Paths.version + , cgSorted = sorted + , cgGraph = graph + , cgCacheDbHash = hashCacheDb cacheDb + } + _ <- tryIOError $ LBS.writeFile path (Aeson.encode cg) + pure () diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 094ae5773d..807b9f3187 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -12,6 +12,7 @@ import Control.Applicative ((<|>)) import Control.Monad.Supply.Class (MonadSupply(..)) import Control.DeepSeq (NFData) import Data.Functor.Contravariant (contramap) +import Data.Hashable (Hashable) import Data.Vector qualified as V import GHC.Generics (Generic) @@ -190,7 +191,7 @@ coerceProperName = ProperName . runProperName -- newtype ModuleName = ModuleName Text deriving (Show, Eq, Ord, Generic) - deriving newtype Serialise + deriving newtype (Serialise, Hashable) instance NFData ModuleName diff --git a/stack.yaml b/stack.yaml index afbac89bca..ef266dd998 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,6 +2,7 @@ # (or the CI build will fail) resolver: lts-22.43 pvp-bounds: both +system-ghc: true packages: - '.' ghc-options: @@ -17,6 +18,10 @@ extra-deps: - haskeline-0.8.2 - these-1.2.1 - aeson-better-errors-0.9.1.3 +# Rock incremental computation dependencies +- dependent-hashmap-0.1.0.1 +- github: ollef/rock + commit: 2b007b75f2866b0c9dae82049a0a06582d883b0f - github: purescript/cheapskate commit: 8bfaf4beeb108e97a274ed51303f278905979e87 diff --git a/stack.yaml.lock b/stack.yaml.lock index 0af2cebb41..389a3858a7 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -39,6 +39,24 @@ packages: size: 492 original: hackage: aeson-better-errors-0.9.1.3 +- completed: + hackage: dependent-hashmap-0.1.0.1@sha256:6d1c20bd79f32d8daebd3cc741f884cc3d093118e3b876eb957defd4c594a966,1892 + pantry-tree: + sha256: 817b36b81735d96696c5b165357c431e0b396dcf45afb8b4384fbfd4f4499cbb + size: 334 + original: + hackage: dependent-hashmap-0.1.0.1 +- completed: + name: rock + pantry-tree: + sha256: cef9733314b1f4778ccecaf5fb6f80ef1004251ea76804073a498ddf02c00ed5 + size: 751 + sha256: 3b2ec18d31734ad105b5ff7cd795d06d4d0e9be925af5bcdb9a7ea20d414cbc7 + size: 12242 + url: https://github.com/ollef/rock/archive/2b007b75f2866b0c9dae82049a0a06582d883b0f.tar.gz + version: 0.3.1.2 + original: + url: https://github.com/ollef/rock/archive/2b007b75f2866b0c9dae82049a0a06582d883b0f.tar.gz - completed: name: cheapskate pantry-tree: