diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index c156a27..60585a4 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/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 - makeLoadInstr ctx@EvalCtx{ stack = (VI32 v:rest) } offset byteWidth cont = do + makeLoadInstrIO :: (Primitive.Prim i, Bits i, Integral i) => EvalCtx -> Natural -> Int -> ([Value] -> i -> IO EvalResult) -> IO EvalResult + 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) - else cont rest . sum <$> mapM readByte [0..byteWidth-1] + then do + 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 diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index 30b5892..6e63017 100644 --- a/src/Language/Wasm/Parser.y +++ b/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 diff --git a/src/Language/Wasm/Structure.hs b/src/Language/Wasm/Structure.hs index 6a7b0a9..47a4ed8 100644 --- a/src/Language/Wasm/Structure.hs +++ b/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 diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index a953080..2a301f5 100644 --- a/src/Language/Wasm/Validate.hs +++ b/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 diff --git a/tests/Test.hs b/tests/Test.hs index becfcf6..e64cf15 100644 --- a/tests/Test.hs +++ b/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