fix some norm error

X-R-G-B · Jan 14, 2024 · 663d44f · 663d44f
1 parent 15175f9
commit 663d44f
Show file tree

Hide file tree

Showing 2 changed files with 63 additions and 44 deletions.
diff --git a/lvtrun/src/Run/Types.hs b/lvtrun/src/Run/Types.hs
@@ -12,7 +12,8 @@ module Run.Types
   VM(..),
   createVm,
   incrementInstIdx,
-  createEmptyExec
+  createEmptyExec,
+  decrementBlockIdx
 )
 where
 
@@ -60,6 +61,9 @@ createVm wasmMod = VM { vmStack = [],
 incrementInstIdx :: CurrentExec -> CurrentExec
 incrementInstIdx cEx = cEx { ceInstIdx = ceInstIdx cEx + 1 }
 
+decrementBlockIdx :: CurrentExec -> CurrentExec
+decrementBlockIdx cEx = cEx { crBlockIndents = (crBlockIndents cEx) - 1 }
+
 createEmptyExec :: CurrentExec
 createEmptyExec = CurrentExec {
   ceLocals = [],

diff --git a/lvtrun/src/Run/Vm.hs b/lvtrun/src/Run/Vm.hs
@@ -13,15 +13,15 @@ module Run.Vm
 )
 where
 
-import Data.Word (Word8)
+import Data.Int (Int32)
 import Control.Exception (throw)
 
 import Types
 import Run.Types
 import Run.Locals
 import Errors (CustomException(..))
 import Run.Functions (getFunctionFromId, getFuncTypeFromId)
-import Run.Stack (Stack, stackPush, stackPop, stackTop, pushResults)
+import Run.Stack (Stack, stackPush, stackPop, stackTop, pushResults, stackPopN)
 
 goToEndInstruction :: CurrentExec -> CurrentExec
 goToEndInstruction cexec
@@ -32,46 +32,64 @@ goToEndInstruction cexec
   where
     currentOpCode = (ceInstructions cexec) !! (ceInstIdx cexec)
 
-execOpCode :: VM -> CurrentExec -> Instruction -> CurrentExec
-execOpCode _ cEx (I32Const val) = cEx { ceStack = stackPush (ceStack cEx) (I_32 val) }
-execOpCode _ cEx (Block _) = cEx { crBlockIndents = (crBlockIndents cEx) + 1 }
-execOpCode _ cEx (I32Eqz) = do
-  let value = stackTop (ceStack cEx)
-  case value of
-    I_32 0 -> cEx { ceStack = stackPush (ceStack cEx) (I_32 1) }
-    I_32 _ -> cEx { ceStack = stackPush (ceStack cEx) (I_32 0) }
+execI32Const :: CurrentExec -> Int32 -> CurrentExec
+execI32Const cEx val = cEx {ceStack = stackPush (ceStack cEx) (I_32 val)}
+
+execI32Eqz :: CurrentExec -> CurrentExec
+execI32Eqz cEx@(CurrentExec {ceStack = stack}) =
+  case (stackTop stack) of
+    I_32 0 -> cEx { ceStack = stackPush stack (I_32 1) }
+    I_32 _ -> cEx { ceStack = stackPush stack (I_32 0) }
     _ -> throw $ RuntimeError "exec I32eqz: bad type"
-execOpCode _ cEx (I32Eq) = do
-  let (value2, newStack1) = stackPop (ceStack cEx)
-  let (value1, newStack2) = stackPop newStack1
-  case (value1, value2) of
-    (I_32 val1, I_32 val2) -> cEx { ceStack = stackPush newStack2 (I_32 (if val1 == val2 then 1 else 0)) }
+
+execI32Add :: CurrentExec -> CurrentExec
+execI32Add cEx@(CurrentExec {ceStack = stack}) =
+  case (stackPopN stack 2) of
+    ([I_32 val2, I_32 val1], newStack) ->
+      cEx { ceStack = stackPush newStack (I_32 (val1 + val2)) }
+    _ -> throw $ RuntimeError "exec I32add: bad type"
+
+execI32Eq :: CurrentExec -> CurrentExec
+execI32Eq cEx@(CurrentExec {ceStack = stack}) =
+  case (stackPopN stack 2) of
+    ([I_32 value2, I_32 value1], newStack) -> case (value1 == value2) of
+      True -> cEx { ceStack = stackPush newStack (I_32 1) }
+      False -> cEx { ceStack = stackPush newStack (I_32 0) }
     _ -> throw $ RuntimeError "exec I32Eq: bad type"
-execOpCode _ cEx (I32Add) = do
-  let (value2, newStack1) = stackPop (ceStack cEx)
-  let (value1, newStack2) = stackPop newStack1
-  case (value1, value2) of
-    (I_32 val1, I_32 val2) -> cEx { ceStack = stackPush newStack2 (I_32 (val1 + val2)) }
-    _ -> throw $ RuntimeError "exec I32Add: bad type"
-execOpCode _ cEx (I32Sub) = do
-  let (value2, newStack1) = stackPop (ceStack cEx)
-  let (value1, newStack2) = stackPop newStack1
-  case (value1, value2) of
-    (I_32 val1, I_32 val2) -> cEx { ceStack = stackPush newStack2 (I_32 (val1 - val2)) }
-    _ -> throw $ RuntimeError "exec I32Sub: bad type"
-execOpCode _ cEx (I32Mul) = do
-  let (value2, newStack1) = stackPop (ceStack cEx)
-  let (value1, newStack2) = stackPop newStack1
-  case (value1, value2) of
-    (I_32 val1, I_32 val2) -> cEx { ceStack = stackPush newStack2 (I_32 (val1 * val2)) }
-    _ -> throw $ RuntimeError "exec I32Mul: bad type"
-execOpCode _ cEx (I32Divs) = do
-  let (value2, newStack1) = stackPop (ceStack cEx)
-  let (value1, newStack2) = stackPop newStack1
-  case (value1, value2) of
-    (I_32 _, I_32 0) -> throw $ RuntimeError "exec I32Divs: division by zero"
-    (I_32 val1, I_32 val2) -> cEx { ceStack = stackPush newStack2 (I_32 (val1 `div` val2)) }
-    _ -> throw $ RuntimeError "exec I32Divs: bad type"
+
+execI32Sub :: CurrentExec -> CurrentExec
+execI32Sub cEx@(CurrentExec {ceStack = stack}) =
+  case (stackPopN stack 2) of
+    ([I_32 val2, I_32 val1], newStack) ->
+      cEx { ceStack = stackPush newStack (I_32 (val1 - val2)) }
+    _ -> throw $ RuntimeError "exec I32sub: bad type"
+
+execI32Mul :: CurrentExec -> CurrentExec
+execI32Mul cEx@(CurrentExec {ceStack = stack}) =
+  case (stackPopN stack 2) of
+    ([I_32 val2, I_32 val1], newStack) ->
+      cEx { ceStack = stackPush newStack (I_32 (val1 * val2)) }
+    _ -> throw $ RuntimeError "exec I32mul: bad type"
+
+execI32Divs :: CurrentExec -> CurrentExec
+execI32Divs cEx@(CurrentExec {ceStack = stack}) =
+  case (stackPopN stack 2) of
+    ([I_32 val2, I_32 val1], newStack) ->
+      cEx { ceStack = stackPush newStack (I_32 (val1 `div` val2)) }
+    _ -> throw $ RuntimeError "exec I32divs: bad type"
+
+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
+execOpCode _ cEx (I32Mul) = execI32Mul cEx
+execOpCode _ cEx (I32Divs) = execI32Divs cEx
 execOpCode _ cEx (BrIf labelIdx) = case stackTop (ceStack cEx) of
     I_32 0 -> cEx
     I_32 _ -> cEx { ceInstIdx = (fromIntegral labelIdx) }
@@ -80,9 +98,6 @@ execOpCode vm cEx (Call funcIdx) = do
   let newVm = execFunctionWithIdx vm funcIdx (ceStack cEx)
   let newStack = pushResults (ceStack cEx) (vmStack newVm) (ceResults (currentExec newVm))
   cEx { ceStack = newStack }
-execOpCode _ cEx (End) = cEx { crBlockIndents = (crBlockIndents cEx) - 1 }
-execOpCode _ cEx (Return) = cEx { crBlockIndents = (crBlockIndents cEx) - 1 }
-execOpCode _ cEx (Unreachable) = throw $ RuntimeError "execOpCode: unreachable"
 execOpCode _ cEx (GetLocal localIdx) = do
   let value = getLocalFromId (ceLocals cEx) localIdx
   cEx { ceStack = stackPush (ceStack cEx) value }