From 27306b0fafd4d739f9df5fa405e4074fad23c3b9 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Tue, 16 Jan 2024 11:18:13 +0100 Subject: [PATCH 1/4] factor the Core -> Asm translation --- app/Commands/Dev/Core/Asm.hs | 9 +- src/Juvix/Compiler/Asm/Data/InfoTable.hs | 81 +--- src/Juvix/Compiler/Asm/Extra/Memory.hs | 10 +- src/Juvix/Compiler/Asm/Extra/Type.hs | 46 +-- src/Juvix/Compiler/Asm/Interpreter.hs | 10 +- src/Juvix/Compiler/Asm/Language.hs | 53 +-- src/Juvix/Compiler/Asm/Pretty/Base.hs | 12 +- .../Compiler/Asm/Transformation/StackUsage.hs | 8 +- src/Juvix/Compiler/Asm/Translation.hs | 4 +- .../Compiler/Asm/Translation/FromCore.hs | 374 ------------------ .../Compiler/Asm/Translation/FromSource.hs | 15 +- .../Compiler/Asm/Translation/FromTree.hs | 256 ++++++++++++ src/Juvix/Compiler/Casm/Language/Base.hs | 2 +- src/Juvix/Compiler/Core/Language/Base.hs | 4 +- src/Juvix/Compiler/Core/Language/Nodes.hs | 2 + src/Juvix/Compiler/Pipeline.hs | 14 +- src/Juvix/Compiler/Reg/Language/Base.hs | 6 +- src/Juvix/Compiler/Reg/Translation/FromAsm.hs | 14 +- src/Juvix/Compiler/Tree.hs | 10 + src/Juvix/Compiler/Tree/Data/InfoTable.hs | 12 + .../Compiler/Tree/Data/InfoTable/Base.hs | 83 ++++ src/Juvix/Compiler/Tree/Extra/Type.hs | 43 ++ src/Juvix/Compiler/Tree/Language.hs | 161 ++++++++ src/Juvix/Compiler/Tree/Language/Base.hs | 45 +++ .../Compiler/{Asm => Tree}/Language/Rep.hs | 2 +- .../Compiler/{Asm => Tree}/Language/Type.hs | 2 +- .../Compiler/Tree/Translation/FromCore.hs | 348 ++++++++++++++++ test/Core/Asm/Base.hs | 5 +- test/Core/Compile/Base.hs | 5 +- 29 files changed, 1054 insertions(+), 582 deletions(-) delete mode 100644 src/Juvix/Compiler/Asm/Translation/FromCore.hs create mode 100644 src/Juvix/Compiler/Asm/Translation/FromTree.hs create mode 100644 src/Juvix/Compiler/Tree.hs create mode 100644 src/Juvix/Compiler/Tree/Data/InfoTable.hs create mode 100644 src/Juvix/Compiler/Tree/Data/InfoTable/Base.hs create mode 100644 src/Juvix/Compiler/Tree/Extra/Type.hs create mode 100644 src/Juvix/Compiler/Tree/Language.hs create mode 100644 src/Juvix/Compiler/Tree/Language/Base.hs rename src/Juvix/Compiler/{Asm => Tree}/Language/Rep.hs (98%) rename src/Juvix/Compiler/{Asm => Tree}/Language/Type.hs (97%) create mode 100644 src/Juvix/Compiler/Tree/Translation/FromCore.hs diff --git a/app/Commands/Dev/Core/Asm.hs b/app/Commands/Dev/Core/Asm.hs index f79c40ac55..52fd1b8799 100644 --- a/app/Commands/Dev/Core/Asm.hs +++ b/app/Commands/Dev/Core/Asm.hs @@ -5,16 +5,15 @@ import Commands.Base import Commands.Dev.Core.Asm.Options import Juvix.Compiler.Asm qualified as Asm import Juvix.Compiler.Core qualified as Core -import Juvix.Compiler.Core.Translation.Stripped.FromCore qualified as Stripped -runCommand :: forall r a. (Members '[Embed IO, App] r, CanonicalProjection a CoreAsmOptions) => a -> Sem r () +runCommand :: forall r a. (Members '[Embed IO, App, TaggedLock] r, CanonicalProjection a CoreAsmOptions) => a -> Sem r () runCommand opts = do - gopts <- askGlobalOptions inputFile :: Path Abs File <- fromAppPathFile sinputFile + ep <- getEntryPoint sinputFile s' <- readFile $ toFilePath inputFile tab <- getRight (mapLeft JuvixError (Core.runParserMain inputFile defaultModuleId mempty s')) - r <- runReader (project @GlobalOptions @Core.CoreOptions gopts) $ runError @JuvixError $ Core.toStripped' (Core.moduleFromInfoTable tab) - tab' <- Asm.fromCore . Stripped.fromCore . Core.computeCombinedInfoTable <$> getRight r + r <- runReader ep $ runError @JuvixError $ coreToAsm (Core.moduleFromInfoTable tab) + tab' <- getRight r if | project opts ^. coreAsmPrint -> renderStdOut (Asm.ppOutDefault tab' tab') diff --git a/src/Juvix/Compiler/Asm/Data/InfoTable.hs b/src/Juvix/Compiler/Asm/Data/InfoTable.hs index 2c957fe666..c29fe2c181 100644 --- a/src/Juvix/Compiler/Asm/Data/InfoTable.hs +++ b/src/Juvix/Compiler/Asm/Data/InfoTable.hs @@ -1,84 +1,19 @@ module Juvix.Compiler.Asm.Data.InfoTable ( module Juvix.Compiler.Asm.Data.InfoTable, - module Juvix.Compiler.Asm.Language.Rep, - module Juvix.Compiler.Asm.Language.Type, + module Juvix.Compiler.Tree.Data.InfoTable.Base, ) where -import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Asm.Language -import Juvix.Compiler.Asm.Language.Rep -import Juvix.Compiler.Asm.Language.Type +import Juvix.Compiler.Tree.Data.InfoTable.Base -data InfoTable = InfoTable - { _infoFunctions :: HashMap Symbol FunctionInfo, - _infoConstrs :: HashMap Tag ConstructorInfo, - _infoInductives :: HashMap Symbol InductiveInfo, - _infoMainFunction :: Maybe Symbol - } - -data FunctionInfo = FunctionInfo - { _functionName :: Text, - _functionLocation :: Maybe Location, - _functionSymbol :: Symbol, - -- | `_functionArgsNum` may be different from `length (typeArgs - -- (_functionType))` only if it is 0 (the "function" takes zero arguments) - -- and the result is a function. - _functionArgsNum :: Int, - -- | length _functionArgNames == _functionArgsNum - _functionArgNames :: [Maybe Text], - _functionType :: Type, - _functionMaxValueStackHeight :: Int, - _functionMaxTempStackHeight :: Int, - _functionCode :: Code - } +type InfoTable = InfoTable' Code (Maybe FunctionInfoExtra) -data ConstructorInfo = ConstructorInfo - { _constructorName :: Text, - _constructorLocation :: Maybe Location, - _constructorTag :: Tag, - -- | `_constructorArgsNum` should always be equal to `length (typeArgs - -- (_constructorType))`. It is stored separately mainly for the benefit of - -- the interpreter (so it does not have to recompute it every time). - _constructorArgsNum :: Int, - -- | length _constructorArgNames == _constructorArgsNum - _constructorArgNames :: [Maybe Text], - -- | Constructor types are assumed to be fully uncurried, i.e., `uncurryType - -- _constructorType == _constructorType` - _constructorType :: Type, - _constructorInductive :: Symbol, - _constructorRepresentation :: MemRep, - _constructorFixity :: Maybe Fixity - } +type FunctionInfo = FunctionInfo' Code (Maybe FunctionInfoExtra) -data InductiveInfo = InductiveInfo - { _inductiveName :: Text, - _inductiveLocation :: Maybe Location, - _inductiveSymbol :: Symbol, - _inductiveKind :: Type, - _inductiveConstructors :: [Tag], - _inductiveRepresentation :: IndRep +data FunctionInfoExtra = FunctionInfoExtra + { _functionMaxValueStackHeight :: Int, + _functionMaxTempStackHeight :: Int } -makeLenses ''InfoTable -makeLenses ''FunctionInfo -makeLenses ''ConstructorInfo -makeLenses ''InductiveInfo - -emptyInfoTable :: InfoTable -emptyInfoTable = - InfoTable - { _infoFunctions = mempty, - _infoConstrs = mempty, - _infoInductives = mempty, - _infoMainFunction = Nothing - } - -lookupFunInfo :: InfoTable -> Symbol -> FunctionInfo -lookupFunInfo infoTable sym = fromMaybe (error "invalid function symbol") (HashMap.lookup sym (infoTable ^. infoFunctions)) - -lookupConstrInfo :: InfoTable -> Tag -> ConstructorInfo -lookupConstrInfo infoTable tag = fromMaybe (error "invalid constructor tag") (HashMap.lookup tag (infoTable ^. infoConstrs)) - -lookupInductiveInfo :: InfoTable -> Symbol -> InductiveInfo -lookupInductiveInfo infoTable sym = fromMaybe (error "invalid inductive symbol") (HashMap.lookup sym (infoTable ^. infoInductives)) +makeLenses ''FunctionInfoExtra diff --git a/src/Juvix/Compiler/Asm/Extra/Memory.hs b/src/Juvix/Compiler/Asm/Extra/Memory.hs index 22beba8f24..eac193a2b9 100644 --- a/src/Juvix/Compiler/Asm/Extra/Memory.hs +++ b/src/Juvix/Compiler/Asm/Extra/Memory.hs @@ -105,11 +105,11 @@ getDirectRefType dr mem = case dr of getValueType' :: (Member (Error AsmError) r) => Maybe Location -> InfoTable -> Memory -> Value -> Sem r Type getValueType' loc tab mem = \case - ConstInt _ -> return mkTypeInteger - ConstBool _ -> return mkTypeBool - ConstString _ -> return TyString - ConstUnit -> return TyUnit - ConstVoid -> return TyVoid + Constant ConstInt {} -> return mkTypeInteger + Constant ConstBool {} -> return mkTypeBool + Constant ConstString {} -> return TyString + Constant ConstUnit -> return TyUnit + Constant ConstVoid -> return TyVoid Ref val -> case getMemValueType tab val mem of Just ty -> return ty Nothing -> throw $ AsmError loc "invalid memory reference" diff --git a/src/Juvix/Compiler/Asm/Extra/Type.hs b/src/Juvix/Compiler/Asm/Extra/Type.hs index 951cbc19bf..e5e9e6ba47 100644 --- a/src/Juvix/Compiler/Asm/Extra/Type.hs +++ b/src/Juvix/Compiler/Asm/Extra/Type.hs @@ -1,49 +1,15 @@ -module Juvix.Compiler.Asm.Extra.Type where +module Juvix.Compiler.Asm.Extra.Type + ( module Juvix.Compiler.Asm.Extra.Type, + module Juvix.Compiler.Tree.Extra.Type, + ) +where import Data.List.NonEmpty qualified as NonEmpty import Juvix.Compiler.Asm.Data.InfoTable import Juvix.Compiler.Asm.Error import Juvix.Compiler.Asm.Language import Juvix.Compiler.Asm.Pretty - -mkTypeInteger :: Type -mkTypeInteger = TyInteger (TypeInteger Nothing Nothing) - -mkTypeBool :: Type -mkTypeBool = TyBool (TypeBool (BuiltinTag TagTrue) (BuiltinTag TagFalse)) - -mkTypeConstr :: Symbol -> Tag -> [Type] -> Type -mkTypeConstr ind tag argTypes = TyConstr (TypeConstr ind tag argTypes) - -mkTypeInductive :: Symbol -> Type -mkTypeInductive ind = TyInductive (TypeInductive ind) - -mkTypeFun :: [Type] -> Type -> Type -mkTypeFun args tgt = case args of - [] -> tgt - a : args' -> TyFun (TypeFun (a :| args') tgt) - -unfoldType :: Type -> ([Type], Type) -unfoldType ty = (typeArgs ty, typeTarget ty) - --- converts e.g. `A -> B -> C -> D` to `(A, B, C) -> D` where `D` is an atom -uncurryType :: Type -> Type -uncurryType ty = case typeArgs ty of - [] -> - ty - tyargs -> - let ty' = uncurryType (typeTarget ty) - in mkTypeFun (tyargs ++ typeArgs ty') (typeTarget ty') - --- converts e.g. `(A, B, C) -> (D, E) -> F` to `A -> B -> C -> D -> E -> F` --- where `F` is an atom -curryType :: Type -> Type -curryType ty = case typeArgs ty of - [] -> - ty - tyargs -> - let ty' = curryType (typeTarget ty) - in foldr (\tyarg ty'' -> mkTypeFun [tyarg] ty'') (typeTarget ty') tyargs +import Juvix.Compiler.Tree.Extra.Type unifyTypes :: forall r. (Members '[Error AsmError, Reader (Maybe Location), Reader InfoTable] r) => Type -> Type -> Sem r Type unifyTypes ty1 ty2 = case (ty1, ty2) of diff --git a/src/Juvix/Compiler/Asm/Interpreter.hs b/src/Juvix/Compiler/Asm/Interpreter.hs index 8e4cbb66e4..635e413127 100644 --- a/src/Juvix/Compiler/Asm/Interpreter.hs +++ b/src/Juvix/Compiler/Asm/Interpreter.hs @@ -212,11 +212,11 @@ runCodeR infoTable funInfo = goCode (funInfo ^. functionCode) >> popLastValueSta getVal :: (Member Runtime r) => Value -> Sem r Val getVal = \case - ConstInt i -> return (ValInteger i) - ConstBool b -> return (ValBool b) - ConstString s -> return (ValString s) - ConstUnit -> return ValUnit - ConstVoid -> return ValVoid + Constant (ConstInt i) -> return (ValInteger i) + Constant (ConstBool b) -> return (ValBool b) + Constant (ConstString s) -> return (ValString s) + Constant ConstUnit -> return ValUnit + Constant ConstVoid -> return ValVoid Ref r -> getMemVal r getMemVal :: (Member Runtime r) => MemValue -> Sem r Val diff --git a/src/Juvix/Compiler/Asm/Language.hs b/src/Juvix/Compiler/Asm/Language.hs index d78570ba44..c1b75d51d5 100644 --- a/src/Juvix/Compiler/Asm/Language.hs +++ b/src/Juvix/Compiler/Asm/Language.hs @@ -8,37 +8,24 @@ -- and memory layout. module Juvix.Compiler.Asm.Language ( module Juvix.Compiler.Asm.Language, - module Juvix.Compiler.Core.Language.Base, + module Juvix.Compiler.Tree.Language.Base, ) where -import Juvix.Compiler.Core.Language.Base +import Juvix.Compiler.Tree.Language.Base -- In what follows, when referring to the stack we mean the current local value -- stack, unless otherwise stated. By stack[n] we denote the n-th cell from the - --- * top* in the value stack (0-based). - --- | Offset of a data field or an argument -type Offset = Int +-- top in the value stack (0-based). -- | Values reference readable values (constant or value stored in memory). Void -- is an unprintable unit. data Value - = ConstInt Integer - | ConstBool Bool - | ConstString Text - | ConstUnit - | ConstVoid + = Constant Constant | Ref MemValue -- | MemValues are references to values stored in random-access memory. -data MemValue - = -- | A direct memory reference. - DRef DirectRef - | -- | ConstrRef is an indirect reference to a field (argument) of - -- a constructor: field k holds the (k+1)th argument. - ConstrRef Field +type MemValue = MemRef' DirectRef -- | DirectRef is a direct memory reference. data DirectRef @@ -48,27 +35,12 @@ data DirectRef -- JVA code: 'arg[]'. ArgRef OffsetRef | -- | TempRef references a value in the temporary stack (0-based offsets, - -- counted from the *bottom* of the temporary stack). JVA code: + -- counted from the _bottom_ of the temporary stack). JVA code: -- 'tmp[]'. TempRef OffsetRef -data OffsetRef = OffsetRef - { _offsetRefOffset :: Offset, - _offsetRefName :: Maybe Text - } - -- | Constructor field reference. JVA code: '.[]' -data Field = Field - { _fieldName :: Maybe Text, - -- | tag of the constructor being referenced - _fieldTag :: Tag, - -- | location where the data is stored - _fieldRef :: DirectRef, - _fieldOffset :: Offset - } - -makeLenses ''Field -makeLenses ''OffsetRef +type Field = Field' DirectRef -- | Function call type data CallType = CallFun Symbol | CallClosure @@ -80,7 +52,7 @@ data Instruction = -- | An instruction which takes its operands from the two top stack cells, -- pops the stack by two, and then pushes the result. Binop Opcode - | -- | Convert the top stack cell to a string. JAV opcode: 'show'. + | -- | Convert the top stack cell to a string. JVA opcode: 'show'. ValShow | -- | Convert a string on top of the stack into an integer. JVA opcode: -- 'atoi'. @@ -222,12 +194,11 @@ data Command = -- | A single non-branching instruction. Instr CmdInstr | -- | Branch based on a boolean value on top of the stack, pop the stack. JVA - -- code: 'br { true: {} false: {} }'. + -- code: 'br { true: {}; false: {}; }'. Branch CmdBranch - | -- | Branch based on the tag of the constructor data on top of the stack. Does - -- _not_ pop the stack. The second argument is the optional default branch. - -- JVA code: 'case { : {} ... : {} default: {} }' - -- (any branch may be omitted). + | -- | Branch based on the tag of the constructor data on top of the stack. + -- Does _not_ pop the stack. JVA code: 'case { : {}; ... + -- : {}; default: {}; }' (any branch may be omitted). Case CmdCase | -- | Push the top of the value stack onto the temporary stack, pop the value -- stack, execute the nested code, and if not tail recursive then pop the diff --git a/src/Juvix/Compiler/Asm/Pretty/Base.hs b/src/Juvix/Compiler/Asm/Pretty/Base.hs index dd426892f9..6fd981414e 100644 --- a/src/Juvix/Compiler/Asm/Pretty/Base.hs +++ b/src/Juvix/Compiler/Asm/Pretty/Base.hs @@ -238,17 +238,17 @@ instance PrettyCode MemValue where instance PrettyCode Value where ppCode :: (Member (Reader Options) r) => Value -> Sem r (Doc Ann) ppCode = \case - ConstInt v -> + Constant (ConstInt v) -> return $ annotate AnnLiteralInteger (pretty v) - ConstBool True -> + Constant (ConstBool True) -> return $ annotate (AnnKind KNameConstructor) (pretty (Str.true_ :: String)) - ConstBool False -> + Constant (ConstBool False) -> return $ annotate (AnnKind KNameConstructor) (pretty (Str.false_ :: String)) - ConstString txt -> + Constant (ConstString txt) -> return $ annotate AnnLiteralString (pretty (show txt :: String)) - ConstUnit {} -> + Constant ConstUnit {} -> return $ annotate (AnnKind KNameConstructor) (pretty (Str.unit :: String)) - ConstVoid {} -> + Constant ConstVoid {} -> return $ annotate (AnnKind KNameConstructor) (pretty (Str.void :: String)) Ref mval -> ppCode mval diff --git a/src/Juvix/Compiler/Asm/Transformation/StackUsage.hs b/src/Juvix/Compiler/Asm/Transformation/StackUsage.hs index 4fec6802f1..c7126fe63e 100644 --- a/src/Juvix/Compiler/Asm/Transformation/StackUsage.hs +++ b/src/Juvix/Compiler/Asm/Transformation/StackUsage.hs @@ -7,10 +7,14 @@ computeFunctionStackUsage tab fi = do ps <- recurseS sig (fi ^. functionCode) let maxValueStack = maximum (map fst ps) maxTempStack = maximum (map snd ps) + extra = + FunctionInfoExtra + { _functionMaxValueStackHeight = maxValueStack, + _functionMaxTempStackHeight = maxTempStack + } return fi - { _functionMaxValueStackHeight = maxValueStack, - _functionMaxTempStackHeight = maxTempStack + { _functionExtra = Just extra } where sig :: RecursorSig StackInfo r (Int, Int) diff --git a/src/Juvix/Compiler/Asm/Translation.hs b/src/Juvix/Compiler/Asm/Translation.hs index cf9e7345ad..be87298aab 100644 --- a/src/Juvix/Compiler/Asm/Translation.hs +++ b/src/Juvix/Compiler/Asm/Translation.hs @@ -1,8 +1,8 @@ module Juvix.Compiler.Asm.Translation - ( module Juvix.Compiler.Asm.Translation.FromCore, + ( module Juvix.Compiler.Asm.Translation.FromTree, module Juvix.Compiler.Asm.Translation.FromSource, ) where -import Juvix.Compiler.Asm.Translation.FromCore import Juvix.Compiler.Asm.Translation.FromSource +import Juvix.Compiler.Asm.Translation.FromTree diff --git a/src/Juvix/Compiler/Asm/Translation/FromCore.hs b/src/Juvix/Compiler/Asm/Translation/FromCore.hs deleted file mode 100644 index bc9587f497..0000000000 --- a/src/Juvix/Compiler/Asm/Translation/FromCore.hs +++ /dev/null @@ -1,374 +0,0 @@ -module Juvix.Compiler.Asm.Translation.FromCore (fromCore) where - -import Data.DList qualified as DL -import Data.HashMap.Strict qualified as HashMap -import Juvix.Compiler.Asm.Data.InfoTable -import Juvix.Compiler.Asm.Extra.Base -import Juvix.Compiler.Asm.Extra.Type -import Juvix.Compiler.Asm.Language -import Juvix.Compiler.Core.Data.BinderList qualified as BL -import Juvix.Compiler.Core.Data.Stripped.InfoTable qualified as Core -import Juvix.Compiler.Core.Language.Stripped qualified as Core - -type BinderList = BL.BinderList - --- DList for O(1) snoc and append -type Code' = DL.DList Command - -fromCore :: Core.InfoTable -> InfoTable -fromCore tab = - InfoTable - { _infoMainFunction = tab ^. Core.infoMain, - _infoFunctions = genCode tab <$> tab ^. Core.infoFunctions, - _infoInductives = translateInductiveInfo <$> tab ^. Core.infoInductives, - _infoConstrs = translateConstructorInfo <$> tab ^. Core.infoConstructors - } - --- Generate code for a single function. -genCode :: Core.InfoTable -> Core.FunctionInfo -> FunctionInfo -genCode infoTable fi = - let argnames = map (Just . (^. Core.argumentName)) (fi ^. Core.functionArgsInfo) - code = - DL.toList $ - go - True - 0 - ( BL.fromList $ - reverse - ( map - (Ref . DRef . ArgRef) - ( zipWithExact - OffsetRef - [0 .. fi ^. Core.functionArgsNum - 1] - argnames - ) - ) - ) - (fi ^. Core.functionBody) - in FunctionInfo - { _functionName = fi ^. Core.functionName, - _functionLocation = fi ^. Core.functionLocation, - _functionSymbol = fi ^. Core.functionSymbol, - _functionArgsNum = fi ^. Core.functionArgsNum, - _functionArgNames = argnames, - _functionType = convertType (fi ^. Core.functionArgsNum) (fi ^. Core.functionType), - _functionCode = code, - _functionMaxTempStackHeight = -1, -- computed later - _functionMaxValueStackHeight = -1 - } - where - -- Assumption: the BinderList does not contain references to the value stack - -- (directly or indirectly). - go :: Bool -> Int -> BinderList Value -> Core.Node -> Code' - go isTail tempSize refs node = case node of - Core.NVar v -> goVar isTail refs v - Core.NIdt idt -> goIdent isTail idt - Core.NCst cst -> goConstant isTail cst - Core.NApp apps -> goApps isTail tempSize refs apps - Core.NBlt blt -> goBuiltinApp isTail tempSize refs blt - Core.NCtr ctr -> goConstr isTail tempSize refs ctr - Core.NLet lt -> goLet isTail tempSize refs lt - Core.NCase c -> goCase isTail tempSize refs c - Core.NIf x -> goIf isTail tempSize refs x - - goVar :: Bool -> BinderList Value -> Core.Var -> Code' - goVar isTail refs Core.Var {..} = - snocReturn isTail $ - DL.singleton $ - mkInstr $ - Push (BL.lookup _varIndex refs) - - goIdent :: Bool -> Core.Ident -> Code' - goIdent isTail Core.Ident {..} = - if - | getArgsNum _identSymbol == 0 -> - DL.singleton $ - mkInstr $ - (if isTail then TailCall else Call) (InstrCall (CallFun _identSymbol) 0) - | otherwise -> - snocReturn isTail $ - DL.singleton $ - mkInstr $ - AllocClosure (InstrAllocClosure _identSymbol 0) - - goConstant :: Bool -> Core.Constant -> Code' - goConstant isTail = \case - Core.Constant _ (Core.ConstInteger i) -> - snocReturn isTail $ - DL.singleton $ - mkInstr $ - Push (ConstInt i) - Core.Constant _ (Core.ConstString s) -> - snocReturn isTail $ - DL.singleton $ - mkInstr $ - Push (ConstString s) - - goApps :: Bool -> Int -> BinderList Value -> Core.Apps -> Code' - goApps isTail tempSize refs (Core.Apps {..}) = - let suppliedArgs = reverse _appsArgs - suppliedArgsNum = length suppliedArgs - in case _appsFun of - Core.FunIdent (Core.Ident {..}) -> - if - | argsNum > suppliedArgsNum -> - snocReturn isTail $ - DL.snoc - (DL.concat (map (go False tempSize refs) suppliedArgs)) - (mkInstr $ AllocClosure (InstrAllocClosure _identSymbol suppliedArgsNum)) - | argsNum == suppliedArgsNum -> - DL.snoc - (DL.concat (map (go False tempSize refs) suppliedArgs)) - (mkInstr $ (if isTail then TailCall else Call) (InstrCall (CallFun _identSymbol) argsNum)) - | otherwise -> - -- If more arguments are supplied (suppliedArgsNum) than - -- the function eats up (argsNum), then the function - -- returns a closure. We should first call the function - -- (with Call) and then use CallClosures or - -- TailCallClosures on the result with the remaining - -- arguments. - DL.snoc - ( DL.snoc - (DL.concat (map (go False tempSize refs) suppliedArgs)) - (mkInstr $ Call (InstrCall (CallFun _identSymbol) argsNum)) - ) - (mkInstr $ (if isTail then TailCallClosures else CallClosures) (InstrCallClosures (suppliedArgsNum - argsNum))) - where - argsNum = getArgsNum _identSymbol - Core.FunVar Core.Var {..} -> - DL.snoc - ( DL.snoc - (DL.concat (map (go False tempSize refs) suppliedArgs)) - (mkInstr $ Push (BL.lookup _varIndex refs)) - ) - (mkInstr $ (if isTail then TailCallClosures else CallClosures) (InstrCallClosures suppliedArgsNum)) - - goBuiltinApp :: Bool -> Int -> BinderList Value -> Core.BuiltinApp -> Code' - goBuiltinApp isTail tempSize refs (Core.BuiltinApp {..}) = - case _builtinAppOp of - OpSeq -> - goSeq isTail tempSize refs _builtinAppArgs - _ -> - snocReturn isTail $ - DL.append - (DL.concat (map (go False tempSize refs) (reverse _builtinAppArgs))) - (genOp _builtinAppOp) - - goSeq :: Bool -> Int -> BinderList Value -> [Core.Node] -> Code' - goSeq isTail tempSize refs = \case - [arg1, arg2] -> - DL.append - (go False tempSize refs arg1) - ( DL.cons - (mkInstr Pop) - (go isTail tempSize refs arg2) - ) - _ -> impossible - - goConstr :: Bool -> Int -> BinderList Value -> Core.Constr -> Code' - goConstr isTail tempSize refs = \case - Core.Constr _ (Core.BuiltinTag Core.TagTrue) _ -> - snocReturn isTail $ - DL.singleton $ - mkInstr $ - Push (ConstBool True) - Core.Constr _ (Core.BuiltinTag Core.TagFalse) _ -> - snocReturn isTail $ - DL.singleton $ - mkInstr $ - Push (ConstBool False) - Core.Constr {..} -> - snocReturn isTail $ - DL.snoc - (DL.concat (map (go False tempSize refs) (reverse _constrArgs))) - (mkInstr $ AllocConstr _constrTag) - - goLet :: Bool -> Int -> BinderList Value -> Core.Let -> Code' - goLet isTail tempSize refs (Core.Let {..}) = - DL.snoc - (go False tempSize refs (_letItem ^. Core.letItemValue)) - ( Save $ - CmdSave - { _cmdSaveInfo = emptyInfo, - _cmdSaveIsTail = isTail, - _cmdSaveCode = DL.toList $ go isTail (tempSize + 1) (BL.cons (Ref (DRef (TempRef nameRef))) refs) _letBody, - _cmdSaveName = Just name - } - ) - where - name = _letItem ^. Core.letItemBinder . Core.binderName - nameRef = OffsetRef tempSize (Just name) - - goCase :: Bool -> Int -> BinderList Value -> Core.Case -> Code' - goCase isTail tempSize refs (Core.Case {..}) = - DL.snoc - (go False tempSize refs _caseValue) - ( Case $ - CmdCase - { _cmdCaseInfo = emptyInfo, - _cmdCaseInductive = _caseInductive, - _cmdCaseBranches = compileCaseBranches _caseBranches, - _cmdCaseDefault = fmap compileCaseDefault _caseDefault - } - ) - where - compileCaseBranches :: [Core.CaseBranch] -> [CaseBranch] - compileCaseBranches branches = - map - ( \(Core.CaseBranch {..}) -> - if - | _caseBranchBindersNum == 0 -> - compileCaseBranchNoBinders _caseBranchTag _caseBranchBody - | otherwise -> - compileCaseBranch _caseBranchBindersNum _caseBranchTag _caseBranchBody - ) - branches - - compileCaseBranchNoBinders :: Tag -> Core.Node -> CaseBranch - compileCaseBranchNoBinders tag body = - CaseBranch - tag - ( DL.toList $ - DL.cons (mkInstr Pop) $ - go isTail tempSize refs body - ) - - compileCaseBranch :: Int -> Tag -> Core.Node -> CaseBranch - compileCaseBranch bindersNum tag body = - CaseBranch - tag - [ Save $ - CmdSave - { _cmdSaveInfo = emptyInfo, - _cmdSaveIsTail = isTail, - _cmdSaveName = Nothing, - _cmdSaveCode = - DL.toList $ - go - isTail - (tempSize + 1) - ( BL.prepend - ( map - (Ref . ConstrRef . Field Nothing tag (TempRef (OffsetRef tempSize Nothing))) - (reverse [0 .. bindersNum - 1]) - ) - refs - ) - body - } - ] - - compileCaseDefault :: Core.Node -> Code - compileCaseDefault = - DL.toList - . DL.cons (mkInstr Pop) - . go isTail tempSize refs - - goIf :: Bool -> Int -> BinderList Value -> Core.If -> Code' - goIf isTail tempSize refs (Core.If {..}) = - DL.snoc - (go False tempSize refs _ifValue) - ( Branch $ - CmdBranch - { _cmdBranchInfo = emptyInfo, - _cmdBranchTrue = DL.toList $ go isTail tempSize refs _ifTrue, - _cmdBranchFalse = DL.toList $ go isTail tempSize refs _ifFalse - } - ) - - genOp :: Core.BuiltinOp -> Code' - genOp = \case - Core.OpIntAdd -> DL.singleton $ mkBinop IntAdd - Core.OpIntSub -> DL.singleton $ mkBinop IntSub - Core.OpIntMul -> DL.singleton $ mkBinop IntMul - Core.OpIntDiv -> DL.singleton $ mkBinop IntDiv - Core.OpIntMod -> DL.singleton $ mkBinop IntMod - Core.OpIntLt -> DL.singleton $ mkBinop IntLt - Core.OpIntLe -> DL.singleton $ mkBinop IntLe - Core.OpEq -> DL.singleton $ mkBinop ValEq - Core.OpShow -> DL.singleton $ mkInstr ValShow - Core.OpStrConcat -> DL.singleton $ mkBinop StrConcat - Core.OpStrToInt -> DL.singleton $ mkInstr StrToInt - Core.OpTrace -> DL.singleton $ mkInstr Trace - Core.OpFail -> DL.singleton $ mkInstr Failure - Core.OpSeq -> impossible - - getArgsNum :: Symbol -> Int - getArgsNum sym = - fromMaybe - impossible - (HashMap.lookup sym (infoTable ^. Core.infoFunctions)) - ^. Core.functionArgsNum - - snocReturn :: Bool -> Code' -> Code' - snocReturn True code = DL.snoc code (mkInstr Return) - snocReturn False code = code - --- | Be mindful that JuvixAsm types are explicitly uncurried, while --- Core.Stripped types are always curried. If a function takes `n` arguments, --- then the first `n` arguments should be uncurried in its JuvixAsm type. -convertType :: Int -> Core.Type -> Type -convertType argsNum ty = - case ty of - Core.TyDynamic -> - TyDynamic - Core.TyPrim x -> - convertPrimitiveType x - Core.TyApp Core.TypeApp {..} -> - TyInductive (TypeInductive _typeAppSymbol) - Core.TyFun {} -> - let (tgt, tyargs) = Core.unfoldType ty - tyargs' = map convertNestedType tyargs - tgt' = convertType 0 tgt - in mkTypeFun (take argsNum tyargs') (mkTypeFun (drop argsNum tyargs') tgt') - -convertPrimitiveType :: Core.Primitive -> Type -convertPrimitiveType = \case - Core.PrimInteger Core.PrimIntegerInfo {..} -> - TyInteger (TypeInteger _infoMinValue _infoMaxValue) - Core.PrimBool Core.PrimBoolInfo {..} -> - TyBool (TypeBool _infoTrueTag _infoFalseTag) - Core.PrimString -> - TyString - --- | `convertNestedType` ensures that the conversion of a type with Dynamic in the --- target is curried. The result of `convertType 0 ty` is always uncurried. -convertNestedType :: Core.Type -> Type -convertNestedType ty = - case ty of - Core.TyFun {} -> - let (tgt, tyargs) = Core.unfoldType ty - in case tgt of - Core.TyDynamic -> - curryType (convertType 0 ty) - _ -> - mkTypeFun (map convertNestedType tyargs) (convertType 0 tgt) - _ -> - convertType 0 ty - -translateInductiveInfo :: Core.InductiveInfo -> InductiveInfo -translateInductiveInfo ii = - InductiveInfo - { _inductiveName = ii ^. Core.inductiveName, - _inductiveLocation = ii ^. Core.inductiveLocation, - _inductiveSymbol = ii ^. Core.inductiveSymbol, - _inductiveKind = convertType 0 (ii ^. Core.inductiveKind), - _inductiveConstructors = ii ^. Core.inductiveConstructors, - _inductiveRepresentation = IndRepStandard - } - -translateConstructorInfo :: Core.ConstructorInfo -> ConstructorInfo -translateConstructorInfo ci = - ConstructorInfo - { _constructorName = ci ^. Core.constructorName, - _constructorLocation = ci ^. Core.constructorLocation, - _constructorTag = ci ^. Core.constructorTag, - _constructorArgsNum = length (typeArgs ty), - _constructorArgNames = ci ^. Core.constructorArgNames, - _constructorType = ty, - _constructorInductive = ci ^. Core.constructorInductive, - _constructorRepresentation = MemRepConstr, - _constructorFixity = ci ^. Core.constructorFixity - } - where - ty = convertType 0 (ci ^. Core.constructorType) diff --git a/src/Juvix/Compiler/Asm/Translation/FromSource.hs b/src/Juvix/Compiler/Asm/Translation/FromSource.hs index 68ff044363..041607050b 100644 --- a/src/Juvix/Compiler/Asm/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Asm/Translation/FromSource.hs @@ -136,8 +136,7 @@ statementFunction = do _functionArgsNum = length argtys, _functionArgNames = argnames, _functionType = mkTypeFun argtys (fromMaybe TyDynamic mrty), - _functionMaxValueStackHeight = -1, -- computed later - _functionMaxTempStackHeight = -1 + _functionExtra = Nothing -- computed later } lift $ registerFunction fi0 let updateNames :: LocalNameMap -> LocalNameMap @@ -404,23 +403,23 @@ value = integerValue <|> boolValue <|> stringValue <|> unitValue <|> voidValue < integerValue :: ParsecS r Value integerValue = do (i, _) <- integer - return $ ConstInt i + return $ Constant $ ConstInt i boolValue :: ParsecS r Value boolValue = - (kw kwTrue $> ConstBool True) - <|> (kw kwFalse $> ConstBool False) + (kw kwTrue $> Constant (ConstBool True)) + <|> (kw kwFalse $> Constant (ConstBool False)) stringValue :: ParsecS r Value stringValue = do (s, _) <- string - return $ ConstString s + return $ Constant $ ConstString s unitValue :: ParsecS r Value -unitValue = kw kwUnit $> ConstUnit +unitValue = kw kwUnit $> (Constant ConstUnit) voidValue :: ParsecS r Value -voidValue = kw kwVoid $> ConstVoid +voidValue = kw kwVoid $> (Constant ConstVoid) memValue :: (Members '[InfoTableBuilder, State LocalNameMap, State Index] r) => diff --git a/src/Juvix/Compiler/Asm/Translation/FromTree.hs b/src/Juvix/Compiler/Asm/Translation/FromTree.hs new file mode 100644 index 0000000000..e85ccf8809 --- /dev/null +++ b/src/Juvix/Compiler/Asm/Translation/FromTree.hs @@ -0,0 +1,256 @@ +module Juvix.Compiler.Asm.Translation.FromTree (fromTree) where + +import Data.DList qualified as DL +import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Extra.Base +import Juvix.Compiler.Asm.Language +import Juvix.Compiler.Tree.Data.InfoTable 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 + } + +-- Generate code for a single function. +genCode :: Tree.FunctionInfo -> FunctionInfo +genCode fi = + FunctionInfo + { _functionName = fi ^. Tree.functionName, + _functionLocation = fi ^. Tree.functionLocation, + _functionSymbol = fi ^. Tree.functionSymbol, + _functionArgsNum = fi ^. Tree.functionArgsNum, + _functionArgNames = fi ^. Tree.functionArgNames, + _functionType = fi ^. Tree.functionType, + _functionCode = DL.toList $ go True (fi ^. Tree.functionCode), + _functionExtra = Nothing -- computed later + } + where + go :: Bool -> Tree.Node -> Code' + go isTail node = case node of + Tree.Binop x -> goBinop isTail x + Tree.Unop x -> goUnop isTail x + Tree.Const x -> goConstant isTail x + Tree.MemRef x -> goMemRef isTail x + Tree.AllocConstr x -> goAllocConstr isTail x + Tree.AllocClosure x -> goAllocClosure isTail x + Tree.ExtendClosure x -> goExtendClosure isTail x + Tree.Call x -> goCall isTail x + Tree.CallClosures x -> goCallClosures isTail x + Tree.Branch x -> goBranch isTail x + Tree.Case x -> goCase isTail x + Tree.Save x -> goSave isTail x + + goBinop :: Bool -> Tree.NodeBinop -> Code' + goBinop isTail Tree.NodeBinop {..} = case _nodeBinopOpcode of + Tree.OpSeq -> + DL.append + (go False _nodeBinopArg1) + ( DL.cons + (mkInstr Pop) + (go isTail _nodeBinopArg2) + ) + _ -> + snocReturn isTail $ + DL.append + (go False _nodeBinopArg2) + ( DL.snoc + (go False _nodeBinopArg1) + (genBinOp _nodeBinopOpcode) + ) + + goUnop :: Bool -> Tree.NodeUnop -> Code' + goUnop isTail Tree.NodeUnop {..} = + snocReturn isTail $ + DL.snoc (go False _nodeUnopArg) (genUnOp _nodeUnopOpcode) + + goConstant :: Bool -> Tree.Constant -> Code' + goConstant isTail c = + snocReturn isTail $ + DL.singleton $ + mkInstr $ + Push (Constant c) + + goMemRef :: Bool -> Tree.MemRef -> Code' + goMemRef isTail ref = + snocReturn isTail $ + DL.singleton $ + mkInstr $ + Push $ + Ref $ + case ref of + Tree.DRef r -> DRef $ goDirectRef r + Tree.ConstrRef r -> ConstrRef $ goFieldRef r + + goAllocConstr :: Bool -> Tree.NodeAllocConstr -> Code' + goAllocConstr isTail Tree.NodeAllocConstr {..} = + snocReturn isTail $ + DL.snoc + (goArgs _nodeAllocConstrArgs) + (mkInstr (AllocConstr _nodeAllocConstrTag)) + + goAllocClosure :: Bool -> Tree.NodeAllocClosure -> Code' + goAllocClosure isTail Tree.NodeAllocClosure {..} = + snocReturn isTail $ + DL.snoc + (goArgs _nodeAllocClosureArgs) + ( mkInstr $ + AllocClosure $ + InstrAllocClosure + { _allocClosureFunSymbol = _nodeAllocClosureFunSymbol, + _allocClosureArgsNum = length _nodeAllocClosureArgs + } + ) + + goExtendClosure :: Bool -> Tree.NodeExtendClosure -> Code' + goExtendClosure isTail Tree.NodeExtendClosure {..} = + snocReturn isTail $ + DL.snoc + (goArgs (toList _nodeExtendClosureArgs)) + ( mkInstr $ + ExtendClosure $ + InstrExtendClosure + { _extendClosureArgsNum = length _nodeExtendClosureArgs + } + ) + + goCall :: Bool -> Tree.NodeCall -> Code' + goCall isTail Tree.NodeCall {..} = case _nodeCallType of + Tree.CallFun sym -> + DL.snoc + (goArgs _nodeCallArgs) + ( mkInstr $ + (if isTail then TailCall else Call) $ + InstrCall + { _callType = CallFun sym, + _callArgsNum = length _nodeCallArgs + } + ) + Tree.CallClosure arg -> + DL.append + (goArgs _nodeCallArgs) + ( DL.snoc (go False arg) $ + mkInstr $ + (if isTail then TailCall else Call) $ + InstrCall + { _callType = CallClosure, + _callArgsNum = length _nodeCallArgs + } + ) + + goCallClosures :: Bool -> Tree.NodeCallClosures -> Code' + goCallClosures isTail Tree.NodeCallClosures {..} = + DL.append + (goArgs _nodeCallClosuresArgs) + ( DL.snoc (go False _nodeCallClosuresFun) $ + mkInstr $ + (if isTail then TailCallClosures else CallClosures) $ + InstrCallClosures + { _callClosuresArgsNum = length _nodeCallClosuresArgs + } + ) + + goBranch :: Bool -> Tree.NodeBranch -> Code' + goBranch isTail Tree.NodeBranch {..} = + DL.snoc + (go False _nodeBranchArg) + ( Branch + CmdBranch + { _cmdBranchInfo = emptyInfo, + _cmdBranchTrue = DL.toList $ go isTail _nodeBranchTrue, + _cmdBranchFalse = DL.toList $ go isTail _nodeBranchFalse + } + ) + + goCase :: Bool -> Tree.NodeCase -> Code' + goCase isTail Tree.NodeCase {..} = + DL.snoc + (go False _nodeCaseArg) + ( Case + CmdCase + { _cmdCaseInfo = emptyInfo, + _cmdCaseInductive = _nodeCaseInductive, + _cmdCaseBranches = goCaseBranch isTail <$> _nodeCaseBranches, + _cmdCaseDefault = + DL.toList . DL.cons (mkInstr Pop) . go isTail <$> _nodeCaseDefault + } + ) + + goCaseBranch :: Bool -> Tree.CaseBranch -> CaseBranch + goCaseBranch isTail Tree.CaseBranch {..} + | _caseBranchSave = + CaseBranch + { _caseBranchTag, + _caseBranchCode = + [ Save $ + CmdSave + { _cmdSaveInfo = emptyInfo, + _cmdSaveName = Nothing, + _cmdSaveIsTail = isTail, + _cmdSaveCode = DL.toList $ go isTail _caseBranchBody + } + ] + } + | otherwise = + CaseBranch + { _caseBranchTag, + _caseBranchCode = + DL.toList $ DL.cons (mkInstr Pop) $ go isTail _caseBranchBody + } + + goSave :: Bool -> Tree.NodeSave -> Code' + goSave isTail Tree.NodeSave {..} = + DL.snoc + (go False _nodeSaveArg) + ( Save + CmdSave + { _cmdSaveInfo = emptyInfo, + _cmdSaveName = _nodeSaveName, + _cmdSaveIsTail = isTail, + _cmdSaveCode = DL.toList $ go isTail _nodeSaveBody + } + ) + + goArgs :: [Tree.Node] -> Code' + goArgs args = DL.concat (map (go False) (reverse args)) + + goDirectRef :: Tree.DirectRef -> DirectRef + goDirectRef = \case + Tree.ArgRef off -> ArgRef off + Tree.TempRef off -> TempRef off + + goFieldRef :: Tree.Field -> Field + goFieldRef = fmap goDirectRef + + genBinOp :: Tree.BinaryOpcode -> Command + genBinOp = \case + Tree.IntAdd -> mkBinop IntAdd + Tree.IntSub -> mkBinop IntSub + Tree.IntMul -> mkBinop IntMul + Tree.IntDiv -> mkBinop IntDiv + Tree.IntMod -> mkBinop IntMod + Tree.IntLt -> mkBinop IntLt + Tree.IntLe -> mkBinop IntLe + Tree.ValEq -> mkBinop ValEq + Tree.StrConcat -> mkBinop StrConcat + Tree.OpSeq -> impossible + + genUnOp :: Tree.UnaryOpcode -> Command + genUnOp = + mkInstr . \case + Tree.OpShow -> ValShow + Tree.OpStrToInt -> StrToInt + Tree.OpTrace -> Trace + Tree.OpFail -> Failure + Tree.OpArgsNum -> ArgsNum + + snocReturn :: Bool -> Code' -> Code' + snocReturn True code = DL.snoc code (mkInstr Return) + snocReturn False code = code diff --git a/src/Juvix/Compiler/Casm/Language/Base.hs b/src/Juvix/Compiler/Casm/Language/Base.hs index 451c1f80ca..06d29634ed 100644 --- a/src/Juvix/Compiler/Casm/Language/Base.hs +++ b/src/Juvix/Compiler/Casm/Language/Base.hs @@ -3,4 +3,4 @@ module Juvix.Compiler.Casm.Language.Base ) where -import Juvix.Compiler.Core.Language.Base hiding (Ap, BuiltinOp (..), Index) +import Juvix.Compiler.Core.Language.Base hiding (Ap, Index) diff --git a/src/Juvix/Compiler/Core/Language/Base.hs b/src/Juvix/Compiler/Core/Language/Base.hs index 2ab80eb4c5..43cef38016 100644 --- a/src/Juvix/Compiler/Core/Language/Base.hs +++ b/src/Juvix/Compiler/Core/Language/Base.hs @@ -10,9 +10,9 @@ where import GHC.Show qualified as Show import Juvix.Compiler.Core.Info (Info, IsInfo, Key) -import Juvix.Compiler.Core.Language.Builtins +import Juvix.Compiler.Core.Language.Builtins (BuiltinDataTag (..), builtinConstrArgsNum) import Juvix.Extra.Serialize -import Juvix.Prelude +import Juvix.Prelude hiding (Const) import Prettyprinter type Location = Interval diff --git a/src/Juvix/Compiler/Core/Language/Nodes.hs b/src/Juvix/Compiler/Core/Language/Nodes.hs index e3ed665cf7..33751e37b6 100644 --- a/src/Juvix/Compiler/Core/Language/Nodes.hs +++ b/src/Juvix/Compiler/Core/Language/Nodes.hs @@ -2,12 +2,14 @@ module Juvix.Compiler.Core.Language.Nodes ( module Juvix.Compiler.Core.Language.Base, module Juvix.Compiler.Core.Language.Primitives, + module Juvix.Compiler.Core.Language.Builtins, module Juvix.Compiler.Core.Language.Nodes, ) where import Data.Serialize import Juvix.Compiler.Core.Language.Base +import Juvix.Compiler.Core.Language.Builtins import Juvix.Compiler.Core.Language.Primitives -- | De Bruijn index of a locally bound variable. diff --git a/src/Juvix/Compiler/Pipeline.hs b/src/Juvix/Compiler/Pipeline.hs index 6e1102875d..5785690a3c 100644 --- a/src/Juvix/Compiler/Pipeline.hs +++ b/src/Juvix/Compiler/Pipeline.hs @@ -11,7 +11,7 @@ import Data.List.Singletons import Juvix.Compiler.Asm.Error qualified as Asm import Juvix.Compiler.Asm.Options qualified as Asm import Juvix.Compiler.Asm.Pipeline qualified as Asm -import Juvix.Compiler.Asm.Translation.FromCore qualified as Asm +import Juvix.Compiler.Asm.Translation.FromTree qualified as Asm import Juvix.Compiler.Backend qualified as Backend import Juvix.Compiler.Backend.C qualified as C import Juvix.Compiler.Backend.Geb qualified as Geb @@ -35,6 +35,7 @@ import Juvix.Compiler.Pipeline.Root.Base import Juvix.Compiler.Reg.Data.InfoTable qualified as Reg import Juvix.Compiler.Reg.Translation.FromAsm qualified as Reg import Juvix.Compiler.Store.Language qualified as Store +import Juvix.Compiler.Tree qualified as Tree import Juvix.Data.Effect.Git import Juvix.Data.Effect.Process import Juvix.Data.Effect.TaggedLock @@ -126,8 +127,11 @@ upToCoreTypecheck = -- Workflows from stored Core -------------------------------------------------------------------------------- +storedCoreToTree :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Tree.InfoTable +storedCoreToTree = Core.toStripped >=> return . Tree.fromCore . Stripped.fromCore . Core.computeCombinedInfoTable + storedCoreToAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Asm.InfoTable -storedCoreToAsm = Core.toStripped >=> return . Asm.fromCore . Stripped.fromCore . Core.computeCombinedInfoTable +storedCoreToAsm = storedCoreToTree >=> treeToAsm storedCoreToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r C.MiniCResult storedCoreToMiniC = storedCoreToAsm >=> asmToMiniC @@ -145,6 +149,9 @@ storedCoreToVampIR' = Core.toVampIR' >=> return . VampIR.fromCore' False . Core. -- Workflows from Core -------------------------------------------------------------------------------- +coreToTree :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Tree.InfoTable +coreToTree = Core.toStored >=> storedCoreToTree + coreToAsm :: (Members '[Error JuvixError, Reader EntryPoint] r) => Core.Module -> Sem r Asm.InfoTable coreToAsm = Core.toStored >=> storedCoreToAsm @@ -164,6 +171,9 @@ coreToVampIR' = Core.toStored' >=> storedCoreToVampIR' -- Other workflows -------------------------------------------------------------------------------- +treeToAsm :: Tree.InfoTable -> Sem r Asm.InfoTable +treeToAsm = return . Asm.fromTree + asmToMiniC :: (Members '[Error JuvixError, Reader EntryPoint] r) => Asm.InfoTable -> Sem r C.MiniCResult asmToMiniC = Asm.toReg >=> regToMiniC . Reg.fromAsm diff --git a/src/Juvix/Compiler/Reg/Language/Base.hs b/src/Juvix/Compiler/Reg/Language/Base.hs index fdd1fde8a9..58bcf5ac97 100644 --- a/src/Juvix/Compiler/Reg/Language/Base.hs +++ b/src/Juvix/Compiler/Reg/Language/Base.hs @@ -1,8 +1,8 @@ module Juvix.Compiler.Reg.Language.Base ( module Juvix.Compiler.Core.Language.Base, - module Juvix.Compiler.Asm.Language.Rep, + module Juvix.Compiler.Tree.Language.Rep, ) where -import Juvix.Compiler.Asm.Language.Rep -import Juvix.Compiler.Core.Language.Base hiding (BuiltinOp (..), Index) +import Juvix.Compiler.Core.Language.Base hiding (Index) +import Juvix.Compiler.Tree.Language.Rep diff --git a/src/Juvix/Compiler/Reg/Translation/FromAsm.hs b/src/Juvix/Compiler/Reg/Translation/FromAsm.hs index 2cac5e7ab4..550d2a69ae 100644 --- a/src/Juvix/Compiler/Reg/Translation/FromAsm.hs +++ b/src/Juvix/Compiler/Reg/Translation/FromAsm.hs @@ -24,8 +24,8 @@ fromAsm tab = _functionLocation = fi ^. Asm.functionLocation, _functionSymbol = fi ^. Asm.functionSymbol, _functionArgsNum = fi ^. Asm.functionArgsNum, - _functionStackVarsNum = fi ^. Asm.functionMaxValueStackHeight, - _functionTempVarsNum = fi ^. Asm.functionMaxTempStackHeight, + _functionStackVarsNum = fromJust (fi ^. Asm.functionExtra) ^. Asm.functionMaxValueStackHeight, + _functionTempVarsNum = fromJust (fi ^. Asm.functionExtra) ^. Asm.functionMaxTempStackHeight, _functionCode = fromAsmFun tab fi } @@ -152,11 +152,11 @@ fromAsmInstr funInfo tab si Asm.CmdInstr {..} = mkValue :: Asm.Value -> Value mkValue = \case - Asm.ConstInt v -> ConstInt v - Asm.ConstBool v -> ConstBool v - Asm.ConstString v -> ConstString v - Asm.ConstUnit -> ConstUnit - Asm.ConstVoid -> ConstVoid + Asm.Constant (Asm.ConstInt v) -> ConstInt v + Asm.Constant (Asm.ConstBool v) -> ConstBool v + Asm.Constant (Asm.ConstString v) -> ConstString v + Asm.Constant Asm.ConstUnit -> ConstUnit + Asm.Constant Asm.ConstVoid -> ConstVoid Asm.Ref mv -> case mv of Asm.DRef dref -> VRef $ mkVar dref Asm.ConstrRef Asm.Field {..} -> diff --git a/src/Juvix/Compiler/Tree.hs b/src/Juvix/Compiler/Tree.hs new file mode 100644 index 0000000000..807cba1932 --- /dev/null +++ b/src/Juvix/Compiler/Tree.hs @@ -0,0 +1,10 @@ +module Juvix.Compiler.Tree + ( module Juvix.Compiler.Tree.Language, + module Juvix.Compiler.Tree.Data.InfoTable, + module Juvix.Compiler.Tree.Translation.FromCore, + ) +where + +import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Language +import Juvix.Compiler.Tree.Translation.FromCore diff --git a/src/Juvix/Compiler/Tree/Data/InfoTable.hs b/src/Juvix/Compiler/Tree/Data/InfoTable.hs new file mode 100644 index 0000000000..283d10fe79 --- /dev/null +++ b/src/Juvix/Compiler/Tree/Data/InfoTable.hs @@ -0,0 +1,12 @@ +module Juvix.Compiler.Tree.Data.InfoTable + ( module Juvix.Compiler.Tree.Data.InfoTable, + module Juvix.Compiler.Tree.Data.InfoTable.Base, + ) +where + +import Juvix.Compiler.Tree.Data.InfoTable.Base +import Juvix.Compiler.Tree.Language + +type InfoTable = InfoTable' Node () + +type FunctionInfo = FunctionInfo' Node () diff --git a/src/Juvix/Compiler/Tree/Data/InfoTable/Base.hs b/src/Juvix/Compiler/Tree/Data/InfoTable/Base.hs new file mode 100644 index 0000000000..50bb780f8a --- /dev/null +++ b/src/Juvix/Compiler/Tree/Data/InfoTable/Base.hs @@ -0,0 +1,83 @@ +module Juvix.Compiler.Tree.Data.InfoTable.Base + ( module Juvix.Compiler.Tree.Data.InfoTable.Base, + module Juvix.Compiler.Tree.Language.Rep, + module Juvix.Compiler.Tree.Language.Type, + ) +where + +import Data.HashMap.Strict qualified as HashMap +import Juvix.Compiler.Tree.Language +import Juvix.Compiler.Tree.Language.Rep +import Juvix.Compiler.Tree.Language.Type + +data InfoTable' a e = InfoTable + { _infoFunctions :: HashMap Symbol (FunctionInfo' a e), + _infoConstrs :: HashMap Tag ConstructorInfo, + _infoInductives :: HashMap Symbol InductiveInfo, + _infoMainFunction :: Maybe Symbol + } + +data FunctionInfo' a e = FunctionInfo + { _functionName :: Text, + _functionLocation :: Maybe Location, + _functionSymbol :: Symbol, + -- | `_functionArgsNum` may be different from `length (typeArgs + -- (_functionType))` only if it is 0 (the "function" takes zero arguments) + -- and the result is a function. + _functionArgsNum :: Int, + -- | length _functionArgNames == _functionArgsNum + _functionArgNames :: [Maybe Text], + _functionType :: Type, + _functionExtra :: e, + _functionCode :: a + } + +data ConstructorInfo = ConstructorInfo + { _constructorName :: Text, + _constructorLocation :: Maybe Location, + _constructorTag :: Tag, + -- | `_constructorArgsNum` should always be equal to `length (typeArgs + -- (_constructorType))`. It is stored separately mainly for the benefit of + -- the interpreter (so it does not have to recompute it every time). + _constructorArgsNum :: Int, + -- | length _constructorArgNames == _constructorArgsNum + _constructorArgNames :: [Maybe Text], + -- | Constructor types are assumed to be fully uncurried, i.e., `uncurryType + -- _constructorType == _constructorType` + _constructorType :: Type, + _constructorInductive :: Symbol, + _constructorRepresentation :: MemRep, + _constructorFixity :: Maybe Fixity + } + +data InductiveInfo = InductiveInfo + { _inductiveName :: Text, + _inductiveLocation :: Maybe Location, + _inductiveSymbol :: Symbol, + _inductiveKind :: Type, + _inductiveConstructors :: [Tag], + _inductiveRepresentation :: IndRep + } + +makeLenses ''InfoTable' +makeLenses ''FunctionInfo' +makeLenses ''ConstructorInfo +makeLenses ''InductiveInfo + +emptyInfoTable :: InfoTable' a e +emptyInfoTable = + InfoTable + { _infoFunctions = mempty, + _infoConstrs = mempty, + _infoInductives = mempty, + _infoMainFunction = Nothing + } + +lookupFunInfo :: InfoTable' a e -> Symbol -> FunctionInfo' a e +lookupFunInfo infoTable sym = fromMaybe (error "invalid function symbol") (HashMap.lookup sym (infoTable ^. infoFunctions)) + +lookupConstrInfo :: InfoTable' a e -> Tag -> ConstructorInfo +lookupConstrInfo infoTable tag = fromMaybe (error "invalid constructor 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)) diff --git a/src/Juvix/Compiler/Tree/Extra/Type.hs b/src/Juvix/Compiler/Tree/Extra/Type.hs new file mode 100644 index 0000000000..0cf65df63b --- /dev/null +++ b/src/Juvix/Compiler/Tree/Extra/Type.hs @@ -0,0 +1,43 @@ +module Juvix.Compiler.Tree.Extra.Type where + +import Juvix.Compiler.Tree.Language.Base +import Juvix.Compiler.Tree.Language.Type + +mkTypeInteger :: Type +mkTypeInteger = TyInteger (TypeInteger Nothing Nothing) + +mkTypeBool :: Type +mkTypeBool = TyBool (TypeBool (BuiltinTag TagTrue) (BuiltinTag TagFalse)) + +mkTypeConstr :: Symbol -> Tag -> [Type] -> Type +mkTypeConstr ind tag argTypes = TyConstr (TypeConstr ind tag argTypes) + +mkTypeInductive :: Symbol -> Type +mkTypeInductive ind = TyInductive (TypeInductive ind) + +mkTypeFun :: [Type] -> Type -> Type +mkTypeFun args tgt = case args of + [] -> tgt + a : args' -> TyFun (TypeFun (a :| args') tgt) + +unfoldType :: Type -> ([Type], Type) +unfoldType ty = (typeArgs ty, typeTarget ty) + +-- converts e.g. `A -> B -> C -> D` to `(A, B, C) -> D` where `D` is an atom +uncurryType :: Type -> Type +uncurryType ty = case typeArgs ty of + [] -> + ty + tyargs -> + let ty' = uncurryType (typeTarget ty) + in mkTypeFun (tyargs ++ typeArgs ty') (typeTarget ty') + +-- converts e.g. `(A, B, C) -> (D, E) -> F` to `A -> B -> C -> D -> E -> F` +-- where `F` is an atom +curryType :: Type -> Type +curryType ty = case typeArgs ty of + [] -> + ty + tyargs -> + let ty' = curryType (typeTarget ty) + in foldr (\tyarg ty'' -> mkTypeFun [tyarg] ty'') (typeTarget ty') tyargs diff --git a/src/Juvix/Compiler/Tree/Language.hs b/src/Juvix/Compiler/Tree/Language.hs new file mode 100644 index 0000000000..69931d930f --- /dev/null +++ b/src/Juvix/Compiler/Tree/Language.hs @@ -0,0 +1,161 @@ +module Juvix.Compiler.Tree.Language + ( module Juvix.Compiler.Tree.Language, + module Juvix.Compiler.Tree.Language.Base, + ) +where + +import Juvix.Compiler.Tree.Language.Base + +-- | MemRefs are references to values stored in memory. +type MemRef = MemRef' DirectRef + +-- | DirectRef is a direct memory reference. +data DirectRef + = -- | ArgRef references an argument in the argument area (0-based offsets). + -- JVT code: 'arg[]'. + ArgRef OffsetRef + | -- | TempRef references a value in the temporary stack (0-based offsets, + -- counted from the _bottom_ of the temporary stack). JVT code: + -- 'tmp[]'. + TempRef OffsetRef + +-- | Constructor field reference. JVT code: '.[]' +type Field = Field' DirectRef + +-- | Function call type +data CallType = CallFun Symbol | CallClosure Node + +data Node + = Binop NodeBinop + | Unop NodeUnop + | -- | A constant value. + Const Constant + | -- | A memory reference. + MemRef MemRef + | -- | Allocate constructor data. JVT code: 'alloc(, x1, .., xn)'. + AllocConstr NodeAllocConstr + | -- | Allocate a closure. JVT code: 'calloc(, x1, .., xn)'. + AllocClosure NodeAllocClosure + | -- | Extend a closure with more arguments. JVT code: 'cextend(cl, x1, .., xn)'. + ExtendClosure NodeExtendClosure + | -- | Call a function given by an immediate constant Symbol or a closure. JVT + -- code: 'call(, x1, .., xn)' or 'call(cl, x1, .., xn)' + Call NodeCall + | -- | 'CallClosures' is like 'Call' with 'CallClosure' call type, except that + -- (1) it either calls or extends the closure depending on the number of + -- supplied arguments vs the number of expected arguments fetched at runtime + -- from the closure, and (2) if the number of expected arguments is smaller + -- than the number of supplied arguments, then the result of the call must + -- be another closure and the process is repeated until we run out of + -- supplied arguments. JVT code: 'ccall(cl, x1, .., xn)'. + CallClosures NodeCallClosures + | -- | Branch based on a boolean value. JVT code: 'br(x) { true: ; + -- false: }'. + Branch NodeBranch + | -- | Branch based on the tag of constructor data. + -- JVT code: 'case(, x) { : ; ... : ; default: }' + -- (any branch may be omitted). + Case NodeCase + | -- | Execute nested code with temporary stack extended with a given value. + -- Used to implement Core.Let and Core.Case. JVT codes: 'save(x) {}', + -- 'save(, x) {}'. + Save NodeSave + +data BinaryOpcode + = IntAdd + | IntSub + | IntMul + | IntDiv + | IntMod + | IntLt + | IntLe + | ValEq + | StrConcat + | -- | Sequence: evaluate and ignore fist argument, return evaluated second + -- argument. JVT code: 'seq(x1, x2)'. + OpSeq + +data UnaryOpcode + = -- | Convert the argument to a string. JVT code: 'show(x)'. + OpShow + | -- | Convert a string to an integer. JVT opcode: 'atoi(x)'. + OpStrToInt + | -- | Print a debug log of the argument and return it. JVT code: 'trace(x)'. + OpTrace + | -- | Interrupt execution with a runtime error printing the argument. JVT + -- code: 'fail(x)'. + OpFail + | -- | Compute the number of expected arguments for the given closure. JVT + -- code: 'argsnum(x)'. + OpArgsNum + +data NodeBinop = NodeBinop + { _nodeBinopOpcode :: BinaryOpcode, + _nodeBinopArg1 :: Node, + _nodeBinopArg2 :: Node + } + +data NodeUnop = NodeUnop + { _nodeUnopOpcode :: UnaryOpcode, + _nodeUnopArg :: Node + } + +data NodeAllocConstr = NodeAllocConstr + { _nodeAllocConstrTag :: Tag, + _nodeAllocConstrArgs :: [Node] + } + +data NodeAllocClosure = NodeAllocClosure + { _nodeAllocClosureFunSymbol :: Symbol, + _nodeAllocClosureArgs :: [Node] + } + +data NodeExtendClosure = NodeExtendClosure + { _nodeExtendClosureFun :: Node, + _nodeExtendClosureArgs :: NonEmpty Node + } + +data NodeCall = NodeCall + { _nodeCallType :: CallType, + _nodeCallArgs :: [Node] + } + +data NodeCallClosures = NodeCallClosures + { _nodeCallClosuresFun :: Node, + _nodeCallClosuresArgs :: [Node] + } + +data NodeBranch = NodeBranch + { _nodeBranchArg :: Node, + _nodeBranchTrue :: Node, + _nodeBranchFalse :: Node + } + +data NodeCase = NodeCase + { _nodeCaseInductive :: Symbol, + _nodeCaseArg :: Node, + _nodeCaseBranches :: [CaseBranch], + _nodeCaseDefault :: Maybe Node + } + +data CaseBranch = CaseBranch + { _caseBranchTag :: Tag, + _caseBranchBody :: Node, + -- | Indicates whether the evaluated case argument should be pushed onto the + -- temporary stack in this branch. + _caseBranchSave :: Bool + } + +data NodeSave = NodeSave + { _nodeSaveName :: Maybe Text, + _nodeSaveArg :: Node, + _nodeSaveBody :: Node + } + +makeLenses ''NodeAllocClosure +makeLenses ''NodeExtendClosure +makeLenses ''NodeCall +makeLenses ''NodeCallClosures +makeLenses ''NodeBranch +makeLenses ''NodeCase +makeLenses ''NodeSave diff --git a/src/Juvix/Compiler/Tree/Language/Base.hs b/src/Juvix/Compiler/Tree/Language/Base.hs new file mode 100644 index 0000000000..527dd17fc5 --- /dev/null +++ b/src/Juvix/Compiler/Tree/Language/Base.hs @@ -0,0 +1,45 @@ +module Juvix.Compiler.Tree.Language.Base + ( module Juvix.Compiler.Tree.Language.Base, + module Juvix.Compiler.Core.Language.Base, + ) +where + +import Juvix.Compiler.Core.Language.Base + +-- | Offset of a data field or an argument +type Offset = Int + +-- | Constant values. Void is an unprintable unit. +data Constant + = ConstInt Integer + | ConstBool Bool + | ConstString Text + | ConstUnit + | ConstVoid + +-- | MemRefs are references to values stored in memory. +data MemRef' r + = -- | A direct memory reference. + DRef r + | -- | ConstrRef is an indirect reference to a field (argument) of + -- a constructor: field k holds the (k+1)th argument. + ConstrRef (Field' r) + +data OffsetRef = OffsetRef + { _offsetRefOffset :: Offset, + _offsetRefName :: Maybe Text + } + +-- | Constructor field reference. +data Field' r = Field + { _fieldName :: Maybe Text, + -- | tag of the constructor being referenced + _fieldTag :: Tag, + -- | location where the data is stored + _fieldRef :: r, + _fieldOffset :: Offset + } + deriving stock (Functor) + +makeLenses ''Field' +makeLenses ''OffsetRef diff --git a/src/Juvix/Compiler/Asm/Language/Rep.hs b/src/Juvix/Compiler/Tree/Language/Rep.hs similarity index 98% rename from src/Juvix/Compiler/Asm/Language/Rep.hs rename to src/Juvix/Compiler/Tree/Language/Rep.hs index 02ed14c8fd..e52f81029b 100644 --- a/src/Juvix/Compiler/Asm/Language/Rep.hs +++ b/src/Juvix/Compiler/Tree/Language/Rep.hs @@ -1,4 +1,4 @@ -module Juvix.Compiler.Asm.Language.Rep where +module Juvix.Compiler.Tree.Language.Rep where -- | Memory representation of a constructor. data MemRep diff --git a/src/Juvix/Compiler/Asm/Language/Type.hs b/src/Juvix/Compiler/Tree/Language/Type.hs similarity index 97% rename from src/Juvix/Compiler/Asm/Language/Type.hs rename to src/Juvix/Compiler/Tree/Language/Type.hs index a768fefc74..37bd52437e 100644 --- a/src/Juvix/Compiler/Asm/Language/Type.hs +++ b/src/Juvix/Compiler/Tree/Language/Type.hs @@ -1,4 +1,4 @@ -module Juvix.Compiler.Asm.Language.Type where +module Juvix.Compiler.Tree.Language.Type where import Juvix.Compiler.Core.Language.Base diff --git a/src/Juvix/Compiler/Tree/Translation/FromCore.hs b/src/Juvix/Compiler/Tree/Translation/FromCore.hs new file mode 100644 index 0000000000..d2d1f36d7c --- /dev/null +++ b/src/Juvix/Compiler/Tree/Translation/FromCore.hs @@ -0,0 +1,348 @@ +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.Language.Stripped qualified as Core +import Juvix.Compiler.Tree.Data.InfoTable +import Juvix.Compiler.Tree.Extra.Type +import Juvix.Compiler.Tree.Language + +type BinderList = BL.BinderList + +fromCore :: Core.InfoTable -> InfoTable +fromCore tab = + InfoTable + { _infoMainFunction = tab ^. Core.infoMain, + _infoFunctions = genCode tab <$> tab ^. Core.infoFunctions, + _infoInductives = translateInductiveInfo <$> tab ^. Core.infoInductives, + _infoConstrs = translateConstructorInfo <$> tab ^. Core.infoConstructors + } + +-- Generate code for a single function. +genCode :: Core.InfoTable -> Core.FunctionInfo -> FunctionInfo +genCode infoTable fi = + let argnames = map (Just . (^. Core.argumentName)) (fi ^. Core.functionArgsInfo) + code = + go + 0 + ( BL.fromList $ + reverse + ( map + (DRef . ArgRef) + ( zipWithExact + OffsetRef + [0 .. fi ^. Core.functionArgsNum - 1] + argnames + ) + ) + ) + (fi ^. Core.functionBody) + in FunctionInfo + { _functionName = fi ^. Core.functionName, + _functionLocation = fi ^. Core.functionLocation, + _functionSymbol = fi ^. Core.functionSymbol, + _functionArgsNum = fi ^. Core.functionArgsNum, + _functionArgNames = argnames, + _functionType = convertType (fi ^. Core.functionArgsNum) (fi ^. Core.functionType), + _functionCode = code, + _functionExtra = () + } + where + go :: Int -> BinderList MemRef -> Core.Node -> Node + go tempSize refs node = case node of + Core.NVar v -> goVar refs v + Core.NIdt idt -> goIdent idt + Core.NCst cst -> goConstant cst + Core.NApp apps -> goApps tempSize refs apps + Core.NBlt blt -> goBuiltinApp tempSize refs blt + Core.NCtr ctr -> goConstr tempSize refs ctr + Core.NLet lt -> goLet tempSize refs lt + Core.NCase c -> goCase tempSize refs c + Core.NIf x -> goIf tempSize refs x + + goVar :: BinderList MemRef -> Core.Var -> Node + goVar refs Core.Var {..} = + MemRef (BL.lookup _varIndex refs) + + goIdent :: Core.Ident -> Node + goIdent Core.Ident {..} = + if + | getArgsNum _identSymbol == 0 -> + Call $ + NodeCall + { _nodeCallType = CallFun _identSymbol, + _nodeCallArgs = [] + } + | otherwise -> + AllocClosure $ + NodeAllocClosure + { _nodeAllocClosureFunSymbol = _identSymbol, + _nodeAllocClosureArgs = [] + } + + goConstant :: Core.Constant -> Node + goConstant = \case + Core.Constant _ (Core.ConstInteger i) -> + Const (ConstInt i) + Core.Constant _ (Core.ConstString s) -> + Const (ConstString s) + + goApps :: Int -> BinderList MemRef -> Core.Apps -> Node + goApps tempSize refs (Core.Apps {..}) = + let suppliedArgs = map (go tempSize refs) _appsArgs + suppliedArgsNum = length suppliedArgs + in case _appsFun of + Core.FunIdent (Core.Ident {..}) -> + if + | argsNum > suppliedArgsNum -> + AllocClosure $ + NodeAllocClosure + { _nodeAllocClosureFunSymbol = _identSymbol, + _nodeAllocClosureArgs = suppliedArgs + } + | argsNum == suppliedArgsNum -> + Call $ + NodeCall + { _nodeCallType = CallFun _identSymbol, + _nodeCallArgs = suppliedArgs + } + | otherwise -> + -- If more arguments are supplied (suppliedArgsNum) than + -- the function eats up (argsNum), then the function + -- returns a closure. We should first call the function + -- (with Call) and then use CallClosures on the result + -- with the remaining arguments. + CallClosures $ + NodeCallClosures + { _nodeCallClosuresFun = + Call $ + NodeCall + { _nodeCallType = CallFun _identSymbol, + _nodeCallArgs = take argsNum suppliedArgs + }, + _nodeCallClosuresArgs = drop argsNum suppliedArgs + } + where + argsNum = getArgsNum _identSymbol + Core.FunVar Core.Var {..} -> + CallClosures $ + NodeCallClosures + { _nodeCallClosuresFun = MemRef $ BL.lookup _varIndex refs, + _nodeCallClosuresArgs = suppliedArgs + } + + goBuiltinApp :: Int -> BinderList MemRef -> Core.BuiltinApp -> Node + goBuiltinApp tempSize refs (Core.BuiltinApp {..}) = + case args of + [arg] -> + Unop $ + NodeUnop + { _nodeUnopOpcode = genUnOp _builtinAppOp, + _nodeUnopArg = arg + } + [arg1, arg2] -> + Binop $ + NodeBinop + { _nodeBinopOpcode = genBinOp _builtinAppOp, + _nodeBinopArg1 = arg1, + _nodeBinopArg2 = arg2 + } + _ -> + impossible + where + args = map (go tempSize refs) _builtinAppArgs + + goConstr :: Int -> BinderList MemRef -> Core.Constr -> Node + goConstr tempSize refs = \case + Core.Constr _ (Core.BuiltinTag Core.TagTrue) _ -> + Const (ConstBool True) + Core.Constr _ (Core.BuiltinTag Core.TagFalse) _ -> + Const (ConstBool False) + Core.Constr {..} -> + AllocConstr $ + NodeAllocConstr + { _nodeAllocConstrTag = _constrTag, + _nodeAllocConstrArgs = args + } + where + args = map (go tempSize refs) _constrArgs + + goLet :: Int -> BinderList MemRef -> Core.Let -> Node + goLet tempSize refs (Core.Let {..}) = + Save $ + NodeSave + { _nodeSaveArg = arg, + _nodeSaveBody = body, + _nodeSaveName = Just name + } + where + name = _letItem ^. Core.letItemBinder . Core.binderName + nameRef = OffsetRef tempSize (Just name) + arg = go tempSize refs (_letItem ^. Core.letItemValue) + body = go (tempSize + 1) (BL.cons (DRef (TempRef nameRef)) refs) _letBody + + goCase :: Int -> BinderList MemRef -> Core.Case -> Node + goCase tempSize refs (Core.Case {..}) = + Case $ + NodeCase + { _nodeCaseArg = go tempSize refs _caseValue, + _nodeCaseInductive = _caseInductive, + _nodeCaseBranches = compileCaseBranches _caseBranches, + _nodeCaseDefault = fmap compileCaseDefault _caseDefault + } + where + compileCaseBranches :: [Core.CaseBranch] -> [CaseBranch] + compileCaseBranches branches = + map + ( \(Core.CaseBranch {..}) -> + if + | _caseBranchBindersNum == 0 -> + compileCaseBranchNoBinders _caseBranchTag _caseBranchBody + | otherwise -> + compileCaseBranch _caseBranchBindersNum _caseBranchTag _caseBranchBody + ) + branches + + compileCaseBranchNoBinders :: Tag -> Core.Node -> CaseBranch + compileCaseBranchNoBinders tag body = + CaseBranch + { _caseBranchTag = tag, + _caseBranchBody = go tempSize refs body, + _caseBranchSave = False + } + + compileCaseBranch :: Int -> Tag -> Core.Node -> CaseBranch + compileCaseBranch bindersNum tag body = + CaseBranch + { _caseBranchTag = tag, + _caseBranchBody = + go + (tempSize + 1) + ( BL.prepend + (map mkFieldRef (reverse [0 .. bindersNum - 1])) + refs + ) + body, + _caseBranchSave = True + } + where + mkFieldRef :: Offset -> MemRef + mkFieldRef off = + ConstrRef $ + Field + { _fieldName = Nothing, + _fieldTag = tag, + _fieldRef = TempRef (OffsetRef tempSize Nothing), + _fieldOffset = off + } + + compileCaseDefault :: Core.Node -> Node + compileCaseDefault = go tempSize refs + + goIf :: Int -> BinderList MemRef -> Core.If -> Node + goIf tempSize refs (Core.If {..}) = + Branch $ + NodeBranch + { _nodeBranchArg = go tempSize refs _ifValue, + _nodeBranchTrue = go tempSize refs _ifTrue, + _nodeBranchFalse = go tempSize refs _ifFalse + } + + genBinOp :: Core.BuiltinOp -> BinaryOpcode + genBinOp = \case + Core.OpIntAdd -> IntAdd + Core.OpIntSub -> IntSub + Core.OpIntMul -> IntMul + Core.OpIntDiv -> IntDiv + Core.OpIntMod -> IntMod + Core.OpIntLt -> IntLt + Core.OpIntLe -> IntLe + Core.OpEq -> ValEq + Core.OpStrConcat -> StrConcat + Core.OpSeq -> OpSeq + _ -> impossible + + genUnOp :: Core.BuiltinOp -> UnaryOpcode + genUnOp = \case + Core.OpShow -> OpShow + Core.OpStrToInt -> OpStrToInt + Core.OpTrace -> OpTrace + Core.OpFail -> OpFail + _ -> impossible + + getArgsNum :: Symbol -> Int + getArgsNum sym = + fromMaybe + impossible + (HashMap.lookup sym (infoTable ^. Core.infoFunctions)) + ^. Core.functionArgsNum + +-- | Be mindful that JuvixTree types are explicitly uncurried, while +-- Core.Stripped types are always curried. If a function takes `n` arguments, +-- then the first `n` arguments should be uncurried in its JuvixTree type. +convertType :: Int -> Core.Type -> Type +convertType argsNum ty = + case ty of + Core.TyDynamic -> + TyDynamic + Core.TyPrim x -> + convertPrimitiveType x + Core.TyApp Core.TypeApp {..} -> + TyInductive (TypeInductive _typeAppSymbol) + Core.TyFun {} -> + let (tgt, tyargs) = Core.unfoldType ty + tyargs' = map convertNestedType tyargs + tgt' = convertType 0 tgt + in mkTypeFun (take argsNum tyargs') (mkTypeFun (drop argsNum tyargs') tgt') + +convertPrimitiveType :: Core.Primitive -> Type +convertPrimitiveType = \case + Core.PrimInteger Core.PrimIntegerInfo {..} -> + TyInteger (TypeInteger _infoMinValue _infoMaxValue) + Core.PrimBool Core.PrimBoolInfo {..} -> + TyBool (TypeBool _infoTrueTag _infoFalseTag) + Core.PrimString -> + TyString + +-- | `convertNestedType` ensures that the conversion of a type with Dynamic in the +-- target is curried. The result of `convertType 0 ty` is always uncurried. +convertNestedType :: Core.Type -> Type +convertNestedType ty = + case ty of + Core.TyFun {} -> + let (tgt, tyargs) = Core.unfoldType ty + in case tgt of + Core.TyDynamic -> + curryType (convertType 0 ty) + _ -> + mkTypeFun (map convertNestedType tyargs) (convertType 0 tgt) + _ -> + convertType 0 ty + +translateInductiveInfo :: Core.InductiveInfo -> InductiveInfo +translateInductiveInfo ii = + InductiveInfo + { _inductiveName = ii ^. Core.inductiveName, + _inductiveLocation = ii ^. Core.inductiveLocation, + _inductiveSymbol = ii ^. Core.inductiveSymbol, + _inductiveKind = convertType 0 (ii ^. Core.inductiveKind), + _inductiveConstructors = ii ^. Core.inductiveConstructors, + _inductiveRepresentation = IndRepStandard + } + +translateConstructorInfo :: Core.ConstructorInfo -> ConstructorInfo +translateConstructorInfo ci = + ConstructorInfo + { _constructorName = ci ^. Core.constructorName, + _constructorLocation = ci ^. Core.constructorLocation, + _constructorTag = ci ^. Core.constructorTag, + _constructorArgsNum = length (typeArgs ty), + _constructorArgNames = ci ^. Core.constructorArgNames, + _constructorType = ty, + _constructorInductive = ci ^. Core.constructorInductive, + _constructorRepresentation = MemRepConstr, + _constructorFixity = ci ^. Core.constructorFixity + } + where + ty = convertType 0 (ci ^. Core.constructorType) diff --git a/test/Core/Asm/Base.hs b/test/Core/Asm/Base.hs index 960d58a316..dfb21aaa27 100644 --- a/test/Core/Asm/Base.hs +++ b/test/Core/Asm/Base.hs @@ -5,12 +5,13 @@ import Base import Core.Eval.Base import Core.Eval.Positive qualified as Eval import Data.Text.IO qualified as TIO -import Juvix.Compiler.Asm.Translation.FromCore qualified as Asm +import Juvix.Compiler.Asm.Translation.FromTree qualified as Asm import Juvix.Compiler.Core.Data.Module (computeCombinedInfoTable, moduleFromInfoTable) import Juvix.Compiler.Core.Options import Juvix.Compiler.Core.Pipeline import Juvix.Compiler.Core.Translation.FromSource import Juvix.Compiler.Core.Translation.Stripped.FromCore qualified as Stripped +import Juvix.Compiler.Tree.Translation.FromCore qualified as Tree import Juvix.Data.PPOutput newtype Test = Test @@ -54,5 +55,5 @@ coreAsmAssertion mainFile expectedFile step = do case run $ runReader defaultCoreOptions $ runError $ toStored' >=> toStripped' $ moduleFromInfoTable $ setupMainFunction defaultModuleId tabIni node of Left err -> assertFailure (show (pretty (fromJuvixError @GenericError err))) Right m -> do - let tab = Asm.fromCore $ Stripped.fromCore $ computeCombinedInfoTable m + let tab = Asm.fromTree $ Tree.fromCore $ Stripped.fromCore $ computeCombinedInfoTable m Asm.asmRunAssertion' tab expectedFile step diff --git a/test/Core/Compile/Base.hs b/test/Core/Compile/Base.hs index 6cd7d4399f..290e6b6c23 100644 --- a/test/Core/Compile/Base.hs +++ b/test/Core/Compile/Base.hs @@ -7,13 +7,14 @@ import Core.Eval.Positive qualified as Eval import Data.Text.IO qualified as TIO import GHC.Base (seq) import Juvix.Compiler.Asm.Pretty qualified as Asm -import Juvix.Compiler.Asm.Translation.FromCore qualified as Asm +import Juvix.Compiler.Asm.Translation.FromTree qualified as Asm import Juvix.Compiler.Core.Data.Module import Juvix.Compiler.Core.Extra.Utils import Juvix.Compiler.Core.Options import Juvix.Compiler.Core.Pipeline import Juvix.Compiler.Core.Translation.FromSource import Juvix.Compiler.Core.Translation.Stripped.FromCore qualified as Stripped +import Juvix.Compiler.Tree.Translation.FromCore qualified as Tree import Juvix.Data.PPOutput newtype Test = Test @@ -53,7 +54,7 @@ coreCompileAssertion' optLevel tab mainFile expectedFile stdinText step = do Right m -> do let tab0 = computeCombinedInfoTable m assertBool "Check info table" (checkInfoTable tab0) - let tab' = Asm.fromCore $ Stripped.fromCore tab0 + let tab' = Asm.fromTree $ Tree.fromCore $ Stripped.fromCore tab0 length (fromText (Asm.ppPrint tab' tab') :: String) `seq` Asm.asmCompileAssertion' optLevel tab' mainFile expectedFile stdinText step where From f00b3c1df7c5a45f67c6db4a2795354cdd8958ab Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Wed, 17 Jan 2024 11:35:31 +0100 Subject: [PATCH 2/4] fix after merge --- src/Juvix/Compiler/Asm/Data/CallGraph.hs | 1 + .../Compiler/Asm/Data/InfoTableBuilder.hs | 1 + src/Juvix/Compiler/Asm/Extra/Apply.hs | 1 + src/Juvix/Compiler/Asm/Extra/Base.hs | 1 + src/Juvix/Compiler/Asm/Extra/Memory.hs | 1 + src/Juvix/Compiler/Asm/Extra/Recursors.hs | 1 + src/Juvix/Compiler/Asm/Extra/Type.hs | 1 + src/Juvix/Compiler/Asm/Pipeline.hs | 1 + src/Juvix/Compiler/Asm/Pretty.hs | 1 + src/Juvix/Compiler/Asm/Pretty/Options.hs | 1 + .../Asm/Transformation/FilterUnreachable.hs | 1 + .../Compiler/Asm/Translation/FromCore.hs | 373 ------------------ .../Compiler/Asm/Translation/FromSource.hs | 1 + .../Compiler/Asm/Translation/FromTree.hs | 2 +- .../Compiler/Nockma/Translation/FromAsm.hs | 11 +- src/Juvix/Compiler/Reg/Translation/FromAsm.hs | 1 + 16 files changed, 20 insertions(+), 379 deletions(-) delete mode 100644 src/Juvix/Compiler/Asm/Translation/FromCore.hs diff --git a/src/Juvix/Compiler/Asm/Data/CallGraph.hs b/src/Juvix/Compiler/Asm/Data/CallGraph.hs index 43d19d4d4d..3cf0ebddfe 100644 --- a/src/Juvix/Compiler/Asm/Data/CallGraph.hs +++ b/src/Juvix/Compiler/Asm/Data/CallGraph.hs @@ -3,6 +3,7 @@ module Juvix.Compiler.Asm.Data.CallGraph where import Data.HashSet qualified as HashSet import Juvix.Compiler.Asm.Data.InfoTable import Juvix.Compiler.Asm.Extra +import Juvix.Compiler.Asm.Language -- | Call graph type type CallGraph = DependencyInfo Symbol diff --git a/src/Juvix/Compiler/Asm/Data/InfoTableBuilder.hs b/src/Juvix/Compiler/Asm/Data/InfoTableBuilder.hs index b2275b8e1d..1451da934f 100644 --- a/src/Juvix/Compiler/Asm/Data/InfoTableBuilder.hs +++ b/src/Juvix/Compiler/Asm/Data/InfoTableBuilder.hs @@ -2,6 +2,7 @@ module Juvix.Compiler.Asm.Data.InfoTableBuilder where import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Language data IdentKind = IdentFun Symbol diff --git a/src/Juvix/Compiler/Asm/Extra/Apply.hs b/src/Juvix/Compiler/Asm/Extra/Apply.hs index 39e0e4927c..840867487d 100644 --- a/src/Juvix/Compiler/Asm/Extra/Apply.hs +++ b/src/Juvix/Compiler/Asm/Extra/Apply.hs @@ -5,6 +5,7 @@ import Data.HashMap.Strict qualified as HashMap import Data.Text.Encoding import Juvix.Compiler.Asm.Data.InfoTable import Juvix.Compiler.Asm.Data.InfoTableBuilder +import Juvix.Compiler.Asm.Language import Juvix.Compiler.Asm.Translation.FromSource data ApplyBuiltins = ApplyBuiltins diff --git a/src/Juvix/Compiler/Asm/Extra/Base.hs b/src/Juvix/Compiler/Asm/Extra/Base.hs index 6c3b02421c..5d2e5d49a4 100644 --- a/src/Juvix/Compiler/Asm/Extra/Base.hs +++ b/src/Juvix/Compiler/Asm/Extra/Base.hs @@ -1,6 +1,7 @@ module Juvix.Compiler.Asm.Extra.Base where import Juvix.Compiler.Asm.Data.InfoTable +import Juvix.Compiler.Asm.Language mkInstr :: Instruction -> Command mkInstr = Instr . CmdInstr emptyInfo diff --git a/src/Juvix/Compiler/Asm/Extra/Memory.hs b/src/Juvix/Compiler/Asm/Extra/Memory.hs index c00adf4f70..8bc21384c4 100644 --- a/src/Juvix/Compiler/Asm/Extra/Memory.hs +++ b/src/Juvix/Compiler/Asm/Extra/Memory.hs @@ -6,6 +6,7 @@ import Juvix.Compiler.Asm.Data.Stack (Stack) import Juvix.Compiler.Asm.Data.Stack qualified as Stack import Juvix.Compiler.Asm.Error import Juvix.Compiler.Asm.Extra.Type +import Juvix.Compiler.Asm.Language import Juvix.Compiler.Asm.Pretty import Safe (atMay) diff --git a/src/Juvix/Compiler/Asm/Extra/Recursors.hs b/src/Juvix/Compiler/Asm/Extra/Recursors.hs index 3573bc4370..99a6206694 100644 --- a/src/Juvix/Compiler/Asm/Extra/Recursors.hs +++ b/src/Juvix/Compiler/Asm/Extra/Recursors.hs @@ -10,6 +10,7 @@ import Juvix.Compiler.Asm.Error import Juvix.Compiler.Asm.Extra.Base import Juvix.Compiler.Asm.Extra.Memory import Juvix.Compiler.Asm.Extra.Type +import Juvix.Compiler.Asm.Language import Juvix.Compiler.Asm.Pretty -- | Recursor signature. Contains read-only recursor parameters. diff --git a/src/Juvix/Compiler/Asm/Extra/Type.hs b/src/Juvix/Compiler/Asm/Extra/Type.hs index ef29742444..e5e9e6ba47 100644 --- a/src/Juvix/Compiler/Asm/Extra/Type.hs +++ b/src/Juvix/Compiler/Asm/Extra/Type.hs @@ -7,6 +7,7 @@ where import Data.List.NonEmpty qualified as NonEmpty import Juvix.Compiler.Asm.Data.InfoTable import Juvix.Compiler.Asm.Error +import Juvix.Compiler.Asm.Language import Juvix.Compiler.Asm.Pretty import Juvix.Compiler.Tree.Extra.Type diff --git a/src/Juvix/Compiler/Asm/Pipeline.hs b/src/Juvix/Compiler/Asm/Pipeline.hs index 66be53368d..1c13a041c2 100644 --- a/src/Juvix/Compiler/Asm/Pipeline.hs +++ b/src/Juvix/Compiler/Asm/Pipeline.hs @@ -10,6 +10,7 @@ import Juvix.Compiler.Asm.Extra import Juvix.Compiler.Asm.Options import Juvix.Compiler.Asm.Transformation import Juvix.Compiler.Pipeline.EntryPoint +import Juvix.Prelude -- | Perform transformations on JuvixAsm necessary before the translation to -- JuvixReg diff --git a/src/Juvix/Compiler/Asm/Pretty.hs b/src/Juvix/Compiler/Asm/Pretty.hs index b3ba68bf02..9fa1d33f57 100644 --- a/src/Juvix/Compiler/Asm/Pretty.hs +++ b/src/Juvix/Compiler/Asm/Pretty.hs @@ -9,6 +9,7 @@ import Juvix.Compiler.Asm.Data.InfoTable 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 diff --git a/src/Juvix/Compiler/Asm/Pretty/Options.hs b/src/Juvix/Compiler/Asm/Pretty/Options.hs index 59bb554668..5b9338e614 100644 --- a/src/Juvix/Compiler/Asm/Pretty/Options.hs +++ b/src/Juvix/Compiler/Asm/Pretty/Options.hs @@ -2,6 +2,7 @@ module Juvix.Compiler.Asm.Pretty.Options where import Juvix.Compiler.Asm.Data.InfoTable import Juvix.Compiler.Core.Pretty.Options qualified as Core +import Juvix.Prelude newtype Options = Options { _optInfoTable :: InfoTable diff --git a/src/Juvix/Compiler/Asm/Transformation/FilterUnreachable.hs b/src/Juvix/Compiler/Asm/Transformation/FilterUnreachable.hs index 30bcc0ca13..455f1d1b07 100644 --- a/src/Juvix/Compiler/Asm/Transformation/FilterUnreachable.hs +++ b/src/Juvix/Compiler/Asm/Transformation/FilterUnreachable.hs @@ -4,6 +4,7 @@ import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Asm.Data.CallGraph import Juvix.Compiler.Asm.Data.InfoTable import Juvix.Compiler.Asm.Error +import Juvix.Prelude filterUnreachable :: (Member (Error AsmError) r) => InfoTable -> Sem r InfoTable filterUnreachable tab = do diff --git a/src/Juvix/Compiler/Asm/Translation/FromCore.hs b/src/Juvix/Compiler/Asm/Translation/FromCore.hs deleted file mode 100644 index c2907413ed..0000000000 --- a/src/Juvix/Compiler/Asm/Translation/FromCore.hs +++ /dev/null @@ -1,373 +0,0 @@ -module Juvix.Compiler.Asm.Translation.FromCore (fromCore) where - -import Data.DList qualified as DL -import Data.HashMap.Strict qualified as HashMap -import Juvix.Compiler.Asm.Data.InfoTable -import Juvix.Compiler.Asm.Extra.Base -import Juvix.Compiler.Asm.Extra.Type -import Juvix.Compiler.Core.Data.BinderList qualified as BL -import Juvix.Compiler.Core.Data.Stripped.InfoTable qualified as Core -import Juvix.Compiler.Core.Language.Stripped qualified as Core - -type BinderList = BL.BinderList - --- DList for O(1) snoc and append -type Code' = DL.DList Command - -fromCore :: Core.InfoTable -> InfoTable -fromCore tab = - InfoTable - { _infoMainFunction = tab ^. Core.infoMain, - _infoFunctions = genCode tab <$> tab ^. Core.infoFunctions, - _infoInductives = translateInductiveInfo <$> tab ^. Core.infoInductives, - _infoConstrs = translateConstructorInfo <$> tab ^. Core.infoConstructors - } - --- Generate code for a single function. -genCode :: Core.InfoTable -> Core.FunctionInfo -> FunctionInfo -genCode infoTable fi = - let argnames = map (Just . (^. Core.argumentName)) (fi ^. Core.functionArgsInfo) - code = - DL.toList $ - go - True - 0 - ( BL.fromList $ - reverse - ( map - (Ref . DRef . ArgRef) - ( zipWithExact - OffsetRef - [0 .. fi ^. Core.functionArgsNum - 1] - argnames - ) - ) - ) - (fi ^. Core.functionBody) - in FunctionInfo - { _functionName = fi ^. Core.functionName, - _functionLocation = fi ^. Core.functionLocation, - _functionSymbol = fi ^. Core.functionSymbol, - _functionArgsNum = fi ^. Core.functionArgsNum, - _functionArgNames = argnames, - _functionType = convertType (fi ^. Core.functionArgsNum) (fi ^. Core.functionType), - _functionCode = code, - _functionMaxTempStackHeight = -1, -- computed later - _functionMaxValueStackHeight = -1 - } - where - -- Assumption: the BinderList does not contain references to the value stack - -- (directly or indirectly). - go :: Bool -> Int -> BinderList Value -> Core.Node -> Code' - go isTail tempSize refs node = case node of - Core.NVar v -> goVar isTail refs v - Core.NIdt idt -> goIdent isTail idt - Core.NCst cst -> goConstant isTail cst - Core.NApp apps -> goApps isTail tempSize refs apps - Core.NBlt blt -> goBuiltinApp isTail tempSize refs blt - Core.NCtr ctr -> goConstr isTail tempSize refs ctr - Core.NLet lt -> goLet isTail tempSize refs lt - Core.NCase c -> goCase isTail tempSize refs c - Core.NIf x -> goIf isTail tempSize refs x - - goVar :: Bool -> BinderList Value -> Core.Var -> Code' - goVar isTail refs Core.Var {..} = - snocReturn isTail $ - DL.singleton $ - mkInstr $ - Push (BL.lookup _varIndex refs) - - goIdent :: Bool -> Core.Ident -> Code' - goIdent isTail Core.Ident {..} = - if - | getArgsNum _identSymbol == 0 -> - DL.singleton $ - mkInstr $ - (if isTail then TailCall else Call) (InstrCall (CallFun _identSymbol) 0) - | otherwise -> - snocReturn isTail $ - DL.singleton $ - mkInstr $ - AllocClosure (InstrAllocClosure _identSymbol 0) - - goConstant :: Bool -> Core.Constant -> Code' - goConstant isTail = \case - Core.Constant _ (Core.ConstInteger i) -> - snocReturn isTail $ - DL.singleton $ - mkInstr $ - Push (ConstInt i) - Core.Constant _ (Core.ConstString s) -> - snocReturn isTail $ - DL.singleton $ - mkInstr $ - Push (ConstString s) - - goApps :: Bool -> Int -> BinderList Value -> Core.Apps -> Code' - goApps isTail tempSize refs (Core.Apps {..}) = - let suppliedArgs = reverse _appsArgs - suppliedArgsNum = length suppliedArgs - in case _appsFun of - Core.FunIdent (Core.Ident {..}) -> - if - | argsNum > suppliedArgsNum -> - snocReturn isTail $ - DL.snoc - (DL.concat (map (go False tempSize refs) suppliedArgs)) - (mkInstr $ AllocClosure (InstrAllocClosure _identSymbol suppliedArgsNum)) - | argsNum == suppliedArgsNum -> - DL.snoc - (DL.concat (map (go False tempSize refs) suppliedArgs)) - (mkInstr $ (if isTail then TailCall else Call) (InstrCall (CallFun _identSymbol) argsNum)) - | otherwise -> - -- If more arguments are supplied (suppliedArgsNum) than - -- the function eats up (argsNum), then the function - -- returns a closure. We should first call the function - -- (with Call) and then use CallClosures or - -- TailCallClosures on the result with the remaining - -- arguments. - DL.snoc - ( DL.snoc - (DL.concat (map (go False tempSize refs) suppliedArgs)) - (mkInstr $ Call (InstrCall (CallFun _identSymbol) argsNum)) - ) - (mkInstr $ (if isTail then TailCallClosures else CallClosures) (InstrCallClosures (suppliedArgsNum - argsNum))) - where - argsNum = getArgsNum _identSymbol - Core.FunVar Core.Var {..} -> - DL.snoc - ( DL.snoc - (DL.concat (map (go False tempSize refs) suppliedArgs)) - (mkInstr $ Push (BL.lookup _varIndex refs)) - ) - (mkInstr $ (if isTail then TailCallClosures else CallClosures) (InstrCallClosures suppliedArgsNum)) - - goBuiltinApp :: Bool -> Int -> BinderList Value -> Core.BuiltinApp -> Code' - goBuiltinApp isTail tempSize refs (Core.BuiltinApp {..}) = - case _builtinAppOp of - OpSeq -> - goSeq isTail tempSize refs _builtinAppArgs - _ -> - snocReturn isTail $ - DL.append - (DL.concat (map (go False tempSize refs) (reverse _builtinAppArgs))) - (genOp _builtinAppOp) - - goSeq :: Bool -> Int -> BinderList Value -> [Core.Node] -> Code' - goSeq isTail tempSize refs = \case - [arg1, arg2] -> - DL.append - (go False tempSize refs arg1) - ( DL.cons - (mkInstr Pop) - (go isTail tempSize refs arg2) - ) - _ -> impossible - - goConstr :: Bool -> Int -> BinderList Value -> Core.Constr -> Code' - goConstr isTail tempSize refs = \case - Core.Constr _ (Core.BuiltinTag Core.TagTrue) _ -> - snocReturn isTail $ - DL.singleton $ - mkInstr $ - Push (ConstBool True) - Core.Constr _ (Core.BuiltinTag Core.TagFalse) _ -> - snocReturn isTail $ - DL.singleton $ - mkInstr $ - Push (ConstBool False) - Core.Constr {..} -> - snocReturn isTail $ - DL.snoc - (DL.concat (map (go False tempSize refs) (reverse _constrArgs))) - (mkInstr $ AllocConstr _constrTag) - - goLet :: Bool -> Int -> BinderList Value -> Core.Let -> Code' - goLet isTail tempSize refs (Core.Let {..}) = - DL.snoc - (go False tempSize refs (_letItem ^. Core.letItemValue)) - ( Save $ - CmdSave - { _cmdSaveInfo = emptyInfo, - _cmdSaveIsTail = isTail, - _cmdSaveCode = DL.toList $ go isTail (tempSize + 1) (BL.cons (Ref (DRef (mkTempRef nameRef))) refs) _letBody, - _cmdSaveName = Just name - } - ) - where - name = _letItem ^. Core.letItemBinder . Core.binderName - nameRef = OffsetRef tempSize (Just name) - - goCase :: Bool -> Int -> BinderList Value -> Core.Case -> Code' - goCase isTail tempSize refs (Core.Case {..}) = - DL.snoc - (go False tempSize refs _caseValue) - ( Case $ - CmdCase - { _cmdCaseInfo = emptyInfo, - _cmdCaseInductive = _caseInductive, - _cmdCaseBranches = compileCaseBranches _caseBranches, - _cmdCaseDefault = fmap compileCaseDefault _caseDefault - } - ) - where - compileCaseBranches :: [Core.CaseBranch] -> [CaseBranch] - compileCaseBranches branches = - map - ( \(Core.CaseBranch {..}) -> - if - | _caseBranchBindersNum == 0 -> - compileCaseBranchNoBinders _caseBranchTag _caseBranchBody - | otherwise -> - compileCaseBranch _caseBranchBindersNum _caseBranchTag _caseBranchBody - ) - branches - - compileCaseBranchNoBinders :: Tag -> Core.Node -> CaseBranch - compileCaseBranchNoBinders tag body = - CaseBranch - tag - ( DL.toList $ - DL.cons (mkInstr Pop) $ - go isTail tempSize refs body - ) - - compileCaseBranch :: Int -> Tag -> Core.Node -> CaseBranch - compileCaseBranch bindersNum tag body = - CaseBranch - tag - [ Save $ - CmdSave - { _cmdSaveInfo = emptyInfo, - _cmdSaveIsTail = isTail, - _cmdSaveName = Nothing, - _cmdSaveCode = - DL.toList $ - go - isTail - (tempSize + 1) - ( BL.prepend - ( map - (Ref . ConstrRef . Field Nothing tag (mkTempRef (OffsetRef tempSize Nothing))) - (reverse [0 .. bindersNum - 1]) - ) - refs - ) - body - } - ] - - compileCaseDefault :: Core.Node -> Code - compileCaseDefault = - DL.toList - . DL.cons (mkInstr Pop) - . go isTail tempSize refs - - goIf :: Bool -> Int -> BinderList Value -> Core.If -> Code' - goIf isTail tempSize refs (Core.If {..}) = - DL.snoc - (go False tempSize refs _ifValue) - ( Branch $ - CmdBranch - { _cmdBranchInfo = emptyInfo, - _cmdBranchTrue = DL.toList $ go isTail tempSize refs _ifTrue, - _cmdBranchFalse = DL.toList $ go isTail tempSize refs _ifFalse - } - ) - - genOp :: Core.BuiltinOp -> Code' - genOp = \case - Core.OpIntAdd -> DL.singleton $ mkBinop IntAdd - Core.OpIntSub -> DL.singleton $ mkBinop IntSub - Core.OpIntMul -> DL.singleton $ mkBinop IntMul - Core.OpIntDiv -> DL.singleton $ mkBinop IntDiv - Core.OpIntMod -> DL.singleton $ mkBinop IntMod - Core.OpIntLt -> DL.singleton $ mkBinop IntLt - Core.OpIntLe -> DL.singleton $ mkBinop IntLe - Core.OpEq -> DL.singleton $ mkBinop ValEq - Core.OpShow -> DL.singleton $ mkInstr ValShow - Core.OpStrConcat -> DL.singleton $ mkBinop StrConcat - Core.OpStrToInt -> DL.singleton $ mkInstr StrToInt - Core.OpTrace -> DL.singleton $ mkInstr Trace - Core.OpFail -> DL.singleton $ mkInstr Failure - Core.OpSeq -> impossible - - getArgsNum :: Symbol -> Int - getArgsNum sym = - fromMaybe - impossible - (HashMap.lookup sym (infoTable ^. Core.infoFunctions)) - ^. Core.functionArgsNum - - snocReturn :: Bool -> Code' -> Code' - snocReturn True code = DL.snoc code (mkInstr Return) - snocReturn False code = code - --- | Be mindful that JuvixAsm types are explicitly uncurried, while --- Core.Stripped types are always curried. If a function takes `n` arguments, --- then the first `n` arguments should be uncurried in its JuvixAsm type. -convertType :: Int -> Core.Type -> Type -convertType argsNum ty = - case ty of - Core.TyDynamic -> - TyDynamic - Core.TyPrim x -> - convertPrimitiveType x - Core.TyApp Core.TypeApp {..} -> - TyInductive (TypeInductive _typeAppSymbol) - Core.TyFun {} -> - let (tgt, tyargs) = Core.unfoldType ty - tyargs' = map convertNestedType tyargs - tgt' = convertType 0 tgt - in mkTypeFun (take argsNum tyargs') (mkTypeFun (drop argsNum tyargs') tgt') - -convertPrimitiveType :: Core.Primitive -> Type -convertPrimitiveType = \case - Core.PrimInteger Core.PrimIntegerInfo {..} -> - TyInteger (TypeInteger _infoMinValue _infoMaxValue) - Core.PrimBool Core.PrimBoolInfo {..} -> - TyBool (TypeBool _infoTrueTag _infoFalseTag) - Core.PrimString -> - TyString - --- | `convertNestedType` ensures that the conversion of a type with Dynamic in the --- target is curried. The result of `convertType 0 ty` is always uncurried. -convertNestedType :: Core.Type -> Type -convertNestedType ty = - case ty of - Core.TyFun {} -> - let (tgt, tyargs) = Core.unfoldType ty - in case tgt of - Core.TyDynamic -> - curryType (convertType 0 ty) - _ -> - mkTypeFun (map convertNestedType tyargs) (convertType 0 tgt) - _ -> - convertType 0 ty - -translateInductiveInfo :: Core.InductiveInfo -> InductiveInfo -translateInductiveInfo ii = - InductiveInfo - { _inductiveName = ii ^. Core.inductiveName, - _inductiveLocation = ii ^. Core.inductiveLocation, - _inductiveSymbol = ii ^. Core.inductiveSymbol, - _inductiveKind = convertType 0 (ii ^. Core.inductiveKind), - _inductiveConstructors = ii ^. Core.inductiveConstructors, - _inductiveRepresentation = IndRepStandard - } - -translateConstructorInfo :: Core.ConstructorInfo -> ConstructorInfo -translateConstructorInfo ci = - ConstructorInfo - { _constructorName = ci ^. Core.constructorName, - _constructorLocation = ci ^. Core.constructorLocation, - _constructorTag = ci ^. Core.constructorTag, - _constructorArgsNum = length (typeArgs ty), - _constructorArgNames = ci ^. Core.constructorArgNames, - _constructorType = ty, - _constructorInductive = ci ^. Core.constructorInductive, - _constructorRepresentation = MemRepConstr, - _constructorFixity = ci ^. Core.constructorFixity - } - where - ty = convertType 0 (ci ^. Core.constructorType) diff --git a/src/Juvix/Compiler/Asm/Translation/FromSource.hs b/src/Juvix/Compiler/Asm/Translation/FromSource.hs index a5b5135a5b..3949b1202d 100644 --- a/src/Juvix/Compiler/Asm/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Asm/Translation/FromSource.hs @@ -12,6 +12,7 @@ import Juvix.Compiler.Asm.Data.InfoTable import Juvix.Compiler.Asm.Data.InfoTableBuilder import Juvix.Compiler.Asm.Extra.Base import Juvix.Compiler.Asm.Extra.Type +import Juvix.Compiler.Asm.Language import Juvix.Compiler.Asm.Translation.FromSource.Lexer import Juvix.Parser.Error import Text.Megaparsec qualified as P diff --git a/src/Juvix/Compiler/Asm/Translation/FromTree.hs b/src/Juvix/Compiler/Asm/Translation/FromTree.hs index e85ccf8809..8582e3f6a2 100644 --- a/src/Juvix/Compiler/Asm/Translation/FromTree.hs +++ b/src/Juvix/Compiler/Asm/Translation/FromTree.hs @@ -224,7 +224,7 @@ genCode fi = goDirectRef :: Tree.DirectRef -> DirectRef goDirectRef = \case Tree.ArgRef off -> ArgRef off - Tree.TempRef off -> TempRef off + Tree.TempRef off -> mkTempRef off goFieldRef :: Tree.Field -> Field goFieldRef = fmap goDirectRef diff --git a/src/Juvix/Compiler/Nockma/Translation/FromAsm.hs b/src/Juvix/Compiler/Nockma/Translation/FromAsm.hs index f3719a51cd..4d065d34b4 100644 --- a/src/Juvix/Compiler/Nockma/Translation/FromAsm.hs +++ b/src/Juvix/Compiler/Nockma/Translation/FromAsm.hs @@ -1,6 +1,7 @@ module Juvix.Compiler.Nockma.Translation.FromAsm where import Juvix.Compiler.Asm.Data.InfoTable qualified as Asm +import Juvix.Compiler.Asm.Language qualified as Asm import Juvix.Compiler.Nockma.Evaluator import Juvix.Compiler.Nockma.Pretty import Juvix.Compiler.Nockma.Stdlib @@ -309,13 +310,13 @@ compile = mapM_ goCommand goPush :: Asm.Value -> Sem r () goPush = \case - Asm.ConstInt i + Asm.Constant (Asm.ConstInt i) | i < 0 -> unsupported "negative numbers" | otherwise -> pushNat (fromInteger i) - Asm.ConstBool i -> push (nockBoolLiteral i) - Asm.ConstString {} -> stringsErr - Asm.ConstUnit -> push constUnit - Asm.ConstVoid -> push constVoid + Asm.Constant (Asm.ConstBool i) -> push (nockBoolLiteral i) + Asm.Constant Asm.ConstString {} -> stringsErr + Asm.Constant Asm.ConstUnit -> push constUnit + Asm.Constant Asm.ConstVoid -> push constVoid Asm.Ref r -> pushMemValue r where pushMemValue :: Asm.MemValue -> Sem r () diff --git a/src/Juvix/Compiler/Reg/Translation/FromAsm.hs b/src/Juvix/Compiler/Reg/Translation/FromAsm.hs index 411ad12ebe..fa2ea2c561 100644 --- a/src/Juvix/Compiler/Reg/Translation/FromAsm.hs +++ b/src/Juvix/Compiler/Reg/Translation/FromAsm.hs @@ -4,6 +4,7 @@ import Data.HashMap.Strict qualified as HashMap import Juvix.Compiler.Asm.Data.InfoTable 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.Language From f7d636982535d68fcac0d7e597c3c66640a8fbf7 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Thu, 18 Jan 2024 10:48:06 +0100 Subject: [PATCH 3/4] fix after merge --- src/Juvix/Compiler/Reg/Translation/FromAsm.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Juvix/Compiler/Reg/Translation/FromAsm.hs b/src/Juvix/Compiler/Reg/Translation/FromAsm.hs index cf176b44e8..c4acc78c0e 100644 --- a/src/Juvix/Compiler/Reg/Translation/FromAsm.hs +++ b/src/Juvix/Compiler/Reg/Translation/FromAsm.hs @@ -99,6 +99,9 @@ fromAsmInstr funInfo tab si Asm.CmdInstr {..} = Asm.Return -> return $ Return InstrReturn {_instrReturnValue = VRef $ VarRef VarGroupLocal ntmps} where + extraInfo :: Asm.FunctionInfoExtra + extraInfo = fromJust (funInfo ^. Asm.functionExtra) + -- `n` is the index of the top of the value stack *before* executing the -- instruction n :: Int @@ -106,7 +109,7 @@ fromAsmInstr funInfo tab si Asm.CmdInstr {..} = -- `ntmps` is the number of temporary variables (= max temporary stack height) ntmps :: Int - ntmps = funInfo ^. Asm.functionMaxTempStackHeight + ntmps = extraInfo ^. Asm.functionMaxTempStackHeight -- Live variables *after* executing the instruction. `k` is the number of -- value stack cells that will be popped by the instruction. TODO: proper @@ -270,7 +273,7 @@ fromAsmBranch fi si Asm.CmdBranch {} codeTrue codeFalse = return $ Branch $ InstrBranch - { _instrBranchValue = VRef $ VarRef VarGroupLocal (fi ^. Asm.functionMaxTempStackHeight + si ^. Asm.stackInfoValueStackHeight - 1), + { _instrBranchValue = VRef $ VarRef VarGroupLocal (fromJust (fi ^. Asm.functionExtra) ^. Asm.functionMaxTempStackHeight + si ^. Asm.stackInfoValueStackHeight - 1), _instrBranchTrue = codeTrue, _instrBranchFalse = codeFalse } @@ -287,7 +290,7 @@ fromAsmCase fi tab si Asm.CmdCase {..} brs def = return $ Case $ InstrCase - { _instrCaseValue = VRef $ VarRef VarGroupLocal (fi ^. Asm.functionMaxTempStackHeight + si ^. Asm.stackInfoValueStackHeight - 1), + { _instrCaseValue = VRef $ VarRef VarGroupLocal (fromJust (fi ^. Asm.functionExtra) ^. Asm.functionMaxTempStackHeight + si ^. Asm.stackInfoValueStackHeight - 1), _instrCaseInductive = _cmdCaseInductive, _instrCaseIndRep = ii ^. Asm.inductiveRepresentation, _instrCaseBranches = @@ -327,7 +330,7 @@ fromAsmSave fi si Asm.CmdSave {} block = Assign ( InstrAssign (VarRef VarGroupLocal (si ^. Asm.stackInfoTempStackHeight)) - (VRef $ VarRef VarGroupLocal (fi ^. Asm.functionMaxTempStackHeight + si ^. Asm.stackInfoValueStackHeight - 1)) + (VRef $ VarRef VarGroupLocal (fromJust (fi ^. Asm.functionExtra) ^. Asm.functionMaxTempStackHeight + si ^. Asm.stackInfoValueStackHeight - 1)) ) : block } From a40c55469e6601e3e8a005c12167c941bb84e6e7 Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Thu, 18 Jan 2024 11:05:59 +0100 Subject: [PATCH 4/4] changes for review --- app/Commands/Dev/Core/Asm.hs | 2 +- src/Juvix/Compiler/Asm/Extra/Memory.hs | 14 +++-- src/Juvix/Compiler/Asm/Interpreter.hs | 14 +++-- src/Juvix/Compiler/Asm/Pretty/Base.hs | 29 +++++---- src/Juvix/Compiler/Tree/Extra/Type.hs | 4 +- .../Compiler/Tree/Translation/FromCore.hs | 60 ++++++++----------- 6 files changed, 64 insertions(+), 59 deletions(-) diff --git a/app/Commands/Dev/Core/Asm.hs b/app/Commands/Dev/Core/Asm.hs index 52fd1b8799..16d77af866 100644 --- a/app/Commands/Dev/Core/Asm.hs +++ b/app/Commands/Dev/Core/Asm.hs @@ -12,7 +12,7 @@ runCommand opts = do ep <- getEntryPoint sinputFile s' <- readFile $ toFilePath inputFile tab <- getRight (mapLeft JuvixError (Core.runParserMain inputFile defaultModuleId mempty s')) - r <- runReader ep $ runError @JuvixError $ coreToAsm (Core.moduleFromInfoTable tab) + r <- runReader ep . runError @JuvixError $ coreToAsm (Core.moduleFromInfoTable tab) tab' <- getRight r if | project opts ^. coreAsmPrint -> diff --git a/src/Juvix/Compiler/Asm/Extra/Memory.hs b/src/Juvix/Compiler/Asm/Extra/Memory.hs index 8bc21384c4..d53842ed14 100644 --- a/src/Juvix/Compiler/Asm/Extra/Memory.hs +++ b/src/Juvix/Compiler/Asm/Extra/Memory.hs @@ -103,13 +103,17 @@ getDirectRefType dr mem = case dr of TempRef RefTemp {..} -> bottomTempStack (_refTempOffsetRef ^. offsetRefOffset) mem +getConstantType :: Constant -> Type +getConstantType = \case + ConstInt {} -> mkTypeInteger + ConstBool {} -> mkTypeBool + ConstString {} -> TyString + ConstUnit -> TyUnit + ConstVoid -> TyVoid + getValueType' :: (Member (Error AsmError) r) => Maybe Location -> InfoTable -> Memory -> Value -> Sem r Type getValueType' loc tab mem = \case - Constant ConstInt {} -> return mkTypeInteger - Constant ConstBool {} -> return mkTypeBool - Constant ConstString {} -> return TyString - Constant ConstUnit -> return TyUnit - Constant ConstVoid -> return TyVoid + Constant c -> return (getConstantType c) Ref val -> case getMemValueType tab val mem of Just ty -> return ty Nothing -> throw $ AsmError loc "invalid memory reference" diff --git a/src/Juvix/Compiler/Asm/Interpreter.hs b/src/Juvix/Compiler/Asm/Interpreter.hs index 5d95eabf35..241d6ca045 100644 --- a/src/Juvix/Compiler/Asm/Interpreter.hs +++ b/src/Juvix/Compiler/Asm/Interpreter.hs @@ -210,13 +210,17 @@ runCodeR infoTable funInfo = goCode (funInfo ^. functionCode) >> popLastValueSta goStrBinOp :: (Member Runtime r) => (Text -> Text -> Val) -> Sem r () goStrBinOp op = goStrBinOp' (\v1 v2 -> return (op v1 v2)) + getConstantVal :: Constant -> Val + getConstantVal = \case + ConstInt i -> ValInteger i + ConstBool b -> ValBool b + ConstString s -> ValString s + ConstUnit -> ValUnit + ConstVoid -> ValVoid + getVal :: (Member Runtime r) => Value -> Sem r Val getVal = \case - Constant (ConstInt i) -> return (ValInteger i) - Constant (ConstBool b) -> return (ValBool b) - Constant (ConstString s) -> return (ValString s) - Constant ConstUnit -> return ValUnit - Constant ConstVoid -> return ValVoid + Constant c -> return (getConstantVal c) Ref r -> getMemVal r getMemVal :: forall r. (Member Runtime r) => MemValue -> Sem r Val diff --git a/src/Juvix/Compiler/Asm/Pretty/Base.hs b/src/Juvix/Compiler/Asm/Pretty/Base.hs index 2f1e96b575..778f2e4fbb 100644 --- a/src/Juvix/Compiler/Asm/Pretty/Base.hs +++ b/src/Juvix/Compiler/Asm/Pretty/Base.hs @@ -237,21 +237,26 @@ instance PrettyCode MemValue where DRef dr -> ppCode dr ConstrRef fld -> ppCode fld -instance PrettyCode Value where - ppCode :: (Member (Reader Options) r) => Value -> Sem r (Doc Ann) +instance PrettyCode Constant where ppCode = \case - Constant (ConstInt v) -> + ConstInt v -> return $ annotate AnnLiteralInteger (pretty v) - Constant (ConstBool True) -> - return $ annotate (AnnKind KNameConstructor) (pretty (Str.true_ :: String)) - Constant (ConstBool False) -> - return $ annotate (AnnKind KNameConstructor) (pretty (Str.false_ :: String)) - Constant (ConstString txt) -> + ConstBool True -> + return $ annotate (AnnKind KNameConstructor) (Str.true_) + ConstBool False -> + return $ annotate (AnnKind KNameConstructor) (Str.false_) + ConstString txt -> return $ annotate AnnLiteralString (pretty (show txt :: String)) - Constant ConstUnit {} -> - return $ annotate (AnnKind KNameConstructor) (pretty (Str.unit :: String)) - Constant ConstVoid {} -> - return $ annotate (AnnKind KNameConstructor) (pretty (Str.void :: String)) + ConstUnit {} -> + return $ annotate (AnnKind KNameConstructor) Str.unit + ConstVoid {} -> + return $ annotate (AnnKind KNameConstructor) Str.void + +instance PrettyCode Value where + ppCode :: (Member (Reader Options) r) => Value -> Sem r (Doc Ann) + ppCode = \case + Constant c -> + ppCode c Ref mval -> ppCode mval diff --git a/src/Juvix/Compiler/Tree/Extra/Type.hs b/src/Juvix/Compiler/Tree/Extra/Type.hs index 0cf65df63b..4e75b303c0 100644 --- a/src/Juvix/Compiler/Tree/Extra/Type.hs +++ b/src/Juvix/Compiler/Tree/Extra/Type.hs @@ -23,7 +23,7 @@ mkTypeFun args tgt = case args of unfoldType :: Type -> ([Type], Type) unfoldType ty = (typeArgs ty, typeTarget ty) --- converts e.g. `A -> B -> C -> D` to `(A, B, C) -> D` where `D` is an atom +-- | Converts e.g. `A -> B -> C -> D` to `(A, B, C) -> D` where `D` is an atom uncurryType :: Type -> Type uncurryType ty = case typeArgs ty of [] -> @@ -32,7 +32,7 @@ uncurryType ty = case typeArgs ty of let ty' = uncurryType (typeTarget ty) in mkTypeFun (tyargs ++ typeArgs ty') (typeTarget ty') --- converts e.g. `(A, B, C) -> (D, E) -> F` to `A -> B -> C -> D -> E -> F` +-- | Converts e.g. `(A, B, C) -> (D, E) -> F` to `A -> B -> C -> D -> E -> F` -- where `F` is an atom curryType :: Type -> Type curryType ty = case typeArgs ty of diff --git a/src/Juvix/Compiler/Tree/Translation/FromCore.hs b/src/Juvix/Compiler/Tree/Translation/FromCore.hs index d2d1f36d7c..0ef5f5507d 100644 --- a/src/Juvix/Compiler/Tree/Translation/FromCore.hs +++ b/src/Juvix/Compiler/Tree/Translation/FromCore.hs @@ -23,21 +23,14 @@ fromCore tab = genCode :: Core.InfoTable -> Core.FunctionInfo -> FunctionInfo genCode infoTable fi = let argnames = map (Just . (^. Core.argumentName)) (fi ^. Core.functionArgsInfo) - code = - go - 0 - ( BL.fromList $ - reverse - ( map - (DRef . ArgRef) - ( zipWithExact - OffsetRef - [0 .. fi ^. Core.functionArgsNum - 1] - argnames - ) - ) + bl = + BL.fromList . reverse $ + ( zipWithExact + (\x y -> DRef $ ArgRef $ OffsetRef x y) + [0 .. fi ^. Core.functionArgsNum - 1] + argnames ) - (fi ^. Core.functionBody) + code = go 0 bl (fi ^. Core.functionBody) in FunctionInfo { _functionName = fi ^. Core.functionName, _functionLocation = fi ^. Core.functionLocation, @@ -66,20 +59,19 @@ genCode infoTable fi = MemRef (BL.lookup _varIndex refs) goIdent :: Core.Ident -> Node - goIdent Core.Ident {..} = - if - | getArgsNum _identSymbol == 0 -> - Call $ - NodeCall - { _nodeCallType = CallFun _identSymbol, - _nodeCallArgs = [] - } - | otherwise -> - AllocClosure $ - NodeAllocClosure - { _nodeAllocClosureFunSymbol = _identSymbol, - _nodeAllocClosureArgs = [] - } + goIdent Core.Ident {..} + | getArgsNum _identSymbol == 0 = + Call $ + NodeCall + { _nodeCallType = CallFun _identSymbol, + _nodeCallArgs = [] + } + | otherwise = + AllocClosure $ + NodeAllocClosure + { _nodeAllocClosureFunSymbol = _identSymbol, + _nodeAllocClosureArgs = [] + } goConstant :: Core.Constant -> Node goConstant = \case @@ -89,11 +81,11 @@ genCode infoTable fi = Const (ConstString s) goApps :: Int -> BinderList MemRef -> Core.Apps -> Node - goApps tempSize refs (Core.Apps {..}) = + goApps tempSize refs Core.Apps {..} = let suppliedArgs = map (go tempSize refs) _appsArgs suppliedArgsNum = length suppliedArgs in case _appsFun of - Core.FunIdent (Core.Ident {..}) -> + Core.FunIdent Core.Ident {..} -> if | argsNum > suppliedArgsNum -> AllocClosure $ @@ -133,7 +125,7 @@ genCode infoTable fi = } goBuiltinApp :: Int -> BinderList MemRef -> Core.BuiltinApp -> Node - goBuiltinApp tempSize refs (Core.BuiltinApp {..}) = + goBuiltinApp tempSize refs Core.BuiltinApp {..} = case args of [arg] -> Unop $ @@ -183,7 +175,7 @@ genCode infoTable fi = body = go (tempSize + 1) (BL.cons (DRef (TempRef nameRef)) refs) _letBody goCase :: Int -> BinderList MemRef -> Core.Case -> Node - goCase tempSize refs (Core.Case {..}) = + goCase tempSize refs Core.Case {..} = Case $ NodeCase { _nodeCaseArg = go tempSize refs _caseValue, @@ -195,7 +187,7 @@ genCode infoTable fi = compileCaseBranches :: [Core.CaseBranch] -> [CaseBranch] compileCaseBranches branches = map - ( \(Core.CaseBranch {..}) -> + ( \Core.CaseBranch {..} -> if | _caseBranchBindersNum == 0 -> compileCaseBranchNoBinders _caseBranchTag _caseBranchBody @@ -241,7 +233,7 @@ genCode infoTable fi = compileCaseDefault = go tempSize refs goIf :: Int -> BinderList MemRef -> Core.If -> Node - goIf tempSize refs (Core.If {..}) = + goIf tempSize refs Core.If {..} = Branch $ NodeBranch { _nodeBranchArg = go tempSize refs _ifValue,