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

pass more tests

Browse Source
This commit is contained in:
Ilya Rezvov
2018-02-25 09:53:28 -08:00
parent c7ecb055d4
commit d53611c1e5
1 changed files with 52 additions and 31 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Validate.hs
+52 -31
View File
@@ -10,7 +10,7 @@ module Language.Wasm.Validate (
import Language.Wasm.Structure import Language.Wasm.Structure
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.List (foldl') import Data.List (foldl', isPrefixOf)
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Data.Maybe (fromMaybe, maybeToList) import Data.Maybe (fromMaybe, maybeToList)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
@@ -81,6 +81,24 @@ data Arrow = Arrow End End deriving (Show, Eq)
asArrow :: FuncType -> Arrow asArrow :: FuncType -> Arrow
asArrow (FuncType params results) = Arrow (map Val params) (map Val results) asArrow (FuncType params results) = Arrow (map Val params) (map Val results)
isArrowMatch :: Arrow -> Arrow -> Bool
isArrowMatch (f `Arrow` t) ( f' `Arrow` t') = isEndMatch f f' && isEndMatch t t'
where
isEndMatch :: End -> End -> Bool
isEndMatch (Any:l) (Any:r) =
let leftTail = takeWhile (/= Any) $ reverse l in
let rightTail = takeWhile (/= Any) $ reverse r in
leftTail `isPrefixOf` rightTail || rightTail `isPrefixOf` leftTail
isEndMatch (Any:l) r =
let leftTail = takeWhile (/= Any) $ reverse l in
let rightTail = takeWhile (/= Any) $ reverse r in
leftTail `isPrefixOf` rightTail || rightTail `isPrefixOf` leftTail
isEndMatch l (Any:r) =
let leftTail = takeWhile (/= Any) $ reverse l in
let rightTail = takeWhile (/= Any) $ reverse r in
leftTail `isPrefixOf` rightTail || rightTail `isPrefixOf` leftTail
isEndMatch l r = l == r
data Ctx = Ctx { data Ctx = Ctx {
types :: [FuncType], types :: [FuncType],
funcs :: [FuncType], funcs :: [FuncType],
@@ -136,20 +154,20 @@ getInstrType Nop = return $ empty ==> empty
getInstrType Block { result, body } = do getInstrType Block { result, body } = do
let blockType = empty ==> result let blockType = empty ==> result
t <- withLabel result $ getExpressionType body t <- withLabel result $ getExpressionType body
if t == blockType if isArrowMatch t blockType
then return $ empty ==> result then return $ empty ==> result
else throwError TypeMismatch else Debug.trace ("block err " ++ show t ++ " - " ++ show blockType) $throwError TypeMismatch
getInstrType Loop { result, body } = do getInstrType Loop { result, body } = do
let blockType = empty ==> result let blockType = empty ==> result
t <- withLabel result $ getExpressionType body t <- withLabel result $ getExpressionType body
if t == blockType if isArrowMatch t blockType
then return $ empty ==> result then return $ empty ==> result
else throwError TypeMismatch else throwError TypeMismatch
getInstrType If { result, true, false } = do getInstrType If { result, true, false } = do
let blockType = empty ==> result let blockType = empty ==> result
l <- withLabel result $ getExpressionType true l <- withLabel result $ getExpressionType true
r <- withLabel result $ getExpressionType false r <- withLabel result $ getExpressionType false
if l == blockType && r == blockType if isArrowMatch l blockType && isArrowMatch r blockType
then return $ I32 ==> result then return $ I32 ==> result
else throwError TypeMismatch else throwError TypeMismatch
getInstrType (Br lbl) = do getInstrType (Br lbl) = do
@@ -329,30 +347,30 @@ replace _ _ [] = []
replace x y (v:r) = (if x == v then y else v) : replace x y r replace x y (v:r) = (if x == v then y else v) : replace x y r
unify :: Arrow -> Arrow -> Checker Arrow unify :: Arrow -> Arrow -> Checker Arrow
unify (f `Arrow` []) (f' `Arrow` t') = unify (f `Arrow` t) (f' `Arrow` t') = unify' (f `Arrow` reverse t) (reverse f' `Arrow` t')
return $ (reverse f' ++ f) `Arrow` t' where
unify (f `Arrow` t) ([] `Arrow` t') = unify' :: Arrow -> Arrow -> Checker Arrow
return $ f `Arrow` (reverse t ++ t') unify' (f `Arrow` []) (f' `Arrow` t') =
unify (f `Arrow` (Val v':t)) ((Val v:f') `Arrow` t') = return $ (reverse f' ++ f) `Arrow` t'
if v == v' unify' (f `Arrow` t) ([] `Arrow` t') =
then unify (f `Arrow` t) (f' `Arrow` t') return $ f `Arrow` (reverse t ++ t')
else Debug.trace ("type err " ++ show v' ++ " - " ++ show v) $ throwError TypeMismatch unify' (f `Arrow` (Val v':t)) ((Val v:f') `Arrow` t') =
unify (f `Arrow` (Var r:t)) ((Val v:f') `Arrow` t') = if v == v'
let subst = replace (Var r) (Val v) in then unify' (f `Arrow` t) (f' `Arrow` t')
unify (subst f `Arrow` subst t) (f' `Arrow` t') else Debug.trace ("type err " ++ show v' ++ " - " ++ show v) $ throwError TypeMismatch
unify (f `Arrow` (Val v:t)) ((Var r:f') `Arrow` t') = unify' (f `Arrow` (Var r:t)) ((Val v:f') `Arrow` t') =
let subst = replace (Var r) (Val v) in let subst = replace (Var r) (Val v) in
unify (f `Arrow` t) (subst f' `Arrow` subst t') unify' (subst f `Arrow` subst t) (f' `Arrow` t')
unify (f `Arrow` (Var r:t)) ((Var r':f') `Arrow` t') = unify' (f `Arrow` (Val v:t)) ((Var r:f') `Arrow` t') =
let subst = replace (Var r') (Var r) in let subst = replace (Var r) (Val v) in
unify (f `Arrow` t) (subst f' `Arrow` subst t') unify' (f `Arrow` t) (subst f' `Arrow` subst t')
unify (f `Arrow` (Any:_)) (_ `Arrow` t') = unify' (f `Arrow` (Var r:t)) ((Var r':f') `Arrow` t') =
return $ f `Arrow` t' let subst = replace (Var r') (Var r) in
unify (f `Arrow` _) ((Any:_) `Arrow` t') = unify' (f `Arrow` t) (subst f' `Arrow` subst t')
return $ f `Arrow` t' unify' (f `Arrow` (Any:_)) (_ `Arrow` t') =
return $ f `Arrow` t'
unify' :: Arrow -> Arrow -> Checker Arrow unify' (f `Arrow` _) ((Any:_) `Arrow` t') =
unify' (f `Arrow` t) (f' `Arrow` t') = unify (f `Arrow` reverse t) (reverse f' `Arrow` t') return $ f `Arrow` t'
getExpressionType :: [Instruction] -> Checker Arrow getExpressionType :: [Instruction] -> Checker Arrow
getExpressionType instrs = getExpressionType instrs =
@@ -366,7 +384,7 @@ getExpressionType instrs =
go arr [] = return arr go arr [] = return arr
go arr (i:rest) = do go arr (i:rest) = do
a <- getInstrType i a <- getInstrType i
arr' <- unify' a arr arr' <- unify a arr
go arr' rest go arr' rest
ctxFromModule :: [ValueType] -> [Maybe ValueType] -> Maybe ValueType -> Module -> Ctx ctxFromModule :: [ValueType] -> [Maybe ValueType] -> Maybe ValueType -> Module -> Ctx
@@ -389,7 +407,10 @@ isFunctionValid Function {funcType, locals, body} mod@Module {types} =
let ctx = ctxFromModule (params ++ locals) [r] r mod in let ctx = ctxFromModule (params ++ locals) [r] r mod in
case runChecker ctx $ getExpressionType body of case runChecker ctx $ getExpressionType body of
Left err -> err Left err -> err
Right arr -> if arr == (empty ==> results) || arr == (Any ==> Any) then Valid else TypeMismatch Right arr ->
if isArrowMatch arr (empty ==> results)
then Valid
else Debug.trace ("fun err " ++ show arr ++ " - " ++ show (empty ==> results)) $ TypeMismatch
functionsShouldBeValid :: Validator functionsShouldBeValid :: Validator
functionsShouldBeValid mod@Module {functions} = functionsShouldBeValid mod@Module {functions} =