From 89e0fb89edeb82058dc7ee7302f026225bd605ae Mon Sep 17 00:00:00 2001 From: Ilya Rezvov Date: Sat, 24 Feb 2018 12:13:50 -0800 Subject: [PATCH] add instruction type signatures --- src/Language/Wasm/Structure.hs | 3 + src/Language/Wasm/Validate.hs | 124 +++++++++++++++++++++++++++++++++ 2 files changed, 127 insertions(+) diff --git a/src/Language/Wasm/Structure.hs b/src/Language/Wasm/Structure.hs index dbf7f6e..48cbd25 100644 --- a/src/Language/Wasm/Structure.hs +++ b/src/Language/Wasm/Structure.hs @@ -30,6 +30,9 @@ module Language.Wasm.Structure ( ValueType(..), ResultType, Expression, + LabelIndex, + LocalIndex, + GlobalIndex, emptyModule ) where diff --git a/src/Language/Wasm/Validate.hs b/src/Language/Wasm/Validate.hs index c30f336..968f433 100644 --- a/src/Language/Wasm/Validate.hs +++ b/src/Language/Wasm/Validate.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} module Language.Wasm.Validate ( ValidationResult(..), @@ -34,6 +35,129 @@ isValid _ = False type Validator = Module -> ValidationResult +data VType = + Val ValueType + | Var + | LabelRef LabelIndex + | LocalRef LocalIndex + | GlobalRef GlobalIndex + | Any + | Result + deriving (Show, Eq) + +type End = [VType] + +empty :: [ValueType] +empty = [] + +class ToEnd a where + toEnd :: a -> [VType] + +instance ToEnd VType where + toEnd val = [val] + +instance ToEnd ValueType where + toEnd val = [Val val] + +instance ToEnd [ValueType] where + toEnd = map Val + +instance ToEnd [VType] where + toEnd = id + +data Arrow = Arrow End End deriving (Show, Eq) + +(==>) :: (ToEnd a, ToEnd b) => a -> b -> Arrow +(==>) a b = Arrow (toEnd a) (toEnd b) + +getInstrType :: Instruction -> Arrow +getInstrType Unreachable = Any ==> Any +getInstrType Nop = empty ==> empty +getInstrType Block { result } = empty ==> result +getInstrType Loop { result } = empty ==> result +getInstrType If { result } = I32 ==> result +getInstrType (Br lbl) = [Any, LabelRef lbl] ==> Any +getInstrType (BrIf lbl) = [LabelRef lbl, Val I32] ==> LabelRef lbl +getInstrType (BrTable _ lbl) = [Any, LabelRef lbl, Val I32] ==> Any +getInstrType Return = [Any, Result] ==> Any +getInstrType (Call _) = Any ==> Any +getInstrType (CallIndirect _) = [Any, Val I32] ==> Any +getInstrType Drop = Var ==> empty +getInstrType Select = [Var, Var, Val I32] ==> Var +getInstrType (GetLocal local) = empty ==> LocalRef local +getInstrType (SetLocal local) = LocalRef local ==> empty +getInstrType (TeeLocal local) = LocalRef local ==> LocalRef local +getInstrType (GetGlobal global) = empty ==> GlobalRef global +getInstrType (SetGlobal global) = GlobalRef global ==> empty +getInstrType (I32Load _) = I32 ==> I32 +getInstrType (I64Load _) = I32 ==> I64 +getInstrType (F32Load _) = I32 ==> F32 +getInstrType (F64Load _) = I32 ==> F64 +getInstrType (I32Load8S _) = I32 ==> I32 +getInstrType (I32Load8U _) = I32 ==> I32 +getInstrType (I32Load16S _) = I32 ==> I32 +getInstrType (I32Load16U _) = I32 ==> I32 +getInstrType (I64Load8S _) = I32 ==> I64 +getInstrType (I64Load8U _) = I32 ==> I64 +getInstrType (I64Load16S _) = I32 ==> I64 +getInstrType (I64Load16U _) = I32 ==> I64 +getInstrType (I64Load32S _) = I32 ==> I64 +getInstrType (I64Load32U _) = I32 ==> I64 +getInstrType (I32Store _) = [I32, I32] ==> empty +getInstrType (I64Store _) = [I32, I64] ==> empty +getInstrType (F32Store _) = [I32, F32] ==> empty +getInstrType (F64Store _) = [I32, F64] ==> empty +getInstrType (I32Store8 _) = [I32, I32] ==> empty +getInstrType (I32Store16 _) = [I32, I32] ==> empty +getInstrType (I64Store8 _) = [I32, I64] ==> empty +getInstrType (I64Store16 _) = [I32, I64] ==> empty +getInstrType (I64Store32 _) = [I32, I64] ==> empty +getInstrType CurrentMemory = empty ==> I32 +getInstrType GrowMemory = I32 ==> I32 +getInstrType (I32Const _) = empty ==> I32 +getInstrType (I64Const _) = empty ==> I64 +getInstrType (F32Const _) = empty ==> F32 +getInstrType (F64Const _) = empty ==> F64 +getInstrType (IUnOp BS32 _) = I32 ==> I32 +getInstrType (IUnOp BS64 _) = I64 ==> I64 +getInstrType (IBinOp BS32 _) = [I32, I32] ==> I32 +getInstrType (IBinOp BS64 _) = [I64, I64] ==> I64 +getInstrType I32Eqz = I32 ==> I32 +getInstrType I64Eqz = I64 ==> I32 +getInstrType (IRelOp BS32 _) = [I32, I32] ==> I32 +getInstrType (IRelOp BS64 _) = [I64, I64] ==> I32 +getInstrType (FUnOp BS32 _) = F32 ==> F32 +getInstrType (FUnOp BS64 _) = F64 ==> F64 +getInstrType (FBinOp BS32 _) = [F32, F32] ==> F32 +getInstrType (FBinOp BS64 _) = [F64, F64] ==> F64 +getInstrType (FRelOp BS32 _) = [F32, F32] ==> I32 +getInstrType (FRelOp BS64 _) = [F64, F64] ==> I32 +getInstrType I32WrapI64 = I64 ==> I32 +getInstrType (ITruncFU BS32 BS32) = F32 ==> I32 +getInstrType (ITruncFU BS32 BS64) = F64 ==> I32 +getInstrType (ITruncFU BS64 BS32) = F32 ==> I64 +getInstrType (ITruncFU BS64 BS64) = F64 ==> I64 +getInstrType (ITruncFS BS32 BS32) = F32 ==> I32 +getInstrType (ITruncFS BS32 BS64) = F64 ==> I32 +getInstrType (ITruncFS BS64 BS32) = F32 ==> I64 +getInstrType (ITruncFS BS64 BS64) = F64 ==> I64 +getInstrType I64ExtendSI32 = I32 ==> I64 +getInstrType I64ExtendUI32 = I32 ==> I64 +getInstrType (FConvertIU BS32 BS32) = I32 ==> F32 +getInstrType (FConvertIU BS32 BS64) = I64 ==> F32 +getInstrType (FConvertIU BS64 BS32) = I32 ==> F64 +getInstrType (FConvertIU BS64 BS64) = I64 ==> F64 +getInstrType (FConvertIS BS32 BS32) = I32 ==> F32 +getInstrType (FConvertIS BS32 BS64) = I64 ==> F32 +getInstrType (FConvertIS BS64 BS32) = I32 ==> F64 +getInstrType (FConvertIS BS64 BS64) = I64 ==> F64 +getInstrType F32DemoteF64 = F64 ==> F32 +getInstrType F64PromoteF32 = F32 ==> F64 +getInstrType (IReinterpretF BS32) = F32 ==> I32 +getInstrType (IReinterpretF BS64) = F64 ==> I64 +getInstrType (FReinterpretI BS32) = I32 ==> F32 +getInstrType (FReinterpretI BS64) = I64 ==> F64 + tablesShouldBeValid :: Validator tablesShouldBeValid Module { imports, tables } = let tableImports = filter isTableImport imports in