Factor the JuvixCore -> JuvixAsm translation into JuvixCore -> JuvixTree -> JuvixAsm

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')

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

src/Juvix/Compiler/Asm/Data/InfoTable.hs

@@ -1,85 +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,
-    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

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

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

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

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)
 
@@ -104,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"

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.

src/Juvix/Compiler/Asm/Extra/Type.hs

@@ -1,48 +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

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 :: forall r. (Member Runtime r) => MemValue -> Sem r Val

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,7 +35,7 @@ data DirectRef
     --   JVA code: 'arg[<offset>]'.
     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[<offset>]'.
     TempRef RefTemp
 
@@ -60,24 +47,10 @@ data RefTemp = RefTemp
     _refTempTempHeight :: Maybe Int
   }
 
-data OffsetRef = OffsetRef
-  { _offsetRefOffset :: Offset,
-    _offsetRefName :: Maybe Text
-  }
+makeLenses ''RefTemp
 
 -- | Constructor field reference. JVA code: '<dref>.<tag>[<offset>]'
-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 ''RefTemp
-makeLenses ''Field
-makeLenses ''OffsetRef
+type Field = Field' DirectRef
 
 -- | Function call type
 data CallType
@@ -91,7 +64,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'.
@@ -234,12 +207,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: {<code>} false: {<code>} }'.
+    -- code: 'br { true: {<code>}; false: {<code>}; }'.
     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 <ind> { <tag>: {<code>} ... <tag>: {<code>} default: {<code>} }'
-    -- (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 <ind> { <tag>: {<code>}; ...
+    -- <tag>: {<code>}; default: {<code>}; }' (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

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

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

src/Juvix/Compiler/Asm/Pretty/Base.hs

@@ -240,17 +240,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