bump deps

Bump dependencies ranges to allow building with GHC 9.8 and 9.10

.envrc

@@ -0,0 +1 @@
+use flake

.gitignore

@@ -10,3 +10,4 @@ setup-config
 wasm-*-docs.tar.gz
 cache
 packagedb
+.direnv/

flake.lock

@@ -0,0 +1,27 @@
+{
+  "nodes": {
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1783604885,
+        "narHash": "sha256-tzMgSkV7kljEkqIjlgV6F+n+xD+/a35Db8bs7a4BFAo=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "767b0d3ec98a143ad9ed7dfc0d5553510ac27133",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "ref": "nixpkgs-unstable",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "nixpkgs": "nixpkgs"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

@@ -0,0 +1,29 @@
+{
+  inputs = {
+    nixpkgs.url = "github:NixOS/nixpkgs/nixpkgs-unstable";
+  };
+
+  outputs = { self, nixpkgs, ... }@inputs:
+    let
+      supportedSystems = [
+        "aarch64-darwin" "aarch64-linux"
+        "x86_64-darwin" "x86_64-linux"
+      ];
+
+      each-system = f: nixpkgs.lib.genAttrs supportedSystems (system: f rec {
+	pkgs = import nixpkgs {
+          inherit system;
+        };
+	inherit (pkgs) lib;
+        inherit system;
+      });
+    in {
+      devShells = each-system ({ pkgs, system, ... }: {
+        default = pkgs.mkShell {
+          packages = with pkgs; [
+            cabal-install ghc stack
+          ];
+        };
+      });
+    };
+}

src/Language/Wasm/Binary.hs

@@ -877,10 +877,10 @@ instance Serialize ElemSegment where
         putVec $ map Expr elements
 
     get = do
-        op <- getWord8
         let funcIndexes = map ((:[]) . RefFunc . unIndex) <$> getVec
         let elemKind = byteGuard 0x00 >> return FuncRef
-        case op of
+        op <- getULEB128 32
+        case (op :: Word8) of
             0x00 -> do
                 offset <- getExpression
                 ElemSegment FuncRef (Active 0 offset) <$> funcIndexes

src/Language/Wasm/Interpreter.hs

@@ -469,7 +469,7 @@ evalConstExpr _ _ [F32Const v] = return $ VF32 v
 evalConstExpr _ _ [F64Const v] = return $ VF64 v
 evalConstExpr _ _ [RefNull FuncRef] = return $ RF Nothing
 evalConstExpr _ _ [RefNull ExternRef] = return $ RE Nothing
-evalConstExpr _ _ [RefFunc idx] = return $ RF $ Just idx
+evalConstExpr inst _ [RefFunc idx] = return $ RF $ Just $ fromIntegral $ funcaddrs inst ! fromIntegral idx
 evalConstExpr inst store [GetGlobal i] = getGlobalValue inst store i
 evalConstExpr _ _ instrs = error $ "Global initializer contains unsupported instructions: " ++ show instrs
 
@@ -521,10 +521,7 @@ allocElems inst st = fmap Vector.fromList . mapM allocElem
         allocElem :: ElemSegment -> IO ElemInstance
         allocElem (ElemSegment t mode refs) = do
             indexes <- flip mapM refs $ \refExpr -> do
-                ref <- evalConstExpr inst st refExpr
+                evalConstExpr inst st refExpr
-                return $ case ref of
-                    RF v -> RF $ fromIntegral . (funcaddrs inst !) . fromIntegral <$> v
-                    _ -> ref
             ElemInstance mode t (Vector.fromList indexes)
                 <$> newIORef False -- is dropped
 
@@ -545,14 +542,14 @@ initialize inst Module {elems, datas, start} = do
     case start of
         Just (StartFunction idx) -> do
             let funInst = funcInstances st ! (funcaddrs inst ! fromIntegral idx)
-            mainRes <- liftIO $ eval defaultBudget st funInst []
+            mainRes <- liftIO $ eval defaultBudget st inst funInst []
             case mainRes of
                 Just [] -> return ()
                 _ -> throwError "Start function terminated with trap"
         Nothing -> return ()
     where
         isActiveElem :: (Int, ElemSegment) -> Bool
-        isActiveElem (_, ElemSegment FuncRef (Active _ _) _) = True
+        isActiveElem (_, ElemSegment _ (Active _ _) _) = True
         isActiveElem _ = False
 
         checkElem :: (Int, ElemSegment) -> Initialize (Address, Address, Int, [Maybe Address])
@@ -565,7 +562,10 @@ initialize inst Module {elems, datas, start} = do
             VI32 val <- liftIO $ evalConstExpr inst st offset
             let from = fromIntegral val
             refs <- liftIO $ mapM (evalConstExpr inst st) elements
-            let funcs = map (\(RF ref) -> (funcaddrs inst !) . fromIntegral <$> ref) refs
+            let toStoreIndex ref = case ref of
+                    RF idx -> fromIntegral <$> idx
+                    RE idx -> fromIntegral <$> idx
+            let funcs = map toStoreIndex refs
             let idx = tableaddrs inst ! fromIntegral tableIndex
             return (idx, elemaddrs inst ! elemN, from, funcs)
 
@@ -636,9 +636,9 @@ data EvalResult =
     | ReturnFn [Value]
     deriving (Show, Eq)
 
-eval :: Natural -> Store -> FunctionInstance -> [Value] -> IO (Maybe [Value])
+eval :: Natural -> Store -> ModuleInstance -> FunctionInstance -> [Value] -> IO (Maybe [Value])
-eval 0 _ _ _ = return Nothing
+eval 0 _ _ _ _ = return Nothing
-eval budget store FunctionInstance { funcType, moduleInstance, code = Function { localTypes, body} } args = do
+eval budget store inst FunctionInstance { funcType, moduleInstance, code = Function { localTypes, body} } args = do
     case sequence $ zipWith checkValType (params funcType) args of
         Just checkedArgs -> do
             let initialContext = EvalCtx {
@@ -777,7 +777,7 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
             let args = params ft
             case sequence $ zipWith checkValType args $ reverse $ take (length args) $ stack ctx of
                 Just params -> do
-                    res <- eval (budget - 1) store funInst params
+                    res <- eval (budget - 1) store inst funInst params
                     case res of
                         Just res -> return $ Done ctx { stack = reverse res ++ (drop (length args) $ stack ctx) }
                         Nothing -> return Trap
@@ -802,7 +802,7 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
                         return (funcInst, params)
                 case checks of
                     Just (funcInst, params) -> do
-                        res <- eval (budget - 1) store funcInst params
+                        res <- eval (budget - 1) store inst funcInst params
                         case res of
                             Just res -> return $ Done ctx { stack = reverse res ++ (drop (length params) rest) }
                             Nothing -> return Trap
@@ -815,7 +815,7 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
             let r = case v of { RE Nothing -> 1; RF Nothing -> 1; _ -> 0 } in
             return $ Done ctx { stack = VI32 r : rest }
         step ctx@EvalCtx{ stack = st } (RefFunc index) =
-            return $ Done ctx { stack = RF (Just index) : st }
+            return $ Done ctx { stack =  (RF $ Just $ fromIntegral $ funcaddrs inst ! fromIntegral index) : st }
         step ctx@EvalCtx{ stack = (_:rest) } Drop = return $ Done ctx { stack = rest }
         step ctx@EvalCtx{ stack = (VI32 test:val2:val1:rest) } (Select _) =
             if test == 0
@@ -1011,7 +1011,7 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
             let from = fromIntegral i
             let val = case ref of
                     RE extRef -> fromIntegral <$> extRef
-                    RF fnRef -> (funcaddrs moduleInstance !) . fromIntegral <$> fnRef
+                    RF fnRef -> fromIntegral <$> fnRef
                     v -> error "Impossible due to validation"
             els <- readIORef items
             if from + inc > MVector.length els
@@ -1051,7 +1051,7 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
             let dst = fromIntegral offset
             let val = case ref of
                     RE extRef -> fromIntegral <$> extRef
-                    RF fnRef -> (funcaddrs moduleInstance !) . fromIntegral <$> fnRef
+                    RF fnRef -> fromIntegral <$> fnRef
                     v -> error "Impossible due to validation"
             els <- readIORef items
             if dst >= MVector.length els
@@ -1440,15 +1440,15 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
         step ctx@EvalCtx{ stack = (VI64 v:rest) } (FReinterpretI BS64) =
             return $ Done ctx { stack = VF64 (wordToDouble v) : rest }
         step EvalCtx{ stack } instr = error $ "Error during evaluation of instruction: " ++ show instr ++ ". Stack " ++ show stack
-eval _ _ HostInstance { funcType, hostCode } args = Just <$> hostCode args
+eval _ _ _ HostInstance { funcType, hostCode } args = Just <$> hostCode args
 
-invoke :: Store -> Address -> [Value] -> IO (Maybe [Value])
+invoke :: Store -> ModuleInstance -> Address -> [Value] -> IO (Maybe [Value])
-invoke st funcIdx = eval defaultBudget st $ funcInstances st ! funcIdx
+invoke st inst funcIdx = eval defaultBudget st inst $ funcInstances st ! funcIdx
 
 invokeExport :: Store -> ModuleInstance -> TL.Text -> [Value] -> IO (Maybe [Value])
-invokeExport st ModuleInstance { exports } name args =
+invokeExport st inst@ModuleInstance { exports } name args =
     case Vector.find (\(ExportInstance n _) -> n == name) exports of
-        Just (ExportInstance _ (ExternFunction addr)) -> invoke st addr args
+        Just (ExportInstance _ (ExternFunction addr)) -> invoke st inst addr args
         _ -> error $ "Function with name " ++ show name ++ " was not found in module's exports"
 
 getGlobalValueByName :: Store -> ModuleInstance -> TL.Text -> IO Value

src/Language/Wasm/Lexer.x

@@ -299,7 +299,9 @@ endBlockComment _inp _len = do
     alexMonadScan
 
 startStringLiteral :: AlexAction Lexeme
-startStringLiteral _inp _len = do
+startStringLiteral (_, prev, _, _) _len = do
+    when (prev `notElem` "() \x09\x0A\x0D")
+        $ alexError "string literal should start after space or parent character"
     alexSetStartCode stringLiteral
     setLexerStringFlag True
     alexMonadScan

src/Language/Wasm/Parser.y

@@ -703,13 +703,16 @@ memarg8 :: { MemArg }
     : opt(offset) opt(align) {% parseMemArg 8 $1 $2 }
 
 select_type_or_instructions(terminator)
-    : terminator { ($1, Nothing, []) }
+    : '(' select_type_or_instructions1(terminator) { $2 }
-    | '(' select_type_or_instructions1(terminator) { $2 }
+    | instruction_list(terminator) {
+        let (end, instr) = $1 in
+        (end, Nothing, instr)
+    }
 
 select_type_or_instructions1(terminator) 
-    : 'result' list(valtype) ')' mixed_instruction_list(terminator) {
+    : 'result' list(valtype) ')' select_type_or_instructions(terminator) {
-        let (end, instr) = $4 in
+        let (end, res, instr) = $4 in
-        (end, Just $2, instr)
+        (end, Just ($2 ++ fromMaybe [] res), instr)
     }
     | folded_instr_list(terminator) {
         let (end, instr) = $1 in
@@ -1007,7 +1010,7 @@ elem1_active_offset :: { ([Instruction], ElemType, [[Instruction]]) }
 elemlist :: { (ElemType, [[Instruction]]) }
     : 'func' list(index) { (FuncRef, funcIndexToExpr $2) }
     | 'funcref' list(elemexpr) { (FuncRef, $2) }
-    | 'externref' { (ExternRef, []) }
+    | 'externref' list(elemexpr) { (ExternRef, $2) }
     | list(index) { (FuncRef, funcIndexToExpr $1) }
 
 elemexpr :: { [Instruction] }

src/Language/Wasm/Script.hs

@@ -56,6 +56,7 @@ runScript onAssertFail script = do
     (st, inst) <- Interpreter.makeHostModule Interpreter.emptyStore [
             ("print", hostPrint []),
             ("print_i32", hostPrint [Struct.I32]),
+            ("print_i64", hostPrint [Struct.I64]),
             ("print_i32_f32", hostPrint [Struct.I32, Struct.F32]),
             ("print_f64_f64", hostPrint [Struct.F64, Struct.F64]),
             ("print_f32", hostPrint [Struct.F32]),

src/Language/Wasm/Validate.hs

@@ -141,7 +141,7 @@ isArrowMatch (f `Arrow` t) ( f' `Arrow` t') = isEndMatch f f' && isEndMatch t t'
 data Ctx = Ctx {
     types :: [FuncType],
     funcs :: [FuncType],
-    tables :: [TableType],
+    tableTypes :: [TableType],
     elems :: [ElemType],
     datas :: [DataMode],
     mems :: [Limit],
@@ -273,7 +273,7 @@ getInstrType _ (Call fun) = do
     Ctx { funcs } <- ask
     maybeToEither (FunctionIndexOutOfRange fun) $ asArrow <$> funcs !? fun
 getInstrType _ (CallIndirect tableIdx sign) = do
-    Ctx { types, tables } <- ask
+    Ctx { types, tableTypes = tables } <- ask
     if length tables <= fromIntegral tableIdx
     then throwError (TableIndexOutOfRange tableIdx)
     else do
@@ -419,7 +419,7 @@ getInstrType _ (DataDrop dataIdx) = do
     when (length datas <= fromIntegral dataIdx) $ throwError (DataIndexOutOfRange dataIdx)
     return $ empty ==> empty
 getInstrType _ (TableInit tableIdx elemIdx) = do
-    Ctx { tables, elems } <- ask
+    Ctx { tableTypes = tables, elems } <- ask
     when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
     when (length elems <= fromIntegral elemIdx) $ throwError (ElemIndexOutOfRange elemIdx)
     let TableType _ tableType = tables !! fromIntegral tableIdx
@@ -427,7 +427,7 @@ getInstrType _ (TableInit tableIdx elemIdx) = do
     when (elemType /= tableType) $ throwError (RefTypeMismatch tableType elemType)
     return $ [I32, I32, I32] ==> empty
 getInstrType _ (TableCopy toIdx fromIdx) = do
-    Ctx { tables } <- ask
+    Ctx { tableTypes = tables } <- ask
     let (from, to) = (fromIntegral fromIdx, fromIntegral toIdx)
     when (length tables <= from) $ throwError (TableIndexOutOfRange fromIdx)
     when (length tables <= to) $ throwError (TableIndexOutOfRange toIdx)
@@ -436,26 +436,26 @@ getInstrType _ (TableCopy toIdx fromIdx) = do
     when (fromType /= toType) $ throwError (RefTypeMismatch fromType toType)
     return $ [I32, I32, I32] ==> empty
 getInstrType _ (TableFill tableIdx) = do
-    Ctx { tables } <- ask
+    Ctx { tableTypes = tables } <- ask
     when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
     let TableType _ tableType = tables !! fromIntegral tableIdx
     return $ [I32, elemTypeToRefType tableType, I32] ==> empty
 getInstrType _ (TableSize tableIdx) = do
-    Ctx { tables } <- ask
+    Ctx { tableTypes = tables } <- ask
     when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
     return $ empty ==> I32
 getInstrType _ (TableGrow tableIdx) = do
-    Ctx { tables } <- ask
+    Ctx { tableTypes = tables } <- ask
     when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
     let TableType _ tableType = tables !! fromIntegral tableIdx
     return $ [elemTypeToRefType tableType, I32] ==> I32
 getInstrType _ (TableGet tableIdx) = do
-    Ctx { tables } <- ask
+    Ctx { tableTypes = 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
+    Ctx { tableTypes = tables } <- ask
     when (length tables <= fromIntegral tableIdx) $ throwError (TableIndexOutOfRange tableIdx)
     let TableType _ tableType = tables !! fromIntegral tableIdx
     return $ [I32, elemTypeToRefType tableType] ==> empty
@@ -604,7 +604,7 @@ ctxFromModule locals labels returns m =
     Ctx {
         types,
         funcs = getFuncTypes m,
-        tables = tableImports ++ map (\(Table t) -> t) tables,
+        tableTypes = tableImports ++ map (\(Table t) -> t) tables,
         elems = map elemType elems,
         datas = map dataMode datas,
         mems = memsImports ++ map (\(Memory l) -> l) mems,
@@ -706,8 +706,6 @@ elemsShouldBeValid m@Module { elems, functions, tables, imports } =
     where
         isElemValid :: Ctx -> ElemSegment -> ValidationResult
         isElemValid ctx (ElemSegment elemType mode elements) = do
-            unless (elemType == FuncRef)
-                $ throwError $ RefTypeMismatch FuncRef elemType
             forM_ elements $ \elem -> runChecker ctx $ do
                 arr <- getExpressionType elem
                 isConstExpression elem
@@ -722,6 +720,9 @@ elemsShouldBeValid m@Module { elems, functions, tables, imports } =
                     let tableImports = filter isTableImport imports
                     when (tableIdx >= fromIntegral (length tableImports + length tables)) $ do
                         throwError $ TableIndexOutOfRange tableIdx
+                    let TableType _ tableType = tableTypes ctx !! (fromIntegral tableIdx)
+                    when (tableType /= elemType) $ do
+                        throwError $ RefTypeMismatch elemType tableType
                 _ -> return ()
         
         isValidRef :: ElemType -> Arrow -> Bool

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-20.23 
+resolver: lts-24.48
 packages:
 - '.'
 extra-deps: []

stack.yaml.lock

@@ -1,12 +1,12 @@
 # This file was autogenerated by Stack.
 # You should not edit this file by hand.
 # For more information, please see the documentation at:
-#   https://docs.haskellstack.org/en/stable/lock_files
+#   https://docs.haskellstack.org/en/stable/topics/lock_files
 
 packages: []
 snapshots:
 - completed:
-    sha256: 4c972e067bae16b95961dbfdd12e07f1ee6c8fffabbfa05c3d65100b03f548b7
+    sha256: 3286bb954fe0e7e0291ca61fac01a689b7165da9d7e8ba3c3a045be989c860fd
-    size: 650253
+    size: 732677
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/23.yaml
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/48.yaml
-  original: lts-20.23
+  original: lts-24.48

tests/Test.hs

@@ -19,7 +19,7 @@ main = do
   files <-
     filter (not . List.isPrefixOf "simd") . filter (List.isSuffixOf ".wast")
       <$> Directory.listDirectory "tests/spec"
-  -- let files = ["bulk.wast"]
+  -- let files = ["binary-leb128.wast"]
   scriptTestCases <- (`mapM` files) $ \file -> do
     test <- LBS.readFile ("tests/spec/" ++ file)
     return $ testCase file $ do

wasm.cabal

@@ -1,6 +1,6 @@
 cabal-version:  2.2
 name:           wasm
-version:        1.1.2
+version:        1.2.0
 synopsis:       WebAssembly Language Toolkit and Interpreter
 description:
   Library for parsing and interpreting WebAssembly, including:
@@ -18,7 +18,7 @@ build-type:     Simple
 category:       Language
 homepage:       https://github.com/SPY/haskell-wasm
 bug-reports:    https://github.com/SPY/haskell-wasm/issues
-tested-with:    GHC==8.6.5, GHC==8.8.4, GHC==8.10.4, GHC==9.2.7
+tested-with:    GHC==8.6.5, GHC==8.8.4, GHC==8.10.4, GHC==9.2.7, GHC==9.10.3
 extra-source-files:
     README.md
     src/Language/Wasm/Parser.y
@@ -52,18 +52,18 @@ library
                -fwarn-incomplete-patterns
                -fwarn-unused-imports
   build-tool-depends:
-      alex:alex >=3.1.3 && < 3.3
+      alex:alex >=3.1.3 && < 3.6
-    , happy:happy >=1.9.4 && < 1.21
+    , happy:happy ^>=2.1
   build-depends:
       array >=0.5 && < 0.6
     , base >=4.6 && < 5
-    , bytestring >=0.10 && < 0.12
+    , bytestring >=0.10 && < 0.13
     , cereal >=0.5 && < 0.6
-    , containers >=0.5 && < 0.7
+    , containers >=0.5 && < 0.8
-    , deepseq >=1.4 && < 1.5
+    , deepseq >=1.4 && < 1.6
     , ieee754 >=0.8 && < 0.9
     , mtl >=2.2.1 && < 2.4
-    , primitive >=0.7 && < 0.8
+    , primitive >=0.7 && < 0.10
     , text >=1.1 && < 3
     , transformers >=0.4 && < 0.7
     , utf8-string >=1.0 && < 1.1