Reg to VM translation

app/Commands/Compile.hs

@@ -26,7 +26,7 @@ runCommand opts@CompileOptions {..} = do
     TargetVampIR -> Compile.runVampIRPipeline arg
     TargetCore -> writeCoreFile arg
     TargetAsm -> Compile.runAsmPipeline arg
-    TargetVampIRVM -> exitMsg (ExitFailure 1) "vampir-vm target not yet supported"
+    TargetVampIRVM -> Compile.runVampIRVMPipeline arg
 
 writeCoreFile :: (Members '[Embed IO, App] r) => Compile.PipelineArg -> Sem r ()
 writeCoreFile pa@Compile.PipelineArg {..} = do

app/Commands/Dev/Core/Compile.hs

@@ -19,7 +19,7 @@ runCommand opts = do
     TargetVampIR -> runVampIRPipeline arg
     TargetCore -> return ()
     TargetAsm -> runAsmPipeline arg
-    TargetVampIRVM -> return ()
+    TargetVampIRVM -> runVampIRVMPipeline arg
   where
     getFile :: Sem r (Path Abs File)
     getFile = getMainFile (opts ^. compileInputFile)

app/Commands/Dev/Core/Compile/Base.hs

@@ -3,6 +3,7 @@ module Commands.Dev.Core.Compile.Base where
 import Commands.Base
 import Commands.Dev.Core.Compile.Options
 import Commands.Extra.Compile qualified as Compile
+import Data.ByteString qualified as BS
 import Data.Text.IO qualified as TIO
 import Juvix.Compiler.Asm.Pretty qualified as Asm
 import Juvix.Compiler.Backend qualified as Backend
@@ -27,7 +28,10 @@ getEntry PipelineArg {..} = do
       { _entryPointTarget = getTarget (_pipelineArgOptions ^. compileTarget),
         _entryPointDebug = _pipelineArgOptions ^. compileDebug,
         _entryPointOptimizationLevel = fromMaybe defaultOptLevel (_pipelineArgOptions ^. compileOptimizationLevel),
-        _entryPointInliningDepth = _pipelineArgOptions ^. compileInliningDepth
+        _entryPointInliningDepth = _pipelineArgOptions ^. compileInliningDepth,
+        _entryPointStackSize = _pipelineArgOptions ^. compileStackSize,
+        _entryPointHeapSize = _pipelineArgOptions ^. compileHeapSize,
+        _entryPointStepsNum = _pipelineArgOptions ^. compileStepsNum
       }
   where
     getTarget :: CompileTarget -> Backend.Target
@@ -38,7 +42,7 @@ getEntry PipelineArg {..} = do
       TargetVampIR -> Backend.TargetVampIR
       TargetCore -> Backend.TargetCore
       TargetAsm -> Backend.TargetAsm
-      TargetVampIRVM -> Backend.TargetVampIR
+      TargetVampIRVM -> Backend.TargetVampIRVM
 
     defaultOptLevel :: Int
     defaultOptLevel
@@ -99,6 +103,17 @@ runVampIRPipeline pa@PipelineArg {..} = do
   VampIR.Result {..} <- getRight (run (runReader entryPoint (runError (coreToVampIR _pipelineArgInfoTable :: Sem '[Error JuvixError, Reader EntryPoint] VampIR.Result))))
   embed $ TIO.writeFile (toFilePath vampirFile) _resultCode
 
+runVampIRVMPipeline ::
+  forall r.
+  (Members '[Embed IO, App] r) =>
+  PipelineArg ->
+  Sem r ()
+runVampIRVMPipeline pa@PipelineArg {..} = do
+  entryPoint <- getEntry pa
+  vampirFile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
+  bs <- getRight (run (runReader entryPoint (runError (coreToVampIRVM _pipelineArgInfoTable :: Sem '[Error JuvixError, Reader EntryPoint] ByteString))))
+  embed $ BS.writeFile (toFilePath vampirFile) bs
+
 runAsmPipeline :: (Members '[Embed IO, App] r) => PipelineArg -> Sem r ()
 runAsmPipeline pa@PipelineArg {..} = do
   entryPoint <- getEntry pa

app/Commands/Dev/Core/Compile/Options.hs

@@ -17,6 +17,7 @@ coreSupportedTargets =
       TargetNative64,
       TargetGeb,
       TargetVampIR,
+      TargetVampIRVM,
       TargetAsm
     ]
 

app/GlobalOptions.hs

@@ -44,7 +44,8 @@ instance CanonicalProjection GlobalOptions Core.CoreOptions where
       { Core._optCheckCoverage = not _globalNoCoverage,
         Core._optUnrollLimit = _globalUnrollLimit,
         Core._optOptimizationLevel = defaultOptimizationLevel,
-        Core._optInliningDepth = defaultInliningDepth
+        Core._optInliningDepth = defaultInliningDepth,
+        Core._optAllowFunction = False
       }
 
 defaultGlobalOptions :: GlobalOptions

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

@@ -21,6 +21,7 @@ data FunctionInfo = FunctionInfo
   { _functionName :: Text,
     _functionLocation :: Maybe Location,
     _functionSymbol :: Symbol,
+    _functionArgNames :: [Maybe Text],
     -- | `_functionArgsNum` may be different from `length (typeArgs
     -- (_functionType))` only if it is 0 (the "function" takes zero arguments)
     -- and the result is a function.

src/Juvix/Compiler/Asm/Translation/FromCore.hs

@@ -40,6 +40,7 @@ genCode infoTable fi =
         { _functionName = fi ^. Core.functionName,
           _functionLocation = fi ^. Core.functionLocation,
           _functionSymbol = fi ^. Core.functionSymbol,
+          _functionArgNames = fi ^. Core.functionArgNames,
           _functionArgsNum = fi ^. Core.functionArgsNum,
           _functionType = convertType (fi ^. Core.functionArgsNum) (fi ^. Core.functionType),
           _functionCode = code,

src/Juvix/Compiler/Asm/Translation/FromSource.hs

@@ -110,6 +110,7 @@ statementFunction = do
             _functionSymbol = sym,
             _functionLocation = Just i,
             _functionCode = [],
+            _functionArgNames = replicate (length argtys) Nothing,
             _functionArgsNum = length argtys,
             _functionType = mkTypeFun argtys (fromMaybe TyDynamic mrty),
             _functionMaxValueStackHeight = -1, -- computed later

src/Juvix/Compiler/Backend.hs

@@ -8,6 +8,7 @@ data Target
   | TargetCNative64
   | TargetGeb
   | TargetVampIR
+  | TargetVampIRVM
   | TargetCore
   | TargetAsm
   deriving stock (Data, Eq, Show)
@@ -65,6 +66,8 @@ getLimits tgt debug = case tgt of
     defaultLimits
   TargetVampIR ->
     defaultLimits
+  TargetVampIRVM ->
+    defaultLimits
   TargetCore ->
     defaultLimits
   TargetAsm ->

src/Juvix/Compiler/Core/Data/Stripped/InfoTable.hs

@@ -18,6 +18,7 @@ data FunctionInfo = FunctionInfo
     -- function arguments
     _functionBody :: Node,
     _functionType :: Type,
+    _functionArgNames :: [Maybe Text],
     -- a function can have 0 arguments
     _functionArgsNum :: Int,
     _functionArgsInfo :: [ArgumentInfo],

src/Juvix/Compiler/Core/Options.hs

@@ -1,5 +1,6 @@
 module Juvix.Compiler.Core.Options where
 
+import Juvix.Compiler.Backend
 import Juvix.Compiler.Defaults
 import Juvix.Compiler.Pipeline.EntryPoint
 import Juvix.Prelude
@@ -8,7 +9,8 @@ data CoreOptions = CoreOptions
   { _optCheckCoverage :: Bool,
     _optUnrollLimit :: Int,
     _optOptimizationLevel :: Int,
-    _optInliningDepth :: Int
+    _optInliningDepth :: Int,
+    _optAllowFunction :: Bool
   }
 
 makeLenses ''CoreOptions
@@ -19,7 +21,8 @@ defaultCoreOptions =
     { _optCheckCoverage = True,
       _optUnrollLimit = defaultUnrollLimit,
       _optOptimizationLevel = defaultOptimizationLevel,
-      _optInliningDepth = defaultInliningDepth
+      _optInliningDepth = defaultInliningDepth,
+      _optAllowFunction = False
     }
 
 fromEntryPoint :: EntryPoint -> CoreOptions
@@ -28,5 +31,6 @@ fromEntryPoint EntryPoint {..} =
     { _optCheckCoverage = not _entryPointNoCoverage,
       _optUnrollLimit = _entryPointUnrollLimit,
       _optOptimizationLevel = _entryPointOptimizationLevel,
-      _optInliningDepth = _entryPointInliningDepth
+      _optInliningDepth = _entryPointInliningDepth,
+      _optAllowFunction = (_entryPointTarget == TargetVampIRVM)
     }

src/Juvix/Compiler/Core/Transformation/Check/Exec.hs

@@ -2,12 +2,14 @@ module Juvix.Compiler.Core.Transformation.Check.Exec where
 
 import Juvix.Compiler.Core.Error
 import Juvix.Compiler.Core.Extra
+import Juvix.Compiler.Core.Options (CoreOptions, optAllowFunction)
 import Juvix.Compiler.Core.Transformation.Base
 import Juvix.Compiler.Core.Transformation.Check.Base
 import Juvix.Data.PPOutput
 
-checkExec :: forall r. Member (Error CoreError) r => InfoTable -> Sem r InfoTable
+checkExec :: forall r. Members '[Error CoreError, Reader CoreOptions] r => InfoTable -> Sem r InfoTable
 checkExec tab = do
+  allowFun <- asks (^. optAllowFunction)
   checkNoAxioms tab
   case tab ^. infoMain of
     Nothing ->
@@ -19,13 +21,14 @@ checkExec tab = do
           }
     Just sym ->
       case ii ^. identifierType of
-        NPi {} ->
-          throw
-            CoreError
-              { _coreErrorMsg = ppOutput "`main` cannot have a function type for this target",
-                _coreErrorNode = Nothing,
-                _coreErrorLoc = loc
-              }
+        NPi {}
+          | not allowFun ->
+              throw
+                CoreError
+                  { _coreErrorMsg = ppOutput "`main` cannot have a function type for this target",
+                    _coreErrorNode = Nothing,
+                    _coreErrorLoc = loc
+                  }
         ty
           | isTypeConstr tab ty ->
               throw

src/Juvix/Compiler/Core/Translation/Stripped/FromCore.hs

@@ -99,6 +99,7 @@ translateFunctionInfo tab IdentifierInfo {..} =
             _identifierArgsNum
             (fromJust $ HashMap.lookup _identifierSymbol (tab ^. identContext)),
         _functionType = translateType _identifierType,
+        _functionArgNames = _identifierArgNames,
         _functionArgsNum = _identifierArgsNum,
         _functionArgsInfo = map translateArgInfo (typeArgsBinders _identifierType),
         _functionIsExported = _identifierIsExported

src/Juvix/Compiler/Pipeline.hs

@@ -36,6 +36,9 @@ import Juvix.Compiler.Pipeline.Root
 import Juvix.Compiler.Pipeline.Setup
 import Juvix.Compiler.Reg.Data.InfoTable qualified as Reg
 import Juvix.Compiler.Reg.Translation.FromAsm qualified as Reg
+import Juvix.Compiler.VM.Language qualified as VM
+import Juvix.Compiler.VM.Pipeline qualified as VM
+import Juvix.Compiler.VM.Translation.FromReg qualified as VM
 import Juvix.Prelude
 
 type PipelineEff = '[PathResolver, Reader EntryPoint, Files, NameIdGen, Builtins, Error JuvixError, HighlightBuilder, Embed IO]
@@ -99,6 +102,18 @@ upToVampIR ::
 upToVampIR =
   upToCore >>= \Core.CoreResult {..} -> coreToVampIR _coreResultTable
 
+upToVM ::
+  (Members '[HighlightBuilder, Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, PathResolver] r) =>
+  Sem r VM.Code
+upToVM =
+  upToCore >>= \Core.CoreResult {..} -> coreToVM _coreResultTable
+
+upToVampIRVM ::
+  (Members '[HighlightBuilder, Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, PathResolver] r) =>
+  Sem r ByteString
+upToVampIRVM =
+  upToVM >>= VM.toVampIR
+
 upToGeb ::
   (Members '[HighlightBuilder, Reader EntryPoint, Files, NameIdGen, Error JuvixError, Builtins, PathResolver] r) =>
   Geb.ResultSpec ->
@@ -125,6 +140,12 @@ upToEval =
 coreToAsm :: Members '[Error JuvixError, Reader EntryPoint] r => Core.InfoTable -> Sem r Asm.InfoTable
 coreToAsm = Core.toStripped >=> return . Asm.fromCore . Stripped.fromCore
 
+coreToVM :: Members '[Error JuvixError, Reader EntryPoint] r => Core.InfoTable -> Sem r VM.Code
+coreToVM = coreToAsm >=> Asm.toReg >=> return . VM.fromReg . Reg.fromAsm
+
+coreToVampIRVM :: Members '[Error JuvixError, Reader EntryPoint] r => Core.InfoTable -> Sem r ByteString
+coreToVampIRVM = coreToVM >=> VM.toVampIR
+
 coreToMiniC :: Members '[Error JuvixError, Reader EntryPoint] r => Core.InfoTable -> Sem r C.MiniCResult
 coreToMiniC = coreToAsm >=> asmToMiniC
 

src/Juvix/Compiler/Pipeline/EntryPoint.hs

@@ -36,6 +36,9 @@ data EntryPoint = EntryPoint
     _entryPointUnrollLimit :: Int,
     _entryPointOptimizationLevel :: Int,
     _entryPointInliningDepth :: Int,
+    _entryPointStackSize :: Int,
+    _entryPointHeapSize :: Int,
+    _entryPointStepsNum :: Int,
     _entryPointGenericOptions :: GenericOptions,
     _entryPointModulePaths :: [Path Abs File],
     _entryPointSymbolPruningMode :: SymbolPruningMode
@@ -81,6 +84,9 @@ defaultEntryPointNoFile roots =
       _entryPointUnrollLimit = defaultUnrollLimit,
       _entryPointOptimizationLevel = defaultOptimizationLevel,
       _entryPointInliningDepth = defaultInliningDepth,
+      _entryPointStackSize = defaultStackSize,
+      _entryPointHeapSize = defaultHeapSize,
+      _entryPointStepsNum = defaultStepsNum,
       _entryPointModulePaths = [],
       _entryPointSymbolPruningMode = FilterUnreachable
     }

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

@@ -13,6 +13,7 @@ data FunctionInfo = FunctionInfo
   { _functionName :: Text,
     _functionLocation :: Maybe Location,
     _functionSymbol :: Symbol,
+    _functionArgNames :: [Maybe Text],
     _functionArgsNum :: Int,
     _functionStackVarsNum :: Int,
     _functionTempVarsNum :: Int,

src/Juvix/Compiler/Reg/Translation/FromAsm.hs

@@ -23,6 +23,7 @@ fromAsm tab =
         { _functionName = fi ^. Asm.functionName,
           _functionLocation = fi ^. Asm.functionLocation,
           _functionSymbol = fi ^. Asm.functionSymbol,
+          _functionArgNames = fi ^. Asm.functionArgNames,
           _functionArgsNum = fi ^. Asm.functionArgsNum,
           _functionStackVarsNum = fi ^. Asm.functionMaxValueStackHeight,
           _functionTempVarsNum = fi ^. Asm.functionMaxTempStackHeight,

src/Juvix/Compiler/VM/Extra/Utils.hs

@@ -17,6 +17,12 @@ mkJumpOnZero val dest = JumpOnZero $ InstrJumpOnZero val dest
 mkLabel :: Text -> Instruction
 mkLabel lab = Label $ InstrLabel lab
 
+regSp :: Int
+regSp = 0
+
+regHp :: Int
+regHp = 1
+
 maxValueReg :: Value -> Int
 maxValueReg = \case
   RegRef r -> r

src/Juvix/Compiler/VM/Language.hs

@@ -6,6 +6,8 @@ where
 
 import Juvix.Compiler.VM.Language.Base hiding (Const)
 
+type Code = [Instruction]
+
 type SmallInt = Int
 
 type RegRef = Int

src/Juvix/Compiler/VM/Options.hs

@@ -1,6 +1,7 @@
 module Juvix.Compiler.VM.Options where
 
 import Juvix.Compiler.Defaults
+import Juvix.Compiler.Pipeline.EntryPoint
 import Juvix.Prelude
 
 data Options = Options
@@ -22,3 +23,11 @@ defaultOptions =
       _optIntegerBits = defaultVampIRIntegerBits,
       _optInputsFile = Nothing
     }
+
+fromEntryPoint :: EntryPoint -> Options
+fromEntryPoint EntryPoint {..} =
+  defaultOptions
+    { _optStackSize = _entryPointStackSize,
+      _optHeapSize = _entryPointHeapSize,
+      _optStepsNum = _entryPointStepsNum
+    }

src/Juvix/Compiler/VM/Pipeline.hs

@@ -0,0 +1,16 @@
+module Juvix.Compiler.VM.Pipeline
+  ( module Juvix.Compiler.VM.Pipeline,
+    module Juvix.Compiler.VM.Options,
+  )
+where
+
+import Juvix.Compiler.Pipeline.EntryPoint
+import Juvix.Compiler.VM.Language
+import Juvix.Compiler.VM.Options
+import Juvix.Compiler.VM.Serialization.ToVampIR
+
+toVampIR' :: Members '[Error LabelError, Reader Options] r => Code -> Sem r ByteString
+toVampIR' code = ask >>= flip serialize code
+
+toVampIR :: Members '[Error JuvixError, Reader EntryPoint] r => Code -> Sem r ByteString
+toVampIR = mapReader fromEntryPoint . mapError (JuvixError @LabelError) . toVampIR'