fix locals index

lvtrun/app/Run/Vm.hs

@@ -90,11 +90,12 @@ getLocalFromId' idx id (x:xs)
 getLocalFromId :: CurrentExec -> LocalIdx -> Value
 getLocalFromId cEx id = getLocalFromId' 0 id (ceLocals cEx)
 
-setLocalWithId :: Locals -> Value -> LocalIdx -> Locals
-setLocalWithId [] _ _ = throw $ WasmError "setLocalWithId: bad id"
-setLocalWithId (x:xs) value id
-  | id == 0 = value : xs
-  | otherwise = x : setLocalWithId xs value (id - 1)
+setLocalWithId :: Int32 -> Locals -> Value -> LocalIdx -> Locals
+setLocalWithId _ [] _ _ = throw $ WasmError "setLocalWithId: bad id"
+setLocalWithId idx (x:xs) value id
+  | idx > id = throw $ WasmError "setLocalWithId: bad id"
+  | idx == id = value : xs
+  | otherwise = x : setLocalWithId (idx + 1) xs value id
 
 -- pushResults StackToPushTo StackToPopFrom ResultTypes
 pushResults :: Stack -> Stack -> [TypeName] -> Stack
@@ -135,30 +136,63 @@ stackPopN stack n
 
 ---------------------------
 
+initLocalsVar :: Locals -> [Local] -> Locals
+initLocalsVar newLocals [] = newLocals
+initLocalsVar newLocals ((Local _ I32):xs) = initLocalsVar (I_32 0 : newLocals) xs
+initLocalsVar newLocals ((Local _ I64):xs) = initLocalsVar (I_64 0 : newLocals) xs
+initLocalsVar newLocals ((Local _ F32):xs) = initLocalsVar (F_32 0 : newLocals) xs
+initLocalsVar newLocals ((Local _ F64):xs) = initLocalsVar (F_64 0 : newLocals) xs
+
+createLocalsParams :: [TypeName] -> [Value] -> Locals
+createLocalsParams [] [] = []
+createLocalsParams (I32:xs) (I_32 val:xs2) = (I_32 val : createLocalsParams xs xs2)
+createLocalsParams (I64:xs) (I_64 val:xs2) = (I_64 val : createLocalsParams xs xs2)
+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"
+
+initLocalsParams :: [TypeName] -> Stack -> (Locals, Stack)
+initLocalsParams [] stack = ([], stack)
+initLocalsParams params stack 
+  | length params > length stack = throw $ WasmError "initLocalsParam: bad nb"
+  | otherwise = do
+    let (values, newStack) = stackPopN stack (length params)
+    let reversedValues = reverse values
+    let newLocals = createLocalsParams params reversedValues
+    (newLocals, newStack)
+
+initLocals :: [Local] -> [TypeName] -> Stack -> (Locals, Stack)
+initLocals localVarTypes paramTypes stack = do
+  let (newLocals, newStack) = initLocalsParams paramTypes stack
+  let localsVar = initLocalsVar newLocals localVarTypes
+  (newLocals ++ localsVar, newStack)
+
+---------------------------
+
 createEmptyLocals :: Locals -> [Local] -> Locals
 createEmptyLocals newLocals [] = newLocals
 createEmptyLocals newLocals ((Local _ I32):xs) = createEmptyLocals (I_32 0 : newLocals) xs
 createEmptyLocals newLocals ((Local _ I64):xs) = createEmptyLocals (I_64 0 : newLocals) xs
 createEmptyLocals newLocals ((Local _ F32):xs) = createEmptyLocals (F_32 0 : newLocals) xs
 createEmptyLocals newLocals ((Local _ F64):xs) = createEmptyLocals (F_64 0 : newLocals) xs
 
-fillLocals :: [TypeName] -> [Value] -> Locals -> Locals -> Locals
-fillLocals [] [] _ acc = reverse acc
-fillLocals (I32:xs) (I_32 val:xs2) (_:locals) acc = fillLocals xs xs2 locals (I_32 val : acc)
-fillLocals (I64:xs) (I_64 val:xs2) (_:locals) acc = fillLocals xs xs2 locals (I_64 val : acc)
-fillLocals (F32:xs) (F_32 val:xs2) (_:locals) acc = fillLocals xs xs2 locals (F_32 val : acc)
-fillLocals (F64:xs) (F_64 val:xs2) (_:locals) acc = fillLocals xs xs2 locals (F_64 val : acc)
-fillLocals _ _ _ _ = throw $ WasmError "fillLocals: bad type"
-
-initLocals :: Int -> [TypeName] -> Stack -> Locals -> (Locals, Stack)
-initLocals nb types stack locals
-  | nb /= length types = throw $ WasmError "initLocals: bad nb"
-  | nb > length stack = throw $ WasmError "initLocals: bad nb"
-  | otherwise = do
-    let (values, newStack) = stackPopN stack nb
-    let reversedValues = reverse values
-    let newLocals = fillLocals types reversedValues locals []
-    (newLocals, newStack)
+-- fillLocals :: [TypeName] -> [Value] -> Locals -> Locals
+-- fillLocals [] [] locals = locals
+-- fillLocals (I32:xs) (I_32 val:xs2) (_:locals) = (I_32 val : fillLocals xs xs2 locals)
+-- fillLocals (I64:xs) (I_64 val:xs2) (_:locals) = (I_64 val : fillLocals xs xs2 locals)
+-- fillLocals (F32:xs) (F_32 val:xs2) (_:locals) = (F_32 val : fillLocals xs xs2 locals)
+-- fillLocals (F64:xs) (F_64 val:xs2) (_:locals) = (F_64 val : fillLocals xs xs2 locals)
+-- fillLocals _ _ _ = throw $ WasmError "fillLocals: bad type"
+
+-- initLocals :: Int -> [TypeName] -> Stack -> Locals -> (Locals, Stack)
+-- initLocals nb types stack locals
+--   | nb /= length types = throw $ WasmError "initLocals: bad nb"
+--   | nb > length stack = throw $ WasmError "initLocals: bad nb"
+--   | otherwise = do
+--     let (values, newStack) = stackPopN stack nb
+--     let reversedValues = reverse values
+--     let newLocals = fillLocals types reversedValues locals
+--     (newLocals, newStack)
 
 ---------------------------
 
@@ -171,22 +205,22 @@ incrementInstIdx cEx = cEx { ceInstIdx = ceInstIdx cEx + 1 }
 ---------------------------
 
 execOpCode :: VM -> CurrentExec -> Instruction -> CurrentExec
-execOpCode vm cEx (I32Const val) = cEx { ceStack = stackPush (ceStack cEx) (I_32 val) }
-execOpCode vm cEx (Block _) = addLabel cEx { crBlockIndents = (crBlockIndents cEx) + 1 }
+execOpCode vm cEx (I32Const val) = trace ("--i32const--" ++ show val) cEx { ceStack = stackPush (ceStack cEx) (I_32 val) }
+execOpCode vm cEx (Block _) = trace "--block--" addLabel cEx { crBlockIndents = (crBlockIndents cEx) + 1 }
 execOpCode vm cEx (I32Eqz) = do
-  let value = stackTop (ceStack cEx)
+  let value = trace "--i32eqz--" 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) }
     _ -> throw $ WasmError "exec I32eqz: bad type"
 execOpCode vm cEx (I32Add) = do
-  let (value2, newStack1) = stackPop (ceStack cEx)
+  let (value2, newStack1) = trace "--i32add--" 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 $ WasmError "exec I32Add: bad type"
 execOpCode vm cEx (I32Sub) = do
-  let (value2, newStack1) = stackPop (ceStack cEx)
+  let (value2, newStack1) = trace "--i32sub--" 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)) }
@@ -198,19 +232,20 @@ execOpCode vm cEx (BrIf labelIdx) = do
     I_32 _ -> cEx { ceStack = newStack, ceInstIdx = (fromIntegral labelIdx) }
     _ -> throw $ WasmError "exec brIf: bad type"
 execOpCode vm cEx (Call funcIdx) = do
-  let newVm = execFunctionWithIdx vm funcIdx (ceStack cEx)
+  let newVm = trace ("--call--" ++ show funcIdx) execFunctionWithIdx vm funcIdx (ceStack cEx)
   let newStack = pushResults (ceStack cEx) (vmStack newVm) (ceResults (currentExec newVm))
   cEx { ceStack = newStack }
-execOpCode vm cEx (End) = cEx { crBlockIndents = (crBlockIndents cEx) - 1 }
+execOpCode vm cEx (End) = trace "--end--" cEx { crBlockIndents = (crBlockIndents cEx) - 1 }
+execOpCode vm cEx (Return) = trace "--end--" cEx { crBlockIndents = (crBlockIndents cEx) - 1 }
 execOpCode vm cEx (Unreachable) = throw $ WasmError "execOpCode: unreachable"
 execOpCode vm cEx (GetLocal localIdx) = do
-  let value = getLocalFromId cEx localIdx
+  let value = trace ("--getLocal--" ++ show localIdx) getLocalFromId cEx localIdx
   cEx { ceStack = stackPush (ceStack cEx) value }
 execOpCode vm cEx (SetLocal localIdx) = do
-  let (value, newStack) = stackPop (ceStack cEx)
-  let newLocals = setLocalWithId (ceLocals cEx) value localIdx
+  let (value, newStack) = trace ("--setLocal--" ++ show localIdx) stackPop (ceStack cEx)
+  let newLocals = setLocalWithId 0 (ceLocals cEx) value localIdx
   cEx { ceStack = newStack, ceLocals = newLocals }
-execOpCode vm cEx _ = cEx
+execOpCode vm cEx _ = trace ("not for: " ++ show (ceInstIdx cEx)) cEx
 
 execOpCodes :: VM -> [Instruction] -> CurrentExec
 execOpCodes vm [] = currentExec vm
@@ -219,25 +254,23 @@ execOpCodes vm instructions
   | ceInstIdx cEx < 0 = throw $ WasmError "execOpCodes: bad index"
   | (instructions !! ceInstIdx cEx) == End && crBlockIndents cEx == 0 = cEx
   | otherwise = do
-    let newCEx = execOpCode vm cEx (instructions !! ceInstIdx cEx)
+    let newCEx = trace ("currentOpCode: " ++ show (instructions !! ceInstIdx cEx)) execOpCode vm cEx (instructions !! ceInstIdx cEx)
     let newVm = vm { currentExec = (incrementInstIdx newCEx) }
     execOpCodes newVm instructions
   where cEx = currentExec vm
 
 execFunction :: VM -> VM
 execFunction vm = do
-  let newCEx = trace ("opcodes=" ++ show (ceInstructions (currentExec vm))) execOpCodes vm (ceInstructions (currentExec vm))
+  let newCEx = trace ("exex: " ++ show (ceInstructions (currentExec vm))) execOpCodes vm (ceInstructions (currentExec vm))
   vm { currentExec = newCEx, vmStack = (pushResults (vmStack vm) (ceStack newCEx) (ceResults newCEx)) }
 
 execFunctionWithIdx :: VM -> FuncIdx -> Stack -> VM
 execFunctionWithIdx vm funcIdx currentStack = do
   let function = getFunctionFromId funcIdx (functions (wasmModule vm))
   let funcTypee = getFuncTypeFromId (funcType function) (types (wasmModule vm))
-  let emptyLocals = createEmptyLocals [] (locals function)
-  let stack = trace ("newFunc") currentStack
-  let (newLocals, newStack) = initLocals (length (params funcTypee)) (params funcTypee) stack emptyLocals
+  let (newLocals, newStack) = initLocals (locals function) (params funcTypee) currentStack
   let cexec = CurrentExec {
-    ceLocals = newLocals,
+    ceLocals = trace ("ij" ++ show newLocals) newLocals,
     ceStack = newStack,
     ceInstructions = body function,
     ceInstIdx = 0,