From 557bfeb92954c6311b616138cc825e5eb2701aa0 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Mon, 10 Feb 2025 14:51:01 +0100 Subject: [PATCH 01/24] add Stripped.Module --- src/Juvix/Compiler/Core/Data/InfoTable.hs | 10 ------ src/Juvix/Compiler/Core/Data/Module.hs | 36 ++----------------- src/Juvix/Compiler/Core/Data/Module/Base.hs | 35 ++++++++++++++++++ .../Compiler/Core/Data/Stripped/InfoTable.hs | 1 + .../Compiler/Core/Data/Stripped/Module.hs | 11 ++++++ .../Compiler/Core/Translation/FromInternal.hs | 6 ++-- .../Compiler/Core/Translation/FromSource.hs | 2 +- src/Juvix/Compiler/Internal/Data/InfoTable.hs | 12 +++++-- .../Internal/Translation/FromInternal.hs | 4 +-- src/Juvix/Compiler/Pipeline/Modular.hs | 1 + src/Juvix/Compiler/Store/Internal/Language.hs | 2 +- 11 files changed, 68 insertions(+), 52 deletions(-) create mode 100644 src/Juvix/Compiler/Core/Data/Module/Base.hs create mode 100644 src/Juvix/Compiler/Core/Data/Stripped/Module.hs create mode 100644 src/Juvix/Compiler/Pipeline/Modular.hs diff --git a/src/Juvix/Compiler/Core/Data/InfoTable.hs b/src/Juvix/Compiler/Core/Data/InfoTable.hs index bee0140fa1..e226df5d34 100644 --- a/src/Juvix/Compiler/Core/Data/InfoTable.hs +++ b/src/Juvix/Compiler/Core/Data/InfoTable.hs @@ -146,13 +146,3 @@ pruneInfoTable' tab = ) ) tab' - -tableIsFragile :: InfoTable -> Bool -tableIsFragile tab = any isFragile (HashMap.elems $ tab ^. infoIdentifiers) - where - isFragile :: IdentifierInfo -> Bool - isFragile IdentifierInfo {..} = - case _identifierPragmas ^. pragmasInline of - Just InlineAlways -> True - Just InlineCase -> True - _ -> False diff --git a/src/Juvix/Compiler/Core/Data/Module.hs b/src/Juvix/Compiler/Core/Data/Module.hs index f2a3ce5239..61b86cd7e5 100644 --- a/src/Juvix/Compiler/Core/Data/Module.hs +++ b/src/Juvix/Compiler/Core/Data/Module.hs @@ -1,43 +1,16 @@ module Juvix.Compiler.Core.Data.Module ( module Juvix.Compiler.Core.Data.Module, + module Juvix.Compiler.Core.Data.Module.Base, module Juvix.Compiler.Core.Data.InfoTable, ) where import Juvix.Compiler.Core.Data.InfoTable +import Juvix.Compiler.Core.Data.Module.Base import Juvix.Compiler.Core.Language import Juvix.Compiler.Core.Pretty -data Module = Module - { _moduleId :: ModuleId, - _moduleInfoTable :: InfoTable, - -- | The imports table contains all dependencies, transitively. E.g., if the - -- module M imports A but not B, but A imports B, then all identifiers from - -- B will be in the imports table of M nonetheless. - _moduleImportsTable :: InfoTable - } - deriving stock (Generic) - -instance NFData Module - -makeLenses ''Module - -withInfoTable :: (Module -> Module) -> InfoTable -> InfoTable -withInfoTable f tab = - f (moduleFromInfoTable tab) ^. moduleInfoTable - -emptyModule :: Module -emptyModule = Module defaultModuleId mempty mempty - -moduleFromInfoTable :: InfoTable -> Module -moduleFromInfoTable tab = Module defaultModuleId tab mempty - -computeCombinedIdentContext :: Module -> IdentContext -computeCombinedIdentContext Module {..} = - _moduleInfoTable ^. identContext <> _moduleImportsTable ^. identContext - -computeCombinedInfoTable :: Module -> InfoTable -computeCombinedInfoTable Module {..} = _moduleInfoTable <> _moduleImportsTable +type Module = Module' InfoTable lookupInductiveInfo' :: Module -> Symbol -> Maybe InductiveInfo lookupInductiveInfo' Module {..} sym = @@ -125,6 +98,3 @@ freshIdentName m = freshName (identNames m) pruneInfoTable :: Module -> Module pruneInfoTable = over moduleInfoTable pruneInfoTable' - -moduleIsFragile :: Module -> Bool -moduleIsFragile Module {..} = tableIsFragile _moduleInfoTable diff --git a/src/Juvix/Compiler/Core/Data/Module/Base.hs b/src/Juvix/Compiler/Core/Data/Module/Base.hs new file mode 100644 index 0000000000..b38107d769 --- /dev/null +++ b/src/Juvix/Compiler/Core/Data/Module/Base.hs @@ -0,0 +1,35 @@ +module Juvix.Compiler.Core.Data.Module.Base where + +import Juvix.Compiler.Core.Language + +data Module' t = Module + { _moduleId :: ModuleId, + _moduleInfoTable :: t, + -- | The imports field contains all direct (non-transitive) dependencies of + -- the module. + _moduleImports :: [ModuleId], + -- | The imports table contains all dependencies, transitively. E.g., if the + -- module M imports A but not B, but A imports B, then all identifiers from + -- B will be in the imports table of M nonetheless. + _moduleImportsTable :: t + } + deriving stock (Generic) + +instance (Serialize t) => Serialize (Module' t) + +instance (NFData t) => NFData (Module' t) + +makeLenses ''Module' + +withInfoTable :: (Monoid t) => (Module' t -> Module' t) -> t -> t +withInfoTable f tab = + f (moduleFromInfoTable tab) ^. moduleInfoTable + +emptyModule :: (Monoid t) => Module' t +emptyModule = Module defaultModuleId mempty mempty mempty + +moduleFromInfoTable :: (Monoid t) => t -> Module' t +moduleFromInfoTable tab = Module defaultModuleId tab mempty mempty + +computeCombinedInfoTable :: (Monoid t) => Module' t -> t +computeCombinedInfoTable Module {..} = _moduleInfoTable <> _moduleImportsTable diff --git a/src/Juvix/Compiler/Core/Data/Stripped/InfoTable.hs b/src/Juvix/Compiler/Core/Data/Stripped/InfoTable.hs index 01ebb2706e..196ebe75c3 100644 --- a/src/Juvix/Compiler/Core/Data/Stripped/InfoTable.hs +++ b/src/Juvix/Compiler/Core/Data/Stripped/InfoTable.hs @@ -8,6 +8,7 @@ data InfoTable = InfoTable _infoFunctions :: HashMap Symbol FunctionInfo, _infoInductives :: HashMap Symbol InductiveInfo, _infoConstructors :: HashMap Tag ConstructorInfo, + -- Used only by the JuvixTree evaluator _infoFieldSize :: Natural } diff --git a/src/Juvix/Compiler/Core/Data/Stripped/Module.hs b/src/Juvix/Compiler/Core/Data/Stripped/Module.hs new file mode 100644 index 0000000000..36818998f7 --- /dev/null +++ b/src/Juvix/Compiler/Core/Data/Stripped/Module.hs @@ -0,0 +1,11 @@ +module Juvix.Compiler.Core.Data.Stripped.Module + ( module Juvix.Compiler.Core.Data.Stripped.Module, + module Juvix.Compiler.Core.Data.Module.Base, + module Juvix.Compiler.Core.Data.Stripped.InfoTable, + ) +where + +import Juvix.Compiler.Core.Data.Module.Base +import Juvix.Compiler.Core.Data.Stripped.InfoTable + +type Module = Module' InfoTable diff --git a/src/Juvix/Compiler/Core/Translation/FromInternal.hs b/src/Juvix/Compiler/Core/Translation/FromInternal.hs index ad79224b62..a886e6a62e 100644 --- a/src/Juvix/Compiler/Core/Translation/FromInternal.hs +++ b/src/Juvix/Compiler/Core/Translation/FromInternal.hs @@ -70,10 +70,12 @@ fromInternal :: fromInternal i = mapError (JuvixError . ErrBadScope) $ do importTab <- asks Store.getInternalModuleTable coreImportsTab <- asks Store.computeCombinedCoreInfoTable - let md = + let imd = i ^. InternalTyped.resultInternalModule + md = Module - { _moduleId = i ^. InternalTyped.resultInternalModule . Internal.internalModuleId, + { _moduleId = imd ^. Internal.internalModuleId, _moduleInfoTable = mempty, + _moduleImports = imd ^. Internal.internalModuleImports, _moduleImportsTable = coreImportsTab } tabs = i ^. InternalTyped.resultTypeCheckingTables diff --git a/src/Juvix/Compiler/Core/Translation/FromSource.hs b/src/Juvix/Compiler/Core/Translation/FromSource.hs index f8bd753fb4..d71158475f 100644 --- a/src/Juvix/Compiler/Core/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Core/Translation/FromSource.hs @@ -33,7 +33,7 @@ runParser :: Path Abs File -> ModuleId -> InfoTable -> Text -> Either JuvixError runParser fileName mid tab input_ = case run $ runError @CoreError $ - runInfoTableBuilder (Module mid tab mempty) $ + runInfoTableBuilder (Module mid tab mempty mempty) $ P.runParserT parseToplevel (fromAbsFile fileName) input_ of Left err -> Left (JuvixError err) Right (_, Left err) -> Left (JuvixError (MegaparsecError err)) diff --git a/src/Juvix/Compiler/Internal/Data/InfoTable.hs b/src/Juvix/Compiler/Internal/Data/InfoTable.hs index 48d818d06b..92f798314b 100644 --- a/src/Juvix/Compiler/Internal/Data/InfoTable.hs +++ b/src/Juvix/Compiler/Internal/Data/InfoTable.hs @@ -81,12 +81,18 @@ letFunctionDefs e = LetFunDef f -> pure f LetMutualBlock (MutualBlockLet fs) -> fs -computeInternalModule :: TypeCheckingTables -> Module -> InternalModule -computeInternalModule tabs m@Module {..} = +computeInternalModule :: InternalModuleTable -> TypeCheckingTables -> Module -> InternalModule +computeInternalModule itab tabs m@Module {..} = InternalModule { _internalModuleId = _moduleId, _internalModuleName = _moduleName, - _internalModuleImports = _moduleBody ^. moduleImports, + _internalModuleImports = + map + ( (^. internalModuleId) + . lookupInternalModule itab + . (^. importModuleName) + ) + (_moduleBody ^. moduleImports), _internalModuleInfoTable = computeInternalModuleInfoTable m, _internalModuleTypeCheckingTables = tabs } diff --git a/src/Juvix/Compiler/Internal/Translation/FromInternal.hs b/src/Juvix/Compiler/Internal/Translation/FromInternal.hs index b522cfd2c7..fd02c80bb7 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromInternal.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromInternal.hs @@ -24,9 +24,9 @@ typeCheckingNew :: Sem (Termination ': r) InternalResult -> Sem r InternalTypedResult typeCheckingNew a = do + itab :: InternalModuleTable <- getInternalModuleTable <$> ask (termin, (res, (bst, checkedModule))) <- runTermination iniTerminationState $ do res :: InternalResult <- a - itab :: InternalModuleTable <- getInternalModuleTable <$> ask stab :: ScopedModuleTable <- getScopedModuleTable <$> ask let table :: InfoTable table = Internal.computeCombinedInfoTable itab <> computeInternalModuleInfoTable (res ^. Internal.resultModule) @@ -41,7 +41,7 @@ typeCheckingNew a = do . runResultBuilder importCtx . mapError (JuvixError @TypeCheckerError) $ checkTopModule (res ^. Internal.resultModule) - let md = computeInternalModule (bst ^. resultBuilderStateTables) checkedModule + let md = computeInternalModule itab (bst ^. resultBuilderStateTables) checkedModule return InternalTypedResult { _resultInternal = res, diff --git a/src/Juvix/Compiler/Pipeline/Modular.hs b/src/Juvix/Compiler/Pipeline/Modular.hs new file mode 100644 index 0000000000..a11488518f --- /dev/null +++ b/src/Juvix/Compiler/Pipeline/Modular.hs @@ -0,0 +1 @@ +module Juvix.Compiler.Pipeline.Modular where diff --git a/src/Juvix/Compiler/Store/Internal/Language.hs b/src/Juvix/Compiler/Store/Internal/Language.hs index 3a0b407b1b..a1cc03b32f 100644 --- a/src/Juvix/Compiler/Store/Internal/Language.hs +++ b/src/Juvix/Compiler/Store/Internal/Language.hs @@ -18,7 +18,7 @@ import Juvix.Prelude data InternalModule = InternalModule { _internalModuleId :: ModuleId, _internalModuleName :: Name, - _internalModuleImports :: [Import], + _internalModuleImports :: [ModuleId], _internalModuleInfoTable :: InfoTable, _internalModuleTypeCheckingTables :: TypeCheckingTables } From 1ee34c5eb36b6ee3d7fbdeffbec1906259d359d7 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Mon, 10 Feb 2025 17:19:02 +0100 Subject: [PATCH 02/24] remove infoFieldSize from info tables --- src/Juvix/Compiler/Asm/Translation/FromTree.hs | 3 +-- src/Juvix/Compiler/Reg/Translation/FromAsm.hs | 3 +-- src/Juvix/Compiler/Tree/Data/InfoTable/Base.hs | 7 ++----- src/Juvix/Compiler/Tree/Evaluator/Builtins.hs | 2 +- src/Juvix/Compiler/Tree/Translation/FromAsm.hs | 3 +-- src/Juvix/Compiler/Tree/Translation/FromCore.hs | 3 +-- 6 files changed, 7 insertions(+), 14 deletions(-) diff --git a/src/Juvix/Compiler/Asm/Translation/FromTree.hs b/src/Juvix/Compiler/Asm/Translation/FromTree.hs index ea5f2d3b0d..cd15c174d8 100644 --- a/src/Juvix/Compiler/Asm/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Asm/Translation/FromTree.hs @@ -16,8 +16,7 @@ fromTree tab = { _infoMainFunction = tab ^. Tree.infoMainFunction, _infoFunctions = genCode <$> tab ^. Tree.infoFunctions, _infoInductives = tab ^. Tree.infoInductives, - _infoConstrs = tab ^. Tree.infoConstrs, - _infoFieldSize = tab ^. Tree.infoFieldSize + _infoConstrs = tab ^. Tree.infoConstrs } -- Generate code for a single function. diff --git a/src/Juvix/Compiler/Reg/Translation/FromAsm.hs b/src/Juvix/Compiler/Reg/Translation/FromAsm.hs index 9527ca82d7..49a619dcb9 100644 --- a/src/Juvix/Compiler/Reg/Translation/FromAsm.hs +++ b/src/Juvix/Compiler/Reg/Translation/FromAsm.hs @@ -14,8 +14,7 @@ fromAsm tab = { _infoFunctions = HashMap.map convertFun (tab ^. Asm.infoFunctions), _infoConstrs = HashMap.map convertConstr (tab ^. Asm.infoConstrs), _infoInductives = HashMap.map convertInductive (tab ^. Asm.infoInductives), - _infoMainFunction = tab ^. Asm.infoMainFunction, - _infoFieldSize = tab ^. Asm.infoFieldSize + _infoMainFunction = tab ^. Asm.infoMainFunction } where convertFun :: Asm.FunctionInfo -> FunctionInfo diff --git a/src/Juvix/Compiler/Tree/Data/InfoTable/Base.hs b/src/Juvix/Compiler/Tree/Data/InfoTable/Base.hs index b8137695a5..cbf57bbefa 100644 --- a/src/Juvix/Compiler/Tree/Data/InfoTable/Base.hs +++ b/src/Juvix/Compiler/Tree/Data/InfoTable/Base.hs @@ -9,14 +9,12 @@ import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Tree.Language import Juvix.Compiler.Tree.Language.Rep import Juvix.Compiler.Tree.Language.Type -import Juvix.Data.Field data InfoTable' code extra = InfoTable { _infoFunctions :: HashMap Symbol (FunctionInfo' code extra), _infoConstrs :: HashMap Tag ConstructorInfo, _infoInductives :: HashMap Symbol InductiveInfo, - _infoMainFunction :: Maybe Symbol, - _infoFieldSize :: Natural + _infoMainFunction :: Maybe Symbol } data FunctionInfo' code extra = FunctionInfo @@ -72,8 +70,7 @@ emptyInfoTable = { _infoFunctions = mempty, _infoConstrs = mempty, _infoInductives = mempty, - _infoMainFunction = Nothing, - _infoFieldSize = defaultFieldSize + _infoMainFunction = Nothing } lookupFunInfo :: InfoTable' a e -> Symbol -> FunctionInfo' a e diff --git a/src/Juvix/Compiler/Tree/Evaluator/Builtins.hs b/src/Juvix/Compiler/Tree/Evaluator/Builtins.hs index d9c1fda4f9..94eef1204d 100644 --- a/src/Juvix/Compiler/Tree/Evaluator/Builtins.hs +++ b/src/Juvix/Compiler/Tree/Evaluator/Builtins.hs @@ -98,7 +98,7 @@ evalUnop tab op v = case op of goIntToField :: Value -> Either ErrorMsg Value goIntToField = \case ValInteger i -> - Right $ ValField $ fieldFromInteger (tab ^. infoFieldSize) i + Right $ ValField $ fieldFromInteger defaultFieldSize i _ -> Left "expected an integer" diff --git a/src/Juvix/Compiler/Tree/Translation/FromAsm.hs b/src/Juvix/Compiler/Tree/Translation/FromAsm.hs index 956ecc6692..042df8c166 100644 --- a/src/Juvix/Compiler/Tree/Translation/FromAsm.hs +++ b/src/Juvix/Compiler/Tree/Translation/FromAsm.hs @@ -23,8 +23,7 @@ fromAsm tab = do { _infoMainFunction = tab ^. Asm.infoMainFunction, _infoFunctions = fns, _infoInductives = tab ^. Asm.infoInductives, - _infoConstrs = tab ^. Asm.infoConstrs, - _infoFieldSize = tab ^. Asm.infoFieldSize + _infoConstrs = tab ^. Asm.infoConstrs } goFunction :: (Member (Error TreeError) r') => Asm.InfoTable -> Asm.FunctionInfo -> Sem r' FunctionInfo diff --git a/src/Juvix/Compiler/Tree/Translation/FromCore.hs b/src/Juvix/Compiler/Tree/Translation/FromCore.hs index e8f41766e6..72793f075d 100644 --- a/src/Juvix/Compiler/Tree/Translation/FromCore.hs +++ b/src/Juvix/Compiler/Tree/Translation/FromCore.hs @@ -17,8 +17,7 @@ fromCore tab = { _infoMainFunction = tab ^. Core.infoMain, _infoFunctions = genCode tab <$> tab ^. Core.infoFunctions, _infoInductives = translateInductiveInfo <$> tab ^. Core.infoInductives, - _infoConstrs = translateConstructorInfo <$> tab ^. Core.infoConstructors, - _infoFieldSize = tab ^. Core.infoFieldSize + _infoConstrs = translateConstructorInfo <$> tab ^. Core.infoConstructors } toTreeOp :: Core.BuiltinOp -> TreeOp From 5991c48b76e434a7781a30450134732a8489d71b Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Mon, 10 Feb 2025 19:00:29 +0100 Subject: [PATCH 03/24] Store.Backend --- src/Juvix/Compiler/Backend.hs | 19 ++++++++- src/Juvix/Compiler/Core/Data/Module/Base.hs | 4 +- .../Compiler/Store/Backend/Module/Base.hs | 32 +++++++++++++++ src/Juvix/Compiler/Store/Backend/Options.hs | 40 +++++++++++++++++++ src/Juvix/Compiler/Store/Backend/Stripped.hs | 1 + 5 files changed, 94 insertions(+), 2 deletions(-) create mode 100644 src/Juvix/Compiler/Store/Backend/Module/Base.hs create mode 100644 src/Juvix/Compiler/Store/Backend/Options.hs create mode 100644 src/Juvix/Compiler/Store/Backend/Stripped.hs diff --git a/src/Juvix/Compiler/Backend.hs b/src/Juvix/Compiler/Backend.hs index 6f6bb785f0..27c99cb7f4 100644 --- a/src/Juvix/Compiler/Backend.hs +++ b/src/Juvix/Compiler/Backend.hs @@ -1,6 +1,7 @@ module Juvix.Compiler.Backend where import GHC.Base (maxInt) +import Juvix.Extra.Serialize import Juvix.Prelude data Target @@ -13,7 +14,11 @@ data Target | TargetRust | TargetAnoma | TargetCairo - deriving stock (Data, Eq, Show) + deriving stock (Data, Eq, Show, Generic) + +instance Serialize Target + +instance NFData Target data Limits = Limits { _limitsMaxConstrs :: Int, @@ -137,3 +142,15 @@ defaultLimits = _limitsBuiltinUIDsNum = maxInt, _limitsSpecialisedApply = 0 } + +getTargetSubdir :: Target -> Path Rel Dir +getTargetSubdir = \case + TargetCWasm32Wasi -> $(mkRelDir "wasm32-wasi") + TargetCNative64 -> $(mkRelDir "native64") + TargetCore -> $(mkRelDir "default") + TargetAsm -> $(mkRelDir "default") + TargetReg -> $(mkRelDir "default") + TargetTree -> $(mkRelDir "tree") + TargetRust -> $(mkRelDir "rust") + TargetAnoma -> $(mkRelDir "anoma") + TargetCairo -> $(mkRelDir "cairo") diff --git a/src/Juvix/Compiler/Core/Data/Module/Base.hs b/src/Juvix/Compiler/Core/Data/Module/Base.hs index b38107d769..25ab337aa2 100644 --- a/src/Juvix/Compiler/Core/Data/Module/Base.hs +++ b/src/Juvix/Compiler/Core/Data/Module/Base.hs @@ -1,6 +1,8 @@ module Juvix.Compiler.Core.Data.Module.Base where -import Juvix.Compiler.Core.Language +import Juvix.Data.ModuleId +import Juvix.Extra.Serialize +import Juvix.Prelude data Module' t = Module { _moduleId :: ModuleId, diff --git a/src/Juvix/Compiler/Store/Backend/Module/Base.hs b/src/Juvix/Compiler/Store/Backend/Module/Base.hs new file mode 100644 index 0000000000..750331448c --- /dev/null +++ b/src/Juvix/Compiler/Store/Backend/Module/Base.hs @@ -0,0 +1,32 @@ +module Juvix.Compiler.Store.Backend.Module.Base where + +import Juvix.Compiler.Store.Backend.Options +import Juvix.Data.ModuleId +import Juvix.Extra.Serialize +import Juvix.Prelude + +data Module' t = Module + { _moduleId :: ModuleId, + _moduleInfoTable :: t, + -- | The imports field contains all direct (non-transitive) dependencies of + -- the module. + _moduleImports :: [ModuleId], + _moduleOptions :: Options + } + deriving stock (Generic) + +instance (Serialize t) => Serialize (Module' t) + +instance (NFData t) => NFData (Module' t) + +makeLenses ''Module' + +newtype ModuleTable' t = ModuleTable + { _moduleTable :: HashMap ModuleId (Module' t) + } + deriving newtype (Semigroup, Monoid) + deriving stock (Generic) + +makeLenses ''ModuleTable' + +instance (NFData t) => NFData (ModuleTable' t) diff --git a/src/Juvix/Compiler/Store/Backend/Options.hs b/src/Juvix/Compiler/Store/Backend/Options.hs new file mode 100644 index 0000000000..865b9e5f8b --- /dev/null +++ b/src/Juvix/Compiler/Store/Backend/Options.hs @@ -0,0 +1,40 @@ +module Juvix.Compiler.Store.Backend.Options where + +import Juvix.Compiler.Backend +import Juvix.Compiler.Pipeline.EntryPoint +import Juvix.Extra.Serialize +import Juvix.Prelude +import Path qualified + +data Options = Options + { _optionsDebug :: Bool, + _optionsOptimizationLevel :: Int, + _optionsFieldSize :: Natural, + _optionsTarget :: Maybe Target + } + deriving stock (Show, Eq, Generic) + +instance Serialize Options + +instance NFData Options + +makeLenses ''Options + +fromEntryPoint :: EntryPoint -> Options +fromEntryPoint EntryPoint {..} = + Options + { _optionsDebug = _entryPointDebug, + _optionsOptimizationLevel = _entryPointOptimizationLevel, + _optionsFieldSize = _entryPointFieldSize, + _optionsTarget = _entryPointTarget + } + +getOptionsSubdir :: Options -> Path Rel Dir +getOptionsSubdir opts = + subdir1 + Path. maybe $(mkRelDir "default") getTargetSubdir (opts ^. optionsTarget) + where + subdir1 = + if + | opts ^. optionsDebug -> $(mkRelDir "debug") + | otherwise -> $(mkRelDir "release") diff --git a/src/Juvix/Compiler/Store/Backend/Stripped.hs b/src/Juvix/Compiler/Store/Backend/Stripped.hs new file mode 100644 index 0000000000..f3180e73a5 --- /dev/null +++ b/src/Juvix/Compiler/Store/Backend/Stripped.hs @@ -0,0 +1 @@ +module Juvix.Compiler.Store.Backend.Stripped where From 1071530f1f1e3d863d94900baccd2af93a98c3be Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Mon, 10 Feb 2025 20:03:45 +0100 Subject: [PATCH 04/24] Core.Stripped.Module --- app/Commands/Dev/Core/Strip.hs | 2 +- src/Juvix/Compiler/Core/Data/Stripped/InfoTable.hs | 11 ++++++----- src/Juvix/Compiler/Core/Data/Stripped/Module.hs | 9 +++++++++ src/Juvix/Compiler/Core/Pretty/Base.hs | 2 +- src/Juvix/Compiler/Core/Translation/FromInternal.hs | 4 ++-- .../Compiler/Core/Translation/Stripped/FromCore.hs | 7 +++---- src/Juvix/Compiler/Pipeline.hs | 3 +-- .../Store/Backend/{Module/Base.hs => Module.hs} | 2 +- src/Juvix/Compiler/Store/Backend/Stripped.hs | 1 - 9 files changed, 24 insertions(+), 17 deletions(-) rename src/Juvix/Compiler/Store/Backend/{Module/Base.hs => Module.hs} (93%) delete mode 100644 src/Juvix/Compiler/Store/Backend/Stripped.hs diff --git a/app/Commands/Dev/Core/Strip.hs b/app/Commands/Dev/Core/Strip.hs index 33dacd2754..b95f1e4de9 100644 --- a/app/Commands/Dev/Core/Strip.hs +++ b/app/Commands/Dev/Core/Strip.hs @@ -21,7 +21,7 @@ runCommand opts = do $ Core.toStripped Core.IdentityTrans (Core.moduleFromInfoTable tab) tab' <- getRight $ - mapRight (Stripped.fromCore (project gopts ^. Core.optFieldSize) . Core.computeCombinedInfoTable) r + mapRight (Stripped.fromCore . Core.computeCombinedInfoTable) r unless (project opts ^. coreStripNoPrint) $ do renderStdOut (Core.ppOut opts tab') where diff --git a/src/Juvix/Compiler/Core/Data/Stripped/InfoTable.hs b/src/Juvix/Compiler/Core/Data/Stripped/InfoTable.hs index 196ebe75c3..04980e5f72 100644 --- a/src/Juvix/Compiler/Core/Data/Stripped/InfoTable.hs +++ b/src/Juvix/Compiler/Core/Data/Stripped/InfoTable.hs @@ -7,9 +7,7 @@ data InfoTable = InfoTable { _infoMain :: Maybe Symbol, _infoFunctions :: HashMap Symbol FunctionInfo, _infoInductives :: HashMap Symbol InductiveInfo, - _infoConstructors :: HashMap Tag ConstructorInfo, - -- Used only by the JuvixTree evaluator - _infoFieldSize :: Natural + _infoConstructors :: HashMap Tag ConstructorInfo } data FunctionInfo = FunctionInfo @@ -67,5 +65,8 @@ makeLenses ''InductiveInfo makeLenses ''ConstructorInfo makeLenses ''ParameterInfo -lookupConstructorInfo :: InfoTable -> Tag -> ConstructorInfo -lookupConstructorInfo tab tag = fromJust $ HashMap.lookup tag (tab ^. infoConstructors) +lookupTabConstructorInfo' :: InfoTable -> Tag -> Maybe ConstructorInfo +lookupTabConstructorInfo' tab tag = HashMap.lookup tag (tab ^. infoConstructors) + +lookupTabConstructorInfo :: InfoTable -> Tag -> ConstructorInfo +lookupTabConstructorInfo tab tag = fromJust $ HashMap.lookup tag (tab ^. infoConstructors) diff --git a/src/Juvix/Compiler/Core/Data/Stripped/Module.hs b/src/Juvix/Compiler/Core/Data/Stripped/Module.hs index 36818998f7..ca6a4cbdd8 100644 --- a/src/Juvix/Compiler/Core/Data/Stripped/Module.hs +++ b/src/Juvix/Compiler/Core/Data/Stripped/Module.hs @@ -7,5 +7,14 @@ where import Juvix.Compiler.Core.Data.Module.Base import Juvix.Compiler.Core.Data.Stripped.InfoTable +import Juvix.Compiler.Core.Language.Stripped type Module = Module' InfoTable + +lookupConstructorInfo' :: Module -> Tag -> Maybe ConstructorInfo +lookupConstructorInfo' md tag = + lookupTabConstructorInfo' (md ^. moduleInfoTable) tag + <|> lookupTabConstructorInfo' (md ^. moduleImportsTable) tag + +lookupConstructorInfo :: Module -> Tag -> ConstructorInfo +lookupConstructorInfo md tag = fromJust $ lookupConstructorInfo' md tag diff --git a/src/Juvix/Compiler/Core/Pretty/Base.hs b/src/Juvix/Compiler/Core/Pretty/Base.hs index 49ea535403..dc4de9f6a9 100644 --- a/src/Juvix/Compiler/Core/Pretty/Base.hs +++ b/src/Juvix/Compiler/Core/Pretty/Base.hs @@ -710,7 +710,7 @@ instance PrettyCode Stripped.InfoTable where ppInductive :: Stripped.InductiveInfo -> Sem r (Doc Ann) ppInductive ii = do name <- ppName KNameInductive (ii ^. Stripped.inductiveName) - ctrs <- mapM (fmap (<> semi) . ppCode . Stripped.lookupConstructorInfo tbl) (ii ^. Stripped.inductiveConstructors) + ctrs <- mapM (fmap (<> semi) . ppCode . Stripped.lookupTabConstructorInfo tbl) (ii ^. Stripped.inductiveConstructors) return (kwInductive <+> name <+> braces (line <> indent' (vsep ctrs) <> line)) instance (PrettyCode a) => PrettyCode (NonEmpty a) where diff --git a/src/Juvix/Compiler/Core/Translation/FromInternal.hs b/src/Juvix/Compiler/Core/Translation/FromInternal.hs index a886e6a62e..2ed1a277a9 100644 --- a/src/Juvix/Compiler/Core/Translation/FromInternal.hs +++ b/src/Juvix/Compiler/Core/Translation/FromInternal.hs @@ -92,8 +92,8 @@ fromInternal i = mapError (JuvixError . ErrBadScope) $ do reserveLiteralIntToIntSymbol let resultModule = i ^. InternalTyped.resultModule resultTable = - Internal.computeCombinedInfoTable importTab - <> i ^. InternalTyped.resultInternalModule . Internal.internalModuleInfoTable + i ^. InternalTyped.resultInternalModule . Internal.internalModuleInfoTable + <> Internal.computeCombinedInfoTable importTab runReader resultTable $ goModule resultModule md' <- getModule diff --git a/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs b/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs index cd33b28da4..fc28de7918 100644 --- a/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs +++ b/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs @@ -9,14 +9,13 @@ import Juvix.Compiler.Core.Info.NameInfo import Juvix.Compiler.Core.Language.Stripped qualified as Stripped import Juvix.Compiler.Core.Pretty -fromCore :: Natural -> InfoTable -> Stripped.InfoTable -fromCore fsize tab = +fromCore :: InfoTable -> Stripped.InfoTable +fromCore tab = Stripped.InfoTable { _infoMain = tab ^. infoMain, _infoFunctions = fmap (translateFunctionInfo tab) (tab' ^. infoIdentifiers), _infoInductives = fmap translateInductiveInfo (tab' ^. infoInductives), - _infoConstructors = fmap translateConstructorInfo (tab' ^. infoConstructors), - _infoFieldSize = fsize + _infoConstructors = fmap translateConstructorInfo (tab' ^. infoConstructors) } where tab' = diff --git a/src/Juvix/Compiler/Pipeline.hs b/src/Juvix/Compiler/Pipeline.hs index 45f7cda05e..11ffcaee60 100644 --- a/src/Juvix/Compiler/Pipeline.hs +++ b/src/Juvix/Compiler/Pipeline.hs @@ -230,9 +230,8 @@ storedCoreToTree :: Core.Module -> Sem r Tree.InfoTable storedCoreToTree checkId md = do - fsize <- asks (^. entryPointFieldSize) Tree.fromCore - . Stripped.fromCore fsize + . Stripped.fromCore . Core.computeCombinedInfoTable <$> Core.toStripped checkId md diff --git a/src/Juvix/Compiler/Store/Backend/Module/Base.hs b/src/Juvix/Compiler/Store/Backend/Module.hs similarity index 93% rename from src/Juvix/Compiler/Store/Backend/Module/Base.hs rename to src/Juvix/Compiler/Store/Backend/Module.hs index 750331448c..bd46845581 100644 --- a/src/Juvix/Compiler/Store/Backend/Module/Base.hs +++ b/src/Juvix/Compiler/Store/Backend/Module.hs @@ -1,4 +1,4 @@ -module Juvix.Compiler.Store.Backend.Module.Base where +module Juvix.Compiler.Store.Backend.Module where import Juvix.Compiler.Store.Backend.Options import Juvix.Data.ModuleId diff --git a/src/Juvix/Compiler/Store/Backend/Stripped.hs b/src/Juvix/Compiler/Store/Backend/Stripped.hs deleted file mode 100644 index f3180e73a5..0000000000 --- a/src/Juvix/Compiler/Store/Backend/Stripped.hs +++ /dev/null @@ -1 +0,0 @@ -module Juvix.Compiler.Store.Backend.Stripped where From 3710ceedd6799a39367406ce6b4a77d94797723c Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Tue, 11 Feb 2025 11:57:19 +0100 Subject: [PATCH 05/24] fix tests --- .../Compiler/Core/Data/Stripped/Module.hs | 20 ------------------- test/Core/Asm/Base.hs | 3 +-- test/Core/Compile/Base.hs | 3 +-- 3 files changed, 2 insertions(+), 24 deletions(-) delete mode 100644 src/Juvix/Compiler/Core/Data/Stripped/Module.hs diff --git a/src/Juvix/Compiler/Core/Data/Stripped/Module.hs b/src/Juvix/Compiler/Core/Data/Stripped/Module.hs deleted file mode 100644 index ca6a4cbdd8..0000000000 --- a/src/Juvix/Compiler/Core/Data/Stripped/Module.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Juvix.Compiler.Core.Data.Stripped.Module - ( module Juvix.Compiler.Core.Data.Stripped.Module, - module Juvix.Compiler.Core.Data.Module.Base, - module Juvix.Compiler.Core.Data.Stripped.InfoTable, - ) -where - -import Juvix.Compiler.Core.Data.Module.Base -import Juvix.Compiler.Core.Data.Stripped.InfoTable -import Juvix.Compiler.Core.Language.Stripped - -type Module = Module' InfoTable - -lookupConstructorInfo' :: Module -> Tag -> Maybe ConstructorInfo -lookupConstructorInfo' md tag = - lookupTabConstructorInfo' (md ^. moduleInfoTable) tag - <|> lookupTabConstructorInfo' (md ^. moduleImportsTable) tag - -lookupConstructorInfo :: Module -> Tag -> ConstructorInfo -lookupConstructorInfo md tag = fromJust $ lookupConstructorInfo' md tag diff --git a/test/Core/Asm/Base.hs b/test/Core/Asm/Base.hs index 9f66c9e85d..5ea6d8e14c 100644 --- a/test/Core/Asm/Base.hs +++ b/test/Core/Asm/Base.hs @@ -12,7 +12,6 @@ import Juvix.Compiler.Core.Translation.FromSource import Juvix.Compiler.Core.Translation.Stripped.FromCore qualified as Stripped import Juvix.Compiler.Pipeline.EntryPoint qualified as EntryPoint import Juvix.Compiler.Tree.Translation.FromCore qualified as Tree -import Juvix.Data.Field import Juvix.Data.PPOutput newtype Test = Test @@ -68,6 +67,6 @@ coreAsmAssertion root' mainFile expectedFile step = do let tab = Asm.fromTree . Tree.fromCore - . Stripped.fromCore (maximum allowedFieldSizes) + . Stripped.fromCore $ computeCombinedInfoTable m Asm.asmRunAssertion' tab expectedFile step diff --git a/test/Core/Compile/Base.hs b/test/Core/Compile/Base.hs index 483d27946a..42530d8c2e 100644 --- a/test/Core/Compile/Base.hs +++ b/test/Core/Compile/Base.hs @@ -15,7 +15,6 @@ import Juvix.Compiler.Core.Translation.FromSource import Juvix.Compiler.Core.Translation.Stripped.FromCore qualified as Stripped import Juvix.Compiler.Pipeline.EntryPoint qualified as EntryPoint import Juvix.Compiler.Tree.Translation.FromCore qualified as Tree -import Juvix.Data.Field import Juvix.Data.PPOutput newtype Test = Test @@ -56,7 +55,7 @@ coreCompileAssertion' entryPoint optLevel tab mainFile expectedFile stdinText st Right m -> do let tab0 = computeCombinedInfoTable m assertBool "Check info table" (checkInfoTable tab0) - let tab' = Asm.fromTree . Tree.fromCore $ Stripped.fromCore (maximum allowedFieldSizes) tab0 + let tab' = Asm.fromTree . Tree.fromCore $ Stripped.fromCore tab0 length (fromText (Asm.ppPrint tab' tab') :: String) `seq` Asm.asmCompileAssertion' entryPoint' optLevel tab' mainFile expectedFile stdinText step where From 1c3c9c0554113948fb47d58d23ba5e714e45f4d2 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Wed, 12 Feb 2025 17:14:35 +0100 Subject: [PATCH 06/24] modules in the backend --- app/AsmInterpreter.hs | 20 +-- app/Commands/Dev/Asm/Compile.hs | 15 +- app/Commands/Dev/Asm/Run.hs | 2 +- app/Commands/Dev/Asm/Validate.hs | 7 +- app/Commands/Dev/Core/Asm.hs | 6 +- app/Commands/Dev/Core/Compile/Base.hs | 25 ++- app/Commands/Dev/Core/Strip.hs | 2 +- app/Commands/Dev/DevCompile/Asm.hs | 6 +- app/Commands/Dev/DevCompile/Reg.hs | 6 +- app/Commands/Dev/DevCompile/Tree.hs | 6 +- app/Commands/Dev/Reg/Read.hs | 17 +- app/Commands/Dev/Reg/Run.hs | 2 +- app/Commands/Dev/Tree.hs | 1 - app/Commands/Dev/Tree/Compile/Anoma.hs | 6 +- app/Commands/Dev/Tree/Compile/Asm.hs | 8 +- app/Commands/Dev/Tree/Compile/Cairo.hs | 6 +- app/Commands/Dev/Tree/Compile/Casm.hs | 6 +- app/Commands/Dev/Tree/Compile/Reg.hs | 9 +- app/Commands/Dev/Tree/Compile/RiscZeroRust.hs | 6 +- app/Commands/Dev/Tree/CompileOld/Base.hs | 148 ------------------ app/Commands/Dev/Tree/CompileOld/Options.hs | 29 ---- app/Commands/Dev/Tree/FromAsm.hs | 10 +- app/Commands/Dev/Tree/Options.hs | 12 -- app/Commands/Dev/Tree/Read.hs | 18 +-- app/Commands/Dev/Tree/Repl.hs | 10 +- app/RegInterpreter.hs | 16 +- app/TreeEvaluator.hs | 24 +-- src/Juvix/Compiler/Asm/Data/CallGraph.hs | 24 +-- src/Juvix/Compiler/Asm/Data/Module.hs | 14 ++ src/Juvix/Compiler/Asm/Extra/Memory.hs | 34 ++-- src/Juvix/Compiler/Asm/Extra/Recursors.hs | 46 +++--- src/Juvix/Compiler/Asm/Extra/Type.hs | 4 +- src/Juvix/Compiler/Asm/Interpreter.hs | 52 +++--- src/Juvix/Compiler/Asm/Interpreter/Runtime.hs | 18 +-- .../Compiler/Asm/Interpreter/RuntimeState.hs | 6 +- src/Juvix/Compiler/Asm/Pipeline.hs | 12 +- src/Juvix/Compiler/Asm/Pretty.hs | 14 +- src/Juvix/Compiler/Asm/Transformation/Base.hs | 14 +- .../Asm/Transformation/FilterUnreachable.hs | 13 +- .../Compiler/Asm/Transformation/Prealloc.hs | 36 ++--- .../Compiler/Asm/Transformation/StackUsage.hs | 16 +- .../Compiler/Asm/Transformation/Validate.hs | 20 +-- .../Compiler/Asm/Translation/FromSource.hs | 6 +- .../Compiler/Asm/Translation/FromTree.hs | 27 ++-- .../Compiler/Casm/Translation/FromReg.hs | 26 +-- src/Juvix/Compiler/Core/Data/Module/Base.hs | 32 +++- .../Compiler/Core/Data/Stripped/Module.hs | 18 +++ src/Juvix/Compiler/Core/Extra/Utils.hs | 6 +- .../Core/Translation/Stripped/FromCore.hs | 18 ++- src/Juvix/Compiler/Pipeline.hs | 75 +++++---- src/Juvix/Compiler/Pipeline/Modular.hs | 6 + src/Juvix/Compiler/Pipeline/Run.hs | 2 +- src/Juvix/Compiler/Reg/Data/Blocks/Module.hs | 14 ++ src/Juvix/Compiler/Reg/Data/Module.hs | 14 ++ src/Juvix/Compiler/Reg/Interpreter.hs | 44 +++--- src/Juvix/Compiler/Reg/Pipeline.hs | 18 +-- src/Juvix/Compiler/Reg/Pretty.hs | 14 +- src/Juvix/Compiler/Reg/Transformation.hs | 4 +- src/Juvix/Compiler/Reg/Transformation/Base.hs | 4 +- .../Reg/Transformation/Blocks/Base.hs | 4 +- .../Reg/Transformation/Blocks/Liveness.hs | 2 +- .../Compiler/Reg/Transformation/Cleanup.hs | 4 +- .../Reg/Transformation/IdentityTrans.hs | 2 +- .../Reg/Transformation/InitBranchVars.hs | 2 +- .../Reg/Transformation/Optimize/BranchToIf.hs | 6 +- .../Optimize/ConstantPropagation.hs | 2 +- .../Optimize/CopyPropagation.hs | 2 +- .../Optimize/DeadCodeElimination.hs | 2 +- .../Transformation/Optimize/Phase/Cairo.hs | 2 +- .../Reg/Transformation/Optimize/Phase/Main.hs | 4 +- src/Juvix/Compiler/Reg/Transformation/SSA.hs | 6 +- .../Reg/Translation/Blocks/FromReg.hs | 16 +- src/Juvix/Compiler/Reg/Translation/FromAsm.hs | 64 ++++---- .../Compiler/Reg/Translation/FromSource.hs | 6 +- src/Juvix/Compiler/Store/Backend/Core.hs | 40 +++++ src/Juvix/Compiler/Store/Backend/Module.hs | 18 ++- .../Compiler/Tree/Data/InfoTable/Base.hs | 47 ++++-- .../Tree/Data/InfoTableBuilder/Base.hs | 56 +++---- src/Juvix/Compiler/Tree/Data/Module.hs | 38 +++++ src/Juvix/Compiler/Tree/Data/Module/Base.hs | 38 +++++ src/Juvix/Compiler/Tree/Evaluator.hs | 38 ++--- src/Juvix/Compiler/Tree/Evaluator/Builtins.hs | 22 +-- src/Juvix/Compiler/Tree/EvaluatorEff.hs | 38 ++--- src/Juvix/Compiler/Tree/Extra/Apply.hs | 28 +++- src/Juvix/Compiler/Tree/Extra/Rep.hs | 19 ++- src/Juvix/Compiler/Tree/Extra/Type.hs | 14 +- src/Juvix/Compiler/Tree/Pipeline.hs | 10 +- src/Juvix/Compiler/Tree/Pretty.hs | 14 +- src/Juvix/Compiler/Tree/Pretty/Base.hs | 2 +- src/Juvix/Compiler/Tree/Pretty/Options.hs | 15 +- src/Juvix/Compiler/Tree/Transformation.hs | 4 +- .../Compiler/Tree/Transformation/Apply.hs | 14 +- .../Compiler/Tree/Transformation/Base.hs | 4 +- .../Tree/Transformation/CheckNoAnoma.hs | 3 +- .../Tree/Transformation/CheckNoByteArray.hs | 3 +- .../Tree/Transformation/FilterUnreachable.hs | 12 +- .../Tree/Transformation/Generic/Base.hs | 53 ++++--- .../Tree/Transformation/IdentityTrans.hs | 6 +- .../Optimize/ConvertUnaryCalls.hs | 8 +- .../Transformation/Optimize/Phase/Main.hs | 2 +- .../Compiler/Tree/Transformation/Validate.hs | 38 ++--- .../Compiler/Tree/Translation/FromAsm.hs | 33 ++-- .../Compiler/Tree/Translation/FromCore.hs | 17 +- .../Compiler/Tree/Translation/FromSource.hs | 6 +- .../Tree/Translation/FromSource/Base.hs | 6 +- 105 files changed, 996 insertions(+), 848 deletions(-) delete mode 100644 app/Commands/Dev/Tree/CompileOld/Base.hs delete mode 100644 app/Commands/Dev/Tree/CompileOld/Options.hs create mode 100644 src/Juvix/Compiler/Asm/Data/Module.hs create mode 100644 src/Juvix/Compiler/Core/Data/Stripped/Module.hs create mode 100644 src/Juvix/Compiler/Reg/Data/Blocks/Module.hs create mode 100644 src/Juvix/Compiler/Reg/Data/Module.hs create mode 100644 src/Juvix/Compiler/Store/Backend/Core.hs create mode 100644 src/Juvix/Compiler/Tree/Data/Module.hs create mode 100644 src/Juvix/Compiler/Tree/Data/Module/Base.hs diff --git a/app/AsmInterpreter.hs b/app/AsmInterpreter.hs index db9fb41699..0baab6dd98 100644 --- a/app/AsmInterpreter.hs +++ b/app/AsmInterpreter.hs @@ -2,36 +2,36 @@ module AsmInterpreter where import App import CommonOptions -import Juvix.Compiler.Asm.Data.InfoTable qualified as Asm +import Juvix.Compiler.Asm.Data.Module qualified as Asm import Juvix.Compiler.Asm.Extra qualified as Asm import Juvix.Compiler.Asm.Interpreter qualified as Asm import Juvix.Compiler.Asm.Pretty qualified as Asm import Juvix.Compiler.Asm.Transformation.Validate qualified as Asm -runAsm :: forall r. (Members '[EmbedIO, App] r) => Bool -> Asm.InfoTable -> Sem r () -runAsm bValidate tab = - let v = if bValidate then Asm.validate' tab else Nothing +runAsm :: forall r. (Members '[EmbedIO, App] r) => Bool -> Asm.Module -> Sem r () +runAsm bValidate md = + let v = if bValidate then Asm.validate' md else Nothing in case v of Just err -> exitJuvixError (JuvixError err) Nothing -> - case tab ^. Asm.infoMainFunction of + case md ^. Asm.moduleInfoTable . Asm.infoMainFunction of Just sym -> do - r <- doRun tab (Asm.lookupFunInfo tab sym) + r <- doRun md (Asm.lookupFunInfo md sym) case r of Left err -> exitJuvixError (JuvixError err) Right Asm.ValVoid -> return () Right val -> do - renderStdOut (Asm.ppOut (Asm.defaultOptions tab) val) + renderStdOut (Asm.ppOut (Asm.defaultOptions md) val) putStrLn "" Nothing -> exitMsg (ExitFailure 1) "no 'main' function" where doRun :: - Asm.InfoTable -> + Asm.Module -> Asm.FunctionInfo -> Sem r (Either Asm.AsmError Asm.Val) - doRun tab' funInfo = - liftIO $ Asm.catchRunErrorIO (Asm.runCodeIO tab' funInfo) + doRun md' funInfo = + liftIO $ Asm.catchRunErrorIO (Asm.runCodeIO md' funInfo) diff --git a/app/Commands/Dev/Asm/Compile.hs b/app/Commands/Dev/Asm/Compile.hs index a5b5a4a240..6a206d2f76 100644 --- a/app/Commands/Dev/Asm/Compile.hs +++ b/app/Commands/Dev/Asm/Compile.hs @@ -9,13 +9,14 @@ import Juvix.Compiler.Backend qualified as Backend import Juvix.Compiler.Backend.C qualified as C import Juvix.Compiler.Casm.Data.Result qualified as Casm import Juvix.Compiler.Casm.Pretty qualified as Casm +import Juvix.Compiler.Reg.Data.Module qualified as Reg import Juvix.Compiler.Reg.Pretty qualified as Reg runCommand :: forall r. (Members '[EmbedIO, App, TaggedLock] r) => AsmCompileOptions -> Sem r () runCommand opts = do file <- getMainFile (Just (opts ^. compileInputFile)) s <- readFile file - tab <- fromRightGenericError (Asm.runParser file s) + md <- fromRightGenericError (Asm.runParser file s) ep <- getEntryPoint (Just (opts ^. compileInputFile)) tgt <- getTarget (opts ^. compileTarget) let entryPoint :: EntryPoint @@ -31,9 +32,9 @@ runCommand opts = do runReader entryPoint . runError @JuvixError . asmToReg - $ tab - tab' <- getRight r - let code = Reg.ppPrint tab' tab' + $ md + md' <- getRight r + let code = Reg.ppPrint md' (Reg.computeCombinedInfoTable md') writeFileEnsureLn regFile code AppTargetCasm -> do casmFile <- Compile.outputFile opts @@ -41,7 +42,7 @@ runCommand opts = do runReader entryPoint . runError @JuvixError . asmToCasm - $ tab + $ md Casm.Result {..} <- getRight r writeFileEnsureLn casmFile (toPlainText $ Casm.ppProgram _resultCode) AppTargetCairo -> do @@ -50,7 +51,7 @@ runCommand opts = do runReader entryPoint . runError @JuvixError . asmToCairo - $ tab + $ md res <- getRight r liftIO $ JSON.encodeFile (toFilePath cairoFile) res _ -> do @@ -59,7 +60,7 @@ runCommand opts = do . run . runReader entryPoint . runError - $ asmToMiniC tab + $ asmToMiniC md buildDir <- askBuildDir ensureDir buildDir cFile <- inputCFile file diff --git a/app/Commands/Dev/Asm/Run.hs b/app/Commands/Dev/Asm/Run.hs index c813c6840b..bfb8eb47d9 100644 --- a/app/Commands/Dev/Asm/Run.hs +++ b/app/Commands/Dev/Asm/Run.hs @@ -11,7 +11,7 @@ runCommand opts = do s <- readFile afile case Asm.runParser afile s of Left err -> exitJuvixError (JuvixError err) - Right tab -> runAsm (not (opts ^. asmRunNoValidate)) tab + Right md -> runAsm (not (opts ^. asmRunNoValidate)) md where file :: AppPath File file = opts ^. asmRunInputFile diff --git a/app/Commands/Dev/Asm/Validate.hs b/app/Commands/Dev/Asm/Validate.hs index 541549b772..8fbbc4719a 100644 --- a/app/Commands/Dev/Asm/Validate.hs +++ b/app/Commands/Dev/Asm/Validate.hs @@ -2,6 +2,7 @@ module Commands.Dev.Asm.Validate where import Commands.Base import Commands.Dev.Asm.Validate.Options +import Juvix.Compiler.Asm.Data.Module qualified as Asm import Juvix.Compiler.Asm.Pretty qualified as Asm import Juvix.Compiler.Asm.Transformation.Validate qualified as Asm import Juvix.Compiler.Asm.Translation.FromSource qualified as Asm @@ -12,8 +13,8 @@ runCommand opts = do s <- readFile afile case Asm.runParser afile s of Left err -> exitJuvixError (JuvixError err) - Right tab -> do - case Asm.validate' tab of + Right md -> do + case Asm.validate' md of Just err -> exitJuvixError (JuvixError err) Nothing -> @@ -21,7 +22,7 @@ runCommand opts = do | opts ^. asmValidateNoPrint -> exitMsg ExitSuccess "validation succeeded" | otherwise -> do - renderStdOut (Asm.ppOutDefault tab tab) + renderStdOut (Asm.ppOutDefault md (Asm.computeCombinedInfoTable md)) exitMsg ExitSuccess "" where file :: AppPath File diff --git a/app/Commands/Dev/Core/Asm.hs b/app/Commands/Dev/Core/Asm.hs index 05cc4bf96f..5496559f16 100644 --- a/app/Commands/Dev/Core/Asm.hs +++ b/app/Commands/Dev/Core/Asm.hs @@ -17,11 +17,11 @@ runCommand opts = do s' <- readFile inputFile tab <- getRight (Core.runParserMain inputFile defaultModuleId mempty s') r <- runReader ep . runError @JuvixError $ coreToAsm (Core.moduleFromInfoTable tab) - tab' <- getRight r + md' <- getRight r if | project opts ^. coreAsmPrint -> - renderStdOut (Asm.ppOutDefault tab' tab') - | otherwise -> runAsm True tab' + renderStdOut (Asm.ppOutDefault md' (Asm.computeCombinedInfoTable md')) + | otherwise -> runAsm True md' where sinputFile :: AppPath File sinputFile = project opts ^. coreAsmInputFile diff --git a/app/Commands/Dev/Core/Compile/Base.hs b/app/Commands/Dev/Core/Compile/Base.hs index a9046bfb08..155efc293a 100644 --- a/app/Commands/Dev/Core/Compile/Base.hs +++ b/app/Commands/Dev/Core/Compile/Base.hs @@ -2,9 +2,9 @@ module Commands.Dev.Core.Compile.Base where import Commands.Base import Commands.Dev.Core.Compile.Options -import Commands.Dev.Tree.CompileOld.Base (outputAnomaResult) import Commands.Extra.Compile qualified as Compile import Data.Aeson qualified as JSON +import Juvix.Compiler.Asm.Data.Module qualified as Asm import Juvix.Compiler.Asm.Pretty qualified as Asm import Juvix.Compiler.Backend qualified as Backend import Juvix.Compiler.Backend.C qualified as C @@ -13,7 +13,11 @@ import Juvix.Compiler.Casm.Data.Result qualified as Casm import Juvix.Compiler.Casm.Pretty qualified as Casm import Juvix.Compiler.Core.Data.Module qualified as Core import Juvix.Compiler.Core.Data.TransformationId qualified as Core +import Juvix.Compiler.Nockma.Pretty qualified as Nockma +import Juvix.Compiler.Nockma.Translation.FromTree qualified as Nockma +import Juvix.Compiler.Reg.Data.Module qualified as Reg import Juvix.Compiler.Reg.Pretty qualified as Reg +import Juvix.Compiler.Tree.Data.Module qualified as Tree import Juvix.Compiler.Tree.Pretty qualified as Tree data PipelineArg = PipelineArg @@ -21,6 +25,13 @@ data PipelineArg = PipelineArg _pipelineArgModule :: Core.Module } +outputAnomaResult :: (Members '[EmbedIO, App] r) => Path Abs File -> Nockma.AnomaResult -> Sem r () +outputAnomaResult nockmaFile Nockma.AnomaResult {..} = do + let code = Nockma.ppSerialize _anomaClosure + prettyNockmaFile = replaceExtensions' [".pretty", ".nockma"] nockmaFile + writeFileEnsureLn nockmaFile code + writeFileEnsureLn prettyNockmaFile (Nockma.ppPrint _anomaClosure) + getEntry :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r EntryPoint getEntry PipelineArg {..} = do ep <- getEntryPoint (Just (_pipelineArgOptions ^. compileInputFile)) @@ -89,8 +100,8 @@ runAsmPipeline pa@PipelineArg {..} = do . runError @JuvixError . coreToAsm $ _pipelineArgModule - tab' <- getRight r - let code = Asm.ppPrint tab' tab' + md' <- getRight r + let code = Asm.ppPrint md' (Asm.computeCombinedInfoTable md') writeFileEnsureLn asmFile code runRegPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () @@ -102,8 +113,8 @@ runRegPipeline pa@PipelineArg {..} = do . runError @JuvixError . coreToReg $ _pipelineArgModule - tab' <- getRight r - let code = Reg.ppPrint tab' tab' + md' <- getRight r + let code = Reg.ppPrint md' (Reg.computeCombinedInfoTable md') writeFileEnsureLn regFile code runTreePipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () @@ -115,8 +126,8 @@ runTreePipeline pa@PipelineArg {..} = do . runError @JuvixError . coreToTree Core.IdentityTrans $ _pipelineArgModule - tab' <- getRight r - let code = Tree.ppPrint tab' tab' + md' <- getRight r + let code = Tree.ppPrint md' (Tree.computeCombinedInfoTable md') writeFileEnsureLn treeFile code runAnomaPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () diff --git a/app/Commands/Dev/Core/Strip.hs b/app/Commands/Dev/Core/Strip.hs index b95f1e4de9..f6cf223253 100644 --- a/app/Commands/Dev/Core/Strip.hs +++ b/app/Commands/Dev/Core/Strip.hs @@ -21,7 +21,7 @@ runCommand opts = do $ Core.toStripped Core.IdentityTrans (Core.moduleFromInfoTable tab) tab' <- getRight $ - mapRight (Stripped.fromCore . Core.computeCombinedInfoTable) r + mapRight (Stripped.fromCore' . Core.computeCombinedInfoTable) r unless (project opts ^. coreStripNoPrint) $ do renderStdOut (Core.ppOut opts tab') where diff --git a/app/Commands/Dev/DevCompile/Asm.hs b/app/Commands/Dev/DevCompile/Asm.hs index b8f256942b..96011d9d94 100644 --- a/app/Commands/Dev/DevCompile/Asm.hs +++ b/app/Commands/Dev/DevCompile/Asm.hs @@ -3,7 +3,7 @@ module Commands.Dev.DevCompile.Asm where import Commands.Base import Commands.Dev.DevCompile.Asm.Options import Commands.Extra.NewCompile -import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Pretty runCommand :: (Members AppEffects r) => AsmOptions 'InputMain -> Sem r () @@ -11,6 +11,6 @@ runCommand opts = do let inputFile = opts ^. asmCompileCommonOptions . compileInputFile moutputFile = opts ^. asmCompileCommonOptions . compileOutputFile outFile :: Path Abs File <- getOutputFile FileExtJuvixAsm inputFile moutputFile - res :: InfoTable <- runPipeline opts inputFile upToAsm - let txt = ppPrint res res + res :: Module <- runPipeline opts inputFile upToAsm + let txt = ppPrint res (computeCombinedInfoTable res) writeFileEnsureLn outFile txt diff --git a/app/Commands/Dev/DevCompile/Reg.hs b/app/Commands/Dev/DevCompile/Reg.hs index 3cddc4ac45..636ee08fbd 100644 --- a/app/Commands/Dev/DevCompile/Reg.hs +++ b/app/Commands/Dev/DevCompile/Reg.hs @@ -3,7 +3,7 @@ module Commands.Dev.DevCompile.Reg where import Commands.Base import Commands.Dev.DevCompile.Reg.Options import Commands.Extra.NewCompile -import Juvix.Compiler.Reg.Data.InfoTable +import Juvix.Compiler.Reg.Data.Module import Juvix.Compiler.Reg.Pretty runCommand :: @@ -14,6 +14,6 @@ runCommand opts = do let inputFile = opts ^. regCompileCommonOptions . compileInputFile moutputFile = opts ^. regCompileCommonOptions . compileOutputFile outFile :: Path Abs File <- getOutputFile FileExtJuvixReg inputFile moutputFile - res :: InfoTable <- runPipeline opts inputFile upToReg - let txt = ppPrint res res + res :: Module <- runPipeline opts inputFile upToReg + let txt = ppPrint res (computeCombinedInfoTable res) writeFileEnsureLn outFile txt diff --git a/app/Commands/Dev/DevCompile/Tree.hs b/app/Commands/Dev/DevCompile/Tree.hs index e1bcb0ebee..609449f16e 100644 --- a/app/Commands/Dev/DevCompile/Tree.hs +++ b/app/Commands/Dev/DevCompile/Tree.hs @@ -3,7 +3,7 @@ module Commands.Dev.DevCompile.Tree where import Commands.Base import Commands.Dev.DevCompile.Tree.Options import Commands.Extra.NewCompile -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Pretty runCommand :: @@ -14,6 +14,6 @@ runCommand opts = do let inputFile = opts ^. treeCompileCommonOptions . compileInputFile moutputFile = opts ^. treeCompileCommonOptions . compileOutputFile outFile :: Path Abs File <- getOutputFile FileExtJuvixTree inputFile moutputFile - res :: InfoTable <- runPipeline opts inputFile upToTree - let txt = ppPrint res res + res :: Module <- runPipeline opts inputFile upToTree + let txt = ppPrint res (computeCombinedInfoTable res) writeFileEnsureLn outFile txt diff --git a/app/Commands/Dev/Reg/Read.hs b/app/Commands/Dev/Reg/Read.hs index 2d58b6f64f..3ac4dd79d3 100644 --- a/app/Commands/Dev/Reg/Read.hs +++ b/app/Commands/Dev/Reg/Read.hs @@ -2,6 +2,7 @@ module Commands.Dev.Reg.Read where import Commands.Base import Commands.Dev.Reg.Read.Options +import Juvix.Compiler.Reg.Data.Module qualified as Reg import Juvix.Compiler.Reg.Pretty qualified as Reg hiding (defaultOptions) import Juvix.Compiler.Reg.Transformation qualified as Reg import Juvix.Compiler.Reg.Translation.FromSource qualified as Reg @@ -14,26 +15,26 @@ runCommand opts = do case Reg.runParser afile s of Left err -> exitJuvixError (JuvixError err) - Right tab -> do + Right md -> do r <- runError @JuvixError . runReader Reg.defaultOptions - $ (Reg.applyTransformations (project opts ^. regReadTransformations) tab) + $ (Reg.applyTransformations (project opts ^. regReadTransformations) md) case r of Left err -> exitJuvixError (JuvixError err) - Right tab' -> do + Right md' -> do unless (project opts ^. regReadNoPrint) $ - renderStdOut (Reg.ppOutDefault tab' tab') - doRun tab' + renderStdOut (Reg.ppOutDefault md' (Reg.computeCombinedInfoTable md')) + doRun md' where file :: AppPath File file = opts ^. regReadInputFile - doRun :: Reg.InfoTable -> Sem r () - doRun tab' + doRun :: Reg.Module -> Sem r () + doRun md' | project opts ^. regReadRun = do putStrLn "--------------------------------" putStrLn "| Run |" putStrLn "--------------------------------" - runReg tab' + runReg md' | otherwise = return () diff --git a/app/Commands/Dev/Reg/Run.hs b/app/Commands/Dev/Reg/Run.hs index 32d5d89186..aa25e3c04c 100644 --- a/app/Commands/Dev/Reg/Run.hs +++ b/app/Commands/Dev/Reg/Run.hs @@ -11,7 +11,7 @@ runCommand opts = do s <- readFile afile case Reg.runParser afile s of Left err -> exitJuvixError (JuvixError err) - Right tab -> runReg tab + Right md -> runReg md where file :: AppPath File file = opts ^. regRunInputFile diff --git a/app/Commands/Dev/Tree.hs b/app/Commands/Dev/Tree.hs index f9b18ace0f..6aa36ce271 100644 --- a/app/Commands/Dev/Tree.hs +++ b/app/Commands/Dev/Tree.hs @@ -12,7 +12,6 @@ runCommand :: forall r. (Members '[EmbedIO, App, TaggedLock] r) => TreeCommand - runCommand = \case Eval opts -> Eval.runCommand opts Compile opts -> Compile.runCommand opts - CompileOld {} -> impossible Read opts -> Read.runCommand opts FromAsm opts -> FromAsm.runCommand opts Repl opts -> Repl.runCommand opts diff --git a/app/Commands/Dev/Tree/Compile/Anoma.hs b/app/Commands/Dev/Tree/Compile/Anoma.hs index 45be289539..3188836bb7 100644 --- a/app/Commands/Dev/Tree/Compile/Anoma.hs +++ b/app/Commands/Dev/Tree/Compile/Anoma.hs @@ -5,7 +5,7 @@ import Commands.Compile.Anoma.Options import Commands.Extra.NewCompile import Juvix.Compiler.Nockma.Pretty qualified as Anoma import Juvix.Compiler.Nockma.Translation.FromTree qualified as Anoma -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Translation.FromSource qualified as Tree runCommand :: @@ -18,7 +18,7 @@ runCommand opts = do moutputFile = opts' ^. compileOutputFile outFile <- getOutputFile FileExtNockma inputFile moutputFile mainFile <- getMainFile inputFile - tab :: InfoTable <- readFile mainFile >>= getRight . Tree.runParser mainFile + md :: Module <- readFile mainFile >>= getRight . Tree.runParser mainFile entrypoint <- applyOptions opts <$> getEntryPoint inputFile @@ -27,5 +27,5 @@ runCommand opts = do . run . runError @JuvixError . runReader entrypoint - $ treeToAnoma tab + $ treeToAnoma md writeFileEnsureLn outFile (Anoma.ppPrint (res ^. Anoma.anomaClosure)) diff --git a/app/Commands/Dev/Tree/Compile/Asm.hs b/app/Commands/Dev/Tree/Compile/Asm.hs index 8897a64fe4..2c74c24428 100644 --- a/app/Commands/Dev/Tree/Compile/Asm.hs +++ b/app/Commands/Dev/Tree/Compile/Asm.hs @@ -4,7 +4,7 @@ import Commands.Base import Commands.Dev.DevCompile.Asm.Options import Commands.Extra.NewCompile import Juvix.Compiler.Asm.Pretty qualified as Asm -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Translation.FromSource qualified as Tree runCommand :: (Members '[App, TaggedLock, EmbedIO] r) => AsmOptions ('InputExtension 'FileExtJuvixTree) -> Sem r () @@ -13,12 +13,12 @@ runCommand opts = do moutputFile = opts ^. asmCompileCommonOptions . compileOutputFile outFile <- getOutputFile FileExtJuvixAsm (Just inputFile) moutputFile mainFile <- getMainFile (Just inputFile) - tab :: InfoTable <- readFile mainFile >>= getRight . Tree.runParser mainFile + md :: Module <- readFile mainFile >>= getRight . Tree.runParser mainFile ep <- getEntryPoint (Just inputFile) res <- getRight . run . runReader ep . runError @JuvixError - $ treeToAsm tab - writeFileEnsureLn outFile (Asm.ppPrint res res) + $ treeToAsm md + writeFileEnsureLn outFile (Asm.ppPrint res (computeCombinedInfoTable res)) diff --git a/app/Commands/Dev/Tree/Compile/Cairo.hs b/app/Commands/Dev/Tree/Compile/Cairo.hs index 2faecd9692..a688b86ba5 100644 --- a/app/Commands/Dev/Tree/Compile/Cairo.hs +++ b/app/Commands/Dev/Tree/Compile/Cairo.hs @@ -4,7 +4,7 @@ import Commands.Base import Commands.Compile.Cairo.Options import Commands.Extra.NewCompile import Data.Aeson qualified as JSON -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Translation.FromSource qualified as Tree runCommand :: (Members '[App, TaggedLock, EmbedIO] r) => CairoOptions ('InputExtension 'FileExtJuvixTree) -> Sem r () @@ -13,7 +13,7 @@ runCommand opts = do moutputFile = opts ^. cairoCompileCommonOptions . compileOutputFile outFile <- getOutputFile FileExtCasm inputFile moutputFile mainFile <- getMainFile inputFile - tab :: InfoTable <- readFile mainFile >>= getRight . Tree.runParser mainFile + md :: Module <- readFile mainFile >>= getRight . Tree.runParser mainFile entrypoint <- applyOptions opts <$> getEntryPoint inputFile @@ -22,5 +22,5 @@ runCommand opts = do . run . runReader entrypoint . runError @JuvixError - $ treeToCairo tab + $ treeToCairo md liftIO (JSON.encodeFile (toFilePath outFile) res) diff --git a/app/Commands/Dev/Tree/Compile/Casm.hs b/app/Commands/Dev/Tree/Compile/Casm.hs index 6fff000add..f81ef2a4e9 100644 --- a/app/Commands/Dev/Tree/Compile/Casm.hs +++ b/app/Commands/Dev/Tree/Compile/Casm.hs @@ -4,7 +4,7 @@ import Commands.Base import Commands.Dev.DevCompile.Casm.Options import Commands.Extra.NewCompile import Juvix.Compiler.Casm.Pretty qualified as Casm -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Translation.FromSource qualified as Tree runCommand :: @@ -17,7 +17,7 @@ runCommand opts = do moutputFile = opts' ^. compileOutputFile outFile <- getOutputFile FileExtCasm inputFile moutputFile mainFile <- getMainFile inputFile - tab :: InfoTable <- readFile mainFile >>= getRight . Tree.runParser mainFile + md :: Module <- readFile mainFile >>= getRight . Tree.runParser mainFile entrypoint <- applyOptions opts <$> getEntryPoint inputFile @@ -26,5 +26,5 @@ runCommand opts = do . run . runError @JuvixError . runReader entrypoint - $ treeToCasm tab + $ treeToCasm md writeFileEnsureLn outFile (Casm.ppPrint res) diff --git a/app/Commands/Dev/Tree/Compile/Reg.hs b/app/Commands/Dev/Tree/Compile/Reg.hs index e9b09d6475..15e8434547 100644 --- a/app/Commands/Dev/Tree/Compile/Reg.hs +++ b/app/Commands/Dev/Tree/Compile/Reg.hs @@ -3,8 +3,9 @@ module Commands.Dev.Tree.Compile.Reg where import Commands.Base import Commands.Dev.DevCompile.Reg.Options import Commands.Extra.NewCompile +import Juvix.Compiler.Reg.Data.Module qualified as Reg import Juvix.Compiler.Reg.Pretty qualified as Reg -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Translation.FromSource qualified as Tree runCommand :: @@ -17,7 +18,7 @@ runCommand opts = do moutputFile = opts' ^. compileOutputFile outFile <- getOutputFile FileExtJuvixReg inputFile moutputFile mainFile <- getMainFile inputFile - tab :: InfoTable <- readFile mainFile >>= getRight . Tree.runParser mainFile + md :: Module <- readFile mainFile >>= getRight . Tree.runParser mainFile entrypoint <- applyOptions opts <$> getEntryPoint inputFile @@ -26,5 +27,5 @@ runCommand opts = do . run . runError @JuvixError . runReader entrypoint - $ treeToReg tab - writeFileEnsureLn outFile (Reg.ppPrint res res) + $ treeToReg md + writeFileEnsureLn outFile (Reg.ppPrint res (Reg.computeCombinedInfoTable res)) diff --git a/app/Commands/Dev/Tree/Compile/RiscZeroRust.hs b/app/Commands/Dev/Tree/Compile/RiscZeroRust.hs index 45bde73365..408ef62e88 100644 --- a/app/Commands/Dev/Tree/Compile/RiscZeroRust.hs +++ b/app/Commands/Dev/Tree/Compile/RiscZeroRust.hs @@ -4,7 +4,7 @@ import Commands.Base import Commands.Compile.RiscZeroRust.Options import Commands.Compile.RiscZeroRust.Rust import Juvix.Compiler.Backend.Rust.Data.Result -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Translation.FromSource qualified as Tree runCommand :: @@ -14,7 +14,7 @@ runCommand :: runCommand opts = do let inputFile = Just $ opts ^. riscZeroRustCompileCommonOptions . compileInputFile mainFile <- getMainFile inputFile - tab :: InfoTable <- readFile mainFile >>= getRight . Tree.runParser mainFile + md :: Module <- readFile mainFile >>= getRight . Tree.runParser mainFile entrypoint <- applyOptions opts <$> getEntryPoint inputFile @@ -23,5 +23,5 @@ runCommand opts = do . run . runError @JuvixError . runReader entrypoint - $ treeToRiscZeroRust tab + $ treeToRiscZeroRust md compileRustCode opts inputFile _resultRustCode diff --git a/app/Commands/Dev/Tree/CompileOld/Base.hs b/app/Commands/Dev/Tree/CompileOld/Base.hs deleted file mode 100644 index 2e587cc429..0000000000 --- a/app/Commands/Dev/Tree/CompileOld/Base.hs +++ /dev/null @@ -1,148 +0,0 @@ -module Commands.Dev.Tree.CompileOld.Base where - -import Commands.Base -import Commands.Dev.Tree.CompileOld.Options -import Commands.Extra.Compile qualified as Compile -import Data.Aeson qualified as JSON -import Juvix.Compiler.Asm.Pretty qualified as Asm -import Juvix.Compiler.Backend qualified as Backend -import Juvix.Compiler.Backend.C qualified as C -import Juvix.Compiler.Casm.Data.Result qualified as Casm -import Juvix.Compiler.Casm.Pretty qualified as Casm -import Juvix.Compiler.Nockma.Pretty qualified as Nockma -import Juvix.Compiler.Nockma.Translation.FromTree qualified as Nockma -import Juvix.Compiler.Reg.Pretty qualified as Reg -import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree - -data PipelineArg = PipelineArg - { _pipelineArgOptions :: CompileOptions, - _pipelineArgFile :: Path Abs File, - _pipelineArgTable :: Tree.InfoTable - } - -getEntry :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r EntryPoint -getEntry PipelineArg {..} = do - ep <- getEntryPoint (Just (AppPath (preFileFromAbs _pipelineArgFile) True)) - return - ep - { _entryPointTarget = Just (getTarget (_pipelineArgOptions ^. compileTarget)), - _entryPointDebug = _pipelineArgOptions ^. compileDebug, - _entryPointUnsafe = _pipelineArgOptions ^. compileUnsafe, - _entryPointOptimizationLevel = fromMaybe defaultOptLevel (_pipelineArgOptions ^. compileOptimizationLevel), - _entryPointInliningDepth = _pipelineArgOptions ^. compileInliningDepth - } - where - getTarget :: CompileTarget -> Backend.Target - getTarget = \case - AppTargetWasm32Wasi -> Backend.TargetCWasm32Wasi - AppTargetNative64 -> Backend.TargetCNative64 - AppTargetCore -> Backend.TargetCore - AppTargetAsm -> Backend.TargetAsm - AppTargetReg -> Backend.TargetReg - AppTargetTree -> Backend.TargetTree - AppTargetAnoma -> Backend.TargetAnoma - AppTargetCasm -> Backend.TargetCairo - AppTargetCairo -> Backend.TargetCairo - AppTargetRiscZeroRust -> Backend.TargetRust - - defaultOptLevel :: Int - defaultOptLevel - | _pipelineArgOptions ^. compileDebug = 0 - | otherwise = defaultOptimizationLevel - -runCPipeline :: - forall r. - (Members '[EmbedIO, App, TaggedLock] r) => - PipelineArg -> - Sem r () -runCPipeline pa@PipelineArg {..} = do - entryPoint <- getEntry pa - C.MiniCResult {..} <- - getRight - . run - . runReader entryPoint - . runError @JuvixError - $ treeToMiniC _pipelineArgTable - cFile <- inputCFile _pipelineArgFile - writeFileEnsureLn cFile _resultCCode - outfile <- Compile.outputFile _pipelineArgOptions - Compile.runCommand - _pipelineArgOptions - { _compileInputFile = AppPath (preFileFromAbs cFile) False, - _compileOutputFile = Just (AppPath (preFileFromAbs outfile) False) - } - where - inputCFile :: Path Abs File -> Sem r (Path Abs File) - inputCFile inputFileCompile = do - buildDir <- askBuildDir - ensureDir buildDir - return (buildDir replaceExtension' ".c" (filename inputFileCompile)) - -runAsmPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () -runAsmPipeline pa@PipelineArg {..} = do - entryPoint <- getEntry pa - asmFile <- Compile.outputFile _pipelineArgOptions - r <- - runReader entryPoint - . runError @JuvixError - . treeToAsm - $ _pipelineArgTable - tab' <- getRight r - let code = Asm.ppPrint tab' tab' - writeFileEnsureLn asmFile code - -runRegPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () -runRegPipeline pa@PipelineArg {..} = do - entryPoint <- getEntry pa - regFile <- Compile.outputFile _pipelineArgOptions - r <- - runReader entryPoint - . runError @JuvixError - . treeToReg - $ _pipelineArgTable - tab' <- getRight r - let code = Reg.ppPrint tab' tab' - writeFileEnsureLn regFile code - -runAnomaPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () -runAnomaPipeline pa@PipelineArg {..} = do - entryPoint <- getEntry pa - nockmaFile <- Compile.outputFile _pipelineArgOptions - r <- - runReader entryPoint - . runError @JuvixError - . treeToAnoma - $ _pipelineArgTable - res <- getRight r - outputAnomaResult nockmaFile res - -outputAnomaResult :: (Members '[EmbedIO, App] r) => Path Abs File -> Nockma.AnomaResult -> Sem r () -outputAnomaResult nockmaFile Nockma.AnomaResult {..} = do - let code = Nockma.ppSerialize _anomaClosure - prettyNockmaFile = replaceExtensions' [".pretty", ".nockma"] nockmaFile - writeFileEnsureLn nockmaFile code - writeFileEnsureLn prettyNockmaFile (Nockma.ppPrint _anomaClosure) - -runCasmPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () -runCasmPipeline pa@PipelineArg {..} = do - entryPoint <- getEntry pa - casmFile <- Compile.outputFile _pipelineArgOptions - r <- - runReader entryPoint - . runError @JuvixError - . treeToCasm - $ _pipelineArgTable - Casm.Result {..} <- getRight r - writeFileEnsureLn casmFile (toPlainText $ Casm.ppProgram _resultCode) - -runCairoPipeline :: (Members '[EmbedIO, App, TaggedLock] r) => PipelineArg -> Sem r () -runCairoPipeline pa@PipelineArg {..} = do - entryPoint <- getEntry pa - cairoFile <- Compile.outputFile _pipelineArgOptions - r <- - runReader entryPoint - . runError @JuvixError - . treeToCairo - $ _pipelineArgTable - res <- getRight r - liftIO $ JSON.encodeFile (toFilePath cairoFile) res diff --git a/app/Commands/Dev/Tree/CompileOld/Options.hs b/app/Commands/Dev/Tree/CompileOld/Options.hs deleted file mode 100644 index 822b098fb5..0000000000 --- a/app/Commands/Dev/Tree/CompileOld/Options.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Commands.Dev.Tree.CompileOld.Options - ( module Commands.Dev.Tree.CompileOld.Options, - module Commands.Extra.Compile.Options, - ) -where - -import Commands.Extra.Compile.Options -import CommonOptions -import Juvix.Config qualified as Config - -treeSupportedTargets :: SupportedTargets -treeSupportedTargets = - AppTargetNative64 - :| [ AppTargetAsm, - AppTargetReg, - AppTargetCasm, - AppTargetCairo, - AppTargetAnoma - ] - <> [AppTargetWasm32Wasi | Config.config ^. Config.configWasm] - <> [AppTargetRiscZeroRust | Config.config ^. Config.configRust] - -parseTreeCompileOptions :: Parser CompileOptions -parseTreeCompileOptions = - parseCompileOptions - treeSupportedTargets - (parseInputFile FileExtJuvixTree) - -type CompileOldOptions = CompileOptions diff --git a/app/Commands/Dev/Tree/FromAsm.hs b/app/Commands/Dev/Tree/FromAsm.hs index 31028ca480..2f5457b320 100644 --- a/app/Commands/Dev/Tree/FromAsm.hs +++ b/app/Commands/Dev/Tree/FromAsm.hs @@ -3,7 +3,7 @@ module Commands.Dev.Tree.FromAsm where import Commands.Base import Commands.Dev.Tree.FromAsm.Options import Juvix.Compiler.Asm.Translation.FromSource qualified as Asm -import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree +import Juvix.Compiler.Tree.Data.Module qualified as Tree import Juvix.Compiler.Tree.Error (TreeError) import Juvix.Compiler.Tree.Pretty qualified as Tree import Juvix.Compiler.Tree.Translation.FromAsm qualified as Tree @@ -14,10 +14,10 @@ runCommand opts = do s <- readFile afile case Asm.runParser afile s of Left err -> exitJuvixError (JuvixError err) - Right tab -> do - r :: Either JuvixError Tree.InfoTable <- runError $ mapError (JuvixError @TreeError) $ Tree.fromAsm tab - tab' <- getRight r - renderStdOut (Tree.ppOutDefault tab' tab') + Right md -> do + r :: Either JuvixError Tree.Module <- runError $ mapError (JuvixError @TreeError) $ Tree.fromAsm md + md' <- getRight r + renderStdOut (Tree.ppOutDefault md' (Tree.computeCombinedInfoTable md')) where file :: AppPath File file = opts ^. treeFromAsmInputFile diff --git a/app/Commands/Dev/Tree/Options.hs b/app/Commands/Dev/Tree/Options.hs index f2cf586fd4..7279af0f5a 100644 --- a/app/Commands/Dev/Tree/Options.hs +++ b/app/Commands/Dev/Tree/Options.hs @@ -1,7 +1,6 @@ module Commands.Dev.Tree.Options where import Commands.Dev.Tree.Compile.Options -import Commands.Dev.Tree.CompileOld.Options import Commands.Dev.Tree.Eval.Options import Commands.Dev.Tree.FromAsm.Options import Commands.Dev.Tree.Read.Options @@ -10,7 +9,6 @@ import CommonOptions data TreeCommand = Eval TreeEvalOptions - | CompileOld CompileOldOptions | Compile CompileCommand | Read TreeReadOptions | FromAsm TreeFromAsmOptions @@ -23,7 +21,6 @@ parseTreeCommand = mconcat [ commandRepl, commandEval, - commandCompileOld, commandCompile, commandRead, commandFromAsm @@ -56,15 +53,6 @@ parseTreeCommand = (Compile <$> parseCompileCommand) (progDesc "Compile a JuvixTree file") - commandCompileOld :: Mod CommandFields TreeCommand - commandCompileOld = command "compile-old" compileInfo - where - compileInfo :: ParserInfo TreeCommand - compileInfo = - info - (CompileOld <$> parseTreeCompileOptions) - (progDesc "Compile a JuvixTree file") - commandRead :: Mod CommandFields TreeCommand commandRead = command "read" readInfo where diff --git a/app/Commands/Dev/Tree/Read.hs b/app/Commands/Dev/Tree/Read.hs index d660aec037..7cf9b7d58c 100644 --- a/app/Commands/Dev/Tree/Read.hs +++ b/app/Commands/Dev/Tree/Read.hs @@ -2,7 +2,7 @@ module Commands.Dev.Tree.Read where import Commands.Base import Commands.Dev.Tree.Read.Options -import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree +import Juvix.Compiler.Tree.Data.Module qualified as Tree import Juvix.Compiler.Tree.Options qualified as TreeOptions import Juvix.Compiler.Tree.Pretty qualified as Tree import Juvix.Compiler.Tree.Transformation qualified as Tree @@ -15,23 +15,23 @@ runCommand opts = do s <- readFile afile case Tree.runParser afile s of Left err -> exitJuvixError (JuvixError err) - Right tab -> do - r <- runReader TreeOptions.defaultOptions $ runError @JuvixError (Tree.applyTransformations (project opts ^. treeReadTransformations) tab) + Right md -> do + r <- runReader TreeOptions.defaultOptions $ runError @JuvixError (Tree.applyTransformations (project opts ^. treeReadTransformations) md) case r of Left err -> exitJuvixError (JuvixError err) - Right tab' -> do + Right md' -> do unless (project opts ^. treeReadNoPrint) $ - renderStdOut (Tree.ppOutDefault tab' tab') - doEval tab' + renderStdOut (Tree.ppOutDefault md' (Tree.computeCombinedInfoTable md')) + doEval md' where file :: AppPath File file = opts ^. treeReadInputFile - doEval :: Tree.InfoTable -> Sem r () - doEval tab' + doEval :: Tree.Module -> Sem r () + doEval md' | project opts ^. treeReadEval = do putStrLn "--------------------------------" putStrLn "| Eval |" putStrLn "--------------------------------" - Eval.evalTree Eval.defaultEvaluator tab' + Eval.evalTree Eval.defaultEvaluator md' | otherwise = return () diff --git a/app/Commands/Dev/Tree/Repl.hs b/app/Commands/Dev/Tree/Repl.hs index e06fff13c3..92458dbcfd 100644 --- a/app/Commands/Dev/Tree/Repl.hs +++ b/app/Commands/Dev/Tree/Repl.hs @@ -4,8 +4,8 @@ import Commands.Base hiding (Atom) import Commands.Dev.Tree.Repl.Options import Control.Exception (throwIO) import Control.Monad.State.Strict qualified as State -import Juvix.Compiler.Tree.Data.InfoTable import Juvix.Compiler.Tree.Data.InfoTableBuilder qualified as Tree +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Language import Juvix.Compiler.Tree.Pretty (ppPrint) import Juvix.Compiler.Tree.Translation.FromSource (parseNodeText', parseText') @@ -89,7 +89,7 @@ evalNode :: Node -> Repl () evalNode node = do sym <- State.gets (^. replStateBuilderState . Tree.stateNextSymbolId) State.modify' (over (replStateBuilderState . Tree.stateNextSymbolId) (+ 1)) - tab <- State.gets (^. replStateBuilderState . Tree.stateInfoTable) + md <- State.gets (^. replStateBuilderState . Tree.stateModule) let fi = FunctionInfo { _functionName = "repl:main", @@ -101,12 +101,12 @@ evalNode node = do _functionArgNames = [], _functionType = TyDynamic } - et <- Eval.doEvalDefault tab fi + et <- Eval.doEvalDefault md fi case et of Left e -> error (show e) Right v -> liftIO $ - putStrLn (ppPrint tab v) + putStrLn (ppPrint md v) replCommand :: String -> Repl () replCommand input_ = Repline.dontCrash $ do @@ -132,6 +132,6 @@ runCommand _ = liftIO . (`State.evalStateT` iniState) $ replAction iniState :: ReplState iniState = ReplState - { _replStateBuilderState = Tree.emptyBuilderState, + { _replStateBuilderState = Tree.mkBuilderState (emptyModule defaultModuleId), _replStateLoadedFile = Nothing } diff --git a/app/RegInterpreter.hs b/app/RegInterpreter.hs index 60b8e27c82..c6801fceb2 100644 --- a/app/RegInterpreter.hs +++ b/app/RegInterpreter.hs @@ -2,28 +2,28 @@ module RegInterpreter where import App import CommonOptions -import Juvix.Compiler.Reg.Data.InfoTable qualified as Reg +import Juvix.Compiler.Reg.Data.Module qualified as Reg import Juvix.Compiler.Reg.Interpreter qualified as Reg import Juvix.Compiler.Reg.Pretty qualified as Reg -runReg :: forall r. (Members '[EmbedIO, App] r) => Reg.InfoTable -> Sem r () -runReg tab = - case tab ^. Reg.infoMainFunction of +runReg :: forall r. (Members '[EmbedIO, App] r) => Reg.Module -> Sem r () +runReg md = + case md ^. Reg.moduleInfoTable . Reg.infoMainFunction of Just sym -> do - r <- doRun tab (Reg.lookupFunInfo tab sym) + r <- doRun md (Reg.lookupFunInfo md sym) case r of Left err -> exitJuvixError (JuvixError err) Right Reg.ValVoid -> return () Right val -> do - renderStdOut (Reg.ppOut (Reg.defaultOptions tab) val) + renderStdOut (Reg.ppOut (Reg.defaultOptions md) val) putStrLn "" Nothing -> exitMsg (ExitFailure 1) "no 'main' function" where doRun :: - Reg.InfoTable -> + Reg.Module -> Reg.FunctionInfo -> Sem r (Either Reg.RegError Reg.Val) - doRun tab' funInfo = runError $ Reg.runFunctionIO stdin stdout tab' [] funInfo + doRun md' funInfo = runError $ Reg.runFunctionIO stdin stdout md' [] funInfo diff --git a/app/TreeEvaluator.hs b/app/TreeEvaluator.hs index 25f75408c0..c488e92884 100644 --- a/app/TreeEvaluator.hs +++ b/app/TreeEvaluator.hs @@ -7,32 +7,32 @@ where import App import Commands.Dev.Tree.Eval.Options import CommonOptions -import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree +import Juvix.Compiler.Tree.Data.Module qualified as Tree import Juvix.Compiler.Tree.Error qualified as Tree import Juvix.Compiler.Tree.Evaluator qualified as Tree import Juvix.Compiler.Tree.EvaluatorEff qualified as Eff import Juvix.Compiler.Tree.Language.Value qualified as Tree import Juvix.Compiler.Tree.Pretty qualified as Tree -evalTree :: forall r. (Members '[EmbedIO, App] r) => Evaluator -> Tree.InfoTable -> Sem r () -evalTree ev tab = - case tab ^. Tree.infoMainFunction of +evalTree :: forall r. (Members '[EmbedIO, App] r) => Evaluator -> Tree.Module -> Sem r () +evalTree ev md = + case md ^. Tree.moduleInfoTable . Tree.infoMainFunction of Just sym -> do - r <- doEval ev tab (Tree.lookupFunInfo tab sym) + r <- doEval ev md (Tree.lookupFunInfo md sym) case r of Left err -> exitJuvixError (JuvixError err) Right Tree.ValVoid -> return () Right val -> do - renderStdOut (Tree.ppOutDefault tab val) + renderStdOut (Tree.ppOutDefault md val) putStrLn "" Nothing -> exitMsg (ExitFailure 1) "no 'main' function" doEvalDefault :: (MonadIO m) => - Tree.InfoTable -> + Tree.Module -> Tree.FunctionInfo -> m (Either Tree.TreeError Tree.Value) doEvalDefault = doEval defaultEvaluator @@ -40,7 +40,7 @@ doEvalDefault = doEval defaultEvaluator doEval :: (MonadIO m) => Evaluator -> - Tree.InfoTable -> + Tree.Module -> Tree.FunctionInfo -> m (Either Tree.TreeError Tree.Value) doEval = \case @@ -49,14 +49,14 @@ doEval = \case doEvalRaw :: (MonadIO m) => - Tree.InfoTable -> + Tree.Module -> Tree.FunctionInfo -> m (Either Tree.TreeError Tree.Value) -doEvalRaw tab' = liftIO . Tree.catchEvalErrorIO . liftIO . Tree.hEvalIO stdin stdout tab' +doEvalRaw md' = liftIO . Tree.catchEvalErrorIO . liftIO . Tree.hEvalIO stdin stdout md' doEvalEff :: (MonadIO m) => - Tree.InfoTable -> + Tree.Module -> Tree.FunctionInfo -> m (Either Tree.TreeError Tree.Value) -doEvalEff tab' funInfo = Eff.hEvalIOEither stdin stdout tab' funInfo +doEvalEff md' funInfo = Eff.hEvalIOEither stdin stdout md' funInfo diff --git a/src/Juvix/Compiler/Asm/Data/CallGraph.hs b/src/Juvix/Compiler/Asm/Data/CallGraph.hs index 3cf0ebddfe..d1bc8cf711 100644 --- a/src/Juvix/Compiler/Asm/Data/CallGraph.hs +++ b/src/Juvix/Compiler/Asm/Data/CallGraph.hs @@ -1,7 +1,7 @@ module Juvix.Compiler.Asm.Data.CallGraph where import Data.HashSet qualified as HashSet -import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Extra import Juvix.Compiler.Asm.Language @@ -9,30 +9,30 @@ import Juvix.Compiler.Asm.Language type CallGraph = DependencyInfo Symbol -- | Compute the call graph -createCallGraph :: (Member (Error AsmError) r) => InfoTable -> Sem r CallGraph -createCallGraph tab = do - graph <- createCallGraphMap tab +createCallGraph :: (Member (Error AsmError) r) => Module -> Sem r CallGraph +createCallGraph md = do + graph <- createCallGraphMap md return $ createDependencyInfo graph startVertices where startVertices :: HashSet Symbol startVertices = HashSet.fromList syms syms :: [Symbol] - syms = maybe [] singleton (tab ^. infoMainFunction) + syms = maybe [] singleton (md ^. moduleInfoTable . infoMainFunction) -createCallGraphMap :: (Member (Error AsmError) r) => InfoTable -> Sem r (HashMap Symbol (HashSet Symbol)) -createCallGraphMap tab = +createCallGraphMap :: (Member (Error AsmError) r) => Module -> Sem r (HashMap Symbol (HashSet Symbol)) +createCallGraphMap md = mapM - (\FunctionInfo {..} -> getFunSymbols tab _functionCode) - (tab ^. infoFunctions) + (\FunctionInfo {..} -> getFunSymbols md _functionCode) + (md ^. moduleInfoTable . infoFunctions) -getFunSymbols :: (Member (Error AsmError) r) => InfoTable -> Code -> Sem r (HashSet Symbol) -getFunSymbols tab code = foldS sig code mempty +getFunSymbols :: (Member (Error AsmError) r) => Module -> Code -> Sem r (HashSet Symbol) +getFunSymbols md code = foldS sig code mempty where sig :: FoldSig StackInfo r (HashSet Symbol) sig = FoldSig - { _foldInfoTable = tab, + { _foldModule = md, _foldAdjust = const mempty, _foldInstr = \_ CmdInstr {..} acc -> return $ goInstr acc _cmdInstrInstruction, _foldBranch = \_ _ a1 a2 a3 -> return $ a1 <> a2 <> a3, diff --git a/src/Juvix/Compiler/Asm/Data/Module.hs b/src/Juvix/Compiler/Asm/Data/Module.hs new file mode 100644 index 0000000000..52eb8c2fc0 --- /dev/null +++ b/src/Juvix/Compiler/Asm/Data/Module.hs @@ -0,0 +1,14 @@ +module Juvix.Compiler.Asm.Data.Module + ( module Juvix.Compiler.Asm.Data.Module, + module Juvix.Compiler.Tree.Data.Module.Base, + module Juvix.Compiler.Asm.Data.InfoTable, + ) +where + +import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Language +import Juvix.Compiler.Tree.Data.Module.Base + +type Module = Module'' Code (Maybe FunctionInfoExtra) + +type ModuleTable = ModuleTable'' Code (Maybe FunctionInfoExtra) diff --git a/src/Juvix/Compiler/Asm/Extra/Memory.hs b/src/Juvix/Compiler/Asm/Extra/Memory.hs index 3ed422085e..749e9e4066 100644 --- a/src/Juvix/Compiler/Asm/Extra/Memory.hs +++ b/src/Juvix/Compiler/Asm/Extra/Memory.hs @@ -1,7 +1,7 @@ module Juvix.Compiler.Asm.Extra.Memory where import Data.HashMap.Strict qualified as HashMap -import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Data.Stack (Stack) import Juvix.Compiler.Asm.Data.Stack qualified as Stack import Juvix.Compiler.Asm.Error @@ -86,7 +86,7 @@ bottomTempStack' n mem = getArgumentType :: Offset -> Memory -> Maybe Type getArgumentType off mem = HashMap.lookup off (mem ^. memoryArgumentArea) -getMemValueType :: InfoTable -> MemRef -> Memory -> Maybe Type +getMemValueType :: Module -> MemRef -> Memory -> Maybe Type getMemValueType tab val mem = case val of DRef dr -> getDirectRefType dr mem ConstrRef fld -> @@ -112,21 +112,21 @@ getConstantType = \case ConstUInt8 {} -> mkTypeUInt8 ConstByteArray {} -> TyByteArray -getValueType' :: (Member (Error AsmError) r) => Maybe Location -> InfoTable -> Memory -> Value -> Sem r Type -getValueType' loc tab mem = \case +getValueType' :: (Member (Error AsmError) r) => Maybe Location -> Module -> Memory -> Value -> Sem r Type +getValueType' loc md mem = \case Constant c -> return (getConstantType c) - Ref val -> case getMemValueType tab val mem of + Ref val -> case getMemValueType md val mem of Just ty -> return ty Nothing -> throw $ AsmError loc "invalid memory reference" -getValueType :: InfoTable -> Memory -> Value -> Maybe Type -getValueType tab mem val = +getValueType :: Module -> Memory -> Value -> Maybe Type +getValueType md mem val = case run (runError ty0) of Left _ -> Nothing Right ty -> Just ty where ty0 :: Sem '[Error AsmError] Type - ty0 = getValueType' Nothing tab mem val + ty0 = getValueType' Nothing md mem val -- | Check if the value stack has at least the given height checkValueStackHeight' :: (Member (Error AsmError) r) => Maybe Location -> Int -> Memory -> Sem r () @@ -144,8 +144,8 @@ checkValueStackHeight' loc n mem = do -- | Check if the values on top of the value stack have the given types (the -- first element of the list corresponds to the top of the stack) -checkValueStack' :: (Member (Error AsmError) r) => Maybe Location -> InfoTable -> [Type] -> Memory -> Sem r () -checkValueStack' loc tab tys mem = do +checkValueStack' :: (Member (Error AsmError) r) => Maybe Location -> Module -> [Type] -> Memory -> Sem r () +checkValueStack' loc md tys mem = do checkValueStackHeight' loc (length tys) mem mapM_ ( \(ty, idx) -> do @@ -156,9 +156,9 @@ checkValueStack' loc tab tys mem = do "type mismatch on value stack cell " <> show idx <> " from top: expected " - <> ppTrace tab ty + <> ppTrace md ty <> " but got " - <> ppTrace tab ty' + <> ppTrace md ty' ) (zip tys [0 ..]) @@ -166,16 +166,16 @@ checkValueStack' loc tab tys mem = do -- representations. Throws an error if some types cannot be unified, or the -- heights of the value stacks or the temporary stacks don't match, or the sizes -- of the argument areas don't match. -unifyMemory' :: (Member (Error AsmError) r) => Maybe Location -> InfoTable -> Memory -> Memory -> Sem r Memory -unifyMemory' loc tab mem1 mem2 = do +unifyMemory' :: (Member (Error AsmError) r) => Maybe Location -> Module -> Memory -> Memory -> Sem r Memory +unifyMemory' loc md mem1 mem2 = do unless (length (mem1 ^. memoryValueStack) == length (mem2 ^. memoryValueStack)) $ throw $ AsmError loc "value stack height mismatch" - vs <- zipWithM (unifyTypes'' loc tab) (toList (mem1 ^. memoryValueStack)) (toList (mem2 ^. memoryValueStack)) + vs <- zipWithM (unifyTypes'' loc md) (toList (mem1 ^. memoryValueStack)) (toList (mem2 ^. memoryValueStack)) unless (length (mem1 ^. memoryTempStack) == length (mem2 ^. memoryTempStack)) $ throw $ AsmError loc "temporary stack height mismatch" - ts <- zipWithM (unifyTypes'' loc tab) (toList (mem1 ^. memoryTempStack)) (toList (mem2 ^. memoryTempStack)) + ts <- zipWithM (unifyTypes'' loc md) (toList (mem1 ^. memoryTempStack)) (toList (mem2 ^. memoryTempStack)) unless ( length (mem1 ^. memoryArgumentArea) == length (mem2 ^. memoryArgumentArea) && mem1 ^. memoryArgsNum == mem2 ^. memoryArgsNum @@ -188,7 +188,7 @@ unifyMemory' loc tab mem1 mem2 = do ( \off -> unifyTypes'' loc - tab + md (fromJust $ HashMap.lookup off (mem1 ^. memoryArgumentArea)) (fromJust $ HashMap.lookup off (mem1 ^. memoryArgumentArea)) ) diff --git a/src/Juvix/Compiler/Asm/Extra/Recursors.hs b/src/Juvix/Compiler/Asm/Extra/Recursors.hs index 6ef851bb38..10d4b30bc5 100644 --- a/src/Juvix/Compiler/Asm/Extra/Recursors.hs +++ b/src/Juvix/Compiler/Asm/Extra/Recursors.hs @@ -4,7 +4,7 @@ module Juvix.Compiler.Asm.Extra.Recursors ) where -import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Data.Stack qualified as Stack import Juvix.Compiler.Asm.Error import Juvix.Compiler.Asm.Extra.Base @@ -15,7 +15,7 @@ import Juvix.Compiler.Asm.Pretty -- | Recursor signature. Contains read-only recursor parameters. data RecursorSig m r a = RecursorSig - { _recursorInfoTable :: InfoTable, + { _recursorModule :: Module, _recurseInstr :: m -> CmdInstr -> Sem r a, _recurseBranch :: Bool -> m -> CmdBranch -> [a] -> [a] -> Sem r a, _recurseCase :: Bool -> m -> CmdCase -> [[a]] -> Maybe [a] -> Sem r a, @@ -85,7 +85,7 @@ recurse' sig = go True Cairo op -> fixMemCairo mem op Push val -> do - ty <- getValueType' loc (sig ^. recursorInfoTable) mem val + ty <- getValueType' loc (sig ^. recursorModule) mem val return (pushValueStack ty mem) Pop -> do when (null (mem ^. memoryValueStack)) $ @@ -103,22 +103,22 @@ recurse' sig = go True Prealloc {} -> return mem AllocConstr tag -> do - let ci = lookupConstrInfo (sig ^. recursorInfoTable) tag + let ci = lookupConstrInfo (sig ^. recursorModule) tag n = ci ^. constructorArgsNum tyargs = typeArgs (ci ^. constructorType) - checkValueStack' loc (sig ^. recursorInfoTable) tyargs mem + checkValueStack' loc (sig ^. recursorModule) tyargs mem tys <- zipWithM - (\ty idx -> unifyTypes'' loc (sig ^. recursorInfoTable) ty (topValueStack' idx mem)) + (\ty idx -> unifyTypes'' loc (sig ^. recursorModule) ty (topValueStack' idx mem)) tyargs [0 ..] return $ pushValueStack (mkTypeConstr (ci ^. constructorInductive) tag tys) $ popValueStack n mem AllocClosure InstrAllocClosure {..} -> do - let fi = lookupFunInfo (sig ^. recursorInfoTable) _allocClosureFunSymbol + let fi = lookupFunInfo (sig ^. recursorModule) _allocClosureFunSymbol (tyargs, tgt) = unfoldType (fi ^. functionType) - checkValueStack' loc (sig ^. recursorInfoTable) (take _allocClosureArgsNum tyargs) mem + checkValueStack' loc (sig ^. recursorModule) (take _allocClosureArgsNum tyargs) mem return $ pushValueStack (mkTypeFun (drop _allocClosureArgsNum tyargs) tgt) $ popValueStack _allocClosureArgsNum mem @@ -137,7 +137,7 @@ recurse' sig = go True fixMemBinOp' :: Memory -> Type -> Type -> Type -> Sem r Memory fixMemBinOp' mem ty0 ty1 rty = do - checkValueStack' loc (sig ^. recursorInfoTable) [ty0, ty1] mem + checkValueStack' loc (sig ^. recursorModule) [ty0, ty1] mem return $ pushValueStack rty (popValueStack 2 mem) fixMemIntOp :: Memory -> Sem r Memory @@ -198,7 +198,7 @@ recurse' sig = go True where checkUnop :: Type -> Type -> Sem r Memory checkUnop ty1 ty2 = do - checkValueStack' loc (sig ^. recursorInfoTable) [ty1] mem + checkValueStack' loc (sig ^. recursorModule) [ty1] mem return (pushValueStack ty2 (popValueStack 1 mem)) fixMemCairo :: Memory -> CairoOp -> Sem r Memory @@ -225,10 +225,10 @@ recurse' sig = go True AsmError loc "invalid call: not enough values on the stack" let ty = case _callType of CallClosure -> topValueStack' 0 mem - CallFun sym -> lookupFunInfo (sig ^. recursorInfoTable) sym ^. functionType + CallFun sym -> lookupFunInfo (sig ^. recursorModule) sym ^. functionType let argsNum = case _callType of CallClosure -> length (typeArgs ty) - CallFun sym -> lookupFunInfo (sig ^. recursorInfoTable) sym ^. functionArgsNum + CallFun sym -> lookupFunInfo (sig ^. recursorModule) sym ^. functionArgsNum when (argsNum /= 0) $ checkFunType ty when (ty /= TyDynamic && argsNum /= _callArgsNum) $ @@ -264,10 +264,10 @@ recurse' sig = go True checkValueStackHeight' loc (argsNum + k) mem let mem' = popValueStack k mem unless (ty == TyDynamic) $ - checkValueStack' loc (sig ^. recursorInfoTable) (take argsNum (typeArgs ty)) mem' + checkValueStack' loc (sig ^. recursorModule) (take argsNum (typeArgs ty)) mem' let tyargs = topValuesFromValueStack' argsNum mem' -- `typeArgs ty` may be shorter than `tyargs` only if `ty` is dynamic - zipWithM_ (unifyTypes'' loc (sig ^. recursorInfoTable)) tyargs (typeArgs ty) + zipWithM_ (unifyTypes'' loc (sig ^. recursorModule)) tyargs (typeArgs ty) return $ pushValueStack (mkTypeFun (drop argsNum (typeArgs ty)) (typeTarget ty)) $ popValueStack argsNum mem' @@ -284,17 +284,17 @@ recurse' sig = go True AsmError loc ( "expected a function, got value of type " - <> ppTrace (sig ^. recursorInfoTable) ty + <> ppTrace (sig ^. recursorModule) ty ) goBranch :: Bool -> Memory -> CmdBranch -> Sem r (Memory, a) goBranch isTail mem cmd@CmdBranch {..} = do - checkValueStack' loc (sig ^. recursorInfoTable) [mkTypeBool] mem + checkValueStack' loc (sig ^. recursorModule) [mkTypeBool] mem let mem0 = popValueStack 1 mem (mem1, as1) <- go isTail mem0 _cmdBranchTrue (mem2, as2) <- go isTail mem0 _cmdBranchFalse a' <- (sig ^. recurseBranch) isTail mem cmd as1 as2 - mem' <- unifyMemory' loc (sig ^. recursorInfoTable) mem1 mem2 + mem' <- unifyMemory' loc (sig ^. recursorModule) mem1 mem2 checkBranchInvariant 1 loc mem0 mem' return (mem', a') where @@ -302,7 +302,7 @@ recurse' sig = go True goCase :: Bool -> Memory -> CmdCase -> Sem r (Memory, a) goCase isTail mem cmd@CmdCase {..} = do - checkValueStack' loc (sig ^. recursorInfoTable) [mkTypeInductive _cmdCaseInductive] mem + checkValueStack' loc (sig ^. recursorModule) [mkTypeInductive _cmdCaseInductive] mem rs <- mapM (go isTail mem . (^. caseBranchCode)) _cmdCaseBranches let mems = map fst rs ass = map snd rs @@ -313,8 +313,8 @@ recurse' sig = go True case mems of [] -> return (fromMaybe mem md, a') mem0 : mems' -> do - mem' <- foldr (\m rm -> rm >>= unifyMemory' loc (sig ^. recursorInfoTable) m) (return mem0) mems' - mem'' <- maybe (return mem') (unifyMemory' loc (sig ^. recursorInfoTable) mem') md + mem' <- foldr (\m rm -> rm >>= unifyMemory' loc (sig ^. recursorModule) m) (return mem0) mems' + mem'' <- maybe (return mem') (unifyMemory' loc (sig ^. recursorModule) mem') md checkBranchInvariant 0 loc mem mem'' return (mem'', a') where @@ -425,7 +425,7 @@ recurseS' sig = go True Prealloc {} -> return si AllocConstr tag -> do - let ci = lookupConstrInfo (sig ^. recursorInfoTable) tag + let ci = lookupConstrInfo (sig ^. recursorModule) tag n = ci ^. constructorArgsNum return $ stackInfoPopValueStack (n - 1) si @@ -528,7 +528,7 @@ recurseS' sig = go True -- `_foldAdjust` to `const empty` where `empty` is the empty accumulator value -- (e.g. `mempty` for a monoid). data FoldSig m r a = FoldSig - { _foldInfoTable :: InfoTable, + { _foldModule :: Module, _foldAdjust :: a -> a, _foldInstr :: m -> CmdInstr -> a -> Sem r a, _foldBranch :: m -> CmdBranch -> a -> a -> a -> Sem r a, @@ -550,7 +550,7 @@ foldS' sig si code acc = do sig' :: RecursorSig StackInfo r (a -> Sem r a) sig' = RecursorSig - { _recursorInfoTable = sig ^. foldInfoTable, + { _recursorModule = sig ^. foldModule, _recurseInstr = \s cmd -> return ((sig ^. foldInstr) s cmd), _recurseBranch = \_ s cmd br1 br2 -> return diff --git a/src/Juvix/Compiler/Asm/Extra/Type.hs b/src/Juvix/Compiler/Asm/Extra/Type.hs index 26b94359c5..acd22b219b 100644 --- a/src/Juvix/Compiler/Asm/Extra/Type.hs +++ b/src/Juvix/Compiler/Asm/Extra/Type.hs @@ -4,13 +4,13 @@ module Juvix.Compiler.Asm.Extra.Type ) where -import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Error import Juvix.Compiler.Asm.Language import Juvix.Compiler.Tree.Error import Juvix.Compiler.Tree.Extra.Type -unifyTypes'' :: forall t e r. (Member (Error AsmError) r) => Maybe Location -> InfoTable' t e -> Type -> Type -> Sem r Type +unifyTypes'' :: forall t e r. (Member (Error AsmError) r) => Maybe Location -> Module'' t e -> Type -> Type -> Sem r Type unifyTypes'' loc tab ty1 ty2 = mapError toAsmError $ unifyTypes' loc tab ty1 ty2 where toAsmError :: TreeError -> AsmError diff --git a/src/Juvix/Compiler/Asm/Interpreter.hs b/src/Juvix/Compiler/Asm/Interpreter.hs index 94686ab75d..e1a343ae3c 100644 --- a/src/Juvix/Compiler/Asm/Interpreter.hs +++ b/src/Juvix/Compiler/Asm/Interpreter.hs @@ -6,7 +6,7 @@ where import Control.Exception qualified as Exception import Control.Monad -import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Error import Juvix.Compiler.Asm.Extra.Base import Juvix.Compiler.Asm.Interpreter.Base @@ -19,14 +19,14 @@ import Juvix.Compiler.Tree.Evaluator.Builtins -- value on top of the value stack at exit, i.e., when executing a toplevel -- Return. Throws a runtime runtimeError if at exit the value stack has more than one -- element. -runCode :: InfoTable -> FunctionInfo -> IO Val +runCode :: Module -> FunctionInfo -> IO Val runCode = hRunCode stdout -hRunCode :: Handle -> InfoTable -> FunctionInfo -> IO Val -hRunCode h infoTable = runM . hEvalRuntime h infoTable . runCodeR infoTable +hRunCode :: Handle -> Module -> FunctionInfo -> IO Val +hRunCode h md = runM . hEvalRuntime h md . runCodeR md -runCodeR :: (Member Runtime r) => InfoTable -> FunctionInfo -> Sem r Val -runCodeR infoTable funInfo = goCode (funInfo ^. functionCode) >> popLastValueStack +runCodeR :: (Member Runtime r) => Module -> FunctionInfo -> Sem r Val +runCodeR md funInfo = goCode (funInfo ^. functionCode) >> popLastValueStack where goCode :: (Member Runtime r) => Code -> Sem r () goCode = \case @@ -74,7 +74,7 @@ runCodeR infoTable funInfo = goCode (funInfo ^. functionCode) >> popLastValueSta goInstr :: (Member Runtime r) => Maybe Location -> Instruction -> Code -> Sem r () goInstr loc instr cont = case instr of Binop op -> goBinOp (evalBinop op) >> goCode cont - Unop op -> goUnop (evalUnop infoTable op) >> goCode cont + Unop op -> goUnop (evalUnop md op) >> goCode cont Cairo {} -> runtimeError "unsupported: Cairo builtin" Push ref -> do v <- getVal ref @@ -89,18 +89,18 @@ runCodeR infoTable funInfo = goCode (funInfo ^. functionCode) >> popLastValueSta goCode cont Trace -> do v <- topValueStack - logMessage (printValue infoTable v) + logMessage (printValue md v) goCode cont Dump -> do dumpState goCode cont Failure -> do v <- topValueStack - runtimeError $ mappend "failure: " (printValue infoTable v) + runtimeError $ mappend "failure: " (printValue md v) Prealloc {} -> goCode cont AllocConstr tag -> do - let ci = lookupConstrInfo infoTable tag + let ci = lookupConstrInfo md tag args <- replicateM (ci ^. constructorArgsNum) popValueStack pushValueStack (ValConstr (Constr tag args)) goCode cont @@ -200,7 +200,7 @@ runCodeR infoTable funInfo = goCode (funInfo ^. functionCode) >> popLastValueSta getCallDetails :: forall r. (Member Runtime r) => Maybe Location -> InstrCall -> Sem r (Code, Frame) getCallDetails loc InstrCall {..} = case _callType of CallFun sym -> do - let fi = lookupFunInfo infoTable sym + let fi = lookupFunInfo md sym unless (_callArgsNum == fi ^. functionArgsNum) (runtimeError "invalid direct call: supplied arguments number not equal to expected arguments number") @@ -208,7 +208,7 @@ runCodeR infoTable funInfo = goCode (funInfo ^. functionCode) >> popLastValueSta return (fi ^. functionCode, frameFromFunctionInfo loc fi args) CallClosure -> do cl <- popValueStack >>= closureFromValue - let fi = lookupFunInfo infoTable (cl ^. closureSymbol) + let fi = lookupFunInfo md (cl ^. closureSymbol) clArgs = length (cl ^. closureArgs) unless (clArgs < fi ^. functionArgsNum) @@ -245,7 +245,7 @@ runCodeR infoTable funInfo = goCode (funInfo ^. functionCode) >> popLastValueSta v <- popValueStack case v of ValClosure cl -> do - let fi = lookupFunInfo infoTable (cl ^. closureSymbol) + let fi = lookupFunInfo md (cl ^. closureSymbol) let n = fi ^. functionArgsNum - length (cl ^. closureArgs) when (n < 0) @@ -281,32 +281,32 @@ runCodeR infoTable funInfo = goCode (funInfo ^. functionCode) >> popLastValueSta Right v -> return v -- | Interpret JuvixAsm code and the resulting IO actions. -runCodeIO :: InfoTable -> FunctionInfo -> IO Val +runCodeIO :: Module -> FunctionInfo -> IO Val runCodeIO = hRunCodeIO stdin stdout -hRunCodeIO :: Handle -> Handle -> InfoTable -> FunctionInfo -> IO Val -hRunCodeIO hin hout infoTable funInfo = do - v <- hRunCode hout infoTable funInfo - hRunIO hin hout infoTable funInfo v +hRunCodeIO :: Handle -> Handle -> Module -> FunctionInfo -> IO Val +hRunCodeIO hin hout md funInfo = do + v <- hRunCode hout md funInfo + hRunIO hin hout md funInfo v -- | Interpret IO actions. -hRunIO :: Handle -> Handle -> InfoTable -> FunctionInfo -> Val -> IO Val -hRunIO hin hout infoTable funInfo = \case +hRunIO :: Handle -> Handle -> Module -> FunctionInfo -> Val -> IO Val +hRunIO hin hout md funInfo = \case ValConstr (Constr (BuiltinTag TagReturn) [x]) -> return x ValConstr (Constr (BuiltinTag TagBind) [x, f]) -> do - x' <- hRunIO hin hout infoTable funInfo x + x' <- hRunIO hin hout md funInfo x let code = [Instr (CmdInstr (CommandInfo Nothing) (Call (InstrCall CallClosure 1)))] let r = pushValueStack x' >> pushValueStack f - >> runCodeR infoTable funInfo {_functionCode = code} - x'' <- runM (hEvalRuntime hout infoTable r) - hRunIO hin hout infoTable funInfo x'' + >> runCodeR md funInfo {_functionCode = code} + x'' <- runM (hEvalRuntime hout md r) + hRunIO hin hout md funInfo x'' ValConstr (Constr (BuiltinTag TagWrite) [ValString s]) -> do hPutStr hout s return ValVoid ValConstr (Constr (BuiltinTag TagWrite) [arg]) -> do - hPutStr hout (ppPrint infoTable arg) + hPutStr hout (ppPrint md arg) return ValVoid ValConstr (Constr (BuiltinTag TagReadLn) []) -> do hFlush hout @@ -328,6 +328,6 @@ toAsmError (RunError {..}) = "runtime error: " <> _runErrorMsg <> "\n\nStacktrace\n----------\n\n" - <> ppTrace (_runErrorState ^. runtimeInfoTable) _runErrorState, + <> ppTrace (_runErrorState ^. runtimeModule) _runErrorState, _asmErrorLoc = _runErrorState ^. runtimeLocation } diff --git a/src/Juvix/Compiler/Asm/Interpreter/Runtime.hs b/src/Juvix/Compiler/Asm/Interpreter/Runtime.hs index 0784ea1b41..f7d5d71646 100644 --- a/src/Juvix/Compiler/Asm/Interpreter/Runtime.hs +++ b/src/Juvix/Compiler/Asm/Interpreter/Runtime.hs @@ -8,7 +8,7 @@ where import Data.HashMap.Strict qualified as HashMap import Debug.Trace qualified as Debug import GHC.Base qualified as GHC -import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Data.Stack qualified as Stack import Juvix.Compiler.Asm.Interpreter.Error import Juvix.Compiler.Asm.Interpreter.RuntimeState @@ -36,8 +36,8 @@ data Runtime :: Effect where makeSem ''Runtime -runRuntime :: forall r a. InfoTable -> Sem (Runtime ': r) a -> Sem r (RuntimeState, a) -runRuntime tab = interp +runRuntime :: forall r a. Module -> Sem (Runtime ': r) a -> Sem r (RuntimeState, a) +runRuntime md = interp where iniState = RuntimeState @@ -45,7 +45,7 @@ runRuntime tab = interp _runtimeFrame = emptyFrame, _runtimeMessages = [], _runtimeLocation = Nothing, - _runtimeInfoTable = tab + _runtimeModule = md } interp :: Sem (Runtime ': r) a -> Sem r (RuntimeState, a) @@ -105,7 +105,7 @@ runRuntime tab = interp doFlushLogs <$> get DumpState -> do s :: RuntimeState <- get - Debug.trace (fromText $ ppTrace (s ^. runtimeInfoTable) s) $ return () + Debug.trace (fromText $ ppTrace (s ^. runtimeModule) s) $ return () RegisterLocation loc -> modify' (set runtimeLocation loc) RuntimeError msg -> do @@ -122,11 +122,11 @@ runRuntime tab = interp let logs = reverse (s ^. runtimeMessages) in map' (\x -> Debug.trace (fromText x) ()) logs `GHC.seq` () -hEvalRuntime :: forall r a. (Member EmbedIO r) => Handle -> InfoTable -> Sem (Runtime ': r) a -> Sem r a -hEvalRuntime h tab r = do - (s, a) <- runRuntime tab r +hEvalRuntime :: forall r a. (Member EmbedIO r) => Handle -> Module -> Sem (Runtime ': r) a -> Sem r a +hEvalRuntime h md r = do + (s, a) <- runRuntime md r mapM_ (hPutStrLn h) (reverse (s ^. runtimeMessages)) return a -evalRuntime :: forall r a. (Member EmbedIO r) => InfoTable -> Sem (Runtime ': r) a -> Sem r a +evalRuntime :: forall r a. (Member EmbedIO r) => Module -> Sem (Runtime ': r) a -> Sem r a evalRuntime = hEvalRuntime stdout diff --git a/src/Juvix/Compiler/Asm/Interpreter/RuntimeState.hs b/src/Juvix/Compiler/Asm/Interpreter/RuntimeState.hs index 13f0829264..ae37b6c8d3 100644 --- a/src/Juvix/Compiler/Asm/Interpreter/RuntimeState.hs +++ b/src/Juvix/Compiler/Asm/Interpreter/RuntimeState.hs @@ -4,7 +4,7 @@ module Juvix.Compiler.Asm.Interpreter.RuntimeState ) where -import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Data.Stack (Stack) import Juvix.Compiler.Asm.Data.Stack qualified as Stack import Juvix.Compiler.Asm.Interpreter.Base @@ -103,8 +103,8 @@ data RuntimeState = RuntimeState _runtimeMessages :: [Text], -- | current location in the source _runtimeLocation :: Maybe Location, - -- | InfoTable associated with the runtime state - _runtimeInfoTable :: InfoTable + -- | Module associated with the runtime state + _runtimeModule :: Module } makeLenses ''AsmCallStack diff --git a/src/Juvix/Compiler/Asm/Pipeline.hs b/src/Juvix/Compiler/Asm/Pipeline.hs index d4e16d0452..92ae5e862b 100644 --- a/src/Juvix/Compiler/Asm/Pipeline.hs +++ b/src/Juvix/Compiler/Asm/Pipeline.hs @@ -1,11 +1,11 @@ module Juvix.Compiler.Asm.Pipeline ( module Juvix.Compiler.Asm.Pipeline, - module Juvix.Compiler.Asm.Data.InfoTable, + module Juvix.Compiler.Asm.Data.Module, module Juvix.Compiler.Asm.Options, ) where -import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Extra import Juvix.Compiler.Asm.Options import Juvix.Compiler.Asm.Transformation @@ -14,16 +14,16 @@ import Juvix.Prelude -- | Perform transformations on JuvixAsm necessary before the translation to -- JuvixReg -toReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => InfoTable -> Sem r InfoTable +toReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Module -> Sem r Module toReg = mapReader fromEntryPoint . mapError (JuvixError @AsmError) . toReg' where - toReg' :: (Members '[Error AsmError, Reader Options] r) => InfoTable -> Sem r InfoTable + toReg' :: (Members '[Error AsmError, Reader Options] r) => Module -> Sem r Module toReg' = validate >=> filterUnreachable >=> computeStackUsage >=> computePrealloc -- | Perform transformations on JuvixAsm necessary before the translation to -- Nockma -toNockma :: (Members '[Error JuvixError, Reader EntryPoint] r) => InfoTable -> Sem r InfoTable +toNockma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Module -> Sem r Module toNockma = mapReader fromEntryPoint . mapError (JuvixError @AsmError) . toNockma' where - toNockma' :: (Members '[Error AsmError, Reader Options] r) => InfoTable -> Sem r InfoTable + toNockma' :: (Members '[Error AsmError, Reader Options] r) => Module -> Sem r Module toNockma' = validate diff --git a/src/Juvix/Compiler/Asm/Pretty.hs b/src/Juvix/Compiler/Asm/Pretty.hs index 9fa1d33f57..ead253a124 100644 --- a/src/Juvix/Compiler/Asm/Pretty.hs +++ b/src/Juvix/Compiler/Asm/Pretty.hs @@ -5,15 +5,15 @@ module Juvix.Compiler.Asm.Pretty ) where -import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Pretty.Base import Juvix.Compiler.Asm.Pretty.Options import Juvix.Data.PPOutput import Juvix.Prelude import Prettyprinter.Render.Terminal qualified as Ansi -ppOutDefault :: (PrettyCode c) => InfoTable -> c -> AnsiText -ppOutDefault tab = mkAnsiText . PPOutput . doc (defaultOptions tab) +ppOutDefault :: (PrettyCode c) => Module -> c -> AnsiText +ppOutDefault md = mkAnsiText . PPOutput . doc (defaultOptions md) ppOut :: (PrettyCode c) => Options -> c -> AnsiText ppOut o = mkAnsiText . PPOutput . doc o @@ -21,8 +21,8 @@ ppOut o = mkAnsiText . PPOutput . doc o ppTrace' :: (PrettyCode c) => Options -> c -> Text ppTrace' opts = Ansi.renderStrict . reAnnotateS stylize . layoutPretty defaultLayoutOptions . doc opts -ppTrace :: (PrettyCode c) => InfoTable -> c -> Text -ppTrace tab = ppTrace' (defaultOptions tab) +ppTrace :: (PrettyCode c) => Module -> c -> Text +ppTrace md = ppTrace' (defaultOptions md) -ppPrint :: (PrettyCode c) => InfoTable -> c -> Text -ppPrint tab = show . ppOutDefault tab +ppPrint :: (PrettyCode c) => Module -> c -> Text +ppPrint md = show . ppOutDefault md diff --git a/src/Juvix/Compiler/Asm/Transformation/Base.hs b/src/Juvix/Compiler/Asm/Transformation/Base.hs index f0fa429c28..803e02ec8a 100644 --- a/src/Juvix/Compiler/Asm/Transformation/Base.hs +++ b/src/Juvix/Compiler/Asm/Transformation/Base.hs @@ -1,12 +1,12 @@ module Juvix.Compiler.Asm.Transformation.Base ( module Juvix.Compiler.Asm.Transformation.Base, - module Juvix.Compiler.Asm.Data.InfoTable, + module Juvix.Compiler.Asm.Data.Module, module Juvix.Compiler.Asm.Extra, module Juvix.Compiler.Asm.Language, ) where -import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Extra import Juvix.Compiler.Asm.Language @@ -15,12 +15,12 @@ liftCodeTransformation f fi = do code <- f (fi ^. functionCode) return fi {_functionCode = code} -liftFunctionTransformation :: (Monad m) => (FunctionInfo -> m FunctionInfo) -> InfoTable -> m InfoTable -liftFunctionTransformation f tab = do - fns <- mapM f (tab ^. infoFunctions) - return tab {_infoFunctions = fns} +liftFunctionTransformation :: (Monad m) => (FunctionInfo -> m FunctionInfo) -> Module -> m Module +liftFunctionTransformation f md = do + fns <- mapM f (md ^. moduleInfoTable . infoFunctions) + return $ over moduleInfoTable (set infoFunctions fns) md -runTransformation :: (InfoTable -> Sem '[Error AsmError] InfoTable) -> InfoTable -> Either AsmError InfoTable +runTransformation :: (Module -> Sem '[Error AsmError] Module) -> Module -> Either AsmError Module runTransformation trans tab = case run $ runError $ trans tab of Left err -> Left err diff --git a/src/Juvix/Compiler/Asm/Transformation/FilterUnreachable.hs b/src/Juvix/Compiler/Asm/Transformation/FilterUnreachable.hs index 455f1d1b07..ef612fb881 100644 --- a/src/Juvix/Compiler/Asm/Transformation/FilterUnreachable.hs +++ b/src/Juvix/Compiler/Asm/Transformation/FilterUnreachable.hs @@ -2,11 +2,14 @@ module Juvix.Compiler.Asm.Transformation.FilterUnreachable where import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Asm.Data.CallGraph -import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Error import Juvix.Prelude -filterUnreachable :: (Member (Error AsmError) r) => InfoTable -> Sem r InfoTable -filterUnreachable tab = do - graph <- createCallGraph tab - return $ over infoFunctions (HashMap.filterWithKey (const . isReachable graph)) tab +filterUnreachable :: (Member (Error AsmError) r) => Module -> Sem r Module +filterUnreachable md + | isJust (md ^. moduleInfoTable . infoMainFunction) = do + graph <- createCallGraph md + return $ over (moduleInfoTable . infoFunctions) (HashMap.filterWithKey (const . isReachable graph)) md + | otherwise = + return md diff --git a/src/Juvix/Compiler/Asm/Transformation/Prealloc.hs b/src/Juvix/Compiler/Asm/Transformation/Prealloc.hs index ce2d03adaa..5a75ef39dc 100644 --- a/src/Juvix/Compiler/Asm/Transformation/Prealloc.hs +++ b/src/Juvix/Compiler/Asm/Transformation/Prealloc.hs @@ -4,10 +4,10 @@ import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Asm.Options import Juvix.Compiler.Asm.Transformation.Base -computeMaxArgsNum :: InfoTable -> Int -computeMaxArgsNum tab = maximum (map (^. functionArgsNum) (HashMap.elems (tab ^. infoFunctions))) +computeMaxArgsNum :: Module -> Int +computeMaxArgsNum md = maximum (map (^. functionArgsNum) (HashMap.elems (md ^. moduleInfoTable . infoFunctions))) -computeCodePrealloc :: forall r. (Members '[Error AsmError, Reader Options] r) => Int -> InfoTable -> Code -> Sem r Code +computeCodePrealloc :: forall r. (Members '[Error AsmError, Reader Options] r) => Int -> Module -> Code -> Sem r Code computeCodePrealloc maxArgsNum tab code = prealloc <$> foldS sig code (0, []) where -- returns the maximum memory use and the mapping result (Code with the @@ -15,7 +15,7 @@ computeCodePrealloc maxArgsNum tab code = prealloc <$> foldS sig code (0, []) sig :: FoldSig StackInfo r (Int, Code) sig = FoldSig - { _foldInfoTable = tab, + { _foldModule = tab, _foldAdjust = second (const []), _foldInstr = const goInstr, _foldBranch = const goBranch, @@ -91,22 +91,22 @@ computeCodePrealloc maxArgsNum tab code = prealloc <$> foldS sig code (0, []) prealloc (0, c) = c prealloc (n, c) = mkInstr (Prealloc (InstrPrealloc n)) : c -computeFunctionPrealloc :: (Members '[Error AsmError, Reader Options] r) => Int -> InfoTable -> FunctionInfo -> Sem r FunctionInfo -computeFunctionPrealloc maxArgsNum tab = liftCodeTransformation (computeCodePrealloc maxArgsNum tab) +computeFunctionPrealloc :: (Members '[Error AsmError, Reader Options] r) => Int -> Module -> FunctionInfo -> Sem r FunctionInfo +computeFunctionPrealloc maxArgsNum md = liftCodeTransformation (computeCodePrealloc maxArgsNum md) -computePrealloc :: (Members '[Error AsmError, Reader Options] r) => InfoTable -> Sem r InfoTable -computePrealloc tab = - liftFunctionTransformation (computeFunctionPrealloc (computeMaxArgsNum tab) tab) tab +computePrealloc :: (Members '[Error AsmError, Reader Options] r) => Module -> Sem r Module +computePrealloc md = + liftFunctionTransformation (computeFunctionPrealloc (computeMaxArgsNum md) md) md -checkCodePrealloc :: forall r. (Members '[Error AsmError, Reader Options] r) => Int -> InfoTable -> Code -> Sem r Bool -checkCodePrealloc maxArgsNum tab code = do +checkCodePrealloc :: forall r. (Members '[Error AsmError, Reader Options] r) => Int -> Module -> Code -> Sem r Bool +checkCodePrealloc maxArgsNum md code = do f <- foldS sig code id return $ f 0 >= 0 where sig :: FoldSig StackInfo r (Int -> Int) sig = FoldSig - { _foldInfoTable = tab, + { _foldModule = md, _foldAdjust = id, _foldInstr = const goInstr, _foldBranch = const goBranch, @@ -121,7 +121,7 @@ checkCodePrealloc maxArgsNum tab code = do AllocConstr tag -> return $ \k -> cont (k - size) where - ci = lookupConstrInfo tab tag + ci = lookupConstrInfo md tag size = getConstrSize (ci ^. constructorRepresentation) (ci ^. constructorArgsNum) AllocClosure InstrAllocClosure {..} -> do opts <- ask @@ -149,10 +149,10 @@ checkCodePrealloc maxArgsNum tab code = do in cont (min k1 k2) goCase :: CmdCase -> [Int -> Int] -> Maybe (Int -> Int) -> (Int -> Int) -> Sem r (Int -> Int) - goCase _ brs md cont = + goCase _ brs mkd cont = return $ \k -> let ks = map (\f -> f k) brs - kd = fmap (\f -> f k) md + kd = fmap (\f -> f k) mkd k' = min (minimum ks) (fromMaybe k kd) in cont k' @@ -160,11 +160,11 @@ checkCodePrealloc maxArgsNum tab code = do goSave _ br cont = return $ cont . br -checkPrealloc :: Options -> InfoTable -> Bool -checkPrealloc opts tab = +checkPrealloc :: Options -> Module -> Bool +checkPrealloc opts md = case run $ runError $ runReader opts sb of Left err -> error (show err) Right b -> b where sb :: Sem '[Reader Options, Error AsmError] Bool - sb = allM (checkCodePrealloc (computeMaxArgsNum tab) tab . (^. functionCode)) (HashMap.elems (tab ^. infoFunctions)) + sb = allM (checkCodePrealloc (computeMaxArgsNum md) md . (^. functionCode)) (HashMap.elems (md ^. moduleInfoTable . infoFunctions)) diff --git a/src/Juvix/Compiler/Asm/Transformation/StackUsage.hs b/src/Juvix/Compiler/Asm/Transformation/StackUsage.hs index 09908b24d7..769246d1c9 100644 --- a/src/Juvix/Compiler/Asm/Transformation/StackUsage.hs +++ b/src/Juvix/Compiler/Asm/Transformation/StackUsage.hs @@ -2,8 +2,8 @@ module Juvix.Compiler.Asm.Transformation.StackUsage where import Juvix.Compiler.Asm.Transformation.Base -computeFunctionStackUsage :: (Member (Error AsmError) r) => InfoTable -> FunctionInfo -> Sem r FunctionInfo -computeFunctionStackUsage tab fi = do +computeFunctionStackUsage :: (Member (Error AsmError) r) => Module -> FunctionInfo -> Sem r FunctionInfo +computeFunctionStackUsage md fi = do ps <- recurseS sig (fi ^. functionCode) let maxValueStack = maximum (map fst ps) maxTempStack = maximum (map snd ps) @@ -20,17 +20,17 @@ computeFunctionStackUsage tab fi = do sig :: RecursorSig StackInfo r (Int, Int) sig = RecursorSig - { _recursorInfoTable = tab, + { _recursorModule = md, _recurseInstr = \si _ -> return (si ^. stackInfoValueStackHeight, si ^. stackInfoTempStackHeight), _recurseBranch = \_ si _ l r -> return ( max (si ^. stackInfoValueStackHeight) (max (maximum (map fst l)) (maximum (map fst r))), max (si ^. stackInfoTempStackHeight) (max (maximum (map snd l)) (maximum (map snd r))) ), - _recurseCase = \_ si _ cs md -> + _recurseCase = \_ si _ cs mdef -> return - ( max (si ^. stackInfoValueStackHeight) (max (maximum (map (maximum . map fst) cs)) (maybe 0 (maximum . map fst) md)), - max (si ^. stackInfoTempStackHeight) (max (maximum (map (maximum . map snd) cs)) (maybe 0 (maximum . map snd) md)) + ( max (si ^. stackInfoValueStackHeight) (max (maximum (map (maximum . map fst) cs)) (maybe 0 (maximum . map fst) mdef)), + max (si ^. stackInfoTempStackHeight) (max (maximum (map (maximum . map snd) cs)) (maybe 0 (maximum . map snd) mdef)) ), _recurseSave = \si _ b -> return @@ -39,5 +39,5 @@ computeFunctionStackUsage tab fi = do ) } -computeStackUsage :: (Member (Error AsmError) r) => InfoTable -> Sem r InfoTable -computeStackUsage tab = liftFunctionTransformation (computeFunctionStackUsage tab) tab +computeStackUsage :: (Member (Error AsmError) r) => Module -> Sem r Module +computeStackUsage md = liftFunctionTransformation (computeFunctionStackUsage md) md diff --git a/src/Juvix/Compiler/Asm/Transformation/Validate.hs b/src/Juvix/Compiler/Asm/Transformation/Validate.hs index c69e5fba00..ab40e9e06f 100644 --- a/src/Juvix/Compiler/Asm/Transformation/Validate.hs +++ b/src/Juvix/Compiler/Asm/Transformation/Validate.hs @@ -2,29 +2,29 @@ module Juvix.Compiler.Asm.Transformation.Validate where import Juvix.Compiler.Asm.Transformation.Base -validateCode :: forall r. (Member (Error AsmError) r) => InfoTable -> FunctionInfo -> Code -> Sem r Code -validateCode tab fi code = do +validateCode :: forall r. (Member (Error AsmError) r) => Module -> FunctionInfo -> Code -> Sem r Code +validateCode md fi code = do recurse sig (argumentsFromFunctionInfo fi) code return code where sig :: RecursorSig Memory r () sig = RecursorSig - { _recursorInfoTable = tab, + { _recursorModule = md, _recurseInstr = \_ _ -> return (), _recurseBranch = \_ _ _ _ _ -> return (), _recurseCase = \_ _ _ _ _ -> return (), _recurseSave = \_ _ _ -> return () } -validateFunction :: (Member (Error AsmError) r) => InfoTable -> FunctionInfo -> Sem r FunctionInfo -validateFunction tab fi = liftCodeTransformation (validateCode tab fi) fi +validateFunction :: (Member (Error AsmError) r) => Module -> FunctionInfo -> Sem r FunctionInfo +validateFunction md fi = liftCodeTransformation (validateCode md fi) fi -validate :: (Member (Error AsmError) r) => InfoTable -> Sem r InfoTable -validate tab = liftFunctionTransformation (validateFunction tab) tab +validate :: (Member (Error AsmError) r) => Module -> Sem r Module +validate md = liftFunctionTransformation (validateFunction md) md -validate' :: InfoTable -> Maybe AsmError -validate' tab = - case run $ runError $ validate tab of +validate' :: Module -> Maybe AsmError +validate' md = + case run $ runError $ validate md of Left err -> Just err _ -> Nothing diff --git a/src/Juvix/Compiler/Asm/Translation/FromSource.hs b/src/Juvix/Compiler/Asm/Translation/FromSource.hs index 17aae334b9..288862e173 100644 --- a/src/Juvix/Compiler/Asm/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Asm/Translation/FromSource.hs @@ -7,8 +7,8 @@ where import Control.Monad.Trans.Class (lift) import Data.HashMap.Strict qualified as HashMap -import Juvix.Compiler.Asm.Data.InfoTable import Juvix.Compiler.Asm.Data.InfoTableBuilder +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Extra.Base import Juvix.Compiler.Asm.Language import Juvix.Compiler.Asm.Translation.FromSource.Lexer @@ -32,13 +32,13 @@ parseAsmSig = _parserSigEmptyExtra = mempty } -parseText :: Text -> Either MegaparsecError InfoTable +parseText :: Text -> Either MegaparsecError Module parseText = runParser noFile parseText' :: BuilderState -> Text -> Either MegaparsecError BuilderState parseText' bs = runParser' bs noFile -runParser :: Path Abs File -> Text -> Either MegaparsecError InfoTable +runParser :: Path Abs File -> Text -> Either MegaparsecError Module runParser = runParserS parseAsmSig runParser' :: BuilderState -> Path Abs File -> Text -> Either MegaparsecError BuilderState diff --git a/src/Juvix/Compiler/Asm/Translation/FromTree.hs b/src/Juvix/Compiler/Asm/Translation/FromTree.hs index cd15c174d8..40be3346bb 100644 --- a/src/Juvix/Compiler/Asm/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Asm/Translation/FromTree.hs @@ -1,23 +1,32 @@ module Juvix.Compiler.Asm.Translation.FromTree (fromTree) where import Data.DList qualified as DL -import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Extra.Base import Juvix.Compiler.Asm.Language -import Juvix.Compiler.Tree.Data.InfoTable qualified as Tree +import Juvix.Compiler.Tree.Data.Module qualified as Tree import Juvix.Compiler.Tree.Language qualified as Tree -- DList for O(1) snoc and append type Code' = DL.DList Command -fromTree :: Tree.InfoTable -> InfoTable -fromTree tab = - InfoTable - { _infoMainFunction = tab ^. Tree.infoMainFunction, - _infoFunctions = genCode <$> tab ^. Tree.infoFunctions, - _infoInductives = tab ^. Tree.infoInductives, - _infoConstrs = tab ^. Tree.infoConstrs +fromTree :: Tree.Module -> Module +fromTree md = + Module + { _moduleId = md ^. moduleId, + _moduleInfoTable = tab', + _moduleImports = md ^. moduleImports, + _moduleImportsTable = mempty } + where + tab = computeCombinedInfoTable md + tab' = + InfoTable + { _infoMainFunction = tab ^. Tree.infoMainFunction, + _infoFunctions = genCode <$> tab ^. Tree.infoFunctions, + _infoInductives = tab ^. Tree.infoInductives, + _infoConstrs = tab ^. Tree.infoConstrs + } -- Generate code for a single function. genCode :: Tree.FunctionInfo -> FunctionInfo diff --git a/src/Juvix/Compiler/Casm/Translation/FromReg.hs b/src/Juvix/Compiler/Casm/Translation/FromReg.hs index 4ad691280f..eb97c4e341 100644 --- a/src/Juvix/Compiler/Casm/Translation/FromReg.hs +++ b/src/Juvix/Compiler/Casm/Translation/FromReg.hs @@ -11,7 +11,7 @@ import Juvix.Compiler.Casm.Extra.Base import Juvix.Compiler.Casm.Extra.Stdlib import Juvix.Compiler.Casm.Language import Juvix.Compiler.Casm.Translation.FromReg.CasmBuilder -import Juvix.Compiler.Reg.Data.Blocks.InfoTable qualified as Reg +import Juvix.Compiler.Reg.Data.Blocks.Module qualified as Reg import Juvix.Compiler.Reg.Extra.Blocks.Info qualified as Reg import Juvix.Compiler.Reg.Language.Blocks qualified as Reg import Juvix.Compiler.Reg.Pretty qualified as Reg @@ -20,7 +20,7 @@ import Juvix.Compiler.Tree.Extra.Rep qualified as Reg import Juvix.Data.Field fromReg :: Reg.InfoTable -> Result -fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolId tab) $ do +fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.nextSymbolId tab) $ do let startAddr :: Address = 2 startSym <- freshSymbol endSym <- freshSymbol @@ -31,7 +31,7 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI registerLabelName startSym startName registerLabelAddress startSym startAddr let mainSym = fromJust $ tab ^. Reg.infoMainFunction - mainInfo = Reg.lookupFunInfo tab mainSym + mainInfo = Reg.lookupTabFunInfo tab mainSym mainName = mainInfo ^. Reg.functionName mainResultType = Reg.typeTarget (mainInfo ^. Reg.functionType) mainArgs = getInputArgs (mainInfo ^. Reg.functionArgsNum) (mainInfo ^. Reg.functionArgNames) @@ -87,7 +87,7 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI where goRecord :: Symbol -> [Instruction] goRecord sym = case indInfo ^. Reg.inductiveConstructors of - [tag] -> case Reg.lookupConstrInfo tab tag of + [tag] -> case Reg.lookupTabConstrInfo tab tag of Reg.ConstructorInfo {..} -> map mkOutInstr [0 .. toOffset _constructorArgsNum - 1] where @@ -95,7 +95,7 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI mkOutInstr i = mkAssignAp (Load $ LoadValue (MemRef Ap (-off - i - 1)) i) _ -> impossible where - indInfo = Reg.lookupInductiveInfo tab sym + indInfo = Reg.lookupTabInductiveInfo tab sym mkLoadInputArg :: Text -> [Instruction] mkLoadInputArg arg = [Hint (HintInput arg), mkAssignAp (Val $ Ref $ MemRef Ap 0)] @@ -111,7 +111,7 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI mkFunCall :: Symbol -> [Instruction] mkFunCall sym = - [ mkCallRel $ Lab $ LabelRef sym (Just $ quoteName $ Reg.lookupFunInfo tab sym ^. Reg.functionName), + [ mkCallRel $ Lab $ LabelRef sym (Just $ quoteName $ Reg.lookupTabFunInfo tab sym ^. Reg.functionName), Return, Nop ] @@ -143,7 +143,7 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI argsOffset = 3 ppVarComment :: Reg.VarRef -> Int -> Text - ppVarComment var off = Reg.ppPrint tab var <> " is [fp + " <> show off <> "]" + ppVarComment var off = Reg.ppPrint (Reg.moduleFromInfoTable tab) var <> " is [fp + " <> show off <> "]" goFun :: forall r. (Member LabelInfoBuilder r) => StdlibBuiltins -> LabelRef -> (Address, [[Instruction]]) -> Reg.FunctionInfo -> Sem r (Address, [[Instruction]]) goFun blts failLab (addr0, acc) funInfo = do @@ -211,7 +211,7 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI saveLiveVar :: Reg.VarRef -> Sem r () saveLiveVar var = do ref <- mkMemRef var - let comment = Reg.ppPrint tab var + let comment = Reg.ppPrint (Reg.moduleFromInfoTable tab) var goAssignAp' (Just comment) (Val (Ref ref)) -- The `goCallBlock` function is used to switch to a new basic block. @@ -262,7 +262,7 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI mkLoad :: Reg.ConstrField -> Sem r RValue mkLoad Reg.ConstrField {..} = do - let tagOffset = if Reg.isConstrRecord tab _constrFieldTag then 0 else 1 + let tagOffset = if Reg.isTabConstrRecord tab _constrFieldTag then 0 else 1 v <- mkMemRef _constrFieldRef return $ Load $ LoadValue v (toOffset _constrFieldIndex + tagOffset) @@ -509,7 +509,7 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI goAlloc :: Reg.InstrAlloc -> Sem r () goAlloc Reg.InstrAlloc {..} = do goAllocCall _instrAllocResult - unless (Reg.isConstrRecord tab _instrAllocTag) $ + unless (Reg.isTabConstrRecord tab _instrAllocTag) $ goAssignAp (Val $ Imm $ fromIntegral tagId) mapM_ goAssignApValue _instrAllocArgs where @@ -584,7 +584,7 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI mapM_ goAssignApValue (reverse args) output'' $ mkCallRel $ Lab $ LabelRef sym (Just funName) where - funName = quoteName (Reg.lookupFunInfo tab sym ^. Reg.functionName) + funName = quoteName (Reg.lookupTabFunInfo tab sym ^. Reg.functionName) Reg.CallClosure cl -> do goAssignApBuiltins mapM_ goAssignApValue (reverse args) @@ -665,7 +665,7 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI goCase :: HashSet Reg.VarRef -> Reg.InstrCase -> Sem r () goCase liveVars Reg.InstrCase {..} = do - massert (not (Reg.isInductiveRecord tab _instrCaseInductive)) + massert (not (Reg.isTabInductiveRecord tab _instrCaseInductive)) syms <- replicateM (length tags) freshSymbol symEnd <- freshSymbol let symMap = HashMap.fromList $ zip tags syms @@ -693,7 +693,7 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI registerLabelAddress symEnd addrEnd output'' $ Label labEnd where - tags = Reg.lookupInductiveInfo tab _instrCaseInductive ^. Reg.inductiveConstructors + tags = Reg.lookupTabInductiveInfo tab _instrCaseInductive ^. Reg.inductiveConstructors ctrTags = HashSet.fromList $ map (^. Reg.caseBranchTag) _instrCaseBranches defaultTags = filter (not . flip HashSet.member ctrTags) tags diff --git a/src/Juvix/Compiler/Core/Data/Module/Base.hs b/src/Juvix/Compiler/Core/Data/Module/Base.hs index 25ab337aa2..c2ce2c76c7 100644 --- a/src/Juvix/Compiler/Core/Data/Module/Base.hs +++ b/src/Juvix/Compiler/Core/Data/Module/Base.hs @@ -1,6 +1,12 @@ -module Juvix.Compiler.Core.Data.Module.Base where +module Juvix.Compiler.Core.Data.Module.Base + ( module Juvix.Compiler.Core.Data.Module.Base, + module Juvix.Data.ModuleId, + ) +where +import Data.HashMap.Strict qualified as HashMap import Juvix.Data.ModuleId +import Juvix.Data.PPOutput (prettyText) import Juvix.Extra.Serialize import Juvix.Prelude @@ -23,15 +29,35 @@ instance (NFData t) => NFData (Module' t) makeLenses ''Module' +newtype ModuleTable' t = ModuleTable + { _moduleTable :: HashMap ModuleId (Module' t) + } + deriving newtype (Semigroup, Monoid) + deriving stock (Generic) + +makeLenses ''ModuleTable' + +instance (NFData t) => NFData (ModuleTable' t) + withInfoTable :: (Monoid t) => (Module' t -> Module' t) -> t -> t withInfoTable f tab = f (moduleFromInfoTable tab) ^. moduleInfoTable -emptyModule :: (Monoid t) => Module' t -emptyModule = Module defaultModuleId mempty mempty mempty +emptyModule :: (Monoid t) => ModuleId -> Module' t +emptyModule mid = Module mid mempty mempty mempty moduleFromInfoTable :: (Monoid t) => t -> Module' t moduleFromInfoTable tab = Module defaultModuleId tab mempty mempty computeCombinedInfoTable :: (Monoid t) => Module' t -> t computeCombinedInfoTable Module {..} = _moduleInfoTable <> _moduleImportsTable + +lookupModuleTable' :: ModuleTable' t -> ModuleId -> Maybe (Module' t) +lookupModuleTable' mt mid = HashMap.lookup mid (mt ^. moduleTable) + +lookupModuleTable :: ModuleTable' t -> ModuleId -> Module' t +lookupModuleTable mt mid = + fromMaybe (impossibleError ("Could not find module " <> prettyText mid)) (lookupModuleTable' mt mid) + +computeImportsTable :: (Monoid t) => ModuleTable' t -> [ModuleId] -> t +computeImportsTable mt = foldMap ((^. moduleImportsTable) . lookupModuleTable mt) diff --git a/src/Juvix/Compiler/Core/Data/Stripped/Module.hs b/src/Juvix/Compiler/Core/Data/Stripped/Module.hs new file mode 100644 index 0000000000..5455148787 --- /dev/null +++ b/src/Juvix/Compiler/Core/Data/Stripped/Module.hs @@ -0,0 +1,18 @@ +module Juvix.Compiler.Core.Data.Stripped.Module + ( module Juvix.Compiler.Core.Data.Stripped.Module, + module Juvix.Compiler.Core.Data.Stripped.InfoTable, + ) +where + +import Juvix.Compiler.Core.Data.Stripped.InfoTable +import Juvix.Data.ModuleId +import Juvix.Prelude + +data Module = Module + { _moduleId :: ModuleId, + _moduleInfoTable :: InfoTable, + -- | The imports field contains all direct (non-transitive) dependencies of + -- the module. + _moduleImports :: [ModuleId] + } + deriving stock (Generic) diff --git a/src/Juvix/Compiler/Core/Extra/Utils.hs b/src/Juvix/Compiler/Core/Extra/Utils.hs index 29f288fca4..ca5bd0dd29 100644 --- a/src/Juvix/Compiler/Core/Extra/Utils.hs +++ b/src/Juvix/Compiler/Core/Extra/Utils.hs @@ -153,7 +153,7 @@ isImmediate md = \case node -> isType md mempty node isImmediate' :: Node -> Bool -isImmediate' = isImmediate emptyModule +isImmediate' = isImmediate (emptyModule defaultModuleId) isImmediateOrLambda :: Module -> Node -> Bool isImmediateOrLambda md node = isImmediate md node || isLambda node @@ -310,7 +310,7 @@ getSymbols md = gather go mempty _ -> acc getSymbols' :: InfoTable -> Node -> HashSet Symbol -getSymbols' tab = getSymbols emptyModule {_moduleInfoTable = tab} +getSymbols' tab = getSymbols (emptyModule defaultModuleId) {_moduleInfoTable = tab} -- | Prism for NRec _NRec :: SimpleFold Node LetRec @@ -673,7 +673,7 @@ getTableSymbolsMap tab = mempty (map (getSymbolsMap md) (HashMap.elems $ tab ^. identContext)) where - md = emptyModule {_moduleInfoTable = tab} + md = (emptyModule defaultModuleId) {_moduleInfoTable = tab} getModuleSymbolsMap :: Module -> HashMap Symbol Int getModuleSymbolsMap = getTableSymbolsMap . computeCombinedInfoTable diff --git a/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs b/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs index fc28de7918..30a5709238 100644 --- a/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs +++ b/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs @@ -1,16 +1,24 @@ -module Juvix.Compiler.Core.Translation.Stripped.FromCore (fromCore) where +module Juvix.Compiler.Core.Translation.Stripped.FromCore (fromCore, fromCore') where import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Core -import Juvix.Compiler.Core.Data.Stripped.InfoTable qualified as Stripped +import Juvix.Compiler.Core.Data.Stripped.Module qualified as Stripped import Juvix.Compiler.Core.Extra.Stripped.Base qualified as Stripped import Juvix.Compiler.Core.Info.LocationInfo import Juvix.Compiler.Core.Info.NameInfo import Juvix.Compiler.Core.Language.Stripped qualified as Stripped import Juvix.Compiler.Core.Pretty -fromCore :: InfoTable -> Stripped.InfoTable -fromCore tab = +fromCore :: Module -> Stripped.Module +fromCore Module {..} = + Stripped.Module + { _moduleId = _moduleId, + _moduleInfoTable = fromCore' (_moduleInfoTable <> _moduleImportsTable), + _moduleImports = _moduleImports + } + +fromCore' :: InfoTable -> Stripped.InfoTable +fromCore' tab = Stripped.InfoTable { _infoMain = tab ^. infoMain, _infoFunctions = fmap (translateFunctionInfo tab) (tab' ^. infoIdentifiers), @@ -179,7 +187,7 @@ translateFunctionInfo tab IdentifierInfo {..} = _functionIsExported = _identifierIsExported } where - body = fromJust $ HashMap.lookup _identifierSymbol (tab ^. identContext) + body = lookupTabIdentifierNode tab _identifierSymbol translateArgInfo :: Binder -> Stripped.ArgumentInfo translateArgInfo Binder {..} = diff --git a/src/Juvix/Compiler/Pipeline.hs b/src/Juvix/Compiler/Pipeline.hs index 11ffcaee60..474acb8b11 100644 --- a/src/Juvix/Compiler/Pipeline.hs +++ b/src/Juvix/Compiler/Pipeline.hs @@ -164,19 +164,19 @@ upToStoredCore' p = do upToReg :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError] r) => - Sem r Reg.InfoTable + Sem r Reg.Module upToReg = upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToReg _coreResultModule upToTree :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError] r) => - Sem r Tree.InfoTable + Sem r Tree.Module upToTree = upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToTree Core.IdentityTrans _coreResultModule upToAsm :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError] r) => - Sem r Asm.InfoTable + Sem r Asm.Module upToAsm = upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToAsm _coreResultModule @@ -228,20 +228,19 @@ storedCoreToTree :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.TransformationId -> Core.Module -> - Sem r Tree.InfoTable + Sem r Tree.Module storedCoreToTree checkId md = do Tree.fromCore . Stripped.fromCore - . Core.computeCombinedInfoTable <$> Core.toStripped checkId md storedCoreToAnoma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r NockmaTree.AnomaResult storedCoreToAnoma = storedCoreToTree Core.CheckAnoma >=> treeToAnoma -storedCoreToAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Asm.InfoTable +storedCoreToAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Asm.Module storedCoreToAsm = storedCoreToTree Core.CheckExec >=> treeToAsm -storedCoreToReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Reg.InfoTable +storedCoreToReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Reg.Module storedCoreToReg = storedCoreToAsm >=> asmToReg storedCoreToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r C.MiniCResult @@ -263,13 +262,13 @@ storedCoreToCairo = storedCoreToCasm >=> casmToCairo -- Workflows from Core -------------------------------------------------------------------------------- -coreToTree :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.TransformationId -> Core.Module -> Sem r Tree.InfoTable +coreToTree :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.TransformationId -> Core.Module -> Sem r Tree.Module coreToTree checkId = Core.toStored >=> storedCoreToTree checkId -coreToAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Asm.InfoTable +coreToAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Asm.Module coreToAsm = Core.toStored >=> storedCoreToAsm -coreToReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Reg.InfoTable +coreToReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Reg.Module coreToReg = Core.toStored >=> storedCoreToReg coreToCasm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Casm.Result @@ -294,68 +293,68 @@ coreToMiniC = coreToAsm >=> asmToMiniC -- Other workflows -------------------------------------------------------------------------------- -treeToAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r Asm.InfoTable +treeToAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.Module -> Sem r Asm.Module treeToAsm = Tree.toAsm >=> return . Asm.fromTree -treeToCairoAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r Asm.InfoTable +treeToCairoAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.Module -> Sem r Asm.Module treeToCairoAsm = Tree.toCairoAsm >=> return . Asm.fromTree -treeToReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r Reg.InfoTable +treeToReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.Module -> Sem r Reg.Module treeToReg = treeToAsm >=> asmToReg -treeToAnoma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r (NockmaTree.AnomaResult) -treeToAnoma = Tree.toNockma >=> mapReader NockmaTree.fromEntryPoint . NockmaTree.fromTreeTable +treeToAnoma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.Module -> Sem r (NockmaTree.AnomaResult) +treeToAnoma = Tree.toNockma >=> mapReader NockmaTree.fromEntryPoint . NockmaTree.fromTreeTable . computeCombinedInfoTable -treeToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r C.MiniCResult +treeToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.Module -> Sem r C.MiniCResult treeToMiniC = treeToAsm >=> asmToMiniC -treeToCasm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r Casm.Result +treeToCasm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.Module -> Sem r Casm.Result treeToCasm = treeToCairoAsm >=> asmToCasm -treeToCairo :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r Cairo.Result +treeToCairo :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.Module -> Sem r Cairo.Result treeToCairo = treeToCasm >=> casmToCairo -treeToRust' :: (Members '[Error JuvixError, Reader EntryPoint] r) => Rust.Backend -> Tree.InfoTable -> Sem r Rust.Result +treeToRust' :: (Members '[Error JuvixError, Reader EntryPoint] r) => Rust.Backend -> Tree.Module -> Sem r Rust.Result treeToRust' backend = treeToReg >=> regToRust' backend -treeToRust :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r Rust.Result +treeToRust :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.Module -> Sem r Rust.Result treeToRust = treeToRust' Rust.BackendRust -treeToRiscZeroRust :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.InfoTable -> Sem r Rust.Result +treeToRiscZeroRust :: (Members '[Error JuvixError, Reader EntryPoint] r) => Tree.Module -> Sem r Rust.Result treeToRiscZeroRust = treeToRust' Rust.BackendRiscZero -asmToReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Asm.InfoTable -> Sem r Reg.InfoTable +asmToReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Asm.Module -> Sem r Reg.Module asmToReg = Asm.toReg >=> return . Reg.fromAsm -asmToCasm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Asm.InfoTable -> Sem r Casm.Result +asmToCasm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Asm.Module -> Sem r Casm.Result asmToCasm = asmToReg >=> regToCasm -asmToCairo :: (Members '[Error JuvixError, Reader EntryPoint] r) => Asm.InfoTable -> Sem r Cairo.Result +asmToCairo :: (Members '[Error JuvixError, Reader EntryPoint] r) => Asm.Module -> Sem r Cairo.Result asmToCairo = asmToReg >=> regToCairo -asmToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Asm.InfoTable -> Sem r C.MiniCResult +asmToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Asm.Module -> Sem r C.MiniCResult asmToMiniC = asmToReg >=> regToMiniC -regToMiniC :: (Member (Reader EntryPoint) r) => Reg.InfoTable -> Sem r C.MiniCResult -regToMiniC tab = do - tab' <- Reg.toC tab +regToMiniC :: (Member (Reader EntryPoint) r) => Reg.Module -> Sem r C.MiniCResult +regToMiniC md = do + md' <- Reg.toC md e <- ask - return $ C.fromReg (Backend.getLimits (fromJust (e ^. entryPointTarget)) (e ^. entryPointDebug)) tab' + return $ C.fromReg (Backend.getLimits (fromJust (e ^. entryPointTarget)) (e ^. entryPointDebug)) (computeCombinedInfoTable md') -regToRust' :: (Member (Reader EntryPoint) r) => Rust.Backend -> Reg.InfoTable -> Sem r Rust.Result -regToRust' backend tab = do - tab' <- Reg.toRust tab +regToRust' :: (Member (Reader EntryPoint) r) => Rust.Backend -> Reg.Module -> Sem r Rust.Result +regToRust' backend md = do + md' <- Reg.toRust md e <- ask - return $ Rust.fromReg backend (Backend.getLimits (fromJust (e ^. entryPointTarget)) (e ^. entryPointDebug)) tab' + return $ Rust.fromReg backend (Backend.getLimits (fromJust (e ^. entryPointTarget)) (e ^. entryPointDebug)) (computeCombinedInfoTable md') -regToRust :: (Member (Reader EntryPoint) r) => Reg.InfoTable -> Sem r Rust.Result +regToRust :: (Member (Reader EntryPoint) r) => Reg.Module -> Sem r Rust.Result regToRust = regToRust' Rust.BackendRust -regToRiscZeroRust :: (Member (Reader EntryPoint) r) => Reg.InfoTable -> Sem r Rust.Result +regToRiscZeroRust :: (Member (Reader EntryPoint) r) => Reg.Module -> Sem r Rust.Result regToRiscZeroRust = regToRust' Rust.BackendRiscZero -regToCasm :: (Member (Reader EntryPoint) r) => Reg.InfoTable -> Sem r Casm.Result -regToCasm = Reg.toCasm >=> return . Casm.fromReg +regToCasm :: (Member (Reader EntryPoint) r) => Reg.Module -> Sem r Casm.Result +regToCasm = Reg.toCasm >=> return . Casm.fromReg . computeCombinedInfoTable casmToCairo :: (Member (Reader EntryPoint) r) => Casm.Result -> Sem r Cairo.Result casmToCairo Casm.Result {..} = do @@ -364,5 +363,5 @@ casmToCairo Casm.Result {..} = do . Cairo.serialize _resultOutputSize (map Casm.builtinName _resultBuiltins) $ Cairo.fromCasm code' -regToCairo :: (Member (Reader EntryPoint) r) => Reg.InfoTable -> Sem r Cairo.Result +regToCairo :: (Member (Reader EntryPoint) r) => Reg.Module -> Sem r Cairo.Result regToCairo = regToCasm >=> casmToCairo diff --git a/src/Juvix/Compiler/Pipeline/Modular.hs b/src/Juvix/Compiler/Pipeline/Modular.hs index a11488518f..5fbfefd0fe 100644 --- a/src/Juvix/Compiler/Pipeline/Modular.hs +++ b/src/Juvix/Compiler/Pipeline/Modular.hs @@ -1 +1,7 @@ module Juvix.Compiler.Pipeline.Modular where + +{- +import Juvix.Compiler.Core.Data.Module +import Juvix.Compiler.Store.Backend.Core qualified as Store.Core +import Juvix.Compiler.Store.Language qualified as Store +-} diff --git a/src/Juvix/Compiler/Pipeline/Run.hs b/src/Juvix/Compiler/Pipeline/Run.hs index 714b90fb08..9f249c41d9 100644 --- a/src/Juvix/Compiler/Pipeline/Run.hs +++ b/src/Juvix/Compiler/Pipeline/Run.hs @@ -294,7 +294,7 @@ runReplPipelineIOEither' lockMode entry = do _artifactResolver = iniResolverState, _artifactNameIdState = genNameIdState defaultModuleId, _artifactTypeCheckingTables = mempty, - _artifactCoreModule = Core.emptyModule, + _artifactCoreModule = Core.emptyModule defaultModuleId, _artifactScopeTable = mempty, _artifactScopeExports = mempty, _artifactScoperState = Scoper.iniScoperState mempty, diff --git a/src/Juvix/Compiler/Reg/Data/Blocks/Module.hs b/src/Juvix/Compiler/Reg/Data/Blocks/Module.hs new file mode 100644 index 0000000000..af6e2a9022 --- /dev/null +++ b/src/Juvix/Compiler/Reg/Data/Blocks/Module.hs @@ -0,0 +1,14 @@ +module Juvix.Compiler.Reg.Data.Blocks.Module + ( module Juvix.Compiler.Reg.Data.Blocks.Module, + module Juvix.Compiler.Reg.Data.Blocks.InfoTable, + module Juvix.Compiler.Tree.Data.Module.Base, + ) +where + +import Juvix.Compiler.Reg.Data.Blocks.InfoTable +import Juvix.Compiler.Reg.Language.Blocks +import Juvix.Compiler.Tree.Data.Module.Base + +type Module = Module'' Block () + +type ModuleTable = ModuleTable'' Block () diff --git a/src/Juvix/Compiler/Reg/Data/Module.hs b/src/Juvix/Compiler/Reg/Data/Module.hs new file mode 100644 index 0000000000..0a619aac73 --- /dev/null +++ b/src/Juvix/Compiler/Reg/Data/Module.hs @@ -0,0 +1,14 @@ +module Juvix.Compiler.Reg.Data.Module + ( module Juvix.Compiler.Reg.Data.Module, + module Juvix.Compiler.Reg.Data.InfoTable, + module Juvix.Compiler.Tree.Data.Module.Base, + ) +where + +import Juvix.Compiler.Reg.Data.InfoTable +import Juvix.Compiler.Reg.Language +import Juvix.Compiler.Tree.Data.Module.Base + +type Module = Module'' Code () + +type ModuleTable = ModuleTable'' Code () diff --git a/src/Juvix/Compiler/Reg/Interpreter.hs b/src/Juvix/Compiler/Reg/Interpreter.hs index 66181269de..bd36a2b963 100644 --- a/src/Juvix/Compiler/Reg/Interpreter.hs +++ b/src/Juvix/Compiler/Reg/Interpreter.hs @@ -9,7 +9,7 @@ import Control.Monad.ST import Data.HashMap.Strict qualified as HashMap import Data.Vector qualified as Vec import Data.Vector.Mutable qualified as MV -import Juvix.Compiler.Reg.Data.InfoTable +import Juvix.Compiler.Reg.Data.Module import Juvix.Compiler.Reg.Error import Juvix.Compiler.Reg.Extra.Info import Juvix.Compiler.Reg.Interpreter.Base @@ -22,15 +22,15 @@ type Vars s = MV.MVector s (Maybe Val) type Args = Vec.Vector Val -runFunction :: forall r. (Members '[Error RegError, EmbedIO] r) => Handle -> InfoTable -> [Val] -> FunctionInfo -> Sem r Val -runFunction hout infoTable args0 info0 = do +runFunction :: forall r. (Members '[Error RegError, EmbedIO] r) => Handle -> Module -> [Val] -> FunctionInfo -> Sem r Val +runFunction hout md args0 info0 = do r <- catchRunError (runST (goFun args0 info0)) case r of Left err -> throw err Right v -> return v where localVarsNum :: HashMap Symbol Int - localVarsNum = HashMap.map (computeLocalVarsNum . (^. functionCode)) (infoTable ^. infoFunctions) + localVarsNum = HashMap.map (computeLocalVarsNum . (^. functionCode)) (md ^. moduleInfoTable . infoFunctions) goFun :: [Val] -> FunctionInfo -> ST s Val goFun args info = do @@ -121,7 +121,7 @@ runFunction hout infoTable args0 info0 = do go args tmps instrs unop :: UnaryOp -> Val -> Val - unop op v = case evalUnop infoTable op v of + unop op v = case evalUnop md op v of Left err -> throwRunError err Nothing Right v' -> v' @@ -199,7 +199,7 @@ runFunction hout infoTable args0 info0 = do writeVarRef args tmps _instrCallResult val go args tmps instrs where - fi = lookupFunInfo infoTable sym + fi = lookupFunInfo md sym CallClosure r -> do cl <- readVarRef args tmps r case cl of @@ -208,7 +208,7 @@ runFunction hout infoTable args0 info0 = do writeVarRef args tmps _instrCallResult val go args tmps instrs where - fi = lookupFunInfo infoTable sym + fi = lookupFunInfo md sym _ -> throwRunError "expected a closure" Nothing @@ -219,13 +219,13 @@ runFunction hout infoTable args0 info0 = do case _instrTailCallType of CallFun sym -> goFun vals fi where - fi = lookupFunInfo infoTable sym + fi = lookupFunInfo md sym CallClosure r -> do cl <- readVarRef args tmps r case cl of ValClosure (Closure sym vs) -> goFun (vs ++ vals) fi where - fi = lookupFunInfo infoTable sym + fi = lookupFunInfo md sym _ -> throwRunError "expected a closure" Nothing | otherwise = @@ -260,7 +260,7 @@ runFunction hout infoTable args0 info0 = do cl' <- goFun (take (fi ^. functionArgsNum) vs') fi goClosures cl' (drop (fi ^. functionArgsNum) vs') where - fi = lookupFunInfo infoTable sym + fi = lookupFunInfo md sym n = length vs + length vals _ -> throwRunError "expected a closure" Nothing @@ -326,19 +326,19 @@ runFunction hout infoTable args0 info0 = do printVal :: Val -> Text printVal = \case ValString s -> s - v -> ppPrint infoTable v + v -> ppPrint md v -runIO :: forall r. (Members '[Error RegError, EmbedIO] r) => Handle -> Handle -> InfoTable -> Val -> Sem r Val -runIO hin hout infoTable = \case +runIO :: forall r. (Members '[Error RegError, EmbedIO] r) => Handle -> Handle -> Module -> Val -> Sem r Val +runIO hin hout md = \case ValConstr (Constr (BuiltinTag TagReturn) [x]) -> return x ValConstr (Constr (BuiltinTag TagBind) [x, f]) -> do - x' <- runIO hin hout infoTable x + x' <- runIO hin hout md x case f of ValClosure (Closure sym args) -> do - let fi = lookupFunInfo infoTable sym - x'' <- runFunction hout infoTable (args ++ [x']) fi - runIO hin hout infoTable x'' + let fi = lookupFunInfo md sym + x'' <- runFunction hout md (args ++ [x']) fi + runIO hin hout md x'' _ -> throw $ RegError @@ -349,7 +349,7 @@ runIO hin hout infoTable = \case hPutStr hout s return ValVoid ValConstr (Constr (BuiltinTag TagWrite) [arg]) -> do - hPutStr hout (ppPrint infoTable arg) + hPutStr hout (ppPrint md arg) return ValVoid ValConstr (Constr (BuiltinTag TagReadLn) []) -> do hFlush hout @@ -358,7 +358,7 @@ runIO hin hout infoTable = \case val -> return val -runFunctionIO :: forall r. (Members '[Error RegError, EmbedIO] r) => Handle -> Handle -> InfoTable -> [Val] -> FunctionInfo -> Sem r Val -runFunctionIO hin hout tab args funInfo = do - val <- runFunction hout tab args funInfo - runIO hin hout tab val +runFunctionIO :: forall r. (Members '[Error RegError, EmbedIO] r) => Handle -> Handle -> Module -> [Val] -> FunctionInfo -> Sem r Val +runFunctionIO hin hout md args funInfo = do + val <- runFunction hout md args funInfo + runIO hin hout md val diff --git a/src/Juvix/Compiler/Reg/Pipeline.hs b/src/Juvix/Compiler/Reg/Pipeline.hs index c9684b12d5..5ae3999093 100644 --- a/src/Juvix/Compiler/Reg/Pipeline.hs +++ b/src/Juvix/Compiler/Reg/Pipeline.hs @@ -1,37 +1,37 @@ module Juvix.Compiler.Reg.Pipeline ( module Juvix.Compiler.Reg.Pipeline, - module Juvix.Compiler.Reg.Data.InfoTable, + module Juvix.Compiler.Reg.Data.Module, Options, ) where import Juvix.Compiler.Pipeline.EntryPoint (EntryPoint) -import Juvix.Compiler.Reg.Data.Blocks.InfoTable qualified as Blocks -import Juvix.Compiler.Reg.Data.InfoTable +import Juvix.Compiler.Reg.Data.Blocks.Module qualified as Blocks +import Juvix.Compiler.Reg.Data.Module import Juvix.Compiler.Reg.Transformation import Juvix.Compiler.Reg.Transformation.Blocks.Liveness qualified as Blocks import Juvix.Compiler.Reg.Translation.Blocks.FromReg qualified as Blocks -- | Perform transformations on JuvixReg necessary before the translation to C -toC :: (Member (Reader EntryPoint) r) => InfoTable -> Sem r InfoTable +toC :: (Member (Reader EntryPoint) r) => Module -> Sem r Module toC = mapReader fromEntryPoint . toC' where - toC' :: (Member (Reader Options) r) => InfoTable -> Sem r InfoTable + toC' :: (Member (Reader Options) r) => Module -> Sem r Module toC' = applyTransformations toCTransformations -- | Perform transformations on JuvixReg necessary before the translation to Rust -toRust :: (Member (Reader EntryPoint) r) => InfoTable -> Sem r InfoTable +toRust :: (Member (Reader EntryPoint) r) => Module -> Sem r Module toRust = mapReader fromEntryPoint . toRust' where - toRust' :: (Member (Reader Options) r) => InfoTable -> Sem r InfoTable + toRust' :: (Member (Reader Options) r) => Module -> Sem r Module toRust' = applyTransformations toRustTransformations -- | Perform transformations on JuvixReg necessary before the translation to -- Cairo assembly -toCasm :: (Member (Reader EntryPoint) r) => InfoTable -> Sem r Blocks.InfoTable +toCasm :: (Member (Reader EntryPoint) r) => Module -> Sem r Blocks.Module toCasm = mapReader fromEntryPoint . toCasm' where - toCasm' :: (Member (Reader Options) r) => InfoTable -> Sem r Blocks.InfoTable + toCasm' :: (Member (Reader Options) r) => Module -> Sem r Blocks.Module toCasm' = applyTransformations toCasmTransformations >=> return . Blocks.computeLiveness . Blocks.fromReg diff --git a/src/Juvix/Compiler/Reg/Pretty.hs b/src/Juvix/Compiler/Reg/Pretty.hs index 625c090c59..54494d5233 100644 --- a/src/Juvix/Compiler/Reg/Pretty.hs +++ b/src/Juvix/Compiler/Reg/Pretty.hs @@ -5,15 +5,15 @@ module Juvix.Compiler.Reg.Pretty ) where -import Juvix.Compiler.Reg.Data.InfoTable +import Juvix.Compiler.Reg.Data.Module import Juvix.Compiler.Reg.Pretty.Base import Juvix.Compiler.Reg.Pretty.Options import Juvix.Data.PPOutput import Juvix.Prelude import Prettyprinter.Render.Terminal qualified as Ansi -ppOutDefault :: (PrettyCode c) => InfoTable' t e -> c -> AnsiText -ppOutDefault tab = mkAnsiText . PPOutput . doc (defaultOptions tab) +ppOutDefault :: (PrettyCode c) => Module'' t e -> c -> AnsiText +ppOutDefault md = mkAnsiText . PPOutput . doc (defaultOptions md) ppOut :: (PrettyCode c) => Options -> c -> AnsiText ppOut o = mkAnsiText . PPOutput . doc o @@ -21,8 +21,8 @@ ppOut o = mkAnsiText . PPOutput . doc o ppTrace' :: (PrettyCode c) => Options -> c -> Text ppTrace' opts = Ansi.renderStrict . reAnnotateS stylize . layoutPretty defaultLayoutOptions . doc opts -ppTrace :: (PrettyCode c) => InfoTable' t e -> c -> Text -ppTrace tab = ppTrace' (defaultOptions tab) +ppTrace :: (PrettyCode c) => Module'' t e -> c -> Text +ppTrace md = ppTrace' (defaultOptions md) -ppPrint :: (PrettyCode c) => InfoTable' t e -> c -> Text -ppPrint tab = toPlainText . ppOutDefault tab +ppPrint :: (PrettyCode c) => Module'' t e -> c -> Text +ppPrint md = toPlainText . ppOutDefault md diff --git a/src/Juvix/Compiler/Reg/Transformation.hs b/src/Juvix/Compiler/Reg/Transformation.hs index 9d7a97b9c0..555a6455e1 100644 --- a/src/Juvix/Compiler/Reg/Transformation.hs +++ b/src/Juvix/Compiler/Reg/Transformation.hs @@ -18,10 +18,10 @@ import Juvix.Compiler.Reg.Transformation.Optimize.Phase.Cairo qualified as Phase import Juvix.Compiler.Reg.Transformation.Optimize.Phase.Main qualified as Phase.Main import Juvix.Compiler.Reg.Transformation.SSA -applyTransformations :: forall r. (Member (Reader Options) r) => [TransformationId] -> InfoTable -> Sem r InfoTable +applyTransformations :: forall r. (Member (Reader Options) r) => [TransformationId] -> Module -> Sem r Module applyTransformations ts tbl = foldM (flip appTrans) tbl ts where - appTrans :: TransformationId -> InfoTable -> Sem r InfoTable + appTrans :: TransformationId -> Module -> Sem r Module appTrans = \case IdentityTrans -> return . identity Cleanup -> return . cleanup diff --git a/src/Juvix/Compiler/Reg/Transformation/Base.hs b/src/Juvix/Compiler/Reg/Transformation/Base.hs index 9f734efb5d..02ef95ec65 100644 --- a/src/Juvix/Compiler/Reg/Transformation/Base.hs +++ b/src/Juvix/Compiler/Reg/Transformation/Base.hs @@ -1,12 +1,12 @@ module Juvix.Compiler.Reg.Transformation.Base ( module Juvix.Compiler.Tree.Transformation.Generic.Base, module Juvix.Compiler.Tree.Options, - module Juvix.Compiler.Reg.Data.InfoTable, + module Juvix.Compiler.Reg.Data.Module, module Juvix.Compiler.Reg.Language, ) where -import Juvix.Compiler.Reg.Data.InfoTable +import Juvix.Compiler.Reg.Data.Module import Juvix.Compiler.Reg.Language import Juvix.Compiler.Tree.Options import Juvix.Compiler.Tree.Transformation.Generic.Base diff --git a/src/Juvix/Compiler/Reg/Transformation/Blocks/Base.hs b/src/Juvix/Compiler/Reg/Transformation/Blocks/Base.hs index 1c631f6ebd..bf2bbbb75f 100644 --- a/src/Juvix/Compiler/Reg/Transformation/Blocks/Base.hs +++ b/src/Juvix/Compiler/Reg/Transformation/Blocks/Base.hs @@ -1,10 +1,10 @@ module Juvix.Compiler.Reg.Transformation.Blocks.Base ( module Juvix.Compiler.Tree.Transformation.Generic.Base, - module Juvix.Compiler.Reg.Data.Blocks.InfoTable, + module Juvix.Compiler.Reg.Data.Blocks.Module, module Juvix.Compiler.Reg.Language.Blocks, ) where -import Juvix.Compiler.Reg.Data.Blocks.InfoTable +import Juvix.Compiler.Reg.Data.Blocks.Module import Juvix.Compiler.Reg.Language.Blocks import Juvix.Compiler.Tree.Transformation.Generic.Base diff --git a/src/Juvix/Compiler/Reg/Transformation/Blocks/Liveness.hs b/src/Juvix/Compiler/Reg/Transformation/Blocks/Liveness.hs index 66dbb38176..6b207b80eb 100644 --- a/src/Juvix/Compiler/Reg/Transformation/Blocks/Liveness.hs +++ b/src/Juvix/Compiler/Reg/Transformation/Blocks/Liveness.hs @@ -34,5 +34,5 @@ computeBlockLiveness' vars block = block'' {_blockLiveVars = vars'} Just x -> HashSet.delete x acc acc2 = HashSet.union acc1 (HashSet.fromList vs) -computeLiveness :: InfoTable -> InfoTable +computeLiveness :: Module -> Module computeLiveness = mapT (const computeBlockLiveness) diff --git a/src/Juvix/Compiler/Reg/Transformation/Cleanup.hs b/src/Juvix/Compiler/Reg/Transformation/Cleanup.hs index b1c28c9052..b156c760c6 100644 --- a/src/Juvix/Compiler/Reg/Transformation/Cleanup.hs +++ b/src/Juvix/Compiler/Reg/Transformation/Cleanup.hs @@ -5,7 +5,7 @@ import Juvix.Compiler.Reg.Extra.Recursors import Juvix.Compiler.Reg.Transformation.Base import Juvix.Compiler.Tree.Extra.Rep -cleanup' :: Bool -> InfoTable -> InfoTable +cleanup' :: Bool -> Module -> Module cleanup' bCairo tab = mapT (const (cmap go)) tab where go :: Code -> Code @@ -22,5 +22,5 @@ cleanup' bCairo tab = mapT (const (cmap go)) tab i : is | bCairo -> updateLiveVars' (const Nothing) i : is is -> is -cleanup :: InfoTable -> InfoTable +cleanup :: Module -> Module cleanup = cleanup' False diff --git a/src/Juvix/Compiler/Reg/Transformation/IdentityTrans.hs b/src/Juvix/Compiler/Reg/Transformation/IdentityTrans.hs index 11acc37c53..5a1de1c910 100644 --- a/src/Juvix/Compiler/Reg/Transformation/IdentityTrans.hs +++ b/src/Juvix/Compiler/Reg/Transformation/IdentityTrans.hs @@ -3,5 +3,5 @@ module Juvix.Compiler.Reg.Transformation.IdentityTrans where import Juvix.Compiler.Reg.Extra.Recursors import Juvix.Compiler.Reg.Transformation.Base -identity :: InfoTable -> InfoTable +identity :: Module -> Module identity = mapT (const (cmap id)) diff --git a/src/Juvix/Compiler/Reg/Transformation/InitBranchVars.hs b/src/Juvix/Compiler/Reg/Transformation/InitBranchVars.hs index 83f9b5957a..9929d1f2ea 100644 --- a/src/Juvix/Compiler/Reg/Transformation/InitBranchVars.hs +++ b/src/Juvix/Compiler/Reg/Transformation/InitBranchVars.hs @@ -8,7 +8,7 @@ import Juvix.Compiler.Reg.Transformation.Base -- | Inserts assignments to initialize variables assigned in other branches. -- Assumes the input is in SSA form (which is preserved). -initBranchVars :: InfoTable -> InfoTable +initBranchVars :: Module -> Module initBranchVars = mapT (const goFun) where goFun :: Code -> Code diff --git a/src/Juvix/Compiler/Reg/Transformation/Optimize/BranchToIf.hs b/src/Juvix/Compiler/Reg/Transformation/Optimize/BranchToIf.hs index bdb0ace3f9..6121abf2d1 100644 --- a/src/Juvix/Compiler/Reg/Transformation/Optimize/BranchToIf.hs +++ b/src/Juvix/Compiler/Reg/Transformation/Optimize/BranchToIf.hs @@ -3,7 +3,7 @@ module Juvix.Compiler.Reg.Transformation.Optimize.BranchToIf where import Juvix.Compiler.Reg.Extra import Juvix.Compiler.Reg.Transformation.Base -convertBranchToIf' :: (BoolOp -> Value -> Value -> Bool) -> InfoTable -> InfoTable +convertBranchToIf' :: (BoolOp -> Value -> Value -> Bool) -> Module -> Module convertBranchToIf' f = mapT (const goFun) where goFun :: Code -> Code @@ -38,10 +38,10 @@ convertBranchToIf' f = mapT (const goFun) : is' is -> is -convertBranchToIf :: InfoTable -> InfoTable +convertBranchToIf :: Module -> Module convertBranchToIf = convertBranchToIf' (\_ _ _ -> True) -convertBranchOnZeroToIf :: InfoTable -> InfoTable +convertBranchOnZeroToIf :: Module -> Module convertBranchOnZeroToIf = convertBranchToIf' check where check :: BoolOp -> Value -> Value -> Bool diff --git a/src/Juvix/Compiler/Reg/Transformation/Optimize/ConstantPropagation.hs b/src/Juvix/Compiler/Reg/Transformation/Optimize/ConstantPropagation.hs index 071d4ab40f..1bb1e566e7 100644 --- a/src/Juvix/Compiler/Reg/Transformation/Optimize/ConstantPropagation.hs +++ b/src/Juvix/Compiler/Reg/Transformation/Optimize/ConstantPropagation.hs @@ -7,7 +7,7 @@ import Juvix.Compiler.Tree.Evaluator.Builtins type VarMap = HashMap VarRef Constant -constantPropagate :: InfoTable -> InfoTable +constantPropagate :: Module -> Module constantPropagate = mapT (const goFun) where goFun :: Code -> Code diff --git a/src/Juvix/Compiler/Reg/Transformation/Optimize/CopyPropagation.hs b/src/Juvix/Compiler/Reg/Transformation/Optimize/CopyPropagation.hs index d90ab58e59..a7a4c2fb39 100644 --- a/src/Juvix/Compiler/Reg/Transformation/Optimize/CopyPropagation.hs +++ b/src/Juvix/Compiler/Reg/Transformation/Optimize/CopyPropagation.hs @@ -6,7 +6,7 @@ import Juvix.Compiler.Reg.Transformation.Base type VarMap = HashMap VarRef VarRef -copyPropagate :: InfoTable -> InfoTable +copyPropagate :: Module -> Module copyPropagate = mapT (const goFun) where goFun :: Code -> Code diff --git a/src/Juvix/Compiler/Reg/Transformation/Optimize/DeadCodeElimination.hs b/src/Juvix/Compiler/Reg/Transformation/Optimize/DeadCodeElimination.hs index 96917deb40..36f194d3b8 100644 --- a/src/Juvix/Compiler/Reg/Transformation/Optimize/DeadCodeElimination.hs +++ b/src/Juvix/Compiler/Reg/Transformation/Optimize/DeadCodeElimination.hs @@ -4,7 +4,7 @@ import Data.HashSet qualified as HashSet import Juvix.Compiler.Reg.Extra import Juvix.Compiler.Reg.Transformation.Base -removeDeadAssignments :: InfoTable -> InfoTable +removeDeadAssignments :: Module -> Module removeDeadAssignments = mapT (const goFun) where goFun :: Code -> Code diff --git a/src/Juvix/Compiler/Reg/Transformation/Optimize/Phase/Cairo.hs b/src/Juvix/Compiler/Reg/Transformation/Optimize/Phase/Cairo.hs index 64ad9c20f5..9deda56615 100644 --- a/src/Juvix/Compiler/Reg/Transformation/Optimize/Phase/Cairo.hs +++ b/src/Juvix/Compiler/Reg/Transformation/Optimize/Phase/Cairo.hs @@ -5,7 +5,7 @@ import Juvix.Compiler.Reg.Transformation.Optimize.BranchToIf import Juvix.Compiler.Reg.Transformation.Optimize.DeadCodeElimination import Juvix.Compiler.Reg.Transformation.Optimize.Phase.Main qualified as Main -optimize :: (Member (Reader Options) r) => InfoTable -> Sem r InfoTable +optimize :: (Member (Reader Options) r) => Module -> Sem r Module optimize = withOptimizationLevel 1 $ Main.optimize diff --git a/src/Juvix/Compiler/Reg/Transformation/Optimize/Phase/Main.hs b/src/Juvix/Compiler/Reg/Transformation/Optimize/Phase/Main.hs index 4dfcdcffaa..c24553edc5 100644 --- a/src/Juvix/Compiler/Reg/Transformation/Optimize/Phase/Main.hs +++ b/src/Juvix/Compiler/Reg/Transformation/Optimize/Phase/Main.hs @@ -5,7 +5,7 @@ import Juvix.Compiler.Reg.Transformation.Optimize.ConstantPropagation import Juvix.Compiler.Reg.Transformation.Optimize.CopyPropagation import Juvix.Compiler.Reg.Transformation.Optimize.DeadCodeElimination -optimize' :: Options -> InfoTable -> InfoTable +optimize' :: Options -> Module -> Module optimize' Options {..} = compose (2 * _optOptimizationLevel) @@ -14,7 +14,7 @@ optimize' Options {..} = . removeDeadAssignments ) -optimize :: (Member (Reader Options) r) => InfoTable -> Sem r InfoTable +optimize :: (Member (Reader Options) r) => Module -> Sem r Module optimize tab = do opts <- ask return $ optimize' opts tab diff --git a/src/Juvix/Compiler/Reg/Transformation/SSA.hs b/src/Juvix/Compiler/Reg/Transformation/SSA.hs index fce911dd86..b9ba6400ed 100644 --- a/src/Juvix/Compiler/Reg/Transformation/SSA.hs +++ b/src/Juvix/Compiler/Reg/Transformation/SSA.hs @@ -120,11 +120,11 @@ computeFunctionSSA = } ] -computeSSA :: InfoTable -> InfoTable +computeSSA :: Module -> Module computeSSA = mapT (const computeFunctionSSA) -checkSSA :: InfoTable -> Bool -checkSSA tab = all (checkFun . (^. functionCode)) (tab ^. infoFunctions) +checkSSA :: Module -> Bool +checkSSA md = all (checkFun . (^. functionCode)) (md ^. moduleInfoTable . infoFunctions) where checkFun :: Code -> Bool checkFun is = getAll $ snd $ ifoldF check (mempty, All True) is diff --git a/src/Juvix/Compiler/Reg/Translation/Blocks/FromReg.hs b/src/Juvix/Compiler/Reg/Translation/Blocks/FromReg.hs index 5e4a380273..944eaac8dc 100644 --- a/src/Juvix/Compiler/Reg/Translation/Blocks/FromReg.hs +++ b/src/Juvix/Compiler/Reg/Translation/Blocks/FromReg.hs @@ -1,13 +1,21 @@ module Juvix.Compiler.Reg.Translation.Blocks.FromReg where -import Juvix.Compiler.Reg.Data.Blocks.InfoTable -import Juvix.Compiler.Reg.Data.InfoTable qualified as Reg +import Juvix.Compiler.Reg.Data.Blocks.Module +import Juvix.Compiler.Reg.Data.Module qualified as Reg import Juvix.Compiler.Reg.Language qualified as Reg import Juvix.Compiler.Reg.Language.Blocks -fromReg :: Reg.InfoTable -> InfoTable -fromReg = over infoFunctions (fmap (over functionCode goCode)) +fromReg :: Reg.Module -> Module +fromReg md = + Module + { _moduleId = md ^. moduleId, + _moduleInfoTable = tab, + _moduleImports = md ^. moduleImports, + _moduleImportsTable = mempty + } where + tab = over infoFunctions (fmap (over functionCode goCode)) (computeCombinedInfoTable md) + goCode :: Reg.Code -> Block goCode = fromMaybe emptyBlock . goCode' diff --git a/src/Juvix/Compiler/Reg/Translation/FromAsm.hs b/src/Juvix/Compiler/Reg/Translation/FromAsm.hs index 49a619dcb9..c6a79436fe 100644 --- a/src/Juvix/Compiler/Reg/Translation/FromAsm.hs +++ b/src/Juvix/Compiler/Reg/Translation/FromAsm.hs @@ -1,22 +1,34 @@ module Juvix.Compiler.Reg.Translation.FromAsm where import Data.HashMap.Strict qualified as HashMap -import Juvix.Compiler.Asm.Data.InfoTable qualified as Asm +import Juvix.Compiler.Asm.Data.Module qualified as Asm import Juvix.Compiler.Asm.Error qualified as Asm import Juvix.Compiler.Asm.Extra.Recursors qualified as Asm import Juvix.Compiler.Asm.Language qualified as Asm -import Juvix.Compiler.Reg.Data.InfoTable +import Juvix.Compiler.Reg.Data.Module import Juvix.Compiler.Reg.Language -fromAsm :: Asm.InfoTable -> InfoTable -fromAsm tab = - InfoTable - { _infoFunctions = HashMap.map convertFun (tab ^. Asm.infoFunctions), - _infoConstrs = HashMap.map convertConstr (tab ^. Asm.infoConstrs), - _infoInductives = HashMap.map convertInductive (tab ^. Asm.infoInductives), - _infoMainFunction = tab ^. Asm.infoMainFunction +fromAsm :: Asm.Module -> Module +fromAsm md = + Module + { _moduleId = md ^. moduleId, + _moduleInfoTable = tab, + _moduleImports = md ^. moduleImports, + _moduleImportsTable = mempty } where + tab0 :: Asm.InfoTable + tab0 = computeCombinedInfoTable md + + tab :: InfoTable + tab = + InfoTable + { _infoFunctions = HashMap.map convertFun (tab0 ^. Asm.infoFunctions), + _infoConstrs = HashMap.map convertConstr (tab0 ^. Asm.infoConstrs), + _infoInductives = HashMap.map convertInductive (tab0 ^. Asm.infoInductives), + _infoMainFunction = tab0 ^. Asm.infoMainFunction + } + convertFun :: Asm.FunctionInfo -> FunctionInfo convertFun fi = FunctionInfo @@ -27,7 +39,7 @@ fromAsm tab = _functionArgNames = fi ^. Asm.functionArgNames, _functionType = fi ^. Asm.functionType, _functionExtra = (), - _functionCode = fromAsmFun tab fi + _functionCode = fromAsmFun md fi } convertConstr :: Asm.ConstructorInfo -> ConstructorInfo @@ -37,10 +49,10 @@ fromAsm tab = convertInductive ii = ii fromAsmFun :: - Asm.InfoTable -> + Asm.Module -> Asm.FunctionInfo -> Code -fromAsmFun tab fi = +fromAsmFun md fi = case run $ runError $ Asm.recurseS sig (fi ^. Asm.functionCode) of Left err -> error (show err) Right code -> code @@ -48,20 +60,20 @@ fromAsmFun tab fi = sig :: Asm.RecursorSig Asm.StackInfo (Error Asm.AsmError ': r) Instruction sig = Asm.RecursorSig - { _recursorInfoTable = tab, - _recurseInstr = fromAsmInstr fi tab, + { _recursorModule = md, + _recurseInstr = fromAsmInstr fi md, _recurseBranch = fromAsmBranch fi, - _recurseCase = fromAsmCase fi tab, + _recurseCase = fromAsmCase fi md, _recurseSave = fromAsmSave fi } fromAsmInstr :: Asm.FunctionInfo -> - Asm.InfoTable -> + Asm.Module -> Asm.StackInfo -> Asm.CmdInstr -> Sem r Instruction -fromAsmInstr funInfo tab si Asm.CmdInstr {..} = +fromAsmInstr funInfo md si Asm.CmdInstr {..} = case _cmdInstrInstruction of Asm.Binop op -> return $ mkBinop op Asm.Unop op -> return $ mkUnop op @@ -157,7 +169,7 @@ fromAsmInstr funInfo tab si Asm.CmdInstr {..} = _constrFieldMemRep = ci ^. Asm.constructorRepresentation } where - ci = fromMaybe impossible $ HashMap.lookup _fieldTag (tab ^. Asm.infoConstrs) + ci = lookupConstrInfo md _fieldTag mkVar :: Asm.DirectRef -> VarRef mkVar = \case @@ -182,7 +194,7 @@ fromAsmInstr funInfo tab si Asm.CmdInstr {..} = _instrAllocMemRep = ci ^. Asm.constructorRepresentation } where - ci = fromMaybe impossible $ HashMap.lookup tag (tab ^. Asm.infoConstrs) + ci = lookupConstrInfo md tag m = n - ci ^. Asm.constructorArgsNum + 1 mkAllocClosure :: Asm.InstrAllocClosure -> Instruction @@ -195,7 +207,7 @@ fromAsmInstr funInfo tab si Asm.CmdInstr {..} = _instrAllocClosureArgs = getArgs' 0 _allocClosureArgsNum } where - fi = fromMaybe impossible $ HashMap.lookup _allocClosureFunSymbol (tab ^. Asm.infoFunctions) + fi = lookupFunInfo md _allocClosureFunSymbol m = n - _allocClosureArgsNum + 1 mkExtendClosure :: Asm.InstrExtendClosure -> Instruction @@ -277,14 +289,14 @@ fromAsmBranch fi isTail si Asm.CmdBranch {} codeTrue codeFalse = fromAsmCase :: Asm.FunctionInfo -> - Asm.InfoTable -> + Asm.Module -> Bool -> Asm.StackInfo -> Asm.CmdCase -> [Code] -> Maybe Code -> Sem r Instruction -fromAsmCase fi tab isTail si Asm.CmdCase {..} brs def = +fromAsmCase fi md isTail si Asm.CmdCase {..} brs def = return $ Case $ InstrCase @@ -295,9 +307,7 @@ fromAsmCase fi tab isTail si Asm.CmdCase {..} brs def = zipWithExact ( \br code -> let tag = br ^. Asm.caseBranchTag - ci = - fromMaybe impossible $ - HashMap.lookup tag (tab ^. Asm.infoConstrs) + ci = lookupConstrInfo md tag in CaseBranch { _caseBranchTag = tag, _caseBranchMemRep = ci ^. Asm.constructorRepresentation, @@ -312,9 +322,7 @@ fromAsmCase fi tab isTail si Asm.CmdCase {..} brs def = } where topIdx = fromJust (fi ^. Asm.functionExtra) ^. Asm.functionMaxTempStackHeight + si ^. Asm.stackInfoValueStackHeight - 1 - ii = - fromMaybe impossible $ - HashMap.lookup _cmdCaseInductive (tab ^. Asm.infoInductives) + ii = lookupInductiveInfo md _cmdCaseInductive fromAsmSave :: Asm.FunctionInfo -> diff --git a/src/Juvix/Compiler/Reg/Translation/FromSource.hs b/src/Juvix/Compiler/Reg/Translation/FromSource.hs index a42bc19d04..cda7b66472 100644 --- a/src/Juvix/Compiler/Reg/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Reg/Translation/FromSource.hs @@ -7,8 +7,8 @@ where import Control.Monad.Trans.Class (lift) import Data.HashMap.Strict qualified as HashMap -import Juvix.Compiler.Reg.Data.InfoTable import Juvix.Compiler.Reg.Data.InfoTableBuilder +import Juvix.Compiler.Reg.Data.Module import Juvix.Compiler.Reg.Language import Juvix.Compiler.Reg.Translation.FromSource.Lexer import Juvix.Compiler.Tree.Translation.FromSource.Base @@ -31,13 +31,13 @@ parseRegSig = _parserSigEmptyExtra = () } -parseText :: Text -> Either MegaparsecError InfoTable +parseText :: Text -> Either MegaparsecError Module parseText = runParser noFile parseText' :: BuilderState -> Text -> Either MegaparsecError BuilderState parseText' bs = runParser' bs noFile -runParser :: Path Abs File -> Text -> Either MegaparsecError InfoTable +runParser :: Path Abs File -> Text -> Either MegaparsecError Module runParser = runParserS parseRegSig runParser' :: BuilderState -> Path Abs File -> Text -> Either MegaparsecError BuilderState diff --git a/src/Juvix/Compiler/Store/Backend/Core.hs b/src/Juvix/Compiler/Store/Backend/Core.hs new file mode 100644 index 0000000000..ddfc2aeb35 --- /dev/null +++ b/src/Juvix/Compiler/Store/Backend/Core.hs @@ -0,0 +1,40 @@ +module Juvix.Compiler.Store.Backend.Core + ( module Juvix.Compiler.Store.Backend.Core, + module Juvix.Compiler.Store.Backend.Module, + module Juvix.Compiler.Store.Core.Data.InfoTable, + ) +where + +import Data.HashMap.Strict qualified as HashMap +import Juvix.Compiler.Pipeline.EntryPoint +import Juvix.Compiler.Store.Backend.Module +import Juvix.Compiler.Store.Core.Data.InfoTable +import Juvix.Compiler.Store.Internal.Language qualified as Internal +import Juvix.Compiler.Store.Language qualified as Store +import Juvix.Prelude + +type Module = Module' InfoTable + +type ModuleTable = ModuleTable' InfoTable + +fromModuleInfo :: (Member (Reader EntryPoint) r) => Store.ModuleInfo -> Sem r Module +fromModuleInfo Store.ModuleInfo {..} = do + ep <- ask + return + Module + { _moduleId = _moduleInfoInternalModule ^. Internal.internalModuleId, + _moduleInfoTable = _moduleInfoCoreTable, + _moduleImports = _moduleInfoInternalModule ^. Internal.internalModuleImports, + _moduleOptions = fromEntryPoint ep, + _moduleSHA256 = _moduleInfoSHA256 + } + +fromModuleInfoTable :: (Member (Reader EntryPoint) r) => Store.ModuleTable -> Sem r ModuleTable +fromModuleInfoTable mt = do + let mis = HashMap.elems (mt ^. Store.moduleTable) + mds <- mapM fromModuleInfo mis + return + . ModuleTable + . HashMap.fromList + . map (\m -> (m ^. moduleId, m)) + $ mds diff --git a/src/Juvix/Compiler/Store/Backend/Module.hs b/src/Juvix/Compiler/Store/Backend/Module.hs index bd46845581..5b7a8aa122 100644 --- a/src/Juvix/Compiler/Store/Backend/Module.hs +++ b/src/Juvix/Compiler/Store/Backend/Module.hs @@ -1,7 +1,13 @@ -module Juvix.Compiler.Store.Backend.Module where +module Juvix.Compiler.Store.Backend.Module + ( module Juvix.Compiler.Store.Backend.Module, + module Juvix.Compiler.Store.Backend.Options, + ) +where +import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Store.Backend.Options import Juvix.Data.ModuleId +import Juvix.Data.PPOutput (prettyText) import Juvix.Extra.Serialize import Juvix.Prelude @@ -11,7 +17,8 @@ data Module' t = Module -- | The imports field contains all direct (non-transitive) dependencies of -- the module. _moduleImports :: [ModuleId], - _moduleOptions :: Options + _moduleOptions :: Options, + _moduleSHA256 :: Text } deriving stock (Generic) @@ -30,3 +37,10 @@ newtype ModuleTable' t = ModuleTable makeLenses ''ModuleTable' instance (NFData t) => NFData (ModuleTable' t) + +lookupModuleTable' :: ModuleTable' t -> ModuleId -> Maybe (Module' t) +lookupModuleTable' mt mid = HashMap.lookup mid (mt ^. moduleTable) + +lookupModuleTable :: ModuleTable' t -> ModuleId -> Module' t +lookupModuleTable mt mid = + fromMaybe (impossibleError ("Could not find module " <> prettyText mid)) (lookupModuleTable' mt mid) diff --git a/src/Juvix/Compiler/Tree/Data/InfoTable/Base.hs b/src/Juvix/Compiler/Tree/Data/InfoTable/Base.hs index cbf57bbefa..082cd33f69 100644 --- a/src/Juvix/Compiler/Tree/Data/InfoTable/Base.hs +++ b/src/Juvix/Compiler/Tree/Data/InfoTable/Base.hs @@ -73,17 +73,44 @@ emptyInfoTable = _infoMainFunction = Nothing } -lookupFunInfo :: InfoTable' a e -> Symbol -> FunctionInfo' a e -lookupFunInfo infoTable sym = fromMaybe (error "invalid function symbol") (HashMap.lookup sym (infoTable ^. infoFunctions)) +lookupTabFunInfo' :: InfoTable' a e -> Symbol -> Maybe (FunctionInfo' a e) +lookupTabFunInfo' infoTable sym = HashMap.lookup sym (infoTable ^. infoFunctions) -lookupConstrInfo :: InfoTable' a e -> Tag -> ConstructorInfo -lookupConstrInfo infoTable tag = fromMaybe (error "invalid constructor tag") (HashMap.lookup tag (infoTable ^. infoConstrs)) +lookupTabConstrInfo' :: InfoTable' a e -> Tag -> Maybe ConstructorInfo +lookupTabConstrInfo' infoTable tag = HashMap.lookup tag (infoTable ^. infoConstrs) -lookupInductiveInfo :: InfoTable' a e -> Symbol -> InductiveInfo -lookupInductiveInfo infoTable sym = fromMaybe (error "invalid inductive symbol") (HashMap.lookup sym (infoTable ^. infoInductives)) +lookupTabInductiveInfo' :: InfoTable' a e -> Symbol -> Maybe InductiveInfo +lookupTabInductiveInfo' infoTable sym = HashMap.lookup sym (infoTable ^. infoInductives) -getNextSymbolId :: InfoTable' a e -> Word -getNextSymbolId tab = maximum (0 : map (^. symbolId) (HashMap.keys (tab ^. infoFunctions) ++ HashMap.keys (tab ^. infoInductives))) + 1 +lookupTabFunInfo :: InfoTable' a e -> Symbol -> FunctionInfo' a e +lookupTabFunInfo infoTable sym = fromMaybe (error "invalid function symbol") (lookupTabFunInfo' infoTable sym) -getNextUserTag :: InfoTable' a e -> Word -getNextUserTag tab = maximum (0 : mapMaybe getUserTagId (HashMap.keys (tab ^. infoConstrs))) + 1 +lookupTabConstrInfo :: InfoTable' a e -> Tag -> ConstructorInfo +lookupTabConstrInfo infoTable tag = fromMaybe (error "invalid constructor tag") (lookupTabConstrInfo' infoTable tag) + +lookupTabInductiveInfo :: InfoTable' a e -> Symbol -> InductiveInfo +lookupTabInductiveInfo infoTable sym = fromMaybe (error "invalid inductive symbol") (lookupTabInductiveInfo' infoTable sym) + +nextSymbolId :: InfoTable' a e -> Word +nextSymbolId tab = maximum (0 : map (^. symbolId) (HashMap.keys (tab ^. infoFunctions) ++ HashMap.keys (tab ^. infoInductives))) + 1 + +nextUserTag :: InfoTable' a e -> Word +nextUserTag tab = maximum (0 : mapMaybe getUserTagId (HashMap.keys (tab ^. infoConstrs))) + 1 + +instance Semigroup (InfoTable' code extra) where + t1 <> t2 = + InfoTable + { _infoFunctions = t1 ^. infoFunctions <> t2 ^. infoFunctions, + _infoInductives = t1 ^. infoInductives <> t2 ^. infoInductives, + _infoConstrs = t1 ^. infoConstrs <> t2 ^. infoConstrs, + _infoMainFunction = t2 ^. infoMainFunction <|> t1 ^. infoMainFunction + } + +instance Monoid (InfoTable' code extra) where + mempty = + InfoTable + { _infoFunctions = mempty, + _infoInductives = mempty, + _infoConstrs = mempty, + _infoMainFunction = Nothing + } diff --git a/src/Juvix/Compiler/Tree/Data/InfoTableBuilder/Base.hs b/src/Juvix/Compiler/Tree/Data/InfoTableBuilder/Base.hs index 31395ed875..e5a539c5b3 100644 --- a/src/Juvix/Compiler/Tree/Data/InfoTableBuilder/Base.hs +++ b/src/Juvix/Compiler/Tree/Data/InfoTableBuilder/Base.hs @@ -9,6 +9,7 @@ module Juvix.Compiler.Tree.Data.InfoTableBuilder.Base where import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Tree.Data.InfoTable.Base +import Juvix.Compiler.Tree.Data.Module.Base import Juvix.Compiler.Tree.Language.Base data IdentKind @@ -32,41 +33,32 @@ data InfoTableBuilder' (t :: GHCType) (e :: GHCType) :: Effect where makeSem ''InfoTableBuilder' data BuilderState' t e = BuilderState - { _stateNextSymbolId :: Word, + { _stateModule :: Module'' t e, + _stateNextSymbolId :: Word, _stateNextUserTag :: Word, - _stateInfoTable :: InfoTable' t e, _stateIdents :: HashMap Text IdentKind } makeLenses ''BuilderState' -emptyBuilderState :: BuilderState' t e -emptyBuilderState = +mkBuilderState :: Module'' t e -> BuilderState' t e +mkBuilderState md = BuilderState - { _stateNextSymbolId = 0, - _stateNextUserTag = 0, - _stateInfoTable = emptyInfoTable, - _stateIdents = mempty + { _stateNextSymbolId = nextSymbolId (md ^. moduleInfoTable), + _stateNextUserTag = nextUserTag (md ^. moduleInfoTable), + _stateModule = md, + _stateIdents = mkIdentsMap (md ^. moduleInfoTable) <> mkIdentsMap (md ^. moduleImportsTable) } + where + mkIdentsMap :: InfoTable' t e -> HashMap Text IdentKind + mkIdentsMap tab = + HashMap.fromList $ + map (\fi -> (fi ^. functionName, IdentFun (fi ^. functionSymbol))) (HashMap.elems (tab ^. infoFunctions)) + ++ map (\ii -> (ii ^. inductiveName, IdentInd (ii ^. inductiveSymbol))) (HashMap.elems (tab ^. infoInductives)) + ++ map (\ci -> (ci ^. constructorName, IdentConstr (ci ^. constructorTag))) (HashMap.elems (tab ^. infoConstrs)) -builderStateFromInfoTable :: InfoTable' t e -> BuilderState' t e -builderStateFromInfoTable tab = - BuilderState - { _stateNextSymbolId = getNextSymbolId tab, - _stateNextUserTag = getNextUserTag tab, - _stateInfoTable = tab, - _stateIdents = - HashMap.fromList $ - map (\fi -> (fi ^. functionName, IdentFun (fi ^. functionSymbol))) (HashMap.elems (tab ^. infoFunctions)) - ++ map (\ii -> (ii ^. inductiveName, IdentInd (ii ^. inductiveSymbol))) (HashMap.elems (tab ^. infoInductives)) - ++ map (\ci -> (ci ^. constructorName, IdentConstr (ci ^. constructorTag))) (HashMap.elems (tab ^. infoConstrs)) - } - -runInfoTableBuilderWithInfoTable :: InfoTable' t e -> Sem (InfoTableBuilder' t e ': r) b -> Sem r (InfoTable' t e, b) -runInfoTableBuilderWithInfoTable tab = fmap (first (^. stateInfoTable)) . runInfoTableBuilder' (builderStateFromInfoTable tab) - -runInfoTableBuilder :: Sem (InfoTableBuilder' t e ': r) b -> Sem r (InfoTable' t e, b) -runInfoTableBuilder = fmap (first (^. stateInfoTable)) . runInfoTableBuilder' emptyBuilderState +runInfoTableBuilder :: Module'' t e -> Sem (InfoTableBuilder' t e ': r) b -> Sem r (Module'' t e, b) +runInfoTableBuilder md = fmap (first (^. stateModule)) . runInfoTableBuilder' (mkBuilderState md) runInfoTableBuilder' :: forall t e b r. @@ -86,24 +78,24 @@ runInfoTableBuilder' bs = reinterpret (runState bs) interp s <- get @(BuilderState' t e) return (UserTag (TagUser defaultModuleId (s ^. stateNextUserTag - 1))) RegisterFunction' fi -> do - modify' (over (stateInfoTable . infoFunctions) (HashMap.insert (fi ^. functionSymbol) fi)) + modify' (over (stateModule . moduleInfoTable . infoFunctions) (HashMap.insert (fi ^. functionSymbol) fi)) modify' @(BuilderState' t e) (over stateIdents (HashMap.insert (fi ^. functionName) (IdentFun (fi ^. functionSymbol)))) RegisterConstr' ci -> do - modify' @(BuilderState' t e) (over (stateInfoTable . infoConstrs) (HashMap.insert (ci ^. constructorTag) ci)) + modify' @(BuilderState' t e) (over (stateModule . moduleInfoTable . infoConstrs) (HashMap.insert (ci ^. constructorTag) ci)) modify' @(BuilderState' t e) (over stateIdents (HashMap.insert (ci ^. constructorName) (IdentConstr (ci ^. constructorTag)))) RegisterInductive' ii -> do - modify' @(BuilderState' t e) (over (stateInfoTable . infoInductives) (HashMap.insert (ii ^. inductiveSymbol) ii)) + modify' @(BuilderState' t e) (over (stateModule . moduleInfoTable . infoInductives) (HashMap.insert (ii ^. inductiveSymbol) ii)) modify' @(BuilderState' t e) (over stateIdents (HashMap.insert (ii ^. inductiveName) (IdentInd (ii ^. inductiveSymbol)))) RegisterForward' txt sym -> modify' @(BuilderState' t e) (over stateIdents (HashMap.insert txt (IdentFwd sym))) RegisterMain' sym -> - modify' @(BuilderState' t e) (over stateInfoTable (set infoMainFunction (Just sym))) + modify' @(BuilderState' t e) (over (stateModule . moduleInfoTable) (set infoMainFunction (Just sym))) GetIdent' txt -> do s <- get @(BuilderState' t e) return $ HashMap.lookup txt (s ^. stateIdents) GetFunctionInfo' sym -> do s <- get - return (lookupFunInfo (s ^. stateInfoTable) sym) + return (lookupTabFunInfo (s ^. stateModule . moduleInfoTable) sym) GetConstructorInfo' tag -> do s <- get @(BuilderState' t e) - return (lookupConstrInfo (s ^. stateInfoTable) tag) + return (lookupTabConstrInfo (s ^. stateModule . moduleInfoTable) tag) diff --git a/src/Juvix/Compiler/Tree/Data/Module.hs b/src/Juvix/Compiler/Tree/Data/Module.hs new file mode 100644 index 0000000000..60a9a4e01d --- /dev/null +++ b/src/Juvix/Compiler/Tree/Data/Module.hs @@ -0,0 +1,38 @@ +module Juvix.Compiler.Tree.Data.Module + ( module Juvix.Compiler.Tree.Data.Module, + module Juvix.Compiler.Tree.Data.InfoTable, + module Juvix.Compiler.Core.Data.Module.Base, + ) +where + +import Juvix.Compiler.Core.Data.Module.Base +import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Language.Base + +type Module = Module' InfoTable + +type ModuleTable = ModuleTable' InfoTable + +lookupInductiveInfo' :: Module -> Symbol -> Maybe InductiveInfo +lookupInductiveInfo' Module {..} sym = + lookupTabInductiveInfo' _moduleInfoTable sym + <|> lookupTabInductiveInfo' _moduleImportsTable sym + +lookupConstrInfo' :: Module -> Tag -> Maybe ConstructorInfo +lookupConstrInfo' Module {..} tag = + lookupTabConstrInfo' _moduleInfoTable tag + <|> lookupTabConstrInfo' _moduleImportsTable tag + +lookupFunInfo' :: Module -> Symbol -> Maybe FunctionInfo +lookupFunInfo' Module {..} sym = + lookupTabFunInfo' _moduleInfoTable sym + <|> lookupTabFunInfo' _moduleImportsTable sym + +lookupInductiveInfo :: Module -> Symbol -> InductiveInfo +lookupInductiveInfo m sym = fromJust (lookupInductiveInfo' m sym) + +lookupConstrInfo :: Module -> Tag -> ConstructorInfo +lookupConstrInfo m tag = fromJust (lookupConstrInfo' m tag) + +lookupFunInfo :: Module -> Symbol -> FunctionInfo +lookupFunInfo m sym = fromJust (lookupFunInfo' m sym) diff --git a/src/Juvix/Compiler/Tree/Data/Module/Base.hs b/src/Juvix/Compiler/Tree/Data/Module/Base.hs new file mode 100644 index 0000000000..0fa4402df4 --- /dev/null +++ b/src/Juvix/Compiler/Tree/Data/Module/Base.hs @@ -0,0 +1,38 @@ +module Juvix.Compiler.Tree.Data.Module.Base + ( module Juvix.Compiler.Tree.Data.Module.Base, + module Juvix.Compiler.Core.Data.Module.Base, + module Juvix.Compiler.Tree.Data.InfoTable.Base, + ) +where + +import Juvix.Compiler.Core.Data.Module.Base +import Juvix.Compiler.Tree.Data.InfoTable.Base +import Juvix.Compiler.Tree.Language.Base + +type Module'' a e = Module' (InfoTable' a e) + +type ModuleTable'' a e = ModuleTable' (InfoTable' a e) + +lookupFunInfo' :: Module'' a e -> Symbol -> Maybe (FunctionInfo' a e) +lookupFunInfo' md sym = + lookupTabFunInfo' (md ^. moduleInfoTable) sym + <|> lookupTabFunInfo' (md ^. moduleImportsTable) sym + +lookupConstrInfo' :: Module'' a e -> Tag -> Maybe ConstructorInfo +lookupConstrInfo' md tag = + lookupTabConstrInfo' (md ^. moduleInfoTable) tag + <|> lookupTabConstrInfo' (md ^. moduleImportsTable) tag + +lookupInductiveInfo' :: Module'' a e -> Symbol -> Maybe InductiveInfo +lookupInductiveInfo' md sym = + lookupTabInductiveInfo' (md ^. moduleInfoTable) sym + <|> lookupTabInductiveInfo' (md ^. moduleImportsTable) sym + +lookupFunInfo :: Module'' a e -> Symbol -> FunctionInfo' a e +lookupFunInfo md sym = fromMaybe (error "invalid function symbol") (lookupFunInfo' md sym) + +lookupConstrInfo :: Module'' a e -> Tag -> ConstructorInfo +lookupConstrInfo md tag = fromMaybe (error "invalid constructor tag") (lookupConstrInfo' md tag) + +lookupInductiveInfo :: Module'' a e -> Symbol -> InductiveInfo +lookupInductiveInfo md sym = fromMaybe (error "invalid inductive symbol") (lookupInductiveInfo' md sym) diff --git a/src/Juvix/Compiler/Tree/Evaluator.hs b/src/Juvix/Compiler/Tree/Evaluator.hs index a104021613..72157eb250 100644 --- a/src/Juvix/Compiler/Tree/Evaluator.hs +++ b/src/Juvix/Compiler/Tree/Evaluator.hs @@ -5,7 +5,7 @@ import Data.ByteString qualified as BS import GHC.IO (unsafePerformIO) import GHC.Show qualified as S import Juvix.Compiler.Core.Data.BinderList qualified as BL -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Error import Juvix.Compiler.Tree.Evaluator.Builtins import Juvix.Compiler.Tree.Extra.Base @@ -28,11 +28,11 @@ instance Show EvalError where instance Exception.Exception EvalError -eval :: InfoTable -> Node -> Value +eval :: Module -> Node -> Value eval = hEval stdout -hEval :: Handle -> InfoTable -> Node -> Value -hEval hout tab = eval' [] mempty +hEval :: Handle -> Module -> Node -> Value +hEval hout md = eval' [] mempty where eval' :: [Value] -> BL.BinderList Value -> Node -> Value eval' args temps node = case node of @@ -74,7 +74,7 @@ hEval hout tab = eval' [] mempty goUnop NodeUnop {..} = let !v = eval' args temps _nodeUnopArg in case _nodeUnopOpcode of - PrimUnop op -> eitherToError $ evalUnop tab op v + PrimUnop op -> eitherToError $ evalUnop md op v OpAssert -> goAssert v OpTrace -> goTrace v OpFail -> goFail v @@ -112,10 +112,10 @@ hEval hout tab = eval' [] mempty _ -> evalError "assertion failed" goFail :: Value -> Value - goFail v = evalError ("failure: " <> printValue tab v) + goFail v = evalError ("failure: " <> printValue md v) goTrace :: Value -> Value - goTrace v = unsafePerformIO (hPutStrLn hout (printValue tab v) >> return v) + goTrace v = unsafePerformIO (hPutStrLn hout (printValue md v) >> return v) goConstant :: NodeConstant -> Value goConstant NodeConstant {..} = constantToValue _nodeConstant @@ -175,7 +175,7 @@ hEval hout tab = eval' [] mempty doCall :: Symbol -> [Value] -> [Node] -> Value doCall sym vs0 as = let !vs = map' (eval' args temps) as - fi = lookupFunInfo tab sym + fi = lookupFunInfo md sym vs' = vs0 ++ vs in if | length vs' == fi ^. functionArgsNum -> @@ -209,7 +209,7 @@ hEval hout tab = eval' [] mempty _closureArgs = vs' } where - fi = lookupFunInfo tab _closureSymbol + fi = lookupFunInfo md _closureSymbol argsNum = fi ^. functionArgsNum vs' = _closureArgs ++ vs n = length vs' @@ -269,17 +269,17 @@ valueToNode = \case ValUInt8 i -> mkConst $ ConstUInt8 i ValByteArray b -> mkConst $ ConstByteArray b -hEvalIO :: (MonadIO m) => Handle -> Handle -> InfoTable -> FunctionInfo -> m Value -hEvalIO hin hout infoTable funInfo = do - let !v = hEval hout infoTable (funInfo ^. functionCode) - hRunIO hin hout infoTable v +hEvalIO :: (MonadIO m) => Handle -> Handle -> Module -> FunctionInfo -> m Value +hEvalIO hin hout md funInfo = do + let !v = hEval hout md (funInfo ^. functionCode) + hRunIO hin hout md v -- | Interpret IO actions. -hRunIO :: (MonadIO m) => Handle -> Handle -> InfoTable -> Value -> m Value -hRunIO hin hout infoTable = \case +hRunIO :: (MonadIO m) => Handle -> Handle -> Module -> Value -> m Value +hRunIO hin hout md = \case ValConstr (Constr (BuiltinTag TagReturn) [x]) -> return x ValConstr (Constr (BuiltinTag TagBind) [x, f]) -> do - x' <- hRunIO hin hout infoTable x + x' <- hRunIO hin hout md x let code = CallClosures NodeCallClosures @@ -287,13 +287,13 @@ hRunIO hin hout infoTable = \case _nodeCallClosuresFun = valueToNode f, _nodeCallClosuresArgs = valueToNode x' :| [] } - !x'' = hEval hout infoTable code - hRunIO hin hout infoTable x'' + !x'' = hEval hout md code + hRunIO hin hout md x'' ValConstr (Constr (BuiltinTag TagWrite) [ValString s]) -> do hPutStr hout s return ValVoid ValConstr (Constr (BuiltinTag TagWrite) [arg]) -> do - hPutStr hout (ppPrint infoTable arg) + hPutStr hout (ppPrint md arg) return ValVoid ValConstr (Constr (BuiltinTag TagReadLn) []) -> do hFlush hout diff --git a/src/Juvix/Compiler/Tree/Evaluator/Builtins.hs b/src/Juvix/Compiler/Tree/Evaluator/Builtins.hs index 94eef1204d..72a01d50a5 100644 --- a/src/Juvix/Compiler/Tree/Evaluator/Builtins.hs +++ b/src/Juvix/Compiler/Tree/Evaluator/Builtins.hs @@ -1,6 +1,6 @@ module Juvix.Compiler.Tree.Evaluator.Builtins where -import Juvix.Compiler.Tree.Data.InfoTable.Base +import Juvix.Compiler.Tree.Data.Module.Base import Juvix.Compiler.Tree.Language.Base import Juvix.Compiler.Tree.Language.Builtins import Juvix.Compiler.Tree.Language.Value @@ -56,9 +56,9 @@ evalBinop op arg1 arg2 = case op of (ValString s1, ValString s2) -> Right $ ValString (s1 <> s2) _ -> Left "expected two string arguments" -evalUnop :: InfoTable' t e -> UnaryOp -> Value -> Either ErrorMsg Value -evalUnop tab op v = case op of - OpShow -> Right $ ValString (printValue tab v) +evalUnop :: Module'' t e -> UnaryOp -> Value -> Either ErrorMsg Value +evalUnop md op v = case op of + OpShow -> Right $ ValString (printValue md v) OpStrToInt -> goStringUnop strToInt v OpFieldToInt -> goFieldToInt v OpIntToField -> goIntToField v @@ -83,7 +83,7 @@ evalUnop tab op v = case op of ValClosure Closure {..} -> Right $ ValInteger (fromIntegral argsNum) where - fi = lookupFunInfo tab _closureSymbol + fi = lookupFunInfo md _closureSymbol argsNum = fi ^. functionArgsNum - length _closureArgs _ -> Left "expected a closure" @@ -116,10 +116,10 @@ evalUnop tab op v = case op of _ -> Left "expected a uint8" -printValue :: InfoTable' t e -> Value -> Text -printValue tab = \case +printValue :: Module'' t e -> Value -> Text +printValue md = \case ValString s -> s - v -> toPlainText . mkAnsiText . PPOutput . doc (defaultOptions tab) $ v + v -> toPlainText . mkAnsiText . PPOutput . doc (defaultOptions md) $ v constantToValue :: Constant -> Value constantToValue = \case @@ -148,7 +148,7 @@ evalBinop' op arg1 arg2 = mapRight valueToConstant $ evalBinop op (constantToValue arg1) (constantToValue arg2) -evalUnop' :: InfoTable' t e -> UnaryOp -> Constant -> Either ErrorMsg Constant -evalUnop' tab op v = +evalUnop' :: Module'' t e -> UnaryOp -> Constant -> Either ErrorMsg Constant +evalUnop' md op v = mapRight valueToConstant $ - evalUnop tab op (constantToValue v) + evalUnop md op (constantToValue v) diff --git a/src/Juvix/Compiler/Tree/EvaluatorEff.hs b/src/Juvix/Compiler/Tree/EvaluatorEff.hs index 83f812bab8..9758154a92 100644 --- a/src/Juvix/Compiler/Tree/EvaluatorEff.hs +++ b/src/Juvix/Compiler/Tree/EvaluatorEff.hs @@ -3,7 +3,7 @@ module Juvix.Compiler.Tree.EvaluatorEff (eval, hEvalIOEither) where import Control.Exception qualified as Exception import Data.ByteString qualified as BS import Juvix.Compiler.Core.Data.BinderList qualified as BL -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Error import Juvix.Compiler.Tree.Evaluator (EvalError (..), toTreeError, valueToNode) import Juvix.Compiler.Tree.Evaluator.Builtins @@ -27,8 +27,8 @@ emptyEvalCtx = _evalCtxTemp = mempty } -eval :: (Members '[Output Value, Error EvalError] r) => InfoTable -> Node -> Sem r Value -eval tab = runReader emptyEvalCtx . eval' +eval :: (Members '[Output Value, Error EvalError] r) => Module -> Node -> Sem r Value +eval md = runReader emptyEvalCtx . eval' where eval' :: forall r'. (Members '[Output Value, Reader EvalCtx, Error EvalError] r') => Node -> Sem r' Value eval' node = case node of @@ -69,7 +69,7 @@ eval tab = runReader emptyEvalCtx . eval' goUnop NodeUnop {..} = do v <- eval' _nodeUnopArg case _nodeUnopOpcode of - PrimUnop op -> eitherToError $ evalUnop tab op v + PrimUnop op -> eitherToError $ evalUnop md op v OpAssert -> goAssert v OpTrace -> goTrace v OpFail -> goFail v @@ -105,10 +105,10 @@ eval tab = runReader emptyEvalCtx . eval' goAssert = \case ValBool True -> return $ ValBool True ValBool False -> evalError "assertion failed" - v -> evalError ("expected a boolean: " <> printValue tab v) + v -> evalError ("expected a boolean: " <> printValue md v) goFail :: Value -> Sem r' Value - goFail v = evalError ("failure: " <> printValue tab v) + goFail v = evalError ("failure: " <> printValue md v) goTrace :: Value -> Sem r' Value goTrace v = output v $> v @@ -189,7 +189,7 @@ eval tab = runReader emptyEvalCtx . eval' doCall :: Symbol -> [Value] -> [Node] -> Sem r' Value doCall sym clArgs as = do vs <- mapM eval' as - let fi = lookupFunInfo tab sym + let fi = lookupFunInfo md sym vs' = clArgs ++ vs in if | length vs' == fi ^. functionArgsNum -> do @@ -245,7 +245,7 @@ eval tab = runReader emptyEvalCtx . eval' } ) where - fi = lookupFunInfo tab _closureSymbol + fi = lookupFunInfo md _closureSymbol argsNum = fi ^. functionArgsNum vs' = _closureArgs ++ vs n = length vs' @@ -295,16 +295,16 @@ hEvalIOEither :: (MonadIO m) => Handle -> Handle -> - InfoTable -> + Module -> FunctionInfo -> m (Either TreeError Value) -hEvalIOEither hin hout infoTable funInfo = do +hEvalIOEither hin hout md funInfo = do let x :: Sem '[Output Value, Error EvalError, Error TreeError, IOE] Value x = do - v <- eval infoTable (funInfo ^. functionCode) - hRunIO hin hout infoTable v + v <- eval md (funInfo ^. functionCode) + hRunIO hin hout md v let handleTrace :: forall q. (MonadIO q) => Value -> q () - handleTrace = hPutStrLn hout . printValue infoTable + handleTrace = hPutStrLn hout . printValue md liftIO . runEff . runError @TreeError @@ -313,11 +313,11 @@ hEvalIOEither hin hout infoTable funInfo = do $ x -- | Interpret IO actions. -hRunIO :: forall r. (Members '[IOE, Error EvalError, Output Value] r) => Handle -> Handle -> InfoTable -> Value -> Sem r Value -hRunIO hin hout infoTable = \case +hRunIO :: forall r. (Members '[IOE, Error EvalError, Output Value] r) => Handle -> Handle -> Module -> Value -> Sem r Value +hRunIO hin hout md = \case ValConstr (Constr (BuiltinTag TagReturn) [x]) -> return x ValConstr (Constr (BuiltinTag TagBind) [x, f]) -> do - x' <- hRunIO hin hout infoTable x + x' <- hRunIO hin hout md x let code = CallClosures NodeCallClosures @@ -325,13 +325,13 @@ hRunIO hin hout infoTable = \case _nodeCallClosuresFun = valueToNode f, _nodeCallClosuresArgs = valueToNode x' :| [] } - res <- eval infoTable code - hRunIO hin hout infoTable res + res <- eval md code + hRunIO hin hout md res ValConstr (Constr (BuiltinTag TagWrite) [ValString s]) -> do hPutStr hout s return ValVoid ValConstr (Constr (BuiltinTag TagWrite) [arg]) -> do - hPutStr hout (ppPrint infoTable arg) + hPutStr hout (ppPrint md arg) return ValVoid ValConstr (Constr (BuiltinTag TagReadLn) []) -> do hFlush hout diff --git a/src/Juvix/Compiler/Tree/Extra/Apply.hs b/src/Juvix/Compiler/Tree/Extra/Apply.hs index d1e4905479..4e55635a7f 100644 --- a/src/Juvix/Compiler/Tree/Extra/Apply.hs +++ b/src/Juvix/Compiler/Tree/Extra/Apply.hs @@ -3,8 +3,8 @@ module Juvix.Compiler.Tree.Extra.Apply where import Data.FileEmbed qualified as FE import Data.HashMap.Strict qualified as HashMap import Data.Text.Encoding -import Juvix.Compiler.Tree.Data.InfoTable import Juvix.Compiler.Tree.Data.InfoTableBuilder +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Language import Juvix.Compiler.Tree.Translation.FromSource @@ -17,11 +17,28 @@ data ApplyBuiltins = ApplyBuiltins makeLenses ''ApplyBuiltins -addApplyBuiltins :: InfoTable -> (ApplyBuiltins, InfoTable) -addApplyBuiltins tab = (blts, bs' ^. stateInfoTable) +applyBuiltinsModuleId :: ModuleId +applyBuiltinsModuleId = + ModuleId + { _moduleIdPath = nonEmptyToTopModulePathKey (pure "$ApplyBuiltinsModule$"), + _moduleIdPackageId = + PackageId + { _packageIdName = "$", + _packageIdVersion = SemVer 1 0 0 Nothing Nothing + } + } + +applyBuiltins :: ApplyBuiltins +applyBuiltins = fst getApplyBuiltins + +applyBuiltinsModule :: Module +applyBuiltinsModule = snd getApplyBuiltins + +getApplyBuiltins :: (ApplyBuiltins, Module) +getApplyBuiltins = (blts, bs' ^. stateModule) where bs :: BuilderState - bs = builderStateFromInfoTable tab + bs = mkBuilderState (emptyModule applyBuiltinsModuleId) bs' :: BuilderState bs' = @@ -44,3 +61,6 @@ addApplyBuiltins tab = (blts, bs' ^. stateInfoTable) f = case fromJust $ HashMap.lookup idt (bs' ^. stateIdents) of IdentFun s -> s _ -> impossible + +addApplyBuiltins :: ModuleTable -> ModuleTable +addApplyBuiltins = over moduleTable (HashMap.insert applyBuiltinsModuleId applyBuiltinsModule) diff --git a/src/Juvix/Compiler/Tree/Extra/Rep.hs b/src/Juvix/Compiler/Tree/Extra/Rep.hs index aec8451b43..39dc7a3f13 100644 --- a/src/Juvix/Compiler/Tree/Extra/Rep.hs +++ b/src/Juvix/Compiler/Tree/Extra/Rep.hs @@ -1,14 +1,21 @@ module Juvix.Compiler.Tree.Extra.Rep where -import Juvix.Compiler.Tree.Data.InfoTable.Base +import Juvix.Compiler.Tree.Data.Module.Base import Juvix.Compiler.Tree.Language.Base isRecord :: InductiveInfo -> Bool isRecord InductiveInfo {..} = length _inductiveConstructors == 1 -isInductiveRecord :: InfoTable' a e -> Symbol -> Bool -isInductiveRecord tab sym = isRecord (lookupInductiveInfo tab sym) +isInductiveRecord :: Module'' a e -> Symbol -> Bool +isInductiveRecord md sym = isRecord (lookupInductiveInfo md sym) -isConstrRecord :: InfoTable' a e -> Tag -> Bool -isConstrRecord tab tag = - isInductiveRecord tab (lookupConstrInfo tab tag ^. constructorInductive) +isConstrRecord :: Module'' a e -> Tag -> Bool +isConstrRecord md tag = + isInductiveRecord md (lookupConstrInfo md tag ^. constructorInductive) + +isTabInductiveRecord :: InfoTable' a e -> Symbol -> Bool +isTabInductiveRecord tab sym = isRecord (lookupTabInductiveInfo tab sym) + +isTabConstrRecord :: InfoTable' a e -> Tag -> Bool +isTabConstrRecord tab tag = + isTabInductiveRecord tab (lookupTabConstrInfo tab tag ^. constructorInductive) diff --git a/src/Juvix/Compiler/Tree/Extra/Type.hs b/src/Juvix/Compiler/Tree/Extra/Type.hs index b6fb0a80da..7cbcbec1d8 100644 --- a/src/Juvix/Compiler/Tree/Extra/Type.hs +++ b/src/Juvix/Compiler/Tree/Extra/Type.hs @@ -10,7 +10,7 @@ module Juvix.Compiler.Tree.Extra.Type ) where -import Juvix.Compiler.Tree.Data.InfoTable.Base +import Juvix.Compiler.Tree.Data.Module.Base import Juvix.Compiler.Tree.Error import Juvix.Compiler.Tree.Extra.Type.Base import Juvix.Compiler.Tree.Language.Base @@ -106,7 +106,7 @@ isSubtype ty1 ty2 = (_, TyFun {}) -> False (_, TyConstr {}) -> False -unifyTypes :: forall t e r. (Members '[Error TreeError, Reader (Maybe Location), Reader (InfoTable' t e)] r) => Type -> Type -> Sem r Type +unifyTypes :: forall t e r. (Members '[Error TreeError, Reader (Maybe Location), Reader (Module'' t e)] r) => Type -> Type -> Sem r Type unifyTypes ty1 ty2 = let (ty1', ty2') = (curryType ty1, curryType ty2) in case (ty1', ty2') of @@ -174,11 +174,11 @@ unifyTypes ty1 ty2 = err :: Sem r a err = do loc <- ask - tab <- ask @(InfoTable' t e) - throw $ TreeError loc ("not unifiable: " <> ppTrace' (defaultOptions tab) ty1 <> ", " <> ppTrace' (defaultOptions tab) ty2) + md <- ask @(Module'' t e) + throw $ TreeError loc ("not unifiable: " <> ppTrace' (defaultOptions md) ty1 <> ", " <> ppTrace' (defaultOptions md) ty2) -unifyTypes' :: forall t e r. (Member (Error TreeError) r) => Maybe Location -> InfoTable' t e -> Type -> Type -> Sem r Type -unifyTypes' loc tab ty1 ty2 = +unifyTypes' :: forall t e r. (Member (Error TreeError) r) => Maybe Location -> Module'' t e -> Type -> Type -> Sem r Type +unifyTypes' loc md ty1 ty2 = runReader loc $ - runReader tab $ + runReader md $ unifyTypes @t @e ty1 ty2 diff --git a/src/Juvix/Compiler/Tree/Pipeline.hs b/src/Juvix/Compiler/Tree/Pipeline.hs index 82033a5173..0485fda031 100644 --- a/src/Juvix/Compiler/Tree/Pipeline.hs +++ b/src/Juvix/Compiler/Tree/Pipeline.hs @@ -1,18 +1,18 @@ module Juvix.Compiler.Tree.Pipeline ( module Juvix.Compiler.Tree.Pipeline, - module Juvix.Compiler.Tree.Data.InfoTable, + module Juvix.Compiler.Tree.Data.Module, ) where import Juvix.Compiler.Pipeline.EntryPoint -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Transformation -toNockma :: (Members '[Error JuvixError, Reader EntryPoint] r) => InfoTable -> Sem r InfoTable +toNockma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Module -> Sem r Module toNockma = mapReader fromEntryPoint . applyTransformations toNockmaTransformations -toAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => InfoTable -> Sem r InfoTable +toAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Module -> Sem r Module toAsm = mapReader fromEntryPoint . applyTransformations toAsmTransformations -toCairoAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => InfoTable -> Sem r InfoTable +toCairoAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Module -> Sem r Module toCairoAsm = mapReader fromEntryPoint . applyTransformations toCairoAsmTransformations diff --git a/src/Juvix/Compiler/Tree/Pretty.hs b/src/Juvix/Compiler/Tree/Pretty.hs index 7f58e67ee3..6195cefd0c 100644 --- a/src/Juvix/Compiler/Tree/Pretty.hs +++ b/src/Juvix/Compiler/Tree/Pretty.hs @@ -5,15 +5,15 @@ module Juvix.Compiler.Tree.Pretty ) where -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Pretty.Base import Juvix.Compiler.Tree.Pretty.Options import Juvix.Data.PPOutput import Juvix.Prelude import Prettyprinter.Render.Terminal qualified as Ansi -ppOutDefault :: (PrettyCode c) => InfoTable -> c -> AnsiText -ppOutDefault tab = mkAnsiText . PPOutput . doc (defaultOptions tab) +ppOutDefault :: (PrettyCode c) => Module -> c -> AnsiText +ppOutDefault md = mkAnsiText . PPOutput . doc (defaultOptions md) ppOut :: (PrettyCode c) => Options -> c -> AnsiText ppOut o = mkAnsiText . PPOutput . doc o @@ -21,8 +21,8 @@ ppOut o = mkAnsiText . PPOutput . doc o ppTrace' :: (PrettyCode c) => Options -> c -> Text ppTrace' opts = Ansi.renderStrict . reAnnotateS stylize . layoutPretty defaultLayoutOptions . doc opts -ppTrace :: (PrettyCode c) => InfoTable -> c -> Text -ppTrace tab = ppTrace' (defaultOptions tab) +ppTrace :: (PrettyCode c) => Module -> c -> Text +ppTrace md = ppTrace' (defaultOptions md) -ppPrint :: (PrettyCode c) => InfoTable -> c -> Text -ppPrint tab = show . ppOutDefault tab +ppPrint :: (PrettyCode c) => Module -> c -> Text +ppPrint md = show . ppOutDefault md diff --git a/src/Juvix/Compiler/Tree/Pretty/Base.hs b/src/Juvix/Compiler/Tree/Pretty/Base.hs index b625b97a9a..52dce15656 100644 --- a/src/Juvix/Compiler/Tree/Pretty/Base.hs +++ b/src/Juvix/Compiler/Tree/Pretty/Base.hs @@ -487,7 +487,7 @@ instance PrettyCode ConstructorInfo where ppInductive :: (Member (Reader Options) r) => InfoTable' t e -> InductiveInfo -> Sem r (Doc Ann) ppInductive tab InductiveInfo {..} = do - ctrs <- mapM (ppCode . lookupConstrInfo tab) _inductiveConstructors + ctrs <- mapM (ppCode . lookupTabConstrInfo tab) _inductiveConstructors return $ kwInductive <+> annotate (AnnKind KNameInductive) (pretty (quoteName _inductiveName)) <+> braces' (vcat (map (<> semi) ctrs)) ppInfoTable :: (Member (Reader Options) r) => (t -> Sem r (Doc Ann)) -> InfoTable' t e -> Sem r (Doc Ann) diff --git a/src/Juvix/Compiler/Tree/Pretty/Options.hs b/src/Juvix/Compiler/Tree/Pretty/Options.hs index 64da920449..a32df95739 100644 --- a/src/Juvix/Compiler/Tree/Pretty/Options.hs +++ b/src/Juvix/Compiler/Tree/Pretty/Options.hs @@ -1,7 +1,7 @@ module Juvix.Compiler.Tree.Pretty.Options where import Juvix.Compiler.Core.Pretty.Options qualified as Core -import Juvix.Compiler.Tree.Data.InfoTable.Base +import Juvix.Compiler.Tree.Data.Module.Base import Juvix.Compiler.Tree.Language.Base data Options = Options @@ -11,14 +11,17 @@ data Options = Options makeLenses ''Options -defaultOptions :: InfoTable' t e -> Options -defaultOptions tab = +defaultOptions :: Module'' t e -> Options +defaultOptions md = Options { _optSymbolNames = - fmap (^. functionName) (tab ^. infoFunctions) - <> fmap (^. inductiveName) (tab ^. infoInductives), + fmap (^. functionName) (md ^. moduleInfoTable . infoFunctions) + <> fmap (^. inductiveName) (md ^. moduleInfoTable . infoInductives) + <> fmap (^. functionName) (md ^. moduleImportsTable . infoFunctions) + <> fmap (^. inductiveName) (md ^. moduleImportsTable . infoInductives), _optTagNames = - fmap (^. constructorName) (tab ^. infoConstrs) + fmap (^. constructorName) (md ^. moduleInfoTable . infoConstrs) + <> fmap (^. constructorName) (md ^. moduleImportsTable . infoConstrs) } toCoreOptions :: Options -> Core.Options diff --git a/src/Juvix/Compiler/Tree/Transformation.hs b/src/Juvix/Compiler/Tree/Transformation.hs index 7bc8ff633c..c77b615207 100644 --- a/src/Juvix/Compiler/Tree/Transformation.hs +++ b/src/Juvix/Compiler/Tree/Transformation.hs @@ -18,10 +18,10 @@ import Juvix.Compiler.Tree.Transformation.Optimize.ConvertUnaryCalls import Juvix.Compiler.Tree.Transformation.Optimize.Phase.Main import Juvix.Compiler.Tree.Transformation.Validate -applyTransformations :: forall r. (Members '[Error JuvixError, Reader Options] r) => [TransformationId] -> InfoTable -> Sem r InfoTable +applyTransformations :: forall r. (Members '[Error JuvixError, Reader Options] r) => [TransformationId] -> Module -> Sem r Module applyTransformations ts tbl = foldM (flip appTrans) tbl ts where - appTrans :: TransformationId -> InfoTable -> Sem r InfoTable + appTrans :: TransformationId -> Module -> Sem r Module appTrans = \case IdentityTrans -> return . identity IdentityU -> return . identityU diff --git a/src/Juvix/Compiler/Tree/Transformation/Apply.hs b/src/Juvix/Compiler/Tree/Transformation/Apply.hs index d5e2db2e0e..c385ae531c 100644 --- a/src/Juvix/Compiler/Tree/Transformation/Apply.hs +++ b/src/Juvix/Compiler/Tree/Transformation/Apply.hs @@ -35,14 +35,14 @@ computeFunctionApply blts = umap go where sym = fromJust $ HashMap.lookup (length args) (blts ^. applyBuiltinsMap) -computeApply :: InfoTable -> InfoTable -computeApply tab = mapT (const (computeFunctionApply blts)) tab' - where - (blts, tab') = addApplyBuiltins tab +-- | Assumption: the applyBuiltins are already available (the +-- applyBuiltinsModule has already been added). +computeApply :: Module -> Module +computeApply = mapT (const (computeFunctionApply applyBuiltins)) -checkNoCallClosures :: InfoTable -> Bool -checkNoCallClosures tab = - all (ufold (\b bs -> b && and bs) go . (^. functionCode)) (tab ^. infoFunctions) +checkNoCallClosures :: Module -> Bool +checkNoCallClosures md = + all (ufold (\b bs -> b && and bs) go . (^. functionCode)) (md ^. moduleInfoTable . infoFunctions) where go :: Node -> Bool go = \case diff --git a/src/Juvix/Compiler/Tree/Transformation/Base.hs b/src/Juvix/Compiler/Tree/Transformation/Base.hs index f3a590fc05..5d6f9d9a22 100644 --- a/src/Juvix/Compiler/Tree/Transformation/Base.hs +++ b/src/Juvix/Compiler/Tree/Transformation/Base.hs @@ -1,12 +1,12 @@ module Juvix.Compiler.Tree.Transformation.Base ( module Juvix.Compiler.Tree.Transformation.Generic.Base, module Juvix.Compiler.Tree.Language, - module Juvix.Compiler.Tree.Data.InfoTable, + module Juvix.Compiler.Tree.Data.Module, module Juvix.Compiler.Tree.Options, ) where -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Language import Juvix.Compiler.Tree.Options import Juvix.Compiler.Tree.Transformation.Generic.Base diff --git a/src/Juvix/Compiler/Tree/Transformation/CheckNoAnoma.hs b/src/Juvix/Compiler/Tree/Transformation/CheckNoAnoma.hs index f30ce9a9e8..aa0b7a8ee3 100644 --- a/src/Juvix/Compiler/Tree/Transformation/CheckNoAnoma.hs +++ b/src/Juvix/Compiler/Tree/Transformation/CheckNoAnoma.hs @@ -1,11 +1,10 @@ module Juvix.Compiler.Tree.Transformation.CheckNoAnoma where -import Juvix.Compiler.Tree.Data.InfoTable import Juvix.Compiler.Tree.Error import Juvix.Compiler.Tree.Extra.Recursors import Juvix.Compiler.Tree.Transformation.Base -checkNoAnoma :: forall r. (Member (Error TreeError) r) => InfoTable -> Sem r () +checkNoAnoma :: forall r. (Member (Error TreeError) r) => Module -> Sem r () checkNoAnoma = walkT checkNode where checkNode :: Symbol -> Node -> Sem r () diff --git a/src/Juvix/Compiler/Tree/Transformation/CheckNoByteArray.hs b/src/Juvix/Compiler/Tree/Transformation/CheckNoByteArray.hs index 2e2fd76a08..92d8c5c294 100644 --- a/src/Juvix/Compiler/Tree/Transformation/CheckNoByteArray.hs +++ b/src/Juvix/Compiler/Tree/Transformation/CheckNoByteArray.hs @@ -1,11 +1,10 @@ module Juvix.Compiler.Tree.Transformation.CheckNoByteArray where -import Juvix.Compiler.Tree.Data.InfoTable import Juvix.Compiler.Tree.Error import Juvix.Compiler.Tree.Extra.Recursors import Juvix.Compiler.Tree.Transformation.Base -checkNoByteArray :: forall r. (Member (Error TreeError) r) => InfoTable -> Sem r () +checkNoByteArray :: forall r. (Member (Error TreeError) r) => Module -> Sem r () checkNoByteArray = walkT checkNode where checkNode :: Symbol -> Node -> Sem r () diff --git a/src/Juvix/Compiler/Tree/Transformation/FilterUnreachable.hs b/src/Juvix/Compiler/Tree/Transformation/FilterUnreachable.hs index 3bfcc7e16b..50f343c526 100644 --- a/src/Juvix/Compiler/Tree/Transformation/FilterUnreachable.hs +++ b/src/Juvix/Compiler/Tree/Transformation/FilterUnreachable.hs @@ -2,11 +2,13 @@ module Juvix.Compiler.Tree.Transformation.FilterUnreachable where import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Tree.Data.CallGraph -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Prelude -filterUnreachable :: InfoTable -> InfoTable -filterUnreachable tab = - over infoFunctions (HashMap.filterWithKey (const . isReachable graph)) tab +filterUnreachable :: Module -> Module +filterUnreachable md + | isJust (md ^. moduleInfoTable . infoMainFunction) = + over (moduleInfoTable . infoFunctions) (HashMap.filterWithKey (const . isReachable graph)) md + | otherwise = md where - graph = createCallGraph tab + graph = createCallGraph (md ^. moduleInfoTable) diff --git a/src/Juvix/Compiler/Tree/Transformation/Generic/Base.hs b/src/Juvix/Compiler/Tree/Transformation/Generic/Base.hs index 84c5fe66e8..1cd9c68211 100644 --- a/src/Juvix/Compiler/Tree/Transformation/Generic/Base.hs +++ b/src/Juvix/Compiler/Tree/Transformation/Generic/Base.hs @@ -3,47 +3,48 @@ module Juvix.Compiler.Tree.Transformation.Generic.Base where import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Tree.Data.InfoTable.Base import Juvix.Compiler.Tree.Data.InfoTableBuilder.Base +import Juvix.Compiler.Tree.Data.Module.Base import Juvix.Compiler.Tree.Language.Base import Juvix.Compiler.Tree.Options -mapFunctionsM :: (Monad m) => (FunctionInfo' a e -> m (FunctionInfo' a e)) -> InfoTable' a e -> m (InfoTable' a e) -mapFunctionsM = overM infoFunctions . mapM +mapFunctionsM :: (Monad m) => (FunctionInfo' a e -> m (FunctionInfo' a e)) -> Module'' a e -> m (Module'' a e) +mapFunctionsM = overM (moduleInfoTable . infoFunctions) . mapM -mapInductivesM :: (Monad m) => (InductiveInfo -> m InductiveInfo) -> InfoTable' a e -> m (InfoTable' a e) -mapInductivesM = overM infoInductives . mapM +mapInductivesM :: (Monad m) => (InductiveInfo -> m InductiveInfo) -> Module'' a e -> m (Module'' a e) +mapInductivesM = overM (moduleInfoTable . infoInductives) . mapM -mapConstructorsM :: (Monad m) => (ConstructorInfo -> m ConstructorInfo) -> InfoTable' a e -> m (InfoTable' a e) -mapConstructorsM = overM infoConstrs . mapM +mapConstructorsM :: (Monad m) => (ConstructorInfo -> m ConstructorInfo) -> Module'' a e -> m (Module'' a e) +mapConstructorsM = overM (moduleInfoTable . infoConstrs) . mapM -mapFunctions :: (FunctionInfo' a e -> FunctionInfo' a e) -> InfoTable' a e -> InfoTable' a e -mapFunctions = over infoFunctions . fmap +mapFunctions :: (FunctionInfo' a e -> FunctionInfo' a e) -> Module'' a e -> Module'' a e +mapFunctions = over (moduleInfoTable . infoFunctions) . fmap -mapInductives :: (InductiveInfo -> InductiveInfo) -> InfoTable' a e -> InfoTable' a e -mapInductives = over infoInductives . fmap +mapInductives :: (InductiveInfo -> InductiveInfo) -> Module'' a e -> Module'' a e +mapInductives = over (moduleInfoTable . infoInductives) . fmap -mapConstructors :: (ConstructorInfo -> ConstructorInfo) -> InfoTable' a e -> InfoTable' a e -mapConstructors = over infoConstrs . fmap +mapConstructors :: (ConstructorInfo -> ConstructorInfo) -> Module'' a e -> Module'' a e +mapConstructors = over (moduleInfoTable . infoConstrs) . fmap -mapT :: (Symbol -> a -> a) -> InfoTable' a e -> InfoTable' a e -mapT f = over infoFunctions (HashMap.mapWithKey (over functionCode . f)) +mapT :: (Symbol -> a -> a) -> Module'' a e -> Module'' a e +mapT f = over (moduleInfoTable . infoFunctions) (HashMap.mapWithKey (over functionCode . f)) -mapT' :: forall a e r. (Symbol -> a -> Sem (InfoTableBuilder' a e ': r) a) -> InfoTable' a e -> Sem r (InfoTable' a e) -mapT' f tab = +mapT' :: forall a e r. (Symbol -> a -> Sem (InfoTableBuilder' a e ': r) a) -> Module'' a e -> Sem r (Module'' a e) +mapT' f md = fmap fst $ - runInfoTableBuilderWithInfoTable tab $ + runInfoTableBuilder md $ mapM_ (\(sym, fi) -> overM functionCode (f sym) fi >>= registerFunction' @a @e) - (HashMap.toList (tab ^. infoFunctions)) + (HashMap.toList (md ^. moduleInfoTable . infoFunctions)) -walkT :: (Applicative f) => (Symbol -> a -> f ()) -> InfoTable' a e -> f () -walkT f tab = for_ (HashMap.toList (tab ^. infoFunctions)) (\(k, v) -> f k (v ^. functionCode)) +walkT :: (Applicative f) => (Symbol -> a -> f ()) -> Module'' a e -> f () +walkT f md = for_ (HashMap.toList (md ^. moduleInfoTable . infoFunctions)) (\(k, v) -> f k (v ^. functionCode)) -withOptimizationLevel :: (Member (Reader Options) r) => Int -> (InfoTable' a e -> Sem r (InfoTable' a e)) -> InfoTable' a e -> Sem r (InfoTable' a e) -withOptimizationLevel n f tab = do +withOptimizationLevel :: (Member (Reader Options) r) => Int -> (Module'' a e -> Sem r (Module'' a e)) -> Module'' a e -> Sem r (Module'' a e) +withOptimizationLevel n f md = do l <- asks (^. optOptimizationLevel) if - | l >= n -> f tab - | otherwise -> return tab + | l >= n -> f md + | otherwise -> return md -withOptimizationLevel' :: (Member (Reader Options) r) => InfoTable' a e -> Int -> (InfoTable' a e -> Sem r (InfoTable' a e)) -> Sem r (InfoTable' a e) -withOptimizationLevel' tab n f = withOptimizationLevel n f tab +withOptimizationLevel' :: (Member (Reader Options) r) => Module'' a e -> Int -> (Module'' a e -> Sem r (Module'' a e)) -> Sem r (Module'' a e) +withOptimizationLevel' md n f = withOptimizationLevel n f md diff --git a/src/Juvix/Compiler/Tree/Transformation/IdentityTrans.hs b/src/Juvix/Compiler/Tree/Transformation/IdentityTrans.hs index d3163502c3..3688d59a48 100644 --- a/src/Juvix/Compiler/Tree/Transformation/IdentityTrans.hs +++ b/src/Juvix/Compiler/Tree/Transformation/IdentityTrans.hs @@ -8,11 +8,11 @@ import Juvix.Compiler.Tree.Data.InfoTable import Juvix.Compiler.Tree.Extra.Recursors import Juvix.Compiler.Tree.Transformation.Base -identity :: InfoTable -> InfoTable +identity :: Module -> Module identity = run . mapT' (const return) -identityU :: InfoTable -> InfoTable +identityU :: Module -> Module identityU = run . mapT' (const (return . umap id)) -identityD :: InfoTable -> InfoTable +identityD :: Module -> Module identityD = run . mapT' (const (return . dmap id)) diff --git a/src/Juvix/Compiler/Tree/Transformation/Optimize/ConvertUnaryCalls.hs b/src/Juvix/Compiler/Tree/Transformation/Optimize/ConvertUnaryCalls.hs index e7455fdc37..687f9c3666 100644 --- a/src/Juvix/Compiler/Tree/Transformation/Optimize/ConvertUnaryCalls.hs +++ b/src/Juvix/Compiler/Tree/Transformation/Optimize/ConvertUnaryCalls.hs @@ -8,13 +8,13 @@ import Juvix.Compiler.Tree.Transformation.Base -- | Replaces generic calls (with CallClosures) to unknown unary functions with -- known non-function target types by direct closure calls (with Call) -convertUnaryCalls :: InfoTable -> InfoTable -convertUnaryCalls tab = mapT convert tab +convertUnaryCalls :: Module -> Module +convertUnaryCalls md = mapT convert md where convert :: Symbol -> Node -> Node convert sym = umapL (go argtys) where - funInfo = lookupFunInfo tab sym + funInfo = lookupFunInfo md sym argtys | funInfo ^. functionArgsNum == 0 = [] | otherwise = typeArgs (funInfo ^. functionType) @@ -32,7 +32,7 @@ convertUnaryCalls tab = mapT convert tab isUnaryWithAtomicTarget (BL.lookupLevel _offsetRefOffset tmps ^. tempVarType) -> mkClosureCall ncl | ConstrRef (Field {..}) <- _nodeMemRef, - constrInfo <- lookupConstrInfo tab _fieldTag, + constrInfo <- lookupConstrInfo md _fieldTag, isUnaryWithAtomicTarget (typeArgs (constrInfo ^. constructorType) !! _fieldOffset) -> mkClosureCall ncl _ -> node diff --git a/src/Juvix/Compiler/Tree/Transformation/Optimize/Phase/Main.hs b/src/Juvix/Compiler/Tree/Transformation/Optimize/Phase/Main.hs index 9a5ea84728..e972efa752 100644 --- a/src/Juvix/Compiler/Tree/Transformation/Optimize/Phase/Main.hs +++ b/src/Juvix/Compiler/Tree/Transformation/Optimize/Phase/Main.hs @@ -3,7 +3,7 @@ module Juvix.Compiler.Tree.Transformation.Optimize.Phase.Main where import Juvix.Compiler.Tree.Transformation.Base import Juvix.Compiler.Tree.Transformation.Optimize.ConvertUnaryCalls -optimize :: (Member (Reader Options) r) => InfoTable -> Sem r InfoTable +optimize :: (Member (Reader Options) r) => Module -> Sem r Module optimize = withOptimizationLevel 1 $ return . convertUnaryCalls diff --git a/src/Juvix/Compiler/Tree/Transformation/Validate.hs b/src/Juvix/Compiler/Tree/Transformation/Validate.hs index 298e900d3a..b9019f6f5f 100644 --- a/src/Juvix/Compiler/Tree/Transformation/Validate.hs +++ b/src/Juvix/Compiler/Tree/Transformation/Validate.hs @@ -1,15 +1,15 @@ module Juvix.Compiler.Tree.Transformation.Validate where import Juvix.Compiler.Core.Data.BinderList qualified as BL -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Error import Juvix.Compiler.Tree.Extra.Base (getNodeLocation) import Juvix.Compiler.Tree.Extra.Recursors import Juvix.Compiler.Tree.Extra.Type import Juvix.Compiler.Tree.Transformation.Base -inferType :: forall r. (Member (Error TreeError) r) => InfoTable -> FunctionInfo -> Node -> Sem r Type -inferType tab funInfo = goInfer mempty +inferType :: forall r. (Member (Error TreeError) r) => Module -> FunctionInfo -> Node -> Sem r Type +inferType md funInfo = goInfer mempty where goInfer :: BinderList Type -> Node -> Sem r Type goInfer bl = \case @@ -42,8 +42,8 @@ inferType tab funInfo = goInfer mempty checkBinop ty1' ty2' rty = do ty1 <- goInfer bl _nodeBinopArg1 ty2 <- goInfer bl _nodeBinopArg2 - void $ unifyTypes' loc tab ty1 ty1' - void $ unifyTypes' loc tab ty2 ty2' + void $ unifyTypes' loc md ty1 ty1' + void $ unifyTypes' loc md ty2 ty2' return rty checkPrimBinop :: BinaryOp -> Sem r Type @@ -74,7 +74,7 @@ inferType tab funInfo = goInfer mempty checkUnop :: Type -> Type -> Sem r Type checkUnop ty rty = do ty' <- goInfer bl _nodeUnopArg - void $ unifyTypes' loc tab ty ty' + void $ unifyTypes' loc md ty ty' return rty checkPrimUnop :: UnaryOp -> Sem r Type @@ -144,7 +144,7 @@ inferType tab funInfo = goInfer mempty | _fieldOffset < length tys = return $ tys !! _fieldOffset | otherwise = return TyDynamic where - ci = lookupConstrInfo tab _fieldTag + ci = lookupConstrInfo md _fieldTag tys = typeArgs (ci ^. constructorType) goAllocConstr :: BinderList Type -> NodeAllocConstr -> Sem r Type @@ -159,7 +159,7 @@ inferType tab funInfo = goInfer mempty _treeErrorMsg = "" } where - ci = lookupConstrInfo tab _nodeAllocConstrTag + ci = lookupConstrInfo md _nodeAllocConstrTag tys = typeArgs (ci ^. constructorType) goAllocClosure :: BinderList Type -> NodeAllocClosure -> Sem r Type @@ -175,7 +175,7 @@ inferType tab funInfo = goInfer mempty } where n = length _nodeAllocClosureArgs - fi = lookupFunInfo tab _nodeAllocClosureFunSymbol + fi = lookupFunInfo md _nodeAllocClosureFunSymbol tys = typeArgs (fi ^. functionType) goExtendClosure :: BinderList Type -> NodeExtendClosure -> Sem r Type @@ -214,7 +214,7 @@ inferType tab funInfo = goInfer mempty } where n = length _nodeCallArgs - fi = lookupFunInfo tab sym + fi = lookupFunInfo md sym tys = typeArgs (fi ^. functionType) CallClosure cl -> do ty <- goInfer bl cl @@ -261,7 +261,7 @@ inferType tab funInfo = goInfer mempty checkType bl _nodeBranchArg mkTypeBool ty1 <- goInfer bl _nodeBranchTrue ty2 <- goInfer bl _nodeBranchFalse - unifyTypes' (_nodeBranchInfo ^. nodeInfoLocation) tab ty1 ty2 + unifyTypes' (_nodeBranchInfo ^. nodeInfoLocation) md ty1 ty2 goCase :: BinderList Type -> NodeCase -> Sem r Type goCase bl NodeCase {..} = do @@ -281,7 +281,7 @@ inferType tab funInfo = goInfer mempty CaseBranch {..} : brs -> do let bl' = if _caseBranchSave then BL.cons ity bl else bl ty' <- goInfer bl' _caseBranchBody - ty'' <- unifyTypes' (_nodeCaseInfo ^. nodeInfoLocation) tab ty ty' + ty'' <- unifyTypes' (_nodeCaseInfo ^. nodeInfoLocation) md ty ty' go ity ty'' brs goSave :: BinderList Type -> NodeSave -> Sem r Type @@ -292,14 +292,14 @@ inferType tab funInfo = goInfer mempty checkType :: BinderList Type -> Node -> Type -> Sem r () checkType bl node ty = do ty' <- goInfer bl node - void $ unifyTypes' (getNodeLocation node) tab ty ty' + void $ unifyTypes' (getNodeLocation node) md ty ty' -validateFunction :: (Member (Error TreeError) r) => InfoTable -> FunctionInfo -> Sem r FunctionInfo -validateFunction tab funInfo = do - ty <- inferType tab funInfo (funInfo ^. functionCode) +validateFunction :: (Member (Error TreeError) r) => Module -> FunctionInfo -> Sem r FunctionInfo +validateFunction md funInfo = do + ty <- inferType md funInfo (funInfo ^. functionCode) let ty' = if funInfo ^. functionArgsNum == 0 then funInfo ^. functionType else typeTarget (funInfo ^. functionType) - void $ unifyTypes' (funInfo ^. functionLocation) tab ty ty' + void $ unifyTypes' (funInfo ^. functionLocation) md ty ty' return funInfo -validate :: (Member (Error TreeError) r) => InfoTable -> Sem r InfoTable -validate tab = mapFunctionsM (validateFunction tab) tab +validate :: (Member (Error TreeError) r) => Module -> Sem r Module +validate md = mapFunctionsM (validateFunction md) md diff --git a/src/Juvix/Compiler/Tree/Translation/FromAsm.hs b/src/Juvix/Compiler/Tree/Translation/FromAsm.hs index 042df8c166..efa197312e 100644 --- a/src/Juvix/Compiler/Tree/Translation/FromAsm.hs +++ b/src/Juvix/Compiler/Tree/Translation/FromAsm.hs @@ -1,9 +1,9 @@ module Juvix.Compiler.Tree.Translation.FromAsm where -import Juvix.Compiler.Asm.Data.InfoTable qualified as Asm +import Juvix.Compiler.Asm.Data.Module qualified as Asm import Juvix.Compiler.Asm.Extra.Base qualified as Asm import Juvix.Compiler.Asm.Language qualified as Asm -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Error import Juvix.Compiler.Tree.Extra.Base import Juvix.Compiler.Tree.Language @@ -15,19 +15,26 @@ newtype TempSize = TempSize makeLenses ''TempSize -fromAsm :: (Member (Error TreeError) r) => Asm.InfoTable -> Sem r InfoTable -fromAsm tab = do - fns <- mapM (goFunction tab) (tab ^. Asm.infoFunctions) +fromAsm :: (Member (Error TreeError) r) => Asm.Module -> Sem r Module +fromAsm md = do + fns <- mapM (goFunction md) (md ^. moduleInfoTable . Asm.infoFunctions) + let tab = + InfoTable + { _infoMainFunction = md ^. moduleInfoTable . Asm.infoMainFunction, + _infoFunctions = fns, + _infoInductives = md ^. moduleInfoTable . Asm.infoInductives, + _infoConstrs = md ^. moduleInfoTable . Asm.infoConstrs + } return $ - InfoTable - { _infoMainFunction = tab ^. Asm.infoMainFunction, - _infoFunctions = fns, - _infoInductives = tab ^. Asm.infoInductives, - _infoConstrs = tab ^. Asm.infoConstrs + Module + { _moduleId = md ^. moduleId, + _moduleInfoTable = tab, + _moduleImports = md ^. moduleImports, + _moduleImportsTable = mempty } -goFunction :: (Member (Error TreeError) r') => Asm.InfoTable -> Asm.FunctionInfo -> Sem r' FunctionInfo -goFunction infoTab fi = do +goFunction :: (Member (Error TreeError) r') => Asm.Module -> Asm.FunctionInfo -> Sem r' FunctionInfo +goFunction md fi = do node' <- runReader (TempSize 0) $ goCodeBlock (fi ^. Asm.functionCode) return $ FunctionInfo @@ -296,7 +303,7 @@ goFunction infoTab fi = do _nodeAllocConstrArgs = args } where - argsNum = Asm.lookupConstrInfo infoTab tag ^. constructorArgsNum + argsNum = Asm.lookupConstrInfo md tag ^. constructorArgsNum goAllocClosure :: Asm.InstrAllocClosure -> Sem r Node goAllocClosure Asm.InstrAllocClosure {..} = do diff --git a/src/Juvix/Compiler/Tree/Translation/FromCore.hs b/src/Juvix/Compiler/Tree/Translation/FromCore.hs index 72793f075d..c4509f0094 100644 --- a/src/Juvix/Compiler/Tree/Translation/FromCore.hs +++ b/src/Juvix/Compiler/Tree/Translation/FromCore.hs @@ -2,17 +2,26 @@ module Juvix.Compiler.Tree.Translation.FromCore where import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Core.Data.BinderList qualified as BL -import Juvix.Compiler.Core.Data.Stripped.InfoTable qualified as Core +import Juvix.Compiler.Core.Data.Stripped.Module qualified as Core import Juvix.Compiler.Core.Language.Stripped qualified as Core -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Extra.Base import Juvix.Compiler.Tree.Extra.Type import Juvix.Compiler.Tree.Language type BinderList = BL.BinderList -fromCore :: Core.InfoTable -> InfoTable -fromCore tab = +fromCore :: Core.Module -> Module +fromCore Core.Module {..} = + Module + { _moduleId = _moduleId, + _moduleInfoTable = fromCore' _moduleInfoTable, + _moduleImports = _moduleImports, + _moduleImportsTable = mempty + } + +fromCore' :: Core.InfoTable -> InfoTable +fromCore' tab = InfoTable { _infoMainFunction = tab ^. Core.infoMain, _infoFunctions = genCode tab <$> tab ^. Core.infoFunctions, diff --git a/src/Juvix/Compiler/Tree/Translation/FromSource.hs b/src/Juvix/Compiler/Tree/Translation/FromSource.hs index e52a1ff781..d8db7e360d 100644 --- a/src/Juvix/Compiler/Tree/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Tree/Translation/FromSource.hs @@ -7,8 +7,8 @@ where import Control.Monad.Trans.Class (lift) import Data.HashMap.Strict qualified as HashMap -import Juvix.Compiler.Tree.Data.InfoTable import Juvix.Compiler.Tree.Data.InfoTableBuilder +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Extra.Base import Juvix.Compiler.Tree.Language import Juvix.Compiler.Tree.Translation.FromSource.Base @@ -32,13 +32,13 @@ parseTreeSig = _parserSigEmptyExtra = () } -parseText :: Text -> Either MegaparsecError InfoTable +parseText :: Text -> Either MegaparsecError Module parseText = runParser noFile parseText' :: BuilderState -> Text -> Either MegaparsecError BuilderState parseText' bs = runParser' bs noFile -runParser :: Path Abs File -> Text -> Either MegaparsecError InfoTable +runParser :: Path Abs File -> Text -> Either MegaparsecError Module runParser = runParserS parseTreeSig runParser' :: BuilderState -> Path Abs File -> Text -> Either MegaparsecError BuilderState diff --git a/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs b/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs index 424c45122e..41a5da8782 100644 --- a/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs +++ b/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs @@ -16,8 +16,8 @@ where import Control.Monad.Trans.Class (lift) import Data.HashMap.Strict qualified as HashMap import Data.List.NonEmpty qualified as NonEmpty -import Juvix.Compiler.Tree.Data.InfoTable.Base import Juvix.Compiler.Tree.Data.InfoTableBuilder.Base +import Juvix.Compiler.Tree.Data.Module.Base import Juvix.Compiler.Tree.Extra.Type import Juvix.Compiler.Tree.Keywords.Base import Juvix.Compiler.Tree.Language.Base @@ -38,8 +38,8 @@ localS update a = do lift $ put s return a' -runParserS :: ParserSig t e d -> Path Abs File -> Text -> Either MegaparsecError (InfoTable' t e) -runParserS sig fileName input_ = (^. stateInfoTable) <$> runParserS' sig emptyBuilderState fileName input_ +runParserS :: ParserSig t e d -> Path Abs File -> Text -> Either MegaparsecError (Module'' t e) +runParserS sig fileName input_ = (^. stateModule) <$> runParserS' sig (mkBuilderState (emptyModule defaultModuleId)) fileName input_ runParserS' :: forall t e d. ParserSig t e d -> BuilderState' t e -> Path Abs File -> Text -> Either MegaparsecError (BuilderState' t e) runParserS' sig bs fileName input_ = case runParserS'' (parseToplevel @t @e @d) sig bs fileName input_ of From 4dbf75b7a788a031e74c47272d106ec01d18dc4e Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Wed, 12 Feb 2025 17:53:07 +0100 Subject: [PATCH 07/24] fix test compilation --- .../Reg/Transformation/InitBranchVars.hs | 4 +- test/Asm/Compile/Base.hs | 12 ++--- test/Asm/Run/Base.hs | 44 ++++++++--------- test/Asm/Transformation/Base.hs | 6 +-- test/Asm/Transformation/Reachability.hs | 2 +- test/Asm/Validate/Base.hs | 8 ++-- test/Casm/Reg/Base.hs | 14 +++--- test/Core/Asm/Base.hs | 9 ++-- test/Core/Compile/Base.hs | 6 +-- test/Nockma/Compile/Tree/Positive.hs | 6 +-- test/Reg/Parse/Base.hs | 14 +++--- test/Reg/Run/Base.hs | 48 +++++++++---------- test/Reg/Transformation/Base.hs | 4 +- test/Tree/Eval/Base.hs | 42 ++++++++-------- test/Tree/Parse/Base.hs | 14 +++--- test/Tree/Transformation/Base.hs | 4 +- test/Tree/Transformation/Reachability.hs | 2 +- 17 files changed, 121 insertions(+), 118 deletions(-) diff --git a/src/Juvix/Compiler/Reg/Transformation/InitBranchVars.hs b/src/Juvix/Compiler/Reg/Transformation/InitBranchVars.hs index 9929d1f2ea..ce56f1122f 100644 --- a/src/Juvix/Compiler/Reg/Transformation/InitBranchVars.hs +++ b/src/Juvix/Compiler/Reg/Transformation/InitBranchVars.hs @@ -76,8 +76,8 @@ initBranchVars = mapT (const goFun) _instrAssignValue = ValConst ConstVoid } -checkInitialized :: InfoTable -> Bool -checkInitialized tab = all (goFun . (^. functionCode)) (tab ^. infoFunctions) +checkInitialized :: Module -> Bool +checkInitialized md = all (goFun . (^. functionCode)) (md ^. moduleInfoTable . infoFunctions) where goFun :: Code -> Bool goFun = snd . ifoldB go (mempty, True) diff --git a/test/Asm/Compile/Base.hs b/test/Asm/Compile/Base.hs index 403b4f5ae9..a32f1e165b 100644 --- a/test/Asm/Compile/Base.hs +++ b/test/Asm/Compile/Base.hs @@ -1,7 +1,7 @@ module Asm.Compile.Base where import Base -import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Error import Juvix.Compiler.Asm.Options import Juvix.Compiler.Asm.Translation.FromSource @@ -9,10 +9,10 @@ import Juvix.Compiler.Backend.C qualified as C import Juvix.Compiler.Pipeline qualified as Pipeline import Runtime.Base qualified as Runtime -asmCompileAssertion' :: EntryPoint -> Int -> InfoTable -> Path Abs File -> Path Abs File -> Text -> (String -> IO ()) -> Assertion -asmCompileAssertion' entryPoint optLevel tab mainFile expectedFile stdinText step = do +asmCompileAssertion' :: EntryPoint -> Int -> Module -> Path Abs File -> Path Abs File -> Text -> (String -> IO ()) -> Assertion +asmCompileAssertion' entryPoint optLevel md mainFile expectedFile stdinText step = do step "Generate C code" - case run $ runReader entryPoint' $ runError @JuvixError $ Pipeline.asmToMiniC tab of + case run $ runReader entryPoint' $ runError @JuvixError $ Pipeline.asmToMiniC md of Left e -> do let err :: AsmError = fromJust (fromJuvixError e) assertFailure ("code generation failed:" <> "\n" <> unpack (err ^. asmErrorMsg)) @@ -42,6 +42,6 @@ asmCompileAssertion root' mainFile expectedFile stdinText step = do s <- readFile mainFile case runParser mainFile s of Left err -> assertFailure (show err) - Right tab -> do + Right md -> do entryPoint <- testDefaultEntryPointIO root' mainFile - asmCompileAssertion' entryPoint 3 tab mainFile expectedFile stdinText step + asmCompileAssertion' entryPoint 3 md mainFile expectedFile stdinText step diff --git a/test/Asm/Run/Base.hs b/test/Asm/Run/Base.hs index 475ccf0cab..1b80fa036b 100644 --- a/test/Asm/Run/Base.hs +++ b/test/Asm/Run/Base.hs @@ -1,7 +1,7 @@ module Asm.Run.Base where import Base -import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Error import Juvix.Compiler.Asm.Interpreter import Juvix.Compiler.Asm.Pretty @@ -9,7 +9,7 @@ import Juvix.Compiler.Asm.Transformation.Validate import Juvix.Compiler.Asm.Translation.FromSource import Juvix.Data.PPOutput -runAssertion :: Handle -> Symbol -> InfoTable -> IO () +runAssertion :: Handle -> Symbol -> Module -> IO () runAssertion hout sym tab = do r' <- doRun hout tab (lookupFunInfo tab sym) case r' of @@ -21,23 +21,23 @@ runAssertion hout sym tab = do ValVoid -> return () _ -> hPutStrLn hout (ppPrint tab value') -asmRunAssertion' :: InfoTable -> Path Abs File -> (String -> IO ()) -> Assertion +asmRunAssertion' :: Module -> Path Abs File -> (String -> IO ()) -> Assertion asmRunAssertion' = asmRunAssertionParam' runAssertion -asmRunAssertionParam' :: (Handle -> Symbol -> InfoTable -> IO ()) -> InfoTable -> Path Abs File -> (String -> IO ()) -> Assertion -asmRunAssertionParam' interpretFun tab expectedFile step = do +asmRunAssertionParam' :: (Handle -> Symbol -> Module -> IO ()) -> Module -> Path Abs File -> (String -> IO ()) -> Assertion +asmRunAssertionParam' interpretFun md expectedFile step = do step "Validate" - case validate' tab of + case validate' md of Just err -> assertFailure (prettyString err) Nothing -> - case tab ^. infoMainFunction of + case md ^. moduleInfoTable . infoMainFunction of Just sym -> do withTempDir' ( \dirPath -> do let outputFile = dirPath $(mkRelFile "out.out") hout <- openFile (toFilePath outputFile) WriteMode step "Interpret" - interpretFun hout sym tab + interpretFun hout sym md hClose hout actualOutput <- readFile outputFile step "Compare expected and actual program output" @@ -46,21 +46,21 @@ asmRunAssertionParam' interpretFun tab expectedFile step = do ) Nothing -> assertFailure "no 'main' function" -asmRunAssertion :: Path Abs File -> Path Abs File -> (InfoTable -> Either AsmError InfoTable) -> (InfoTable -> Assertion) -> (String -> IO ()) -> Assertion +asmRunAssertion :: Path Abs File -> Path Abs File -> (Module -> Either AsmError Module) -> (Module -> Assertion) -> (String -> IO ()) -> Assertion asmRunAssertion = asmRunAssertionParam runAssertion -asmRunAssertionParam :: (Handle -> Symbol -> InfoTable -> IO ()) -> Path Abs File -> Path Abs File -> (InfoTable -> Either AsmError InfoTable) -> (InfoTable -> Assertion) -> (String -> IO ()) -> Assertion +asmRunAssertionParam :: (Handle -> Symbol -> Module -> IO ()) -> Path Abs File -> Path Abs File -> (Module -> Either AsmError Module) -> (Module -> Assertion) -> (String -> IO ()) -> Assertion asmRunAssertionParam interpretFun mainFile expectedFile trans testTrans step = do step "Parse" r <- parseFile mainFile case r of Left err -> assertFailure (prettyString err) - Right tab0 -> do - case trans tab0 of + Right md -> do + case trans md of Left err -> assertFailure (prettyString err) - Right tab -> do - testTrans tab - asmRunAssertionParam' interpretFun tab expectedFile step + Right md' -> do + testTrans md' + asmRunAssertionParam' interpretFun md' expectedFile step asmRunErrorAssertion :: Path Abs File -> (String -> IO ()) -> Assertion asmRunErrorAssertion mainFile step = do @@ -68,19 +68,19 @@ asmRunErrorAssertion mainFile step = do r <- parseFile mainFile case r of Left _ -> assertBool "" True - Right tab -> do + Right md -> do step "Validate" - case validate' tab of + case validate' md of Just _ -> assertBool "" True Nothing -> - case tab ^. infoMainFunction of + case md ^. moduleInfoTable . infoMainFunction of Just sym -> do withTempDir' ( \dirPath -> do let outputFile = dirPath $(mkRelFile "out.out") hout <- openFile (toFilePath outputFile) WriteMode step "Interpret" - r' <- doRun hout tab (lookupFunInfo tab sym) + r' <- doRun hout md (lookupFunInfo md sym) hClose hout case r' of Left _ -> assertBool "" True @@ -88,14 +88,14 @@ asmRunErrorAssertion mainFile step = do ) Nothing -> assertBool "" True -parseFile :: Path Abs File -> IO (Either MegaparsecError InfoTable) +parseFile :: Path Abs File -> IO (Either MegaparsecError Module) parseFile f = do s <- readFile f return (runParser f s) doRun :: Handle -> - InfoTable -> + Module -> FunctionInfo -> IO (Either AsmError Val) -doRun hout tab funInfo = catchRunErrorIO (hRunCodeIO stdin hout tab funInfo) +doRun hout md funInfo = catchRunErrorIO (hRunCodeIO stdin hout md funInfo) diff --git a/test/Asm/Transformation/Base.hs b/test/Asm/Transformation/Base.hs index 672265bc72..5d16f0fa46 100644 --- a/test/Asm/Transformation/Base.hs +++ b/test/Asm/Transformation/Base.hs @@ -3,12 +3,12 @@ module Asm.Transformation.Base where import Asm.Run.Base import Asm.Run.Positive qualified as Run import Base -import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Error data Test = Test - { _testTransformation :: InfoTable -> Either AsmError InfoTable, - _testAssertion :: InfoTable -> Assertion, + { _testTransformation :: Module -> Either AsmError Module, + _testAssertion :: Module -> Assertion, _testEval :: Run.PosTest } diff --git a/test/Asm/Transformation/Reachability.hs b/test/Asm/Transformation/Reachability.hs index 7f5fcce59a..6bdec59281 100644 --- a/test/Asm/Transformation/Reachability.hs +++ b/test/Asm/Transformation/Reachability.hs @@ -46,7 +46,7 @@ liftTest ReachabilityTest {..} = fromTest Test { _testTransformation = runTransformation (runReader opts . filterUnreachable), - _testAssertion = \tab -> unless (nubSort (map (^. functionName) (HashMap.elems (tab ^. infoFunctions))) == nubSort _reachabilityTestReachable) (error "check reachable"), + _testAssertion = \md -> unless (nubSort (map (^. functionName) (HashMap.elems (md ^. moduleInfoTable . infoFunctions))) == nubSort _reachabilityTestReachable) (error "check reachable"), _testEval = _reachabilityTestEval } where diff --git a/test/Asm/Validate/Base.hs b/test/Asm/Validate/Base.hs index 9348879896..5f858795c8 100644 --- a/test/Asm/Validate/Base.hs +++ b/test/Asm/Validate/Base.hs @@ -1,7 +1,7 @@ module Asm.Validate.Base where import Base -import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Data.Module import Juvix.Compiler.Asm.Transformation.Validate import Juvix.Compiler.Asm.Translation.FromSource @@ -11,13 +11,13 @@ asmValidateErrorAssertion mainFile step = do r <- parseFile mainFile case r of Left _ -> assertBool "" True - Right tab -> do + Right md -> do step "Validate" - case validate' tab of + case validate' md of Just _ -> assertBool "" True Nothing -> assertFailure "no error" -parseFile :: Path Abs File -> IO (Either MegaparsecError InfoTable) +parseFile :: Path Abs File -> IO (Either MegaparsecError Module) parseFile f = do s <- readFile f return (runParser f s) diff --git a/test/Casm/Reg/Base.hs b/test/Casm/Reg/Base.hs index 801db6d8ee..038cc71e58 100644 --- a/test/Casm/Reg/Base.hs +++ b/test/Casm/Reg/Base.hs @@ -6,14 +6,14 @@ import Data.Aeson import Juvix.Compiler.Casm.Data.Result import Juvix.Compiler.Casm.Error import Juvix.Compiler.Casm.Interpreter -import Juvix.Compiler.Reg.Data.InfoTable qualified as Reg +import Juvix.Compiler.Reg.Data.Module qualified as Reg import Juvix.Data.PPOutput import Reg.Run.Base qualified as Reg -compileAssertion' :: EntryPoint -> Maybe (Path Abs File) -> Path Abs Dir -> Path Abs File -> Symbol -> Reg.InfoTable -> (String -> IO ()) -> Assertion -compileAssertion' entryPoint inputFile _ outputFile _ tab step = do +compileAssertion' :: EntryPoint -> Maybe (Path Abs File) -> Path Abs Dir -> Path Abs File -> Symbol -> Reg.Module -> (String -> IO ()) -> Assertion +compileAssertion' entryPoint inputFile _ outputFile _ md step = do step "Translate to CASM" - case run . runError @JuvixError . runReader entryPoint $ regToCasm tab of + case run . runError @JuvixError . runReader entryPoint $ regToCasm md of Left err -> assertFailure (prettyString (fromJuvixError @GenericError err)) Right Result {..} -> do step "Interpret" @@ -27,10 +27,10 @@ compileAssertion' entryPoint inputFile _ outputFile _ tab step = do hPrint hout v hClose hout -cairoAssertion' :: EntryPoint -> Maybe (Path Abs File) -> Path Abs Dir -> Path Abs File -> Symbol -> Reg.InfoTable -> (String -> IO ()) -> Assertion -cairoAssertion' entryPoint inputFile dirPath outputFile _ tab step = do +cairoAssertion' :: EntryPoint -> Maybe (Path Abs File) -> Path Abs Dir -> Path Abs File -> Symbol -> Reg.Module -> (String -> IO ()) -> Assertion +cairoAssertion' entryPoint inputFile dirPath outputFile _ md step = do step "Translate to Cairo" - case run . runError @JuvixError . runReader entryPoint $ regToCairo tab of + case run . runError @JuvixError . runReader entryPoint $ regToCairo md of Left err -> assertFailure (prettyString (fromJuvixError @GenericError err)) Right res -> do step "Serialize to Cairo bytecode" diff --git a/test/Core/Asm/Base.hs b/test/Core/Asm/Base.hs index 5ea6d8e14c..7e678a13f7 100644 --- a/test/Core/Asm/Base.hs +++ b/test/Core/Asm/Base.hs @@ -5,7 +5,7 @@ import Base import Core.Eval.Base import Core.Eval.Positive qualified as Eval import Juvix.Compiler.Asm.Translation.FromTree qualified as Asm -import Juvix.Compiler.Core.Data.Module (computeCombinedInfoTable, moduleFromInfoTable) +import Juvix.Compiler.Core.Data.Module (moduleFromInfoTable) import Juvix.Compiler.Core.Data.TransformationId import Juvix.Compiler.Core.Pipeline import Juvix.Compiler.Core.Translation.FromSource @@ -64,9 +64,8 @@ coreAsmAssertion root' mainFile expectedFile step = do $ setupMainFunction defaultModuleId tabIni node of Left err -> assertFailure (prettyString (fromJuvixError @GenericError err)) Right m -> do - let tab = + let md = Asm.fromTree . Tree.fromCore - . Stripped.fromCore - $ computeCombinedInfoTable m - Asm.asmRunAssertion' tab expectedFile step + $ Stripped.fromCore m + Asm.asmRunAssertion' md expectedFile step diff --git a/test/Core/Compile/Base.hs b/test/Core/Compile/Base.hs index 42530d8c2e..ba93af38b7 100644 --- a/test/Core/Compile/Base.hs +++ b/test/Core/Compile/Base.hs @@ -55,9 +55,9 @@ coreCompileAssertion' entryPoint optLevel tab mainFile expectedFile stdinText st Right m -> do let tab0 = computeCombinedInfoTable m assertBool "Check info table" (checkInfoTable tab0) - let tab' = Asm.fromTree . Tree.fromCore $ Stripped.fromCore tab0 - length (fromText (Asm.ppPrint tab' tab') :: String) `seq` - Asm.asmCompileAssertion' entryPoint' optLevel tab' mainFile expectedFile stdinText step + let md' = Asm.fromTree . Tree.fromCore $ Stripped.fromCore m + length (fromText (Asm.ppPrint md' (computeCombinedInfoTable md')) :: String) `seq` + Asm.asmCompileAssertion' entryPoint' optLevel md' mainFile expectedFile stdinText step where entryPoint' = entryPoint {_entryPointOptimizationLevel = optLevel} diff --git a/test/Nockma/Compile/Tree/Positive.hs b/test/Nockma/Compile/Tree/Positive.hs index f0559edac7..b2001322d4 100644 --- a/test/Nockma/Compile/Tree/Positive.hs +++ b/test/Nockma/Compile/Tree/Positive.hs @@ -11,15 +11,15 @@ import Juvix.Compiler.Tree import Tree.Eval.Base import Tree.Eval.Positive qualified as Tree -runNockmaAssertion :: Path Abs Dir -> Handle -> Symbol -> InfoTable -> IO () -runNockmaAssertion root hout _main tab = do +runNockmaAssertion :: Path Abs Dir -> Handle -> Symbol -> Module -> IO () +runNockmaAssertion root hout _main md = do entryPoint <- testDefaultEntryPointNoFileIO root let entryPoint' = entryPoint {_entryPointDebug = True} anomaRes :: AnomaResult <- runM . runErrorIO' @JuvixError . runReader entryPoint' - $ treeToAnoma tab + $ treeToAnoma md res <- runM . runOutputSem @(Nockma.Term Natural) diff --git a/test/Reg/Parse/Base.hs b/test/Reg/Parse/Base.hs index b6aadfa8f5..81a3bfaf2c 100644 --- a/test/Reg/Parse/Base.hs +++ b/test/Reg/Parse/Base.hs @@ -1,7 +1,7 @@ module Reg.Parse.Base where import Base -import Juvix.Compiler.Reg.Data.InfoTable +import Juvix.Compiler.Reg.Data.Module import Juvix.Compiler.Reg.Pretty import Juvix.Compiler.Reg.Translation.FromSource import Juvix.Data.PPOutput @@ -12,21 +12,23 @@ regParseAssertion mainFile step = do r <- parseFile mainFile case r of Left err -> assertFailure (prettyString err) - Right tab -> do + Right md -> do withTempDir' ( \dirPath -> do let outputFile = dirPath $(mkRelFile "out.out") step "Print" - writeFileEnsureLn outputFile (ppPrint tab tab) + writeFileEnsureLn outputFile (ppPrint md (computeCombinedInfoTable md)) step "Parse printed" r' <- parseFile outputFile case r' of Left err -> assertFailure (prettyString err) - Right tab' -> do - assertBool ("Check: print . parse = print . parse . print . parse") (ppPrint tab tab == ppPrint tab' tab') + Right md' -> do + assertBool + ("Check: print . parse = print . parse . print . parse") + (ppPrint md (computeCombinedInfoTable md) == ppPrint md' (computeCombinedInfoTable md')) ) -parseFile :: Path Abs File -> IO (Either MegaparsecError InfoTable) +parseFile :: Path Abs File -> IO (Either MegaparsecError Module) parseFile f = do s <- readFile f return (runParser f s) diff --git a/test/Reg/Run/Base.hs b/test/Reg/Run/Base.hs index 5083173375..8626265f10 100644 --- a/test/Reg/Run/Base.hs +++ b/test/Reg/Run/Base.hs @@ -1,7 +1,7 @@ module Reg.Run.Base where import Base -import Juvix.Compiler.Reg.Data.InfoTable +import Juvix.Compiler.Reg.Data.Module import Juvix.Compiler.Reg.Error import Juvix.Compiler.Reg.Interpreter import Juvix.Compiler.Reg.Pretty @@ -9,11 +9,11 @@ import Juvix.Compiler.Reg.Transformation as Reg import Juvix.Compiler.Reg.Translation.FromSource import Juvix.Data.PPOutput -runAssertion :: Path Abs Dir -> Path Abs File -> Symbol -> InfoTable -> (String -> IO ()) -> Assertion -runAssertion _ outputFile sym tab step = do +runAssertion :: Path Abs Dir -> Path Abs File -> Symbol -> Module -> (String -> IO ()) -> Assertion +runAssertion _ outputFile sym md step = do hout <- openFile (toFilePath outputFile) WriteMode step "Interpret" - r' <- doRun hout tab (lookupFunInfo tab sym) + r' <- doRun hout md (lookupFunInfo md sym) case r' of Left err -> do hClose hout @@ -23,20 +23,20 @@ runAssertion _ outputFile sym tab step = do ValVoid -> hClose hout _ -> do - hPutStrLn hout (ppPrint tab value') + hPutStrLn hout (ppPrint md value') hClose hout -regRunAssertion' :: InfoTable -> Path Abs File -> (String -> IO ()) -> Assertion +regRunAssertion' :: Module -> Path Abs File -> (String -> IO ()) -> Assertion regRunAssertion' = regRunAssertionParam' runAssertion -regRunAssertionParam' :: (Path Abs Dir -> Path Abs File -> Symbol -> InfoTable -> (String -> IO ()) -> Assertion) -> InfoTable -> Path Abs File -> (String -> IO ()) -> Assertion -regRunAssertionParam' interpretFun tab expectedFile step = do - case tab ^. infoMainFunction of +regRunAssertionParam' :: (Path Abs Dir -> Path Abs File -> Symbol -> Module -> (String -> IO ()) -> Assertion) -> Module -> Path Abs File -> (String -> IO ()) -> Assertion +regRunAssertionParam' interpretFun md expectedFile step = do + case md ^. moduleInfoTable . infoMainFunction of Just sym -> do withTempDir' ( \dirPath -> do let outputFile = dirPath $(mkRelFile "out.out") - interpretFun dirPath outputFile sym tab step + interpretFun dirPath outputFile sym md step actualOutput <- readFile outputFile step "Compare expected and actual program output" expected <- readFile expectedFile @@ -44,23 +44,23 @@ regRunAssertionParam' interpretFun tab expectedFile step = do ) Nothing -> assertFailure "no 'main' function" -regRunAssertion :: Path Abs File -> Path Abs File -> [TransformationId] -> (InfoTable -> Assertion) -> (String -> IO ()) -> Assertion +regRunAssertion :: Path Abs File -> Path Abs File -> [TransformationId] -> (Module -> Assertion) -> (String -> IO ()) -> Assertion regRunAssertion = regRunAssertionParam runAssertion -regRunAssertionParam :: (Path Abs Dir -> Path Abs File -> Symbol -> InfoTable -> (String -> IO ()) -> Assertion) -> Path Abs File -> Path Abs File -> [TransformationId] -> (InfoTable -> Assertion) -> (String -> IO ()) -> Assertion +regRunAssertionParam :: (Path Abs Dir -> Path Abs File -> Symbol -> Module -> (String -> IO ()) -> Assertion) -> Path Abs File -> Path Abs File -> [TransformationId] -> (Module -> Assertion) -> (String -> IO ()) -> Assertion regRunAssertionParam interpretFun mainFile expectedFile trans testTrans step = do step "Parse" r <- parseFile mainFile case r of Left err -> assertFailure (prettyString err) - Right tab0 -> do + Right md -> do unless (null trans) $ step "Transform" - case run $ runError @JuvixError $ runReader Reg.defaultOptions $ applyTransformations trans tab0 of + case run $ runError @JuvixError $ runReader Reg.defaultOptions $ applyTransformations trans md of Left err -> assertFailure (prettyString (fromJuvixError @GenericError err)) - Right tab -> do - testTrans tab - regRunAssertionParam' interpretFun tab expectedFile step + Right md' -> do + testTrans md' + regRunAssertionParam' interpretFun md' expectedFile step regRunErrorAssertion :: Path Abs File -> (String -> IO ()) -> Assertion regRunErrorAssertion mainFile step = do @@ -68,15 +68,15 @@ regRunErrorAssertion mainFile step = do r <- parseFile mainFile case r of Left _ -> assertBool "" True - Right tab -> - case tab ^. infoMainFunction of + Right md -> + case md ^. moduleInfoTable . infoMainFunction of Just sym -> do withTempDir' ( \dirPath -> do let outputFile = dirPath $(mkRelFile "out.out") hout <- openFile (toFilePath outputFile) WriteMode step "Interpret" - r' <- doRun hout tab (lookupFunInfo tab sym) + r' <- doRun hout md (lookupFunInfo md sym) hClose hout case r' of Left _ -> assertBool "" True @@ -84,17 +84,17 @@ regRunErrorAssertion mainFile step = do ) Nothing -> assertBool "" True -parseFile :: Path Abs File -> IO (Either MegaparsecError InfoTable) +parseFile :: Path Abs File -> IO (Either MegaparsecError Module) parseFile f = do s <- readFile f return (runParser f s) doRun :: Handle -> - InfoTable -> + Module -> FunctionInfo -> IO (Either RegError Val) -doRun hout tab funInfo = +doRun hout md funInfo = runM . runError - $ runFunctionIO stdin hout tab [] funInfo + $ runFunctionIO stdin hout md [] funInfo diff --git a/test/Reg/Transformation/Base.hs b/test/Reg/Transformation/Base.hs index c1756c1b34..892601b5b2 100644 --- a/test/Reg/Transformation/Base.hs +++ b/test/Reg/Transformation/Base.hs @@ -1,14 +1,14 @@ module Reg.Transformation.Base where import Base -import Juvix.Compiler.Reg.Data.InfoTable +import Juvix.Compiler.Reg.Data.Module import Juvix.Compiler.Reg.Transformation import Reg.Parse.Positive qualified as Parse import Reg.Run.Base data Test = Test { _testTransformations :: [TransformationId], - _testAssertion :: InfoTable -> Assertion, + _testAssertion :: Module -> Assertion, _testRun :: Parse.PosTest } diff --git a/test/Tree/Eval/Base.hs b/test/Tree/Eval/Base.hs index db6315dc02..4875d8592a 100644 --- a/test/Tree/Eval/Base.hs +++ b/test/Tree/Eval/Base.hs @@ -1,7 +1,7 @@ module Tree.Eval.Base where import Base -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Data.TransformationId import Juvix.Compiler.Tree.Error import Juvix.Compiler.Tree.Evaluator @@ -17,17 +17,17 @@ treeEvalAssertion :: Path Abs File -> Path Abs File -> [TransformationId] -> - (InfoTable -> Assertion) -> + (Module -> Assertion) -> (String -> IO ()) -> Assertion treeEvalAssertion = treeEvalAssertionParam evalAssertion treeEvalAssertionParam :: - (Handle -> Symbol -> InfoTable -> IO ()) -> + (Handle -> Symbol -> Module -> IO ()) -> Path Abs File -> Path Abs File -> [TransformationId] -> - (InfoTable -> Assertion) -> + (Module -> Assertion) -> (String -> IO ()) -> Assertion treeEvalAssertionParam evalParam mainFile expectedFile trans testTrans step = do @@ -35,26 +35,26 @@ treeEvalAssertionParam evalParam mainFile expectedFile trans testTrans step = do s <- readFile mainFile case runParser mainFile s of Left err -> assertFailure (prettyString err) - Right tab0 -> do + Right md0 -> do step "Validate" let opts = Tree.defaultOptions - case run $ runReader opts $ runError @JuvixError $ applyTransformations [Validate] tab0 of + case run $ runReader opts $ runError @JuvixError $ applyTransformations [Validate] md0 of Left err -> assertFailure (prettyString (fromJuvixError @GenericError err)) - Right tab1 -> do + Right md1 -> do unless (null trans) $ step "Transform" - case run $ runReader opts $ runError @JuvixError $ applyTransformations trans tab1 of + case run $ runReader opts $ runError @JuvixError $ applyTransformations trans md1 of Left err -> assertFailure (prettyString (fromJuvixError @GenericError err)) - Right tab -> do - testTrans tab - case tab ^. infoMainFunction of + Right md -> do + testTrans md + case md ^. moduleInfoTable . infoMainFunction of Just sym -> do withTempDir' ( \dirPath -> do let outputFile = dirPath $(mkRelFile "out.out") hout <- openFile (toFilePath outputFile) WriteMode step "Evaluate" - evalParam hout sym tab + evalParam hout sym md hClose hout actualOutput <- readFile outputFile step "Compare expected and actual program output" @@ -63,9 +63,9 @@ treeEvalAssertionParam evalParam mainFile expectedFile trans testTrans step = do ) Nothing -> assertFailure "no 'main' function" -evalAssertion :: Handle -> Symbol -> InfoTable -> IO () -evalAssertion hout sym tab = do - r' <- doEval hout tab (lookupFunInfo tab sym) +evalAssertion :: Handle -> Symbol -> Module -> IO () +evalAssertion hout sym md = do + r' <- doEval hout md (lookupFunInfo md sym) case r' of Left err -> do hClose hout @@ -73,14 +73,14 @@ evalAssertion hout sym tab = do Right value' -> do case value' of ValVoid -> return () - _ -> hPutStrLn hout (ppPrint tab value') + _ -> hPutStrLn hout (ppPrint md value') doEval :: Handle -> - InfoTable -> + Module -> FunctionInfo -> IO (Either TreeError Value) -doEval hout tab funInfo = catchEvalErrorIO (hEvalIO stdin hout tab funInfo) +doEval hout md funInfo = catchEvalErrorIO (hEvalIO stdin hout md funInfo) treeEvalErrorAssertion :: Path Abs File -> (String -> IO ()) -> Assertion treeEvalErrorAssertion mainFile step = do @@ -88,15 +88,15 @@ treeEvalErrorAssertion mainFile step = do s <- readFile mainFile case runParser mainFile s of Left err -> assertFailure (prettyString err) - Right tab -> - case tab ^. infoMainFunction of + Right md -> + case md ^. moduleInfoTable . infoMainFunction of Just sym -> do withTempDir' ( \dirPath -> do let outputFile = dirPath $(mkRelFile "out.out") hout <- openFile (toFilePath outputFile) WriteMode step "Evaluate" - r' <- doEval hout tab (lookupFunInfo tab sym) + r' <- doEval hout md (lookupFunInfo md sym) hClose hout case r' of Left _ -> assertBool "" True diff --git a/test/Tree/Parse/Base.hs b/test/Tree/Parse/Base.hs index 8e1049f894..ac7ddd8912 100644 --- a/test/Tree/Parse/Base.hs +++ b/test/Tree/Parse/Base.hs @@ -1,7 +1,7 @@ module Tree.Parse.Base where import Base -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Pretty import Juvix.Compiler.Tree.Translation.FromSource import Juvix.Data.PPOutput @@ -12,21 +12,23 @@ treeParseAssertion mainFile step = do r <- parseFile mainFile case r of Left err -> assertFailure (prettyString err) - Right tab -> do + Right md -> do withTempDir' ( \dirPath -> do let outputFile = dirPath $(mkRelFile "out.out") step "Print" - writeFileEnsureLn outputFile (ppPrint tab tab) + writeFileEnsureLn outputFile (ppPrint md (computeCombinedInfoTable md)) step "Parse printed" r' <- parseFile outputFile case r' of Left err -> assertFailure (prettyString err) - Right tab' -> do - assertBool ("Check: print . parse = print . parse . print . parse") (ppPrint tab tab == ppPrint tab' tab') + Right md' -> do + assertBool + ("Check: print . parse = print . parse . print . parse") + (ppPrint md (computeCombinedInfoTable md) == ppPrint md' (computeCombinedInfoTable md')) ) -parseFile :: Path Abs File -> IO (Either MegaparsecError InfoTable) +parseFile :: Path Abs File -> IO (Either MegaparsecError Module) parseFile f = do s <- readFile f return (runParser f s) diff --git a/test/Tree/Transformation/Base.hs b/test/Tree/Transformation/Base.hs index 9f7e88e06b..b1fe3f667a 100644 --- a/test/Tree/Transformation/Base.hs +++ b/test/Tree/Transformation/Base.hs @@ -1,14 +1,14 @@ module Tree.Transformation.Base where import Base -import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Transformation import Tree.Eval.Base import Tree.Eval.Positive qualified as Eval data Test = Test { _testTransformations :: [TransformationId], - _testAssertion :: InfoTable -> Assertion, + _testAssertion :: Module -> Assertion, _testEval :: Eval.PosTest } diff --git a/test/Tree/Transformation/Reachability.hs b/test/Tree/Transformation/Reachability.hs index 4f6cd7c8d6..98213ebbfc 100644 --- a/test/Tree/Transformation/Reachability.hs +++ b/test/Tree/Transformation/Reachability.hs @@ -43,6 +43,6 @@ liftTest ReachabilityTest {..} = fromTest Test { _testTransformations = [Tree.FilterUnreachable], - _testAssertion = \tab -> unless (nubSort (map (^. functionName) (HashMap.elems (tab ^. infoFunctions))) == nubSort _reachabilityTestReachable) (error "check reachable"), + _testAssertion = \md -> unless (nubSort (map (^. functionName) (HashMap.elems (md ^. moduleInfoTable . infoFunctions))) == nubSort _reachabilityTestReachable) (error "check reachable"), _testEval = _reachabilityTestEval } From 15baf76c7aed22b0304b51f119039e737ad91ae4 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Thu, 13 Feb 2025 11:04:55 +0100 Subject: [PATCH 08/24] fix apply transformation --- src/Juvix/Compiler/Tree/Transformation/Apply.hs | 6 +++--- test/Reg/Transformation/InitBranchVars.hs | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Juvix/Compiler/Tree/Transformation/Apply.hs b/src/Juvix/Compiler/Tree/Transformation/Apply.hs index c385ae531c..b9f71117d0 100644 --- a/src/Juvix/Compiler/Tree/Transformation/Apply.hs +++ b/src/Juvix/Compiler/Tree/Transformation/Apply.hs @@ -35,10 +35,10 @@ computeFunctionApply blts = umap go where sym = fromJust $ HashMap.lookup (length args) (blts ^. applyBuiltinsMap) --- | Assumption: the applyBuiltins are already available (the --- applyBuiltinsModule has already been added). computeApply :: Module -> Module -computeApply = mapT (const (computeFunctionApply applyBuiltins)) +computeApply = + mapT (const (computeFunctionApply applyBuiltins)) + . over moduleImportsTable (applyBuiltinsModule ^. moduleInfoTable <>) checkNoCallClosures :: Module -> Bool checkNoCallClosures md = diff --git a/test/Reg/Transformation/InitBranchVars.hs b/test/Reg/Transformation/InitBranchVars.hs index 34089ba4cd..f593b105ab 100644 --- a/test/Reg/Transformation/InitBranchVars.hs +++ b/test/Reg/Transformation/InitBranchVars.hs @@ -18,8 +18,8 @@ liftTest _testRun = fromTest Test { _testTransformations = pipe, - _testAssertion = \tab -> do - unless (checkSSA tab) $ error "check ssa" - unless (checkInitialized tab) $ error "check initialized", + _testAssertion = \md -> do + unless (checkSSA md) $ error "check ssa" + unless (checkInitialized md) $ error "check initialized", _testRun } From 16c16e28994409d5545da25b9a8cf10f12bf1e7b Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Fri, 14 Feb 2025 15:43:12 +0100 Subject: [PATCH 09/24] modular pipeline wip --- src/Juvix/Compiler/Core/Data/Module.hs | 2 + src/Juvix/Compiler/Core/Data/Module/Base.hs | 9 ++++ src/Juvix/Compiler/Pipeline/Modular.hs | 47 +++++++++++++++++-- src/Juvix/Compiler/Pipeline/Modular/Cache.hs | 8 ++++ src/Juvix/Compiler/Pipeline/Modular/Result.hs | 15 ++++++ 5 files changed, 76 insertions(+), 5 deletions(-) create mode 100644 src/Juvix/Compiler/Pipeline/Modular/Cache.hs create mode 100644 src/Juvix/Compiler/Pipeline/Modular/Result.hs diff --git a/src/Juvix/Compiler/Core/Data/Module.hs b/src/Juvix/Compiler/Core/Data/Module.hs index 61b86cd7e5..213c608f74 100644 --- a/src/Juvix/Compiler/Core/Data/Module.hs +++ b/src/Juvix/Compiler/Core/Data/Module.hs @@ -12,6 +12,8 @@ import Juvix.Compiler.Core.Pretty type Module = Module' InfoTable +type ModuleTable = ModuleTable' InfoTable + lookupInductiveInfo' :: Module -> Symbol -> Maybe InductiveInfo lookupInductiveInfo' Module {..} sym = lookupTabInductiveInfo' _moduleInfoTable sym diff --git a/src/Juvix/Compiler/Core/Data/Module/Base.hs b/src/Juvix/Compiler/Core/Data/Module/Base.hs index c2ce2c76c7..eefe8ad256 100644 --- a/src/Juvix/Compiler/Core/Data/Module/Base.hs +++ b/src/Juvix/Compiler/Core/Data/Module/Base.hs @@ -61,3 +61,12 @@ lookupModuleTable mt mid = computeImportsTable :: (Monoid t) => ModuleTable' t -> [ModuleId] -> t computeImportsTable mt = foldMap ((^. moduleImportsTable) . lookupModuleTable mt) + +updateImportsTable :: (Monoid t) => ModuleTable' t -> Module' t -> Module' t +updateImportsTable mt m = + set moduleImportsTable (computeImportsTable mt (m ^. moduleImports)) m + +updateImportsTableM :: (Monoid t, Members '[Reader (ModuleTable' t)] r) => Module' t -> Sem r (Module' t) +updateImportsTableM md = do + mt <- ask + return $ updateImportsTable mt md diff --git a/src/Juvix/Compiler/Pipeline/Modular.hs b/src/Juvix/Compiler/Pipeline/Modular.hs index 5fbfefd0fe..586c94a6af 100644 --- a/src/Juvix/Compiler/Pipeline/Modular.hs +++ b/src/Juvix/Compiler/Pipeline/Modular.hs @@ -1,7 +1,44 @@ module Juvix.Compiler.Pipeline.Modular where -{- -import Juvix.Compiler.Core.Data.Module -import Juvix.Compiler.Store.Backend.Core qualified as Store.Core -import Juvix.Compiler.Store.Language qualified as Store --} +import Data.HashMap.Strict qualified as HashMap +import Juvix.Compiler.Core.Data.Module qualified as Core +import Juvix.Compiler.Core.Data.Module.Base (Module', ModuleTable') +import Juvix.Compiler.Core.Data.TransformationId qualified as Core +import Juvix.Compiler.Pipeline qualified as Pipeline +import Juvix.Compiler.Pipeline.EntryPoint +import Juvix.Compiler.Pipeline.Modular.Cache +import Juvix.Compiler.Pipeline.Modular.Result +import Juvix.Compiler.Tree.Pipeline qualified as Tree +import Juvix.Prelude + +processModule :: + (Members '[Files, Error JuvixError, Reader EntryPoint, ModuleCache t] r) => + ModuleId -> + Sem r (PipelineResult (Module' t)) +processModule = cacheGet + +processModuleCacheMiss :: + forall t r. + (Members '[Files, Error JuvixError, Reader EntryPoint, ModuleCache t] r) => + (ModuleId -> Sem r (Module' t)) -> + ModuleId -> + Sem r (PipelineResult (Module' t)) +processModuleCacheMiss f mid = do + undefined + +processModuleTable :: + forall t t' r. + (Monoid t', Members '[Files, Error JuvixError, Reader EntryPoint] r) => + (Module' t -> Sem r (PipelineResult (Module' t))) -> + ModuleTable' t -> + Sem r (ModuleTable' t') +processModuleTable f mt = do + undefined + +processCoreToTree :: + (Members '[Files, Error JuvixError, Reader EntryPoint] r) => + Core.TransformationId -> + Core.Module -> + Sem r (PipelineResult Tree.Module) +processCoreToTree checkId md = + processModuleCacheMiss (Pipeline.coreToTree checkId) md diff --git a/src/Juvix/Compiler/Pipeline/Modular/Cache.hs b/src/Juvix/Compiler/Pipeline/Modular/Cache.hs new file mode 100644 index 0000000000..a2b19f2f6d --- /dev/null +++ b/src/Juvix/Compiler/Pipeline/Modular/Cache.hs @@ -0,0 +1,8 @@ +module Juvix.Compiler.Pipeline.Modular.Cache where + +import Juvix.Compiler.Pipeline.Modular.Result +import Juvix.Compiler.Store.Backend.Module +import Juvix.Data.Effect.Cache +import Juvix.Data.ModuleId + +type ModuleCache t = Cache ModuleId (PipelineResult (Module' t)) diff --git a/src/Juvix/Compiler/Pipeline/Modular/Result.hs b/src/Juvix/Compiler/Pipeline/Modular/Result.hs new file mode 100644 index 0000000000..1706110803 --- /dev/null +++ b/src/Juvix/Compiler/Pipeline/Modular/Result.hs @@ -0,0 +1,15 @@ +module Juvix.Compiler.Pipeline.Modular.Result where + +import Juvix.Prelude + +data PipelineResult a = PipelineResult + { _pipelineResult :: a, + -- | True if the module had to be recompiled. False if the module was loaded + -- from disk. + _pipelineResultChanged :: Bool + } + deriving stock (Generic) + +makeLenses ''PipelineResult + +instance (NFData a) => NFData (PipelineResult a) From e2ba38bc2287649181c268ce0e272c83424e8c30 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Fri, 14 Feb 2025 18:40:36 +0100 Subject: [PATCH 10/24] wip --- src/Juvix/Compiler/Backend.hs | 12 ++++ src/Juvix/Compiler/Core/Data/Module/Base.hs | 7 +- src/Juvix/Compiler/Pipeline/Modular.hs | 72 ++++++++++++++------ src/Juvix/Compiler/Pipeline/Modular/Cache.hs | 3 +- src/Juvix/Compiler/Store/Backend/Options.hs | 3 + 5 files changed, 71 insertions(+), 26 deletions(-) diff --git a/src/Juvix/Compiler/Backend.hs b/src/Juvix/Compiler/Backend.hs index 27c99cb7f4..b48ca0153b 100644 --- a/src/Juvix/Compiler/Backend.hs +++ b/src/Juvix/Compiler/Backend.hs @@ -154,3 +154,15 @@ getTargetSubdir = \case TargetRust -> $(mkRelDir "rust") TargetAnoma -> $(mkRelDir "anoma") TargetCairo -> $(mkRelDir "cairo") + +getTargetExtension :: Target -> String +getTargetExtension = \case + TargetCWasm32Wasi -> ".c.bin" + TargetCNative64 -> ".c.bin" + TargetCore -> ".core.bin" + TargetAsm -> ".asm.bin" + TargetReg -> ".reg.bin" + TargetTree -> ".tree.bin" + TargetRust -> ".rs.bin" + TargetAnoma -> ".anoma.bin" + TargetCairo -> ".cairo.bin" diff --git a/src/Juvix/Compiler/Core/Data/Module/Base.hs b/src/Juvix/Compiler/Core/Data/Module/Base.hs index eefe8ad256..0743918da5 100644 --- a/src/Juvix/Compiler/Core/Data/Module/Base.hs +++ b/src/Juvix/Compiler/Core/Data/Module/Base.hs @@ -19,7 +19,8 @@ data Module' t = Module -- | The imports table contains all dependencies, transitively. E.g., if the -- module M imports A but not B, but A imports B, then all identifiers from -- B will be in the imports table of M nonetheless. - _moduleImportsTable :: t + _moduleImportsTable :: t, + _moduleSHA256 :: Text } deriving stock (Generic) @@ -44,10 +45,10 @@ withInfoTable f tab = f (moduleFromInfoTable tab) ^. moduleInfoTable emptyModule :: (Monoid t) => ModuleId -> Module' t -emptyModule mid = Module mid mempty mempty mempty +emptyModule mid = Module mid mempty mempty mempty "" moduleFromInfoTable :: (Monoid t) => t -> Module' t -moduleFromInfoTable tab = Module defaultModuleId tab mempty mempty +moduleFromInfoTable tab = Module defaultModuleId tab mempty mempty "" computeCombinedInfoTable :: (Monoid t) => Module' t -> t computeCombinedInfoTable Module {..} = _moduleInfoTable <> _moduleImportsTable diff --git a/src/Juvix/Compiler/Pipeline/Modular.hs b/src/Juvix/Compiler/Pipeline/Modular.hs index 586c94a6af..d0b1880ca5 100644 --- a/src/Juvix/Compiler/Pipeline/Modular.hs +++ b/src/Juvix/Compiler/Pipeline/Modular.hs @@ -1,44 +1,74 @@ module Juvix.Compiler.Pipeline.Modular where -import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Core.Data.Module qualified as Core -import Juvix.Compiler.Core.Data.Module.Base (Module', ModuleTable') +import Juvix.Compiler.Core.Data.Module.Base import Juvix.Compiler.Core.Data.TransformationId qualified as Core import Juvix.Compiler.Pipeline qualified as Pipeline import Juvix.Compiler.Pipeline.EntryPoint import Juvix.Compiler.Pipeline.Modular.Cache import Juvix.Compiler.Pipeline.Modular.Result +import Juvix.Compiler.Store.Backend.Module qualified as Stored import Juvix.Compiler.Tree.Pipeline qualified as Tree +import Juvix.Data.SHA256 qualified as SHA256 +import Juvix.Extra.Serialize qualified as Serialize import Juvix.Prelude +import Path qualified processModule :: - (Members '[Files, Error JuvixError, Reader EntryPoint, ModuleCache t] r) => + (Members '[Files, Error JuvixError, Reader EntryPoint, ModuleCache (Module' t)] r) => ModuleId -> Sem r (PipelineResult (Module' t)) processModule = cacheGet processModuleCacheMiss :: - forall t r. - (Members '[Files, Error JuvixError, Reader EntryPoint, ModuleCache t] r) => - (ModuleId -> Sem r (Module' t)) -> - ModuleId -> - Sem r (PipelineResult (Module' t)) -processModuleCacheMiss f mid = do - undefined - -processModuleTable :: forall t t' r. - (Monoid t', Members '[Files, Error JuvixError, Reader EntryPoint] r) => - (Module' t -> Sem r (PipelineResult (Module' t))) -> + (Serialize t', Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint, ModuleCache (Module' t')] r) => ModuleTable' t -> - Sem r (ModuleTable' t') -processModuleTable f mt = do - undefined + (Module' t -> Sem r (Module' t')) -> + ModuleId -> + Sem r (PipelineResult (Module' t')) +processModuleCacheMiss mt f mid = do + entry <- ask + let root = entry ^. entryPointRoot + opts = Stored.fromEntryPoint entry + buildDir = resolveAbsBuildDir root (entry ^. entryPointBuildDir) + sourcePath = fromJust (entry ^. entryPointModulePath) + relPath = + fromJust + . replaceExtension (Stored.getOptionsExtension opts) + . fromJust + $ stripProperPrefix $(mkAbsDir "/") sourcePath + subdir = Stored.getOptionsSubdir opts + absPath = buildDir Path. subdir Path. relPath + md0 = lookupModuleTable mt mid + sha256 = md0 ^. moduleSHA256 + mmd :: Maybe (Stored.Module' t') <- Serialize.loadFromFile absPath + case mmd of + Just md + | md ^. Stored.moduleSHA256 == sha256 + && md ^. Stored.moduleOptions == opts -> do + pure (PipelineResult (toModule md) False) + _ -> do + md :: Module' t' <- f md0 + let md' = md & moduleSHA256 .~ sha256 + Serialize.saveToFile absPath md + cachePut mid (PipelineResult md) + pure (PipelineResult md) processCoreToTree :: - (Members '[Files, Error JuvixError, Reader EntryPoint] r) => + (Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint, ModuleCache Tree.Module] r) => Core.TransformationId -> - Core.Module -> + Core.ModuleTable -> + ModuleId -> Sem r (PipelineResult Tree.Module) -processCoreToTree checkId md = - processModuleCacheMiss (Pipeline.coreToTree checkId) md +processCoreToTree checkId mt mid = do + processModuleCacheMiss mt (Pipeline.coreToTree checkId) mid + +runModularPipeline :: + forall t t' r. + (Monoid t', Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint] r) => + (Module' t -> Sem r (PipelineResult (Module' t'))) -> + ModuleTable' t -> + Sem r (ModuleTable' t') +runModularPipeline f mt = do + undefined diff --git a/src/Juvix/Compiler/Pipeline/Modular/Cache.hs b/src/Juvix/Compiler/Pipeline/Modular/Cache.hs index a2b19f2f6d..8efa0ec935 100644 --- a/src/Juvix/Compiler/Pipeline/Modular/Cache.hs +++ b/src/Juvix/Compiler/Pipeline/Modular/Cache.hs @@ -1,8 +1,7 @@ module Juvix.Compiler.Pipeline.Modular.Cache where import Juvix.Compiler.Pipeline.Modular.Result -import Juvix.Compiler.Store.Backend.Module import Juvix.Data.Effect.Cache import Juvix.Data.ModuleId -type ModuleCache t = Cache ModuleId (PipelineResult (Module' t)) +type ModuleCache m = Cache ModuleId (PipelineResult m) diff --git a/src/Juvix/Compiler/Store/Backend/Options.hs b/src/Juvix/Compiler/Store/Backend/Options.hs index 865b9e5f8b..a98ea7640f 100644 --- a/src/Juvix/Compiler/Store/Backend/Options.hs +++ b/src/Juvix/Compiler/Store/Backend/Options.hs @@ -38,3 +38,6 @@ getOptionsSubdir opts = if | opts ^. optionsDebug -> $(mkRelDir "debug") | otherwise -> $(mkRelDir "release") + +getOptionsExtension :: Options -> String +getOptionsExtension opts = maybe ".bin" getTargetExtension (opts ^. optionsTarget) From c35134a856b413672b25305ce9171fa435c6e957 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Mon, 17 Feb 2025 10:57:46 +0100 Subject: [PATCH 11/24] Tree module serialization --- src/Juvix/Compiler/Pipeline/Modular.hs | 55 +++++++++++---- src/Juvix/Compiler/Store/Backend/Module.hs | 21 ++++++ .../Compiler/Tree/Data/InfoTable/Base.hs | 12 ++++ src/Juvix/Compiler/Tree/Language.hs | 69 +++++++++++++++++++ src/Juvix/Compiler/Tree/Language/Base.hs | 22 ++++-- src/Juvix/Compiler/Tree/Language/Builtins.hs | 24 +++++-- src/Juvix/Compiler/Tree/Language/Rep.hs | 12 +++- src/Juvix/Compiler/Tree/Language/Type.hs | 22 ++++-- 8 files changed, 206 insertions(+), 31 deletions(-) diff --git a/src/Juvix/Compiler/Pipeline/Modular.hs b/src/Juvix/Compiler/Pipeline/Modular.hs index d0b1880ca5..b3475edf78 100644 --- a/src/Juvix/Compiler/Pipeline/Modular.hs +++ b/src/Juvix/Compiler/Pipeline/Modular.hs @@ -9,7 +9,6 @@ import Juvix.Compiler.Pipeline.Modular.Cache import Juvix.Compiler.Pipeline.Modular.Result import Juvix.Compiler.Store.Backend.Module qualified as Stored import Juvix.Compiler.Tree.Pipeline qualified as Tree -import Juvix.Data.SHA256 qualified as SHA256 import Juvix.Extra.Serialize qualified as Serialize import Juvix.Prelude import Path qualified @@ -22,7 +21,7 @@ processModule = cacheGet processModuleCacheMiss :: forall t t' r. - (Serialize t', Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint, ModuleCache (Module' t')] r) => + (Monoid t', Serialize t', Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint, ModuleCache (Module' t')] r) => ModuleTable' t -> (Module' t -> Sem r (Module' t')) -> ModuleId -> @@ -42,18 +41,48 @@ processModuleCacheMiss mt f mid = do absPath = buildDir Path. subdir Path. relPath md0 = lookupModuleTable mt mid sha256 = md0 ^. moduleSHA256 - mmd :: Maybe (Stored.Module' t') <- Serialize.loadFromFile absPath - case mmd of - Just md - | md ^. Stored.moduleSHA256 == sha256 - && md ^. Stored.moduleOptions == opts -> do - pure (PipelineResult (toModule md) False) - _ -> do + res <- processImports (md0 ^. moduleImports) + let changed = res ^. pipelineResultChanged + imports = res ^. pipelineResult + if + | changed -> + recompile opts absPath imports md0 + | otherwise -> do + mmd :: Maybe (Stored.Module' t') <- Serialize.loadFromFile absPath + case mmd of + Just md + | md ^. Stored.moduleSHA256 == sha256 + && md ^. Stored.moduleOptions == opts -> do + return + PipelineResult + { _pipelineResult = Stored.toCoreModule imports md, + _pipelineResultChanged = False + } + _ -> + recompile opts absPath imports md0 + where + recompile :: Stored.Options -> Path Abs File -> [Module' t'] -> Module' t -> Sem r (PipelineResult (Module' t')) + recompile opts absPath imports md0 = do md :: Module' t' <- f md0 - let md' = md & moduleSHA256 .~ sha256 - Serialize.saveToFile absPath md - cachePut mid (PipelineResult md) - pure (PipelineResult md) + let md' = md {_moduleImportsTable = mconcatMap computeCombinedInfoTable imports} + Serialize.saveToFile absPath (Stored.fromCoreModule opts md') + return + PipelineResult + { _pipelineResult = md', + _pipelineResultChanged = True + } + +processImports :: + (Members '[Files, Error JuvixError, Reader EntryPoint, ModuleCache (Module' t)] r) => + [ModuleId] -> + Sem r (PipelineResult [Module' t]) +processImports mids = do + res <- mapM processModule mids + return + PipelineResult + { _pipelineResult = map (^. pipelineResult) res, + _pipelineResultChanged = any (^. pipelineResultChanged) res + } processCoreToTree :: (Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint, ModuleCache Tree.Module] r) => diff --git a/src/Juvix/Compiler/Store/Backend/Module.hs b/src/Juvix/Compiler/Store/Backend/Module.hs index 5b7a8aa122..b9dcac1781 100644 --- a/src/Juvix/Compiler/Store/Backend/Module.hs +++ b/src/Juvix/Compiler/Store/Backend/Module.hs @@ -5,6 +5,7 @@ module Juvix.Compiler.Store.Backend.Module where import Data.HashMap.Strict qualified as HashMap +import Juvix.Compiler.Core.Data.Module.Base qualified as Core import Juvix.Compiler.Store.Backend.Options import Juvix.Data.ModuleId import Juvix.Data.PPOutput (prettyText) @@ -44,3 +45,23 @@ lookupModuleTable' mt mid = HashMap.lookup mid (mt ^. moduleTable) lookupModuleTable :: ModuleTable' t -> ModuleId -> Module' t lookupModuleTable mt mid = fromMaybe (impossibleError ("Could not find module " <> prettyText mid)) (lookupModuleTable' mt mid) + +toCoreModule :: (Monoid t) => [Core.Module' t] -> Module' t -> Core.Module' t +toCoreModule imports Module {..} = + Core.Module + { _moduleId = _moduleId, + _moduleInfoTable = _moduleInfoTable, + _moduleImports = _moduleImports, + _moduleImportsTable = mconcatMap Core.computeCombinedInfoTable imports, + _moduleSHA256 = _moduleSHA256 + } + +fromCoreModule :: Options -> Core.Module' t -> Module' t +fromCoreModule opts Core.Module {..} = + Module + { _moduleId = _moduleId, + _moduleInfoTable = _moduleInfoTable, + _moduleImports = _moduleImports, + _moduleOptions = opts, + _moduleSHA256 = _moduleSHA256 + } diff --git a/src/Juvix/Compiler/Tree/Data/InfoTable/Base.hs b/src/Juvix/Compiler/Tree/Data/InfoTable/Base.hs index 082cd33f69..d1ef6a9de2 100644 --- a/src/Juvix/Compiler/Tree/Data/InfoTable/Base.hs +++ b/src/Juvix/Compiler/Tree/Data/InfoTable/Base.hs @@ -16,6 +16,7 @@ data InfoTable' code extra = InfoTable _infoInductives :: HashMap Symbol InductiveInfo, _infoMainFunction :: Maybe Symbol } + deriving stock (Generic) data FunctionInfo' code extra = FunctionInfo { _functionName :: Text, @@ -31,6 +32,7 @@ data FunctionInfo' code extra = FunctionInfo _functionExtra :: extra, _functionCode :: code } + deriving stock (Generic) data ConstructorInfo = ConstructorInfo { _constructorName :: Text, @@ -49,6 +51,7 @@ data ConstructorInfo = ConstructorInfo _constructorRepresentation :: MemRep, _constructorFixity :: Maybe Fixity } + deriving stock (Generic) data InductiveInfo = InductiveInfo { _inductiveName :: Text, @@ -58,6 +61,15 @@ data InductiveInfo = InductiveInfo _inductiveConstructors :: [Tag], _inductiveRepresentation :: IndRep } + deriving stock (Generic) + +instance (Serialize code, Serialize extra) => Serialize (FunctionInfo' code extra) + +instance Serialize ConstructorInfo + +instance Serialize InductiveInfo + +instance (Serialize code, Serialize extra) => Serialize (InfoTable' code extra) makeLenses ''InfoTable' makeLenses ''FunctionInfo' diff --git a/src/Juvix/Compiler/Tree/Language.hs b/src/Juvix/Compiler/Tree/Language.hs index a783fed046..f5417b8242 100644 --- a/src/Juvix/Compiler/Tree/Language.hs +++ b/src/Juvix/Compiler/Tree/Language.hs @@ -14,6 +14,9 @@ import Juvix.Compiler.Tree.Language.Type data CallType = CallFun Symbol | CallClosure Node + deriving stock (Generic) + +instance Serialize CallType data Node = Binop NodeBinop @@ -53,17 +56,26 @@ data Node -- Used to implement Core.Let. JVT codes: 'save(x) {}', -- 'save[](x) {}'. Save NodeSave + deriving stock (Generic) + +instance Serialize Node newtype NodeInfo = NodeInfo { _nodeInfoLocation :: Maybe Location } deriving newtype (Semigroup, Monoid) + deriving stock (Generic) + +instance Serialize NodeInfo data BinaryOpcode = PrimBinop BinaryOp | -- | Sequence: evaluate and ignore fist argument, return evaluated second -- argument. JVT code: 'seq(x1, x2)'. OpSeq + deriving stock (Generic) + +instance Serialize BinaryOpcode data TreeOp = TreeBinaryOpcode BinaryOpcode @@ -71,6 +83,9 @@ data TreeOp | TreeByteArrayOp ByteArrayOp | TreeCairoOp CairoOp | TreeAnomaOp AnomaOp + deriving stock (Generic) + +instance Serialize TreeOp data UnaryOpcode = PrimUnop UnaryOp @@ -80,6 +95,9 @@ data UnaryOpcode OpTrace | -- | Interrupt execution with a runtime error printing the argument. OpFail + deriving stock (Generic) + +instance Serialize UnaryOpcode data NodeBinop = NodeBinop { _nodeBinopInfo :: NodeInfo, @@ -87,58 +105,88 @@ data NodeBinop = NodeBinop _nodeBinopArg1 :: Node, _nodeBinopArg2 :: Node } + deriving stock (Generic) + +instance Serialize NodeBinop data NodeUnop = NodeUnop { _nodeUnopInfo :: NodeInfo, _nodeUnopOpcode :: UnaryOpcode, _nodeUnopArg :: Node } + deriving stock (Generic) + +instance Serialize NodeUnop data NodeByteArray = NodeByteArray { _nodeByteArrayInfo :: NodeInfo, _nodeByteArrayOpcode :: ByteArrayOp, _nodeByteArrayArgs :: [Node] } + deriving stock (Generic) + +instance Serialize NodeByteArray data NodeCairo = NodeCairo { _nodeCairoInfo :: NodeInfo, _nodeCairoOpcode :: CairoOp, _nodeCairoArgs :: [Node] } + deriving stock (Generic) + +instance Serialize NodeCairo data NodeAnoma = NodeAnoma { _nodeAnomaInfo :: NodeInfo, _nodeAnomaOpcode :: AnomaOp, _nodeAnomaArgs :: [Node] } + deriving stock (Generic) + +instance Serialize NodeAnoma data NodeConstant = NodeConstant { _nodeConstantInfo :: NodeInfo, _nodeConstant :: Constant } + deriving stock (Generic) + +instance Serialize NodeConstant data NodeMemRef = NodeMemRef { _nodeMemRefInfo :: NodeInfo, _nodeMemRef :: MemRef } + deriving stock (Generic) + +instance Serialize NodeMemRef data NodeAllocConstr = NodeAllocConstr { _nodeAllocConstrInfo :: NodeInfo, _nodeAllocConstrTag :: Tag, _nodeAllocConstrArgs :: [Node] } + deriving stock (Generic) + +instance Serialize NodeAllocConstr data NodeAllocClosure = NodeAllocClosure { _nodeAllocClosureInfo :: NodeInfo, _nodeAllocClosureFunSymbol :: Symbol, _nodeAllocClosureArgs :: [Node] } + deriving stock (Generic) + +instance Serialize NodeAllocClosure data NodeExtendClosure = NodeExtendClosure { _nodeExtendClosureInfo :: NodeInfo, _nodeExtendClosureFun :: Node, _nodeExtendClosureArgs :: NonEmpty Node } + deriving stock (Generic) + +instance Serialize NodeExtendClosure -- | If _nodeCallType is 'CallClosure', then _nodeCallArgs must be non-empty. data NodeCall = NodeCall @@ -146,12 +194,18 @@ data NodeCall = NodeCall _nodeCallType :: CallType, _nodeCallArgs :: [Node] } + deriving stock (Generic) + +instance Serialize NodeCall data NodeCallClosures = NodeCallClosures { _nodeCallClosuresInfo :: NodeInfo, _nodeCallClosuresFun :: Node, _nodeCallClosuresArgs :: NonEmpty Node } + deriving stock (Generic) + +instance Serialize NodeCallClosures data NodeBranch = NodeBranch { _nodeBranchInfo :: NodeInfo, @@ -159,6 +213,9 @@ data NodeBranch = NodeBranch _nodeBranchTrue :: Node, _nodeBranchFalse :: Node } + deriving stock (Generic) + +instance Serialize NodeBranch data NodeCase = NodeCase { _nodeCaseInfo :: NodeInfo, @@ -167,6 +224,9 @@ data NodeCase = NodeCase _nodeCaseBranches :: [CaseBranch], _nodeCaseDefault :: Maybe Node } + deriving stock (Generic) + +instance Serialize NodeCase data CaseBranch = CaseBranch { _caseBranchLocation :: Maybe Location, @@ -176,12 +236,18 @@ data CaseBranch = CaseBranch -- temporary stack in this branch. _caseBranchSave :: Bool } + deriving stock (Generic) + +instance Serialize CaseBranch data TempVar = TempVar { _tempVarName :: Maybe Text, _tempVarLocation :: Maybe Location, _tempVarType :: Type } + deriving stock (Generic) + +instance Serialize TempVar data NodeSave = NodeSave { _nodeSaveInfo :: NodeInfo, @@ -189,6 +255,9 @@ data NodeSave = NodeSave _nodeSaveArg :: Node, _nodeSaveBody :: Node } + deriving stock (Generic) + +instance Serialize NodeSave makeLenses ''NodeBinop makeLenses ''NodeUnop diff --git a/src/Juvix/Compiler/Tree/Language/Base.hs b/src/Juvix/Compiler/Tree/Language/Base.hs index 8ed0586f1e..2be6124b3e 100644 --- a/src/Juvix/Compiler/Tree/Language/Base.hs +++ b/src/Juvix/Compiler/Tree/Language/Base.hs @@ -24,6 +24,8 @@ data Constant instance (Hashable Constant) +instance Serialize Constant + -- | MemRefs are references to values stored in memory. data MemRef = -- | A direct memory reference. @@ -31,13 +33,17 @@ data MemRef | -- | ConstrRef is an indirect reference to a field (argument) of -- a constructor: field k holds the (k+1)th argument. ConstrRef Field - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance Serialize MemRef data OffsetRef = OffsetRef { _offsetRefOffset :: Offset, _offsetRefName :: Maybe Text } - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance Serialize OffsetRef -- | DirectRef is a direct memory reference. data DirectRef @@ -48,7 +54,9 @@ data DirectRef -- counted from the _bottom_ of the temporary stack). JVT/JVA code: -- 'tmp[]'. TempRef RefTemp - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance Serialize DirectRef mkTempRef :: OffsetRef -> DirectRef mkTempRef o = TempRef (RefTemp o) @@ -56,7 +64,9 @@ mkTempRef o = TempRef (RefTemp o) newtype RefTemp = RefTemp { _refTempOffsetRef :: OffsetRef } - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance Serialize RefTemp -- | Constructor field reference. JVT/JVA code: '.[]' data Field = Field @@ -67,7 +77,9 @@ data Field = Field _fieldRef :: DirectRef, _fieldOffset :: Offset } - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance Serialize Field makeLenses ''Field makeLenses ''OffsetRef diff --git a/src/Juvix/Compiler/Tree/Language/Builtins.hs b/src/Juvix/Compiler/Tree/Language/Builtins.hs index 2e944d619f..51d1b8208c 100644 --- a/src/Juvix/Compiler/Tree/Language/Builtins.hs +++ b/src/Juvix/Compiler/Tree/Language/Builtins.hs @@ -6,7 +6,9 @@ data BoolOp = OpIntLt | OpIntLe | OpEq - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance Serialize BoolOp data BinaryOp = OpBool BoolOp @@ -20,7 +22,9 @@ data BinaryOp | OpFieldMul | OpFieldDiv | OpStrConcat - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance Serialize BinaryOp isCommutative :: BinaryOp -> Bool isCommutative = \case @@ -54,7 +58,9 @@ data UnaryOp | -- | Compute the number of expected arguments for the given closure. JV* -- opcode: `argsnum`. OpArgsNum - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance Serialize UnaryOp -- | Builtin Cairo operations. Implemented only in the Cairo backend. data CairoOp @@ -64,7 +70,9 @@ data CairoOp OpCairoEc | -- | Cairo random elliptic curve point generation. OpCairoRandomEcPoint - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance Serialize CairoOp -- | Builtin ByteArray operations data ByteArrayOp @@ -72,7 +80,9 @@ data ByteArrayOp OpByteArrayFromListUInt8 | -- | Get the size of a ByteArray OpByteArrayLength - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance Serialize ByteArrayOp cairoOpArgsNum :: CairoOp -> Int cairoOpArgsNum = \case @@ -136,4 +146,6 @@ data AnomaOp OpAnomaIsNullifier | OpAnomaSetToList | OpAnomaSetFromList - deriving stock (Eq, Show) + deriving stock (Eq, Show, Generic) + +instance Serialize AnomaOp diff --git a/src/Juvix/Compiler/Tree/Language/Rep.hs b/src/Juvix/Compiler/Tree/Language/Rep.hs index 44b879a663..7a143966e2 100644 --- a/src/Juvix/Compiler/Tree/Language/Rep.hs +++ b/src/Juvix/Compiler/Tree/Language/Rep.hs @@ -25,7 +25,7 @@ data MemRep -- representing constructors of different inductive types because they have -- no tag). The argument is the representation of the wrapped value. MemRepUnpacked ValRep - deriving stock (Eq) + deriving stock (Eq, Generic) -- | Representation of values. data ValRep @@ -39,7 +39,7 @@ data ValRep ValRepWord | -- | Constructor of an inductive type with a given representation. ValRepInd IndRep - deriving stock (Eq) + deriving stock (Eq, Generic) -- | Representation of an inductive type. data IndRep @@ -68,4 +68,10 @@ data IndRep | -- | The constructors can have any representation as long as there is no -- ambiguity arising from unpacking. IndRepMixed - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance Serialize MemRep + +instance Serialize ValRep + +instance Serialize IndRep diff --git a/src/Juvix/Compiler/Tree/Language/Type.hs b/src/Juvix/Compiler/Tree/Language/Type.hs index 5be9777c6d..3c8c1292ab 100644 --- a/src/Juvix/Compiler/Tree/Language/Type.hs +++ b/src/Juvix/Compiler/Tree/Language/Type.hs @@ -17,18 +17,19 @@ data Type -- of an appropriate TyInductive. TyConstr TypeConstr | TyFun TypeFun - deriving stock (Eq) + deriving stock (Eq, Generic) data TypeInteger = TypeInteger { _typeIntegerMinValue :: Maybe Integer, _typeIntegerMaxValue :: Maybe Integer } - deriving stock (Eq) + deriving stock (Eq, Generic) data TypeBool = TypeBool { _typeBoolTrueTag :: Tag, _typeBoolFalseTag :: Tag } + deriving stock (Generic) instance Eq TypeBool where _ == _ = True @@ -36,13 +37,14 @@ instance Eq TypeBool where newtype TypeInductive = TypeInductive { _typeInductiveSymbol :: Symbol } - deriving stock (Eq) + deriving stock (Eq, Generic) data TypeConstr = TypeConstr { _typeConstrInductive :: Symbol, _typeConstrTag :: Tag, _typeConstrFields :: [Type] } + deriving stock (Generic) instance Eq TypeConstr where (TypeConstr _ tag1 _) == (TypeConstr _ tag2 _) = tag1 == tag2 @@ -51,7 +53,19 @@ data TypeFun = TypeFun { _typeFunArgs :: NonEmpty Type, _typeFunTarget :: Type } - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance Serialize TypeInteger + +instance Serialize TypeBool + +instance Serialize TypeInductive + +instance Serialize TypeConstr + +instance Serialize TypeFun + +instance Serialize Type makeLenses ''TypeInteger makeLenses ''TypeBool From 92bf54f2f91338c2976b606c94454664af33d1cf Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Mon, 17 Feb 2025 12:41:07 +0100 Subject: [PATCH 12/24] modular pipeline --- src/Juvix/Compiler/Pipeline/Modular.hs | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/src/Juvix/Compiler/Pipeline/Modular.hs b/src/Juvix/Compiler/Pipeline/Modular.hs index b3475edf78..fb30e3ce2c 100644 --- a/src/Juvix/Compiler/Pipeline/Modular.hs +++ b/src/Juvix/Compiler/Pipeline/Modular.hs @@ -21,7 +21,10 @@ processModule = cacheGet processModuleCacheMiss :: forall t t' r. - (Monoid t', Serialize t', Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint, ModuleCache (Module' t')] r) => + ( Monoid t', + Serialize t', + Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint, ModuleCache (Module' t')] r + ) => ModuleTable' t -> (Module' t -> Sem r (Module' t')) -> ModuleId -> @@ -95,9 +98,21 @@ processCoreToTree checkId mt mid = do runModularPipeline :: forall t t' r. - (Monoid t', Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint] r) => - (Module' t -> Sem r (PipelineResult (Module' t'))) -> + (Serialize t', Monoid t', Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint] r) => + (forall r'. (Members '[Error JuvixError, Reader EntryPoint] r') => Module' t -> Sem r' (Module' t')) -> ModuleTable' t -> Sem r (ModuleTable' t') runModularPipeline f mt = do - undefined + tab <- + evalCacheEmpty + (processModuleCacheMiss mt f) + $ mapM (fmap (^. pipelineResult) . processModule . (^. moduleId)) (mt ^. moduleTable) + return $ ModuleTable tab + +runModularCoreToTree :: + (Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint] r) => + Core.TransformationId -> + Core.ModuleTable -> + Sem r Tree.ModuleTable +runModularCoreToTree checkId mt = + runModularPipeline (Pipeline.coreToTree checkId) mt From 65e864d9364f588480f0f2c7304d4412e023075d Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Mon, 17 Feb 2025 13:13:59 +0100 Subject: [PATCH 13/24] fix compilation --- src/Juvix/Compiler/Asm/Translation/FromTree.hs | 3 ++- src/Juvix/Compiler/Core/Data/Stripped/Module.hs | 3 ++- src/Juvix/Compiler/Core/Translation/FromInternal.hs | 3 ++- src/Juvix/Compiler/Core/Translation/FromSource.hs | 2 +- src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs | 4 +++- src/Juvix/Compiler/Reg/Translation/Blocks/FromReg.hs | 3 ++- src/Juvix/Compiler/Reg/Translation/FromAsm.hs | 3 ++- src/Juvix/Compiler/Tree/Translation/FromAsm.hs | 3 ++- src/Juvix/Compiler/Tree/Translation/FromCore.hs | 3 ++- 9 files changed, 18 insertions(+), 9 deletions(-) diff --git a/src/Juvix/Compiler/Asm/Translation/FromTree.hs b/src/Juvix/Compiler/Asm/Translation/FromTree.hs index 40be3346bb..d12a3762d0 100644 --- a/src/Juvix/Compiler/Asm/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Asm/Translation/FromTree.hs @@ -16,7 +16,8 @@ fromTree md = { _moduleId = md ^. moduleId, _moduleInfoTable = tab', _moduleImports = md ^. moduleImports, - _moduleImportsTable = mempty + _moduleImportsTable = mempty, + _moduleSHA256 = md ^. moduleSHA256 } where tab = computeCombinedInfoTable md diff --git a/src/Juvix/Compiler/Core/Data/Stripped/Module.hs b/src/Juvix/Compiler/Core/Data/Stripped/Module.hs index 5455148787..a554fade05 100644 --- a/src/Juvix/Compiler/Core/Data/Stripped/Module.hs +++ b/src/Juvix/Compiler/Core/Data/Stripped/Module.hs @@ -13,6 +13,7 @@ data Module = Module _moduleInfoTable :: InfoTable, -- | The imports field contains all direct (non-transitive) dependencies of -- the module. - _moduleImports :: [ModuleId] + _moduleImports :: [ModuleId], + _moduleSHA256 :: Text } deriving stock (Generic) diff --git a/src/Juvix/Compiler/Core/Translation/FromInternal.hs b/src/Juvix/Compiler/Core/Translation/FromInternal.hs index 2ed1a277a9..6762fff461 100644 --- a/src/Juvix/Compiler/Core/Translation/FromInternal.hs +++ b/src/Juvix/Compiler/Core/Translation/FromInternal.hs @@ -76,7 +76,8 @@ fromInternal i = mapError (JuvixError . ErrBadScope) $ do { _moduleId = imd ^. Internal.internalModuleId, _moduleInfoTable = mempty, _moduleImports = imd ^. Internal.internalModuleImports, - _moduleImportsTable = coreImportsTab + _moduleImportsTable = coreImportsTab, + _moduleSHA256 = "" } tabs = i ^. InternalTyped.resultTypeCheckingTables res <- diff --git a/src/Juvix/Compiler/Core/Translation/FromSource.hs b/src/Juvix/Compiler/Core/Translation/FromSource.hs index d71158475f..5811b1fe1b 100644 --- a/src/Juvix/Compiler/Core/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Core/Translation/FromSource.hs @@ -33,7 +33,7 @@ runParser :: Path Abs File -> ModuleId -> InfoTable -> Text -> Either JuvixError runParser fileName mid tab input_ = case run $ runError @CoreError $ - runInfoTableBuilder (Module mid tab mempty mempty) $ + runInfoTableBuilder (Module mid tab mempty mempty "") $ P.runParserT parseToplevel (fromAbsFile fileName) input_ of Left err -> Left (JuvixError err) Right (_, Left err) -> Left (JuvixError (MegaparsecError err)) diff --git a/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs b/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs index 30a5709238..533a550b03 100644 --- a/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs +++ b/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs @@ -13,8 +13,10 @@ fromCore :: Module -> Stripped.Module fromCore Module {..} = Stripped.Module { _moduleId = _moduleId, + -- TODO: don't combine info tables _moduleInfoTable = fromCore' (_moduleInfoTable <> _moduleImportsTable), - _moduleImports = _moduleImports + _moduleImports = _moduleImports, + _moduleSHA256 = _moduleSHA256 } fromCore' :: InfoTable -> Stripped.InfoTable diff --git a/src/Juvix/Compiler/Reg/Translation/Blocks/FromReg.hs b/src/Juvix/Compiler/Reg/Translation/Blocks/FromReg.hs index 944eaac8dc..69d9551ce1 100644 --- a/src/Juvix/Compiler/Reg/Translation/Blocks/FromReg.hs +++ b/src/Juvix/Compiler/Reg/Translation/Blocks/FromReg.hs @@ -11,7 +11,8 @@ fromReg md = { _moduleId = md ^. moduleId, _moduleInfoTable = tab, _moduleImports = md ^. moduleImports, - _moduleImportsTable = mempty + _moduleImportsTable = mempty, + _moduleSHA256 = md ^. moduleSHA256 } where tab = over infoFunctions (fmap (over functionCode goCode)) (computeCombinedInfoTable md) diff --git a/src/Juvix/Compiler/Reg/Translation/FromAsm.hs b/src/Juvix/Compiler/Reg/Translation/FromAsm.hs index c6a79436fe..0c73c43f3d 100644 --- a/src/Juvix/Compiler/Reg/Translation/FromAsm.hs +++ b/src/Juvix/Compiler/Reg/Translation/FromAsm.hs @@ -14,7 +14,8 @@ fromAsm md = { _moduleId = md ^. moduleId, _moduleInfoTable = tab, _moduleImports = md ^. moduleImports, - _moduleImportsTable = mempty + _moduleImportsTable = mempty, + _moduleSHA256 = md ^. moduleSHA256 } where tab0 :: Asm.InfoTable diff --git a/src/Juvix/Compiler/Tree/Translation/FromAsm.hs b/src/Juvix/Compiler/Tree/Translation/FromAsm.hs index efa197312e..57cf415283 100644 --- a/src/Juvix/Compiler/Tree/Translation/FromAsm.hs +++ b/src/Juvix/Compiler/Tree/Translation/FromAsm.hs @@ -30,7 +30,8 @@ fromAsm md = do { _moduleId = md ^. moduleId, _moduleInfoTable = tab, _moduleImports = md ^. moduleImports, - _moduleImportsTable = mempty + _moduleImportsTable = mempty, + _moduleSHA256 = md ^. moduleSHA256 } goFunction :: (Member (Error TreeError) r') => Asm.Module -> Asm.FunctionInfo -> Sem r' FunctionInfo diff --git a/src/Juvix/Compiler/Tree/Translation/FromCore.hs b/src/Juvix/Compiler/Tree/Translation/FromCore.hs index c4509f0094..939d89dead 100644 --- a/src/Juvix/Compiler/Tree/Translation/FromCore.hs +++ b/src/Juvix/Compiler/Tree/Translation/FromCore.hs @@ -17,7 +17,8 @@ fromCore Core.Module {..} = { _moduleId = _moduleId, _moduleInfoTable = fromCore' _moduleInfoTable, _moduleImports = _moduleImports, - _moduleImportsTable = mempty + _moduleImportsTable = mempty, + _moduleSHA256 = _moduleSHA256 } fromCore' :: Core.InfoTable -> InfoTable From c61c7737823682ad025f91d509fbe969cf452499 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Tue, 18 Feb 2025 11:48:48 +0100 Subject: [PATCH 14/24] move sha256 computation --- app/App.hs | 7 +++++- src/Juvix/Compiler/Core/Data/Module/Base.hs | 6 ++--- .../Compiler/Core/Data/Stripped/Module.hs | 2 +- .../Compiler/Core/Data/TransformationId.hs | 2 +- .../Compiler/Core/Translation/FromInternal.hs | 5 ++-- .../Compiler/Core/Translation/FromSource.hs | 2 +- src/Juvix/Compiler/Pipeline.hs | 4 +++- src/Juvix/Compiler/Pipeline/Driver.hs | 24 +++++++++---------- src/Juvix/Compiler/Pipeline/DriverParallel.hs | 2 +- src/Juvix/Compiler/Pipeline/EntryPoint.hs | 6 +++-- src/Juvix/Compiler/Pipeline/Modular.hs | 17 ++++--------- .../Compiler/Pipeline/ModuleInfoCache.hs | 9 ++++--- src/Juvix/Compiler/Store/Backend/Module.hs | 4 ++-- 13 files changed, 46 insertions(+), 44 deletions(-) diff --git a/app/App.hs b/app/App.hs index d78cc066d2..0372bf7924 100644 --- a/app/App.hs +++ b/app/App.hs @@ -10,6 +10,7 @@ import Juvix.Compiler.Pipeline.Loader.PathResolver import Juvix.Compiler.Pipeline.Root import Juvix.Compiler.Pipeline.Run import Juvix.Data.Error qualified as Error +import Juvix.Data.SHA256 qualified as SHA256 import Juvix.Extra.Paths.Base hiding (rootBuildDir) import Juvix.Parser.Error import System.Console.ANSI qualified as Ansi @@ -170,7 +171,11 @@ getEntryPoint' RunAppIOArgs {..} inputFile = do | opts ^. globalStdin -> Just <$> liftIO getContents | otherwise -> return Nothing mainFile <- getMainAppFileMaybe inputFile - set entryPointStdin estdin <$> entryPointFromGlobalOptionsPre root ((^. pathPath) <$> mainFile) opts + mainFile' <- maybe (return Nothing) (fmap Just . fromAppFile) mainFile + sha256 <- maybe (return Nothing) (fmap Just . runFilesIO . SHA256.digestFile) mainFile' + set entryPointSHA256 sha256 + . set entryPointStdin estdin + <$> entryPointFromGlobalOptionsPre root ((^. pathPath) <$> mainFile) opts runPipelineEither :: (Members '[EmbedIO, TaggedLock, Logger, App] r, EntryPointOptions opts) => diff --git a/src/Juvix/Compiler/Core/Data/Module/Base.hs b/src/Juvix/Compiler/Core/Data/Module/Base.hs index 0743918da5..53ee4df1cd 100644 --- a/src/Juvix/Compiler/Core/Data/Module/Base.hs +++ b/src/Juvix/Compiler/Core/Data/Module/Base.hs @@ -20,7 +20,7 @@ data Module' t = Module -- module M imports A but not B, but A imports B, then all identifiers from -- B will be in the imports table of M nonetheless. _moduleImportsTable :: t, - _moduleSHA256 :: Text + _moduleSHA256 :: Maybe Text } deriving stock (Generic) @@ -45,10 +45,10 @@ withInfoTable f tab = f (moduleFromInfoTable tab) ^. moduleInfoTable emptyModule :: (Monoid t) => ModuleId -> Module' t -emptyModule mid = Module mid mempty mempty mempty "" +emptyModule mid = Module mid mempty mempty mempty Nothing moduleFromInfoTable :: (Monoid t) => t -> Module' t -moduleFromInfoTable tab = Module defaultModuleId tab mempty mempty "" +moduleFromInfoTable tab = Module defaultModuleId tab mempty mempty Nothing computeCombinedInfoTable :: (Monoid t) => Module' t -> t computeCombinedInfoTable Module {..} = _moduleInfoTable <> _moduleImportsTable diff --git a/src/Juvix/Compiler/Core/Data/Stripped/Module.hs b/src/Juvix/Compiler/Core/Data/Stripped/Module.hs index a554fade05..51cb1224c7 100644 --- a/src/Juvix/Compiler/Core/Data/Stripped/Module.hs +++ b/src/Juvix/Compiler/Core/Data/Stripped/Module.hs @@ -14,6 +14,6 @@ data Module = Module -- | The imports field contains all direct (non-transitive) dependencies of -- the module. _moduleImports :: [ModuleId], - _moduleSHA256 :: Text + _moduleSHA256 :: Maybe Text } deriving stock (Generic) diff --git a/src/Juvix/Compiler/Core/Data/TransformationId.hs b/src/Juvix/Compiler/Core/Data/TransformationId.hs index f1e523921a..8f6ebac1cb 100644 --- a/src/Juvix/Compiler/Core/Data/TransformationId.hs +++ b/src/Juvix/Compiler/Core/Data/TransformationId.hs @@ -82,7 +82,7 @@ toNormalizeTransformations = toStrippedTransformations :: TransformationId -> [TransformationId] toStrippedTransformations checkId = - [CombineInfoTables, FilterUnreachable, checkId, RemoveTypeArgs, DisambiguateNames] + [FilterUnreachable, checkId, RemoveTypeArgs, DisambiguateNames] instance TransformationId' TransformationId where transformationText :: TransformationId -> Text diff --git a/src/Juvix/Compiler/Core/Translation/FromInternal.hs b/src/Juvix/Compiler/Core/Translation/FromInternal.hs index 6762fff461..798aac39f3 100644 --- a/src/Juvix/Compiler/Core/Translation/FromInternal.hs +++ b/src/Juvix/Compiler/Core/Translation/FromInternal.hs @@ -65,9 +65,10 @@ computeImplicitArgs = \case fromInternal :: (Members '[NameIdGen, Reader Store.ModuleTable, Error JuvixError] k) => + Maybe Text -> InternalTyped.InternalTypedResult -> Sem k CoreResult -fromInternal i = mapError (JuvixError . ErrBadScope) $ do +fromInternal sha256 i = mapError (JuvixError . ErrBadScope) $ do importTab <- asks Store.getInternalModuleTable coreImportsTab <- asks Store.computeCombinedCoreInfoTable let imd = i ^. InternalTyped.resultInternalModule @@ -77,7 +78,7 @@ fromInternal i = mapError (JuvixError . ErrBadScope) $ do _moduleInfoTable = mempty, _moduleImports = imd ^. Internal.internalModuleImports, _moduleImportsTable = coreImportsTab, - _moduleSHA256 = "" + _moduleSHA256 = sha256 } tabs = i ^. InternalTyped.resultTypeCheckingTables res <- diff --git a/src/Juvix/Compiler/Core/Translation/FromSource.hs b/src/Juvix/Compiler/Core/Translation/FromSource.hs index 5811b1fe1b..d77918268e 100644 --- a/src/Juvix/Compiler/Core/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Core/Translation/FromSource.hs @@ -33,7 +33,7 @@ runParser :: Path Abs File -> ModuleId -> InfoTable -> Text -> Either JuvixError runParser fileName mid tab input_ = case run $ runError @CoreError $ - runInfoTableBuilder (Module mid tab mempty mempty "") $ + runInfoTableBuilder (Module mid tab mempty mempty Nothing) $ P.runParserT parseToplevel (fromAbsFile fileName) input_ of Left err -> Left (JuvixError err) Right (_, Left err) -> Left (JuvixError (MegaparsecError err)) diff --git a/src/Juvix/Compiler/Pipeline.hs b/src/Juvix/Compiler/Pipeline.hs index 474acb8b11..6cc1f32f53 100644 --- a/src/Juvix/Compiler/Pipeline.hs +++ b/src/Juvix/Compiler/Pipeline.hs @@ -143,7 +143,9 @@ upToIsabelle = upToInternalTyped >>= Isabelle.fromInternal upToCore :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError] r) => Sem r Core.CoreResult -upToCore = upToInternalTyped >>= Core.fromInternal +upToCore = do + sha256 <- asks (^. entryPointSHA256) + upToInternalTyped >>= Core.fromInternal sha256 upToStoredCore :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError] r) => diff --git a/src/Juvix/Compiler/Pipeline/Driver.hs b/src/Juvix/Compiler/Pipeline/Driver.hs index a147e92002..61e5e997cd 100644 --- a/src/Juvix/Compiler/Pipeline/Driver.hs +++ b/src/Juvix/Compiler/Pipeline/Driver.hs @@ -55,7 +55,6 @@ import Juvix.Compiler.Store.Options qualified as StoredOptions import Juvix.Compiler.Store.Scoped.Language (ScopedModuleTable) import Juvix.Compiler.Store.Scoped.Language qualified as Scoped import Juvix.Data.CodeAnn -import Juvix.Data.SHA256 qualified as SHA256 import Juvix.Extra.Serialize qualified as Serialize import Juvix.Prelude import Parallel.ProgressLog @@ -114,7 +113,8 @@ evalModuleInfoCachePackageDotJuvix = compileSequentially :: forall r. ( Members - '[ ModuleInfoCache, + '[ Files, + ModuleInfoCache, Reader EntryPoint, PathResolver, Reader ImportTree @@ -208,7 +208,10 @@ processModuleCacheMissDecide :: EntryIndex -> Sem r (ProcessModuleDecision rrecompile) processModuleCacheMissDecide entryIx = do - let buildDir = resolveAbsBuildDir root (entry ^. entryPointBuildDir) + let entry = entryIx ^. entryIxEntry + root = entry ^. entryPointRoot + opts = StoredModule.fromEntryPoint entry + buildDir = resolveAbsBuildDir root (entry ^. entryPointBuildDir) sourcePath = fromJust (entry ^. entryPointModulePath) relPath = fromJust @@ -217,11 +220,11 @@ processModuleCacheMissDecide entryIx = do $ stripProperPrefix $(mkAbsDir "/") sourcePath subdir = StoredOptions.getOptionsSubdir opts absPath = buildDir Path. subdir Path. relPath - sha256 <- SHA256.digestFile sourcePath + sha256 = fromJust (entry ^. entryPointSHA256) let recompile :: Sem rrecompile (PipelineResult Store.ModuleInfo) recompile = do - res <- processModuleToStoredCore sha256 entry + res <- processModuleToStoredCore entry Serialize.saveToFile absPath (res ^. pipelineResult) return res @@ -249,10 +252,6 @@ processModuleCacheMissDecide entryIx = do _pipelineResultImports = _compileResultModuleTable, _pipelineResultChanged = False } - where - entry = entryIx ^. entryIxEntry - root = entry ^. entryPointRoot - opts = StoredModule.fromEntryPoint entry processModuleCacheMiss :: forall r. @@ -283,7 +282,7 @@ processModuleCacheMiss entryIx = do ProcessModuleRecompile recomp -> recomp ^. recompileDo processProject :: - (Members '[PathResolver, ModuleInfoCache, Reader EntryPoint, Reader ImportTree] r) => + (Members '[Files, PathResolver, ModuleInfoCache, Reader EntryPoint, Reader ImportTree] r) => Sem r [ProcessedNode ()] processProject = do rootDir <- asks (^. entryPointRoot) @@ -538,10 +537,9 @@ processImports imports = do processModuleToStoredCore :: forall r. (Members '[ModuleInfoCache, PathResolver, HighlightBuilder, TopModuleNameChecker, Error JuvixError, Files] r) => - Text -> EntryPoint -> Sem r (PipelineResult Store.ModuleInfo) -processModuleToStoredCore sha256 entry = over pipelineResult mkModuleInfo <$> processFileToStoredCore entry +processModuleToStoredCore entry = over pipelineResult mkModuleInfo <$> processFileToStoredCore entry where mkModuleInfo :: Core.CoreResult -> Store.ModuleInfo mkModuleInfo Core.CoreResult {..} = @@ -551,7 +549,7 @@ processModuleToStoredCore sha256 entry = over pipelineResult mkModuleInfo <$> pr _moduleInfoCoreTable = fromCore (_coreResultModule ^. Core.moduleInfoTable), _moduleInfoImports = map (^. importModulePath) $ scoperResult ^. Scoper.resultParserResult . Parser.resultParserState . parserStateImports, _moduleInfoOptions = StoredOptions.fromEntryPoint entry, - _moduleInfoSHA256 = sha256 + _moduleInfoSHA256 = fromJust (entry ^. entryPointSHA256) } where scoperResult = _coreResultInternalTypedResult ^. InternalTyped.resultInternal . Internal.resultScoper diff --git a/src/Juvix/Compiler/Pipeline/DriverParallel.hs b/src/Juvix/Compiler/Pipeline/DriverParallel.hs index 395856a6bf..fba553fd43 100644 --- a/src/Juvix/Compiler/Pipeline/DriverParallel.hs +++ b/src/Juvix/Compiler/Pipeline/DriverParallel.hs @@ -33,7 +33,7 @@ type Node = EntryIndex mkNodesIndex :: forall r. - (Members '[PathResolver, Reader EntryPoint] r) => + (Members '[Files, PathResolver, Reader EntryPoint] r) => ImportTree -> Sem r (NodesIndex ImportNode Node) mkNodesIndex tree = diff --git a/src/Juvix/Compiler/Pipeline/EntryPoint.hs b/src/Juvix/Compiler/Pipeline/EntryPoint.hs index eb9fe4349c..5d6f0cf248 100644 --- a/src/Juvix/Compiler/Pipeline/EntryPoint.hs +++ b/src/Juvix/Compiler/Pipeline/EntryPoint.hs @@ -55,7 +55,8 @@ data EntryPoint = EntryPoint _entryPointOffline :: Bool, _entryPointFieldSize :: Natural, _entryPointIsabelleOnlyTypes :: Bool, - _entryPointPipeline :: Maybe Pipeline + _entryPointPipeline :: Maybe Pipeline, + _entryPointSHA256 :: Maybe Text } deriving stock (Eq, Show) @@ -108,5 +109,6 @@ defaultEntryPointNoFile pkg root = _entryPointOffline = False, _entryPointFieldSize = defaultFieldSize, _entryPointIsabelleOnlyTypes = False, - _entryPointPipeline = Nothing + _entryPointPipeline = Nothing, + _entryPointSHA256 = Nothing } diff --git a/src/Juvix/Compiler/Pipeline/Modular.hs b/src/Juvix/Compiler/Pipeline/Modular.hs index fb30e3ce2c..103b7deb09 100644 --- a/src/Juvix/Compiler/Pipeline/Modular.hs +++ b/src/Juvix/Compiler/Pipeline/Modular.hs @@ -43,7 +43,7 @@ processModuleCacheMiss mt f mid = do subdir = Stored.getOptionsSubdir opts absPath = buildDir Path. subdir Path. relPath md0 = lookupModuleTable mt mid - sha256 = md0 ^. moduleSHA256 + sha256 = fromJust (md0 ^. moduleSHA256) res <- processImports (md0 ^. moduleImports) let changed = res ^. pipelineResultChanged imports = res ^. pipelineResult @@ -87,15 +87,6 @@ processImports mids = do _pipelineResultChanged = any (^. pipelineResultChanged) res } -processCoreToTree :: - (Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint, ModuleCache Tree.Module] r) => - Core.TransformationId -> - Core.ModuleTable -> - ModuleId -> - Sem r (PipelineResult Tree.Module) -processCoreToTree checkId mt mid = do - processModuleCacheMiss mt (Pipeline.coreToTree checkId) mid - runModularPipeline :: forall t t' r. (Serialize t', Monoid t', Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint] r) => @@ -109,10 +100,10 @@ runModularPipeline f mt = do $ mapM (fmap (^. pipelineResult) . processModule . (^. moduleId)) (mt ^. moduleTable) return $ ModuleTable tab -runModularCoreToTree :: +runModularStoredCoreToTree :: (Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint] r) => Core.TransformationId -> Core.ModuleTable -> Sem r Tree.ModuleTable -runModularCoreToTree checkId mt = - runModularPipeline (Pipeline.coreToTree checkId) mt +runModularStoredCoreToTree checkId mt = + runModularPipeline (Pipeline.storedCoreToTree checkId) mt diff --git a/src/Juvix/Compiler/Pipeline/ModuleInfoCache.hs b/src/Juvix/Compiler/Pipeline/ModuleInfoCache.hs index 0340a41868..78304e31d3 100644 --- a/src/Juvix/Compiler/Pipeline/ModuleInfoCache.hs +++ b/src/Juvix/Compiler/Pipeline/ModuleInfoCache.hs @@ -5,6 +5,7 @@ import Juvix.Compiler.Pipeline.Loader.PathResolver import Juvix.Compiler.Pipeline.Result import Juvix.Compiler.Store.Language qualified as Store import Juvix.Data.Effect.Cache +import Juvix.Data.SHA256 qualified as SHA256 import Juvix.Prelude data EntryIndex = EntryIndex @@ -28,19 +29,21 @@ entryIndexPath = fromMaybe err . (^. entryIxEntry . entryPointModulePath) err :: a err = error "unexpected: EntryIndex should always have a path" -mkEntryIndex :: (Members '[PathResolver, Reader EntryPoint] r) => ImportNode -> Sem r EntryIndex +mkEntryIndex :: (Members '[Files, PathResolver, Reader EntryPoint] r) => ImportNode -> Sem r EntryIndex mkEntryIndex node = do entry <- ask pkgId <- importNodePackageId node let path = node ^. importNodeAbsFile - stdin' + sha256 <- SHA256.digestFile path + let stdin' | Just path == entry ^. entryPointModulePath = entry ^. entryPointStdin | otherwise = Nothing entry' = entry { _entryPointStdin = stdin', _entryPointPackageId = pkgId, - _entryPointModulePath = Just path + _entryPointModulePath = Just path, + _entryPointSHA256 = Just sha256 } return EntryIndex diff --git a/src/Juvix/Compiler/Store/Backend/Module.hs b/src/Juvix/Compiler/Store/Backend/Module.hs index b9dcac1781..02f3ada60d 100644 --- a/src/Juvix/Compiler/Store/Backend/Module.hs +++ b/src/Juvix/Compiler/Store/Backend/Module.hs @@ -53,7 +53,7 @@ toCoreModule imports Module {..} = _moduleInfoTable = _moduleInfoTable, _moduleImports = _moduleImports, _moduleImportsTable = mconcatMap Core.computeCombinedInfoTable imports, - _moduleSHA256 = _moduleSHA256 + _moduleSHA256 = Just _moduleSHA256 } fromCoreModule :: Options -> Core.Module' t -> Module' t @@ -63,5 +63,5 @@ fromCoreModule opts Core.Module {..} = _moduleInfoTable = _moduleInfoTable, _moduleImports = _moduleImports, _moduleOptions = opts, - _moduleSHA256 = _moduleSHA256 + _moduleSHA256 = fromJust _moduleSHA256 } From 5aabc9101a0619cf707a5d8cbda02227aa623079 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Tue, 18 Feb 2025 17:59:57 +0100 Subject: [PATCH 15/24] runModularPipeline --- app/App.hs | 40 +++++++++++++++++++-- src/Juvix/Compiler/Core/Data/Module/Base.hs | 2 +- src/Juvix/Compiler/Pipeline/Driver.hs | 23 ++++++++++-- src/Juvix/Compiler/Pipeline/Driver/Data.hs | 8 +++-- src/Juvix/Compiler/Pipeline/Modular.hs | 23 ++++++++---- src/Juvix/Compiler/Pipeline/Modular/Run.hs | 19 ++++++++++ src/Juvix/Compiler/Pipeline/Result.hs | 4 +++ src/Juvix/Compiler/Store/Extra.hs | 21 +++++++++++ src/Juvix/Compiler/Store/Scoped/Language.hs | 3 -- 9 files changed, 125 insertions(+), 18 deletions(-) create mode 100644 src/Juvix/Compiler/Pipeline/Modular/Run.hs diff --git a/app/App.hs b/app/App.hs index 0372bf7924..44d25e515e 100644 --- a/app/App.hs +++ b/app/App.hs @@ -2,13 +2,21 @@ module App where import CommonOptions import Data.ByteString qualified as ByteString +import Data.HashMap.Strict qualified as HashMap import GlobalOptions import Juvix.Compiler.Backend.Markdown.Error +import Juvix.Compiler.Core.Data.Module qualified as Core +import Juvix.Compiler.Core.Translation.FromInternal.Data.Context qualified as Core import Juvix.Compiler.Internal.Translation (InternalTypedResult) import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker +import Juvix.Compiler.Pipeline qualified as Pipeline import Juvix.Compiler.Pipeline.Loader.PathResolver +import Juvix.Compiler.Pipeline.Modular (ModularEff) +import Juvix.Compiler.Pipeline.Modular.Run qualified as Pipeline.Modular import Juvix.Compiler.Pipeline.Root import Juvix.Compiler.Pipeline.Run +import Juvix.Compiler.Store.Extra qualified as Store +import Juvix.Compiler.Store.Language qualified as Store import Juvix.Data.Error qualified as Error import Juvix.Data.SHA256 qualified as SHA256 import Juvix.Extra.Paths.Base hiding (rootBuildDir) @@ -177,6 +185,15 @@ getEntryPoint' RunAppIOArgs {..} inputFile = do . set entryPointStdin estdin <$> entryPointFromGlobalOptionsPre root ((^. pathPath) <$> mainFile) opts +getEntryPoint'' :: + (Members '[App, EmbedIO, TaggedLock] r, EntryPointOptions opts) => + opts -> + Maybe (AppPath File) -> + Sem r EntryPoint +getEntryPoint'' opts inputFile = do + args <- askArgs + applyOptions opts <$> getEntryPoint' args inputFile + runPipelineEither :: (Members '[EmbedIO, TaggedLock, Logger, App] r, EntryPointOptions opts) => opts -> @@ -184,8 +201,7 @@ runPipelineEither :: Sem (PipelineEff r) a -> Sem r (Either JuvixError (ResolverState, PipelineResult a)) runPipelineEither opts input_ p = runPipelineOptions $ do - args <- askArgs - entry <- applyOptions opts <$> getEntryPoint' args input_ + entry <- getEntryPoint'' opts input_ runIOEither entry (inject p) getEntryPointStdin' :: (Members '[EmbedIO, TaggedLock] r) => RunAppIOArgs -> Sem r EntryPoint @@ -335,6 +351,26 @@ runPipelineSetup p = do r <- runIOEitherPipeline entry (inject p) >>= fromRightJuvixError return (snd r) +runPipelineModular :: + forall a r opts. + (Members '[App, EmbedIO, Logger, TaggedLock] r, EntryPointOptions opts) => + opts -> + Maybe (AppPath File) -> + (Core.ModuleTable -> Sem (ModularEff r) a) -> + Sem r a +runPipelineModular opts input_ f = runPipelineOptions $ do + entry <- getEntryPoint'' opts input_ + let p :: Sem (PipelineEff r) Core.CoreResult = Pipeline.upToStoredCore + r <- runIOEither entry (inject p) >>= fromRightJuvixError + let res = snd r + md = res ^. pipelineResult . Core.coreResultModule + mtab = + over Core.moduleTable (HashMap.insert (md ^. Core.moduleId) md) + . Store.toCoreModuleTable (res ^. pipelineResultImportTables) + . HashMap.elems + $ res ^. pipelineResultImports . Store.moduleTable + Pipeline.Modular.runIOEitherPipeline entry (inject (f mtab)) >>= fromRightJuvixError + renderStdOutLn :: forall a r. (Member App r, HasAnsiBackend a, HasTextBackend a) => a -> Sem r () renderStdOutLn txt = renderStdOut txt >> newline diff --git a/src/Juvix/Compiler/Core/Data/Module/Base.hs b/src/Juvix/Compiler/Core/Data/Module/Base.hs index 53ee4df1cd..892d2c0714 100644 --- a/src/Juvix/Compiler/Core/Data/Module/Base.hs +++ b/src/Juvix/Compiler/Core/Data/Module/Base.hs @@ -61,7 +61,7 @@ lookupModuleTable mt mid = fromMaybe (impossibleError ("Could not find module " <> prettyText mid)) (lookupModuleTable' mt mid) computeImportsTable :: (Monoid t) => ModuleTable' t -> [ModuleId] -> t -computeImportsTable mt = foldMap ((^. moduleImportsTable) . lookupModuleTable mt) +computeImportsTable mt = foldMap (computeCombinedInfoTable . lookupModuleTable mt) updateImportsTable :: (Monoid t) => ModuleTable' t -> Module' t -> Module' t updateImportsTable mt m = diff --git a/src/Juvix/Compiler/Pipeline/Driver.hs b/src/Juvix/Compiler/Pipeline/Driver.hs index 61e5e997cd..17c92962ae 100644 --- a/src/Juvix/Compiler/Pipeline/Driver.hs +++ b/src/Juvix/Compiler/Pipeline/Driver.hs @@ -46,6 +46,7 @@ import Juvix.Compiler.Pipeline.JvoCache import Juvix.Compiler.Pipeline.Loader.PathResolver import Juvix.Compiler.Pipeline.ModuleInfoCache import Juvix.Compiler.Store.Core.Extra +import Juvix.Compiler.Store.Core.Extra qualified as Store import Juvix.Compiler.Store.Extra import Juvix.Compiler.Store.Extra qualified as Store import Juvix.Compiler.Store.Language @@ -250,6 +251,7 @@ processModuleCacheMissDecide entryIx = do PipelineResult { _pipelineResult = info, _pipelineResultImports = _compileResultModuleTable, + _pipelineResultImportTables = _compileResultImportTables, _pipelineResultChanged = False } @@ -492,11 +494,12 @@ processFileUpToParsing :: processFileUpToParsing entry = do res <- runReader entry upToParsing let imports :: [Import 'Parsed] = res ^. Parser.resultParserState . Parser.parserStateImports - mtab <- (^. compileResultModuleTable) <$> runReader entry (processImports (map (^. importModulePath) imports)) + CompileResult {..} <- runReader entry (processImports (map (^. importModulePath) imports)) return PipelineResult { _pipelineResult = res, - _pipelineResultImports = mtab, + _pipelineResultImports = _compileResultModuleTable, + _pipelineResultImportTables = _compileResultImportTables, _pipelineResultChanged = True } @@ -528,11 +531,25 @@ processImports imports = do Store.mkModuleTable (map (^. pipelineResult) ms) <> mconcatMap (^. pipelineResultImports) ms changed = any (^. pipelineResultChanged) ms + itabs = + HashMap.fromList + . map computeImportsTable + $ ms return CompileResult { _compileResultChanged = changed, - _compileResultModuleTable = mtab + _compileResultModuleTable = mtab, + _compileResultImportTables = itabs } + where + computeImportsTable :: PipelineResult Store.ModuleInfo -> (ModuleId, Core.InfoTable) + computeImportsTable r = + ( mid, + Store.toCore (r ^. pipelineResult . Store.moduleInfoCoreTable) + <> mconcat (HashMap.elems (r ^. pipelineResultImportTables)) + ) + where + mid = r ^. pipelineResult . Store.moduleInfoInternalModule . Internal.internalModuleId processModuleToStoredCore :: forall r. diff --git a/src/Juvix/Compiler/Pipeline/Driver/Data.hs b/src/Juvix/Compiler/Pipeline/Driver/Data.hs index 3753fc4568..966436c260 100644 --- a/src/Juvix/Compiler/Pipeline/Driver/Data.hs +++ b/src/Juvix/Compiler/Pipeline/Driver/Data.hs @@ -4,6 +4,7 @@ module Juvix.Compiler.Pipeline.Driver.Data ) where +import Juvix.Compiler.Core.Data.InfoTable qualified as Core import Juvix.Compiler.Pipeline.Loader.PathResolver.ImportTree.Base import Juvix.Compiler.Pipeline.Result import Juvix.Compiler.Store.Language @@ -14,6 +15,7 @@ import Prelude (show) data CompileResult = CompileResult { _compileResultModuleTable :: Store.ModuleTable, + _compileResultImportTables :: HashMap ModuleId Core.InfoTable, _compileResultChanged :: Bool } @@ -33,14 +35,16 @@ instance Semigroup CompileResult where sconcat l = CompileResult { _compileResultChanged = any (^. compileResultChanged) l, - _compileResultModuleTable = sconcatMap (^. compileResultModuleTable) l + _compileResultModuleTable = sconcatMap (^. compileResultModuleTable) l, + _compileResultImportTables = sconcatMap (^. compileResultImportTables) l } instance Monoid CompileResult where mempty = CompileResult { _compileResultChanged = False, - _compileResultModuleTable = mempty + _compileResultModuleTable = mempty, + _compileResultImportTables = mempty } data ProcessModuleDecision (r :: [Effect]) diff --git a/src/Juvix/Compiler/Pipeline/Modular.hs b/src/Juvix/Compiler/Pipeline/Modular.hs index 103b7deb09..f7f466f6ab 100644 --- a/src/Juvix/Compiler/Pipeline/Modular.hs +++ b/src/Juvix/Compiler/Pipeline/Modular.hs @@ -1,5 +1,6 @@ module Juvix.Compiler.Pipeline.Modular where +import Data.List.Singletons (type (++)) import Juvix.Compiler.Core.Data.Module qualified as Core import Juvix.Compiler.Core.Data.Module.Base import Juvix.Compiler.Core.Data.TransformationId qualified as Core @@ -13,6 +14,14 @@ import Juvix.Extra.Serialize qualified as Serialize import Juvix.Prelude import Path qualified +type ModularEff r = + '[ Files, + TaggedLock, + Reader EntryPoint, + Error JuvixError + ] + ++ r + processModule :: (Members '[Files, Error JuvixError, Reader EntryPoint, ModuleCache (Module' t)] r) => ModuleId -> @@ -87,23 +96,23 @@ processImports mids = do _pipelineResultChanged = any (^. pipelineResultChanged) res } -runModularPipeline :: +processModuleTable :: forall t t' r. (Serialize t', Monoid t', Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint] r) => - (forall r'. (Members '[Error JuvixError, Reader EntryPoint] r') => Module' t -> Sem r' (Module' t')) -> + (Module' t -> Sem r (Module' t')) -> ModuleTable' t -> Sem r (ModuleTable' t') -runModularPipeline f mt = do +processModuleTable f mt = do tab <- evalCacheEmpty - (processModuleCacheMiss mt f) + (processModuleCacheMiss mt (inject . f)) $ mapM (fmap (^. pipelineResult) . processModule . (^. moduleId)) (mt ^. moduleTable) return $ ModuleTable tab -runModularStoredCoreToTree :: +modularCoreToTree :: (Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint] r) => Core.TransformationId -> Core.ModuleTable -> Sem r Tree.ModuleTable -runModularStoredCoreToTree checkId mt = - runModularPipeline (Pipeline.storedCoreToTree checkId) mt +modularCoreToTree checkId mt = + processModuleTable (Pipeline.storedCoreToTree checkId) mt diff --git a/src/Juvix/Compiler/Pipeline/Modular/Run.hs b/src/Juvix/Compiler/Pipeline/Modular/Run.hs new file mode 100644 index 0000000000..a6d06f7435 --- /dev/null +++ b/src/Juvix/Compiler/Pipeline/Modular/Run.hs @@ -0,0 +1,19 @@ +module Juvix.Compiler.Pipeline.Modular.Run where + +import Juvix.Compiler.Concrete.Data.Highlight +import Juvix.Compiler.Pipeline.EntryPoint +import Juvix.Compiler.Pipeline.Modular +import Juvix.Prelude + +runIOEitherPipeline :: + forall a r. + (Members '[TaggedLock, EmbedIO] r) => + EntryPoint -> + Sem (ModularEff r) a -> + Sem r (Either JuvixError a) +runIOEitherPipeline entry a = + evalHighlightBuilder + . runJuvixError + . runReader entry + . runFilesIO + $ inject a diff --git a/src/Juvix/Compiler/Pipeline/Result.hs b/src/Juvix/Compiler/Pipeline/Result.hs index 4e143287b4..f49901a273 100644 --- a/src/Juvix/Compiler/Pipeline/Result.hs +++ b/src/Juvix/Compiler/Pipeline/Result.hs @@ -1,5 +1,6 @@ module Juvix.Compiler.Pipeline.Result where +import Juvix.Compiler.Core.Data.InfoTable qualified as Core import Juvix.Compiler.Store.Language qualified as Store import Juvix.Prelude @@ -10,6 +11,9 @@ data PipelineResult a = PipelineResult -- then still both A and B will be in the imports table in the pipeline -- result for processing M. _pipelineResultImports :: Store.ModuleTable, + -- | Core imports table for every transitive import stored in + -- _pipelineResultImports. + _pipelineResultImportTables :: HashMap ModuleId Core.InfoTable, -- | True if the module had to be recompiled. False if the module was loaded -- from disk. _pipelineResultChanged :: Bool diff --git a/src/Juvix/Compiler/Store/Extra.hs b/src/Juvix/Compiler/Store/Extra.hs index dbd99c58a8..7184126951 100644 --- a/src/Juvix/Compiler/Store/Extra.hs +++ b/src/Juvix/Compiler/Store/Extra.hs @@ -4,6 +4,7 @@ import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Concrete.Data.Name qualified as C import Juvix.Compiler.Concrete.Data.ScopedName qualified as S import Juvix.Compiler.Core.Data.InfoTable qualified as Core +import Juvix.Compiler.Core.Data.Module qualified as Core import Juvix.Compiler.Store.Core.Extra import Juvix.Compiler.Store.Internal.Language import Juvix.Compiler.Store.Language @@ -52,3 +53,23 @@ computeCombinedBuiltins mtab = mconcatMap (^. moduleInfoScopedModule . scopedModuleInfoTable . infoBuiltins) (HashMap.elems (mtab ^. moduleTable)) + +toCoreModuleTable :: HashMap ModuleId Core.InfoTable -> [ModuleInfo] -> Core.ModuleTable +toCoreModuleTable imports modules = + Core.ModuleTable + . HashMap.fromList + . map (\md -> (md ^. Core.moduleId, md)) + . map (toCoreModule imports) + $ modules + +toCoreModule :: HashMap ModuleId Core.InfoTable -> ModuleInfo -> Core.Module +toCoreModule imports ModuleInfo {..} = + Core.Module + { _moduleId = mid, + _moduleInfoTable = toCore _moduleInfoCoreTable, + _moduleImports = _moduleInfoInternalModule ^. internalModuleImports, + _moduleImportsTable = fromJust $ HashMap.lookup mid imports, + _moduleSHA256 = Just _moduleInfoSHA256 + } + where + mid = _moduleInfoInternalModule ^. internalModuleId diff --git a/src/Juvix/Compiler/Store/Scoped/Language.hs b/src/Juvix/Compiler/Store/Scoped/Language.hs index 53816a85df..7e2aea9f7e 100644 --- a/src/Juvix/Compiler/Store/Scoped/Language.hs +++ b/src/Juvix/Compiler/Store/Scoped/Language.hs @@ -64,9 +64,6 @@ exportAllNames = createExportsTable :: ExportInfo -> HashSet NameId createExportsTable = HashSet.fromList . (^.. exportAllNames . S.nameId) -getScopedModuleNameId :: ScopedModule -> S.NameId -getScopedModuleNameId m = m ^. scopedModuleName . S.nameId - getCombinedInfoTable :: ScopedModule -> InfoTable getCombinedInfoTable sm = sm ^. scopedModuleInfoTable <> mconcatMap getCombinedInfoTable (sm ^. scopedModuleLocalModules) From b386d269738ec13e3e8256727662de05eee54d75 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Wed, 19 Feb 2025 13:01:15 +0100 Subject: [PATCH 16/24] fix non-modular pipeline --- src/Juvix/Compiler/Core/Data/Module/Base.hs | 7 +++++++ src/Juvix/Compiler/Core/Transformation.hs | 1 - .../Core/Transformation/CombineInfoTables.hs | 10 ---------- .../Core/Translation/Stripped/FromCore.hs | 3 +-- src/Juvix/Compiler/Pipeline.hs | 16 ++++++++-------- test/Main.hs | 4 ++-- 6 files changed, 18 insertions(+), 23 deletions(-) delete mode 100644 src/Juvix/Compiler/Core/Transformation/CombineInfoTables.hs diff --git a/src/Juvix/Compiler/Core/Data/Module/Base.hs b/src/Juvix/Compiler/Core/Data/Module/Base.hs index 892d2c0714..013eb56715 100644 --- a/src/Juvix/Compiler/Core/Data/Module/Base.hs +++ b/src/Juvix/Compiler/Core/Data/Module/Base.hs @@ -53,6 +53,13 @@ moduleFromInfoTable tab = Module defaultModuleId tab mempty mempty Nothing computeCombinedInfoTable :: (Monoid t) => Module' t -> t computeCombinedInfoTable Module {..} = _moduleInfoTable <> _moduleImportsTable +combineInfoTables :: (Monoid t) => Module' t -> Module' t +combineInfoTables md = + md + { _moduleInfoTable = computeCombinedInfoTable md, + _moduleImportsTable = mempty + } + lookupModuleTable' :: ModuleTable' t -> ModuleId -> Maybe (Module' t) lookupModuleTable' mt mid = HashMap.lookup mid (mt ^. moduleTable) diff --git a/src/Juvix/Compiler/Core/Transformation.hs b/src/Juvix/Compiler/Core/Transformation.hs index db4a691241..9eb1b33fc5 100644 --- a/src/Juvix/Compiler/Core/Transformation.hs +++ b/src/Juvix/Compiler/Core/Transformation.hs @@ -17,7 +17,6 @@ import Juvix.Compiler.Core.Transformation.Check.Anoma import Juvix.Compiler.Core.Transformation.Check.Cairo import Juvix.Compiler.Core.Transformation.Check.Exec import Juvix.Compiler.Core.Transformation.Check.Rust -import Juvix.Compiler.Core.Transformation.CombineInfoTables (combineInfoTables) import Juvix.Compiler.Core.Transformation.ComputeTypeInfo import Juvix.Compiler.Core.Transformation.ConvertBuiltinTypes import Juvix.Compiler.Core.Transformation.DetectConstantSideConditions diff --git a/src/Juvix/Compiler/Core/Transformation/CombineInfoTables.hs b/src/Juvix/Compiler/Core/Transformation/CombineInfoTables.hs deleted file mode 100644 index 7736df2b4a..0000000000 --- a/src/Juvix/Compiler/Core/Transformation/CombineInfoTables.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Juvix.Compiler.Core.Transformation.CombineInfoTables where - -import Juvix.Compiler.Core.Transformation.Base - -combineInfoTables :: Module -> Module -combineInfoTables md = - md - { _moduleInfoTable = computeCombinedInfoTable md, - _moduleImportsTable = mempty - } diff --git a/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs b/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs index 533a550b03..5130075e6e 100644 --- a/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs +++ b/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs @@ -13,8 +13,7 @@ fromCore :: Module -> Stripped.Module fromCore Module {..} = Stripped.Module { _moduleId = _moduleId, - -- TODO: don't combine info tables - _moduleInfoTable = fromCore' (_moduleInfoTable <> _moduleImportsTable), + _moduleInfoTable = fromCore' _moduleInfoTable, _moduleImports = _moduleImports, _moduleSHA256 = _moduleSHA256 } diff --git a/src/Juvix/Compiler/Pipeline.hs b/src/Juvix/Compiler/Pipeline.hs index 6cc1f32f53..18ce27c3a7 100644 --- a/src/Juvix/Compiler/Pipeline.hs +++ b/src/Juvix/Compiler/Pipeline.hs @@ -168,31 +168,31 @@ upToReg :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError] r) => Sem r Reg.Module upToReg = - upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToReg _coreResultModule + upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToReg (Core.combineInfoTables _coreResultModule) upToTree :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError] r) => Sem r Tree.Module upToTree = - upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToTree Core.IdentityTrans _coreResultModule + upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToTree Core.IdentityTrans (Core.combineInfoTables _coreResultModule) upToAsm :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError] r) => Sem r Asm.Module upToAsm = - upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToAsm _coreResultModule + upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToAsm (Core.combineInfoTables _coreResultModule) upToCasm :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError] r) => Sem r Casm.Result upToCasm = - upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToCasm _coreResultModule + upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToCasm (Core.combineInfoTables _coreResultModule) upToCairo :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError] r) => Sem r Cairo.Result upToCairo = - upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToCairo _coreResultModule + upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToCairo (Core.combineInfoTables _coreResultModule) upToMiniC :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError] r) => @@ -202,17 +202,17 @@ upToMiniC = upToAsm >>= asmToMiniC upToAnoma :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError] r) => Sem r NockmaTree.AnomaResult -upToAnoma = upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToAnoma _coreResultModule +upToAnoma = upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToAnoma (Core.combineInfoTables _coreResultModule) upToRust :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError, PathResolver] r) => Sem r Rust.Result -upToRust = upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToRust _coreResultModule +upToRust = upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToRust (Core.combineInfoTables _coreResultModule) upToRiscZeroRust :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError, PathResolver] r) => Sem r Rust.Result -upToRiscZeroRust = upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToRiscZeroRust _coreResultModule +upToRiscZeroRust = upToStoredCore' Core.PipelineExec >>= \Core.CoreResult {..} -> storedCoreToRiscZeroRust (Core.combineInfoTables _coreResultModule) upToCoreTypecheck :: (Members '[HighlightBuilder, Reader Parser.ParserResult, Reader EntryPoint, Reader Store.ModuleTable, Files, NameIdGen, Error JuvixError] r) => diff --git a/test/Main.hs b/test/Main.hs index 6f7dd375ab..98ef785718 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -28,9 +28,9 @@ import Typecheck qualified slowTests :: IO TestTree slowTests = - sequentialTestGroup + testGroup "Juvix slow tests" - AllFinish + -- AllFinish <$> sequence [ return Runtime.allTests, return Reg.allTests, From 3d8164e16390736a8b16b6f29a2b787049a216e8 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Wed, 19 Feb 2025 13:15:11 +0100 Subject: [PATCH 17/24] fix IR parsing --- .../Compiler/Tree/Data/InfoTableBuilder/Base.hs | 4 ++-- .../Compiler/Tree/Translation/FromSource/Base.hs | 12 +++++++++++- test/Main.hs | 4 ++-- 3 files changed, 15 insertions(+), 5 deletions(-) diff --git a/src/Juvix/Compiler/Tree/Data/InfoTableBuilder/Base.hs b/src/Juvix/Compiler/Tree/Data/InfoTableBuilder/Base.hs index e5a539c5b3..e96ee9596c 100644 --- a/src/Juvix/Compiler/Tree/Data/InfoTableBuilder/Base.hs +++ b/src/Juvix/Compiler/Tree/Data/InfoTableBuilder/Base.hs @@ -72,11 +72,11 @@ runInfoTableBuilder' bs = reinterpret (runState bs) interp FreshSymbol' -> do s :: BuilderState' t e <- get modify' @(BuilderState' t e) (over stateNextSymbolId (+ 1)) - return (Symbol defaultModuleId (s ^. stateNextSymbolId)) + return (Symbol (s ^. stateModule . moduleId) (s ^. stateNextSymbolId)) FreshTag' -> do modify' @(BuilderState' t e) (over stateNextUserTag (+ 1)) s <- get @(BuilderState' t e) - return (UserTag (TagUser defaultModuleId (s ^. stateNextUserTag - 1))) + return (UserTag (TagUser (s ^. stateModule . moduleId) (s ^. stateNextUserTag - 1))) RegisterFunction' fi -> do modify' (over (stateModule . moduleInfoTable . infoFunctions) (HashMap.insert (fi ^. functionSymbol) fi)) modify' @(BuilderState' t e) (over stateIdents (HashMap.insert (fi ^. functionName) (IdentFun (fi ^. functionSymbol)))) diff --git a/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs b/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs index 41a5da8782..9a587fa7a0 100644 --- a/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs +++ b/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs @@ -39,7 +39,17 @@ localS update a = do return a' runParserS :: ParserSig t e d -> Path Abs File -> Text -> Either MegaparsecError (Module'' t e) -runParserS sig fileName input_ = (^. stateModule) <$> runParserS' sig (mkBuilderState (emptyModule defaultModuleId)) fileName input_ +runParserS sig fileName input_ = (^. stateModule) <$> runParserS' sig (mkBuilderState (emptyModule mid)) fileName input_ + where + mid = + ModuleId + { _moduleIdPath = nonEmptyToTopModulePathKey (pure (toFilePath fileName)), + _moduleIdPackageId = + PackageId + { _packageIdName = "$", + _packageIdVersion = SemVer 1 0 0 Nothing Nothing + } + } runParserS' :: forall t e d. ParserSig t e d -> BuilderState' t e -> Path Abs File -> Text -> Either MegaparsecError (BuilderState' t e) runParserS' sig bs fileName input_ = case runParserS'' (parseToplevel @t @e @d) sig bs fileName input_ of diff --git a/test/Main.hs b/test/Main.hs index 98ef785718..6f7dd375ab 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -28,9 +28,9 @@ import Typecheck qualified slowTests :: IO TestTree slowTests = - testGroup + sequentialTestGroup "Juvix slow tests" - -- AllFinish + AllFinish <$> sequence [ return Runtime.allTests, return Reg.allTests, From d25ecf5a8f381ce5cbc733c158ec9a2328640b82 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Wed, 19 Feb 2025 15:50:50 +0100 Subject: [PATCH 18/24] fix tests --- src/Juvix/Compiler/Tree/Data/Module.hs | 2 +- test/Casm/Compilation/Base.hs | 2 +- test/Rust/Compilation/Base.hs | 2 +- test/Rust/RiscZero/Base.hs | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Juvix/Compiler/Tree/Data/Module.hs b/src/Juvix/Compiler/Tree/Data/Module.hs index 60a9a4e01d..2b633a5d64 100644 --- a/src/Juvix/Compiler/Tree/Data/Module.hs +++ b/src/Juvix/Compiler/Tree/Data/Module.hs @@ -31,7 +31,7 @@ lookupFunInfo' Module {..} sym = lookupInductiveInfo :: Module -> Symbol -> InductiveInfo lookupInductiveInfo m sym = fromJust (lookupInductiveInfo' m sym) -lookupConstrInfo :: Module -> Tag -> ConstructorInfo +lookupConstrInfo :: (HasCallStack) => Module -> Tag -> ConstructorInfo lookupConstrInfo m tag = fromJust (lookupConstrInfo' m tag) lookupFunInfo :: Module -> Symbol -> FunctionInfo diff --git a/test/Casm/Compilation/Base.hs b/test/Casm/Compilation/Base.hs index 5511f70e93..ec756db2c1 100644 --- a/test/Casm/Compilation/Base.hs +++ b/test/Casm/Compilation/Base.hs @@ -47,7 +47,7 @@ compileAssertionEntry adjustEntry root' bInterp bRunVM optLevel mainFile inputFi } PipelineResult {..} <- snd <$> testRunIO entryPoint' upToStoredCore step "Translate to CASM" - case run $ runError @JuvixError $ runReader entryPoint' $ storedCoreToCasm (_pipelineResult ^. Core.coreResultModule) of + case run $ runError @JuvixError $ runReader entryPoint' $ storedCoreToCasm (Core.combineInfoTables (_pipelineResult ^. Core.coreResultModule)) of Left err -> assertFailure (prettyString (fromJuvixError @GenericError err)) Right Result {..} -> do withTempDir' diff --git a/test/Rust/Compilation/Base.hs b/test/Rust/Compilation/Base.hs index 29e57b1f2f..52b455e521 100644 --- a/test/Rust/Compilation/Base.hs +++ b/test/Rust/Compilation/Base.hs @@ -28,7 +28,7 @@ compileAssertion root' optLevel mainFile expectedFile step = do <$> testDefaultEntryPointIO root' mainFile PipelineResult {..} <- snd <$> testRunIO entryPoint upToStoredCore step "Translate to Rust" - case run $ runError @JuvixError $ runReader entryPoint $ storedCoreToRust (_pipelineResult ^. Core.coreResultModule) of + case run $ runError @JuvixError $ runReader entryPoint $ storedCoreToRust (Core.combineInfoTables (_pipelineResult ^. Core.coreResultModule)) of Left err -> assertFailure (prettyString (fromJuvixError @GenericError err)) Right Result {..} -> do withTempDir' diff --git a/test/Rust/RiscZero/Base.hs b/test/Rust/RiscZero/Base.hs index f7219b0d03..01d3798e08 100644 --- a/test/Rust/RiscZero/Base.hs +++ b/test/Rust/RiscZero/Base.hs @@ -34,7 +34,7 @@ compileAssertion tmpDir' root' optLevel mainFile expectedFile step = do <$> testDefaultEntryPointIO root' mainFile PipelineResult {..} <- snd <$> testRunIO entryPoint upToStoredCore step "Translate to RISC0 Rust" - case run $ runError @JuvixError $ runReader entryPoint $ storedCoreToRiscZeroRust (_pipelineResult ^. Core.coreResultModule) of + case run $ runError @JuvixError $ runReader entryPoint $ storedCoreToRiscZeroRust (Core.combineInfoTables (_pipelineResult ^. Core.coreResultModule)) of Left err -> assertFailure (prettyString (fromJuvixError @GenericError err)) Right Result {..} -> do let outDir = tmpDir $(mkRelDir "out") From e8aff908609029afda9a981978d330e26fcd4f6c Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Thu, 20 Feb 2025 19:25:57 +0100 Subject: [PATCH 19/24] modular stripped --- app/App.hs | 5 +- app/Commands/Dev/DevCompile/Asm/Options.hs | 5 +- app/Commands/Dev/DevCompile/Core/Options.hs | 5 +- app/Commands/Dev/DevCompile/Tree.hs | 8 ++- app/Commands/Dev/DevCompile/Tree/Options.hs | 5 +- src/Juvix/Compiler/Backend.hs | 42 +++++++++------ .../Compiler/Core/Data/Stripped/InfoTable.hs | 42 +++++++++++++++ .../Compiler/Core/Data/Stripped/Module.hs | 46 +++++++++++----- src/Juvix/Compiler/Core/Language/Nodes.hs | 8 +++ src/Juvix/Compiler/Core/Language/Stripped.hs | 20 ++++++- .../Compiler/Core/Language/Stripped/Type.hs | 12 +++-- .../Core/Transformation/RemoveTypeArgs.hs | 7 +-- .../Compiler/Core/Translation/FromInternal.hs | 12 +++-- .../Core/Translation/Stripped/FromCore.hs | 10 +++- src/Juvix/Compiler/Internal/Extra.hs | 12 +++++ src/Juvix/Compiler/Internal/Language.hs | 1 + src/Juvix/Compiler/Pipeline.hs | 46 ++++++++++++++-- src/Juvix/Compiler/Pipeline/Driver.hs | 4 +- src/Juvix/Compiler/Pipeline/Modular.hs | 54 +++++++++++++------ src/Juvix/Compiler/Store/Backend/Module.hs | 8 +-- src/Juvix/Compiler/Store/Backend/Options.hs | 26 ++++----- .../Tree/Transformation/FilterUnreachable.hs | 15 +++--- .../Compiler/Tree/Translation/FromCore.hs | 21 ++++---- src/Juvix/Prelude/Path.hs | 3 ++ 24 files changed, 310 insertions(+), 107 deletions(-) diff --git a/app/App.hs b/app/App.hs index 44d25e515e..825bb63394 100644 --- a/app/App.hs +++ b/app/App.hs @@ -357,7 +357,7 @@ runPipelineModular :: opts -> Maybe (AppPath File) -> (Core.ModuleTable -> Sem (ModularEff r) a) -> - Sem r a + Sem r (ModuleId, a) runPipelineModular opts input_ f = runPipelineOptions $ do entry <- getEntryPoint'' opts input_ let p :: Sem (PipelineEff r) Core.CoreResult = Pipeline.upToStoredCore @@ -369,7 +369,8 @@ runPipelineModular opts input_ f = runPipelineOptions $ do . Store.toCoreModuleTable (res ^. pipelineResultImportTables) . HashMap.elems $ res ^. pipelineResultImports . Store.moduleTable - Pipeline.Modular.runIOEitherPipeline entry (inject (f mtab)) >>= fromRightJuvixError + a <- Pipeline.Modular.runIOEitherPipeline entry (inject (f mtab)) >>= fromRightJuvixError + return (md ^. Core.moduleId, a) renderStdOutLn :: forall a r. (Member App r, HasAnsiBackend a, HasTextBackend a) => a -> Sem r () renderStdOutLn txt = renderStdOut txt >> newline diff --git a/app/Commands/Dev/DevCompile/Asm/Options.hs b/app/Commands/Dev/DevCompile/Asm/Options.hs index adb31f1d9f..62ca98a87a 100644 --- a/app/Commands/Dev/DevCompile/Asm/Options.hs +++ b/app/Commands/Dev/DevCompile/Asm/Options.hs @@ -23,4 +23,7 @@ parseAsm = do pure AsmOptions {..} instance EntryPointOptions (AsmOptions k) where - applyOptions = applyOptions . (^. asmCompileCommonOptions) + applyOptions opts = + set entryPointPipeline (Just PipelineExec) + . set entryPointTarget (Just TargetAsm) + . applyOptions (opts ^. asmCompileCommonOptions) diff --git a/app/Commands/Dev/DevCompile/Core/Options.hs b/app/Commands/Dev/DevCompile/Core/Options.hs index 497bf16b0f..6ca4ef965f 100644 --- a/app/Commands/Dev/DevCompile/Core/Options.hs +++ b/app/Commands/Dev/DevCompile/Core/Options.hs @@ -23,4 +23,7 @@ parseCore = do pure CoreOptions {..} instance EntryPointOptions (CoreOptions k) where - applyOptions = applyOptions . (^. coreCompileCommonOptions) + applyOptions opts = + set entryPointPipeline (Just PipelineExec) + . set entryPointTarget (Just TargetCore) + . applyOptions (opts ^. coreCompileCommonOptions) diff --git a/app/Commands/Dev/DevCompile/Tree.hs b/app/Commands/Dev/DevCompile/Tree.hs index 609449f16e..f14944e835 100644 --- a/app/Commands/Dev/DevCompile/Tree.hs +++ b/app/Commands/Dev/DevCompile/Tree.hs @@ -3,8 +3,11 @@ module Commands.Dev.DevCompile.Tree where import Commands.Base import Commands.Dev.DevCompile.Tree.Options import Commands.Extra.NewCompile +import Juvix.Compiler.Core.Data.TransformationId qualified as Core +import Juvix.Compiler.Pipeline.Modular (modularCoreToTree) import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Pretty +import Juvix.Compiler.Tree.Transformation.FilterUnreachable runCommand :: (Members AppEffects r) => @@ -14,6 +17,7 @@ runCommand opts = do let inputFile = opts ^. treeCompileCommonOptions . compileInputFile moutputFile = opts ^. treeCompileCommonOptions . compileOutputFile outFile :: Path Abs File <- getOutputFile FileExtJuvixTree inputFile moutputFile - res :: Module <- runPipeline opts inputFile upToTree - let txt = ppPrint res (computeCombinedInfoTable res) + (mid, mtab) <- runPipelineModular opts inputFile (modularCoreToTree Core.IdentityTrans) + let md = filterUnreachable (combineInfoTables (lookupModuleTable mtab mid)) + txt = ppPrint md (md ^. moduleInfoTable) writeFileEnsureLn outFile txt diff --git a/app/Commands/Dev/DevCompile/Tree/Options.hs b/app/Commands/Dev/DevCompile/Tree/Options.hs index 6b1b7ea2d8..b465f129c9 100644 --- a/app/Commands/Dev/DevCompile/Tree/Options.hs +++ b/app/Commands/Dev/DevCompile/Tree/Options.hs @@ -23,4 +23,7 @@ parseTree = do pure TreeOptions {..} instance EntryPointOptions (TreeOptions k) where - applyOptions = applyOptions . (^. treeCompileCommonOptions) + applyOptions opts = + set entryPointPipeline (Just PipelineExec) + . set entryPointTarget (Just TargetTree) + . applyOptions (opts ^. treeCompileCommonOptions) diff --git a/src/Juvix/Compiler/Backend.hs b/src/Juvix/Compiler/Backend.hs index b48ca0153b..9cf317a4a3 100644 --- a/src/Juvix/Compiler/Backend.hs +++ b/src/Juvix/Compiler/Backend.hs @@ -8,9 +8,10 @@ data Target = TargetCWasm32Wasi | TargetCNative64 | TargetCore + | TargetStripped + | TargetTree | TargetAsm | TargetReg - | TargetTree | TargetRust | TargetAnoma | TargetCairo @@ -74,6 +75,10 @@ getLimits tgt debug = case tgt of } TargetCore -> defaultLimits + TargetStripped -> + defaultLimits + TargetTree -> + defaultLimits TargetAsm -> defaultLimits TargetReg -> @@ -91,8 +96,6 @@ getLimits tgt debug = case tgt of _limitsBuiltinUIDsNum = 8, _limitsSpecialisedApply = 3 } - TargetTree -> - defaultLimits TargetAnoma -> defaultLimits TargetCairo -> @@ -143,26 +146,33 @@ defaultLimits = _limitsSpecialisedApply = 0 } -getTargetSubdir :: Target -> Path Rel Dir -getTargetSubdir = \case - TargetCWasm32Wasi -> $(mkRelDir "wasm32-wasi") - TargetCNative64 -> $(mkRelDir "native64") +getTargetSubdir :: Target -> Target -> Path Rel Dir +getTargetSubdir midTarget finalTarget = case midTarget of TargetCore -> $(mkRelDir "default") - TargetAsm -> $(mkRelDir "default") - TargetReg -> $(mkRelDir "default") - TargetTree -> $(mkRelDir "tree") - TargetRust -> $(mkRelDir "rust") - TargetAnoma -> $(mkRelDir "anoma") - TargetCairo -> $(mkRelDir "cairo") + TargetStripped -> $(mkRelDir "default") + TargetTree -> $(mkRelDir "default") + _ -> + case finalTarget of + TargetCWasm32Wasi -> $(mkRelDir "wasm32-wasi") + TargetCNative64 -> $(mkRelDir "native64") + TargetCore -> $(mkRelDir "default") + TargetStripped -> $(mkRelDir "default") + TargetTree -> $(mkRelDir "default") + TargetAsm -> $(mkRelDir "default") + TargetReg -> $(mkRelDir "default") + TargetRust -> $(mkRelDir "rust") + TargetAnoma -> $(mkRelDir "anoma") + TargetCairo -> $(mkRelDir "cairo") getTargetExtension :: Target -> String getTargetExtension = \case - TargetCWasm32Wasi -> ".c.bin" - TargetCNative64 -> ".c.bin" + TargetCWasm32Wasi -> ".c.wasm.bin" + TargetCNative64 -> ".c.native.bin" TargetCore -> ".core.bin" + TargetStripped -> ".stripped.bin" + TargetTree -> ".tree.bin" TargetAsm -> ".asm.bin" TargetReg -> ".reg.bin" - TargetTree -> ".tree.bin" TargetRust -> ".rs.bin" TargetAnoma -> ".anoma.bin" TargetCairo -> ".cairo.bin" diff --git a/src/Juvix/Compiler/Core/Data/Stripped/InfoTable.hs b/src/Juvix/Compiler/Core/Data/Stripped/InfoTable.hs index 04980e5f72..103f99c1af 100644 --- a/src/Juvix/Compiler/Core/Data/Stripped/InfoTable.hs +++ b/src/Juvix/Compiler/Core/Data/Stripped/InfoTable.hs @@ -9,6 +9,9 @@ data InfoTable = InfoTable _infoInductives :: HashMap Symbol InductiveInfo, _infoConstructors :: HashMap Tag ConstructorInfo } + deriving stock (Generic) + +instance Serialize InfoTable data FunctionInfo = FunctionInfo { _functionName :: Text, @@ -23,12 +26,18 @@ data FunctionInfo = FunctionInfo _functionArgsInfo :: [ArgumentInfo], _functionIsExported :: Bool } + deriving stock (Generic) + +instance Serialize FunctionInfo data ArgumentInfo = ArgumentInfo { _argumentName :: Text, _argumentLocation :: Maybe Location, _argumentType :: Type } + deriving stock (Generic) + +instance Serialize ArgumentInfo data InductiveInfo = InductiveInfo { _inductiveName :: Text, @@ -38,6 +47,9 @@ data InductiveInfo = InductiveInfo _inductiveConstructors :: [Tag], _inductiveParams :: [ParameterInfo] } + deriving stock (Generic) + +instance Serialize InductiveInfo data ConstructorInfo = ConstructorInfo { _constructorName :: Text, @@ -50,6 +62,9 @@ data ConstructorInfo = ConstructorInfo _constructorArgsNum :: Int, _constructorFixity :: Maybe Fixity } + deriving stock (Generic) + +instance Serialize ConstructorInfo data ParameterInfo = ParameterInfo { _paramName :: Text, @@ -57,6 +72,9 @@ data ParameterInfo = ParameterInfo _paramKind :: Type, _paramIsImplicit :: Bool } + deriving stock (Generic) + +instance Serialize ParameterInfo makeLenses ''InfoTable makeLenses ''FunctionInfo @@ -65,8 +83,32 @@ makeLenses ''InductiveInfo makeLenses ''ConstructorInfo makeLenses ''ParameterInfo +instance Semigroup InfoTable where + tab1 <> tab2 = + InfoTable + { _infoMain = tab1 ^. infoMain <|> tab2 ^. infoMain, + _infoFunctions = tab1 ^. infoFunctions <> tab2 ^. infoFunctions, + _infoInductives = tab1 ^. infoInductives <> tab2 ^. infoInductives, + _infoConstructors = tab1 ^. infoConstructors <> tab2 ^. infoConstructors + } + +instance Monoid InfoTable where + mempty = + InfoTable + { _infoMain = Nothing, + _infoFunctions = mempty, + _infoInductives = mempty, + _infoConstructors = mempty + } + lookupTabConstructorInfo' :: InfoTable -> Tag -> Maybe ConstructorInfo lookupTabConstructorInfo' tab tag = HashMap.lookup tag (tab ^. infoConstructors) +lookupTabFunInfo' :: InfoTable -> Symbol -> Maybe FunctionInfo +lookupTabFunInfo' tab sym = HashMap.lookup sym (tab ^. infoFunctions) + +lookupTabInductiveInfo' :: InfoTable -> Symbol -> Maybe InductiveInfo +lookupTabInductiveInfo' tab sym = HashMap.lookup sym (tab ^. infoInductives) + lookupTabConstructorInfo :: InfoTable -> Tag -> ConstructorInfo lookupTabConstructorInfo tab tag = fromJust $ HashMap.lookup tag (tab ^. infoConstructors) diff --git a/src/Juvix/Compiler/Core/Data/Stripped/Module.hs b/src/Juvix/Compiler/Core/Data/Stripped/Module.hs index 51cb1224c7..1f0bf97d4d 100644 --- a/src/Juvix/Compiler/Core/Data/Stripped/Module.hs +++ b/src/Juvix/Compiler/Core/Data/Stripped/Module.hs @@ -1,19 +1,41 @@ module Juvix.Compiler.Core.Data.Stripped.Module ( module Juvix.Compiler.Core.Data.Stripped.Module, module Juvix.Compiler.Core.Data.Stripped.InfoTable, + module Juvix.Compiler.Core.Data.Module.Base, ) where +import Juvix.Compiler.Core.Data.Module.Base import Juvix.Compiler.Core.Data.Stripped.InfoTable -import Juvix.Data.ModuleId -import Juvix.Prelude - -data Module = Module - { _moduleId :: ModuleId, - _moduleInfoTable :: InfoTable, - -- | The imports field contains all direct (non-transitive) dependencies of - -- the module. - _moduleImports :: [ModuleId], - _moduleSHA256 :: Maybe Text - } - deriving stock (Generic) +import Juvix.Compiler.Core.Language.Stripped + +type Module = Module' InfoTable + +type ModuleTable = ModuleTable' InfoTable + +lookupInductiveInfo' :: Module -> Symbol -> Maybe InductiveInfo +lookupInductiveInfo' Module {..} sym = + lookupTabInductiveInfo' _moduleInfoTable sym + <|> lookupTabInductiveInfo' _moduleImportsTable sym + +lookupConstructorInfo' :: Module -> Tag -> Maybe ConstructorInfo +lookupConstructorInfo' Module {..} tag = + lookupTabConstructorInfo' _moduleInfoTable tag + <|> lookupTabConstructorInfo' _moduleImportsTable tag + +lookupFunInfo' :: Module -> Symbol -> Maybe FunctionInfo +lookupFunInfo' Module {..} sym = + lookupTabFunInfo' _moduleInfoTable sym + <|> lookupTabFunInfo' _moduleImportsTable sym + +impossibleSymbolNotFound :: (HasCallStack) => Symbol -> a +impossibleSymbolNotFound sym = impossibleError ("Could not find symbol " <> show sym) + +lookupInductiveInfo :: Module -> Symbol -> InductiveInfo +lookupInductiveInfo m sym = fromMaybe (impossibleSymbolNotFound sym) (lookupInductiveInfo' m sym) + +lookupConstructorInfo :: Module -> Tag -> ConstructorInfo +lookupConstructorInfo m tag = fromJust (lookupConstructorInfo' m tag) + +lookupFunInfo :: Module -> Symbol -> FunctionInfo +lookupFunInfo m sym = fromMaybe (impossibleSymbolNotFound sym) (lookupFunInfo' m sym) diff --git a/src/Juvix/Compiler/Core/Language/Nodes.hs b/src/Juvix/Compiler/Core/Language/Nodes.hs index 3c8bd8c803..edf299adfd 100644 --- a/src/Juvix/Compiler/Core/Language/Nodes.hs +++ b/src/Juvix/Compiler/Core/Language/Nodes.hs @@ -299,6 +299,10 @@ instance (Serialize i, Serialize a) => Serialize (App' i a) instance (NFData i, NFData a) => NFData (App' i a) +instance (Serialize i, Serialize f, Serialize a) => Serialize (Apps' i f a) + +instance (NFData i, NFData f, NFData a) => NFData (Apps' i f a) + instance (Serialize i, Serialize a) => Serialize (BuiltinApp' i a) instance (NFData i, NFData a) => NFData (BuiltinApp' i a) @@ -335,6 +339,10 @@ instance (Serialize i, Serialize bi, Serialize a, Serialize ty) => Serialize (Ca instance (NFData i, NFData bi, NFData a, NFData ty) => NFData (Case' i bi a ty) +instance (Serialize i, Serialize a) => Serialize (If' i a) + +instance (NFData i, NFData a) => NFData (If' i a) + instance (Serialize i, Serialize a) => Serialize (Pi' i a) instance (NFData i, NFData a) => NFData (Pi' i a) diff --git a/src/Juvix/Compiler/Core/Language/Stripped.hs b/src/Juvix/Compiler/Core/Language/Stripped.hs index c2214718a7..4d4e8418d9 100644 --- a/src/Juvix/Compiler/Core/Language/Stripped.hs +++ b/src/Juvix/Compiler/Core/Language/Stripped.hs @@ -19,23 +19,35 @@ data VarInfo = VarInfo _varInfoLocation :: Maybe Location, _varInfoType :: Type -- TyDynamic if not available } + deriving stock (Generic) + +instance Serialize VarInfo data IdentInfo = IdentInfo { _identInfoName :: Text, _identInfoLocation :: Maybe Location, _identInfoType :: Type } + deriving stock (Generic) + +instance Serialize IdentInfo data ConstrInfo = ConstrInfo { _constrInfoName :: Text, _constrInfoLocation :: Maybe Location, _constrInfoType :: Type } + deriving stock (Generic) + +instance Serialize ConstrInfo data CaseBranchInfo = CaseBranchInfo { _caseBranchInfoConstrName :: Text, _caseBranchInfoConstrType :: Type } + deriving stock (Generic) + +instance Serialize CaseBranchInfo {---------------------------------------------------------------------------------} @@ -50,7 +62,9 @@ type Apps = Apps' () Fun Node data Fun = FunVar Var | FunIdent Ident - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance Serialize Fun type BuiltinApp = BuiltinApp' () Node @@ -80,7 +94,9 @@ data Node | NLet Let | NCase Case | NIf If - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance Serialize Node instance HasAtomicity Node where atomicity = \case diff --git a/src/Juvix/Compiler/Core/Language/Stripped/Type.hs b/src/Juvix/Compiler/Core/Language/Stripped/Type.hs index 26a0c55b14..2e6aed9dfa 100644 --- a/src/Juvix/Compiler/Core/Language/Stripped/Type.hs +++ b/src/Juvix/Compiler/Core/Language/Stripped/Type.hs @@ -8,7 +8,9 @@ data Type | TyPrim Primitive | TyApp TypeApp | TyFun TypeFun - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance Serialize Type data TypeApp = TypeApp { _typeAppName :: Text, @@ -16,13 +18,17 @@ data TypeApp = TypeApp _typeAppSymbol :: Symbol, _typeAppArgs :: [Type] } - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance Serialize TypeApp data TypeFun = TypeFun { _typeFunLeft :: Type, _typeFunRight :: Type } - deriving stock (Eq) + deriving stock (Eq, Generic) + +instance Serialize TypeFun makeLenses ''TypeApp makeLenses ''TypeFun diff --git a/src/Juvix/Compiler/Core/Transformation/RemoveTypeArgs.hs b/src/Juvix/Compiler/Core/Transformation/RemoveTypeArgs.hs index 3d596cca89..099be3a9cc 100644 --- a/src/Juvix/Compiler/Core/Transformation/RemoveTypeArgs.hs +++ b/src/Juvix/Compiler/Core/Transformation/RemoveTypeArgs.hs @@ -12,7 +12,7 @@ import Juvix.Compiler.Core.Transformation.Base convertNode :: Module -> Node -> Node convertNode md = convert mempty where - unsupported :: forall a. Node -> a + unsupported :: (HasCallStack) => forall a. Node -> a unsupported node = error ("remove type arguments: unsupported node\n\t" <> ppTrace node) convert :: BinderList Binder -> Node -> Node @@ -38,11 +38,12 @@ convertNode md = convert mempty let (h, args) = unfoldApps node ty = case h of - NVar (Var {..}) -> + NVar Var {..} -> BL.lookup _varIndex vars ^. binderType - NIdt (Ident {..}) -> + NIdt Ident {..} -> let fi = lookupIdentifierInfo md _identSymbol in fi ^. identifierType + NBot Bottom {..} -> _bottomType _ -> unsupported node args' = filterArgs snd ty args in if diff --git a/src/Juvix/Compiler/Core/Translation/FromInternal.hs b/src/Juvix/Compiler/Core/Translation/FromInternal.hs index 798aac39f3..51ad163463 100644 --- a/src/Juvix/Compiler/Core/Translation/FromInternal.hs +++ b/src/Juvix/Compiler/Core/Translation/FromInternal.hs @@ -155,11 +155,12 @@ preInductiveDef i = do _paramIsImplicit = False, _paramKind = ty' } + kind <- fromTopIndex $ goExpression (Internal.getInductiveKind i) let info = InductiveInfo { _inductiveLocation = Just $ i ^. Internal.inductiveName . nameLoc, _inductiveSymbol = sym, - _inductiveKind = mkSmallUniv, + _inductiveKind = kind, _inductiveConstructors = [], _inductiveParams = params', _inductivePositive = i ^. Internal.inductivePositive, @@ -644,7 +645,7 @@ goLet l = goClauses (toList (l ^. Internal.letClauses)) rest <- goClauses cs return (mkLetRec (setInfoPragmas pragmas mempty) items rest) -builtinInductive :: Internal.AxiomDef -> Maybe (forall r. (Members '[InfoTableBuilder] r) => Sem r ()) +builtinInductive :: Internal.AxiomDef -> Maybe (forall r. (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, Reader InternalTyped.FunctionsTable, Reader InternalTyped.InfoTable, NameIdGen, Error BadScope] r) => Sem r ()) builtinInductive a = case a ^. Internal.axiomBuiltin of Nothing -> Nothing @@ -716,18 +717,19 @@ builtinInductive a = Internal.BuiltinByteArrayFromListByte -> Nothing Internal.BuiltinByteArrayLength -> Nothing where - registerInductiveAxiom :: forall r. (Members '[InfoTableBuilder] r) => Maybe BuiltinAxiom -> [(Tag, Text, Type -> Type, Maybe BuiltinConstructor)] -> Sem r () + registerInductiveAxiom :: forall r. (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, Reader InternalTyped.FunctionsTable, Reader InternalTyped.InfoTable, NameIdGen, Error BadScope] r) => Maybe BuiltinAxiom -> [(Tag, Text, Type -> Type, Maybe BuiltinConstructor)] -> Sem r () registerInductiveAxiom ax ctrs = do sym <- freshSymbol let name = a ^. Internal.axiomName . nameText ty = mkTypeConstr (setInfoName name mempty) sym [] ctrs' = builtinConstrs sym ty ctrs + kind <- fromTopIndex $ goExpression (a ^. Internal.axiomType) let _inductiveName = a ^. Internal.axiomName . nameText info = InductiveInfo { _inductiveLocation = Just $ a ^. Internal.axiomName . nameLoc, _inductiveSymbol = sym, - _inductiveKind = mkSmallUniv, + _inductiveKind = kind, _inductiveConstructors = map (^. constructorTag) ctrs', _inductiveParams = [], _inductivePositive = False, @@ -740,7 +742,7 @@ builtinInductive a = goAxiomInductive :: forall r. - (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, Reader InternalTyped.FunctionsTable, Reader Internal.InfoTable, NameIdGen] r) => + (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, Reader InternalTyped.FunctionsTable, Reader Internal.InfoTable, NameIdGen, Error BadScope] r) => Internal.AxiomDef -> Sem r () goAxiomInductive a = case builtinInductive a of diff --git a/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs b/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs index 5130075e6e..ba949416c1 100644 --- a/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs +++ b/src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs @@ -15,6 +15,7 @@ fromCore Module {..} = { _moduleId = _moduleId, _moduleInfoTable = fromCore' _moduleInfoTable, _moduleImports = _moduleImports, + _moduleImportsTable = mempty, _moduleSHA256 = _moduleSHA256 } @@ -291,13 +292,18 @@ translateNode node = case node of (translateNode _caseValue) (map translateCaseBranch _caseBranches) (fmap translateNode _caseDefault) + NBot {} -> + unitNode _ | isType' node -> - Stripped.mkConstr (Stripped.ConstrInfo "()" Nothing Stripped.TyDynamic) (BuiltinTag TagTrue) [] + unitNode _ -> unsupported where - unsupported :: a + unitNode :: Stripped.Node + unitNode = Stripped.mkConstr (Stripped.ConstrInfo "()" Nothing Stripped.TyDynamic) (BuiltinTag TagTrue) [] + + unsupported :: (HasCallStack) => a unsupported = error "Core to Core.Stripped: unsupported node" translateIf :: Node -> Node -> Node -> Stripped.Node diff --git a/src/Juvix/Compiler/Internal/Extra.hs b/src/Juvix/Compiler/Internal/Extra.hs index 099f2cc434..89b15f891e 100644 --- a/src/Juvix/Compiler/Internal/Extra.hs +++ b/src/Juvix/Compiler/Internal/Extra.hs @@ -353,3 +353,15 @@ substituteIndParams :: expr -> Sem r expr substituteIndParams = substitutionE . HashMap.fromList . map (first (^. inductiveParamName)) + +getInductiveKind :: InductiveDef -> Expression +getInductiveKind InductiveDef {..} = + foldr + ( \p f -> + ExpressionFunction $ + Function + (FunctionParameter (Just (p ^. inductiveParamName)) Explicit (p ^. inductiveParamType)) + f + ) + _inductiveType + _inductiveParameters diff --git a/src/Juvix/Compiler/Internal/Language.hs b/src/Juvix/Compiler/Internal/Language.hs index f3e43e2a4f..50fec3f079 100644 --- a/src/Juvix/Compiler/Internal/Language.hs +++ b/src/Juvix/Compiler/Internal/Language.hs @@ -434,6 +434,7 @@ instance NFData InductiveParameter data InductiveDef = InductiveDef { _inductiveName :: InductiveName, _inductiveBuiltin :: Maybe BuiltinInductive, + -- The universe of the inductive type, not the full kind _inductiveType :: Expression, _inductiveParameters :: [InductiveParameter], _inductiveConstructors :: [ConstructorDef], diff --git a/src/Juvix/Compiler/Pipeline.hs b/src/Juvix/Compiler/Pipeline.hs index 18ce27c3a7..2a0e178341 100644 --- a/src/Juvix/Compiler/Pipeline.hs +++ b/src/Juvix/Compiler/Pipeline.hs @@ -28,6 +28,7 @@ import Juvix.Compiler.Concrete.Translation.FromSource qualified as Parser import Juvix.Compiler.Concrete.Translation.FromSource.TopModuleNameChecker import Juvix.Compiler.Concrete.Translation.ImportScanner import Juvix.Compiler.Core qualified as Core +import Juvix.Compiler.Core.Data.Stripped.Module qualified as Stripped import Juvix.Compiler.Core.Transformation import Juvix.Compiler.Core.Translation.Stripped.FromCore qualified as Stripped import Juvix.Compiler.Internal qualified as Internal @@ -226,15 +227,21 @@ upToCoreTypecheck = do -- Workflows from stored Core -------------------------------------------------------------------------------- +storedCoreToStripped :: + (Members '[Error JuvixError, Reader EntryPoint] r) => + Core.TransformationId -> + Core.Module -> + Sem r Stripped.Module +storedCoreToStripped checkId md = + Stripped.fromCore + <$> Core.toStripped checkId md + storedCoreToTree :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.TransformationId -> Core.Module -> Sem r Tree.Module -storedCoreToTree checkId md = do - Tree.fromCore - . Stripped.fromCore - <$> Core.toStripped checkId md +storedCoreToTree checkId = storedCoreToStripped checkId >=> strippedCoreToTree storedCoreToAnoma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r NockmaTree.AnomaResult storedCoreToAnoma = storedCoreToTree Core.CheckAnoma >=> treeToAnoma @@ -260,6 +267,37 @@ storedCoreToCasm = local (set entryPointFieldSize cairoFieldSize) . storedCoreTo storedCoreToCairo :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Cairo.Result storedCoreToCairo = storedCoreToCasm >=> casmToCairo +-------------------------------------------------------------------------------- +-- Workflows from stripped Core +-------------------------------------------------------------------------------- + +strippedCoreToTree :: Stripped.Module -> Sem r Tree.Module +strippedCoreToTree = return . Tree.fromCore + +strippedCoreToAnoma :: (Members '[Error JuvixError, Reader EntryPoint] r) => Stripped.Module -> Sem r NockmaTree.AnomaResult +strippedCoreToAnoma = strippedCoreToTree >=> treeToAnoma + +strippedCoreToAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Stripped.Module -> Sem r Asm.Module +strippedCoreToAsm = strippedCoreToTree >=> treeToAsm + +strippedCoreToReg :: (Members '[Error JuvixError, Reader EntryPoint] r) => Stripped.Module -> Sem r Reg.Module +strippedCoreToReg = strippedCoreToAsm >=> asmToReg + +strippedCoreToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Stripped.Module -> Sem r C.MiniCResult +strippedCoreToMiniC = strippedCoreToAsm >=> asmToMiniC + +strippedCoreToRust :: (Members '[Error JuvixError, Reader EntryPoint] r) => Stripped.Module -> Sem r Rust.Result +strippedCoreToRust = strippedCoreToTree >=> treeToReg >=> regToRust + +strippedCoreToRiscZeroRust :: (Members '[Error JuvixError, Reader EntryPoint] r) => Stripped.Module -> Sem r Rust.Result +strippedCoreToRiscZeroRust = strippedCoreToTree >=> treeToReg >=> regToRiscZeroRust + +strippedCoreToCasm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Stripped.Module -> Sem r Casm.Result +strippedCoreToCasm = local (set entryPointFieldSize cairoFieldSize) . strippedCoreToTree >=> treeToCasm + +strippedCoreToCairo :: (Members '[Error JuvixError, Reader EntryPoint] r) => Stripped.Module -> Sem r Cairo.Result +strippedCoreToCairo = strippedCoreToCasm >=> casmToCairo + -------------------------------------------------------------------------------- -- Workflows from Core -------------------------------------------------------------------------------- diff --git a/src/Juvix/Compiler/Pipeline/Driver.hs b/src/Juvix/Compiler/Pipeline/Driver.hs index 17c92962ae..19e119477b 100644 --- a/src/Juvix/Compiler/Pipeline/Driver.hs +++ b/src/Juvix/Compiler/Pipeline/Driver.hs @@ -539,7 +539,9 @@ processImports imports = do CompileResult { _compileResultChanged = changed, _compileResultModuleTable = mtab, - _compileResultImportTables = itabs + _compileResultImportTables = + itabs + <> mconcatMap (^. pipelineResultImportTables) ms } where computeImportsTable :: PipelineResult Store.ModuleInfo -> (ModuleId, Core.InfoTable) diff --git a/src/Juvix/Compiler/Pipeline/Modular.hs b/src/Juvix/Compiler/Pipeline/Modular.hs index f7f466f6ab..52b1c845d0 100644 --- a/src/Juvix/Compiler/Pipeline/Modular.hs +++ b/src/Juvix/Compiler/Pipeline/Modular.hs @@ -1,17 +1,19 @@ module Juvix.Compiler.Pipeline.Modular where import Data.List.Singletons (type (++)) +import Juvix.Compiler.Backend import Juvix.Compiler.Core.Data.Module qualified as Core import Juvix.Compiler.Core.Data.Module.Base +import Juvix.Compiler.Core.Data.Stripped.Module qualified as Stripped import Juvix.Compiler.Core.Data.TransformationId qualified as Core import Juvix.Compiler.Pipeline qualified as Pipeline import Juvix.Compiler.Pipeline.EntryPoint -import Juvix.Compiler.Pipeline.Modular.Cache import Juvix.Compiler.Pipeline.Modular.Result import Juvix.Compiler.Store.Backend.Module qualified as Stored import Juvix.Compiler.Tree.Pipeline qualified as Tree import Juvix.Extra.Serialize qualified as Serialize import Juvix.Prelude +import Juvix.Prelude.Pretty import Path qualified type ModularEff r = @@ -22,6 +24,8 @@ type ModularEff r = ] ++ r +type ModuleCache m = Cache ModuleId (PipelineResult m) + processModule :: (Members '[Files, Error JuvixError, Reader EntryPoint, ModuleCache (Module' t)] r) => ModuleId -> @@ -34,22 +38,22 @@ processModuleCacheMiss :: Serialize t', Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint, ModuleCache (Module' t')] r ) => + Target -> ModuleTable' t -> (Module' t -> Sem r (Module' t')) -> ModuleId -> Sem r (PipelineResult (Module' t')) -processModuleCacheMiss mt f mid = do +processModuleCacheMiss midTarget mt f mid = do entry <- ask let root = entry ^. entryPointRoot opts = Stored.fromEntryPoint entry buildDir = resolveAbsBuildDir root (entry ^. entryPointBuildDir) - sourcePath = fromJust (entry ^. entryPointModulePath) relPath = - fromJust - . replaceExtension (Stored.getOptionsExtension opts) - . fromJust - $ stripProperPrefix $(mkAbsDir "/") sourcePath - subdir = Stored.getOptionsSubdir opts + relFile + ( sanitizeFilename (unpack $ prettyText mid) + <> getTargetExtension midTarget + ) + subdir = Stored.getOptionsSubdir midTarget opts absPath = buildDir Path. subdir Path. relPath md0 = lookupModuleTable mt mid sha256 = fromJust (md0 ^. moduleSHA256) @@ -64,20 +68,24 @@ processModuleCacheMiss mt f mid = do case mmd of Just md | md ^. Stored.moduleSHA256 == sha256 - && md ^. Stored.moduleOptions == opts -> do + && md ^. Stored.moduleOptions == opts + && md ^. Stored.moduleId == mid -> do return PipelineResult - { _pipelineResult = Stored.toCoreModule imports md, + { _pipelineResult = Stored.toBaseModule imports md, _pipelineResultChanged = False } + | otherwise -> recompile opts absPath imports md0 _ -> recompile opts absPath imports md0 where recompile :: Stored.Options -> Path Abs File -> [Module' t'] -> Module' t -> Sem r (PipelineResult (Module' t')) recompile opts absPath imports md0 = do md :: Module' t' <- f md0 + massert (md ^. moduleId == mid) + massert (md ^. moduleSHA256 == md0 ^. moduleSHA256) let md' = md {_moduleImportsTable = mconcatMap computeCombinedInfoTable imports} - Serialize.saveToFile absPath (Stored.fromCoreModule opts md') + Serialize.saveToFile absPath (Stored.fromBaseModule opts md') return PipelineResult { _pipelineResult = md', @@ -99,20 +107,36 @@ processImports mids = do processModuleTable :: forall t t' r. (Serialize t', Monoid t', Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint] r) => + Target -> (Module' t -> Sem r (Module' t')) -> ModuleTable' t -> Sem r (ModuleTable' t') -processModuleTable f mt = do +processModuleTable midTarget f mt = do tab <- evalCacheEmpty - (processModuleCacheMiss mt (inject . f)) + (processModuleCacheMiss midTarget mt (inject . f)) $ mapM (fmap (^. pipelineResult) . processModule . (^. moduleId)) (mt ^. moduleTable) return $ ModuleTable tab +modularCoreToStripped :: + (Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint] r) => + Core.TransformationId -> + Core.ModuleTable -> + Sem r Stripped.ModuleTable +modularCoreToStripped checkId mt = + processModuleTable TargetStripped (Pipeline.storedCoreToStripped checkId) mt + modularCoreToTree :: (Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint] r) => Core.TransformationId -> Core.ModuleTable -> Sem r Tree.ModuleTable -modularCoreToTree checkId mt = - processModuleTable (Pipeline.storedCoreToTree checkId) mt +modularCoreToTree checkId = + modularCoreToStripped checkId >=> modularStrippedToTree + +modularStrippedToTree :: + (Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint] r) => + Stripped.ModuleTable -> + Sem r Tree.ModuleTable +modularStrippedToTree mt = + processModuleTable TargetTree Pipeline.strippedCoreToTree mt diff --git a/src/Juvix/Compiler/Store/Backend/Module.hs b/src/Juvix/Compiler/Store/Backend/Module.hs index 02f3ada60d..02b9c1ac11 100644 --- a/src/Juvix/Compiler/Store/Backend/Module.hs +++ b/src/Juvix/Compiler/Store/Backend/Module.hs @@ -46,8 +46,8 @@ lookupModuleTable :: ModuleTable' t -> ModuleId -> Module' t lookupModuleTable mt mid = fromMaybe (impossibleError ("Could not find module " <> prettyText mid)) (lookupModuleTable' mt mid) -toCoreModule :: (Monoid t) => [Core.Module' t] -> Module' t -> Core.Module' t -toCoreModule imports Module {..} = +toBaseModule :: (Monoid t) => [Core.Module' t] -> Module' t -> Core.Module' t +toBaseModule imports Module {..} = Core.Module { _moduleId = _moduleId, _moduleInfoTable = _moduleInfoTable, @@ -56,8 +56,8 @@ toCoreModule imports Module {..} = _moduleSHA256 = Just _moduleSHA256 } -fromCoreModule :: Options -> Core.Module' t -> Module' t -fromCoreModule opts Core.Module {..} = +fromBaseModule :: Options -> Core.Module' t -> Module' t +fromBaseModule opts Core.Module {..} = Module { _moduleId = _moduleId, _moduleInfoTable = _moduleInfoTable, diff --git a/src/Juvix/Compiler/Store/Backend/Options.hs b/src/Juvix/Compiler/Store/Backend/Options.hs index a98ea7640f..471d580152 100644 --- a/src/Juvix/Compiler/Store/Backend/Options.hs +++ b/src/Juvix/Compiler/Store/Backend/Options.hs @@ -2,15 +2,14 @@ module Juvix.Compiler.Store.Backend.Options where import Juvix.Compiler.Backend import Juvix.Compiler.Pipeline.EntryPoint +import Juvix.Compiler.Store.Options qualified as Store import Juvix.Extra.Serialize import Juvix.Prelude import Path qualified data Options = Options - { _optionsDebug :: Bool, - _optionsOptimizationLevel :: Int, - _optionsFieldSize :: Natural, - _optionsTarget :: Maybe Target + { _optionsInfo :: Store.Options, + _optionsFinalTarget :: Maybe Target } deriving stock (Show, Eq, Generic) @@ -21,23 +20,18 @@ instance NFData Options makeLenses ''Options fromEntryPoint :: EntryPoint -> Options -fromEntryPoint EntryPoint {..} = +fromEntryPoint e@EntryPoint {..} = Options - { _optionsDebug = _entryPointDebug, - _optionsOptimizationLevel = _entryPointOptimizationLevel, - _optionsFieldSize = _entryPointFieldSize, - _optionsTarget = _entryPointTarget + { _optionsInfo = Store.fromEntryPoint e, + _optionsFinalTarget = _entryPointTarget } -getOptionsSubdir :: Options -> Path Rel Dir -getOptionsSubdir opts = +getOptionsSubdir :: Target -> Options -> Path Rel Dir +getOptionsSubdir midTarget opts = subdir1 - Path. maybe $(mkRelDir "default") getTargetSubdir (opts ^. optionsTarget) + Path. maybe $(mkRelDir "default") (getTargetSubdir midTarget) (opts ^. optionsFinalTarget) where subdir1 = if - | opts ^. optionsDebug -> $(mkRelDir "debug") + | opts ^. optionsInfo . Store.optionsDebug -> $(mkRelDir "debug") | otherwise -> $(mkRelDir "release") - -getOptionsExtension :: Options -> String -getOptionsExtension opts = maybe ".bin" getTargetExtension (opts ^. optionsTarget) diff --git a/src/Juvix/Compiler/Tree/Transformation/FilterUnreachable.hs b/src/Juvix/Compiler/Tree/Transformation/FilterUnreachable.hs index 50f343c526..e493628c02 100644 --- a/src/Juvix/Compiler/Tree/Transformation/FilterUnreachable.hs +++ b/src/Juvix/Compiler/Tree/Transformation/FilterUnreachable.hs @@ -5,10 +5,13 @@ import Juvix.Compiler.Tree.Data.CallGraph import Juvix.Compiler.Tree.Data.Module import Juvix.Prelude -filterUnreachable :: Module -> Module -filterUnreachable md - | isJust (md ^. moduleInfoTable . infoMainFunction) = - over (moduleInfoTable . infoFunctions) (HashMap.filterWithKey (const . isReachable graph)) md - | otherwise = md +filterUnreachable' :: InfoTable -> InfoTable +filterUnreachable' tab + | isJust (tab ^. infoMainFunction) = + over infoFunctions (HashMap.filterWithKey (const . isReachable graph)) tab + | otherwise = tab where - graph = createCallGraph (md ^. moduleInfoTable) + graph = createCallGraph tab + +filterUnreachable :: Module -> Module +filterUnreachable = over moduleInfoTable filterUnreachable' diff --git a/src/Juvix/Compiler/Tree/Translation/FromCore.hs b/src/Juvix/Compiler/Tree/Translation/FromCore.hs index 939d89dead..94788f81aa 100644 --- a/src/Juvix/Compiler/Tree/Translation/FromCore.hs +++ b/src/Juvix/Compiler/Tree/Translation/FromCore.hs @@ -1,6 +1,5 @@ module Juvix.Compiler.Tree.Translation.FromCore where -import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Core.Data.BinderList qualified as BL import Juvix.Compiler.Core.Data.Stripped.Module qualified as Core import Juvix.Compiler.Core.Language.Stripped qualified as Core @@ -12,23 +11,25 @@ import Juvix.Compiler.Tree.Language type BinderList = BL.BinderList fromCore :: Core.Module -> Module -fromCore Core.Module {..} = +fromCore md@Core.Module {..} = Module { _moduleId = _moduleId, - _moduleInfoTable = fromCore' _moduleInfoTable, + _moduleInfoTable = fromCore' md, _moduleImports = _moduleImports, _moduleImportsTable = mempty, _moduleSHA256 = _moduleSHA256 } -fromCore' :: Core.InfoTable -> InfoTable -fromCore' tab = +fromCore' :: Core.Module -> InfoTable +fromCore' md = InfoTable { _infoMainFunction = tab ^. Core.infoMain, - _infoFunctions = genCode tab <$> tab ^. Core.infoFunctions, + _infoFunctions = genCode md <$> tab ^. Core.infoFunctions, _infoInductives = translateInductiveInfo <$> tab ^. Core.infoInductives, _infoConstrs = translateConstructorInfo <$> tab ^. Core.infoConstructors } + where + tab = md ^. Core.moduleInfoTable toTreeOp :: Core.BuiltinOp -> TreeOp toTreeOp = \case @@ -95,8 +96,8 @@ toTreeOp = \case Core.OpByteArrayLength -> TreeByteArrayOp OpByteArrayLength -- Generate code for a single function. -genCode :: Core.InfoTable -> Core.FunctionInfo -> FunctionInfo -genCode infoTable fi = +genCode :: Core.Module -> Core.FunctionInfo -> FunctionInfo +genCode md fi = let argnames = map (Just . (^. Core.argumentName)) (fi ^. Core.functionArgsInfo) bl = BL.fromList . reverse $ @@ -368,9 +369,7 @@ genCode infoTable fi = getArgsNum :: Symbol -> Int getArgsNum sym = - fromMaybe - impossible - (HashMap.lookup sym (infoTable ^. Core.infoFunctions)) + Core.lookupFunInfo md sym ^. Core.functionArgsNum -- | Be mindful that JuvixTree types are explicitly uncurried, while diff --git a/src/Juvix/Prelude/Path.hs b/src/Juvix/Prelude/Path.hs index 8075a197f4..07be0cdcdf 100644 --- a/src/Juvix/Prelude/Path.hs +++ b/src/Juvix/Prelude/Path.hs @@ -151,3 +151,6 @@ writeFile p bs = do pathFileToPathDir :: Path Abs File -> Path Abs Dir pathFileToPathDir = absDir . toFilePath + +sanitizeFilename :: String -> FilePath +sanitizeFilename = map (\c -> if isAlphaNum c || c `elem` (".-_" :: String) then c else '_') From 01b6e8b28d7500bbcbac28f9a63678a20cf3a15e Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Fri, 21 Feb 2025 10:33:13 +0100 Subject: [PATCH 20/24] use backend modularization in compilation pipeline tests --- .../Core/Transformation/RemoveTypeArgs.hs | 2 +- test/Base.hs | 30 ++++++++ test/Compilation/Base.hs | 37 ++++++---- test/Core/Compile/Base.hs | 16 ++--- test/Tree.hs | 3 +- test/Tree/Compile.hs | 7 ++ test/Tree/Compile/Base.hs | 71 +++++++++++++++++++ test/Tree/Compile/Positive.hs | 25 +++++++ test/Tree/Eval/Base.hs | 48 ++++++++----- 9 files changed, 195 insertions(+), 44 deletions(-) create mode 100644 test/Tree/Compile.hs create mode 100644 test/Tree/Compile/Base.hs create mode 100644 test/Tree/Compile/Positive.hs diff --git a/src/Juvix/Compiler/Core/Transformation/RemoveTypeArgs.hs b/src/Juvix/Compiler/Core/Transformation/RemoveTypeArgs.hs index 099be3a9cc..0d98ae3c0f 100644 --- a/src/Juvix/Compiler/Core/Transformation/RemoveTypeArgs.hs +++ b/src/Juvix/Compiler/Core/Transformation/RemoveTypeArgs.hs @@ -153,7 +153,7 @@ convertInductive md ii = tyargs = typeArgs (ii ^. inductiveKind) ty' = convertNode md (ii ^. inductiveKind) --- | Remove type arguments and type abstractions. +-- | Removes type arguments and type abstractions. -- -- Also adjusts the types, removing quantification over types and replacing all -- type variables with the dynamic type. diff --git a/test/Base.hs b/test/Base.hs index ef8ea865da..4d61065236 100644 --- a/test/Base.hs +++ b/test/Base.hs @@ -15,14 +15,21 @@ import Control.Exception qualified as E import Control.Monad.Extra as Monad import Data.Algorithm.Diff import Data.Algorithm.DiffOutput +import Data.HashMap.Strict qualified as HashMap import GHC.Generics qualified as GHC import Juvix.Compiler.Backend (Target (TargetAnoma)) +import Juvix.Compiler.Core qualified as Core import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination import Juvix.Compiler.Nockma.Language hiding (Path) import Juvix.Compiler.Nockma.Translation.FromTree (anomaClosure) +import Juvix.Compiler.Pipeline qualified as Pipeline import Juvix.Compiler.Pipeline.EntryPoint.IO import Juvix.Compiler.Pipeline.Loader.PathResolver +import Juvix.Compiler.Pipeline.Modular +import Juvix.Compiler.Pipeline.Modular.Run qualified as Pipeline.Modular import Juvix.Compiler.Pipeline.Run +import Juvix.Compiler.Store.Extra qualified as Store +import Juvix.Compiler.Store.Language qualified as Store import Juvix.Data.Effect.TaggedLock import Juvix.Extra.Paths hiding (rootBuildDir) import Juvix.Prelude hiding (assert, readProcess) @@ -109,6 +116,29 @@ testRunIO e = testTaggedLockedToIO . runIO defaultGenericOptions e +testRunIOModular :: + forall a m. + (MonadIO m) => + EntryPoint -> + (forall r. Core.ModuleTable -> Sem (ModularEff r) a) -> + m (Either JuvixError (ModuleId, a)) +testRunIOModular entry f = testTaggedLockedToIO $ do + r <- runIOEither entry Pipeline.upToStoredCore + case r of + Left e -> return $ Left e + Right (_, res) -> do + let md = res ^. pipelineResult . Core.coreResultModule + mtab = + over Core.moduleTable (HashMap.insert (md ^. Core.moduleId) md) + . Store.toCoreModuleTable (res ^. pipelineResultImportTables) + . HashMap.elems + $ res ^. pipelineResultImports . Store.moduleTable + ea <- Pipeline.Modular.runIOEitherPipeline entry (inject (f mtab)) + case ea of + Left e -> return $ Left e + Right a -> + return $ Right (md ^. Core.moduleId, a) + testDefaultEntryPointIO :: (MonadIO m) => Path Abs Dir -> Path Abs File -> m EntryPoint testDefaultEntryPointIO cwd mainFile = testTaggedLockedToIO $ diff --git a/test/Compilation/Base.hs b/test/Compilation/Base.hs index 9b0ac1e931..b7576ab42c 100644 --- a/test/Compilation/Base.hs +++ b/test/Compilation/Base.hs @@ -1,9 +1,14 @@ module Compilation.Base where import Base -import Core.Compile.Base -import Core.Eval.Base +import Data.HashMap.Strict qualified as HashMap +import Juvix.Compiler.Backend import Juvix.Compiler.Core qualified as Core +import Juvix.Compiler.Pipeline.Modular (modularCoreToTree) +import Juvix.Compiler.Tree.Data.Module qualified as Tree +import Juvix.Prelude.Pretty +import Tree.Compile.Base +import Tree.Eval.Base data CompileAssertionMode = EvalOnly @@ -19,7 +24,11 @@ compileAssertion :: Path Abs File -> (String -> IO ()) -> Assertion -compileAssertion = compileAssertionEntry (set entryPointPipeline (Just PipelineExec)) +compileAssertion = + compileAssertionEntry + ( set entryPointTarget (Just TargetCNative64) + . set entryPointPipeline (Just PipelineExec) + ) compileAssertionEntry :: (EntryPoint -> EntryPoint) -> @@ -31,16 +40,20 @@ compileAssertionEntry :: (String -> IO ()) -> Assertion compileAssertionEntry adjustEntry root' optLevel mode mainFile expectedFile step = do - step "Translate to JuvixCore" + step "Translate to JuvixTree" entryPoint <- adjustEntry <$> testDefaultEntryPointIO root' mainFile - PipelineResult {..} <- snd <$> testRunIO entryPoint upToStoredCore - let tab' = Core.computeCombinedInfoTable (_pipelineResult ^. Core.coreResultModule) - evalAssertion = coreEvalAssertion' EvalModePlain tab' mainFile expectedFile step - compileAssertion' stdinText = coreCompileAssertion' entryPoint optLevel tab' mainFile expectedFile stdinText step - case mode of - EvalOnly -> evalAssertion - CompileOnly stdinText -> compileAssertion' stdinText - EvalAndCompile -> evalAssertion >> compileAssertion' "" + r <- testRunIOModular entryPoint (modularCoreToTree Core.CheckExec) + case r of + Left e -> assertFailure (prettyString (fromJuvixError @GenericError e)) + Right (mid, mtab) -> do + let md = fromJust $ HashMap.lookup mid (mtab ^. Core.moduleTable) + tab' = Tree.computeCombinedInfoTable md + evalAssertion = treeEvalAssertion' (Tree.moduleFromInfoTable tab') expectedFile step + compileAssertion' stdinText = treeCompileAssertion' entryPoint optLevel tab' mainFile expectedFile stdinText step + case mode of + EvalOnly -> evalAssertion + CompileOnly stdinText -> compileAssertion' stdinText + EvalAndCompile -> evalAssertion >> compileAssertion' "" compileErrorAssertion :: Path Abs Dir -> diff --git a/test/Core/Compile/Base.hs b/test/Core/Compile/Base.hs index ba93af38b7..e0dfe55a10 100644 --- a/test/Core/Compile/Base.hs +++ b/test/Core/Compile/Base.hs @@ -6,15 +6,10 @@ import Core.Eval.Base import Core.Eval.Positive qualified as Eval import GHC.Base (seq) import Juvix.Compiler.Asm.Pretty qualified as Asm -import Juvix.Compiler.Asm.Translation.FromTree qualified as Asm import Juvix.Compiler.Core.Data.Module -import Juvix.Compiler.Core.Data.TransformationId -import Juvix.Compiler.Core.Extra.Utils import Juvix.Compiler.Core.Pipeline import Juvix.Compiler.Core.Translation.FromSource -import Juvix.Compiler.Core.Translation.Stripped.FromCore qualified as Stripped import Juvix.Compiler.Pipeline.EntryPoint qualified as EntryPoint -import Juvix.Compiler.Tree.Translation.FromCore qualified as Tree import Juvix.Data.PPOutput newtype Test = Test @@ -50,14 +45,11 @@ coreCompileAssertion' :: Assertion coreCompileAssertion' entryPoint optLevel tab mainFile expectedFile stdinText step = do step "Translate to JuvixAsm" - case run . runReader entryPoint' . runError $ toStripped CheckExec (moduleFromInfoTable tab) of + case run . runReader entryPoint' . runError $ storedCoreToAsm (moduleFromInfoTable tab) of Left err -> assertFailure (prettyString (fromJuvixError @GenericError err)) - Right m -> do - let tab0 = computeCombinedInfoTable m - assertBool "Check info table" (checkInfoTable tab0) - let md' = Asm.fromTree . Tree.fromCore $ Stripped.fromCore m - length (fromText (Asm.ppPrint md' (computeCombinedInfoTable md')) :: String) `seq` - Asm.asmCompileAssertion' entryPoint' optLevel md' mainFile expectedFile stdinText step + Right md -> do + length (fromText (Asm.ppPrint md (computeCombinedInfoTable md)) :: String) `seq` + Asm.asmCompileAssertion' entryPoint' optLevel md mainFile expectedFile stdinText step where entryPoint' = entryPoint {_entryPointOptimizationLevel = optLevel} diff --git a/test/Tree.hs b/test/Tree.hs index cecd03ea2f..649a0fea58 100644 --- a/test/Tree.hs +++ b/test/Tree.hs @@ -2,9 +2,10 @@ module Tree where import Base import Tree.Asm qualified as Asm +import Tree.Compile qualified as Compile import Tree.Eval qualified as Eval import Tree.Parse qualified as Parse import Tree.Transformation qualified as Transformation allTests :: TestTree -allTests = testGroup "JuvixTree tests" [Parse.allTests, Eval.allTests, Asm.allTests, Transformation.allTests] +allTests = testGroup "JuvixTree tests" [Parse.allTests, Eval.allTests, Asm.allTests, Compile.allTests, Transformation.allTests] diff --git a/test/Tree/Compile.hs b/test/Tree/Compile.hs new file mode 100644 index 0000000000..8ad2b4acf5 --- /dev/null +++ b/test/Tree/Compile.hs @@ -0,0 +1,7 @@ +module Tree.Compile where + +import Base +import Tree.Compile.Positive qualified as P + +allTests :: TestTree +allTests = testGroup "JuvixTree compilation tests" [P.allTests] diff --git a/test/Tree/Compile/Base.hs b/test/Tree/Compile/Base.hs new file mode 100644 index 0000000000..160f85bb2b --- /dev/null +++ b/test/Tree/Compile/Base.hs @@ -0,0 +1,71 @@ +module Tree.Compile.Base where + +import Asm.Compile.Base qualified as Asm +import Base +import GHC.Base (seq) +import Juvix.Compiler.Asm.Pretty qualified as Asm +import Juvix.Compiler.Pipeline.EntryPoint qualified as EntryPoint +import Juvix.Compiler.Tree.Data.Module +import Juvix.Compiler.Tree.Translation.FromSource +import Juvix.Data.PPOutput +import Tree.Eval.Positive qualified as Eval + +newtype Test = Test + { _testEval :: Eval.PosTest + } + +fromTest :: Test -> TestTree +fromTest = mkTest . toTestDescr + +root :: Path Abs Dir +root = relToProject $(mkRelDir "tests/Tree/positive/") + +toTestDescr :: Test -> TestDescr +toTestDescr Test {..} = + let Eval.PosTest {..} = _testEval + tRoot = root _relDir + file' = tRoot _file + expected' = tRoot _expectedFile + in TestDescr + { _testName = _name, + _testRoot = tRoot, + _testAssertion = Steps $ treeCompileAssertion tRoot file' expected' "" + } + +treeCompileAssertion' :: + EntryPoint -> + Int -> + InfoTable -> + Path Abs File -> + Path Abs File -> + Text -> + (String -> IO ()) -> + Assertion +treeCompileAssertion' entryPoint optLevel tab mainFile expectedFile stdinText step = do + step "Translate to JuvixAsm" + case run . runReader entryPoint' . runError $ treeToAsm (moduleFromInfoTable tab) of + Left err -> assertFailure (prettyString (fromJuvixError @GenericError err)) + Right md -> do + length (fromText (Asm.ppPrint md (computeCombinedInfoTable md)) :: String) `seq` + Asm.asmCompileAssertion' entryPoint' optLevel md mainFile expectedFile stdinText step + where + entryPoint' = entryPoint {_entryPointOptimizationLevel = optLevel} + +treeCompileAssertion :: + Path Abs Dir -> + Path Abs File -> + Path Abs File -> + Text -> + (String -> IO ()) -> + Assertion +treeCompileAssertion root' mainFile expectedFile stdinText step = do + step "Parse" + s <- readFile mainFile + case runParser mainFile s of + Left err -> assertFailure (prettyString err) + Right md -> do + entryPoint <- + set entryPointPipeline (Just EntryPoint.PipelineExec) + <$> testDefaultEntryPointIO root' mainFile + let tab = computeCombinedInfoTable md + treeCompileAssertion' entryPoint 3 tab mainFile expectedFile stdinText step diff --git a/test/Tree/Compile/Positive.hs b/test/Tree/Compile/Positive.hs new file mode 100644 index 0000000000..b085a2a1fb --- /dev/null +++ b/test/Tree/Compile/Positive.hs @@ -0,0 +1,25 @@ +module Tree.Compile.Positive where + +import Base +import Tree.Compile.Base +import Tree.Eval.Positive qualified as Eval + +testDescr :: Eval.PosTest -> TestDescr +testDescr Eval.PosTest {..} = + let tRoot = Eval.root _relDir + file' = tRoot _file + expected' = tRoot _expectedFile + in TestDescr + { _testName = _name, + _testRoot = tRoot, + _testAssertion = Steps $ treeCompileAssertion tRoot file' expected' "" + } + +ignoredTests :: [String] +ignoredTests = ["Test040: ByteArray"] + +allTests :: TestTree +allTests = + testGroup + "JuvixTree compilation positive tests" + (map (mkTest . testDescr) (Eval.filterOutTests ignoredTests Eval.tests)) diff --git a/test/Tree/Eval/Base.hs b/test/Tree/Eval/Base.hs index 4875d8592a..40c5e06754 100644 --- a/test/Tree/Eval/Base.hs +++ b/test/Tree/Eval/Base.hs @@ -20,7 +20,7 @@ treeEvalAssertion :: (Module -> Assertion) -> (String -> IO ()) -> Assertion -treeEvalAssertion = treeEvalAssertionParam evalAssertion +treeEvalAssertion = treeEvalAssertionParam doEvalAssertion treeEvalAssertionParam :: (Handle -> Symbol -> Module -> IO ()) -> @@ -47,24 +47,36 @@ treeEvalAssertionParam evalParam mainFile expectedFile trans testTrans step = do Left err -> assertFailure (prettyString (fromJuvixError @GenericError err)) Right md -> do testTrans md - case md ^. moduleInfoTable . infoMainFunction of - Just sym -> do - withTempDir' - ( \dirPath -> do - let outputFile = dirPath $(mkRelFile "out.out") - hout <- openFile (toFilePath outputFile) WriteMode - step "Evaluate" - evalParam hout sym md - hClose hout - actualOutput <- readFile outputFile - step "Compare expected and actual program output" - expected <- readFile expectedFile - assertEqDiffText ("Check: RUN output = " <> toFilePath expectedFile) actualOutput expected - ) - Nothing -> assertFailure "no 'main' function" + treeEvalAssertionParam' evalParam md expectedFile step -evalAssertion :: Handle -> Symbol -> Module -> IO () -evalAssertion hout sym md = do +treeEvalAssertionParam' :: + (Handle -> Symbol -> Module -> IO ()) -> + Module -> + Path Abs File -> + (String -> IO ()) -> + Assertion +treeEvalAssertionParam' evalParam md expectedFile step = + case md ^. moduleInfoTable . infoMainFunction of + Just sym -> do + withTempDir' + ( \dirPath -> do + let outputFile = dirPath $(mkRelFile "out.out") + hout <- openFile (toFilePath outputFile) WriteMode + step "Evaluate" + evalParam hout sym md + hClose hout + actualOutput <- readFile outputFile + step "Compare expected and actual program output" + expected <- readFile expectedFile + assertEqDiffText ("Check: RUN output = " <> toFilePath expectedFile) actualOutput expected + ) + Nothing -> assertFailure "no 'main' function" + +treeEvalAssertion' :: Module -> Path Abs File -> (String -> IO ()) -> Assertion +treeEvalAssertion' = treeEvalAssertionParam' doEvalAssertion + +doEvalAssertion :: Handle -> Symbol -> Module -> IO () +doEvalAssertion hout sym md = do r' <- doEval hout md (lookupFunInfo md sym) case r' of Left err -> do From d0e7b1c4ade2bf27cdc00782f13b78dfdd1559f3 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Fri, 21 Feb 2025 15:55:58 +0100 Subject: [PATCH 21/24] runIOEitherModular --- app/App.hs | 21 +++--------- app/Commands/Dev/DevCompile/Tree.hs | 3 +- src/Juvix/Compiler/Core/Pipeline.hs | 7 ++++ src/Juvix/Compiler/Pipeline/Modular.hs | 10 +++--- src/Juvix/Compiler/Pipeline/Modular/Run.hs | 36 ++++++++++++++++++++ test/Base.hs | 38 ++++++++++------------ test/Compilation/Base.hs | 10 ++++-- test/Tree.hs | 2 +- 8 files changed, 78 insertions(+), 49 deletions(-) diff --git a/app/App.hs b/app/App.hs index 825bb63394..8dbed86b88 100644 --- a/app/App.hs +++ b/app/App.hs @@ -2,21 +2,17 @@ module App where import CommonOptions import Data.ByteString qualified as ByteString -import Data.HashMap.Strict qualified as HashMap import GlobalOptions import Juvix.Compiler.Backend.Markdown.Error import Juvix.Compiler.Core.Data.Module qualified as Core -import Juvix.Compiler.Core.Translation.FromInternal.Data.Context qualified as Core +import Juvix.Compiler.Core.Data.TransformationId qualified as Core import Juvix.Compiler.Internal.Translation (InternalTypedResult) import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination.Checker -import Juvix.Compiler.Pipeline qualified as Pipeline import Juvix.Compiler.Pipeline.Loader.PathResolver import Juvix.Compiler.Pipeline.Modular (ModularEff) import Juvix.Compiler.Pipeline.Modular.Run qualified as Pipeline.Modular import Juvix.Compiler.Pipeline.Root import Juvix.Compiler.Pipeline.Run -import Juvix.Compiler.Store.Extra qualified as Store -import Juvix.Compiler.Store.Language qualified as Store import Juvix.Data.Error qualified as Error import Juvix.Data.SHA256 qualified as SHA256 import Juvix.Extra.Paths.Base hiding (rootBuildDir) @@ -356,21 +352,12 @@ runPipelineModular :: (Members '[App, EmbedIO, Logger, TaggedLock] r, EntryPointOptions opts) => opts -> Maybe (AppPath File) -> + Maybe Core.TransformationId -> (Core.ModuleTable -> Sem (ModularEff r) a) -> Sem r (ModuleId, a) -runPipelineModular opts input_ f = runPipelineOptions $ do +runPipelineModular opts input_ checkId f = runPipelineOptions $ do entry <- getEntryPoint'' opts input_ - let p :: Sem (PipelineEff r) Core.CoreResult = Pipeline.upToStoredCore - r <- runIOEither entry (inject p) >>= fromRightJuvixError - let res = snd r - md = res ^. pipelineResult . Core.coreResultModule - mtab = - over Core.moduleTable (HashMap.insert (md ^. Core.moduleId) md) - . Store.toCoreModuleTable (res ^. pipelineResultImportTables) - . HashMap.elems - $ res ^. pipelineResultImports . Store.moduleTable - a <- Pipeline.Modular.runIOEitherPipeline entry (inject (f mtab)) >>= fromRightJuvixError - return (md ^. Core.moduleId, a) + Pipeline.Modular.runIOEitherModular checkId entry (inject . f) >>= fromRightJuvixError renderStdOutLn :: forall a r. (Member App r, HasAnsiBackend a, HasTextBackend a) => a -> Sem r () renderStdOutLn txt = renderStdOut txt >> newline diff --git a/app/Commands/Dev/DevCompile/Tree.hs b/app/Commands/Dev/DevCompile/Tree.hs index f14944e835..f112984c62 100644 --- a/app/Commands/Dev/DevCompile/Tree.hs +++ b/app/Commands/Dev/DevCompile/Tree.hs @@ -3,7 +3,6 @@ module Commands.Dev.DevCompile.Tree where import Commands.Base import Commands.Dev.DevCompile.Tree.Options import Commands.Extra.NewCompile -import Juvix.Compiler.Core.Data.TransformationId qualified as Core import Juvix.Compiler.Pipeline.Modular (modularCoreToTree) import Juvix.Compiler.Tree.Data.Module import Juvix.Compiler.Tree.Pretty @@ -17,7 +16,7 @@ runCommand opts = do let inputFile = opts ^. treeCompileCommonOptions . compileInputFile moutputFile = opts ^. treeCompileCommonOptions . compileOutputFile outFile :: Path Abs File <- getOutputFile FileExtJuvixTree inputFile moutputFile - (mid, mtab) <- runPipelineModular opts inputFile (modularCoreToTree Core.IdentityTrans) + (mid, mtab) <- runPipelineModular opts inputFile Nothing modularCoreToTree let md = filterUnreachable (combineInfoTables (lookupModuleTable mtab mid)) txt = ppPrint md (md ^. moduleInfoTable) writeFileEnsureLn outFile txt diff --git a/src/Juvix/Compiler/Core/Pipeline.hs b/src/Juvix/Compiler/Core/Pipeline.hs index befc90419d..c873c77f93 100644 --- a/src/Juvix/Compiler/Core/Pipeline.hs +++ b/src/Juvix/Compiler/Core/Pipeline.hs @@ -37,3 +37,10 @@ toStripped checkId md = do let checkId' = if noCheck then IdentityTrans else checkId mapReader fromEntryPoint $ applyTransformations (toStrippedTransformations checkId') md + +checkModule :: (Members '[Error JuvixError, Reader EntryPoint] r) => TransformationId -> Module -> Sem r () +checkModule checkId md = do + noCheck <- asks (^. entryPointNoCheck) + let checkId' = if noCheck then IdentityTrans else checkId + mapReader fromEntryPoint $ + void (applyTransformations [CombineInfoTables, FilterUnreachable, checkId'] md) diff --git a/src/Juvix/Compiler/Pipeline/Modular.hs b/src/Juvix/Compiler/Pipeline/Modular.hs index 52b1c845d0..2e06f1871b 100644 --- a/src/Juvix/Compiler/Pipeline/Modular.hs +++ b/src/Juvix/Compiler/Pipeline/Modular.hs @@ -120,19 +120,17 @@ processModuleTable midTarget f mt = do modularCoreToStripped :: (Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint] r) => - Core.TransformationId -> Core.ModuleTable -> Sem r Stripped.ModuleTable -modularCoreToStripped checkId mt = - processModuleTable TargetStripped (Pipeline.storedCoreToStripped checkId) mt +modularCoreToStripped mt = + processModuleTable TargetStripped (Pipeline.storedCoreToStripped Core.IdentityTrans) mt modularCoreToTree :: (Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint] r) => - Core.TransformationId -> Core.ModuleTable -> Sem r Tree.ModuleTable -modularCoreToTree checkId = - modularCoreToStripped checkId >=> modularStrippedToTree +modularCoreToTree = + modularCoreToStripped >=> modularStrippedToTree modularStrippedToTree :: (Members '[Files, TaggedLock, Error JuvixError, Reader EntryPoint] r) => diff --git a/src/Juvix/Compiler/Pipeline/Modular/Run.hs b/src/Juvix/Compiler/Pipeline/Modular/Run.hs index a6d06f7435..6ce43312a9 100644 --- a/src/Juvix/Compiler/Pipeline/Modular/Run.hs +++ b/src/Juvix/Compiler/Pipeline/Modular/Run.hs @@ -1,8 +1,14 @@ module Juvix.Compiler.Pipeline.Modular.Run where +import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Concrete.Data.Highlight +import Juvix.Compiler.Core qualified as Core +import Juvix.Compiler.Pipeline qualified as Pipeline import Juvix.Compiler.Pipeline.EntryPoint import Juvix.Compiler.Pipeline.Modular +import Juvix.Compiler.Pipeline.Run qualified as Pipeline +import Juvix.Compiler.Store.Extra qualified as Store +import Juvix.Compiler.Store.Language qualified as Store import Juvix.Prelude runIOEitherPipeline :: @@ -17,3 +23,33 @@ runIOEitherPipeline entry a = . runReader entry . runFilesIO $ inject a + +runIOEitherModular :: + forall a r. + (Members '[TaggedLock, EmbedIO, Logger, Reader Pipeline.PipelineOptions] r) => + Maybe Core.TransformationId -> + EntryPoint -> + (Core.ModuleTable -> Sem (ModularEff r) a) -> + Sem r (Either JuvixError (ModuleId, a)) +runIOEitherModular mcheckId entry f = do + r <- Pipeline.runIOEither entry Pipeline.upToStoredCore + case r of + Left e -> return $ Left e + Right (_, res) -> do + let md = res ^. Pipeline.pipelineResult . Core.coreResultModule + mtab = + over Core.moduleTable (HashMap.insert (md ^. Core.moduleId) md) + . Store.toCoreModuleTable (res ^. Pipeline.pipelineResultImportTables) + . HashMap.elems + $ res ^. Pipeline.pipelineResultImports . Store.moduleTable + merror <- case mcheckId of + Nothing -> return $ Right () + Just checkId -> runIOEitherPipeline entry (Core.checkModule checkId md) + case merror of + Left e -> return $ Left e + Right () -> do + ea <- runIOEitherPipeline entry (inject (f mtab)) + case ea of + Left e -> return $ Left e + Right a -> + return $ Right (md ^. Core.moduleId, a) diff --git a/test/Base.hs b/test/Base.hs index 4d61065236..f6868d46c8 100644 --- a/test/Base.hs +++ b/test/Base.hs @@ -15,22 +15,19 @@ import Control.Exception qualified as E import Control.Monad.Extra as Monad import Data.Algorithm.Diff import Data.Algorithm.DiffOutput -import Data.HashMap.Strict qualified as HashMap import GHC.Generics qualified as GHC import Juvix.Compiler.Backend (Target (TargetAnoma)) import Juvix.Compiler.Core qualified as Core import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.Termination import Juvix.Compiler.Nockma.Language hiding (Path) import Juvix.Compiler.Nockma.Translation.FromTree (anomaClosure) -import Juvix.Compiler.Pipeline qualified as Pipeline import Juvix.Compiler.Pipeline.EntryPoint.IO import Juvix.Compiler.Pipeline.Loader.PathResolver import Juvix.Compiler.Pipeline.Modular import Juvix.Compiler.Pipeline.Modular.Run qualified as Pipeline.Modular import Juvix.Compiler.Pipeline.Run -import Juvix.Compiler.Store.Extra qualified as Store -import Juvix.Compiler.Store.Language qualified as Store import Juvix.Data.Effect.TaggedLock +import Juvix.Data.SHA256 qualified as SHA256 import Juvix.Extra.Paths hiding (rootBuildDir) import Juvix.Prelude hiding (assert, readProcess) import Juvix.Prelude.Env @@ -119,25 +116,26 @@ testRunIO e = testRunIOModular :: forall a m. (MonadIO m) => + Maybe Core.TransformationId -> EntryPoint -> (forall r. Core.ModuleTable -> Sem (ModularEff r) a) -> m (Either JuvixError (ModuleId, a)) -testRunIOModular entry f = testTaggedLockedToIO $ do - r <- runIOEither entry Pipeline.upToStoredCore - case r of - Left e -> return $ Left e - Right (_, res) -> do - let md = res ^. pipelineResult . Core.coreResultModule - mtab = - over Core.moduleTable (HashMap.insert (md ^. Core.moduleId) md) - . Store.toCoreModuleTable (res ^. pipelineResultImportTables) - . HashMap.elems - $ res ^. pipelineResultImports . Store.moduleTable - ea <- Pipeline.Modular.runIOEitherPipeline entry (inject (f mtab)) - case ea of - Left e -> return $ Left e - Right a -> - return $ Right (md ^. Core.moduleId, a) +testRunIOModular checkId entry f = do + entry' <- setEntryPointSHA256 entry + testTaggedLockedToIO $ + Pipeline.Modular.runIOEitherModular checkId entry' f + +setEntryPointSHA256 :: (MonadIO m) => EntryPoint -> m EntryPoint +setEntryPointSHA256 entry = + case entry ^. entryPointModulePath of + Nothing -> return entry + Just sourceFile -> do + sha256 <- + runM + . runFilesIO + . SHA256.digestFile + $ sourceFile + return $ set entryPointSHA256 (Just sha256) entry testDefaultEntryPointIO :: (MonadIO m) => Path Abs Dir -> Path Abs File -> m EntryPoint testDefaultEntryPointIO cwd mainFile = diff --git a/test/Compilation/Base.hs b/test/Compilation/Base.hs index b7576ab42c..b89607035b 100644 --- a/test/Compilation/Base.hs +++ b/test/Compilation/Base.hs @@ -24,11 +24,14 @@ compileAssertion :: Path Abs File -> (String -> IO ()) -> Assertion -compileAssertion = +compileAssertion root' optLevel = compileAssertionEntry ( set entryPointTarget (Just TargetCNative64) . set entryPointPipeline (Just PipelineExec) + . set entryPointOptimizationLevel optLevel ) + root' + optLevel compileAssertionEntry :: (EntryPoint -> EntryPoint) -> @@ -42,9 +45,10 @@ compileAssertionEntry :: compileAssertionEntry adjustEntry root' optLevel mode mainFile expectedFile step = do step "Translate to JuvixTree" entryPoint <- adjustEntry <$> testDefaultEntryPointIO root' mainFile - r <- testRunIOModular entryPoint (modularCoreToTree Core.CheckExec) + r <- testRunIOModular (Just Core.CheckExec) entryPoint modularCoreToTree case r of - Left e -> assertFailure (prettyString (fromJuvixError @GenericError e)) + Left e -> do + assertFailure (prettyString (fromJuvixError @GenericError e)) Right (mid, mtab) -> do let md = fromJust $ HashMap.lookup mid (mtab ^. Core.moduleTable) tab' = Tree.computeCombinedInfoTable md diff --git a/test/Tree.hs b/test/Tree.hs index 649a0fea58..374d2c739f 100644 --- a/test/Tree.hs +++ b/test/Tree.hs @@ -8,4 +8,4 @@ import Tree.Parse qualified as Parse import Tree.Transformation qualified as Transformation allTests :: TestTree -allTests = testGroup "JuvixTree tests" [Parse.allTests, Eval.allTests, Asm.allTests, Compile.allTests, Transformation.allTests] +allTests = testGroup "JuvixTree tests" [Parse.allTests, Eval.allTests, Asm.allTests, Transformation.allTests, Compile.allTests] From e9b4e75a4e86ac0b5dce3929a3cea4af277b2905 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Mon, 24 Feb 2025 11:10:23 +0100 Subject: [PATCH 22/24] use Core evaluator in pipeline tests --- test/Compilation/Base.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/test/Compilation/Base.hs b/test/Compilation/Base.hs index b89607035b..2ea6d1d6e2 100644 --- a/test/Compilation/Base.hs +++ b/test/Compilation/Base.hs @@ -1,6 +1,7 @@ module Compilation.Base where import Base +import Core.Eval.Base import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Backend import Juvix.Compiler.Core qualified as Core @@ -8,7 +9,6 @@ import Juvix.Compiler.Pipeline.Modular (modularCoreToTree) import Juvix.Compiler.Tree.Data.Module qualified as Tree import Juvix.Prelude.Pretty import Tree.Compile.Base -import Tree.Eval.Base data CompileAssertionMode = EvalOnly @@ -51,9 +51,12 @@ compileAssertionEntry adjustEntry root' optLevel mode mainFile expectedFile step assertFailure (prettyString (fromJuvixError @GenericError e)) Right (mid, mtab) -> do let md = fromJust $ HashMap.lookup mid (mtab ^. Core.moduleTable) - tab' = Tree.computeCombinedInfoTable md - evalAssertion = treeEvalAssertion' (Tree.moduleFromInfoTable tab') expectedFile step - compileAssertion' stdinText = treeCompileAssertion' entryPoint optLevel tab' mainFile expectedFile stdinText step + evalAssertion = do + step "Translate to JuvixCore" + PipelineResult {..} <- snd <$> testRunIO entryPoint upToStoredCore + let tab' = Core.computeCombinedInfoTable (_pipelineResult ^. Core.coreResultModule) + coreEvalAssertion' EvalModePlain tab' mainFile expectedFile step + compileAssertion' stdinText = treeCompileAssertion' entryPoint optLevel (Tree.computeCombinedInfoTable md) mainFile expectedFile stdinText step case mode of EvalOnly -> evalAssertion CompileOnly stdinText -> compileAssertion' stdinText From 5aa6abec5c161f4c345cfb6e6f27865db034578c Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Tue, 25 Feb 2025 11:29:54 +0100 Subject: [PATCH 23/24] remove unused code --- src/Juvix/Compiler/Pipeline/Modular/Cache.hs | 7 ------- 1 file changed, 7 deletions(-) delete mode 100644 src/Juvix/Compiler/Pipeline/Modular/Cache.hs diff --git a/src/Juvix/Compiler/Pipeline/Modular/Cache.hs b/src/Juvix/Compiler/Pipeline/Modular/Cache.hs deleted file mode 100644 index 8efa0ec935..0000000000 --- a/src/Juvix/Compiler/Pipeline/Modular/Cache.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Juvix.Compiler.Pipeline.Modular.Cache where - -import Juvix.Compiler.Pipeline.Modular.Result -import Juvix.Data.Effect.Cache -import Juvix.Data.ModuleId - -type ModuleCache m = Cache ModuleId (PipelineResult m) From dab8de75ae720ef0266353eb87b47d8600fa8a45 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Tue, 25 Feb 2025 11:35:39 +0100 Subject: [PATCH 24/24] changes --- src/Juvix/Compiler/Internal/Extra.hs | 10 +--------- src/Juvix/Compiler/Pipeline/EntryPoint.hs | 1 + 2 files changed, 2 insertions(+), 9 deletions(-) diff --git a/src/Juvix/Compiler/Internal/Extra.hs b/src/Juvix/Compiler/Internal/Extra.hs index 89b15f891e..cdd8ee3427 100644 --- a/src/Juvix/Compiler/Internal/Extra.hs +++ b/src/Juvix/Compiler/Internal/Extra.hs @@ -356,12 +356,4 @@ substituteIndParams = substitutionE . HashMap.fromList . map (first (^. inductiv getInductiveKind :: InductiveDef -> Expression getInductiveKind InductiveDef {..} = - foldr - ( \p f -> - ExpressionFunction $ - Function - (FunctionParameter (Just (p ^. inductiveParamName)) Explicit (p ^. inductiveParamType)) - f - ) - _inductiveType - _inductiveParameters + foldFunType (map inductiveToFunctionParam _inductiveParameters) _inductiveType diff --git a/src/Juvix/Compiler/Pipeline/EntryPoint.hs b/src/Juvix/Compiler/Pipeline/EntryPoint.hs index 5d6f0cf248..435c485d4f 100644 --- a/src/Juvix/Compiler/Pipeline/EntryPoint.hs +++ b/src/Juvix/Compiler/Pipeline/EntryPoint.hs @@ -56,6 +56,7 @@ data EntryPoint = EntryPoint _entryPointFieldSize :: Natural, _entryPointIsabelleOnlyTypes :: Bool, _entryPointPipeline :: Maybe Pipeline, + -- | The SHA256 hash of the source file at _entryPointModulePath _entryPointSHA256 :: Maybe Text } deriving stock (Eq, Show)