draft translation from Core

src/Juvix/Asm/Interpreter.hs

@@ -8,7 +8,7 @@ import Juvix.Asm.Interpreter.Runtime
 import Juvix.Asm.Language
 
 -- The returned Val is the value on top of the value stack at exit, i.e., when
--- executing a toplevel Return. Results in a runtime error if at exit the value
+-- executing a toplevel Return. Throws a runtime error if at exit the value
 -- stack has more than one element.
 runCode :: InfoTable -> Code -> Val
 runCode infoTable = run . evalRuntime . goToplevel
@@ -52,18 +52,32 @@ runCode infoTable = run . evalRuntime . goToplevel
         args <- replicateM allocClosureArgsNum popValueStack
         pushValueStack (ValClosure (Closure allocClosureFunSymbol (reverse args)))
         goCode cont
+      ExtendClosure {..} -> do
+        v <- popValueStack
+        case v of
+          ValClosure cl -> do
+            args <- replicateM extendClosureArgsNum popValueStack
+            pushValueStack
+              ( ValClosure
+                  ( Closure
+                      (cl ^. closureSymbol)
+                      (cl ^. closureArgs ++ reverse args)
+                  )
+              )
+            goCode cont
+          _ -> error "invalid closure extension: expected closure on top of value stack"
       Branch {..} -> do
         v <- popValueStack
         case v of
           ValBool True -> goCode branchTrue
           ValBool False -> goCode branchFalse
-          _ -> error "branch on a non-boolean"
+          _ -> error "branch on non-boolean"
         goCode cont
       Case {..} -> do
         v <- popValueStack
         case v of
           ValConstr c -> branch (c ^. constrTag) caseBranches caseDefault
-          _ -> error "case on a non-data"
+          _ -> error "case on non-data"
         goCode cont
         where
           branch :: Member Runtime r => Tag -> [CaseBranch] -> Maybe Code -> Sem r ()

src/Juvix/Asm/Interpreter/Extra.hs

@@ -1,8 +1,8 @@
 module Juvix.Asm.Interpreter.Extra where
 
 import Data.HashMap.Strict qualified as HashMap
-import Juvix.Asm.Interpreter.Runtime
 import Juvix.Asm.Data.InfoTable
+import Juvix.Asm.Interpreter.Runtime
 import Juvix.Prelude
 
 frameFromFunctionInfo :: FunctionInfo -> [Val] -> Frame

src/Juvix/Asm/Interpreter/Runtime.hs

@@ -81,8 +81,6 @@ data Continuation = Continuation
     _contCode :: Code
   }
 
-
-
 {-
   The following types of values may be stored in the heap or an activation
   frame.

src/Juvix/Asm/Language.hs

@@ -86,6 +86,13 @@ data Instruction
     -- arguments are popped from the stack and stored in the closure at
     -- _decreasing_ offsets. The result is pushed on top of the stack.
     AllocClosure {allocClosureFunSymbol :: Symbol, allocClosureArgsNum :: Int}
+  | -- Extend a closure on top of the stack with more arguments. n =
+    -- extendClosureArgsNum indicates the number of arguments to extend the
+    -- closure with -- it must be less than the number of arguments expected by
+    -- the closure. Pops the closure from the stack, pops n additional arguments
+    -- from the stack and extends the closure with them in _decreasing_ order,
+    -- then pushes the extended closure on top of the stack.
+    ExtendClosure {extendClosureArgsNum :: Int}
   | -- Branch based on a boolean value on top of the stack, pop the stack.
     Branch {branchTrue :: Code, branchFalse :: Code}
   | -- Branch based on the tag of the constructor data on top of the stack, pop

src/Juvix/Asm/Translation/Extra/InfoTableBuilder.hs

@@ -1,8 +1,8 @@
 module Juvix.Asm.Translation.Extra.InfoTableBuilder where
 
 import Data.HashMap.Strict qualified as HashMap
-import Juvix.Asm.Language
 import Juvix.Asm.Data.InfoTable
+import Juvix.Asm.Language
 
 data InfoTableBuilder m a where
   RegisterFunction :: FunctionInfo -> InfoTableBuilder m ()

src/Juvix/Asm/Translation/FromCore.hs

@@ -1,34 +1,154 @@
 module Juvix.Asm.Translation.FromCore where
 
-import Juvix.Core.Language qualified as Core
-import Juvix.Asm.Language
 import Data.DList qualified as DL
+import Data.HashMap.Strict qualified as HashMap
+import Juvix.Asm.Language
+import Juvix.Core.Data.BinderList qualified as BL
+import Juvix.Core.Data.InfoTable qualified as Core
+import Juvix.Core.Extra qualified as Core
+import Juvix.Core.Language qualified as Core
+import Juvix.Core.Language.Info qualified as Info
+import Juvix.Core.Language.Info.ArgsNumInfo
 
--- DList for O(1) concatenation
+type BinderList = BL.BinderList
+
+-- DList for O(1) snoc and append
 type Code' = DL.DList Instruction
 
--- Generate code for a single function. Assumes lambda-lifting, i.e., lambdas
--- occur only at the top.
-genCode :: Core.Node -> Code
-genCode = DL.toList . goToplevel
+-- Generate code for a single function.
+--
+-- Assumptions:
+-- - lambda-lifted, i.e., lambdas occur only at the top,
+-- - well-typed (no illegal applications),
+-- - no evaluation-only nodes,
+-- - no axioms,
+-- - fully applied constructors and builtins,
+-- - ArgsNumInfo available for each Var node.
+genCode :: Core.InfoTable -> Core.Node -> Code
+genCode infoTable = DL.toList . goToplevel
   where
-    unimplemented :: a
-    unimplemented = error "not yet implemented"
-
     goToplevel :: Core.Node -> Code'
-    goToplevel node = unimplemented
+    goToplevel node =
+      let (k, body) = Core.unfoldLambdas node
+       in go True 0 (BL.fromList $ reverse (map (Ref . ArgRef) [0 .. k - 1])) body
 
-    go :: [Value] -> Core.Node -> Code'
-    go refs = \case
-      Core.Var {..} -> unimplemented
-      Core.Ident {..} -> unimplemented
-      Core.Constant {..} -> unimplemented
-      Core.Axiom {..} -> unimplemented
-      Core.App {..} -> unimplemented
-      Core.BuiltinApp {..} -> unimplemented
-      Core.ConstrApp {..} -> unimplemented
-      Core.Lambda {..} -> unimplemented
-      Core.Let {..} -> unimplemented
-      Core.Case {..} -> unimplemented
-      Core.If {..} -> unimplemented
+    -- 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.Var {..} ->
+        snocReturn isTail $ DL.singleton (Push (BL.lookup varIndex refs))
+      Core.Ident {..} ->
+        snocReturn isTail $ DL.singleton (AllocClosure identSymbol 0)
+      Core.Constant _ (Core.ConstInteger i) ->
+        snocReturn isTail $ DL.singleton (Push (ConstInt i))
+      Core.Constant _ (Core.ConstBool b) ->
+        snocReturn isTail $ DL.singleton (Push (ConstBool b))
+      Core.App {} ->
+        let (fun, args) = Core.unfoldApp node
+         in case fun of
+              Core.Ident {..} ->
+                if
+                    | argsNum > length args ->
+                        snocReturn isTail $
+                          DL.snoc
+                            (DL.concat (map (go False tempSize refs) args))
+                            (AllocClosure identSymbol (length args))
+                    | argsNum == length args ->
+                        DL.snoc
+                          (DL.concat (map (go False tempSize refs) args))
+                          ((if isTail then TailCall else Call) (CallFun identSymbol))
+                    | otherwise -> impossible
+                where
+                  argsNum =
+                    fromMaybe
+                      impossible
+                      (HashMap.lookup identSymbol (infoTable ^. Core.infoIdents))
+                      ^. Core.identArgsNum
+              Core.Var {..} ->
+                if
+                    | argsNum > length args ->
+                        snocReturn isTail $
+                          DL.snoc
+                            ( DL.snoc
+                                (DL.concat (map (go False tempSize refs) args))
+                                (Push (BL.lookup varIndex refs))
+                            )
+                            (ExtendClosure (length args))
+                    | argsNum == length args ->
+                        DL.snoc
+                          ( DL.snoc
+                              (DL.concat (map (go False tempSize refs) args))
+                              (Push (BL.lookup varIndex refs))
+                          )
+                          ((if isTail then TailCall else Call) CallClosure)
+                    | otherwise -> impossible
+                where
+                  argsNum =
+                    fromMaybe impossible (Info.lookup kArgsNumInfo varInfo)
+                      ^. infoArgsNum
+              _ -> impossible
+      Core.BuiltinApp {..} ->
+        snocReturn isTail $
+          DL.snoc
+            (DL.concat (map (go False tempSize refs) builtinArgs))
+            (genOp builtinOp)
+      Core.ConstrApp {..} ->
+        snocReturn isTail $
+          DL.snoc
+            (DL.concat (map (go False tempSize refs) constrArgs))
+            (AllocConstr constrTag)
+      Core.Let {..} ->
+        DL.append
+          (DL.snoc (DL.snoc (go False tempSize refs letValue) (Store tempSize)) Pop)
+          (go isTail (tempSize + 1) (BL.extend (Ref (TempRef tempSize)) refs) letBody)
+      Core.Case {..} ->
+        DL.snoc
+          (DL.snoc (go False tempSize refs caseValue) (Store tempSize))
+          ( Case
+              ( map
+                  ( \(Core.CaseBranch {..}) ->
+                      CaseBranch
+                        caseTag
+                        ( DL.toList $
+                            go
+                              isTail
+                              (tempSize + 1)
+                              ( BL.prepend
+                                  ( map
+                                      (Ref . ConstrRef . Field (TempRef tempSize))
+                                      (reverse [0 .. caseBindersNum - 1])
+                                  )
+                                  refs
+                              )
+                              caseBranch
+                        )
+                  )
+                  caseBranches
+              )
+              (fmap (DL.toList . go isTail (tempSize + 1) refs) caseDefault)
+          )
+      Core.If {..} ->
+        DL.snoc
+          (go False tempSize refs ifValue)
+          ( Branch
+              (DL.toList $ go isTail tempSize refs ifTrueBranch)
+              (DL.toList $ go isTail tempSize refs ifFalseBranch)
+          )
       _ -> impossible
+
+    genOp :: Core.BuiltinOp -> Instruction
+    genOp = \case
+      Core.OpIntAdd -> IntAdd
+      Core.OpIntSub -> IntSub
+      Core.OpIntMul -> IntMul
+      Core.OpIntDiv -> IntDiv
+      Core.OpIntEq -> IntEq
+      Core.OpIntLt -> IntLt
+      Core.OpIntLe -> IntLe
+      Core.OpBoolAnd -> BoolAnd
+      Core.OpBoolOr -> BoolOr
+
+    snocReturn :: Bool -> Code' -> Code'
+    snocReturn True code = DL.snoc code Return
+    snocReturn False code = code