diff --git a/src/Language/Wasm/Interpreter.hs b/src/Language/Wasm/Interpreter.hs index 6b023e9..7bd6705 100644 --- a/src/Language/Wasm/Interpreter.hs +++ b/src/Language/Wasm/Interpreter.hs @@ -67,6 +67,8 @@ import Language.Wasm.FloatUtils ( doubleToWord ) +import Debug.Trace as Debug + data Value = VI32 Word32 | VI64 Word64 @@ -169,7 +171,7 @@ type Address = Int type TableStore = IOVector (Maybe Address) data TableInstance = TableInstance { - lim :: Limit, + t :: TableType, items :: TableStore } @@ -422,7 +424,7 @@ calcInstance (Store fs ts ms gs es ds) imps mod = do tableAddr <- case idx of ExternTable tableAddr -> return tableAddr _ -> throwError "incompatible import type" - let TableInstance { lim } = ts ! tableAddr + let TableInstance { t = TableType lim _ } = ts ! tableAddr if limitMatch lim limit then return idx else throwError "incompatible import type" @@ -480,9 +482,9 @@ allocTables :: [Table] -> IO (Vector TableInstance) allocTables = fmap Vector.fromList . mapM allocTable where allocTable :: Table -> IO TableInstance - allocTable (Table (TableType lim@(Limit from to) _)) = + allocTable (Table t@(TableType lim@(Limit from to) _)) = let elements = MVector.replicate (fromIntegral from) Nothing in - TableInstance lim <$> elements + TableInstance t <$> elements defaultBudget :: Natural defaultBudget = 300 @@ -641,6 +643,8 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function { checkValType I64 (VI64 v) = Just $ VI64 v checkValType F32 (VF32 v) = Just $ VF32 v checkValType F64 (VF64 v) = Just $ VF64 v + checkValType Func (RF v) = Just $ RF v + checkValType Extern (RE v) = Just $ RE v checkValType _ _ = Nothing initLocal :: ValueType -> Value @@ -920,6 +924,29 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function { Vector.iforM_ (Vector.slice src len refs) $ \idx (RF fn) -> MVector.unsafeWrite items (dst + idx) (fromIntegral <$> fn) return $ Done ctx { stack = rest } + step ctx@EvalCtx{ stack = (ref:VI32 offset:rest) } (TableSet tableIdx) = do + let tableAddr = tableaddrs moduleInstance ! fromIntegral tableIdx + let TableInstance { items } = tableInstances store ! tableAddr + let dst = fromIntegral offset + let val = case ref of + RE extRef -> extRef + RF fnRef -> fnRef + v -> error "Impossible due to validation" + if dst > MVector.length items + then return Trap + else do + MVector.unsafeWrite items dst (fromIntegral <$> val) + return $ Done ctx { stack = rest } + step ctx@EvalCtx{ stack = (VI32 offset:rest) } (TableGet tableIdx) = do + let tableAddr = tableaddrs moduleInstance ! fromIntegral tableIdx + let TableInstance { t = TableType _ et, items } = tableInstances store ! tableAddr + let dst = fromIntegral offset + if dst > MVector.length items + then return Trap + else do + v <- MVector.unsafeRead items dst + let val = (case et of {FuncRef -> RF; ExternRef -> RE}) (fromIntegral <$> v) + return $ Done ctx { stack = val : rest } step ctx (I32Const v) = return $ Done ctx { stack = VI32 v : stack ctx } step ctx (I64Const v) = return $ Done ctx { stack = VI64 v : stack ctx } step ctx (F32Const v) = return $ Done ctx { stack = VF32 v : stack ctx } diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index e9aad36..076d5d9 100644 --- a/src/Language/Wasm/Parser.y +++ b/src/Language/Wasm/Parser.y @@ -133,6 +133,7 @@ import Language.Wasm.Lexer ( 'ref.null' { Lexeme _ (TKeyword "ref.null") } 'ref.is_null' { Lexeme _ (TKeyword "ref.is_null") } 'ref.func' { Lexeme _ (TKeyword "ref.func") } +'ref.extern' { Lexeme _ (TKeyword "ref.extern") } 'drop' { Lexeme _ (TKeyword "drop") } 'select' { Lexeme _ (TKeyword "select") } 'get_local' { Lexeme _ (TKeyword "local.get") } @@ -438,6 +439,7 @@ plaininstr :: { PlainInstr } | 'ref.null' heaptype { RefNull $2 } | 'ref.is_null' { RefIsNull } | 'ref.func' index { RefFunc $2 } + | 'ref.extern' u32 { RefExtern $2 } -- variable instructions | 'get_local' index { GetLocal $2 } | 'set_local' index { SetLocal $2 } @@ -471,11 +473,13 @@ plaininstr :: { PlainInstr } | 'memory.size' { CurrentMemory } | 'memory.grow' { GrowMemory } -- table instructions - | 'table.init' index opt(index) { + | 'table.init' index opt(index) { case $3 of Nothing -> TableInit (Index 0) $2 Just elemIdx -> TableInit $2 elemIdx } + | 'table.get' index { TableGet $2 } + | 'table.set' index { TableSet $2 } -- numeric instructions | 'i32.const' int32 { I32Const $2 } | 'i64.const' int64 { I64Const $2 } @@ -1184,6 +1188,7 @@ data PlainInstr = | RefNull ElemType | RefIsNull | RefFunc FuncIndex + | RefExtern Natural -- Parametric instructions | Drop | Select @@ -1460,6 +1465,7 @@ constInstructionToValue (PlainInstr (F32Const v)) = S.F32Const v constInstructionToValue (PlainInstr (I64Const v)) = S.I64Const $ integerToWord64 v constInstructionToValue (PlainInstr (F64Const v)) = S.F64Const v constInstructionToValue (PlainInstr (RefNull et)) = S.RefNull et +constInstructionToValue (PlainInstr (RefExtern n)) = S.RefExtern n constInstructionToValue _ = error "Only const instructions supported as arguments for actions" funcIndexToExpr :: [FuncIndex] -> [[Instruction]] @@ -1653,6 +1659,8 @@ desugarize fields = do case getFuncIndex ctxMod funIdx of Just idx -> return $ S.RefFunc idx Nothing -> Left "unknown function" + synInstrToStruct FunCtx { ctxMod } (PlainInstr (RefExtern idx)) = + return $ S.RefExtern idx synInstrToStruct ctx (PlainInstr (GetLocal localIdx)) = case getLocalIndex ctx localIdx of Just idx -> return $ S.GetLocal idx @@ -1705,6 +1713,14 @@ desugarize fields = do Just elemIdx -> return $ S.TableInit tableIdx elemIdx Nothing -> Left "unknown elem" Nothing -> Left "unknown table" + synInstrToStruct FunCtx { ctxMod } (PlainInstr (TableSet tableIdx)) = + case getTableIndex ctxMod tableIdx of + Just tableIdx -> return $ S.TableSet tableIdx + Nothing -> Left "unknown table" + synInstrToStruct FunCtx { ctxMod } (PlainInstr (TableGet tableIdx)) = + case getTableIndex ctxMod tableIdx of + Just tableIdx -> return $ S.TableGet tableIdx + Nothing -> Left "unknown table" synInstrToStruct _ (PlainInstr (I32Const val)) = return $ S.I32Const $ integerToWord32 val synInstrToStruct _ (PlainInstr (I64Const val)) = return $ S.I64Const $ integerToWord64 val synInstrToStruct _ (PlainInstr (F32Const val)) = return $ S.F32Const val diff --git a/src/Language/Wasm/Script.hs b/src/Language/Wasm/Script.hs index a4ce926..fb895a5 100644 --- a/src/Language/Wasm/Script.hs +++ b/src/Language/Wasm/Script.hs @@ -124,7 +124,8 @@ runScript onAssertFail script = do asArg [Struct.F64Const v] = Interpreter.VF64 v asArg [Struct.RefNull Struct.FuncRef] = Interpreter.RF Nothing asArg [Struct.RefNull Struct.ExternRef] = Interpreter.RE Nothing - asArg _ = error "Only const instructions supported as arguments for actions" + asArg [Struct.RefExtern v] = Interpreter.RE (Just v) + asArg expr = error $ "Only const instructions supported as arguments for actions: " ++ show expr runAction :: ScriptState -> Action -> IO (Maybe [Interpreter.Value]) runAction st (Invoke ident name args) = do @@ -176,7 +177,6 @@ runScript onAssertFail script = do getFailureString (Validate.RefTypeMismatch _ _) = ["type mismatch"] getFailureString Validate.ResultTypeDoesntMatch = ["type mismatch"] getFailureString Validate.MoreThanOneMemory = ["multiple memories"] - getFailureString Validate.MoreThanOneTable = ["multiple tables"] getFailureString (Validate.LocalIndexOutOfRange idx) = ["unknown local", "unknown local " <> TL.pack (show idx)] getFailureString (Validate.MemoryIndexOutOfRange idx) = ["unknown memory", "unknown memory " <> TL.pack (show idx)] getFailureString (Validate.TableIndexOutOfRange idx) = ["unknown table", "unknown table " <> TL.pack (show idx)] diff --git a/src/Language/Wasm/Structure.hs b/src/Language/Wasm/Structure.hs index 4a7e7d9..a49cf9e 100644 --- a/src/Language/Wasm/Structure.hs +++ b/src/Language/Wasm/Structure.hs @@ -142,6 +142,7 @@ data Instruction index = | RefNull ElemType | RefIsNull | RefFunc index + | RefExtern Natural -- Parametric instructions | Drop | Select diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index 6ef2824..f8e60cd 100644 --- a/src/Language/Wasm/Validate.hs +++ b/src/Language/Wasm/Validate.hs @@ -32,7 +32,6 @@ data ValidationError = | MemoryLimitExceeded | AlignmentOverflow | MoreThanOneMemory - | MoreThanOneTable | FunctionIndexOutOfRange | TableIndexOutOfRange Natural | MemoryIndexOutOfRange Natural @@ -200,6 +199,10 @@ getResultType (TypeIndex typeIdx) = do Ctx { types } <- ask maybeToEither TypeIndexOutOfRange $ results <$> types !? typeIdx +elemTypeToRefType :: ElemType -> ValueType +elemTypeToRefType FuncRef = Func +elemTypeToRefType ExternRef = Extern + getInstrType :: Instruction Natural -> Checker Arrow getInstrType Unreachable = return $ Any ==> Any getInstrType Nop = return $ empty ==> empty @@ -265,7 +268,8 @@ getInstrType (RefNull elType) = do let t = case elType of { FuncRef -> Func; ExternRef -> Extern } return $ empty ==> Val t getInstrType RefIsNull = do - return $ empty ==> Val I32 + var <- freshVar + return $ var ==> Val I32 getInstrType (RefFunc funIdx) = do Ctx { funcs } <- ask if fromIntegral funIdx < length funcs @@ -375,6 +379,16 @@ getInstrType (TableInit tableIdx elemIdx) = do let elemType = elems !! fromIntegral elemIdx when (elemType /= tableType) $ throwError (RefTypeMismatch tableType elemType) return $ [I32, I32, I32] ==> empty +getInstrType (TableGet tableIdx) = do + Ctx { tables } <- ask + when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx) + let TableType _ tableType = tables !! fromIntegral tableIdx + return $ I32 ==> (elemTypeToRefType tableType) +getInstrType (TableSet tableIdx) = do + Ctx { tables } <- ask + when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx) + let TableType _ tableType = tables !! fromIntegral tableIdx + return $ [I32, elemTypeToRefType tableType] ==> empty getInstrType (I32Const _) = return $ empty ==> I32 getInstrType (I64Const _) = return $ empty ==> I64 getInstrType (F32Const _) = return $ empty ==> F32 @@ -533,10 +547,7 @@ tablesShouldBeValid :: Validator tablesShouldBeValid Module { imports, tables } = let tableImports = filter isTableImport imports in let res = foldMap (\Import { desc = ImportTable t } -> isValidTableType t) tableImports in - let res' = foldl' (\r (Table t) -> r <> isValidTableType t) res tables in - if length tableImports + length tables <= 1 - then res' - else Left MoreThanOneTable + foldl' (\r (Table t) -> r <> isValidTableType t) res tables where isValidTableType :: TableType -> ValidationResult isValidTableType (TableType (Limit min max) _) = diff --git a/tests/Test.hs b/tests/Test.hs index c4411b2..a8727a9 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -17,8 +17,7 @@ import qualified Data.List as List main :: IO () main = do files <- filter (List.isSuffixOf ".wast") <$> Directory.listDirectory "tests/spec" - -- let files = ["ref_null.wast", "ref_is_null.wast"] - let files = ["elem.wast"] + let files = ["ref_is_null.wast"] scriptTestCases <- (`mapM` files) $ \file -> do test <- LBS.readFile ("tests/spec/" ++ file) return $ testCase file $ do