diff --git a/README.md b/README.md index 51987d8..d8283c8 100644 --- a/README.md +++ b/README.md @@ -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 +``` diff --git a/src/Language/Wasm/Binary.hs b/src/Language/Wasm/Binary.hs index aca9138..8edaa0e 100644 --- a/src/Language/Wasm/Binary.hs +++ b/src/Language/Wasm/Binary.hs @@ -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 [] diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index 5c554d7..e6e495f 100644 --- a/src/Language/Wasm/Parser.y +++ b/src/Language/Wasm/Parser.y @@ -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 $ diff --git a/src/Language/Wasm/Script.hs b/src/Language/Wasm/Script.hs index a737605..e0e4e2d 100644 --- a/src/Language/Wasm/Script.hs +++ b/src/Language/Wasm/Script.hs @@ -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 diff --git a/src/Language/Wasm/Structure.hs b/src/Language/Wasm/Structure.hs index 14f81ca..1e884a1 100644 --- a/src/Language/Wasm/Structure.hs +++ b/src/Language/Wasm/Structure.hs @@ -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 { diff --git a/wasm.cabal b/wasm.cabal index b077d2b..187719a 100644 --- a/wasm.cabal +++ b/wasm.cabal @@ -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