msyds/haskell-wasm
1
0
Fork 0
forked from GitHub/haskell-wasm
Code Pull Requests Activity

implemented assert_malformed assertion and added NFData instances for all parsing types

Browse Source
This commit is contained in:
Ilya Rezvov
2018-04-15 16:16:11 -07:00
parent 73124a3eff
commit 09f4b15d2c
6 changed files with 85 additions and 56 deletions
Download Patch File Download Diff File Expand all files Collapse all files
README.md
+6
View File
@@ -20,3 +20,9 @@
* [ ] Compile Core Tests to Tasty test cases and pass all tests
* [ ] Command line tool for calling interpreter/compiler/validator
* [ ] Codegen interface for type enforced generating valid WASM code
## Development
Clond sources to directory and use `stack` for running tests:
```
stack && stack test
```
src/Language/Wasm/Binary.hs
+13 -8
View File
@@ -96,8 +96,10 @@ skipCustomSection :: Get ()
skipCustomSection = do
byteGuard 0x00
size <- getULEB128
getByteString size
return ()
content <- getByteString size
case runGet getName content of
Right _name -> return ()
Left _ -> fail "invalid UTF-8 encoding"
getSection :: SectionType -> Get a -> a -> Get a
getSection sectionType parser def = do
@@ -111,6 +113,7 @@ getSection sectionType parser def = do
parseSection op
| op == 0 = skipCustomSection >> getSection sectionType parser def
| op == fromEnum sectionType = getWord8 >> (getULEB128 :: Get Natural) >> parser
| op > fromEnum DataSection = fail "invalid section id"
| op > fromEnum sectionType = return def
| otherwise =
fail $ "Incorrect order of sections. Expected " ++ show sectionType
@@ -126,7 +129,9 @@ getName :: Get TL.Text
getName = do
len <- getULEB128
bytes <- getLazyByteString len
return $ TLEncoding.decodeUtf8 bytes
case TLEncoding.decodeUtf8' bytes of
Right name -> return name
Left _ -> fail "invalid UTF-8 encoding"
putResultType :: ResultType -> Put
putResultType [] = putWord8 0x40
@@ -230,7 +235,7 @@ instance Serialize GlobalType where
case op of
0x00 -> return $ Const valType
0x01 -> return $ Mut valType
_ -> fail "Unexpected byte in place of Global type opcode"
_ -> fail "invalid mutability"
instance Serialize ImportDesc where
put (ImportFunc typeIdx) = putWord8 0x00 >> putULEB128 typeIdx
@@ -770,10 +775,10 @@ instance Serialize Module where
putSection DataSection $ putVec $ datas mod
get = do
-- magic
mapM_ byteGuard [0x00, 0x61, 0x73, 0x6D]
-- version
mapM_ byteGuard [0x01, 0x00, 0x00, 0x00]
magic <- getWord32be
if magic == 0x0061736D then return () else fail "magic header not detected"
version <- getWord32be
if version == 0x01000000 then return () else fail "unknown binary version"
types <- getSection TypeSection getVec []
imports <- getSection ImportSection getVec []
funcTypes <- getSection FunctionSection getVec []
src/Language/Wasm/Parser.y
+25 -21
View File
@@ -3,6 +3,8 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
module Language.Wasm.Parser (
parseModule,
@@ -73,6 +75,8 @@ import Data.Word (Word32, Word64)
import Data.Bits ((.|.))
import Numeric.IEEE (infinity, nan)
import Language.Wasm.FloatUtils (doubleToFloat)
import Control.DeepSeq (NFData)
import GHC.Generics (Generic)
import Language.Wasm.Lexer (
Token (
@@ -1143,7 +1147,7 @@ integerToWord64 i
| i < 0 && i >= -(2 ^ 63) = 0xFFFFFFFFFFFFFFFF - (fromIntegral (abs i)) + 1
| otherwise = error "I64 is out of bounds."
data FuncType = FuncType { params :: [ParamType], results :: [ValueType] } deriving (Show, Eq)
data FuncType = FuncType { params :: [ParamType], results :: [ValueType] } deriving (Show, Eq, Generic, NFData)
emptyFuncType :: FuncType
emptyFuncType = FuncType [] []
@@ -1151,11 +1155,11 @@ emptyFuncType = FuncType [] []
data ParamType = ParamType {
ident :: Maybe Ident,
paramType :: ValueType
} deriving (Show, Eq)
} deriving (Show, Eq, Generic, NFData)
newtype Ident = Ident TL.Text deriving (Show, Eq)
newtype Ident = Ident TL.Text deriving (Show, Eq, Generic, NFData)
data Index = Named Ident | Index Natural deriving (Show, Eq)
data Index = Named Ident | Index Natural deriving (Show, Eq, Generic, NFData)
type LabelIndex = Index
type FuncIndex = Index
@@ -1234,14 +1238,14 @@ data PlainInstr =
| F64PromoteF32
| IReinterpretF BitSize
| FReinterpretI BitSize
deriving (Show, Eq)
deriving (Show, Eq, Generic, NFData)
data TypeDef = TypeDef (Maybe Ident) FuncType deriving (Show, Eq)
data TypeDef = TypeDef (Maybe Ident) FuncType deriving (Show, Eq, Generic, NFData)
data TypeUse =
IndexedTypeUse TypeIndex (Maybe FuncType)
| AnonimousTypeUse FuncType
deriving (Show, Eq)
deriving (Show, Eq, Generic, NFData)
data Instruction =
PlainInstr PlainInstr
@@ -1261,25 +1265,25 @@ data Instruction =
trueBranch :: [Instruction],
falseBranch :: [Instruction]
}
deriving (Show, Eq)
deriving (Show, Eq, Generic, NFData)
data Import = Import {
sourceModule :: TL.Text,
name :: TL.Text,
desc :: ImportDesc
} deriving (Show, Eq)
} deriving (Show, Eq, Generic, NFData)
data ImportDesc =
ImportFunc (Maybe Ident) TypeUse
| ImportTable (Maybe Ident) TableType
| ImportMemory (Maybe Ident) Limit
| ImportGlobal (Maybe Ident) GlobalType
deriving (Show, Eq)
deriving (Show, Eq, Generic, NFData)
data LocalType = LocalType {
ident :: Maybe Ident,
localType :: ValueType
} deriving (Show, Eq)
} deriving (Show, Eq, Generic, NFData)
data Function = Function {
ident :: Maybe Ident,
@@ -1287,7 +1291,7 @@ data Function = Function {
locals :: [LocalType],
body :: [Instruction]
}
deriving (Show, Eq)
deriving (Show, Eq, Generic, NFData)
emptyFunction :: Function
emptyFunction =
@@ -1303,40 +1307,40 @@ data Global = Global {
globalType :: GlobalType,
initializer :: [Instruction]
}
deriving (Show, Eq)
deriving (Show, Eq, Generic, NFData)
data Memory = Memory (Maybe Ident) Limit deriving (Show, Eq)
data Memory = Memory (Maybe Ident) Limit deriving (Show, Eq, Generic, NFData)
data Table = Table (Maybe Ident) TableType deriving (Show, Eq)
data Table = Table (Maybe Ident) TableType deriving (Show, Eq, Generic, NFData)
data ExportDesc =
ExportFunc (Maybe FuncIndex)
| ExportTable (Maybe TableIndex)
| ExportMemory (Maybe MemoryIndex)
| ExportGlobal (Maybe GlobalIndex)
deriving (Show, Eq)
deriving (Show, Eq, Generic, NFData)
data Export = Export {
name :: TL.Text,
desc :: ExportDesc
}
deriving (Show, Eq)
deriving (Show, Eq, Generic, NFData)
data StartFunction = StartFunction FuncIndex deriving (Show, Eq)
data StartFunction = StartFunction FuncIndex deriving (Show, Eq, Generic, NFData)
data ElemSegment = ElemSegment {
tableIndex :: TableIndex,
offset :: [Instruction],
funcIndexes :: [FuncIndex]
}
deriving (Show, Eq)
deriving (Show, Eq, Generic, NFData)
data DataSegment = DataSegment {
memIndex :: MemoryIndex,
offset :: [Instruction],
datastring :: TL.Text
}
deriving (Show, Eq)
deriving (Show, Eq, Generic, NFData)
data ModuleField =
MFType TypeDef
@@ -1349,7 +1353,7 @@ data ModuleField =
| MFStart StartFunction
| MFElem ElemSegment
| MFData DataSegment
deriving(Show, Eq)
deriving(Show, Eq, Generic, NFData)
happyError (Lexeme _ EOF : []) = error $ "Error occuried during parsing phase at the end of file"
happyError (Lexeme (AlexPn abs line col) tok : tokens) = error $
src/Language/Wasm/Script.hs
+9
View File
@@ -9,6 +9,7 @@ import qualified Data.Vector as Vector
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLEncoding
import Numeric.IEEE (identicalIEEE)
import qualified Control.DeepSeq as DeepSeq
import Language.Wasm.Parser (
Ident(..),
@@ -197,6 +198,14 @@ runScript onAssertFail script = do
++ ", but actual is "
++ show (getFailureString reason)
in onAssertFail msg assert
runAssert st assert@(AssertMalformed (TextModDef _ textRep) failureString) =
case DeepSeq.force $ Parser.parseModule <$> Lexer.scanner (TLEncoding.encodeUtf8 textRep) of
Right _ -> onAssertFail ("Module parsing should fail with failure string " ++ show failureString) assert
Left _ -> return ()
runAssert st assert@(AssertMalformed (BinaryModDef ident binaryRep) failureString) =
case Binary.decodeModuleLazy binaryRep of
Right _ -> onAssertFail ("Module decoding should fail with failure string " ++ show failureString) assert
Left _ -> return ()
runAssert _ _ = return ()
runCommand :: ScriptState -> Command -> IO ScriptState
src/Language/Wasm/Structure.hs
+31 -27
View File
@@ -1,4 +1,6 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
module Language.Wasm.Structure (
Module(..),
@@ -44,10 +46,12 @@ import Numeric.Natural (Natural)
import Data.Word (Word32, Word64)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text.Lazy as TL
import Control.DeepSeq (NFData)
import GHC.Generics (Generic)
data BitSize = BS32 | BS64 deriving (Show, Eq)
data BitSize = BS32 | BS64 deriving (Show, Eq, Generic, NFData)
data IUnOp = IClz | ICtz | IPopcnt deriving (Show, Eq)
data IUnOp = IClz | ICtz | IPopcnt deriving (Show, Eq, Generic, NFData)
data IBinOp =
IAdd
@@ -65,17 +69,17 @@ data IBinOp =
| IShrS
| IRotl
| IRotr
deriving (Show, Eq)
deriving (Show, Eq, Generic, NFData)
data IRelOp = IEq | INe | ILtU | ILtS | IGtU | IGtS | ILeU | ILeS | IGeU | IGeS deriving (Show, Eq)
data IRelOp = IEq | INe | ILtU | ILtS | IGtU | IGtS | ILeU | ILeS | IGeU | IGeS deriving (Show, Eq, Generic, NFData)
data FUnOp = FAbs | FNeg | FCeil | FFloor | FTrunc | FNearest | FSqrt deriving (Show, Eq)
data FUnOp = FAbs | FNeg | FCeil | FFloor | FTrunc | FNearest | FSqrt deriving (Show, Eq, Generic, NFData)
data FBinOp = FAdd | FSub | FMul | FDiv | FMin | FMax | FCopySign deriving (Show, Eq)
data FBinOp = FAdd | FSub | FMul | FDiv | FMin | FMax | FCopySign deriving (Show, Eq, Generic, NFData)
data FRelOp = FEq | FNe | FLt | FGt | FLe | FGe deriving (Show, Eq)
data FRelOp = FEq | FNe | FLt | FGt | FLe | FGe deriving (Show, Eq, Generic, NFData)
data MemArg = MemArg { offset :: Natural, align :: Natural } deriving (Show, Eq)
data MemArg = MemArg { offset :: Natural, align :: Natural } deriving (Show, Eq, Generic, NFData)
type LabelIndex = Natural
type FuncIndex = Natural
@@ -90,13 +94,13 @@ data ValueType =
| I64
| F32
| F64
deriving (Show, Eq)
deriving (Show, Eq, Generic, NFData)
type ResultType = [ValueType]
type ParamsType = [ValueType]
type LocalsType = [ValueType]
data FuncType = FuncType { params :: ParamsType, results :: ResultType } deriving (Show, Eq)
data FuncType = FuncType { params :: ParamsType, results :: ResultType } deriving (Show, Eq, Generic, NFData)
data Instruction =
-- Control instructions
@@ -170,7 +174,7 @@ data Instruction =
| F64PromoteF32
| IReinterpretF BitSize
| FReinterpretI BitSize
deriving (Show, Eq)
deriving (Show, Eq, Generic, NFData)
type Expression = [Instruction]
@@ -178,63 +182,63 @@ data Function = Function {
funcType :: TypeIndex,
localTypes :: LocalsType,
body :: Expression
} deriving (Show, Eq)
} deriving (Show, Eq, Generic, NFData)
data Limit = Limit Natural (Maybe Natural) deriving (Show, Eq)
data Limit = Limit Natural (Maybe Natural) deriving (Show, Eq, Generic, NFData)
data ElemType = AnyFunc deriving (Show, Eq)
data ElemType = AnyFunc deriving (Show, Eq, Generic, NFData)
data TableType = TableType Limit ElemType deriving (Show, Eq)
data TableType = TableType Limit ElemType deriving (Show, Eq, Generic, NFData)
data Table = Table TableType deriving (Show, Eq)
data Table = Table TableType deriving (Show, Eq, Generic, NFData)
data Memory = Memory Limit deriving (Show, Eq)
data Memory = Memory Limit deriving (Show, Eq, Generic, NFData)
data GlobalType = Const ValueType | Mut ValueType deriving (Show, Eq)
data GlobalType = Const ValueType | Mut ValueType deriving (Show, Eq, Generic, NFData)
data Global = Global {
globalType :: GlobalType,
initializer :: Expression
} deriving (Show, Eq)
} deriving (Show, Eq, Generic, NFData)
data ElemSegment = ElemSegment {
tableIndex :: TableIndex,
offset :: [Instruction],
funcIndexes :: [FuncIndex]
} deriving (Show, Eq)
} deriving (Show, Eq, Generic, NFData)
data DataSegment = DataSegment {
memIndex :: MemoryIndex,
offset :: Expression,
chunk :: LBS.ByteString
} deriving (Show, Eq)
} deriving (Show, Eq, Generic, NFData)
data StartFunction = StartFunction FuncIndex deriving (Show, Eq)
data StartFunction = StartFunction FuncIndex deriving (Show, Eq, Generic, NFData)
data ExportDesc =
ExportFunc FuncIndex
| ExportTable TableIndex
| ExportMemory MemoryIndex
| ExportGlobal GlobalIndex
deriving (Show, Eq)
deriving (Show, Eq, Generic, NFData)
data Export = Export {
name :: TL.Text,
desc :: ExportDesc
} deriving (Show, Eq)
} deriving (Show, Eq, Generic, NFData)
data ImportDesc =
ImportFunc TypeIndex
| ImportTable TableType
| ImportMemory Limit
| ImportGlobal GlobalType
deriving (Show, Eq)
deriving (Show, Eq, Generic, NFData)
data Import = Import {
sourceModule :: TL.Text,
name :: TL.Text,
desc :: ImportDesc
} deriving (Show, Eq)
} deriving (Show, Eq, Generic, NFData)
isFuncImport :: Import -> Bool
isFuncImport (Import _ _ (ImportFunc _)) = True
@@ -263,7 +267,7 @@ data Module = Module {
start :: Maybe StartFunction,
imports :: [Import],
exports :: [Export]
} deriving (Show, Eq)
} deriving (Show, Eq, Generic, NFData)
emptyModule :: Module
emptyModule = Module {
wasm.cabal
+1
View File
@@ -32,6 +32,7 @@ library
, cereal >= 0.5
, vector >= 0.12
, ieee754 >= 0.8
, deepseq >= 1.4
build-tools:
alex >=3.1.3
, happy >=1.9.4