implement v128.load[8|16|32|64}_lane

src/Language/Wasm/Interpreter.hs

@@ -699,8 +699,8 @@ eval budget store inst FunctionInstance { funcType, moduleInstance, code = Funct
                 Done ctx' -> go ctx' rest
                 command -> return command
         
-        makeLoadInstr :: (Primitive.Prim i, Bits i, Integral i) => EvalCtx -> Natural -> Int -> ([Value] -> i -> EvalResult) -> IO EvalResult
+        makeLoadInstrIO :: (Primitive.Prim i, Bits i, Integral i) => EvalCtx -> Natural -> Int -> ([Value] -> i -> IO EvalResult) -> IO EvalResult
-        makeLoadInstr ctx@EvalCtx{ stack = (VI32 v:rest) } offset byteWidth cont = do
+        makeLoadInstrIO 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
@@ -713,10 +713,14 @@ eval budget store inst FunctionInstance { funcType, moduleInstance, code = Funct
             then return Trap
             else (
                     if isAligned
-                    then cont rest <$> ByteArray.readByteArray memory (addr `quot` byteWidth)
+                    then do
-                    else cont rest . sum <$> mapM readByte [0..byteWidth-1]
+                        ByteArray.readByteArray memory (addr `quot` byteWidth) >>= cont rest
+                    else mapM readByte [0..byteWidth-1] >>= cont rest . sum
                 )
-        makeLoadInstr _ _ _ _ = error "Incorrect value on top of stack for memory instruction"
+        makeLoadInstrIO _ _ _ _ = error "Incorrect value on top of stack for memory instruction"
+
+        makeLoadInstr :: (Primitive.Prim i, Bits i, Integral i) => EvalCtx -> Natural -> Int -> ([Value] -> i -> EvalResult) -> IO EvalResult
+        makeLoadInstr ctx off w cont = makeLoadInstrIO ctx off w (\x -> return . cont x)
 
         loadByteArray :: EvalCtx -> Natural -> Int -> ([Value] -> ByteArray.ByteArray -> EvalResult) -> IO EvalResult
         loadByteArray ctx@EvalCtx{ stack = (VI32 v:rest) } offset byteWidth cont = do
@@ -886,6 +890,30 @@ eval budget store inst FunctionInstance { funcType, moduleInstance, code = Funct
         step ctx (V128Load MemArg { offset }) =
             loadByteArray ctx offset 16 $ \rest arr ->
                 Done ctx { stack = VV128 arr : rest }
+        step ctx@EvalCtx{ stack = (VV128 v:rest) } (V128Load8Lane MemArg { offset } lane) =
+            makeLoadInstrIO @Word8 ctx{stack = rest} offset 1 $ \rest w -> do
+                arr <- ByteArray.thawByteArray v 0 16
+                ByteArray.writeByteArray arr (fromIntegral lane) w
+                r <- ByteArray.unsafeFreezeByteArray arr
+                return $ Done ctx { stack = VV128 r : rest }
+        step ctx@EvalCtx{ stack = (VV128 v:rest) } (V128Load16Lane MemArg { offset } lane) =
+            makeLoadInstrIO @Word16 ctx{stack = rest} offset 2 $ \rest w -> do
+                arr <- ByteArray.thawByteArray v 0 16
+                ByteArray.writeByteArray arr (fromIntegral lane) w
+                r <- ByteArray.unsafeFreezeByteArray arr
+                return $ Done ctx { stack = VV128 r : rest }
+        step ctx@EvalCtx{ stack = (VV128 v:rest) } (V128Load32Lane MemArg { offset } lane) =
+            makeLoadInstrIO @Word32 ctx{stack = rest} offset 4 $ \rest w -> do
+                arr <- ByteArray.thawByteArray v 0 16
+                ByteArray.writeByteArray arr (fromIntegral lane) w
+                r <- ByteArray.unsafeFreezeByteArray arr
+                return $ Done ctx { stack = VV128 r : rest }
+        step ctx@EvalCtx{ stack = (VV128 v:rest) } (V128Load64Lane MemArg { offset } lane) =
+            makeLoadInstrIO @Word64 ctx{stack = rest} offset 8 $ \rest w -> do
+                arr <- ByteArray.thawByteArray v 0 16
+                ByteArray.writeByteArray arr (fromIntegral lane) w
+                r <- ByteArray.unsafeFreezeByteArray arr
+                return $ Done ctx { stack = VV128 r : rest }
         step ctx (V128Load8Splat MemArg { offset }) =
             makeLoadInstr @Word8 ctx offset 1 $ \rest val ->
                 let v = ByteArray.byteArrayFromListN 16 $ replicate 16 val in

src/Language/Wasm/Parser.y

@@ -151,6 +151,10 @@ import Language.Wasm.Lexer (
 'f32.load'            { Lexeme _ (TKeyword "f32.load") }
 'f64.load'            { Lexeme _ (TKeyword "f64.load") }
 'v128.load'           { Lexeme _ (TKeyword "v128.load") }
+'v128.load8_lane'     { Lexeme _ (TKeyword "v128.load8_lane") }
+'v128.load16_lane'    { Lexeme _ (TKeyword "v128.load16_lane") }
+'v128.load32_lane'    { Lexeme _ (TKeyword "v128.load32_lane") }
+'v128.load64_lane'    { Lexeme _ (TKeyword "v128.load64_lane") }
 'v128.load8_splat'    { Lexeme _ (TKeyword "v128.load8_splat") }
 'v128.load16_splat'   { Lexeme _ (TKeyword "v128.load16_splat") }
 'v128.load32_splat'   { Lexeme _ (TKeyword "v128.load32_splat") }
@@ -609,6 +613,10 @@ plaininstr :: { PlainInstr }
     | 'f32.load' memarg4             { F32Load $2 }
     | 'f64.load' memarg8             { F64Load $2 }
     | 'v128.load' memarg16           { V128Load $2 }
+    | 'v128.load8_lane' memarg1 lane_index  { V128Load8Lane $2 $3 }
+    | 'v128.load16_lane' memarg2 lane_index { V128Load16Lane $2 $3 }
+    | 'v128.load32_lane' memarg4 lane_index { V128Load32Lane $2 $3 }
+    | 'v128.load64_lane' memarg8 lane_index { V128Load64Lane $2 $3 }
     | 'v128.load8_splat' memarg1     { V128Load8Splat $2 }
     | 'v128.load16_splat' memarg2    { V128Load16Splat $2 }
     | 'v128.load32_splat' memarg4    { V128Load32Splat $2 }
@@ -1493,6 +1501,10 @@ data PlainInstr =
     | F32Load MemArg
     | F64Load MemArg
     | V128Load MemArg
+    | V128Load8Lane MemArg Natural
+    | V128Load16Lane MemArg Natural
+    | V128Load32Lane MemArg Natural
+    | V128Load64Lane MemArg Natural
     | V128Load8Splat MemArg
     | V128Load16Splat MemArg
     | V128Load32Splat MemArg
@@ -2029,6 +2041,10 @@ desugarize fields = do
         synInstrToStruct _ (PlainInstr (F32Load memArg)) = return $ S.F32Load memArg
         synInstrToStruct _ (PlainInstr (F64Load memArg)) = return $ S.F64Load memArg
         synInstrToStruct _ (PlainInstr (V128Load memArg)) = return $ S.V128Load memArg
+        synInstrToStruct _ (PlainInstr (V128Load8Lane memArg idx)) = return $ S.V128Load8Lane memArg idx
+        synInstrToStruct _ (PlainInstr (V128Load16Lane memArg idx)) = return $ S.V128Load16Lane memArg idx
+        synInstrToStruct _ (PlainInstr (V128Load32Lane memArg idx)) = return $ S.V128Load32Lane memArg idx
+        synInstrToStruct _ (PlainInstr (V128Load64Lane memArg idx)) = return $ S.V128Load64Lane memArg idx
         synInstrToStruct _ (PlainInstr (V128Load8Splat memArg)) = return $ S.V128Load8Splat memArg
         synInstrToStruct _ (PlainInstr (V128Load16Splat memArg)) = return $ S.V128Load16Splat memArg
         synInstrToStruct _ (PlainInstr (V128Load32Splat memArg)) = return $ S.V128Load32Splat memArg

src/Language/Wasm/Structure.hs

@@ -167,6 +167,10 @@ data Instruction index =
     | F32Load MemArg
     | F64Load MemArg
     | V128Load MemArg
+    | V128Load8Lane MemArg Natural
+    | V128Load16Lane MemArg Natural
+    | V128Load32Lane MemArg Natural
+    | V128Load64Lane MemArg Natural
     | V128Load8Splat MemArg
     | V128Load16Splat MemArg
     | V128Load32Splat MemArg

src/Language/Wasm/Validate.hs

@@ -340,6 +340,22 @@ getInstrType _ (F64Load memarg) = do
 getInstrType _ (V128Load memarg) = do
     checkMemoryInstr 16 memarg
     return $ I32 ==> V128
+getInstrType _ (V128Load8Lane memarg idx) = do
+    checkMemoryInstr 1 memarg
+    when (idx >= 16) $ throwError LaneIndexOutOfRange
+    return $ [I32, V128] ==> V128
+getInstrType _ (V128Load16Lane memarg idx) = do
+    checkMemoryInstr 2 memarg
+    when (idx >= 8) $ throwError LaneIndexOutOfRange
+    return $ [I32, V128] ==> V128
+getInstrType _ (V128Load32Lane memarg idx) = do
+    checkMemoryInstr 4 memarg
+    when (idx >= 4) $ throwError LaneIndexOutOfRange
+    return $ [I32, V128] ==> V128
+getInstrType _ (V128Load64Lane memarg idx) = do
+    checkMemoryInstr 8 memarg
+    when (idx >= 2) $ throwError LaneIndexOutOfRange
+    return $ [I32, V128] ==> V128
 getInstrType _ (V128Load8Splat memarg) = do
     checkMemoryInstr 1 memarg
     return $ I32 ==> V128

tests/Test.hs

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