diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 8eb1a72572..6177616654 100644 --- 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 index bcbdc62ebf..a30d498984 100644 --- 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 index 477c2e68f4..01c58855ff 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -8,6 +8,10 @@ module Language.PureScript.Externs , ExternsFixity(..) , ExternsTypeFixity(..) , ExternsDeclaration(..) + , BuildCacheFile(..) + , ExternCacheKey(..) + , DeclarationCacheRef(..) + , BuildCacheDb , externsIsCurrentVersion , moduleToExternsFile , applyExternsFileToEnvironment @@ -16,7 +20,7 @@ module Language.PureScript.Externs import Prelude -import Codec.Serialise (Serialise) +import Codec.Serialise (Serialise, serialise) import Control.Monad (join) import GHC.Generics (Generic) import Data.Maybe (fromMaybe, mapMaybe, maybeToList) @@ -27,6 +31,7 @@ import qualified Data.Text as T import Data.Version (showVersion) import qualified Data.Map as M import qualified Data.List.NonEmpty as NEL +import Data.Function ((&)) import Language.PureScript.AST import Language.PureScript.AST.Declarations.ChainId (ChainId) @@ -38,6 +43,13 @@ import Language.PureScript.Types import Paths_purescript as Paths +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.Lazy.UTF8 as BLU + +import Control.Monad.State.Lazy (State, runState, modify) +import Debug.Trace +import PrettyPrint + -- | The data which will be serialized to an externs file data ExternsFile = ExternsFile -- NOTE: Make sure to keep `efVersion` as the first field in this @@ -59,10 +71,44 @@ data ExternsFile = ExternsFile -- ^ List of type and value declaration , efSourceSpan :: SourceSpan -- ^ Source span for error reporting + , efBuildCache :: BuildCacheFile } deriving (Show, Generic) instance Serialise ExternsFile +-- TODO[drathier]: is it enough to look at just the cacheDeclarations (what we export)? or do we need to look at the cached imports too? + +-- -- | The data which will be serialized to a build cache file +data BuildCacheFile = BuildCacheFile + -- NOTE[drathier]: using bytestrings here for much faster encoding/decoding, since we only care about equality for now. When we want to look at what's actually imported, we have to split this up a bit; BS into Map BS BS. + -- NOTE: Make sure to keep `efVersion` as the first field in this + -- record, so the derived Serialise instance produces CBOR that can + -- be checked for its version independent of the remaining format + { bcVersion :: Text + -- ^ The externs version + , bcModuleName :: ModuleName + -- ^ Module name + -- , bcCacheDeclarations :: M.Map DeclarationCacheRef [ExternCacheKey] + , bcCacheBlob :: B.ByteString + -- ^ All of the things, in one ByteString. We only care about equality anyway. + , bcCacheDecls :: M.Map DeclarationRef B.ByteString + -- ^ Exported things which we might want to re-export in modules depending on this one + , bcDeclarations :: M.Map Text ([(Text, Maybe (Type ()))], Type ()) + -- ^ Exported things which we might want to re-export in modules depending on this one + , bcDeclShapes :: M.Map (ProperName 'TypeName) (CacheShape, CacheTypeDetails) + -- ^ WIP + , bcCacheDeps :: M.Map ModuleName B.ByteString + -- ^ all declarations explicitly imported from a specific module, if explicitly imported + -- 1. open imports are not cached, for now, since we don't know which things are used + -- 2. hiding imports are also not cached, even though we could skip the hidden things and treat it as a closed import afterwards + -- 3. explicit imports are matched to see if anything differs + -- 4. if an imported modulename is missing, it's a new import or something we couldn't cache, so treat it as a cache miss + -- 5. [ExternsDeclaration] is the list of extdecls we saw when building this module/externsfile; it's what we should compare against when looking for cache hits + } deriving (Show, Generic) +instance Serialise BuildCacheFile + +type BuildCacheDb = M.Map ModuleName BuildCacheFile + -- | A module import in an externs file data ExternsImport = ExternsImport { @@ -195,6 +241,195 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar qual :: a -> Qualified a qual = Qualified (ByModuleName efModuleName) + +_efBuildCache :: ExternsFile -> BuildCacheFile +_efBuildCache = efBuildCache + +_bcCacheBlob :: BuildCacheFile -> B.ByteString +_bcCacheBlob = bcCacheBlob + +_bcDeclShapes :: BuildCacheFile -> M.Map (ProperName 'TypeName) (CacheShape, CacheTypeDetails) +_bcDeclShapes = bcDeclShapes + +data DeclarationCacheRef + -- | + -- A type class + -- + = DeclCacheTypeClassRef (ProperName 'ClassName) + -- | + -- A type operator + -- + | DeclCacheTypeOpRef (OpName 'TypeOpName) + -- | + -- A type constructor with data constructors + -- + | DeclCacheTypeRef (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName]) + -- | + -- A value + -- + | DeclCacheValueRef Ident + -- | + -- A value-level operator + -- + | DeclCacheValueOpRef (OpName 'ValueOpName) + -- | + -- A type class instance, created during typeclass desugaring + -- + | DeclCacheTypeInstanceRef Ident NameSource + -- | + -- A module, in its entirety + -- + | DeclCacheModuleRef ModuleName + -- | + -- A value re-exported from another module. These will be inserted during + -- elaboration in name desugaring. + -- + | DeclCacheReExportRef ExportSource DeclarationRef + deriving (Show, Generic) + +instance Serialise DeclarationCacheRef + +declRefToCacheRef :: DeclarationRef -> DeclarationCacheRef +declRefToCacheRef = \case + TypeClassRef _ className -> DeclCacheTypeClassRef className + TypeOpRef _ typeOpName -> DeclCacheTypeOpRef typeOpName + TypeRef _ typeName mConstructorNames -> DeclCacheTypeRef typeName mConstructorNames + ValueRef _ ident -> DeclCacheValueRef ident + ValueOpRef _ valueOpName -> DeclCacheValueOpRef valueOpName + TypeInstanceRef _ ident nameSource -> DeclCacheTypeInstanceRef ident nameSource + ModuleRef _ moduleName -> DeclCacheModuleRef moduleName + ReExportRef _ exportSource declarationRef -> DeclCacheReExportRef exportSource declarationRef + +data ExternCacheKey = + -- | A type declaration + CacheEDType + { cacheEdTypeName :: ProperName 'TypeName + , cacheEdTypeKind :: Type () + -- , cacheEdTypeDeclarationKind :: TypeKind -- TODO[drathier]: contains SourceType for adt's, can we safely skip the entire field? Probably not + } + -- | A type synonym + | CacheEDTypeSynonym + { cacheEdTypeSynonymName :: ProperName 'TypeName + , cacheEdTypeSynonymArguments :: [(Text, Maybe (Type ()))] + , cacheEdTypeSynonymType :: Type () -- CacheType + } + -- | A data constructor + | CacheEDDataConstructor + { cacheEdDataCtorName :: ProperName 'ConstructorName + , cacheEdDataCtorOrigin :: DataDeclType + , cacheEdDataCtorTypeCtor :: ProperName 'TypeName + , cacheEdDataCtorType :: Type () + , cacheEdDataCtorFields :: [Ident] + } + -- | A value declaration + | CacheEDValue + { cacheEdValueName :: Ident + , cacheEdValueType :: Type () + } + -- | A type class declaration + | CacheEDClass + { cacheEdClassName :: ProperName 'ClassName + , cacheEdClassTypeArguments :: [(Text, Maybe (Type ()))] + , cacheEdClassMembers :: [(Ident, (Type ()))] + , cacheEdClassConstraints :: [Constraint ()] + , cacheEdFunctionalDependencies :: [FunctionalDependency] + , cacheEdIsEmpty :: Bool + } + -- | An instance declaration + | CacheEDInstance + { cacheEdInstanceClassName :: Qualified (ProperName 'ClassName) + , cacheEdInstanceName :: Ident + , cacheEdInstanceForAll :: [(Text, Type ())] + , cacheEdInstanceKinds :: [Type ()] + , cacheEdInstanceTypes :: [Type ()] + , cacheEdInstanceConstraints :: Maybe [Constraint ()] + , cacheEdInstanceChain :: Maybe ChainId -- contains sourcepos, can we skip it? + , cacheEdInstanceChainIndex :: Integer + , cacheEdInstanceNameSource :: NameSource + -- , cacheEdInstanceSourceSpan :: SourceSpan + } + deriving (Show, Generic) + +instance Serialise ExternCacheKey + +extDeclToCacheKey :: M.Map Text ([(Text, Maybe (Type ()))], Type ()) -> ExternsDeclaration -> ExternCacheKey +extDeclToCacheKey _decls = \case + EDType + edTypeName -- :: ProperName 'TypeName + edTypeKind -- :: Type () + _ -- (edTypeDeclarationKind :: TypeKind) -- contains SourceType for adt's, can we safely skip the entire field? + -> + CacheEDType + edTypeName + (const () <$> edTypeKind) + -- A type synonym + EDTypeSynonym + edTypeSynonymName -- :: ProperName 'TypeName + edTypeSynonymArguments -- :: [(Text, Maybe (Type ()))] + edTypeSynonymType -- :: Type () + -> + CacheEDTypeSynonym + edTypeSynonymName + (fmap (fmap (fmap (const ()))) <$> edTypeSynonymArguments) + (const () <$> edTypeSynonymType) + -- A data constructor + EDDataConstructor + edDataCtorName -- :: ProperName 'ConstructorName + edDataCtorOrigin -- :: DataDeclType + edDataCtorTypeCtor -- :: ProperName 'TypeName + edDataCtorType -- :: Type () + edDataCtorFields -- :: [Ident] + -> CacheEDDataConstructor + edDataCtorName + edDataCtorOrigin + edDataCtorTypeCtor + (const () <$> edDataCtorType) + edDataCtorFields + -- A value declaration + EDValue + edValueName -- :: Ident + edValueType -- :: Type () + -> CacheEDValue + edValueName + (const () <$> edValueType) + -- A type class declaration + EDClass + edClassName -- :: ProperName 'ClassName + edClassTypeArguments -- :: [(Text, Maybe (Type ()))] + edClassMembers -- :: [(Ident, Type ())] + edClassConstraints -- :: [Constraint ()] + edFunctionalDependencies -- :: [FunctionalDependency] + edIsEmpty -- :: Bool + -> CacheEDClass + edClassName + (fmap (fmap (fmap (const ()))) <$> edClassTypeArguments) + (fmap (fmap (const ())) <$> edClassMembers) + (fmap (const ()) <$> edClassConstraints) + edFunctionalDependencies + edIsEmpty + -- An instance declaration + EDInstance + edInstanceClassName -- :: Qualified (ProperName 'ClassName) + edInstanceName -- :: Ident + edInstanceForAll -- :: [(Text, Type ())] + edInstanceKinds -- :: [Type ()] + edInstanceTypes -- :: [Type ()] + edInstanceConstraints -- :: Maybe [Constraint ()] + edInstanceChain -- :: Maybe ChainId -- contains sourcepos, can we skip it? + edInstanceChainIndex -- :: Integer + edInstanceNameSource -- :: NameSource + _ -- (edInstanceSourceSpan :: SourceSpan + -> CacheEDInstance + edInstanceClassName + edInstanceName + (fmap (fmap (const ())) <$> edInstanceForAll) + (fmap (const ()) <$> edInstanceKinds) + (fmap (const ()) <$> edInstanceTypes) + (fmap (fmap (const ())) <$> edInstanceConstraints) + edInstanceChain + edInstanceChainIndex + edInstanceNameSource + -- | Generate an externs file for all declarations in a module. -- -- The `Map Ident Ident` argument should contain any top-level `GenIdent`s that @@ -202,9 +437,9 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar -- happens in the CoreFn, not the original module AST, so it needs to be -- applied to the exported names here also. (The appropriate map is returned by -- `L.P.Renamer.renameInModule`.) -moduleToExternsFile :: Module -> Environment -> M.Map Ident Ident -> ExternsFile -moduleToExternsFile (Module _ _ _ _ Nothing) _ _ = internalError "moduleToExternsFile: module exports were not elaborated" -moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsFile{..} +moduleToExternsFile :: M.Map ModuleName ExternsFile -> Module -> Environment -> M.Map Ident Ident -> ExternsFile +moduleToExternsFile _ (Module _ _ _ _ Nothing) _ _ = internalError "moduleToExternsFile: module exports were not elaborated" +moduleToExternsFile externsMap (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsFile{..} where efVersion = T.pack (showVersion Paths.version) efModuleName = mn @@ -212,9 +447,244 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsF efImports = mapMaybe importDecl ds efFixities = mapMaybe fixityDecl ds efTypeFixities = mapMaybe typeFixityDecl ds - efDeclarations = concatMap toExternsDeclaration exps + efDeclarations = concat $ map snd $ bcCacheDeclarationsPre efSourceSpan = ss + -- TODO[drathier]: look up relevant defs in `ds` when exposing type aliases (and presumably type classes too?), and add them to the externs file for easy diffing + + ------ decls + + ------ + + bcDeclarations :: M.Map Text ([(Text, Maybe (Type ()))], Type ()) + bcDeclarations = M.fromList $ concatMap typeDeclForCache ds + efBuildCache = BuildCacheFile efVersion efModuleName bcCacheBlob bcCacheDecls bcDeclarations bcDeclShapes bcCacheImports + + bcReExportDeclShapes :: M.Map (ProperName 'TypeName) (CacheShape, CacheTypeDetails) + bcReExportDeclShapes = + -- ASSUMPTION[drathier]: no exposed constructors? then other modules cannot possibly care about the internal shape of this data type, since cross-module inlining isn't a thing + let + getModu modu = + externsMap + & M.lookup modu + & fromMaybe (trace ("bcReExportDeclShapes: missing module in externsMap:" <> sShow (mn, modu, M.keys externsMap)) $ internalError "bcReExportDeclShapes: missing module in externsMap") + & _efBuildCache + & _bcDeclShapes + + f (TypeClassRef _ _) = [] + f (TypeOpRef _ _) = [] + f (TypeRef _ _ _) = [] + f (ValueRef _ _) = [] + f (ValueOpRef _ _) = [] + f (TypeInstanceRef _ _ _) = [] + f (ModuleRef _ _) = [] -- Anything re-exported via a ModuleRef is also exposed on a per-decl basis via an ReExportRef, so we only use ReExportRef to find re-exports. + f (ReExportRef _ (ExportSource _ (ModuleName moduName)) _) | "Prim" `T.isPrefixOf` moduName = [] + f (ReExportRef _ (ExportSource _ mn2) (TypeRef _ tn _)) = + getModu mn2 + & (\m -> M.intersection m (M.singleton tn ())) + & M.toList + f (ReExportRef _ _ _) = [] + in + M.fromList $ concatMap f exps + + expsTypeNames :: M.Map (ProperName 'TypeName) Bool + expsTypeNames = + -- ASSUMPTION[drathier]: no exposed constructors? then other modules cannot possibly care about the internal shape of this data type, since cross-module inlining isn't a thing + let + f (TypeClassRef _ _) = [] + f (TypeOpRef _ _) = [] + -- type synonyms don't have ctors in ast but do effectively have a single exposed ctor, so keep it in + f (TypeRef _ tn _) | (Just (_, TypeSynonym)) <- Qualified (ByModuleName mn) tn `M.lookup` types env = [(tn, True)] + -- data types with no public ctors are opaque to all other modules, so no need to expose its internal shapes + f (TypeRef _ tn (Just [])) = [(tn, False)] + -- if there are any exposed ctors, expose the type shape + f (TypeRef _ tn _) = [(tn, True)] + f (ValueRef _ _) = [] + f (ValueOpRef _ _) = [] + f (TypeInstanceRef _ _ _) = [] + -- re-exports are handled elsewhere + f (ModuleRef _ _) = [] + f (ReExportRef _ _ _) = [] + in + M.fromList $ concatMap f exps + + bcDeclShapes :: M.Map (ProperName 'TypeName) (CacheShape, CacheTypeDetails) + bcDeclShapes = + M.intersectionWith + (\(cs, ctd) shouldShowInternals -> + if shouldShowInternals then + (cs, ctd) + else + (cs, CacheTypeDetails mempty) + ) + bcDeclShapesAll + expsTypeNames + -- add in re-exports + & (<>) bcReExportDeclShapes + -- & (\v -> trace ("bcDeclShapes:" <> sShow (mn, exps, v)) v) + + + bcDeclShapesAll :: M.Map (ProperName 'TypeName) (CacheShape, CacheTypeDetails) + bcDeclShapesAll = + ds + & concatMap declToCacheShape + & M.fromList + & M.map (\(cs, cts) -> + ( cs + , cts + & M.mapWithKey (\k () -> + case k of + Qualified (BySourcePos _) _ -> + internalError "dsCacheShapesWithDetails: unexpected Qualified BySourcePos" + + Qualified (ByModuleName km@(ModuleName kmn)) tn | "Prim" `T.isPrefixOf` kmn -> (PrimType km tn, CacheTypeDetails mempty) + Qualified (ByModuleName km) tn | "$" `T.isInfixOf` runProperName tn -> (TypeClassDictType km tn, CacheTypeDetails mempty) + Qualified (ByModuleName km) tn | km == mn -> (OwnModuleRef km tn, CacheTypeDetails mempty) + Qualified (ByModuleName km) tn -> + let + moduExterns = + M.lookup km externsMap + & fromMaybe (trace ("dsCacheShapesWithDetails: missing module in externsMap:" <> sShow (km, tn, M.keys externsMap)) $ internalError "dsCacheShapesWithDetails: missing module in externsMap") + & _efBuildCache + & _bcDeclShapes + in + moduExterns + & M.lookup tn + & fromMaybe (trace ("dsCacheShapesWithDetails: missing type in externsMap:" <> sShow (mn, km, tn, M.keys externsMap, moduExterns)) $ internalError "dsCacheShapesWithDetails: missing type in externsMap") + ) + & M.toList + & mapMaybe (\case + (Qualified (ByModuleName km) k, v) -> Just ((km,k), v) + (Qualified (BySourcePos pos) k, v) -> trace (show ("BcDeclShapesAll-Externs: skipping Qualified BySourcePos" :: String, pos, "k" :: String, k, "v" :: String, v)) Nothing + ) -- TODO partial + & M.fromList + & CacheTypeDetails + ) + ) + + bcCacheDecls :: M.Map DeclarationRef B.ByteString + bcCacheBlob :: B.ByteString + (bcCacheDecls, bcCacheBlob) = + let + bshow a = BLU.fromString ("[" <> show a <> "]") + + _ = (serialise :: Int -> B.ByteString) + + foldCache :: Show a => Serialise a => [a] -> B.ByteString + foldCache = foldr (\a acc -> bshow a <> "|" <> acc) B.empty + + cacheDecls :: M.Map DeclarationRef B.ByteString + cacheDecls = + M.fromList $ fmap (\(k,v) -> (k, foldCache (extDeclToCacheKey bcDeclarations <$> v))) $ filter (\(k, _) -> elem k efExports) bcCacheDeclarationsPre + + -- cacheDecls2 = + -- foldr + -- (\(k,vs) m1 -> + -- case elem k efExports of + -- False -> m1 + -- True -> + -- foldr + -- (\v acc -> bshow (declRefToCacheRef k) <> ":" <> bshow (extDeclToCacheKey v) <> acc) + -- m1 + -- vs + -- ) + -- B.empty + -- bcCacheDeclarationsPre + + cacheExports = foldCache (declRefToCacheRef <$> efExports) + cacheImports = foldr (<>) B.empty $ (\v -> (serialise (eiModule v) <> ":" <> removeSourceSpansFromImport (eiImportType v))) <$> efImports + cacheFixities = foldCache efFixities + cacheTypeFixities = foldCache efTypeFixities + + removeSourceSpansFromImport = \case + Implicit -> "Implicit" + Explicit declRefs -> "Explicit" <> foldCache (declRefToCacheRef <$> declRefs) + Hiding declRefs -> "Hiding" <> foldCache (declRefToCacheRef <$> declRefs) + in + ( cacheDecls + , cacheExports + <> cacheImports + <> cacheFixities + <> cacheTypeFixities + ) + + bcCacheDeclarationsPre :: [(DeclarationRef, [ExternsDeclaration])] + bcCacheDeclarationsPre = (\ref -> (ref, (toExternsDeclaration ref))) <$> exps + + bcCacheImports :: M.Map ModuleName B.ByteString + bcCacheImports = -- TODO[drathier]: fill in + externsMap + & M.filterWithKey (\k _ -> elem k importModuleNames) + & fmap _efBuildCache + & fmap _bcCacheBlob + + importModuleNames = eiModule <$> efImports + + typeDeclForCache :: Declaration -> [(Text ,([(Text, Maybe (Type ()))] , Type ()))] + typeDeclForCache (TypeSynonymDeclaration _ typeName targs underlyingType) = + [(runProperName typeName, (fmap (fmap (fmap (const ()))) <$> targs, const () <$> underlyingType))] + typeDeclForCache _ = [] + + declToCacheShape + :: Declaration + -> [(ProperName 'TypeName, (CacheShape, CacheTypeState))] + declToCacheShape decl = + let + (things, cts) = runState (declToCacheShapeImpl decl) mempty + f (name, cs) = (name, (cs, cts)) + in f <$> things + + declToCacheShapeImpl + :: Declaration + -> State CacheTypeState [(ProperName 'TypeName, CacheShape)] + declToCacheShapeImpl (DataDeclaration _ dataOrNewtype typeName targs ctors) = do + let + handleCtor (DataConstructorDeclaration _ ctorName ctorFields) = do + ctorFieldsv <- mapM (mapM typeToCacheTypeImpl) ctorFields + pure (ctorName, ctorFieldsv) + + targsv <- mapM (mapM (mapM typeToCacheTypeImpl)) targs + ctorsv <- mapM handleCtor ctors + + pure + [ ( typeName + , CacheShapeDataDecl + dataOrNewtype + typeName + targsv + ctorsv + ) + ] + -- TODO[drathier]: how do we handle mutually recursive data types? + declToCacheShapeImpl (DataBindingGroupDeclaration things) = do + -- e.g. the Void type lives here + thingsv <- mapM declToCacheShapeImpl things + pure $ concat thingsv + + declToCacheShapeImpl (ExternDataDeclaration _ typeName underlyingType) = do + underlyingTypev <- typeToCacheTypeImpl underlyingType + pure + [ ( typeName + , CacheShapeForeignTypeDecl + typeName + underlyingTypev + ) + ] + declToCacheShapeImpl (TypeSynonymDeclaration _ typeName targs underlyingType) = do + targsv <- mapM (mapM (mapM typeToCacheTypeImpl)) targs + underlyingTypev <- typeToCacheTypeImpl underlyingType + pure + [ ( typeName + , CacheShapeTypeDecl + typeName + targsv + underlyingTypev + ) + ] + declToCacheShapeImpl _ = pure [] + + ----- + fixityDecl :: Declaration -> Maybe ExternsFixity fixityDecl (ValueFixityDeclaration _ (Fixity assoc prec) name op) = fmap (const (ExternsFixity assoc prec op name)) (find ((== Just op) . getValueOpRef) exps) @@ -276,3 +746,102 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsF externsFileName :: FilePath externsFileName = "externs.cbor" + +data CacheShape + = PrimType ModuleName (ProperName 'TypeName) + | TypeClassDictType ModuleName (ProperName 'TypeName) + | OwnModuleRef ModuleName (ProperName 'TypeName) + | CacheShapeTypeDecl + (ProperName 'TypeName) + [(Text, Maybe (Type ()))] + (Type ()) + | CacheShapeForeignTypeDecl + (ProperName 'TypeName) + (Type ()) + | CacheShapeDataDecl + DataDeclType + (ProperName 'TypeName) + [(Text, Maybe (Type ()))] + [(ProperName 'ConstructorName, [(Ident, Type ())])] + -- CacheShapeDataRecDecl + -- DataDeclType + -- (ProperName 'TypeName) + -- [(Text, Maybe (Type ()))] + -- [(ProperName 'ConstructorName, [(Ident, Type ())])] + deriving (Show, Eq, Ord, Generic) + +instance Serialise CacheShape + +data CacheTypeDetails = CacheTypeDetails (M.Map (ModuleName, ProperName 'TypeName) (CacheShape, CacheTypeDetails)) + deriving (Show, Eq, Generic) + +instance Serialise CacheTypeDetails + + + + + + +---------------- + + +type CacheTypeState = M.Map (Qualified (ProperName 'TypeName)) () + +typeToCacheTypeImpl :: Type a -> State CacheTypeState (Type ()) +typeToCacheTypeImpl t = case t of + TUnknown _ a -> pure $ TUnknown () a + TypeVar _ a -> pure $ TypeVar () a + TypeLevelString _ a -> pure $ TypeLevelString () a + TypeLevelInt _ a -> pure $ TypeLevelInt () a + TypeWildcard _ a -> pure $ TypeWildcard () a + TypeConstructor _ a -> do + modify (M.insert a ()) + pure $ TypeConstructor () a + TypeOp _ a -> pure $ TypeOp () a + TypeApp _ a b -> do + av <- typeToCacheTypeImpl a + bv <- typeToCacheTypeImpl b + pure $ TypeApp () av bv + KindApp _ a b -> do + av <- typeToCacheTypeImpl a + bv <- typeToCacheTypeImpl b + pure $ KindApp () av bv + ForAll _ a b c d -> do + bv <- mapM typeToCacheTypeImpl b + cv <- typeToCacheTypeImpl c + pure $ ForAll () a bv cv d + ConstrainedType _ a b -> do + av <- constraintToCacheTypeImpl a + bv <- typeToCacheTypeImpl b + pure $ ConstrainedType () av bv + Skolem _ a b c d -> do + bv <- mapM typeToCacheTypeImpl b + pure $ Skolem () a bv c d + REmpty _ -> pure $ REmpty () + RCons _ a b c -> do + bv <- typeToCacheTypeImpl b + cv <- typeToCacheTypeImpl c + pure $ RCons () a bv cv + KindedType _ a b -> do + av <- typeToCacheTypeImpl a + bv <- typeToCacheTypeImpl b + pure $ KindedType () av bv + BinaryNoParensType _ a b c -> do + av <- typeToCacheTypeImpl a + bv <- typeToCacheTypeImpl b + cv <- typeToCacheTypeImpl c + pure $ BinaryNoParensType () av bv cv + ParensInType _ a -> do + av <- typeToCacheTypeImpl a + pure $ ParensInType () av + +constraintToCacheTypeImpl :: Constraint a -> State CacheTypeState (Constraint ()) +constraintToCacheTypeImpl (Constraint {..}) = do + cka <- mapM typeToCacheTypeImpl constraintKindArgs + ca <- mapM typeToCacheTypeImpl constraintArgs + pure $ Constraint + () + constraintClass + cka + ca + constraintData diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index d9e7157f16..fc383ced4b 100644 --- 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 index ff50ba1d0c..74bd08e9d0 100644 --- 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 diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index cf9c2833a9..2704144204 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -1,16 +1,28 @@ +{-# LANGUAGE TypeApplications #-} module Language.PureScript.Make.BuildPlan ( BuildPlan(bpEnv, bpIndex) , BuildJobResult(..) + , DidPublicApiChange(..) + , buildJobSucceeded , buildJobSuccess , construct , getResult , collectResults , markComplete , needsRebuild + -- + , bjResult + , bpBuildJobs + , pbExternsFile + , bpPrebuilt + , bjPrebuilt + , bjDirtyExterns + , shouldWeRebuild ) where import Prelude +import Codec.Serialise as Serialise import Control.Concurrent.Async.Lifted as A import Control.Concurrent.Lifted as C import Control.Monad.Base (liftBase) @@ -20,7 +32,7 @@ import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Data.Foldable (foldl') import qualified Data.Map as M import Data.Maybe (fromMaybe, mapMaybe) -import Data.Time.Clock (UTCTime) +import Data.Time.Clock (UTCTime(..)) import Language.PureScript.AST import Language.PureScript.Crash import qualified Language.PureScript.CST as CST @@ -28,9 +40,22 @@ import Language.PureScript.Errors import Language.PureScript.Externs import Language.PureScript.Make.Actions as Actions import Language.PureScript.Make.Cache -import Language.PureScript.Names (ModuleName) +import Language.PureScript.Names (ModuleName(..)) import Language.PureScript.Sugar.Names.Env import System.Directory (getCurrentDirectory) +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) + -- | The BuildPlan tracks information about our build progress, and holds all -- prebuilt modules for incremental builds. @@ -46,25 +71,109 @@ data Prebuilt = Prebuilt , pbExternsFile :: ExternsFile } -newtype BuildJob = BuildJob +data BuildJob = BuildJob { bjResult :: C.MVar BuildJobResult -- ^ Note: an empty MVar indicates that the build job has not yet finished. + -- TODO[drathier]: remove both fields here and newtype BuildJob again: + , bjPrebuilt :: Maybe Prebuilt + , bjDirtyExterns :: Maybe ExternsFile } data BuildJobResult - = BuildJobSucceeded !MultipleErrors !ExternsFile + = BuildJobSucceeded !MultipleErrors !ExternsFile !DidPublicApiChange -- ^ Succeeded, with warnings and externs -- + | BuildJobCacheHit !ExternsFile + -- ^ Cache hit, so no warnings + -- | BuildJobFailed !MultipleErrors -- ^ Failed, with errors | BuildJobSkipped -- ^ The build job was not run, because an upstream build job failed -buildJobSuccess :: BuildJobResult -> Maybe (MultipleErrors, ExternsFile) -buildJobSuccess (BuildJobSucceeded warnings externs) = Just (warnings, externs) +data DidPublicApiChange + = PublicApiChanged + | PublicApiStayedTheSame + deriving (Show, Eq) + +buildJobSucceeded :: Maybe BuildCacheFile -> MultipleErrors -> ExternsFile -> BuildJobResult +buildJobSucceeded mDirtyCache warnings externs = + case mDirtyCache of + Just dirtyCache | fastEqBuildCache dirtyCache (efBuildCache externs) -> BuildJobSucceeded warnings externs PublicApiStayedTheSame + _ -> BuildJobSucceeded warnings externs PublicApiChanged + +fastEqBuildCache :: BuildCacheFile -> BuildCacheFile -> Bool +fastEqBuildCache cache externsCache = + let + toCmp (BuildCacheFile bcVersion bcModuleName bcCacheBlob bcCacheDecls bcDeclarations bcDeclShapes _bcCacheDeps) = + -- don't compare imports; it will result in two layers being rebuilt instead of one + BuildCacheFile bcVersion bcModuleName bcCacheBlob bcCacheDecls bcDeclarations bcDeclShapes mempty + in + Serialise.serialise (toCmp cache) == Serialise.serialise (toCmp externsCache) + +buildJobSuccess :: BuildJobResult -> Maybe (MultipleErrors, ExternsFile, DidPublicApiChange) +buildJobSuccess (BuildJobSucceeded warnings externs wasRebuildNeeded) = Just (warnings, externs, wasRebuildNeeded) +buildJobSuccess (BuildJobCacheHit externs) = Just (MultipleErrors [], externs, PublicApiStayedTheSame) buildJobSuccess _ = Nothing + +shouldWeRebuild + :: MonadBaseControl IO m + => ModuleName + -> M.Map ModuleName (MVar BuildJobResult) + -> M.Map ModuleName () + -> m Bool +shouldWeRebuild _moduleName deps directDeps = do + let depChangedAndWeShouldBuild = + \case + BuildJobSucceeded _ _ PublicApiChanged -> True + BuildJobSucceeded _ _ PublicApiStayedTheSame -> False + BuildJobCacheHit _ -> False + BuildJobSkipped -> False + BuildJobFailed _ -> False + + let _bjKey = + \case + BuildJobSucceeded _ _ PublicApiChanged -> "BuildJobSucceeded:PublicApiChanged" :: String + BuildJobSucceeded _ _ PublicApiStayedTheSame -> "BuildJobSucceeded:PublicApiStayedTheSame" :: String + BuildJobCacheHit _ -> "BuildJobCacheHit" :: String + BuildJobFailed _ -> "BuildJobFailed" :: String + BuildJobSkipped -> "BuildJobSkipped" :: String + + -- did any dependency change? + anyUpstreamChanges <- + deps + -- & (\v -> trace (show ("depsExternDecls1" :: String, M.keys v)) v) + & (id :: M.Map ModuleName (MVar BuildJobResult) -> M.Map ModuleName (MVar BuildJobResult)) + & (\keepValues -> M.intersection keepValues directDeps) + -- & (\v -> trace (show ("depsExternDecls2" :: String, M.keys v, "dirtyImportedModules" :: String, dirtyImportedModules)) v) + & (id :: M.Map ModuleName (MVar BuildJobResult) -> M.Map ModuleName (MVar BuildJobResult)) + & traverse tryReadMVar + & fmap (\bjmap -> + bjmap + -- & M.elems + & fmap (fromMaybe (internalError "shouldWeRebuild1: no barrier")) + & M.filter depChangedAndWeShouldBuild + & \case + m | M.null m -> False + _changedDeps -> + -- trace (show ("shouldWeRebuild:yes" :: String, moduleName, "changed" :: String, fmap bjKey changedDeps )) + True + -- v -> + -- trace (show ("shouldWeRebuild:no" :: String, + -- case v of + -- BuildJobSucceeded _ _ PublicApiChanged -> "BuildJobSucceeded:PublicApiChanged" :: String + -- BuildJobSucceeded _ _ PublicApiStayedTheSame -> "BuildJobSucceeded:PublicApiStayedTheSame" :: String + -- BuildJobCacheHit _ -> "BuildJobCacheHit" :: String + -- BuildJobFailed _ -> "BuildJobFailed" :: String + -- BuildJobSkipped -> "BuildJobSkipped" :: String + -- , M.keys directDeps)) + -- False + ) + pure anyUpstreamChanges + -- TODO[drathier]: we can do more here; if a dep changed but we don't import the changed thing, we can consider the dep unchanged + -- | Information obtained about a particular module while constructing a build -- plan; used to decide whether a module needs rebuilding. data RebuildStatus = RebuildStatus @@ -77,6 +186,8 @@ data RebuildStatus = RebuildStatus -- rebuilt according to a RebuildPolicy instead. , statusPrebuilt :: Maybe Prebuilt -- ^ Prebuilt externs and timestamp for this module, if any. + , statusDirtyExterns :: Maybe ExternsFile + -- ^ Prebuilt externs and timestamp for this module, if any, but also present even if the source file is changed. } -- | Called when we finished compiling a module and want to report back the @@ -88,7 +199,7 @@ markComplete -> BuildJobResult -> m () markComplete buildPlan moduleName result = do - let BuildJob rVar = fromMaybe (internalError "make: markComplete no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) + let BuildJob rVar _ _ = fromMaybe (internalError "make: markComplete no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) putMVar rVar result -- | Whether or not the module with the given ModuleName needs to be rebuilt @@ -103,7 +214,7 @@ collectResults => BuildPlan -> m (M.Map ModuleName BuildJobResult) collectResults buildPlan = do - let prebuiltResults = M.map (BuildJobSucceeded (MultipleErrors []) . pbExternsFile) (bpPrebuilt buildPlan) + let prebuiltResults = M.map (buildJobSucceeded Nothing (MultipleErrors []) . pbExternsFile) (bpPrebuilt buildPlan) barrierResults <- traverse (readMVar . bjResult) $ bpBuildJobs buildPlan pure (M.union prebuiltResults barrierResults) @@ -113,13 +224,14 @@ getResult :: (MonadBaseControl IO m) => BuildPlan -> ModuleName - -> m (Maybe (MultipleErrors, ExternsFile)) + -> m (Maybe (MultipleErrors, ExternsFile, DidPublicApiChange)) getResult buildPlan moduleName = case M.lookup moduleName (bpPrebuilt buildPlan) of Just es -> - pure (Just (MultipleErrors [], pbExternsFile es)) + pure (Just (MultipleErrors [], pbExternsFile es, PublicApiStayedTheSame)) Nothing -> do - r <- readMVar $ bjResult $ fromMaybe (internalError "make: no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) + let bj = fromMaybe (internalError "make: no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan) + r <- readMVar $ bjResult bj pure $ buildJobSuccess r -- | Constructs a BuildPlan for the given module graph. @@ -137,34 +249,43 @@ construct MakeActions{..} cacheDb (sorted, graph) = do rebuildStatuses <- A.forConcurrently sortedModuleNames getRebuildStatus let prebuilt = foldl' collectPrebuiltModules M.empty $ - mapMaybe (\s -> (statusModuleName s, statusRebuildNever s,) <$> statusPrebuilt s) rebuildStatuses - let toBeRebuilt = filter (not . flip M.member prebuilt) sortedModuleNames + mapMaybe (\s -> (statusModuleName s, statusRebuildNever s,) <$> statusPrebuilt s) (snd <$> rebuildStatuses) + let toBeRebuilt = filter (not . flip M.member prebuilt . fst) rebuildStatuses + -- _ <- trace (show ("BuildPlan.construct 4 start" :: String, unsafePerformIO dt)) $ pure () buildJobs <- foldM makeBuildJob M.empty toBeRebuilt + -- _ <- trace (show ("BuildPlan.construct 5 start" :: String, unsafePerformIO dt)) $ pure () env <- C.newMVar primEnv idx <- C.newMVar 1 - pure - ( BuildPlan prebuilt buildJobs env idx - , let - update = flip $ \s -> - M.alter (const (statusNewCacheInfo s)) (statusModuleName s) - in - foldl' update cacheDb rebuildStatuses - ) + -- _ <- trace (show ("BuildPlan.construct 6 start" :: String, unsafePerformIO dt)) $ pure () + let res = + ( BuildPlan prebuilt buildJobs env idx + , let + update = flip $ \s -> + M.alter (const (statusNewCacheInfo s)) (statusModuleName s) + in + foldl' update cacheDb (snd <$> rebuildStatuses) + ) + -- trace (show ("BuildPlan.construct 7 end" :: String, unsafePerformIO dt)) $ pure () + pure res where - makeBuildJob prev moduleName = do - buildJob <- BuildJob <$> C.newEmptyMVar + makeBuildJob prev (moduleName, rebuildStatus) = do + buildJobMvar <- C.newEmptyMVar + let buildJob = BuildJob buildJobMvar (statusPrebuilt rebuildStatus) (statusDirtyExterns rebuildStatus) pure (M.insert moduleName buildJob prev) - getRebuildStatus :: ModuleName -> m RebuildStatus - getRebuildStatus moduleName = do + getRebuildStatus :: ModuleName -> m (ModuleName, RebuildStatus) + -- TODO[drathier]: statusDirtyExterns seemingly contains no more info than Prebuilt does; are we filtering Prebuilt but not DirtyExterns somewhere? Why have both? + getRebuildStatus moduleName = (moduleName,) <$> do inputInfo <- getInputTimestampsAndHashes moduleName case inputInfo of Left RebuildNever -> do - prebuilt <- findExistingExtern moduleName + dirtyExterns <- snd <$> readExterns moduleName + prebuilt <- findExistingExtern dirtyExterns moduleName pure (RebuildStatus { statusModuleName = moduleName , statusRebuildNever = True , statusPrebuilt = prebuilt + , statusDirtyExterns = dirtyExterns , statusNewCacheInfo = Nothing }) Left RebuildAlways -> do @@ -172,26 +293,30 @@ construct MakeActions{..} cacheDb (sorted, graph) = do { statusModuleName = moduleName , statusRebuildNever = False , statusPrebuilt = Nothing + , statusDirtyExterns = Nothing , statusNewCacheInfo = Nothing }) Right cacheInfo -> do cwd <- liftBase getCurrentDirectory (newCacheInfo, isUpToDate) <- checkChanged cacheDb moduleName cwd cacheInfo + dirtyExterns <- snd <$> readExterns moduleName prebuilt <- + -- NOTE[fh]: prebuilt is Nothing for source-modified files, and Just for non-source modified files if isUpToDate - then findExistingExtern moduleName + then findExistingExtern dirtyExterns moduleName else pure Nothing pure (RebuildStatus { statusModuleName = moduleName , statusRebuildNever = False , statusPrebuilt = prebuilt + , statusDirtyExterns = dirtyExterns , statusNewCacheInfo = Just newCacheInfo }) - findExistingExtern :: ModuleName -> m (Maybe Prebuilt) - findExistingExtern moduleName = runMaybeT $ do + findExistingExtern :: Maybe ExternsFile -> ModuleName -> m (Maybe Prebuilt) + findExistingExtern mexterns moduleName = runMaybeT $ do timestamp <- MaybeT $ getOutputTimestamp moduleName - externs <- MaybeT $ snd <$> readExterns moduleName + externs <- MaybeT $ pure mexterns pure (Prebuilt timestamp externs) collectPrebuiltModules :: M.Map ModuleName Prebuilt -> (ModuleName, Bool, Prebuilt) -> M.Map ModuleName Prebuilt @@ -202,10 +327,11 @@ construct MakeActions{..} cacheDb (sorted, graph) = do case traverse (fmap pbModificationTime . flip M.lookup prev) deps of Nothing -> -- If we end up here, one of the dependencies didn't exist in the - -- prebuilt map and so we know a dependency needs to be rebuilt, which - -- means we need to be rebuilt in turn. + -- prebuilt map and so we know a dependency might need to be rebuilt, which + -- means we might need to be rebuilt in turn. prev Just modTimes -> + -- TODO[drathier]: this feels too pessimistic, we might not have to rebuild even if a dep was modified; is this code intended to just filter out things we for sure won't have to rebuild, or to exactly say which files we should rebuild? case maximumMaybe modTimes of Just depModTime | pbModificationTime pb < depModTime -> prev diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index cea5fa882f..9778c750c2 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -47,6 +47,7 @@ import qualified System.Directory as Directory import System.FilePath (takeDirectory) import System.IO.Error (tryIOError, isDoesNotExistError) import System.IO.UTF8 (readUTF8FileT) +import Debug.Trace -- | A monad for running make actions newtype Make a = Make @@ -139,6 +140,7 @@ catchDoesNotExist inner = do r <- tryJust (guard . isDoesNotExistError) inner case r of Left () -> + trace ("cborExternsDoesNotExistError") $ return Nothing Right x -> return (Just x) @@ -148,6 +150,7 @@ catchDeserialiseFailure inner = do r <- tryJust fromException inner case r of Left (_ :: Serialise.DeserialiseFailure) -> + trace ("cborExternsDeserialiseFailure") $ return Nothing Right x -> return (Just x) diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index 909f5046f9..2856807289 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -2,6 +2,7 @@ module Language.PureScript.ModuleDependencies ( DependencyDepth(..) , sortModules + , sortModules3 , ModuleGraph , ModuleSignature(..) , moduleSignature @@ -40,21 +41,41 @@ sortModules -> (a -> ModuleSignature) -> [a] -> m ([a], ModuleGraph) -sortModules dependencyDepth toSig ms = do +sortModules dependencyDepth toSig ms = + (\(a,b,_) -> (a,b)) <$> sortModules3 dependencyDepth toSig ms + +-- | Sort a collection of modules based on module dependencies. +-- +-- Reports an error if the module graph contains a cycle. +sortModules3 + :: forall m a + . MonadError MultipleErrors m + => DependencyDepth + -> (a -> ModuleSignature) + -> [a] + -> m ([a], ModuleGraph, ModuleGraph) +sortModules3 dependencyDepth toSig ms = do let ms' = (\m -> (m, toSig m)) <$> ms mns = S.fromList $ map (sigModuleName . snd) ms' verts <- parU ms' (toGraphNode mns) ms'' <- parU (stronglyConnComp verts) toModule let (graph, fromVertex, toVertex) = graphFromEdges verts - moduleGraph = do (_, mn, _) <- verts - let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn) - deps = case dependencyDepth of - Direct -> graph ! v - Transitive -> reachable graph v - toKey i = case fromVertex i of (_, key, _) -> key - return (mn, filter (/= mn) (map toKey deps)) - return (fst <$> ms'', moduleGraph) + -- (moduleGraph, directDeps) :: (ModuleGraph, [ModuleName]) = do + moduleGraph3 :: [(ModuleName, [ModuleName], [ModuleName])] = do + (_, mn, _) <- verts + let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn) + deps = case dependencyDepth of + Direct -> graph ! v + Transitive -> reachable graph v + toKey i = case fromVertex i of (_, key, _) -> key + -- (return :: _) ((mn, filter (/= mn) (map toKey deps)), map toKey (graph ! v)) + return (mn, filter (/= mn) (map toKey deps), map toKey (graph ! v)) + -- [(mn, filter (/= mn) (map toKey deps))] + + moduleGraph = (\(a,b,_) -> (a,b)) <$> moduleGraph3 + directDepsGraph = (\(a,_,c) -> (a,c)) <$> moduleGraph3 + return (fst <$> ms'', moduleGraph, directDepsGraph) where toGraphNode :: S.Set ModuleName -> (a, ModuleSignature) -> m ((a, ModuleSignature), ModuleName, [ModuleName]) toGraphNode mns m@(_, ModuleSignature _ mn deps) = do diff --git a/src/PrettyPrint.hs b/src/PrettyPrint.hs new file mode 100644 index 0000000000..a7467c2bfa --- /dev/null +++ b/src/PrettyPrint.hs @@ -0,0 +1,45 @@ +-- | +module PrettyPrint where + +import Prelude +import qualified Data.Text as T +import Data.Function ((&)) + +-- | +sShow :: Show a => a -> String +sShow a = pformat 0 $! show a -- T.unpack $! pShow a + +-- | +tShow :: Show a => a -> T.Text +tShow a = T.pack $ sShow a + +-- | +pformat :: Int -> String -> String +pformat ident s = + let + nextIsDedent = + case s of + ')':_ -> 1 + ']':_ -> 1 + '}':_ -> 1 + _ -> 0 + ind = repeat ' ' & take ((ident-nextIsDedent)*2) + indl = repeat ' ' & take (((ident-nextIsDedent)-1)*2) + in + case s of + '\n':rest -> "\n" ++ ind ++ pformat ident rest + ':':rest -> ":\n" ++ ind ++ pformat ident rest + ';':rest -> ";\n" ++ ind ++ pformat ident rest + ',':rest -> "\n" ++ indl ++ "," ++ pformat ident rest + '(':')':rest -> "()" ++ pformat ident rest + '[':']':rest -> "[]" ++ pformat ident rest + '(':rest -> "\n" ++ ind ++ "(" ++ pformat (ident+1) rest + '[':rest -> "\n" ++ ind ++ "[" ++ pformat (ident+1) rest + '{':rest -> "\n" ++ ind ++ "{" ++ pformat (ident+1) rest + ')':rest -> ")\n" ++ indl ++ pformat (ident-1) rest + ']':rest -> "]\n" ++ indl ++ pformat (ident-1) rest + '}':rest -> "}\n" ++ indl ++ pformat (ident-1) rest + x:rest -> x : pformat ident rest + [] -> "" + + diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index 9ba778650b..b0629d8c9b 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -77,6 +77,7 @@ ef = P.ExternsFile --, efSourceSpan = (P.internalModuleSourceSpan "") -- } + (P.BuildCacheFile mempty (mn "InstanceModule") mempty mempty mempty mempty mempty) moduleMap :: ModuleMap [IdeDeclarationAnn] moduleMap = Map.singleton (mn "ClassModule") [ideTypeClass "MyClass" P.kindType []] diff --git a/tests/TestMake.hs b/tests/TestMake.hs index 75f422e8ac..e169a13f29 100644 --- a/tests/TestMake.hs +++ b/tests/TestMake.hs @@ -104,9 +104,9 @@ spec = do it "recompiles downstream modules when a module is rebuilt" $ do let moduleAPath = sourcesDir "A.purs" moduleBPath = sourcesDir "B.purs" - moduleAContent1 = "module A where\nfoo = 0\n" - moduleAContent2 = "module A where\nfoo = 1\n" - moduleBContent = "module B where\nimport A (foo)\nbar = foo\n" + moduleAContent1 = "module A where\ndata Foo = Foo | Foo10\n" + moduleAContent2 = "module A where\ndata Foo = Foo | Foo11\n" + moduleBContent = "module B where\nimport A (Foo(..))\nbar = Foo\n" writeFileWithTimestamp moduleAPath timestampA moduleAContent1 writeFileWithTimestamp moduleBPath timestampB moduleBContent @@ -120,10 +120,10 @@ spec = do moduleBPath = sourcesDir "B.purs" moduleCPath = sourcesDir "C.purs" modulePaths = [moduleAPath, moduleBPath, moduleCPath] - moduleAContent1 = "module A where\nfoo = 0\n" - moduleAContent2 = "module A where\nfoo = 1\n" - moduleBContent = "module B where\nimport A (foo)\nbar = foo\n" - moduleCContent = "module C where\nbaz = 3\n" + moduleAContent1 = "module A where\ndata Foo = Foo | Foo20\n" + moduleAContent2 = "module A where\ndata Foo = Foo | Foo21\n" + moduleBContent = "module B where\nimport A (Foo(..))\nbar = Foo\n" + moduleCContent = "module C where\nbaz = 23\n" writeFileWithTimestamp moduleAPath timestampA moduleAContent1 writeFileWithTimestamp moduleBPath timestampB moduleBContent