diff --git a/lvtrun/src/Run/Types.hs b/lvtrun/src/Run/Types.hs index 8618365..e3f8de6 100644 --- 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 index c92b27b..d33140b 100644 --- a/lvtrun/src/Run/Vm.hs +++ b/lvtrun/src/Run/Vm.hs @@ -13,7 +13,7 @@ module Run.Vm ) where -import Data.Word (Word8) +import Data.Int (Int32) import Control.Exception (throw) import Types @@ -21,7 +21,7 @@ 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 }