syntax support for ref.ops and pass ref_null.wast

src/Language/Wasm/Interpreter.hs

@@ -70,6 +70,8 @@ data Value =
     | VI64 Word64
     | VF32 Float
     | VF64 Double
+    | RF (Maybe Natural)
+    | RE (Maybe Natural)
     deriving (Eq, Show)
 
 asInt32 :: Word32 -> Int32
@@ -187,6 +189,8 @@ getValueType (VI32 _) = I32
 getValueType (VI64 _) = I64
 getValueType (VF32 _) = F32
 getValueType (VF64 _) = F64
+getValueType (RF _) = Func
+genValueType (RE _) = Extern
 
 data ExportInstance = ExportInstance TL.Text ExternalValue deriving (Eq, Show)
 
@@ -422,6 +426,9 @@ evalConstExpr _ _ [I32Const v] = return $ VI32 v
 evalConstExpr _ _ [I64Const v] = return $ VI64 v
 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 store [GetGlobal i] = getGlobalValue inst store i
 evalConstExpr _ _ instrs = error $ "Global initializer contains unsupported instructions: " ++ show instrs
 
@@ -718,6 +725,15 @@ eval budget store FunctionInstance { funcType, moduleInstance, code = Function {
                         Just res -> return $ Done ctx { stack = reverse res ++ (drop (length params) rest) }
                         Nothing -> return Trap
                 Nothing -> return Trap
+        step ctx@EvalCtx{ stack = st } (RefNull FuncRef) =
+            return $ Done ctx { stack = RF Nothing : st }
+        step ctx@EvalCtx{ stack = st } (RefNull ExternRef) =
+            return $ Done ctx { stack = RE Nothing : st }
+        step ctx@EvalCtx{ stack = v:rest } RefIsNull =
+            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 }
         step ctx@EvalCtx{ stack = (_:rest) } Drop = return $ Done ctx { stack = rest }
         step ctx@EvalCtx{ stack = (VI32 test:val2:val1:rest) } Select =
             if test == 0

src/Language/Wasm/Parser.y

@@ -119,6 +119,8 @@ import Language.Wasm.Lexer (
 'f64'                 { Lexeme _ (TKeyword "f64") }
 'mut'                 { Lexeme _ (TKeyword "mut") }
 'funcref'             { Lexeme _ (TKeyword "funcref") }
+'externref'           { Lexeme _ (TKeyword "externref") }
+'extern'              { Lexeme _ (TKeyword "extern") }
 'type'                { Lexeme _ (TKeyword "type") }
 'unreachable'         { Lexeme _ (TKeyword "unreachable") }
 'nop'                 { Lexeme _ (TKeyword "nop") }
@@ -128,6 +130,9 @@ import Language.Wasm.Lexer (
 'return'              { Lexeme _ (TKeyword "return") }
 'call'                { Lexeme _ (TKeyword "call") }
 'call_indirect'       { Lexeme _ (TKeyword "call_indirect") }
+'ref.null'            { Lexeme _ (TKeyword "ref.null") }
+'ref.is_null'         { Lexeme _ (TKeyword "ref.is_null") }
+'ref.func'            { Lexeme _ (TKeyword "ref.func") }
 'drop'                { Lexeme _ (TKeyword "drop") }
 'select'              { Lexeme _ (TKeyword "select") }
 'get_local'           { Lexeme _ (TKeyword "local.get") }
@@ -363,6 +368,8 @@ valtype :: { ValueType }
     | 'i64' { I64 }
     | 'f32' { F32 }
     | 'f64' { F64 }
+    | 'funcref' { Func }
+    | 'externref' { Extern }
 
 index :: { Index }
     : u32 { Index $1 }
@@ -418,6 +425,10 @@ plaininstr :: { PlainInstr }
     | 'call' index                   { Call $2 }
     | 'drop'                         { Drop }
     | 'select'                       { Select }
+    -- reference instructions
+    | 'ref.null' heaptype            { RefNull $2 }
+    | 'ref.is_null'                  { RefIsNull }
+    | 'ref.func' index               { RefFunc $2 }
     -- variable instructions
     | 'get_local' index              { GetLocal $2 }
     | 'set_local' index              { SetLocal $2 }
@@ -856,6 +867,11 @@ limits :: { Limit }
 
 elemtype :: { ElemType }
     : 'funcref' { FuncRef }
+    | 'externref' { ExternRef }
+
+heaptype :: { ElemType }
+    : 'func' { FuncRef }
+    | 'extern' { ExternRef }
 
 tabletype :: { TableType }
     : limits elemtype { TableType $1 $2 }
@@ -1116,6 +1132,10 @@ data PlainInstr =
     | Return
     | Call FuncIndex
     | CallIndirect TypeUse
+    -- Reference instructions
+    | RefNull ElemType
+    | RefIsNull
+    | RefFunc FuncIndex
     -- Parametric instructions
     | Drop
     | Select
@@ -1376,6 +1396,7 @@ constInstructionToValue (PlainInstr (I32Const v)) = S.I32Const $ integerToWord32
 constInstructionToValue (PlainInstr (F32Const v)) = S.F32Const v
 constInstructionToValue (PlainInstr (I64Const v)) = S.I64Const $ integerToWord64 v
 constInstructionToValue (PlainInstr (F64Const v)) = S.F64Const v
+constInstructionToValue (PlainInstr (RefNull et)) = S.RefNull et
 constInstructionToValue _ = error "Only const instructions supported as arguments for actions"
 
 desugarize :: [ModuleField] -> Either String S.Module
@@ -1562,6 +1583,12 @@ desugarize fields = do
                 Nothing -> Left "unknown type"
         synInstrToStruct _ (PlainInstr Drop) = return $ S.Drop
         synInstrToStruct _ (PlainInstr Select) = return $ S.Select
+        synInstrToStruct _ (PlainInstr (RefNull elType)) = return $ S.RefNull elType
+        synInstrToStruct _ (PlainInstr RefIsNull) = return $ S.RefIsNull
+        synInstrToStruct FunCtx { ctxMod } (PlainInstr (RefFunc funIdx)) =
+            case getFuncIndex ctxMod funIdx of
+                Just idx -> return $ S.RefFunc idx
+                Nothing -> Left "unknown function"
         synInstrToStruct ctx (PlainInstr (GetLocal localIdx)) =
             case getLocalIndex ctx localIdx of
                 Just idx -> return $ S.GetLocal idx

src/Language/Wasm/Script.hs

@@ -122,6 +122,8 @@ runScript onAssertFail script = do
         asArg [Struct.F32Const v] = Interpreter.VF32 v
         asArg [Struct.I64Const v] = Interpreter.VI64 v
         asArg [Struct.F64Const v] = Interpreter.VF64 v
+        asArg [Struct.RefNull Struct.FuncRef] = Interpreter.RF Nothing
+        asArg [Struct.RefNull Struct.ExternRef] = Interpreter.RE Nothing
         asArg _                   = error "Only const instructions supported as arguments for actions"
 
         runAction :: ScriptState -> Action -> IO (Maybe [Interpreter.Value])
@@ -139,6 +141,8 @@ runScript onAssertFail script = do
         isValueEqual (Interpreter.VI64 v1) (Interpreter.VI64 v2) = v1 == v2
         isValueEqual (Interpreter.VF32 v1) (Interpreter.VF32 v2) = (isNaN v1 && isNaN v2) || identicalIEEE v1 v2
         isValueEqual (Interpreter.VF64 v1) (Interpreter.VF64 v2) = (isNaN v1 && isNaN v2) || identicalIEEE v1 v2
+        isValueEqual (Interpreter.RF f1) (Interpreter.RF f2) = f1 == f2
+        isValueEqual (Interpreter.RE e1) (Interpreter.RE e2) = e1 == e2
         isValueEqual _ _ = False
 
         isNaNReturned :: Action -> Assertion -> AssertM ()

src/Language/Wasm/Structure.hs

@@ -108,6 +108,8 @@ data ValueType =
     | I64
     | F32
     | F64
+    | Func
+    | Extern
     deriving (Show, Eq, Generic, NFData)
 
 type ResultType = [ValueType]
@@ -134,6 +136,10 @@ data Instruction index =
     | Return
     | Call index
     | CallIndirect index
+    -- Reference instructions
+    | RefNull ElemType
+    | RefIsNull
+    | RefFunc index
     -- Parametric instructions
     | Drop
     | Select
@@ -207,7 +213,7 @@ data Function = Function {
 
 data Limit = Limit Natural (Maybe Natural) deriving (Show, Eq, Generic, NFData)
 
-data ElemType = FuncRef deriving (Show, Eq, Generic, NFData)
+data ElemType = FuncRef | ExternRef deriving (Show, Eq, Generic, NFData)
 
 data TableType = TableType Limit ElemType deriving (Show, Eq, Generic, NFData)
 

src/Language/Wasm/Validate.hs

@@ -258,6 +258,16 @@ getInstrType Drop = do
 getInstrType Select = do
     var <- freshVar
     return $ [var, var, Val I32] ==> var
+getInstrType (RefNull elType) = do
+    let t = case elType of { FuncRef -> Func; ExternRef -> Extern }
+    return $ empty ==> Val t
+getInstrType RefIsNull = do
+    return $ empty ==> Val I32
+getInstrType (RefFunc funIdx) = do
+    Ctx { funcs } <- ask
+    if fromIntegral funIdx < length funcs
+    then return $ empty ==> Val I32
+    else throwError FunctionIndexOutOfRange
 getInstrType (GetLocal local) = do
     Ctx { locals }  <- ask
     t <- maybeToEither (LocalIndexOutOfRange local) $ locals !? local
@@ -445,6 +455,8 @@ isConstExpression ((I32Const _):rest) = isConstExpression rest
 isConstExpression ((I64Const _):rest) = isConstExpression rest
 isConstExpression ((F32Const _):rest) = isConstExpression rest
 isConstExpression ((F64Const _):rest) = isConstExpression rest
+isConstExpression ((RefNull _):rest) = isConstExpression rest
+isConstExpression ((RefFunc _):rest) = isConstExpression rest
 isConstExpression ((GetGlobal idx):rest) = do
     Ctx {globals, importedGlobals} <- ask
     if importedGlobals <= idx

tests/Test.hs

@@ -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 = ["const.wast"]
+  let files = ["ref_null.wast", "ref_is_null.wast"]
   scriptTestCases <- (`mapM` files) $ \file -> do
     test <- LBS.readFile ("tests/spec/" ++ file)
     return $ testCase file $ do