Implement MemoryFill and MemoryCopy bulk memory ops

default.nix

@@ -17,11 +17,18 @@
 
 let
 
+spec-tests-mvp = pkgs.fetchFromGitHub {
+     owner  = "WebAssembly";
+     repo   = "testsuite";
+     rev    = "35c50bf6fbb002cfdc1227b0af731bdcaf877714";
+     sha256 = "0difcpya5i7fc4xdrysx49186x9vh5yhm88dqpmfppj7ddj39l9i";
+  };
+
 spec-tests = pkgs.fetchFromGitHub {
     owner  = "WebAssembly";
     repo   = "testsuite";
-    rev    = "35c50bf6fbb002cfdc1227b0af731bdcaf877714";
-    sha256 = "0difcpya5i7fc4xdrysx49186x9vh5yhm88dqpmfppj7ddj39l9i";
+    rev    = "6aacfd8929504d8e02a5144a14d184196ede6790";
+    sha256 = "sha256-HrnTpIEVN3H9P4fuSBUkaMpNdMxa2pbfp1iPElJLlUM";
   };
 
 drv = pkgs.haskellPackages.developPackage {
@@ -47,4 +54,7 @@ drv = pkgs.haskellPackages.developPackage {
   inherit returnShellEnv;
 };
 
-in drv.overrideAttrs(old: { WASM_SPEC_TESTS = "${spec-tests}"; })
+in drv.overrideAttrs(old:
+  { WASM_SPEC_TESTS_MVP = spec-tests-mvp;
+    WASM_SPEC_TESTS = spec-tests;
+  })

src/Wasm/Binary/Decode.hs

@@ -258,6 +258,10 @@ getMathPrefix = do
     0x05 -> return $ Convert $ I64ConvertOp Int.TruncUSatF32
     0x06 -> return $ Convert $ I64ConvertOp Int.TruncSSatF64
     0x07 -> return $ Convert $ I64ConvertOp Int.TruncUSatF64
+    0x0A -> do (0, 0) <- (,) <$> getWord8 <*> getWord8
+               return MemoryCopy
+    0x0B -> do 0 <- getWord8
+               return MemoryFill
     _    -> fail (printf "getMathPrefix: illegal op %d" byte)
 
 

src/Wasm/Binary/Encode.hs

@@ -384,6 +384,10 @@ putInstr = flip (.) unFix $ \case
   MemoryGrow -> do
     putWord8 0x40
     putWord8 0x00
+  MemoryFill -> do
+    mapM_ putWord8 [0xFC, 0x0B, 0x00]
+  MemoryCopy -> do
+    mapM_ putWord8 [0xFC, 0x0A, 0x00, 0x00]
 
   -- Constants.
   Const (value -> I32 val) -> do

src/Wasm/Exec/Eval.hs

@@ -479,6 +479,48 @@ step(Code cs cfg vs (e:es)) = (`runReaderT` cfg) $ do
                   Right () -> oldSize
           k (I32 result : vs') es
 
+        (MemoryFill, I32 0 : _ : I32 dst : vs') -> {-# SCC step_MemoryFill #-} do
+          inst    <- getFrameInst
+          mem     <- lift $ memory inst (0 @@ at)
+          -- Zero len with offset out-of-bounds at the end of memory is allowed
+          sz      <- lift $ lift $ Memory.size mem
+          if Memory.pageSize * sz >= dst
+            then k vs' es
+            else k vs' (Trapping (memoryErrorString Memory.MemoryBoundsError) @@ at : es)
+
+        (MemoryFill, I32 cnt : v : I32 dst : vs') -> {-# SCC step_MemoryFill #-} do
+          inst    <- getFrameInst
+          mem     <- lift $ memory inst (0 @@ at)
+          let [addr, count] = fromIntegral . i64_extend_u_i32 . fromIntegral <$> [dst, cnt]
+          if addr + count > 2^32
+            then k vs' (Trapping (memoryErrorString Memory.MemoryBoundsError) @@ at : es)
+            else do
+              eres <- lift $ lift $ runExceptT $ mapM_ (\off -> Memory.storePacked Pack8 mem addr off v) [0 .. pred cnt]
+              case eres of
+                Right () -> k vs' es
+                Left exn -> k vs' (Trapping (memoryErrorString exn) @@ at : es)
+
+        (MemoryCopy, I32 0 : I32 src : I32 dst : vs') -> {-# SCC step_MemoryCopy #-} do
+          inst    <- getFrameInst
+          mem     <- lift $ memory inst (0 @@ at)
+          -- Zero len with src/dest offset out-of-bounds at the end of memory is allowed
+          sz      <- lift $ lift $ Memory.size mem
+          if Memory.pageSize * sz >= dst && Memory.pageSize * sz >= src
+            then k vs' es
+            else k vs' (Trapping (memoryErrorString Memory.MemoryBoundsError) @@ at : es)
+
+        (MemoryCopy, I32 cnt : I32 src : I32 dst : vs') -> {-# SCC step_MemoryCopy #-} do
+          inst    <- getFrameInst
+          mem     <- lift $ memory inst (0 @@ at)
+          let [addr_dst, addr_src, count] = fromIntegral . i64_extend_u_i32 . fromIntegral <$> [dst, src, cnt]
+          let range = if dst < src then [0 .. pred cnt] else tail $ enumFromThenTo cnt (pred cnt) 0
+          eres <- lift $ lift $ runExceptT $
+            mapM_ (\addr -> Memory.loadPacked Pack8 ZX mem (addr + pred count) 0 I32Type) [addr_dst, addr_src]
+            >> mapM_ (\off -> Memory.loadPacked Pack8 ZX mem addr_src off I32Type >>= Memory.storePacked Pack8 mem addr_dst off) range
+          case eres of
+            Right () -> k vs' es
+            Left exn -> k vs' (Trapping (memoryErrorString exn) @@ at : es)
+
         (Const v, vs) -> {-# SCC step_Const #-}
           k (value v : vs) es
 

src/Wasm/Runtime/Memory.hs

@@ -24,6 +24,7 @@ module Wasm.Runtime.Memory
   , loadValue
   , exportMemory
   , importMemory
+  , pageSize
   ) where
 
 import           Control.Exception

src/Wasm/Syntax/AST.hs

@@ -94,6 +94,8 @@ data InstrF (phrase :: * -> *) fix
   | Store StoreOp
   | MemorySize
   | MemoryGrow
+  | MemoryFill
+  | MemoryCopy
   | Const (Literal phrase)
   | Test TestOp
   | Compare CompareOp
@@ -135,6 +137,8 @@ instance (NFData1 phrase) => NFData1 (InstrF phrase) where
     Store op -> rnf op
     MemorySize -> ()
     MemoryGrow -> ()
+    MemoryFill -> ()
+    MemoryCopy -> ()
     Const lit -> rnfLift lit
     Test op -> rnf op
     Compare op -> rnf op
@@ -219,6 +223,10 @@ instance (Show1 phrase) => Show1 (InstrF phrase) where
       showString "MemorySize"
     MemoryGrow ->
       showString "MemoryGrow"
+    MemoryFill ->
+      showString "MemoryFill"
+    MemoryCopy ->
+      showString "MemoryCopy"
     Const lit ->
       showString "Const " .
       showLiftPrec 11 lit
@@ -320,12 +328,14 @@ showWasm d ((value -> Fix instr):instrs) = go instr . showString "\n" . showWasm
     Store (MemoryOp I64Type x y (Just Pack8))       -> showString "i64.store8 " . showsPrec d x . showString " " . showsPrec d y
     Store (MemoryOp I64Type x y (Just Pack16))      -> showString "i64.store16 " . showsPrec d x . showString " " . showsPrec d y
     Store (MemoryOp I64Type x y (Just Pack32))      -> showString "i64.store32 " . showsPrec d x . showString " " . showsPrec d y
-    MemorySize                                      -> showString "memory_size"
-    MemoryGrow                                      -> showString "memory_grow"
-    Const (value -> I32 x)                           -> showString "i32.const " . showsPrec d x
-    Const (value -> I64 x)                           -> showString "i64.const " . showsPrec d x
-    Const (value -> F32 x)                           -> showString "f32.const " . showsPrec d x
-    Const (value -> F64 x)                           -> showString "f64.const " . showsPrec d x
+    MemorySize                                      -> showString "memory.size"
+    MemoryGrow                                      -> showString "memory.grow"
+    MemoryFill                                      -> showString "memory.fill"
+    MemoryCopy                                      -> showString "memory.copy"
+    Const (value -> I32 x)                          -> showString "i32.const " . showsPrec d x
+    Const (value -> I64 x)                          -> showString "i64.const " . showsPrec d x
+    Const (value -> F32 x)                          -> showString "f32.const " . showsPrec d x
+    Const (value -> F64 x)                          -> showString "f64.const " . showsPrec d x
     Unary (I32UnaryOp Clz)                          -> showString "i32.clz"
     Unary (I32UnaryOp Ctz)                          -> showString "i32.ctz"
     Unary (I32UnaryOp Popcnt)                       -> showString "i32.popcnt"

src/Wasm/Syntax/DSL.hs

@@ -78,6 +78,8 @@ class Monad (WasmM t) => Wasm t where
   -- Memory operators.
   memory_size :: WasmM t ()
   memory_grow :: WasmM t ()
+  memory_fill :: WasmM t ()
+  memory_copy :: WasmM t ()
 
   -- Constants.
   i32_const :: Int32 -> WasmM t ()
@@ -306,6 +308,8 @@ instance Applicative f => Wasm [Instr f] where
   -- Memory operators.
   memory_size = WasmM $ tell [Fix $ MemorySize]
   memory_grow = WasmM $ tell [Fix $ MemoryGrow]
+  memory_fill = WasmM $ tell [Fix $ MemoryFill]
+  memory_copy = WasmM $ tell [Fix $ MemoryCopy]
 
   -- Constants.
   i32_const x = WasmM $ tell [Fix $ Const (pure (I32 x))]

test/Main.hs

@@ -11,23 +11,69 @@ import Spec as Spec (tests)
 
 main :: IO ()
 main = do
+  mwasmPathMVP <- lookupEnv "WASM_SPEC_TESTS_MVP"
+  testDirMVP <- case mwasmPathMVP of
+      Nothing -> error "Please define WASM_SPEC_TESTS_MVP to point to .../WebAssembly/spec/test/core"
+      Just path -> pure path
   mwasmPath <- lookupEnv "WASM_SPEC_TESTS"
   testDir <- case mwasmPath of
-      Nothing -> error "Please define WASM_SPEC_TESTS to point to .../WebAssebly/spec/test/core"
-      Just path -> return path
+      Nothing -> error "Please define WASM_SPEC_TESTS to point to .../WebAssembly/spec/test/core"
+      Just path -> pure path
+  putStrLn $ "Using wasm MVP spec test directory: " ++ testDirMVP
   putStrLn $ "Using wasm spec test directory: " ++ testDir
+
+  filesMVP <- listDirectory testDirMVP
+  let wastFilesMVP = flip concatMap filesMVP $ \file ->
+        [ testDirMVP ++ "/" ++ file
+        | ".wast" `isSuffixOf` file
+          && file `notElem`
+          [ "inline-module.wast"
+            -- We aren't going to bother fully supporting
+            -- Unicode function names in the reference interpreter yet.
+          , "names.wast"
+          ]
+        ]
+
   files <- listDirectory testDir
   let wastFiles = flip concatMap files $ \file ->
         [ testDir ++ "/" ++ file
         | ".wast" `isSuffixOf` file
-            && "inline-module.wast" /= file
-              -- We aren't going to bother fully supporting
-              -- Unicode function names in the reference interpreter yet.
-            && "names.wast" /= file
+          && file `notElem`
+          [ "inline-module.wast"
+            -- We aren't going to bother fully supporting
+            -- Unicode function names in the reference interpreter yet.
+          , "names.wast"
+            -- These contain features that `winter` won't accept yet
+          , "bulk.wast"
+          , "memory_init.wast"
+          , "ref_null.wast"
+          , "table_get.wast"
+          , "table_grow.wast"
+          , "table.wast"
+          , "ref_is_null.wast"
+          , "ref_func.wast"
+          , "unreached-valid.wast"
+          , "exports.wast"
+          , "imports.wast"
+          , "br_table.wast"
+          , "table_size.wast"
+          , "table_fill.wast"
+          , "table_init.wast"
+          , "table_set.wast"
+          , "table_copy.wast"
+          , "global.wast"
+          , "linking.wast"
+          , "binary-leb128.wast"
+          , "elem.wast"
+          , "call_indirect.wast"
+          , "binary.wast"
+          , "select.wast"
+          ]
         ]
 
   defaultMain $ testGroup "main"
     [ Property.tests
     , Unit.tests
-    , Spec.tests wastFiles
+    , Spec.tests [] "spec MVP" wastFilesMVP
+    , Spec.tests ["--enable-bulk-memory"] "spec" wastFiles
     ]

test/Spec.hs

@@ -17,16 +17,16 @@ import           Wasm.Util.Float (floatToBits, doubleToBits)
 import           SpecTest (spectest)
 import           Wat2Wasm (wat2Wasm)
 
-tests :: [FilePath] -> TestTree
-tests files = testGroup "spec" $ map prep files
+tests :: [String] -> String -> [FilePath] -> TestTree
+tests languageFlags name files = testGroup name $ map prep files
  where
   prep file = testCaseSteps file $ \step -> do
     input <- Prelude.readFile file
     inst  <- spectest
     parseWastFile @(Winter Phrase) @IO file input
       (M.singleton "spectest" 1)
       (IM.singleton 1 inst)
-      wat2Wasm step valListEq assertFailure
+      (wat2Wasm languageFlags) step valListEq assertFailure
 
 valListEq :: [Value] -> [Value] -> Bool
 valListEq vs1 vs2 =

test/Wat2Wasm.hs

@@ -7,18 +7,18 @@ import           System.Exit
 import           System.IO.Temp
 import           System.Process
 
-wat2Wasm :: String -> IO ByteString
-wat2Wasm contents = do
+wat2Wasm :: [String] -> String -> IO ByteString
+wat2Wasm languageFlags contents = do
   wat  <- emptyTempFile "." "test.wat"
   wasm <- emptyTempFile "." "test.wasm"
   writeFile wat contents
   (exit, _out, err) <-
-    readProcessWithExitCode "wat2wasm" [wat, "-o", wasm] ""
+    readProcessWithExitCode "wat2wasm" (wat : languageFlags <> ["-o", wasm]) ""
   case exit of
-    ExitSuccess   -> do
+    ExitSuccess -> do
       res <- BL.readFile wasm
       removeFile wat
       removeFile wasm
-      return res
+      pure res
     ExitFailure _ ->
       fail err