added line position for failed asserts and implemented mutable globals import/export proposal

2021-03-09 22:45:16 -08:00
parent 02e2c4a705
commit 252ced4989
4 changed files with 101 additions and 69 deletions
@@ -19,7 +19,8 @@ module Language.Wasm.Interpreter (
    emptyStore,
    emptyImports,
    makeHostModule,
-    makeMutGlobal
+    makeMutGlobal,
+    makeConstGlobal
 ) where

 import qualified Data.Map as Map
@@ -177,6 +178,9 @@ data GlobalInstance = GIConst ValueType Value | GIMut ValueType (IORef Value)
 makeMutGlobal :: Value -> IO GlobalInstance
 makeMutGlobal val = GIMut (getValueType val) <$> newIORef val

+makeConstGlobal :: Value -> GlobalInstance
+makeConstGlobal val = GIConst (getValueType val) val
+
 getValueType :: Value -> ValueType
 getValueType (VI32 _) = I32
 getValueType (VI64 _) = I64
@@ -364,13 +368,11 @@ calcInstance (Store fs ts ms gs) imps Module {functions, types, tables, mems, gl
                ExternGlobal globalAddr -> return globalAddr
                _ -> err
            let globalInst = gs ! globalAddr
-            let vt = case globalType of
-                    Const vt -> vt
-                    Mut vt -> vt
-            let vt' = case globalInst of
-                    GIConst vt _ -> vt
-                    GIMut vt _ -> vt
-            if vt == vt' then return idx else err
+            let typesMatch = case (globalType, globalInst) of
+                    (Const vt, GIConst vt' _) -> vt == vt'
+                    (Mut vt, GIMut vt' _) -> vt == vt'
+                    _ -> False
+            if typesMatch then return idx else err
        checkImportType imp@(Import _ _ (ImportMemory limit)) = do
            idx <- getImpIdx imp
            memAddr <- case idx of
@@ -313,14 +313,14 @@ import Language.Wasm.Lexer (
 'register'            { Lexeme _ (TKeyword "register") }
 'invoke'              { Lexeme _ (TKeyword "invoke") }
 'get'                 { Lexeme _ (TKeyword "get") }
-'assert_return'       { Lexeme _ (TKeyword "assert_return") }
-'assert_return_canonical_nan' { Lexeme _ (TKeyword "assert_return_canonical_nan") }
-'assert_return_arithmetic_nan' { Lexeme _ (TKeyword "assert_return_arithmetic_nan") }
-'assert_trap'         { Lexeme _ (TKeyword "assert_trap") }
-'assert_malformed'    { Lexeme _ (TKeyword "assert_malformed") }
-'assert_invalid'      { Lexeme _ (TKeyword "assert_invalid") }
-'assert_unlinkable'   { Lexeme _ (TKeyword "assert_unlinkable") }
-'assert_exhaustion'   { Lexeme _ (TKeyword "assert_exhaustion") }
+'assert_return'       { Lexeme $$ (TKeyword "assert_return") }
+'assert_return_canonical_nan' { Lexeme $$ (TKeyword "assert_return_canonical_nan") }
+'assert_return_arithmetic_nan' { Lexeme $$ (TKeyword "assert_return_arithmetic_nan") }
+'assert_trap'         { Lexeme $$ (TKeyword "assert_trap") }
+'assert_malformed'    { Lexeme $$ (TKeyword "assert_malformed") }
+'assert_invalid'      { Lexeme $$ (TKeyword "assert_invalid") }
+'assert_unlinkable'   { Lexeme $$ (TKeyword "assert_unlinkable") }
+'assert_exhaustion'   { Lexeme $$ (TKeyword "assert_exhaustion") }
 'script'              { Lexeme _ (TKeyword "script") }
 'input'               { Lexeme _ (TKeyword "input") }
 'output'              { Lexeme _ (TKeyword "output") }
@@ -1104,7 +1104,7 @@ command1 :: { Command }
    : module1 { ModuleDef $1 }
    | 'register' string opt(ident) ')' { Register $2 $3 }
    | action1 { Action $1 }
-    | assertion1 { Assertion $1 }
+    | assertion1 { let (Just (AlexPn _ line _), a) = $1 in Assertion line a }
    | meta1 { Meta $1 }

 module1 :: { ModuleDef }
@@ -1117,15 +1117,15 @@ action1 :: { Action }
    : 'invoke' opt(ident) string list(folded_instr) ')' { Invoke $2 $3 (map (map constInstructionToValue) $4) }
    | 'get' opt(ident) string ')' { Get $2 $3 }

-assertion1 :: { Assertion }
-    : 'assert_return' '(' action1 list(folded_instr) ')' { AssertReturn $3 (map (map constInstructionToValue) $4) }
-    | 'assert_return_canonical_nan' '(' action1 ')' { AssertReturnCanonicalNaN $3 }
-    | 'assert_return_arithmetic_nan' '(' action1 ')' { AssertReturnArithmeticNaN $3 }
-    | 'assert_trap' '(' assertion_trap string ')' { AssertTrap $3 $4 }
-    | 'assert_malformed' '(' module1 string ')' { AssertMalformed $3 $4 }
-    | 'assert_invalid' '(' module1 string ')' { AssertInvalid $3 $4 }
-    | 'assert_unlinkable' '(' module1 string ')' { AssertUnlinkable $3 $4 }
-    | 'assert_exhaustion' '(' action1 string ')' { AssertExhaustion $3 $4 }
+assertion1 :: { (Maybe AlexPosn, Assertion) }
+    : 'assert_return' '(' action1 list(folded_instr) ')' { ($1, AssertReturn $3 (map (map constInstructionToValue) $4)) }
+    | 'assert_return_canonical_nan' '(' action1 ')' { ($1, AssertReturnCanonicalNaN $3) }
+    | 'assert_return_arithmetic_nan' '(' action1 ')' { ($1, AssertReturnArithmeticNaN $3) }
+    | 'assert_trap' '(' assertion_trap string ')' { ($1, AssertTrap $3 $4) }
+    | 'assert_malformed' '(' module1 string ')' { ($1, AssertMalformed $3 $4) }
+    | 'assert_invalid' '(' module1 string ')' { ($1, AssertInvalid $3 $4) }
+    | 'assert_unlinkable' '(' module1 string ')' { ($1, AssertUnlinkable $3 $4) }
+    | 'assert_exhaustion' '(' action1 string ')' { ($1, AssertExhaustion $3 $4) }

 assertion_trap :: { Either Action ModuleDef }
    : action1 { Left $1 }
@@ -1454,7 +1454,7 @@ data Command
    = ModuleDef ModuleDef
    | Register TL.Text (Maybe Ident)
    | Action Action
-    | Assertion Assertion
+    | Assertion Int Assertion
    | Meta Meta
    deriving (Show, Eq)

@@ -1518,6 +1518,7 @@ desugarize fields = do
    segments <- mapM (synDataToStruct mod) $ datas mod
    globs <- mapM (synGlobalToStruct mod) $ globals mod
    checkMemoryIdentsUniqueness mod
+    checkGlobalIdentsUniqueness mod
    return S.Module {
        S.types = map synTypeDefToStruct $ types mod,
        S.functions = funs,
@@ -1855,7 +1856,7 @@ desugarize fields = do
        getMemIndexes :: Module -> Ident -> [Natural]
        getMemIndexes Module { imports, mems } id =
            let memImports = zip [0..] $ filter isMemImport imports in
-            let importIndexes = map fst $ filter (\((_, Import { desc = ImportMemory ident _ })) -> ident == Just id) memImports in
+            let importIndexes = map fst $ filter (\(_, Import { desc = ImportMemory ident _ }) -> ident == Just id) memImports in
            let isIdent (_, (Memory _ (Just id) _)) = True in
            let memIndexes = map fst $ filter isIdent $ zip [length memImports..] mems in
            map fromIntegral $ importIndexes ++ memIndexes
@@ -1873,6 +1874,23 @@ desugarize fields = do
            let ctx = FunCtx mod [] [] [] in
            S.Global globalType <$> mapM (synInstrToStruct ctx) initializer

+        checkGlobalIdentsUniqueness :: Module -> Either String ()
+        checkGlobalIdentsUniqueness m@Module { imports, globals } = do
+            mapM_ checkImportUniqueness $ filter isGlobalImport imports
+            mapM_ checkGlobalUniqueness globals
+            where
+                checkImportUniqueness Import { desc = ImportGlobal (Just id) _ } =
+                    if length (getGlobalIndexes m id) > 1
+                    then Left "duplicate global"
+                    else return ()
+                checkImportUniqueness _ = return ()
+
+                checkGlobalUniqueness (Global _ (Just id) _ _) =
+                    if length (getGlobalIndexes m id) > 1
+                    then Left "duplicate global"
+                    else return ()
+                checkGlobalUniqueness _ = return ()
+
        extractGlobal :: [Global] -> ModuleField -> [Global]
        extractGlobal globals (MFGlobal global) = global : globals
        extractGlobal globals _ = globals
@@ -1881,14 +1899,19 @@ desugarize fields = do
        isGlobalImport Import { desc = ImportGlobal _ _ } = True
        isGlobalImport _ = False

+        getGlobalIndexes :: Module -> Ident -> [Natural]
+        getGlobalIndexes Module { imports, globals } id =
+            let globalImports = zip [0..] $ filter isGlobalImport imports in
+            let importIndexes = map fst $ filter (\(_, Import { desc = ImportGlobal ident _ }) -> ident == Just id) globalImports in
+            let isIdent (_, Global { ident }) = ident == Just id in
+            let globalIndexes = map fst $ filter isIdent $ zip [length globalImports..] globals in
+            map fromIntegral $ importIndexes ++ globalIndexes
+
        getGlobalIndex :: Module -> GlobalIndex -> Maybe Natural
-        getGlobalIndex Module { imports, globals } (Named id) =
-            let globalImports = filter isGlobalImport imports in
-            case findIndex (\(Import { desc = ImportGlobal ident _ }) -> ident == Just id) globalImports of
-                Just idx -> return $ fromIntegral idx
-                Nothing ->
-                    let isIdent (Global { ident }) = ident == Just id in
-                    fromIntegral . (+ length globalImports) <$> findIndex isIdent globals
+        getGlobalIndex mod@Module { imports, globals } (Named id) =
+            case getGlobalIndexes mod id of
+                [idx] -> return idx
+                _ -> Nothing
        getGlobalIndex Module { imports, globals } (Index idx) = Just idx

        -- elem segment
@@ -47,7 +47,7 @@ emptyState = ScriptState {

 runScript :: OnAssertFail -> Script -> IO ()
 runScript onAssertFail script = do
-    (globI32, globF32, globF64) <- hostGlobals
+    (globI32, globI64, globF32, globF64) <- hostGlobals
    (st, inst) <- Interpreter.makeHostModule Interpreter.emptyStore [
            ("print", hostPrint []),
            ("print_i32", hostPrint [Struct.I32]),
@@ -56,6 +56,7 @@ runScript onAssertFail script = do
            ("print_f32", hostPrint [Struct.F32]),
            ("print_f64", hostPrint [Struct.F64]),
            ("global_i32", globI32),
+            ("global_i64", globI64),
            ("global_f32", globF32),
            ("global_f64", globF64),
            ("memory", Interpreter.HostMemory $ Struct.Limit 1 (Just 2)),
@@ -65,10 +66,16 @@ runScript onAssertFail script = do
    where
        hostPrint paramTypes = Interpreter.HostFunction (Struct.FuncType paramTypes []) (\args -> return [])
        hostGlobals = do
-            globI32 <- Interpreter.makeMutGlobal $ Interpreter.VI32 666
+            let globI32 = Interpreter.makeConstGlobal $ Interpreter.VI32 666
+            let globI64 = Interpreter.makeConstGlobal $ Interpreter.VI64 666
            globF32 <- Interpreter.makeMutGlobal $ Interpreter.VF32 666
            globF64 <- Interpreter.makeMutGlobal $ Interpreter.VF64 666
-            return (Interpreter.HostGlobal globI32, Interpreter.HostGlobal globF32, Interpreter.HostGlobal globF64)
+            return (
+                    Interpreter.HostGlobal globI32,
+                    Interpreter.HostGlobal globI64,
+                    Interpreter.HostGlobal globF32,
+                    Interpreter.HostGlobal globF64
+                )

        go [] _ = return ()
        go (c:cs) st = runCommand st c >>= go cs
@@ -130,19 +137,19 @@ runScript onAssertFail script = do
        isValueEqual (Interpreter.VF64 v1) (Interpreter.VF64 v2) = identicalIEEE v1 v2
        isValueEqual _ _ = False

-        isNaNReturned :: ScriptState -> Action -> Assertion -> IO ()
-        isNaNReturned st action assert = do
+        isNaNReturned :: ScriptState -> String -> Action -> Assertion -> IO ()
+        isNaNReturned st pos action assert = do
            result <- runAction st action
            case result of
                Just [Interpreter.VF32 v] ->
                    if isNaN v
                    then return ()
-                    else onAssertFail ("Expected NaN, but action returned " ++ show v) assert
+                    else onAssertFail (pos ++ ": Expected NaN, but action returned " ++ show v) assert
                Just [Interpreter.VF64 v] ->
                    if isNaN v
                    then return ()
-                    else onAssertFail ("Expected NaN, but action returned " ++ show v) assert
-                _ -> onAssertFail ("Expected NaN, but action returned " ++ show result) assert
+                    else onAssertFail (pos ++ ": Expected NaN, but action returned " ++ show v) assert
+                _ -> onAssertFail (pos ++ ": Expected NaN, but action returned " ++ show result) assert
        
        buildModule :: ModuleDef -> (Maybe Ident, Struct.Module)
        buildModule (RawModDef ident m) = (ident, m)
@@ -178,67 +185,67 @@ runScript onAssertFail script = do
        getFailureString Validate.InvalidStartFunctionType = ["start function"]
        getFailureString r = [TL.concat ["not implemented ", (TL.pack $ show r)]]

-        runAssert :: ScriptState -> Assertion -> IO ()
-        runAssert st assert@(AssertReturn action expected) = do
+        runAssert :: ScriptState -> String -> Assertion -> IO ()
+        runAssert st pos assert@(AssertReturn action expected) = do
            result <- runAction st action
            case result of
                Just result -> do
                    if length result == length expected && (all id $ zipWith isValueEqual result (map asArg expected))
                    then return ()
-                    else onAssertFail ("Expected " ++ show (map asArg expected) ++ ", but action returned " ++ show result) assert
-                Nothing -> onAssertFail ("Expected " ++ show (map asArg expected) ++ ", but action returned Trap") assert
-        runAssert st assert@(AssertReturnCanonicalNaN action) = isNaNReturned st action assert
-        runAssert st assert@(AssertReturnArithmeticNaN action) = isNaNReturned st action assert
-        runAssert st assert@(AssertInvalid moduleDef failureString) =
+                    else onAssertFail (pos ++ ": Expected " ++ show (map asArg expected) ++ ", but action returned " ++ show result) assert
+                Nothing -> onAssertFail (pos ++ ": Expected " ++ show (map asArg expected) ++ ", but action returned Trap") assert
+        runAssert st pos assert@(AssertReturnCanonicalNaN action) = isNaNReturned st pos action assert
+        runAssert st pos assert@(AssertReturnArithmeticNaN action) = isNaNReturned st pos action assert
+        runAssert st pos assert@(AssertInvalid moduleDef failureString) =
            let (_, m) = buildModule moduleDef in
            case Validate.validate m of
-                Right _ -> onAssertFail "An invalid module passed validation step" assert
+                Right _ -> onAssertFail (pos ++ ": An invalid module passed validation step") assert
                Left reason ->
                    if failureString `elem` getFailureString reason
                    then return ()
                    else
-                        let msg = "Module is invalid for other reason. Expected "
+                        let msg = pos ++ ": Module is invalid for other reason. Expected "
                                ++ show failureString
                                ++ ", but actual is "
                                ++ show (getFailureString reason)
                        in onAssertFail msg assert
-        runAssert st assert@(AssertMalformed (TextModDef _ textRep) failureString) =
+        runAssert st pos assert@(AssertMalformed (TextModDef _ textRep) failureString) =
            case DeepSeq.force $ Lexer.scanner (TLEncoding.encodeUtf8 textRep) >>= Parser.parseModule of
-                Right _ -> onAssertFail ("Module parsing should fail with failure string " ++ show failureString) assert
+                Right _ -> onAssertFail (pos ++ ": Module parsing should fail with failure string " ++ show failureString) assert
                Left _ -> return ()
-        runAssert st assert@(AssertMalformed (BinaryModDef ident binaryRep) failureString) =
+        runAssert st pos assert@(AssertMalformed (BinaryModDef ident binaryRep) failureString) =
            case Binary.decodeModuleLazy binaryRep of
-                Right _ -> onAssertFail ("Module decoding should fail with failure string " ++ show failureString) assert
+                Right _ -> onAssertFail (pos ++ ": Module decoding should fail with failure string " ++ show failureString) assert
                Left _ -> return ()
-        runAssert st assert@(AssertMalformed (RawModDef _ _) failureString) = return ()
-        runAssert st assert@(AssertUnlinkable moduleDef failureString) =
+        runAssert st _ assert@(AssertMalformed (RawModDef _ _) failureString) = return ()
+        runAssert st pos assert@(AssertUnlinkable moduleDef failureString) =
            let (_, m) = buildModule moduleDef in
            case Validate.validate m of
                Right m -> do
                    res <- Interpreter.instantiate (store st) (buildImports st) m
                    case res of
                        Left err -> return ()
-                        Right _ -> onAssertFail ("Module linking should fail with failure string " ++ show failureString) assert
-                Left reason -> error $ "Module linking failed due to invalid module with reason: " ++ show reason
-        runAssert st assert@(AssertTrap (Left action) failureString) = do
+                        Right _ -> onAssertFail (pos ++ ": Module linking should fail with failure string " ++ show failureString) assert
+                Left reason -> error $ pos ++ ": Module linking failed due to invalid module with reason: " ++ show reason
+        runAssert st pos assert@(AssertTrap (Left action) failureString) = do
            result <- runAction st action
            if isNothing result
            then return ()
-            else onAssertFail ("Expected trap, but action returned " ++ show (fromJust result)) assert
-        runAssert st assert@(AssertTrap (Right moduleDef) failureString) =
+            else onAssertFail (pos ++ ":Expected trap, but action returned " ++ show (fromJust result)) assert
+        runAssert st pos assert@(AssertTrap (Right moduleDef) failureString) =
            let (_, m) = buildModule moduleDef in
            case Validate.validate m of
                Right m -> do
                    res <- Interpreter.instantiate (store st) (buildImports st) m
                    case res of
                        Left "Start function terminated with trap" -> return ()
-                        _ -> onAssertFail ("Module linking should fail with trap during execution of a start function") assert
-                Left reason -> error $ "Module linking failed due to invalid module with reason: " ++ show reason
-        runAssert st assert@(AssertExhaustion action failureString) = do
+                        _ -> onAssertFail (pos ++ ": Module linking should fail with trap during execution of a start function") assert
+                Left reason -> error $ pos ++ ": Module linking failed due to invalid module with reason: " ++ show reason
+        runAssert st pos assert@(AssertExhaustion action failureString) = do
            result <- runAction st action
            if isNothing result
            then return ()
-            else onAssertFail ("Expected exhaustion, but action returned " ++ show (fromJust result)) assert
+            else onAssertFail (pos ++ ": Expected exhaustion, but action returned " ++ show (fromJust result)) assert

        runCommand :: ScriptState -> Command -> IO ScriptState
        runCommand st (ModuleDef moduleDef) =
@@ -246,5 +253,5 @@ runScript onAssertFail script = do
            addModule ident m st
        runCommand st (Register name i) = return $ addToRegistery name i st
        runCommand st (Action action) = runAction st action >> return st
-        runCommand st (Assertion assertion) = runAssert st assertion >> return st
+        runCommand st (Assertion pos assertion) = runAssert st ("Line " ++ show pos) assertion >> return st
        runCommand st _ = return st
@@ -17,7 +17,7 @@ import qualified Data.List as List
 main :: IO ()
 main = do
  files <- filter (List.isSuffixOf ".wast") <$> Directory.listDirectory "tests/spec"
-  -- let files = ["linking.wast"]
+  -- let files = ["global.wast"]
  scriptTestCases <- (`mapM` files) $ \file -> do
    test <- LBS.readFile ("tests/spec/" ++ file)
    return $ testCase file $ do