implement v128.load with signed and unsigined extend

src/Language/Wasm/Interpreter.hs

@@ -717,6 +717,19 @@ eval budget store inst FunctionInstance { funcType, moduleInstance, code = Funct
                 )
         makeLoadInstr _ _ _ _ = error "Incorrect value on top of stack for memory instruction"
 
+        loadByteArray :: EvalCtx -> Natural -> Int -> ([Value] -> ByteArray.ByteArray -> EvalResult) -> IO EvalResult
+        loadByteArray ctx@EvalCtx{ stack = (VI32 v:rest) } offset byteWidth cont = do
+            let MemoryInstance { memory = memoryRef } = memInstances store ! (memaddrs moduleInstance ! 0)
+            memory <- readIORef memoryRef
+            let addr = fromIntegral v + fromIntegral offset
+            len <- ByteArray.getSizeofMutableByteArray memory
+            if addr + byteWidth > len
+            then return Trap
+            else do
+                val <- ByteArray.freezeByteArray memory addr byteWidth
+                return $ cont rest val
+        loadByteArray _ _ _ _ = error "Incorrect value on top of stack for memory instruction"
+
         makeStoreInstr :: (Primitive.Prim i, Bits i, Integral i) => EvalCtx -> Natural -> Int -> i -> IO EvalResult
         makeStoreInstr ctx@EvalCtx{ stack = (VI32 va:rest) } offset byteWidth v = do
             let MemoryInstance { memory = memoryRef } = memInstances store ! (memaddrs moduleInstance ! 0)
@@ -869,16 +882,9 @@ eval budget store inst FunctionInstance { funcType, moduleInstance, code = Funct
             makeLoadInstr ctx offset 4 $ (\rest val -> Done ctx { stack = VF32 (wordToFloat val) : rest })
         step ctx (F64Load MemArg { offset }) =
             makeLoadInstr ctx offset 8 $ (\rest val -> Done ctx { stack = VF64 (wordToDouble val) : rest })
-        step ctx@EvalCtx{ stack = (VI32 v:rest) } (V128Load MemArg { offset }) = do
+        step ctx (V128Load MemArg { offset }) =
-            let MemoryInstance { memory = memoryRef } = memInstances store ! (memaddrs moduleInstance ! 0)
+            loadByteArray ctx offset 16 $ \rest arr ->
-            memory <- readIORef memoryRef
+                Done ctx { stack = VV128 arr : rest }
-            let addr = fromIntegral v + fromIntegral offset
-            len <- ByteArray.getSizeofMutableByteArray memory
-            if addr + 16 > len
-            then return Trap
-            else do
-                val <- ByteArray.freezeByteArray memory addr 16
-                return $ Done ctx { stack = VV128 val : rest }
         step ctx (V128Load8Splat MemArg { offset }) =
             makeLoadInstr @Word8 ctx offset 1 $ \rest val ->
                 let v = ByteArray.byteArrayFromListN 16 $ replicate 16 val in
@@ -903,6 +909,45 @@ eval budget store inst FunctionInstance { funcType, moduleInstance, code = Funct
             makeLoadInstr @Word64 ctx offset 8 $ \rest val ->
                 let v = ByteArray.byteArrayFromListN 2 [val, 0] in
                 Done ctx { stack = VV128 v : rest }
+        step ctx (V128Load8x8S MemArg { offset }) =
+            loadByteArray ctx offset 8 $ \rest arr ->
+                let ext b = if b >= 0x80 then 0xFF00 + fromIntegral b else fromIntegral b in
+                let v = ByteArray.byteArrayFromListN @Word16 8
+                        $ ByteArray.foldrByteArray @Word8 (\b -> (ext b:)) [] arr
+                in
+                Done ctx { stack = VV128 v : rest }
+        step ctx (V128Load8x8U MemArg { offset }) =
+            loadByteArray ctx offset 8 $ \rest arr ->
+                let v = ByteArray.byteArrayFromListN @Word16 8
+                        $ ByteArray.foldrByteArray @Word8 (\b -> (fromIntegral b:)) [] arr
+                in
+                Done ctx { stack = VV128 v : rest }
+        step ctx (V128Load16x4S MemArg { offset }) =
+            loadByteArray ctx offset 8 $ \rest arr ->
+                let ext b = if b >= 0x8000 then 0xFFFF0000 + fromIntegral b else fromIntegral b in
+                let v = ByteArray.byteArrayFromListN @Word32 4
+                        $ ByteArray.foldrByteArray @Word16 (\b -> (ext b:)) [] arr
+                in
+                Done ctx { stack = VV128 v : rest }
+        step ctx (V128Load16x4U MemArg { offset }) =
+            loadByteArray ctx offset 8 $ \rest arr ->
+                let v = ByteArray.byteArrayFromListN @Word32 4
+                        $ ByteArray.foldrByteArray @Word16 (\b -> (fromIntegral b:)) [] arr
+                in
+                Done ctx { stack = VV128 v : rest }
+        step ctx (V128Load32x2S MemArg { offset }) =
+            loadByteArray ctx offset 8 $ \rest arr ->
+                let ext b = if b >= 0x80000000 then 0xFFFFFFFF00000000 + fromIntegral b else fromIntegral b in
+                let v = ByteArray.byteArrayFromListN @Word64 2
+                        $ ByteArray.foldrByteArray @Word32 (\b -> (ext b:)) [] arr
+                in
+                Done ctx { stack = VV128 v : rest }
+        step ctx (V128Load32x2U MemArg { offset }) =
+            loadByteArray ctx offset 8 $ \rest arr ->
+                let v = ByteArray.byteArrayFromListN @Word64 2
+                        $ ByteArray.foldrByteArray @Word32 (\b -> (fromIntegral b:)) [] arr
+                in
+                Done ctx { stack = VV128 v : rest }
         step ctx (I32Load8U MemArg { offset }) =
             makeLoadInstr @Word8 ctx offset 1 $ (\rest val -> Done ctx { stack = VI32 (fromIntegral val) : rest })
         step ctx (I32Load8S MemArg { offset }) =

src/Language/Wasm/Parser.y

@@ -157,6 +157,12 @@ import Language.Wasm.Lexer (
 'v128.load64_splat'   { Lexeme _ (TKeyword "v128.load64_splat") }
 'v128.load32_zero'    { Lexeme _ (TKeyword "v128.load32_zero") }
 'v128.load64_zero'    { Lexeme _ (TKeyword "v128.load64_zero") }
+'v128.load8x8_s'      { Lexeme _ (TKeyword "v128.load8x8_s") }
+'v128.load8x8_u'      { Lexeme _ (TKeyword "v128.load8x8_u") }
+'v128.load16x4_s'     { Lexeme _ (TKeyword "v128.load16x4_s") }
+'v128.load16x4_u'     { Lexeme _ (TKeyword "v128.load16x4_u") }
+'v128.load32x2_s'     { Lexeme _ (TKeyword "v128.load32x2_s") }
+'v128.load32x2_u'     { Lexeme _ (TKeyword "v128.load32x2_u") }
 'i32.load8_s'         { Lexeme _ (TKeyword "i32.load8_s") }
 'i32.load8_u'         { Lexeme _ (TKeyword "i32.load8_u") }
 'i32.load16_s'        { Lexeme _ (TKeyword "i32.load16_s") }
@@ -575,6 +581,12 @@ plaininstr :: { PlainInstr }
     | 'v128.load64_splat' memarg8    { V128Load64Splat $2 }
     | 'v128.load32_zero' memarg4     { V128Load32Zero $2 }
     | 'v128.load64_zero' memarg8     { V128Load64Zero $2 }
+    | 'v128.load8x8_s' memarg8       { V128Load8x8S $2 }
+    | 'v128.load8x8_u' memarg8       { V128Load8x8U $2 }
+    | 'v128.load16x4_s' memarg8      { V128Load16x4S $2 }
+    | 'v128.load16x4_u' memarg8      { V128Load16x4U $2 }
+    | 'v128.load32x2_s' memarg8      { V128Load32x2S $2 }
+    | 'v128.load32x2_u' memarg8      { V128Load32x2U $2 }
     | 'i32.load8_s' memarg1          { I32Load8S $2 }
     | 'i32.load8_u' memarg1          { I32Load8U $2 }
     | 'i32.load16_s' memarg2         { I32Load16S $2 }
@@ -1447,6 +1459,12 @@ data PlainInstr =
     | V128Load64Splat MemArg
     | V128Load32Zero MemArg
     | V128Load64Zero MemArg
+    | V128Load8x8S MemArg
+    | V128Load8x8U MemArg
+    | V128Load16x4S MemArg
+    | V128Load16x4U MemArg
+    | V128Load32x2S MemArg
+    | V128Load32x2U MemArg
     | I32Load8S MemArg
     | I32Load8U MemArg
     | I32Load16S MemArg
@@ -1976,6 +1994,12 @@ desugarize fields = do
         synInstrToStruct _ (PlainInstr (V128Load64Splat memArg)) = return $ S.V128Load64Splat memArg
         synInstrToStruct _ (PlainInstr (V128Load32Zero memArg)) = return $ S.V128Load32Zero memArg
         synInstrToStruct _ (PlainInstr (V128Load64Zero memArg)) = return $ S.V128Load64Zero memArg
+        synInstrToStruct _ (PlainInstr (V128Load8x8S memArg)) = return $ S.V128Load8x8S memArg
+        synInstrToStruct _ (PlainInstr (V128Load8x8U memArg)) = return $ S.V128Load8x8U memArg
+        synInstrToStruct _ (PlainInstr (V128Load16x4S memArg)) = return $ S.V128Load16x4S memArg
+        synInstrToStruct _ (PlainInstr (V128Load16x4U memArg)) = return $ S.V128Load16x4U memArg
+        synInstrToStruct _ (PlainInstr (V128Load32x2S memArg)) = return $ S.V128Load32x2S memArg
+        synInstrToStruct _ (PlainInstr (V128Load32x2U memArg)) = return $ S.V128Load32x2U memArg
         synInstrToStruct _ (PlainInstr (I32Load8S memArg)) = return $ S.I32Load8S memArg
         synInstrToStruct _ (PlainInstr (I32Load8U memArg)) = return $ S.I32Load8U memArg
         synInstrToStruct _ (PlainInstr (I32Load16S memArg)) = return $ S.I32Load16S memArg

src/Language/Wasm/Structure.hs

@@ -171,6 +171,12 @@ data Instruction index =
     | V128Load64Splat MemArg
     | V128Load32Zero MemArg
     | V128Load64Zero MemArg
+    | V128Load8x8S MemArg
+    | V128Load8x8U MemArg
+    | V128Load16x4S MemArg
+    | V128Load16x4U MemArg
+    | V128Load32x2S MemArg
+    | V128Load32x2U MemArg
     | I32Load8S MemArg
     | I32Load8U MemArg
     | I32Load16S MemArg

src/Language/Wasm/Validate.hs

@@ -358,6 +358,24 @@ getInstrType _ (V128Load32Zero memarg) = do
 getInstrType _ (V128Load64Zero memarg) = do
     checkMemoryInstr 8 memarg
     return $ I32 ==> V128
+getInstrType _ (V128Load8x8S memarg) = do
+    checkMemoryInstr 8 memarg
+    return $ I32 ==> V128
+getInstrType _ (V128Load8x8U memarg) = do
+    checkMemoryInstr 8 memarg
+    return $ I32 ==> V128
+getInstrType _ (V128Load16x4S memarg) = do
+    checkMemoryInstr 8 memarg
+    return $ I32 ==> V128
+getInstrType _ (V128Load16x4U memarg) = do
+    checkMemoryInstr 8 memarg
+    return $ I32 ==> V128
+getInstrType _ (V128Load32x2S memarg) = do
+    checkMemoryInstr 8 memarg
+    return $ I32 ==> V128
+getInstrType _ (V128Load32x2U memarg) = do
+    checkMemoryInstr 8 memarg
+    return $ I32 ==> V128
 getInstrType _ (I32Load8S memarg) = do
     checkMemoryInstr 1 memarg
     return $ I32 ==> I32

tests/Test.hs

@@ -20,7 +20,7 @@ main = do
     filter (List.isPrefixOf "simd") . 
     filter (List.isSuffixOf ".wast")
       <$> Directory.listDirectory "tests/spec"
-  let files = ["simd_load_extend.wast"]
+  -- let files = ["simd_load_extend.wast"]
   scriptTestCases <- (`mapM` files) $ \file -> do
     test <- LBS.readFile ("tests/spec/" ++ file)
     return $ testCase file $ do