tests & bugfixes

app/VMInterpreter.hs

@@ -2,9 +2,15 @@ module VMInterpreter where
 
 import App
 import CommonOptions
+import Juvix.Compiler.VM.Extra.Labels qualified as VM
 import Juvix.Compiler.VM.Interpreter qualified as VM
 import Juvix.Compiler.VM.Language qualified as VM
 
 runVM :: forall r. (Members '[Embed IO, App] r) => [VM.Instruction] -> Sem r ()
-runVM instrs =
-  embed (print (VM.runCode instrs))
+runVM instrs = do
+  r :: Either VM.LabelError [VM.Instruction] <- runError $ VM.resolveLabels instrs
+  case r of
+    Left err ->
+      exitJuvixError (JuvixError err)
+    Right instrs' ->
+      embed (print (VM.runCode instrs'))

runtime/src/vampir/vm.pir

@@ -59,9 +59,9 @@ def OpStore = 8;
 def OpMove = 9;
 // halt 0, 0, 0
 def OpHalt = 10;
-// alloc dest, num, 0
+// alloc dest, val, 0
 def OpAlloc = 11;
-// push src, 0, 0
+// push 0, val, 0
 def OpPush = 12;
 // pop dest, 0, 0
 def OpPop = 13;
@@ -115,7 +115,7 @@ def exec_eq reg val1 val2 (pc, sp, hp, regs, stack, heap) = {
 };
 
 def exec_load dest src off (pc, sp, hp, regs, stack, heap) = {
-    def addr = read_val regs src;
+    def addr = read regs src;
     def v = read heap (addr + off);
     (pc + 1, sp, hp, write regs dest v, stack, heap)
 };
@@ -135,12 +135,13 @@ def exec_halt reg val1 val2 (pc, sp, hp, regs, stack, heap) = {
     (pc, sp, hp, regs, stack, heap)
 };
 
-def exec_alloc reg num _ (pc, sp, hp, regs, stack, heap) = {
-    (pc + 1, sp, hp + num, write regs reg hp, stack, heap)
+def exec_alloc reg val _ (pc, sp, hp, regs, stack, heap) = {
+    def v = read_val regs val;
+    (pc + 1, sp, hp + v, write regs reg hp, stack, heap)
 };
 
-def exec_push reg _ _ (pc, sp, hp, regs, stack, heap) = {
-    def v = read regs reg;
+def exec_push _ val _ (pc, sp, hp, regs, stack, heap) = {
+    def v = read_val regs val;
     (pc + 1, sp + 1, hp, regs, write stack sp v, heap)
 };
 
@@ -157,7 +158,7 @@ def exec_jump _ val _ (pc, sp, hp, regs, stack, heap) = {
 def exec_jumpz reg val _ (pc, sp, hp, regs, stack, heap) = {
     def addr = read_val regs val;
     def v = read regs reg;
-    (if (isZero v) addr pc, sp, hp, regs, stack, heap)
+    (if (isZero v) addr (pc + 1), sp, hp, regs, stack, heap)
 };
 
 def opcodes = ( (OpIntAdd, exec_add):
@@ -185,6 +186,6 @@ def run_rec code state = {
 };
 
 def run n code = {
-    def (_, _, regs, _, _) = iter n (run_rec code) (0, 0, 0, zeros regsNum, zeros stackSize, zeros heapSize);
+    def (_, _, regs, _, _) = iter n (run_rec code) (0, 0, 1, zeros regsNum, zeros stackSize, zeros heapSize);
     hd regs
 };

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

@@ -2,11 +2,36 @@ module Juvix.Compiler.VM.Extra.Labels where
 
 import Data.HashMap.Strict qualified as HashMap
 import Juvix.Compiler.VM.Language
+import Juvix.Data.PPOutput
 
 data LabelError = ErrUndeclaredLabel Text | ErrDuplicateLabel Text
 
 makeLenses ''LabelError
 
+instance ToGenericError LabelError where
+  genericError :: (Member (Reader GenericOptions) r) => LabelError -> Sem r GenericError
+  genericError e = ask >>= generr
+    where
+      generr :: GenericOptions -> Sem r GenericError
+      generr _ =
+        return
+          GenericError
+            { _genericErrorLoc = i,
+              _genericErrorMessage = ppOutput (pretty msg),
+              _genericErrorIntervals = [i]
+            }
+        where
+          i = defaultLoc
+          msg = case e of
+            ErrUndeclaredLabel lab -> "undeclared label: " <> lab
+            ErrDuplicateLabel lab -> "duplicate label: " <> lab
+
+          mockFile :: Path Abs File
+          mockFile = $(mkAbsFile "/vm-run")
+
+          defaultLoc :: Interval
+          defaultLoc = singletonInterval (mkInitialLoc mockFile)
+
 resolveLabels ::
   Member (Error LabelError) r => [Instruction] -> Sem r [Instruction]
 resolveLabels instrs0 = do
@@ -52,7 +77,6 @@ resolveLabels instrs0 = do
           Jump x -> Jump <$> goJump x
           JumpOnZero x -> JumpOnZero <$> goJumpOnZero x
           Label {} -> impossible
-
       return $ instr' : instrs'
       where
         adjustValue :: Value -> Sem r Value
@@ -83,7 +107,7 @@ resolveLabels instrs0 = do
         goAlloc = return
 
         goPush :: InstrPush -> Sem r InstrPush
-        goPush = return
+        goPush = overM instrPushValue adjustValue
 
         goPop :: InstrPop -> Sem r InstrPop
         goPop = return

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

@@ -14,11 +14,11 @@ mkStore dest off val = Store $ InstrStore dest off val
 mkMove :: RegRef -> Value -> Instruction
 mkMove reg val = Move $ InstrMove reg val
 
-mkAlloc :: RegRef -> SmallInt -> Instruction
-mkAlloc reg num = Alloc $ InstrAlloc reg num
+mkAlloc :: RegRef -> Value -> Instruction
+mkAlloc reg val = Alloc $ InstrAlloc reg val
 
-mkPush :: RegRef -> Instruction
-mkPush reg = Push $ InstrPush reg
+mkPush :: Value -> Instruction
+mkPush val = Push $ InstrPush val
 
 mkPop :: RegRef -> Instruction
 mkPop reg = Pop $ InstrPop reg
@@ -52,7 +52,7 @@ maxInstrReg = \case
   Alloc InstrAlloc {..} ->
     _instrAllocDest
   Push InstrPush {..} ->
-    _instrPushSrc
+    maxValueReg _instrPushValue
   Pop InstrPop {..} ->
     _instrPopDest
   Jump InstrJump {..} ->

src/Juvix/Compiler/VM/Interpreter.hs

@@ -24,7 +24,7 @@ runCode instrs0 = runST goCode
       heap <- MV.replicate heapSize 0
       stack <- MV.replicate stackSize 0
       regs <- MV.replicate regsNum 0
-      go 0 0 0 regs stack heap
+      go 0 0 1 regs stack heap
       MV.read regs 0
 
     go ::
@@ -65,10 +65,9 @@ runCode instrs0 = runST goCode
       MV.MVector s Int ->
       ST s ()
     goBinop BinaryOp {..} pc sp hp regs stack heap = do
-      reg <- MV.read regs _binaryOpResult
       val1 <- readValue regs _binaryOpArg1
       val2 <- readValue regs _binaryOpArg2
-      MV.write regs reg (computeBinop val1 val2)
+      MV.write regs _binaryOpResult (computeBinop val1 val2)
       go (pc + 1) sp hp regs stack heap
       where
         computeBinop :: Int -> Int -> Int
@@ -91,10 +90,9 @@ runCode instrs0 = runST goCode
       MV.MVector s Int ->
       ST s ()
     goLoad InstrLoad {..} pc sp hp regs stack heap = do
-      dest <- MV.read regs _instrLoadDest
       src <- MV.read regs _instrLoadSrc
       v <- MV.read heap (src + _instrLoadOffset)
-      MV.write regs dest v
+      MV.write regs _instrLoadDest v
       go (pc + 1) sp hp regs stack heap
 
     goStore ::
@@ -136,8 +134,9 @@ runCode instrs0 = runST goCode
       MV.MVector s Int ->
       ST s ()
     goAlloc InstrAlloc {..} pc sp hp regs stack heap = do
+      v <- readValue regs _instrAllocSize
       MV.write regs _instrAllocDest hp
-      go (pc + 1) sp (hp + _instrAllocNum) regs stack heap
+      go (pc + 1) sp (hp + v) regs stack heap
 
     goPush ::
       InstrPush ->
@@ -149,7 +148,7 @@ runCode instrs0 = runST goCode
       MV.MVector s Int ->
       ST s ()
     goPush InstrPush {..} pc sp hp regs stack heap = do
-      v <- MV.read regs _instrPushSrc
+      v <- readValue regs _instrPushValue
       MV.write stack sp v
       go (pc + 1) (sp + 1) hp regs stack heap
 
@@ -192,4 +191,4 @@ runCode instrs0 = runST goCode
     goJumpOnZero InstrJumpOnZero {..} pc sp hp regs stack heap = do
       addr <- readValue regs _instrJumpOnZeroDest
       v <- MV.read regs _instrJumpOnZeroReg
-      go (if v == 0 then addr else pc) sp hp regs stack heap
+      go (if v == 0 then addr else pc + 1) sp hp regs stack heap

src/Juvix/Compiler/VM/Language.hs

@@ -14,13 +14,14 @@ data Value
   = Const SmallInt
   | RegRef RegRef
   | LabelRef Text
+  deriving stock (Show)
 
 -- Constructor representation: tag, field1, .., fieldn
 --
 -- Closure representation: addr, n, m, arg1, .., argn
 --
--- Here `m` is the total number of arguments the function accepts and `n` is the
--- number of arguments actually stored in the closure.
+-- Here `n` is the number of arguments stored in the closure and `m` is the
+-- remaining number of arguments to the function.
 --
 -- The tag and the address can be read/written using ordinary load/store with
 -- offset 0.
@@ -51,56 +52,67 @@ data Instruction
     JumpOnZero InstrJumpOnZero
   | -- | JVB opcode: 'labelName:'
     Label InstrLabel
+  deriving stock (Show)
 
 data BinaryOp = BinaryOp
   { _binaryOpCode :: Opcode,
     _binaryOpResult :: RegRef,
     _binaryOpArg1 :: Value,
     _binaryOpArg2 :: Value
   }
+  deriving stock (Show)
 
 data InstrLoad = InstrLoad
   { _instrLoadDest :: RegRef,
     _instrLoadSrc :: RegRef,
     _instrLoadOffset :: SmallInt
   }
+  deriving stock (Show)
 
 data InstrStore = InstrStore
   { _instrStoreDest :: RegRef,
     _instrStoreOffset :: SmallInt,
     _instrStoreValue :: Value
   }
+  deriving stock (Show)
 
 data InstrMove = InstrMove
   { _instrMoveDest :: RegRef,
     _instrMoveValue :: Value
   }
+  deriving stock (Show)
 
 data InstrAlloc = InstrAlloc
   { _instrAllocDest :: RegRef,
-    _instrAllocNum :: SmallInt
+    _instrAllocSize :: Value
   }
+  deriving stock (Show)
 
 newtype InstrPush = InstrPush
-  { _instrPushSrc :: RegRef
+  { _instrPushValue :: Value
   }
+  deriving stock (Show)
 
 newtype InstrPop = InstrPop
   { _instrPopDest :: RegRef
   }
+  deriving stock (Show)
 
 newtype InstrJump = InstrJump
   { _instrJumpDest :: Value
   }
+  deriving stock (Show)
 
 data InstrJumpOnZero = InstrJumpOnZero
   { _instrJumpOnZeroReg :: RegRef,
     _instrJumpOnZeroDest :: Value
   }
+  deriving stock (Show)
 
 newtype InstrLabel = InstrLabel
   { _instrLabelName :: Text
   }
+  deriving stock (Show)
 
 -- | Binary operation opcodes.
 data Opcode
@@ -118,6 +130,7 @@ data Opcode
     OpIntLt
   | -- | JVB opcode: 'eq reg, val1, val2'.
     OpIntEq
+  deriving stock (Show)
 
 instructionOpcode :: Instruction -> Int
 instructionOpcode = \case

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

@@ -25,12 +25,14 @@ runParser fileName input =
 
 parseToplevel :: ParsecS r [Instruction]
 parseToplevel = do
-  instrs <- P.sepEndBy statement (kw delimSemicolon)
+  instrs <- P.many statement
   P.eof
   return instrs
 
 statement :: ParsecS r Instruction
-statement = label <|> instruction
+statement = do
+  space
+  label <|> instruction
 
 label :: ParsecS r Instruction
 label = P.try $ do
@@ -65,6 +67,8 @@ instruction = do
       Move <$> parseMoveArgs
     "halt" ->
       return Halt
+    "alloc" ->
+      Alloc <$> parseAllocArgs
     "push" ->
       Push <$> parsePushArgs
     "pop" ->
@@ -110,8 +114,15 @@ parseMoveArgs = do
   val <- value
   return $ InstrMove dest val
 
+parseAllocArgs :: ParsecS r InstrAlloc
+parseAllocArgs = do
+  dest <- register
+  comma
+  val <- value
+  return $ InstrAlloc dest val
+
 parsePushArgs :: ParsecS r InstrPush
-parsePushArgs = InstrPush <$> register
+parsePushArgs = InstrPush <$> value
 
 parsePopArgs :: ParsecS r InstrPop
 parsePopArgs = InstrPop <$> register

tests/VM/positive/out/test001.out

@@ -0,0 +1 @@
+21

tests/VM/positive/test001.jvb

@@ -0,0 +1,11 @@
+-- arithmetic
+move r0, 7
+add r0, r0, 3
+mul r0, r0, 2
+sub r0, r0, 3
+mul r0, r0, 5
+div r0, r0, 5
+move r1, 4
+add r0, r1, r0
+halt
+-- result: 21

tests/VM/positive/test002.jvb

@@ -0,0 +1,11 @@
+-- loops
+  move r1, 100
+  move r0, 0
+loop:
+  add r0, r0, r1
+  sub r1, r1, 1
+  jumpz r1, exit
+  jump loop
+exit:
+  halt
+-- result: 5050

tests/VM/positive/test003.jvb

@@ -0,0 +1,16 @@
+-- direct call
+
+  move r0, 2
+  move r1, 3
+  move r2, 5
+  push return_label_1
+  jump calculate
+return_label_1:
+  halt
+  -- result: 11
+
+calculate:
+  mul r0, r0, r1
+  add r0, r0, r2
+  pop r1
+  jump r1