GitHub/haskell-wasm
1
0
Fork 1
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

all tests are green

Browse Source
This commit is contained in:
Ilya Rezvov
2023-08-21 21:11:14 -06:00
parent a5ffe38a1c
commit f2f5fcc56f
2 changed files with 158 additions and 152 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Validate.hs
+157 -151
View File
@@ -219,24 +219,24 @@ elemTypeToRefType :: ElemType -> ValueType
elemTypeToRefType FuncRef = Func elemTypeToRefType FuncRef = Func
elemTypeToRefType ExternRef = Extern elemTypeToRefType ExternRef = Extern
getInstrType :: Instruction Natural -> Checker Arrow getInstrType :: [VType] -> Instruction Natural -> Checker Arrow
getInstrType Unreachable = return $ Any ==> Any getInstrType _ Unreachable = return $ Any ==> Any
getInstrType Nop = return $ empty ==> empty getInstrType _ Nop = return $ empty ==> empty
getInstrType Block { blockType, body } = do getInstrType _ Block { blockType, body } = do
bt@(Arrow from _) <- getBlockType blockType bt@(Arrow from _) <- getBlockType blockType
resultType <- getResultType blockType resultType <- getResultType blockType
t <- withLabel resultType $ getExpressionTypeWithInput from body t <- withLabel resultType $ getExpressionTypeWithInput from body
if isArrowMatch t bt if isArrowMatch t bt
then return bt then return bt
else throwError $ TypeMismatch t bt else throwError $ TypeMismatch t bt
getInstrType Loop { blockType, body } = do getInstrType _ Loop { blockType, body } = do
bt@(Arrow from _) <- getBlockType blockType bt@(Arrow from _) <- getBlockType blockType
resultType <- getResultType blockType resultType <- getResultType blockType
t <- withLabel (map (\(Val v) -> v) from) $ getExpressionTypeWithInput from body t <- withLabel (map (\(Val v) -> v) from) $ getExpressionTypeWithInput from body
if isArrowMatch t bt if isArrowMatch t bt
then return bt then return bt
else throwError $ TypeMismatch t bt else throwError $ TypeMismatch t bt
getInstrType If { blockType, true, false } = do getInstrType _ If { blockType, true, false } = do
bt@(Arrow from _) <- getBlockType blockType bt@(Arrow from _) <- getBlockType blockType
resultType <- getResultType blockType resultType <- getResultType blockType
l <- withLabel resultType $ getExpressionTypeWithInput from true l <- withLabel resultType $ getExpressionTypeWithInput from true
@@ -249,48 +249,53 @@ getInstrType If { blockType, true, false } = do
else (throwError $ TypeMismatch r bt) else (throwError $ TypeMismatch r bt)
) )
else throwError $ TypeMismatch l bt else throwError $ TypeMismatch l bt
getInstrType (Br lbl) = do getInstrType _ (Br lbl) = do
r <- map Val <$> getLabel lbl r <- map Val <$> getLabel lbl
return $ (Any : r) ==> Any return $ (Any : r) ==> Any
getInstrType (BrIf lbl) = do getInstrType _ (BrIf lbl) = do
r <- map Val <$> getLabel lbl r <- map Val <$> getLabel lbl
return $ (r ++ [Val I32]) ==> r return $ (r ++ [Val I32]) ==> r
getInstrType (BrTable lbls lbl) = do getInstrType stack (BrTable lbls lbl) = do
r <- getLabel lbl r <- getLabel lbl
rs <- mapM getLabel lbls let returns lbl = do
if all (== r) rs args <- map Val <$> getLabel lbl
res <- matchStack stack (Val I32 : reverse args) []
return (args, res)
alternatives <- mapM returns lbls
(_, def) <- returns lbl
if all (\(args, res) -> res == def && length args == length r) alternatives
then return $ ([Any] ++ (map Val r) ++ [Val I32]) ==> Any then return $ ([Any] ++ (map Val r) ++ [Val I32]) ==> Any
else throwError ResultTypeDoesntMatch else throwError ResultTypeDoesntMatch
getInstrType Return = do getInstrType _ Return = do
Ctx { returns } <- ask Ctx { returns } <- ask
return $ (Any : (map Val returns)) ==> Any return $ (Any : (map Val returns)) ==> Any
getInstrType (Call fun) = do getInstrType _ (Call fun) = do
Ctx { funcs } <- ask Ctx { funcs } <- ask
maybeToEither (FunctionIndexOutOfRange fun) $ asArrow <$> funcs !? fun maybeToEither (FunctionIndexOutOfRange fun) $ asArrow <$> funcs !? fun
getInstrType (CallIndirect tableIdx sign) = do getInstrType _ (CallIndirect tableIdx sign) = do
Ctx { types, tables } <- ask Ctx { types, tables } <- ask
if length tables <= fromIntegral tableIdx if length tables <= fromIntegral tableIdx
then throwError (TableIndexOutOfRange tableIdx) then throwError (TableIndexOutOfRange tableIdx)
else do else do
Arrow from to <- maybeToEither TypeIndexOutOfRange $ asArrow <$> types !? sign Arrow from to <- maybeToEither TypeIndexOutOfRange $ asArrow <$> types !? sign
return $ (from ++ [Val I32]) ==> to return $ (from ++ [Val I32]) ==> to
getInstrType Drop = do getInstrType _ Drop = do
var <- freshVar var <- freshVar
return $ var ==> empty return $ var ==> empty
getInstrType (Select Nothing) = do getInstrType _ (Select Nothing) = do
var <- return NonRefVar var <- return NonRefVar
return $ [var, var, Val I32] ==> var return $ [var, var, Val I32] ==> var
getInstrType (Select (Just vt)) = getInstrType _ (Select (Just vt)) =
case vt of case vt of
[t] -> return $ [t, t, I32] ==> t [t] -> return $ [t, t, I32] ==> t
_ -> throwError InvalidResultArity _ -> throwError InvalidResultArity
getInstrType (RefNull elType) = do getInstrType _ (RefNull elType) = do
let t = case elType of { FuncRef -> Func; ExternRef -> Extern } let t = case elType of { FuncRef -> Func; ExternRef -> Extern }
return $ empty ==> Val t return $ empty ==> Val t
getInstrType RefIsNull = do getInstrType _ RefIsNull = do
var <- freshVar var <- freshVar
return $ var ==> Val I32 return $ var ==> Val I32
getInstrType (RefFunc funIdx) = do getInstrType _ (RefFunc funIdx) = do
Ctx { funcs, refs } <- ask Ctx { funcs, refs } <- ask
if fromIntegral funIdx < length funcs if fromIntegral funIdx < length funcs
then do then do
@@ -298,122 +303,122 @@ getInstrType (RefFunc funIdx) = do
throwError $ UndeclaredFunctionRef $ fromIntegral funIdx throwError $ UndeclaredFunctionRef $ fromIntegral funIdx
return $ empty ==> Val Func return $ empty ==> Val Func
else throwError $ FunctionIndexOutOfRange $ fromIntegral funIdx else throwError $ FunctionIndexOutOfRange $ fromIntegral funIdx
getInstrType (GetLocal local) = do getInstrType _ (GetLocal local) = do
Ctx { locals } <- ask Ctx { locals } <- ask
t <- maybeToEither (LocalIndexOutOfRange local) $ locals !? local t <- maybeToEither (LocalIndexOutOfRange local) $ locals !? local
return $ empty ==> Val t return $ empty ==> Val t
getInstrType (SetLocal local) = do getInstrType _ (SetLocal local) = do
Ctx { locals } <- ask Ctx { locals } <- ask
t <- maybeToEither (LocalIndexOutOfRange local) $ locals !? local t <- maybeToEither (LocalIndexOutOfRange local) $ locals !? local
return $ Val t ==> empty return $ Val t ==> empty
getInstrType (TeeLocal local) = do getInstrType _ (TeeLocal local) = do
Ctx { locals } <- ask Ctx { locals } <- ask
t <- maybeToEither (LocalIndexOutOfRange local) $ locals !? local t <- maybeToEither (LocalIndexOutOfRange local) $ locals !? local
return $ Val t ==> Val t return $ Val t ==> Val t
getInstrType (GetGlobal global) = do getInstrType _ (GetGlobal global) = do
Ctx { globals } <- ask Ctx { globals } <- ask
t <- maybeToEither (GlobalIndexOutOfRange global) $ asType <$> globals !? global t <- maybeToEither (GlobalIndexOutOfRange global) $ asType <$> globals !? global
return $ empty ==> t return $ empty ==> t
getInstrType (SetGlobal global) = do getInstrType _ (SetGlobal global) = do
Ctx { globals } <- ask Ctx { globals } <- ask
t <- maybeToEither (GlobalIndexOutOfRange global) $ asType <$> globals !? global t <- maybeToEither (GlobalIndexOutOfRange global) $ asType <$> globals !? global
shouldBeMut $ globals !! fromIntegral global shouldBeMut $ globals !! fromIntegral global
return $ t ==> empty return $ t ==> empty
getInstrType (I32Load memarg) = do getInstrType _ (I32Load memarg) = do
checkMemoryInstr 4 memarg checkMemoryInstr 4 memarg
return $ I32 ==> I32 return $ I32 ==> I32
getInstrType (I64Load memarg) = do getInstrType _ (I64Load memarg) = do
checkMemoryInstr 8 memarg checkMemoryInstr 8 memarg
return $ I32 ==> I64 return $ I32 ==> I64
getInstrType (F32Load memarg) = do getInstrType _ (F32Load memarg) = do
checkMemoryInstr 4 memarg checkMemoryInstr 4 memarg
return $ I32 ==> F32 return $ I32 ==> F32
getInstrType (F64Load memarg) = do getInstrType _ (F64Load memarg) = do
checkMemoryInstr 8 memarg checkMemoryInstr 8 memarg
return $ I32 ==> F64 return $ I32 ==> F64
getInstrType (I32Load8S memarg) = do getInstrType _ (I32Load8S memarg) = do
checkMemoryInstr 1 memarg checkMemoryInstr 1 memarg
return $ I32 ==> I32 return $ I32 ==> I32
getInstrType (I32Load8U memarg) = do getInstrType _ (I32Load8U memarg) = do
checkMemoryInstr 1 memarg checkMemoryInstr 1 memarg
return $ I32 ==> I32 return $ I32 ==> I32
getInstrType (I32Load16S memarg) = do getInstrType _ (I32Load16S memarg) = do
checkMemoryInstr 2 memarg checkMemoryInstr 2 memarg
return $ I32 ==> I32 return $ I32 ==> I32
getInstrType (I32Load16U memarg) = do getInstrType _ (I32Load16U memarg) = do
checkMemoryInstr 2 memarg checkMemoryInstr 2 memarg
return $ I32 ==> I32 return $ I32 ==> I32
getInstrType (I64Load8S memarg) = do getInstrType _ (I64Load8S memarg) = do
checkMemoryInstr 1 memarg checkMemoryInstr 1 memarg
return $ I32 ==> I64 return $ I32 ==> I64
getInstrType (I64Load8U memarg) = do getInstrType _ (I64Load8U memarg) = do
checkMemoryInstr 1 memarg checkMemoryInstr 1 memarg
return $ I32 ==> I64 return $ I32 ==> I64
getInstrType (I64Load16S memarg) = do getInstrType _ (I64Load16S memarg) = do
checkMemoryInstr 2 memarg checkMemoryInstr 2 memarg
return $ I32 ==> I64 return $ I32 ==> I64
getInstrType (I64Load16U memarg) = do getInstrType _ (I64Load16U memarg) = do
checkMemoryInstr 2 memarg checkMemoryInstr 2 memarg
return $ I32 ==> I64 return $ I32 ==> I64
getInstrType (I64Load32S memarg) = do getInstrType _ (I64Load32S memarg) = do
checkMemoryInstr 4 memarg checkMemoryInstr 4 memarg
return $ I32 ==> I64 return $ I32 ==> I64
getInstrType (I64Load32U memarg) = do getInstrType _ (I64Load32U memarg) = do
checkMemoryInstr 4 memarg checkMemoryInstr 4 memarg
return $ I32 ==> I64 return $ I32 ==> I64
getInstrType (I32Store memarg) = do getInstrType _ (I32Store memarg) = do
checkMemoryInstr 4 memarg checkMemoryInstr 4 memarg
return $ [I32, I32] ==> empty return $ [I32, I32] ==> empty
getInstrType (I64Store memarg) = do getInstrType _ (I64Store memarg) = do
checkMemoryInstr 8 memarg checkMemoryInstr 8 memarg
return $ [I32, I64] ==> empty return $ [I32, I64] ==> empty
getInstrType (F32Store memarg) = do getInstrType _ (F32Store memarg) = do
checkMemoryInstr 4 memarg checkMemoryInstr 4 memarg
return $ [I32, F32] ==> empty return $ [I32, F32] ==> empty
getInstrType (F64Store memarg) = do getInstrType _ (F64Store memarg) = do
checkMemoryInstr 8 memarg checkMemoryInstr 8 memarg
return $ [I32, F64] ==> empty return $ [I32, F64] ==> empty
getInstrType (I32Store8 memarg) = do getInstrType _ (I32Store8 memarg) = do
checkMemoryInstr 1 memarg checkMemoryInstr 1 memarg
return $ [I32, I32] ==> empty return $ [I32, I32] ==> empty
getInstrType (I32Store16 memarg) = do getInstrType _ (I32Store16 memarg) = do
checkMemoryInstr 2 memarg checkMemoryInstr 2 memarg
return $ [I32, I32] ==> empty return $ [I32, I32] ==> empty
getInstrType (I64Store8 memarg) = do getInstrType _ (I64Store8 memarg) = do
checkMemoryInstr 1 memarg checkMemoryInstr 1 memarg
return $ [I32, I64] ==> empty return $ [I32, I64] ==> empty
getInstrType (I64Store16 memarg) = do getInstrType _ (I64Store16 memarg) = do
checkMemoryInstr 2 memarg checkMemoryInstr 2 memarg
return $ [I32, I64] ==> empty return $ [I32, I64] ==> empty
getInstrType (I64Store32 memarg) = do getInstrType _ (I64Store32 memarg) = do
checkMemoryInstr 4 memarg checkMemoryInstr 4 memarg
return $ [I32, I64] ==> empty return $ [I32, I64] ==> empty
getInstrType MemorySize = do getInstrType _ MemorySize = do
Ctx { mems } <- ask Ctx { mems } <- ask
when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0) when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0)
return $ empty ==> I32 return $ empty ==> I32
getInstrType MemoryGrow = do getInstrType _ MemoryGrow = do
Ctx { mems } <- ask Ctx { mems } <- ask
when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0) when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0)
return $ I32 ==> I32 return $ I32 ==> I32
getInstrType MemoryFill = do getInstrType _ MemoryFill = do
Ctx { mems } <- ask Ctx { mems } <- ask
when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0) when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0)
return $ [I32, I32, I32] ==> empty return $ [I32, I32, I32] ==> empty
getInstrType MemoryCopy = do getInstrType _ MemoryCopy = do
Ctx { mems } <- ask Ctx { mems } <- ask
when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0) when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0)
return $ [I32, I32, I32] ==> empty return $ [I32, I32, I32] ==> empty
getInstrType (MemoryInit dataIdx) = do getInstrType _ (MemoryInit dataIdx) = do
Ctx { mems, datas } <- ask Ctx { mems, datas } <- ask
when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0) when (length mems < 1) $ throwError (MemoryIndexOutOfRange 0)
when (length datas <= fromIntegral dataIdx) $ throwError (DataIndexOutOfRange dataIdx) when (length datas <= fromIntegral dataIdx) $ throwError (DataIndexOutOfRange dataIdx)
return $ [I32, I32, I32] ==> empty return $ [I32, I32, I32] ==> empty
getInstrType (DataDrop dataIdx) = do getInstrType _ (DataDrop dataIdx) = do
Ctx { datas } <- ask Ctx { datas } <- ask
when (length datas <= fromIntegral dataIdx) $ throwError (DataIndexOutOfRange dataIdx) when (length datas <= fromIntegral dataIdx) $ throwError (DataIndexOutOfRange dataIdx)
return $ empty ==> empty return $ empty ==> empty
getInstrType (TableInit tableIdx elemIdx) = do getInstrType _ (TableInit tableIdx elemIdx) = do
Ctx { tables, elems } <- ask Ctx { tables, elems } <- ask
when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx) when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
when (length elems <= fromIntegral elemIdx) $ throwError (ElemIndexOutOfRange elemIdx) when (length elems <= fromIntegral elemIdx) $ throwError (ElemIndexOutOfRange elemIdx)
@@ -421,7 +426,7 @@ getInstrType (TableInit tableIdx elemIdx) = do
let elemType = elems !! fromIntegral elemIdx let elemType = elems !! fromIntegral elemIdx
when (elemType /= tableType) $ throwError (RefTypeMismatch tableType elemType) when (elemType /= tableType) $ throwError (RefTypeMismatch tableType elemType)
return $ [I32, I32, I32] ==> empty return $ [I32, I32, I32] ==> empty
getInstrType (TableCopy toIdx fromIdx) = do getInstrType _ (TableCopy toIdx fromIdx) = do
Ctx { tables } <- ask Ctx { tables } <- ask
let (from, to) = (fromIntegral fromIdx, fromIntegral toIdx) let (from, to) = (fromIntegral fromIdx, fromIntegral toIdx)
when (length tables <= from) $ throwError (TableIndexOutOfRange fromIdx) when (length tables <= from) $ throwError (TableIndexOutOfRange fromIdx)
@@ -430,85 +435,85 @@ getInstrType (TableCopy toIdx fromIdx) = do
let TableType _ toType = tables !! to let TableType _ toType = tables !! to
when (fromType /= toType) $ throwError (RefTypeMismatch fromType toType) when (fromType /= toType) $ throwError (RefTypeMismatch fromType toType)
return $ [I32, I32, I32] ==> empty return $ [I32, I32, I32] ==> empty
getInstrType (TableFill tableIdx) = do getInstrType _ (TableFill tableIdx) = do
Ctx { tables } <- ask Ctx { tables } <- ask
when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx) when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
let TableType _ tableType = tables !! fromIntegral tableIdx let TableType _ tableType = tables !! fromIntegral tableIdx
return $ [I32, elemTypeToRefType tableType, I32] ==> empty return $ [I32, elemTypeToRefType tableType, I32] ==> empty
getInstrType (TableSize tableIdx) = do getInstrType _ (TableSize tableIdx) = do
Ctx { tables } <- ask Ctx { tables } <- ask
when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx) when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
return $ empty ==> I32 return $ empty ==> I32
getInstrType (TableGrow tableIdx) = do getInstrType _ (TableGrow tableIdx) = do
Ctx { tables } <- ask Ctx { tables } <- ask
when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx) when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
let TableType _ tableType = tables !! fromIntegral tableIdx let TableType _ tableType = tables !! fromIntegral tableIdx
return $ [elemTypeToRefType tableType, I32] ==> I32 return $ [elemTypeToRefType tableType, I32] ==> I32
getInstrType (TableGet tableIdx) = do getInstrType _ (TableGet tableIdx) = do
Ctx { tables } <- ask Ctx { tables } <- ask
when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx) when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
let TableType _ tableType = tables !! fromIntegral tableIdx let TableType _ tableType = tables !! fromIntegral tableIdx
return $ I32 ==> (elemTypeToRefType tableType) return $ I32 ==> (elemTypeToRefType tableType)
getInstrType (TableSet tableIdx) = do getInstrType _ (TableSet tableIdx) = do
Ctx { tables } <- ask Ctx { tables } <- ask
when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx) when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
let TableType _ tableType = tables !! fromIntegral tableIdx let TableType _ tableType = tables !! fromIntegral tableIdx
return $ [I32, elemTypeToRefType tableType] ==> empty return $ [I32, elemTypeToRefType tableType] ==> empty
getInstrType (ElemDrop elemIdx) = do getInstrType _ (ElemDrop elemIdx) = do
Ctx { elems } <- ask Ctx { elems } <- ask
when (length elems <= fromIntegral elemIdx) $ throwError (ElemIndexOutOfRange elemIdx) when (length elems <= fromIntegral elemIdx) $ throwError (ElemIndexOutOfRange elemIdx)
return $ empty ==> empty return $ empty ==> empty
getInstrType (I32Const _) = return $ empty ==> I32 getInstrType _ (I32Const _) = return $ empty ==> I32
getInstrType (I64Const _) = return $ empty ==> I64 getInstrType _ (I64Const _) = return $ empty ==> I64
getInstrType (F32Const _) = return $ empty ==> F32 getInstrType _ (F32Const _) = return $ empty ==> F32
getInstrType (F64Const _) = return $ empty ==> F64 getInstrType _ (F64Const _) = return $ empty ==> F64
getInstrType (IUnOp BS32 _) = return $ I32 ==> I32 getInstrType _ (IUnOp BS32 _) = return $ I32 ==> I32
getInstrType (IUnOp BS64 _) = return $ I64 ==> I64 getInstrType _ (IUnOp BS64 _) = return $ I64 ==> I64
getInstrType (IBinOp BS32 _) = return $ [I32, I32] ==> I32 getInstrType _ (IBinOp BS32 _) = return $ [I32, I32] ==> I32
getInstrType (IBinOp BS64 _) = return $ [I64, I64] ==> I64 getInstrType _ (IBinOp BS64 _) = return $ [I64, I64] ==> I64
getInstrType I32Eqz = return $ I32 ==> I32 getInstrType _ I32Eqz = return $ I32 ==> I32
getInstrType I64Eqz = return $ I64 ==> I32 getInstrType _ I64Eqz = return $ I64 ==> I32
getInstrType (IRelOp BS32 _) = return $ [I32, I32] ==> I32 getInstrType _ (IRelOp BS32 _) = return $ [I32, I32] ==> I32
getInstrType (IRelOp BS64 _) = return $ [I64, I64] ==> I32 getInstrType _ (IRelOp BS64 _) = return $ [I64, I64] ==> I32
getInstrType (FUnOp BS32 _) = return $ F32 ==> F32 getInstrType _ (FUnOp BS32 _) = return $ F32 ==> F32
getInstrType (FUnOp BS64 _) = return $ F64 ==> F64 getInstrType _ (FUnOp BS64 _) = return $ F64 ==> F64
getInstrType (FBinOp BS32 _) = return $ [F32, F32] ==> F32 getInstrType _ (FBinOp BS32 _) = return $ [F32, F32] ==> F32
getInstrType (FBinOp BS64 _) = return $ [F64, F64] ==> F64 getInstrType _ (FBinOp BS64 _) = return $ [F64, F64] ==> F64
getInstrType (FRelOp BS32 _) = return $ [F32, F32] ==> I32 getInstrType _ (FRelOp BS32 _) = return $ [F32, F32] ==> I32
getInstrType (FRelOp BS64 _) = return $ [F64, F64] ==> I32 getInstrType _ (FRelOp BS64 _) = return $ [F64, F64] ==> I32
getInstrType I32WrapI64 = return $ I64 ==> I32 getInstrType _ I32WrapI64 = return $ I64 ==> I32
getInstrType (ITruncFU BS32 BS32) = return $ F32 ==> I32 getInstrType _ (ITruncFU BS32 BS32) = return $ F32 ==> I32
getInstrType (ITruncFU BS32 BS64) = return $ F64 ==> I32 getInstrType _ (ITruncFU BS32 BS64) = return $ F64 ==> I32
getInstrType (ITruncFU BS64 BS32) = return $ F32 ==> I64 getInstrType _ (ITruncFU BS64 BS32) = return $ F32 ==> I64
getInstrType (ITruncFU BS64 BS64) = return $ F64 ==> I64 getInstrType _ (ITruncFU BS64 BS64) = return $ F64 ==> I64
getInstrType (ITruncFS BS32 BS32) = return $ F32 ==> I32 getInstrType _ (ITruncFS BS32 BS32) = return $ F32 ==> I32
getInstrType (ITruncFS BS32 BS64) = return $ F64 ==> I32 getInstrType _ (ITruncFS BS32 BS64) = return $ F64 ==> I32
getInstrType (ITruncFS BS64 BS32) = return $ F32 ==> I64 getInstrType _ (ITruncFS BS64 BS32) = return $ F32 ==> I64
getInstrType (ITruncFS BS64 BS64) = return $ F64 ==> I64 getInstrType _ (ITruncFS BS64 BS64) = return $ F64 ==> I64
getInstrType (ITruncSatFU BS32 BS32) = return $ F32 ==> I32 getInstrType _ (ITruncSatFU BS32 BS32) = return $ F32 ==> I32
getInstrType (ITruncSatFU BS32 BS64) = return $ F64 ==> I32 getInstrType _ (ITruncSatFU BS32 BS64) = return $ F64 ==> I32
getInstrType (ITruncSatFU BS64 BS32) = return $ F32 ==> I64 getInstrType _ (ITruncSatFU BS64 BS32) = return $ F32 ==> I64
getInstrType (ITruncSatFU BS64 BS64) = return $ F64 ==> I64 getInstrType _ (ITruncSatFU BS64 BS64) = return $ F64 ==> I64
getInstrType (ITruncSatFS BS32 BS32) = return $ F32 ==> I32 getInstrType _ (ITruncSatFS BS32 BS32) = return $ F32 ==> I32
getInstrType (ITruncSatFS BS32 BS64) = return $ F64 ==> I32 getInstrType _ (ITruncSatFS BS32 BS64) = return $ F64 ==> I32
getInstrType (ITruncSatFS BS64 BS32) = return $ F32 ==> I64 getInstrType _ (ITruncSatFS BS64 BS32) = return $ F32 ==> I64
getInstrType (ITruncSatFS BS64 BS64) = return $ F64 ==> I64 getInstrType _ (ITruncSatFS BS64 BS64) = return $ F64 ==> I64
getInstrType I64ExtendSI32 = return $ I32 ==> I64 getInstrType _ I64ExtendSI32 = return $ I32 ==> I64
getInstrType I64ExtendUI32 = return $ I32 ==> I64 getInstrType _ I64ExtendUI32 = return $ I32 ==> I64
getInstrType (FConvertIU BS32 BS32) = return $ I32 ==> F32 getInstrType _ (FConvertIU BS32 BS32) = return $ I32 ==> F32
getInstrType (FConvertIU BS32 BS64) = return $ I64 ==> F32 getInstrType _ (FConvertIU BS32 BS64) = return $ I64 ==> F32
getInstrType (FConvertIU BS64 BS32) = return $ I32 ==> F64 getInstrType _ (FConvertIU BS64 BS32) = return $ I32 ==> F64
getInstrType (FConvertIU BS64 BS64) = return $ I64 ==> F64 getInstrType _ (FConvertIU BS64 BS64) = return $ I64 ==> F64
getInstrType (FConvertIS BS32 BS32) = return $ I32 ==> F32 getInstrType _ (FConvertIS BS32 BS32) = return $ I32 ==> F32
getInstrType (FConvertIS BS32 BS64) = return $ I64 ==> F32 getInstrType _ (FConvertIS BS32 BS64) = return $ I64 ==> F32
getInstrType (FConvertIS BS64 BS32) = return $ I32 ==> F64 getInstrType _ (FConvertIS BS64 BS32) = return $ I32 ==> F64
getInstrType (FConvertIS BS64 BS64) = return $ I64 ==> F64 getInstrType _ (FConvertIS BS64 BS64) = return $ I64 ==> F64
getInstrType F32DemoteF64 = return $ F64 ==> F32 getInstrType _ F32DemoteF64 = return $ F64 ==> F32
getInstrType F64PromoteF32 = return $ F32 ==> F64 getInstrType _ F64PromoteF32 = return $ F32 ==> F64
getInstrType (IReinterpretF BS32) = return $ F32 ==> I32 getInstrType _ (IReinterpretF BS32) = return $ F32 ==> I32
getInstrType (IReinterpretF BS64) = return $ F64 ==> I64 getInstrType _ (IReinterpretF BS64) = return $ F64 ==> I64
getInstrType (FReinterpretI BS32) = return $ I32 ==> F32 getInstrType _ (FReinterpretI BS32) = return $ I32 ==> F32
getInstrType (FReinterpretI BS64) = return $ I64 ==> F64 getInstrType _ (FReinterpretI BS64) = return $ I64 ==> F64
replace :: (Eq a) => a -> a -> [a] -> [a] replace :: (Eq a) => a -> a -> [a] -> [a]
@@ -520,45 +525,46 @@ getExpressionTypeWithInput inp = fmap (inp `Arrow`) . foldM go inp
where where
go :: [VType] -> Instruction Natural -> Checker [VType] go :: [VType] -> Instruction Natural -> Checker [VType]
go stack instr = do go stack instr = do
(f `Arrow` t) <- getInstrType instr (f `Arrow` t) <- getInstrType stack instr
matchStack stack (reverse f) t matchStack stack (reverse f) t
isRef (Func) = True isRef :: ValueType -> Bool
isRef (Extern) = True isRef (Func) = True
isRef _ = False isRef (Extern) = True
isRef _ = False
matchStack :: [VType] -> [VType] -> [VType] -> Checker [VType]
matchStack stack@(Any:_) _arg res = return $ res ++ stack matchStack :: [VType] -> [VType] -> [VType] -> Checker [VType]
matchStack (Val v:stack) (Val v':args) res = matchStack stack@(Any:_) _arg res = return $ res ++ stack
if v == v' matchStack (Val v:stack) (Val v':args) res =
then matchStack stack args res if v == v'
else throwError $ TypeMismatch ((reverse $ Val v':args) `Arrow` res) ([] `Arrow` (Val v:stack)) then matchStack stack args res
matchStack _ (Any:_) res = return $ res else throwError $ TypeMismatch ((reverse $ Val v':args) `Arrow` res) ([] `Arrow` (Val v:stack))
matchStack (Val v:stack) (Var:args) res = matchStack _ (Any:_) res = return $ res
let subst = replace Var (Val v) in matchStack (Val v:stack) (Var:args) res =
matchStack stack (subst args) (subst res) let subst = replace Var (Val v) in
matchStack (Var:stack) (Val v:args) res = matchStack stack (subst args) (subst res)
let subst = replace Var (Val v) in matchStack (Var:stack) (Val v:args) res =
matchStack stack (subst args) (subst res) let subst = replace Var (Val v) in
matchStack (Val v:stack) (NonRefVar:args) res = matchStack stack (subst args) (subst res)
let subst = replace NonRefVar (Val v) in matchStack (Val v:stack) (NonRefVar:args) res =
if isRef v let subst = replace NonRefVar (Val v) in
then throwError $ TypeMismatch (empty ==> empty) (empty ==> empty) if isRef v
else matchStack stack (subst args) (subst res) then throwError $ TypeMismatch (empty ==> empty) (empty ==> empty)
matchStack (NonRefVar:stack) (Val v:args) res = else matchStack stack (subst args) (subst res)
let subst = replace NonRefVar (Val v) in matchStack (NonRefVar:stack) (Val v:args) res =
if isRef v let subst = replace NonRefVar (Val v) in
then throwError $ TypeMismatch (empty ==> empty) (empty ==> empty) if isRef v
else matchStack stack (subst args) (subst res) then throwError $ TypeMismatch (empty ==> empty) (empty ==> empty)
matchStack (Var:stack) (NonRefVar:args) res = else matchStack stack (subst args) (subst res)
let subst = replace NonRefVar NonRefVar in matchStack (Var:stack) (NonRefVar:args) res =
matchStack stack (subst args) (subst res) let subst = replace NonRefVar NonRefVar in
matchStack (NonRefVar:stack) (Var:args) res = matchStack stack (subst args) (subst res)
let subst = replace Var NonRefVar in matchStack (NonRefVar:stack) (Var:args) res =
matchStack stack (subst args) (subst res) let subst = replace Var NonRefVar in
matchStack stack [] res = return $ res ++ stack matchStack stack (subst args) (subst res)
matchStack [] args res = throwError $ TypeMismatch ((reverse args) `Arrow` res) ([] `Arrow` []) matchStack stack [] res = return $ res ++ stack
matchStack st args res = error $ "inconsistent checker state: " ++ show (st, args, res) matchStack [] args res = throwError $ TypeMismatch ((reverse args) `Arrow` res) ([] `Arrow` [])
matchStack st args res = error $ "inconsistent checker state: " ++ show (st, args, res)
getExpressionType :: Expression -> Checker Arrow getExpressionType :: Expression -> Checker Arrow
getExpressionType = getExpressionTypeWithInput [] getExpressionType = getExpressionTypeWithInput []
tests/Test.hs
+1 -1
View File
@@ -19,7 +19,7 @@ main = do
files <- files <-
filter (not . List.isPrefixOf "simd") . filter (List.isSuffixOf ".wast") filter (not . List.isPrefixOf "simd") . filter (List.isSuffixOf ".wast")
<$> Directory.listDirectory "tests/spec" <$> Directory.listDirectory "tests/spec"
-- let files = ["unreached-valid.wast"] -- let files = ["bulk.wast"]
scriptTestCases <- (`mapM` files) $ \file -> do scriptTestCases <- (`mapM` files) $ \file -> do
test <- LBS.readFile ("tests/spec/" ++ file) test <- LBS.readFile ("tests/spec/" ++ file)
return $ testCase file $ do return $ testCase file $ do