ref: 467a298ff2034683199996d080b82dca6ee4cfb7
parent: f1cc8a5095c1b7f86ab2d155c6d08ec9f573c5fe
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Wed Mar 27 14:16:23 EDT 2024
Make the Cache more abstract and prepare for packages.
--- a/src/MicroHs/Compile.hs
+++ b/src/MicroHs/Compile.hs
@@ -70,31 +70,30 @@
((cm, t), ch) <- runStateIO (compileModuleCached flags nm) ach
when (verbosityGT flags 0) $
putStrLn $ "total import time " ++ padLeft 6 (show t) ++ "ms"
- return ((tModuleName $ tModuleOf cm, concatMap bindingsOf $ map tModuleOf $ M.elems $ cache ch), ch)
+ return ((tModuleName cm, concatMap bindingsOf $ cachedModules ch), ch)
-- Compile a module with the given name.
-- If the module has already been compiled, return the cached result.
-compileModuleCached :: Flags -> IdentModule -> StateIO Cache (CModule, Time)
+compileModuleCached :: Flags -> IdentModule -> StateIO Cache (TModule [LDef], Time)
compileModuleCached flags mn = do
- ch <- gets cache
- case M.lookup mn ch of
+ cash <- get
+ case lookupCache mn cash of
Nothing -> do
modify $ addWorking mn
when (verbosityGT flags 0) $
liftIO $ putStrLn $ "importing " ++ showIdent mn
- (cm, tp, tt, ts) <- compileModule flags mn
+ (cm@(tm,_,_), tp, tt, ts) <- compileModule flags mn
when (verbosityGT flags 0) $
liftIO $ putStrLn $ "importing done " ++ showIdent mn ++ ", " ++ show (tp + tt) ++
"ms (" ++ show tp ++ " + " ++ show tt ++ ")"when (loading flags && mn /= mkIdent "Interactive") $
liftIO $ putStrLn $ "loaded " ++ showIdent mn
- cash <- get
- put $ workToDone cm cash
- return (cm, tp + tt + ts)
- Just cm -> do
+ modify $ workToDone cm
+ return (tm, tp + tt + ts)
+ Just tm -> do
when (verbosityGT flags 0) $
liftIO $ putStrLn $ "importing cached " ++ showIdent mn
- return (cm, 0)
+ return (tm, 0)
-- Find and compile a module with the given name.
-- The times are (parsing, typecheck+desugar, imported modules)
@@ -120,7 +119,7 @@
(impMdls, ts) <- fmap unzip $ mapM (compileModuleCached flags) imported
t3 <- liftIO getTimeMilli
let
- tmdl = typeCheck (zip specs (map tModuleOf impMdls)) mdl
+ tmdl = typeCheck (zip specs impMdls) mdl
when (verbosityGT flags 2) $
liftIO $ putStrLn $ "type checked:\n" ++ showTModule showEDefs tmdl ++ "-----\n"
let
@@ -129,7 +128,7 @@
t4 <- liftIO getTimeMilli
when (verbosityGT flags 3) $
(liftIO $ putStrLn $ "desugared:\n" ++ showTModule showLDefs dmdl)
- let cmdl = CModule dmdl imported chksum
+ let cmdl = (dmdl, imported, chksum)
return (cmdl, t2-t1, t4-t3, sum ts)
addPreludeImport :: EModule -> EModule
@@ -149,12 +148,13 @@
-------------------------------------------
validateCache :: Flags -> Cache -> IO Cache
-validateCache flags cash = execStateIO (mapM_ validate (M.keys (cache cash))) cash
+validateCache flags acash = execStateIO (mapM_ (validate . fst) fdeps) acash
where
- deps = invertGraph [ (tModuleName tm, imps) | CModule tm imps _ <- M.elems (cache cash) ]
+ fdeps = getImportDeps acash -- forwards dependencies
+ deps = invertGraph fdeps -- backwards dependencies
invalidate :: IdentModule -> StateIO Cache ()
invalidate mn = do
- b <- gets $ isJust . M.lookup mn . cache
+ b <- gets $ isJust . lookupCache mn
when b $ do
-- It's still in the cache, so invalidate it, and all modules that import it
when (verbosityGT flags 0) $
@@ -163,10 +163,10 @@
mapM_ invalidate $ fromMaybe [] $ M.lookup mn deps
validate :: IdentModule -> StateIO Cache ()
validate mn = do
- ch <- get
- case M.lookup mn (cache ch) of
+ cash <- get
+ case lookupCacheChksum mn cash of
Nothing -> return () -- no longer in the cache, so just ignore.
- Just (CModule _ _ chksum) -> do
+ Just chksum -> do
mhdl <- liftIO $ findModulePath flags mn
case mhdl of
Nothing ->
--- a/src/MicroHs/CompileCache.hs
+++ b/src/MicroHs/CompileCache.hs
@@ -1,6 +1,8 @@
module MicroHs.CompileCache(
- CModule(..), tModuleOf,
- Cache, cache, addWorking, emptyCache, deleteFromCache, workToDone,
+ CModule,
+ Cache, addWorking, emptyCache, deleteFromCache, workToDone,
+ cachedModules, lookupCache, lookupCacheChksum, getImportDeps,
+ addPackage,
saveCache, loadCached,
) where
import Prelude
@@ -8,32 +10,44 @@
import MicroHs.Expr(IdentModule)
import MicroHs.Ident(showIdent)
import qualified MicroHs.IdentMap as M
-import MicroHs.TypeCheck(TModule)
+import MicroHs.Package
+import MicroHs.TypeCheck(TModule, tModuleName)
import System.IO
import System.IO.Serialize
import System.IO.MD5(MD5CheckSum)
import Compat
-data CModule = CModule
+type CModule = (TModule [LDef], [IdentModule], MD5CheckSum)
+
+data CacheEntry =
+ CompMdl -- module compiled in in this session
(TModule [LDef]) -- the cached module
[IdentModule] -- imported module names
MD5CheckSum -- checksum of the source file
+ | PkgMdl -- module from a package
+ (TModule [LDef]) -- the cached module
-- deriving (Show)
-tModuleOf :: CModule -> TModule [LDef]
-tModuleOf (CModule t _ _) = t
+tModuleOf :: CacheEntry -> TModule [LDef]
+tModuleOf (CompMdl t _ _) = t
+tModuleOf (PkgMdl t) = t
+chksumOf :: CacheEntry -> MD5CheckSum
+chksumOf (CompMdl _ _ k) = k
+chksumOf _ = undefined
+
data Cache = Cache {working :: [IdentModule], -- modules currently being processed (used to detected circular imports)
- cache :: M.Map CModule -- cached compiled modules
+ cache :: M.Map CacheEntry, -- cached compiled modules
+ pkgs :: [Package] -- loaded packages
}
-- deriving (Show)
emptyCache :: Cache
-emptyCache = Cache [] M.empty
+emptyCache = Cache { working = [], cache = M.empty, pkgs = [] }deleteFromCache :: IdentModule -> Cache -> Cache
-deleteFromCache mn (Cache is m) = Cache is (M.delete mn m)
+deleteFromCache mn c = c{ cache = M.delete mn (cache c) }addWorking :: IdentModule -> Cache -> Cache
addWorking mn c =
@@ -44,8 +58,24 @@
c{ working = mn : ws }workToDone :: CModule -> Cache -> Cache
-workToDone cm (Cache (mn:ws) m) = Cache ws (M.insert mn cm m)
+workToDone (t, i, k) c@(Cache{ working = mn:ws, cache = m }) = c{ working = ws, cache = M.insert mn (CompMdl t i k) m }workToDone _ _ = undefined
+
+cachedModules :: Cache -> [TModule [LDef]]
+cachedModules = map tModuleOf . M.elems . cache
+
+lookupCache :: IdentModule -> Cache -> Maybe (TModule [LDef])
+lookupCache mn c = tModuleOf <$> M.lookup mn (cache c)
+
+lookupCacheChksum :: IdentModule -> Cache -> Maybe MD5CheckSum
+lookupCacheChksum mn c = chksumOf <$> M.lookup mn (cache c)
+
+getImportDeps :: Cache -> [(IdentModule, [IdentModule])]
+getImportDeps cash = [ (tModuleName tm, imps) | CompMdl tm imps _ <- M.elems (cache cash) ]
+
+addPackage :: Package -> Cache -> Cache
+addPackage p c = c{ pkgs = p : pkgs c, cache = foldr ins (cache c) (pkgExported p) }+ where ins t = M.insert (tModuleName t) (PkgMdl t)
saveCache :: FilePath -> Cache -> IO ()
saveCache fn cash = writeSerializedCompressed fn cash
--- a/src/MicroHs/Interactive.hs
+++ b/src/MicroHs/Interactive.hs
@@ -8,7 +8,6 @@
import MicroHs.Expr(EType, showEType)
import MicroHs.Flags
import MicroHs.Ident(mkIdent, Ident)
-import qualified MicroHs.IdentMap as M
import MicroHs.Parse
import MicroHs.StateIO
import MicroHs.SymTab(Entry(..))
@@ -246,20 +245,20 @@
Left e ->
liftIO $ err e
-getCModule :: Cache -> CModule
+getCModule :: Cache -> TModule [LDef]
getCModule cash =
- case M.lookup interactiveId (cache cash) of
+ case lookupCache interactiveId cash of
Nothing -> undefined -- this cannot happen
Just cm -> cm
getTypeInCache :: Cache -> Ident -> EType
getTypeInCache cash i =
- case tModuleOf (getCModule cash) of
+ case getCModule cash of
TModule _ _ _ _ _ _ vals _ ->
head $ [ t | ValueExport i' (Entry _ t) <- vals, i == i' ] ++ [undefined]
getKindInCache :: Cache -> Ident -> EType
getKindInCache cash i =
- case tModuleOf (getCModule cash) of
+ case getCModule cash of
TModule _ _ tys _ _ _ _ _ ->
head $ [ k | TypeExport i' (Entry _ k) _ <- tys, i == i' ] ++ [undefined]
--- a/src/MicroHs/Package.hs
+++ b/src/MicroHs/Package.hs
@@ -1,31 +1,34 @@
module MicroHs.Package(
- PackageName, PackageVersion,
+ IdentPackage,
Package(..),
) where
+import Data.Version
import MicroHs.Desugar(LDef)
+import MicroHs.Ident(Ident)
import MicroHs.TypeCheck(TModule)
--
--- Packages are organized as follows.
--- The environment variable $PKGDIR determines the location,
--- with the default $HOME/.mcabal/packages
--- The file $PKGDIR/toc.txt the the table of contents.
--- Each line is the name of a package followed by the exported modules.
--- For each package 'foo' there is a serialized package
--- in $PKGDIR/foo.pkg
--- On startup the table of contents is read.
--- From this we get a map from module names to package file names.
--- On first use of a package module, we load the corresponding package file.
--- There is also a map from package names to loaded packages.
+-- Packages are organized as follows:
+-- There is a package search path (default is ~/.mcabal/mhs-VERSION/)
+-- In this directory there is a subdirectory, packages, that contains a
+-- serialized Package for each installed package.
+-- There is also a file for each exported module that contains just
+-- the package name.
+-- So if we have a package foo, exporting modules Foo.Bar and Foo.baz
+-- we would have the following directory structure
+-- packages/foo.pkg
+-- Foo/Bar
+-- Foo/Baz
+-- The files Foo/Bar and Foo/Baz will contain simply "foo".
--
+type IdentPackage = Ident
-type PackageName = String
-type PackageVersion = String
-
data Package = Package {- pkgName :: PackageName, -- package name
- pkgVersion :: PackageVersion, -- package version
- pkgExported :: [TModule [LDef]] -- exported modules
- pkgOther :: [TModule [LDef]] -- non-exported modules
- pkgDepends :: [(PackageName, PackageVersion)] -- used packages
+ pkgName :: IdentPackage, -- package name
+ pkgVersion :: Version, -- package version
+ pkgExported :: [TModule [LDef]], -- exported modules
+ pkgOther :: [TModule [LDef]], -- non-exported modules
+ pkgDepends :: [(IdentPackage, Version)] -- used packages
+ }
+ -- deriving (Show)
--
⑨