diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index 1a7d830..e86980c 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/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 - let MemoryInstance { memory = memoryRef } = memInstances store ! (memaddrs moduleInstance ! 0) - memory <- readIORef memoryRef - 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 (V128Load MemArg { offset }) = + loadByteArray ctx offset 16 $ \rest arr -> + Done ctx { stack = VV128 arr : 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 }) = diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index e0185fe..c514062 100644 --- a/src/Language/Wasm/Parser.y +++ b/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 diff --git a/src/Language/Wasm/Structure.hs b/src/Language/Wasm/Structure.hs index a0c9161..f14dd48 100644 --- a/src/Language/Wasm/Structure.hs +++ b/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 diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index 31a8622..5777dd0 100644 --- a/src/Language/Wasm/Validate.hs +++ b/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 diff --git a/tests/Test.hs b/tests/Test.hs index 0c21098..361bd56 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_load_extend.wast"] + -- let files = ["simd_load_extend.wast"] scriptTestCases <- (`mapM` files) $ \file -> do test <- LBS.readFile ("tests/spec/" ++ file) return $ testCase file $ do