From 4b2e6e2a91ee7ccb19e97c62d0f199336f917fe6 Mon Sep 17 00:00:00 2001 From: Ilya Rezvov Date: Thu, 15 Feb 2018 15:30:53 -0800 Subject: [PATCH] desugarize type definitions --- src/Language/Wasm/Parser.y | 64 ++++++++++++++++++++++++++- src/Language/Wasm/Structure.hs | 79 +++++++++++++++++++--------------- 2 files changed, 107 insertions(+), 36 deletions(-) diff --git a/src/Language/Wasm/Parser.y b/src/Language/Wasm/Parser.y index e0fdb43..7f2a142 100644 --- a/src/Language/Wasm/Parser.y +++ b/src/Language/Wasm/Parser.y @@ -2,9 +2,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} module Language.Wasm.Parser ( parseModule, + parseModuleFields, + desugarize, ModuleField(..), DataSegment(..), ElemSegment(..), @@ -44,6 +47,8 @@ import Language.Wasm.Structure ( ValueType(..) ) +import qualified Language.Wasm.Structure as S + import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLEncoding @@ -75,7 +80,8 @@ import Debug.Trace as Debug } -%name parseModule modAsFields +%name parseModule mod +%name parseModuleFields modAsFields %tokentype { Lexeme } %token @@ -263,7 +269,7 @@ import Debug.Trace as Debug 'loop' { Lexeme _ (TKeyword "loop") } 'if' { Lexeme _ (TKeyword "if") } 'else' { Lexeme _ (TKeyword "else") } -'end' { Lexeme _ (TKeyword "end") } +-- unused now 'end' { Lexeme _ (TKeyword "end") } 'then' { Lexeme _ (TKeyword "then") } 'table' { Lexeme _ (TKeyword "table") } 'memory' { Lexeme _ (TKeyword "memory") } @@ -836,6 +842,9 @@ modAsFields :: { [ModuleField] } : '(' 'module' list(modulefield) ')' EOF { concat $3 } | '(' modulefield1 list(modulefield) EOF { $2 ++ concat $3} +mod :: { S.Module } + : modAsFields { desugarize $1 } + -- utils rev_list(p) @@ -1126,4 +1135,55 @@ happyError (Lexeme (AlexPn abs line col) tok : tokens) = error $ "Token " ++ show tok ++ ". " ++ "Token lookahed: " ++ show (take 3 tokens) +funcTypesEq :: FuncType -> FuncType -> Bool +funcTypesEq l r = + let paramTypes = map paramType . params in + paramTypes l == paramTypes r && results l == results r + +desugarize :: [ModuleField] -> S.Module +desugarize fields = + let typeDefs = extractTypeDefs fields in + S.emptyModule { + S.types = map synTypeDefToStruct typeDefs + } + where + synTypeDefToStruct :: TypeDef -> S.FuncType + synTypeDefToStruct (TypeDef _ FuncType { params, results }) = + S.FuncType (map paramType params) results + + extractTypeDefs :: [ModuleField] -> [TypeDef] + extractTypeDefs = reverse . foldl' extractTypeDef [] + + extractTypeDef :: [TypeDef] -> ModuleField -> [TypeDef] + extractTypeDef defs (MFType def) = def : defs + extractTypeDef defs (MFImport Import { desc = ImportFunc _ typeUse }) = + matchTypeUse defs typeUse + extractTypeDef defs (MFFunc Function { funcType, body }) = + extractTypeDefFromInstructions (matchTypeUse defs funcType) body + extractTypeDef defs (MFFunc Function { funcType, body }) = + extractTypeDefFromInstructions (matchTypeUse defs funcType) body + extractTypeDef defs (MFGlobal Global { initializer }) = + extractTypeDefFromInstructions defs initializer + extractTypeDef defs _ = defs + + extractTypeDefFromInstructions :: [TypeDef] -> [Instruction] -> [TypeDef] + extractTypeDefFromInstructions = foldl' extractTypeDefFromInstruction + + extractTypeDefFromInstruction :: [TypeDef] -> Instruction -> [TypeDef] + extractTypeDefFromInstruction defs (PlainInstr (CallIndirect typeUse)) = + matchTypeUse defs typeUse + extractTypeDefFromInstruction defs (BlockInstr { body }) = + extractTypeDefFromInstructions defs body + extractTypeDefFromInstruction defs (LoopInstr { body }) = + extractTypeDefFromInstructions defs body + extractTypeDefFromInstruction defs (IfInstr { trueBranch, falseBranch }) = + extractTypeDefFromInstructions defs $ trueBranch ++ falseBranch + extractTypeDefFromInstruction defs _ = defs + + matchTypeUse :: [TypeDef] -> TypeUse -> [TypeDef] + matchTypeUse defs (AnonimousTypeUse funcType) = + if any (\(TypeDef _ ft) -> funcTypesEq ft funcType) defs + then defs + else (TypeDef Nothing funcType) : defs + matchTypeUse defs _ = defs } \ No newline at end of file diff --git a/src/Language/Wasm/Structure.hs b/src/Language/Wasm/Structure.hs index 2a53ab8..20639e6 100644 --- a/src/Language/Wasm/Structure.hs +++ b/src/Language/Wasm/Structure.hs @@ -28,7 +28,8 @@ module Language.Wasm.Structure ( Limit(..), GlobalType(..), FuncType(..), - ValueType(..) + ValueType(..), + emptyModule ) where import Numeric.Natural (Natural) @@ -183,24 +184,21 @@ data Memory = Memory Limit deriving (Show, Eq) data GlobalType = Const ValueType | Mut ValueType deriving (Show, Eq) data Global = Global { - globalType :: GlobalType, - initializer :: Expression - } - deriving (Show, Eq) + globalType :: GlobalType, + initializer :: Expression +} deriving (Show, Eq) data ElemSegment = ElemSegment { - tableIndex :: TableIndex, - offset :: [Instruction], - funcIndexes :: [FuncIndex] - } - deriving (Show, Eq) + tableIndex :: TableIndex, + offset :: [Instruction], + funcIndexes :: [FuncIndex] +} deriving (Show, Eq) data DataSegment = DataSegment { - memIndex :: MemoryIndex, - offset :: Expression, - initializer :: LBS.ByteString - } - deriving (Show, Eq) + memIndex :: MemoryIndex, + offset :: Expression, + initializer :: LBS.ByteString +} deriving (Show, Eq) data StartFunction = StartFunction FuncIndex deriving (Show, Eq) @@ -212,10 +210,9 @@ data ExportDesc = deriving (Show, Eq) data Export = Export { - name :: TL.Text, - desc :: ExportDesc - } - deriving (Show, Eq) + name :: TL.Text, + desc :: ExportDesc +} deriving (Show, Eq) data ImportDesc = ImportFunc TypeIndex @@ -225,20 +222,34 @@ data ImportDesc = deriving (Show, Eq) data Import = Import { - sourceModule :: TL.Text, - name :: TL.Text, - desc :: ImportDesc - } deriving (Show, Eq) + sourceModule :: TL.Text, + name :: TL.Text, + desc :: ImportDesc +} deriving (Show, Eq) data Module = Module { - types :: [FuncType], - functions :: [Function], - tables :: [Table], - mems :: [Memory], - globals :: [Global], - elems :: [ElemSegment], - datas :: [DataSegment], - start :: Maybe StartFunction, - imports :: [Import], - exports :: [Export] - } deriving (Show, Eq) + types :: [FuncType], + functions :: [Function], + tables :: [Table], + mems :: [Memory], + globals :: [Global], + elems :: [ElemSegment], + datas :: [DataSegment], + start :: Maybe StartFunction, + imports :: [Import], + exports :: [Export] +} deriving (Show, Eq) + +emptyModule :: Module +emptyModule = Module { + types = [], + functions = [], + tables = [], + mems = [], + globals = [], + elems = [], + datas = [], + start = Nothing, + imports = [], + exports = [] +}