Support multi-value

by cargo-culting
WebAssembly/spec@484180b

This fixes #14

src/Wasm/Binary/Decode.hs

@@ -17,6 +17,7 @@ import           Data.ByteString.Lazy
 import           Data.Fix
 import           Data.Functor.Identity
 import           Data.Int
+import           Data.Bits
 import           Data.List                     as List
 import qualified Data.Vector                   as V
 import           Data.Text.Lazy
@@ -77,7 +78,7 @@ getText :: Int -> Get Text
 getText budget = do
   bytes <- getByteSlice budget
   case decodeUtf8' bytes of
-    Left  _    -> fail "getText: invalid UTF-8 encoding"
+    Left  _    -> fail "getText: malformed UTF-8 encoding"
     Right text -> return text
 
 getValueType :: Get ValueType
@@ -88,30 +89,22 @@ getValueType = do
     0x7E -> return I64Type
     0x7D -> return F32Type
     0x7C -> return F64Type
-    _    -> fail $ printf "getValueType: invalid value type: 0x%02X" byte
+    _    -> fail $ printf "getValueType: malformed value type: 0x%02X" byte
 
 getElemType :: Get ElemType
 getElemType = do
   byte <- getWord8
   case byte of
     0x70 -> return AnyFuncType
-    _    -> fail $ printf "getElemType: invalid element type: 0x%02X" byte
+    _    -> fail $ printf "getElemType: malformed element type: 0x%02X" byte
 
 getStackType :: Get StackType
-getStackType = do
-  byte <- getWord8
-  case byte of
-    0x40 -> return []
-    0x7F -> return [I32Type]
-    0x7E -> return [I64Type]
-    0x7D -> return [F32Type]
-    0x7C -> return [F64Type]
-    _    -> fail $ printf "getStackType: invalid stack type: 0x%02X" byte
+getStackType = getList 32 getValueType
 
 getFuncType :: Get FuncType
 getFuncType = do
   byteGuard 0x60
-  FuncType <$> getList 32 getValueType <*> getList 32 getValueType
+  FuncType <$> getStackType <*> getStackType
 
 getLimits :: Get (Limits Int32)
 getLimits = do
@@ -129,7 +122,7 @@ getMutability = do
   case byte of
     0x00 -> return Immutable
     0x01 -> return Mutable
-    _    -> fail $ printf "getMutability: invalid mutability type: 0x%02X" byte
+    _    -> fail $ printf "getMutability: malformed mutability type: 0x%02X" byte
 
 getTableType :: Get TableType
 getTableType = TableType <$> getElemType <*> getLimits
@@ -165,6 +158,16 @@ getFunc = do
 {-# SPECIALIZE getFunc :: Get (Func Identity) #-}
 {-# SPECIALIZE getFunc :: Get (Func Phrase) #-}
 
+getBlockType :: Decodable phrase => Get (BlockType phrase)
+getBlockType = do
+  byte <- lookAhead getWord8
+  case byte of
+    0x40 ->
+         ValBlockType Nothing <$ skip 1
+    _ | byte .&. 0xc0 == 0x40 ->
+         ValBlockType . Just <$> getValueType
+    _ -> VarBlockType <$> getVar
+
 getLocals :: Get [ValueType]
 getLocals = do
   n <- getULEB128 32
@@ -203,7 +206,7 @@ getImportDesc = do
     0x02 -> MemoryImport <$> getMemoryType
     0x03 -> GlobalImport <$> getGlobalType
     _    -> fail
-      $ printf "getImportDesc: invalid import description type: 0x%02X" byte
+      $ printf "getImportDesc: malformed import description type: 0x%02X" byte
 
 {-# SPECIALIZE getImportDesc :: Get (ImportDesc Identity) #-}
 {-# SPECIALIZE getImportDesc :: Get (ImportDesc Phrase) #-}
@@ -252,17 +255,17 @@ getInstr = Fix <$> do
     0x00 -> return Unreachable
     0x01 -> return Nop
     0x02 -> do
-      result <- getStackType
+      result <- getBlockType
       expr   <- getInstrBlock
       byteGuard 0x0B
       return $ Block result expr
     0x03 -> do
-      result <- getStackType
+      result <- getBlockType
       expr   <- getInstrBlock
       byteGuard 0x0B
       return $ Loop result expr
     0x04 -> do
-      condition   <- getStackType
+      condition   <- getBlockType
       consequent  <- getInstrBlock
       alternative <- getAlternative <|> return []
       byteGuard 0x0B
@@ -611,7 +614,7 @@ getSection code def parser = do
           getSection code def parser
         else if
           | byte > 0x0B -> fail
-          $ printf "getSection: invalid section code: 0x%02X" byte
+          $ printf "getSection: malformed section code: 0x%02X" byte
           | byte > code -> return def
           | byte < code -> fail
           $ printf "getSection: unexpected section code: 0x%02X" byte

src/Wasm/Binary/Encode.hs

@@ -65,18 +65,13 @@ putElemType :: ElemType -> Put
 putElemType AnyFuncType = putWord8 0x70
 
 putStackType :: StackType -> Put
-putStackType = \case
-  []          -> putWord8 0x40
-  I32Type : _ -> putWord8 0x7F
-  I64Type : _ -> putWord8 0x7E
-  F32Type : _ -> putWord8 0x7D
-  F64Type : _ -> putWord8 0x7C
+putStackType = putList putValueType
 
 putFuncType :: FuncType -> Put
 putFuncType FuncType {..} = do
   putWord8 0x60
-  putList putValueType _funcInput
-  putList putValueType _funcOutput
+  putStackType _funcInput
+  putStackType _funcOutput
 
 putLimits :: Limits Int32 -> Put
 putLimits Limits {..} = do
@@ -109,6 +104,12 @@ putVar = liftPut putULEB128
 {-# SPECIALIZE putVar :: Var Identity -> Put #-}
 {-# SPECIALIZE putVar :: Var Phrase -> Put #-}
 
+putBlockType :: Encodable phrase => BlockType phrase -> Put
+putBlockType = \case
+  VarBlockType x -> putVar x
+  ValBlockType Nothing -> putWord8 0x40
+  ValBlockType (Just t) -> putValueType t
+
 putGlobal :: Encodable phrase => Global phrase -> Put
 putGlobal Global {..} = do
   putGlobalType _globalType
@@ -225,17 +226,17 @@ putInstr = flip (.) unFix $ \case
   Nop               -> putWord8 0x01
   Block result expr -> do
     putWord8 0x02
-    putStackType result
+    putBlockType result
     putInstrBlock expr
     putWord8 0x0B
   Loop result expr -> do
     putWord8 0x03
-    putStackType result
+    putBlockType result
     putInstrBlock expr
     putWord8 0x0B
-  If condition consequent alternative -> do
+  If result consequent alternative -> do
     putWord8 0x04
-    putStackType condition
+    putBlockType result
     putInstrBlock consequent
     putAlternative alternative
     putWord8 0x0B

src/Wasm/Exec/Eval.hs

@@ -131,7 +131,7 @@ gives a significant performance boost.
 The correspondence between their and our 'Code' type is the following:
 
     Wasm:   (vs1, Label n les (vs2, es2) :: es1)
-    Winter: Code cfg1 (Label n les les (Code … cfg2 vs1 es1)) vs2 es2
+    Winter: Code (Label n les (Code … cfg2 vs1 es1)) cfg1 vs2 es2
 
 The point is that now es2 (the instruction to execute next) is nicely exposed
 for O(1) analsys, instead of hidden deep in the Code data structure. On
@@ -279,13 +279,27 @@ funcElem :: (Regioned f, PrimMonad m)
 funcElem = elem
 {-# INLINE funcElem #-}
 
+blockType :: (Regioned f, PrimMonad m)
+          => ModuleInst f m -> BlockType f -> EvalT m FuncType
+blockType inst = \case
+  VarBlockType x -> type_ inst x
+  ValBlockType Nothing -> return $ FuncType [] []
+  ValBlockType (Just t) -> return $ FuncType [] [t]
+
 takeFrom :: Monad m
          => Int -> Stack a -> Region -> EvalT m (Stack a)
 takeFrom n vs at' =
   if n > length vs
   then throwError $ EvalCrashError at' "stack underflow"
   else pure $ take n vs
 
+splitFrom :: Monad m
+         => Int -> Stack a -> Region -> EvalT m (Stack a, Stack a)
+splitFrom n vs at' =
+  if n > length vs
+  then throwError $ EvalCrashError at' "stack underflow"
+  else pure $ splitAt n vs
+
 partialZip :: [a] -> [b] -> [Either a (Either b (a, b))]
 partialZip [] [] = []
 partialZip xs [] = map Left xs
@@ -334,18 +348,24 @@ step(Code cs cfg vs (e:es)) = (`runReaderT` cfg) $ do
           k vs (Trapping "unreachable executed" @@ at : es)
         (Nop, vs)                      -> {-# SCC step_Nop #-}
           k vs es
-        (Block ts es', vs)             -> {-# SCC step_Block #-}
+        (Block bt es', vs)             -> {-# SCC step_Block #-} do
+          inst <- getFrameInst
+          FuncType ts1 ts2 <- lift $ blockType inst bt
+          (args, vs') <- lift $ splitFrom (length ts1) vs at
           return $ Code
-            (Label (length ts) id (Code cs cfg vs es))
-            cfg [] (map plain es')
-        (Loop _ es', vs)               -> {-# SCC step_Loop #-}
+            (Label (length ts2) id (Code cs cfg vs' es))
+            cfg args (map plain es')
+        (Loop bt es', vs)               -> {-# SCC step_Loop #-} do
+          inst <- getFrameInst
+          FuncType ts1 _ts2 <- lift $ blockType inst bt
+          (args, vs') <- lift $ splitFrom (length ts1) vs at
           return $ Code
-            (Label 0 (e :) (Code cs cfg vs es))
-            cfg [] (map plain es')
-        (If ts _ es2, I32 0 : vs')     -> {-# SCC step_If1 #-}
-          k vs' (Plain (Fix (Block ts es2)) @@ at : es)
-        (If ts es1 _, I32 _ : vs')     -> {-# SCC step_If2 #-}
-          k vs' (Plain (Fix (Block ts es1)) @@ at : es)
+            (Label (length ts1) (e :) (Code cs cfg vs' es))
+            cfg args (map plain es')
+        (If bt _ es2, I32 0 : vs')     -> {-# SCC step_If1 #-}
+          k vs' (Plain (Fix (Block bt es2)) @@ at : es)
+        (If bt es1 _, I32 _ : vs')     -> {-# SCC step_If2 #-}
+          k vs' (Plain (Fix (Block bt es1)) @@ at : es)
         (Br x, vs)                     -> {-# SCC step_Br #-}
           k [] (Breaking (value x) vs @@ at : es)
         (BrIf _, I32 0 : vs')          -> {-# SCC step_BrIf1 #-}
@@ -548,13 +568,11 @@ step(Code cs cfg vs (e:es)) = (`runReaderT` cfg) $ do
         when (budget == 0) $
           throwError $ EvalExhaustionError at "call stack exhausted"
 
-        let FuncType ins outs = Func.typeOf func
-            n = length ins
+        let FuncType ins out = Func.typeOf func
+            n1 = length ins
+            n2 = length out
 
-        (reverse -> args, vs') <-
-          if n > length vs
-          then throwError $ EvalCrashError at "stack underflow"
-          else pure $ splitAt n vs
+        (reverse -> args, vs') <- lift $ splitFrom n1 vs at
 
         -- traceM $ "Invoke: ins  = " ++ show ins
         -- traceM $ "Invoke: args = " ++ show args
@@ -568,17 +586,22 @@ step(Code cs cfg vs (e:es)) = (`runReaderT` cfg) $ do
             inst' <- getInst ref
             locals' <- traverse newMutVar $ V.fromList $
               args ++ map defaultValue (value f^.funcLocals)
+            let cfg' = cfg & configFrame .~ Frame inst' locals' & configBudget %~ pred
+            {-
             return $ Code
-                (Framed (length outs) (Code cs cfg vs' es))
-                (cfg & configFrame .~ Frame inst' locals' & configBudget %~ pred)
+                (Framed n2 (Code cs cfg vs' es))
                 []
-                [Plain (Fix (Block outs (value f^.funcBody))) @@ region f]
+                [Plain (Fix (Block out (value f^.funcBody))) @@ region f]
+            -}
+            return $ Code
+              (Label n2 id (Code (Framed n2 (Code cs cfg vs' es)) cfg' [] []))
+              cfg' [] (map plain (value f^.funcBody))
 
           Func.HostFunc _ f -> do
             -- jww (2018-11-01): Need an exception handler here, so we can
             -- report host errors.
             let res = reverse (f args)
-            lift $ checkTypes at outs res
+            lift $ checkTypes at out res
             k (res ++ vs') es
             -- try (reverse (f args) ++ vs', [])
             -- with Crash (_, msg) -> EvalCrashError at msg)
@@ -590,7 +613,7 @@ step(Code cs cfg vs (e:es)) = (`runReaderT` cfg) $ do
             case res' of
               Left err -> throwError $ EvalTrapError at err
               Right (reverse -> res) -> do
-                lift $ checkTypes at outs res
+                lift $ checkTypes at out res
                 k (res ++ vs') es
                 -- try (reverse (f args) ++ vs', [])
                 -- with Crash (_, msg) -> EvalCrashError at msg)

src/Wasm/Syntax/AST.hs

@@ -55,14 +55,30 @@ _Type = traverse
 {-# SPECIALIZE _Type :: Traversal' (Type Identity) FuncType #-}
 {-# SPECIALIZE _Type :: Traversal' (Type Phrase) FuncType #-}
 
+data BlockType phrase = VarBlockType (Var phrase) | ValBlockType (Maybe ValueType)
+
+instance (NFData1 phrase) => NFData (BlockType phrase) where
+  rnf = \case
+    VarBlockType var -> rnfLift var
+    ValBlockType vt -> rnf vt
+
+instance (Show1 phrase) => Show (BlockType phrase) where
+  showsPrec d = showParen (d > 10) . \case
+    VarBlockType var ->
+      showString "VarBlockType " .
+      showLiftPrec 11 var
+    ValBlockType vt ->
+      showString "ValBlockType " .
+      showPrec 11 vt
+
 data InstrF (phrase :: * -> *) fix
   = Unreachable
   | Nop
   | Drop
   | Select
-  | Block StackType [phrase fix]
-  | Loop StackType [phrase fix]
-  | If StackType [phrase fix] [phrase fix]
+  | Block (BlockType phrase) [phrase fix]
+  | Loop (BlockType phrase) [phrase fix]
+  | If (BlockType phrase) [phrase fix] [phrase fix]
   | Br (Var phrase)
   | BrIf (Var phrase)
   | BrTable [Var phrase] (Var phrase)

src/Wasm/Syntax/DSL.hs

@@ -24,10 +24,11 @@ class Monad (WasmM t) => Wasm t where
   -- Control flow operators.
   unreachable :: WasmM t Void
   nop :: WasmM t ()
-  block :: [ValueType] -> WasmM t a -> WasmM t ()
-  loop :: [ValueType] -> WasmM t a -> WasmM t ()
-  if_ :: [ValueType] -> WasmM t a -> WasmM t ()
-  if_else_ :: [ValueType] -> WasmM t a -> WasmM t a -> WasmM t ()
+  -- This only allows pre-multi-value blocks
+  block :: Maybe ValueType -> WasmM t a -> WasmM t ()
+  loop :: Maybe ValueType -> WasmM t a -> WasmM t ()
+  if_ :: Maybe ValueType -> WasmM t a -> WasmM t ()
+  if_else_ :: Maybe ValueType -> WasmM t a -> WasmM t a -> WasmM t ()
   br :: Int -> WasmM t ()
   br_if :: Int -> WasmM t ()
   br_table :: [Int] -> Int -> WasmM t ()
@@ -251,10 +252,10 @@ instance Applicative f => Wasm [Instr f] where
   -- Control flow operators.
   unreachable    = WasmM $ error "unreachable!" <$ tell [Fix Unreachable]
   nop            = WasmM $ tell [Fix Nop]
-  block l b      = WasmM $ tell [Fix $ Block l (map pure (execWriter (runWasmM b)))]
-  loop l b       = WasmM $ tell [Fix $ Loop l (map pure (execWriter (runWasmM b)))]
-  if_ l x        = WasmM $ tell [Fix $ If l (map pure (execWriter (runWasmM x))) [pure (Fix Nop)]]
-  if_else_ l x y = WasmM $ tell [Fix $ If l (map pure (execWriter (runWasmM x)))
+  block l b      = WasmM $ tell [Fix $ Block (ValBlockType l) (map pure (execWriter (runWasmM b)))]
+  loop l b       = WasmM $ tell [Fix $ Loop (ValBlockType l) (map pure (execWriter (runWasmM b)))]
+  if_ l x        = WasmM $ tell [Fix $ If (ValBlockType l) (map pure (execWriter (runWasmM x))) [pure (Fix Nop)]]
+  if_else_ l x y = WasmM $ tell [Fix $ If (ValBlockType l) (map pure (execWriter (runWasmM x)))
                               (map pure (execWriter (runWasmM y)))]
   br n           = WasmM $ tell [Fix $ Br (pure n)]
   br_if n        = WasmM $ tell [Fix $ BrIf (pure n)]

test/Wat2Wasm.hs

@@ -13,7 +13,7 @@ wat2Wasm contents = do
   wasm <- emptyTempFile "." "test.wasm"
   writeFile wat contents
   (exit, _out, err) <-
-    readProcessWithExitCode "wat2wasm" [wat, "-o", wasm] ""
+    readProcessWithExitCode "wat2wasm" ["--enable-multi-value", wat, "-o", wasm] ""
   case exit of
     ExitSuccess   -> do
       res <- BL.readFile wasm