Merge pull request #21 from X-R-G-B/vm

Vm

lvtrun/README.md

@@ -32,17 +32,21 @@
 
 # ----------------------- 2 -----------------------
 
-02
+02 24
 # 02 is the id of the import section
-24 01 16 77
-61 73 69 5f
-73 6e 61 70
-73 68 6f 74
-5f 70 72 65
-76 69 65 77
-31 09 70 72
-6f 63 5f 65
-78 69 74 00
+# 1 vector
+01
+# name is 16hex = 22dec bytes long
+16
+# name = "wasi_snapshot_preview1"
+77 61 73 69 5f 73 6e 61 70 73 68 6f 74 5f 70 72 65 76 69 65 77 31
+# name is 09
+09
+# name = "proct_exit"
+70 72 6f 63 5f 65 78 69 74
+# 00 = func = function
+00
+# 00 = typeidx = 0
 02
 
 # ----------------------- 3 -----------------------

lvtrun/src/OpCodes.hs

@@ -21,7 +21,6 @@ import Leb128 (getLEB128ToI32, getLEB128ToI64)
 import Types (Instruction(..), MemArg(..), BlockType(..))
 
 extractOpCode' :: [Word8] -> ([Word8], BSL.ByteString)
-extractOpCode' (0x03:rest) = ([0x03], BSL.pack rest) 
 extractOpCode' (0x11:rest) = ([0x11], BSL.pack rest)
 extractOpCode' (0x00:rest) = ([0x00], BSL.pack rest)
 extractOpCode' (0x0b:rest) = ([0x0b], BSL.pack rest)
@@ -58,21 +57,23 @@ extractOpCode' (0x4a:rest) = ([0x4a], BSL.pack rest)
 extractOpCode' (0x4c:rest) = ([0x4c], BSL.pack rest)
 extractOpCode' (0x4e:rest) = ([0x4e], BSL.pack rest)
 extractOpCode' (0x47:rest) = ([0x47], BSL.pack rest)
+extractOpCode' (0x05:rest) = ([0x05], BSL.pack rest)
 extractOpCode' (0x3f:0x00:rest) = ([0x3f, 0x00], BSL.pack rest)
 extractOpCode' (0x40:0x00:rest) = ([0x40, 0x00], BSL.pack rest)
 extractOpCode' (0x04:0x40:rest) = ([0x04, 0x40], BSL.pack rest)
-extractOpCode' _ = throw $ WasmError "ExtractOpCode: bad opcode"
+extractOpCode' (0x03:0x40:rest) = ([0x03, 0x40], BSL.pack rest)
+extractOpCode' idx = throw $ WasmError "ExtractOpCode: bad opcode"
 
 extractOpCode :: BSL.ByteString -> ([Word8], BSL.ByteString)
 extractOpCode bytes = extractOpCode' (BSL.unpack bytes)
 
 createInstruction :: [Word8] -> BSL.ByteString -> (Instruction, BSL.ByteString)
-createInstruction [0x03] bytes = (Nop, bytes)
 createInstruction [0x11] bytes = (Nop, bytes)
 createInstruction [0x00] bytes = (Unreachable, bytes)
 createInstruction [0x01] bytes = (Nop, bytes)
 createInstruction [0x02] bytes = (Block EmptyType, bytes)
 createInstruction [0x0b] bytes = (End, bytes)
+createInstruction [0x05] bytes = (Else, bytes)
 createInstruction [0x48] bytes = (I32Lts, bytes)
 createInstruction [0x0f] bytes = (Return, bytes)
 createInstruction [0x4b] bytes = (I32Gtu, bytes)
@@ -89,6 +90,7 @@ createInstruction [0x4e] bytes = (I32Ges, bytes)
 createInstruction [0x4c] bytes = (I32Les, bytes)
 createInstruction [0x71] bytes = (I32And, bytes)
 createInstruction [0x04, 0x40] bytes = (If, bytes)
+createInstruction [0x03, 0x40] bytes = (Loop, bytes)
 createInstruction [0x3f, 0x00] bytes = (MemorySize, bytes)
 createInstruction [0x40, 0x00] bytes = (MemoryGrow, bytes)
 createInstruction [0x0d] bytes = (\(value, rest) ->

lvtrun/src/Run/Functions.hs

@@ -21,16 +21,16 @@ import Errors (CustomException(..))
 import Types (Export(..), ExportDesc(..), Function(..), FuncType(..))
 
 getStartFunctionId :: [Export] -> Int32
-getStartFunctionId [] = throw $ WasmError "No start function"
+getStartFunctionId [] = throw $ RuntimeError "No start function"
 getStartFunctionId (x:xs)
   | expName x == "start" =
     case expDesc x of
       ExportFunc idx -> idx
-      _ -> throw $ WasmError "getStartFunctionId: bad export"
+      _ -> throw $ RuntimeError "getStartFunctionId: bad export"
   | otherwise = getStartFunctionId xs
 
 getFunctionFromId :: Int32 -> [Function] -> Function
-getFunctionFromId _ [] = throw $ WasmError "getFunctionFromId: bad id"
+getFunctionFromId _ [] = throw $ RuntimeError "getFunctionFromId: bad id"
 getFunctionFromId id (x:xs)
   | funcIdx x == id = x
   | otherwise = getFunctionFromId id xs
@@ -40,7 +40,7 @@ getStartFunction exports functions =
   getFunctionFromId (getStartFunctionId exports) functions
 
 getFuncTypeFromId :: Int32 -> [FuncType] -> FuncType
-getFuncTypeFromId _ [] = throw $ WasmError "getFuncTypeFromId: bad id"
+getFuncTypeFromId _ [] = throw $ RuntimeError "getFuncTypeFromId: bad id"
 getFuncTypeFromId id (x:xs)
   | typeId x == id = x
   | otherwise = getFuncTypeFromId id xs

lvtrun/src/Run/Locals.hs

@@ -25,19 +25,19 @@ import Run.Stack (Stack, stackPopN)
 type Locals = [Value]
 
 getLocalFromId' :: Int32 -> LocalIdx -> Locals -> Value
-getLocalFromId' _ _ [] = throw $ WasmError "getLocalFromId: bad id"
+getLocalFromId' _ _ [] = throw $ RuntimeError "getLocalFromId: bad id"
 getLocalFromId' idx idntifier (x:xs)
-  | idx > idntifier = throw $ WasmError "getLocalFromId: bad id"
+  | idx > idntifier = throw $ RuntimeError "getLocalFromId: bad id"
   | idx == idntifier = x
   | otherwise = getLocalFromId' (idx + 1) idntifier xs
 
 getLocalFromId :: Locals -> LocalIdx -> Value
 getLocalFromId lcals idntifier = getLocalFromId' 0 idntifier lcals
 
 setLocalWithId :: Int32 -> Locals -> Value -> LocalIdx -> Locals
-setLocalWithId _ [] _ _ = throw $ WasmError "setLocalWithId: bad id"
+setLocalWithId _ [] _ _ = throw $ RuntimeError "setLocalWithId: bad id"
 setLocalWithId idx (x:xs) value idntifier
-  | idx > idntifier = throw $ WasmError "setLocalWithId: bad id"
+  | idx > idntifier = throw $ RuntimeError "setLocalWithId: bad id"
   | idx == idntifier = value : xs
   | otherwise = x : setLocalWithId (idx + 1) xs value idntifier
 
@@ -64,7 +64,7 @@ createLocalsParams (F32:xs) (F_32 val:xs2) =
   (F_32 val : createLocalsParams xs xs2)
 createLocalsParams (F64:xs) (F_64 val:xs2) =
   (F_64 val : createLocalsParams xs xs2)
-createLocalsParams _ _ = throw $ WasmError "createLocalsParams: bad type"
+createLocalsParams _ _ = throw $ RuntimeError "createLocalsParams: bad type"
 
 initLocalsParams' :: (Locals, Stack) -> [TypeName] -> (Locals, Stack)
 initLocalsParams' ([], newStack) _ = ([], newStack)
@@ -74,7 +74,7 @@ initLocalsParams' (values, newStack) prms =
 initLocalsParams :: [TypeName] -> Stack -> (Locals, Stack)
 initLocalsParams [] stack = ([], stack)
 initLocalsParams prms stack 
-  | length prms > length stack = throw $ WasmError "initLocalsParam: bad nb"
+  | length prms > length stack = throw $ RuntimeError "initLocalsParam: bad nb"
   | otherwise = initLocalsParams' (stackPopN stack (length prms)) prms
 
 initLocals :: [Local] -> [TypeName] -> Stack -> (Locals, Stack)

lvtrun/src/Run/Types.hs

@@ -13,22 +13,29 @@ module Run.Types
   createVm,
   incrementInstIdx,
   createEmptyExec,
-  decrementBlockIdx
+  decrementBlockIdx,
+  getLabelOpIdx,
+  addLabel,
+  incrementBlockIdx,
+  goToLabel
 )
 where
 
 import Data.Word (Word8)
+import Control.Exception (throw)
 
 import Types
+import Data.Int (Int32)
 import Run.Stack (Stack)
 import Run.Locals (Locals)
+import Errors (CustomException(..))
 
 data CurrentExec = CurrentExec {
   ceLocals :: Locals,
   ceStack :: Stack,
   ceInstructions :: [Instruction],
   ceInstIdx :: Int,
-  ceLabels :: [Int],
+  ceLabels :: [Int32],
   ceParams :: [TypeName],
   ceResults :: [TypeName],
   crBlockIndents :: Int
@@ -58,9 +65,35 @@ createVm wasmMod = VM { vmStack = [],
   wasmModule = wasmMod
 }
 
+goToLabel :: CurrentExec -> LabelIdx -> CurrentExec
+goToLabel cEx labelIdx =
+  cEx {ceInstIdx = fromIntegral (getLabelOpIdx cEx labelIdx)}
+
+getLabelOpIdx :: CurrentExec -> LabelIdx -> Int
+getLabelOpIdx cEx labelIdx
+  | labelIdx >= fromIntegral (length (ceLabels cEx)) =
+    throw $ RuntimeError "getLabelOpIdx: bad index"
+  | otherwise = (fromIntegral (ceLabels cEx !! fromIntegral labelIdx))
+
+doesLabelExist :: [Int32] -> LabelIdx -> Bool
+doesLabelExist [] _ = False
+doesLabelExist (x:xs) labelIdx
+  | x == labelIdx = True
+  | otherwise = doesLabelExist xs labelIdx
+
+addLabel :: CurrentExec -> CurrentExec
+addLabel cEx
+  | doesLabelExist (ceLabels cEx) labelIdx = cEx
+  | otherwise = cEx { ceLabels = (ceLabels cEx) ++ [labelIdx] }
+  where
+    labelIdx = fromIntegral (ceInstIdx cEx)
+
 incrementInstIdx :: CurrentExec -> CurrentExec
 incrementInstIdx cEx = cEx { ceInstIdx = ceInstIdx cEx + 1 }
 
+incrementBlockIdx :: CurrentExec -> CurrentExec
+incrementBlockIdx cEx = cEx { crBlockIndents = (crBlockIndents cEx) + 1 }
+
 decrementBlockIdx :: CurrentExec -> CurrentExec
 decrementBlockIdx cEx = cEx { crBlockIndents = (crBlockIndents cEx) - 1 }
 

lvtrun/src/Run/Vm.hs

@@ -102,20 +102,83 @@ execCall vm cEx funcIdx = cEx { ceStack = newStack }
     currentStack = ceStack cEx
     res = ceResults (currentExec newVm)
 
+doesElseExist' :: [Instruction] -> Bool
+doesElseExist' [] = False
+doesElseExist' (Else:_) = True
+doesElseExist' (_:rest) = doesElseExist' rest
+
+doesElseExist :: CurrentExec -> Bool
+doesElseExist cEx = doesElseExist' (drop (ceInstIdx cEx) (ceInstructions cEx))
+
+getElseIndex' :: [Instruction] -> Int -> Int
+getElseIndex' [] _ = throw $ RuntimeError "getElseIndex: missing else"
+getElseIndex' (Else:_) idx = idx
+getElseIndex' (_:rest) idx = getElseIndex' rest (idx + 1)
+
+getElseIndex :: CurrentExec -> Int
+getElseIndex cEx = getElseIndex' (drop (ceInstIdx cEx) (ceInstructions cEx)) 0
+
+executeElse :: CurrentExec -> CurrentExec
+executeElse cEx@(CurrentExec {ceStack = stack}) =
+  case doesElseExist cEx of
+    False -> cEx
+    True -> cEx { ceInstIdx = getElseIndex cEx }
+
 execIf :: CurrentExec -> CurrentExec
 execIf cEx@(CurrentExec {ceStack = stack}) = case stackTop stack of
   I_32 0 -> goToEndInstruction cEx
-  I_32 1 -> cEx { crBlockIndents = (crBlockIndents cEx) + 1 }
+  I_32 1 -> executeElse (addLabel (cEx { crBlockIndents = (crBlockIndents cEx) + 1 }))
   I_32 _ -> throw $ RuntimeError "execIf: bad if statement"
   _ -> throw $ RuntimeError "execIf: bad type"
 
+execI32GtS :: CurrentExec -> CurrentExec
+execI32GtS cEx@(CurrentExec {ceStack = stack}) =
+  case (stackPopN stack 2) of
+    ([I_32 val2, I_32 val1], newStack) -> case (val1 > val2) of
+      True -> cEx { ceStack = stackPush newStack (I_32 1) }
+      False -> cEx { ceStack = stackPush newStack (I_32 0) }
+
+execI32GeS :: CurrentExec -> CurrentExec
+execI32GeS cEx@(CurrentExec {ceStack = stack}) =
+  case (stackPopN stack 2) of
+    ([I_32 val2, I_32 val1], newStack) -> case (val1 >= val2) of
+      True -> cEx { ceStack = stackPush newStack (I_32 1) }
+      False -> cEx { ceStack = stackPush newStack (I_32 0) }
+
+execI32LtS :: CurrentExec -> CurrentExec
+execI32LtS cEx@(CurrentExec {ceStack = stack}) =
+  case (stackPopN stack 2) of
+    ([I_32 val2, I_32 val1], newStack) -> case (val1 < val2) of
+      True -> cEx { ceStack = stackPush newStack (I_32 1) }
+      False -> cEx { ceStack = stackPush newStack (I_32 0) }
+
+execI32LeS :: CurrentExec -> CurrentExec
+execI32LeS cEx@(CurrentExec {ceStack = stack}) =
+  case (stackPopN stack 2) of
+    ([I_32 val2, I_32 val1], newStack) -> case (val1 <= val2) of
+      True -> cEx { ceStack = stackPush newStack (I_32 1) }
+      False -> cEx { ceStack = stackPush newStack (I_32 0) }
+
+execI32GtU :: CurrentExec -> CurrentExec
+execI32GtU cEx@(CurrentExec {ceStack = stack}) =
+  case (stackPopN stack 2) of
+    ([I_32 val2, I_32 val1], newStack) ->
+      case ((fromIntegral val1) > (fromIntegral val2)) of
+        True -> cEx { ceStack = stackPush newStack (I_32 1) }
+        False -> cEx { ceStack = stackPush newStack (I_32 0) }
+
+incrementBlockIndent :: CurrentExec -> CurrentExec
+incrementBlockIndent cEx = cEx { crBlockIndents = (crBlockIndents cEx) + 1 }
+
+execBr :: CurrentExec -> LabelIdx -> CurrentExec
+execBr cEx labelIdx = goToLabel cEx labelIdx
+
 execOpCode :: VM -> CurrentExec -> Instruction -> CurrentExec
 execOpCode _ cEx (Unreachable) = throw $ RuntimeError "execOpCode: unreachable"
 execOpCode _ cEx (End) = decrementBlockIdx cEx
 execOpCode _ cEx (Return) = decrementBlockIdx cEx
 execOpCode _ cEx (I32Const val) = execI32Const cEx val
 execOpCode _ cEx (I32Eqz) = execI32Eqz cEx
-execOpCode _ cEx (Block _) = cEx { crBlockIndents = (crBlockIndents cEx) + 1 }
 execOpCode _ cEx (I32Eq) = execI32Eq cEx
 execOpCode _ cEx (I32Add) = execI32Add cEx
 execOpCode _ cEx (I32Sub) = execI32Sub cEx
@@ -126,7 +189,16 @@ execOpCode _ cEx (SetLocal localIdx) = execSetLocal cEx localIdx
 execOpCode _ cEx (BrIf labelIdx) = execBrIf cEx
 execOpCode vm cEx (Call funcIdx) = execCall vm cEx funcIdx
 execOpCode _ cEx (If) = execIf cEx
-execOpCode _ cEx _ = cEx
+execOpCode _ cEx (I32Gts) = execI32GtS cEx
+execOpCode _ cEx (I32Ges) = execI32GeS cEx
+execOpCode _ cEx (I32Lts) = execI32LtS cEx
+execOpCode _ cEx (I32Les) = execI32LeS cEx
+execOpCode _ cEx (I32Gtu) = execI32GtU cEx
+execOpCode _ cEx (Block _) = incrementBlockIndent (addLabel cEx)
+execOpCode _ cEx (Br labelIdx) = execBr cEx labelIdx
+execOpCode _ cEx (Loop) = incrementBlockIndent (addLabel cEx)
+execOpCode _ cEx (Else) = throw $ RuntimeError "elseWithoutIf"
+execOpCode _ cEx _ = throw $ RuntimeError "execOpCode: not implemented"
 
 execOpCodes :: VM -> [Instruction] -> CurrentExec
 execOpCodes vm [] = currentExec vm

lvtrun/src/Types.hs

@@ -117,10 +117,12 @@ data Instruction =
   | I32Leu
   | I32Eq
   | I32Lts
+  | Else
   | I32Gts
   | I32Les
   | I32Ges
   | I32Ne
+  | Loop
   | LocalTee LocalIdx
   | BrIf LabelIdx
   | If
@@ -130,6 +132,9 @@ data Instruction =
   | MemorySize
   | MemoryGrow
   deriving (Eq)
+--IF/ELSE
+--LOOP
+--BR
 
 instance Show Instruction where
   show Unreachable = "\n\t\t\t\tunreachable"
@@ -170,6 +175,7 @@ instance Show Instruction where
   show (Br idx) = "\n\t\t\t\tbr " ++ (show idx)
   show End = "\n\t\t\t\tend"
   show (Block blockType) = "\n\t\t\t\tblock " ++ (show blockType)
+  show (Loop) = "\n\t\t\t\tloop"
 
 -- Module section