msyds/haskell-wasm
1
0
Fork 0
forked from GitHub/haskell-wasm
Code Pull Requests Activity

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

Browse Source
This commit is contained in:
Ilya Rezvov
2023-09-08 18:34:55 -06:00
parent 3944bf9113
commit 6bb5ea841c
5 changed files with 70 additions and 6 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Interpreter.hs
+33 -5
View File
@@ -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
src/Language/Wasm/Parser.y
+16
View File
@@ -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
+4
View File
@@ -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
+16
View File
@@ -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
+1 -1
View File
@@ -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