GitHub/haskell-wasm
1
0
Fork 1
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix call_inderect type use parsing

Browse Source
This commit is contained in:
Ilya Rezvov
2018-04-16 20:51:04 -07:00
parent b27ce14618
commit 7dfbe2775e
1 changed files with 123 additions and 91 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Parser.y
+123 -91
View File
@@ -767,10 +767,6 @@ raw_call_indirect_functype1 :: { (Maybe FuncType, [Instruction]) }
let ft = fromMaybe emptyFuncType $ fst $4 in let ft = fromMaybe emptyFuncType $ fst $4 in
(Just $ ft { params = map (ParamType Nothing) $2 ++ params ft }, snd $4) (Just $ ft { params = map (ParamType Nothing) $2 ++ params ft }, snd $4)
} }
| 'param' ident valtype ')' raw_call_indirect_functype {
let ft = fromMaybe emptyFuncType $ fst $5 in
(Just $ ft { params = (ParamType (Just $2) $3) : params ft }, snd $5)
}
| raw_call_indirect_return_functype1 { $1 } | raw_call_indirect_return_functype1 { $1 }
raw_call_indirect_return_functype :: { (Maybe FuncType, [Instruction]) } raw_call_indirect_return_functype :: { (Maybe FuncType, [Instruction]) }
@@ -849,8 +845,20 @@ folded_call_indirect_functype :: { (Maybe FuncType, [Instruction]) }
| ')' { (Nothing, []) } | ')' { (Nothing, []) }
folded_call_indirect_functype1 :: { (Maybe FuncType, [Instruction]) } folded_call_indirect_functype1 :: { (Maybe FuncType, [Instruction]) }
: paramsresulttypeuse folded_call_indirect_functype { : 'param' list(valtype) ')' folded_call_indirect_functype {
(Just $ mergeFuncType $1 $ fromMaybe emptyFuncType $ fst $2, snd $2) let ft = fromMaybe emptyFuncType $ fst $4 in
(Just $ ft { params = map (ParamType Nothing) $2 ++ params ft }, snd $4)
}
| folded_call_indirect_return_functype1 { $1 }
folded_call_indirect_return_functype :: { (Maybe FuncType, [Instruction]) }
: '(' folded_call_indirect_return_functype1 { $2 }
| ')' { (Nothing, []) }
folded_call_indirect_return_functype1 :: { (Maybe FuncType, [Instruction]) }
: 'result' list(valtype) ')' folded_call_indirect_return_functype {
let ft = fromMaybe emptyFuncType $ fst $4 in
(Just $ ft { results = $2 ++ results ft }, snd $4)
} }
| foldedinstr1 list(foldedinstr) ')' { (Nothing, $1 ++ concat $2) } | foldedinstr1 list(foldedinstr) ')' { (Nothing, $1 ++ concat $2) }
@@ -1508,15 +1516,18 @@ desugarize fields = do
exports = [] exports = []
} }
funs <- mapM (synFunctionToStruct mod) $ functions mod funs <- mapM (synFunctionToStruct mod) $ functions mod
elements <- mapM (synElemToStruct mod) $ elems mod
segments <- mapM (synDataToStruct mod) $ datas mod
globs <- mapM (synGlobalToStruct mod) $ globals mod
return S.Module { return S.Module {
S.types = map synTypeDefToStruct $ types mod, S.types = map synTypeDefToStruct $ types mod,
S.functions = funs, S.functions = funs,
S.tables = map synTableToStruct $ tables mod, S.tables = map synTableToStruct $ tables mod,
S.imports = map (synImportToStruct $ types mod) $ imports mod, S.imports = map (synImportToStruct $ types mod) $ imports mod,
S.elems = map (synElemToStruct mod) $ elems mod, S.elems = elements,
S.datas = map (synDataToStruct mod) $ datas mod, S.datas = segments,
S.mems = map synMemoryToStruct $ mems mod, S.mems = map synMemoryToStruct $ mems mod,
S.globals = map (synGlobalToStruct mod) $ globals mod, S.globals = globs,
S.start = fmap (synStartToStruct mod) $ start mod, S.start = fmap (synStartToStruct mod) $ start mod,
S.exports = synExportsToStruct mod $ appendIndexToFuncs fields S.exports = synExportsToStruct mod $ appendIndexToFuncs fields
} }
@@ -1626,92 +1637,112 @@ desugarize fields = do
extractImport imports (MFImport imp) = imp : imports extractImport imports (MFImport imp) = imp : imports
extractImport imports _ = imports extractImport imports _ = imports
unwrapLabel ctx labelIdx =
case getLabelIdx ctx labelIdx of
Just i -> Right i
Nothing -> Left "unknown label"
-- functions -- functions
synInstrToStruct :: FunCtx -> Instruction -> S.Instruction synInstrToStruct :: FunCtx -> Instruction -> Either String S.Instruction
synInstrToStruct _ (PlainInstr Unreachable) = S.Unreachable synInstrToStruct _ (PlainInstr Unreachable) = return S.Unreachable
synInstrToStruct _ (PlainInstr Nop) = S.Nop synInstrToStruct _ (PlainInstr Nop) = return S.Nop
synInstrToStruct ctx (PlainInstr (Br labelIdx)) = synInstrToStruct ctx (PlainInstr (Br labelIdx)) =
fromJust $ S.Br <$> getLabelIdx ctx labelIdx S.Br <$> unwrapLabel ctx labelIdx
synInstrToStruct ctx (PlainInstr (BrIf labelIdx)) = synInstrToStruct ctx (PlainInstr (BrIf labelIdx)) =
fromJust $ S.BrIf <$> getLabelIdx ctx labelIdx S.BrIf <$> unwrapLabel ctx labelIdx
synInstrToStruct ctx (PlainInstr (BrTable lbls lbl)) = synInstrToStruct ctx (PlainInstr (BrTable lbls lbl)) = do
S.BrTable (map (fromJust . getLabelIdx ctx) lbls) $ fromJust $ getLabelIdx ctx lbl labels <- mapM (unwrapLabel ctx) lbls
synInstrToStruct _ (PlainInstr Return) = S.Return S.BrTable labels <$> unwrapLabel ctx lbl
synInstrToStruct _ (PlainInstr Return) = return S.Return
synInstrToStruct FunCtx { ctxMod } (PlainInstr (Call funIdx)) = synInstrToStruct FunCtx { ctxMod } (PlainInstr (Call funIdx)) =
S.Call $ fromJust $ getFuncIndex ctxMod funIdx case getFuncIndex ctxMod funIdx of
Just idx -> return $ S.Call idx
Nothing -> Left "unknown function"
synInstrToStruct FunCtx { ctxMod = Module { types } } (PlainInstr (CallIndirect typeUse)) = synInstrToStruct FunCtx { ctxMod = Module { types } } (PlainInstr (CallIndirect typeUse)) =
fromJust $ S.CallIndirect <$> getTypeIndex types typeUse case getTypeIndex types typeUse of
synInstrToStruct _ (PlainInstr Drop) = S.Drop Just idx -> return $ S.CallIndirect idx
synInstrToStruct _ (PlainInstr Select) = S.Select Nothing -> Left "unknown type"
synInstrToStruct _ (PlainInstr Drop) = return $ S.Drop
synInstrToStruct _ (PlainInstr Select) = return $ S.Select
synInstrToStruct ctx (PlainInstr (GetLocal localIdx)) = synInstrToStruct ctx (PlainInstr (GetLocal localIdx)) =
S.GetLocal $ fromJust $ getLocalIndex ctx localIdx case getLocalIndex ctx localIdx of
Just idx -> return $ S.GetLocal idx
Nothing -> Left "unknown local"
synInstrToStruct ctx (PlainInstr (SetLocal localIdx)) = synInstrToStruct ctx (PlainInstr (SetLocal localIdx)) =
S.SetLocal $ fromJust $ getLocalIndex ctx localIdx case getLocalIndex ctx localIdx of
Just idx -> return $ S.SetLocal idx
Nothing -> Left "unknown local"
synInstrToStruct ctx (PlainInstr (TeeLocal localIdx)) = synInstrToStruct ctx (PlainInstr (TeeLocal localIdx)) =
S.TeeLocal $ fromJust $ getLocalIndex ctx localIdx case getLocalIndex ctx localIdx of
Just idx -> return $ S.TeeLocal idx
Nothing -> Left "unknown local"
synInstrToStruct FunCtx { ctxMod } (PlainInstr (GetGlobal globalIdx)) = synInstrToStruct FunCtx { ctxMod } (PlainInstr (GetGlobal globalIdx)) =
S.GetGlobal $ fromJust $ getGlobalIndex ctxMod globalIdx case getGlobalIndex ctxMod globalIdx of
Just idx -> return $ S.GetGlobal idx
Nothing -> Left "unknown global"
synInstrToStruct FunCtx { ctxMod } (PlainInstr (SetGlobal globalIdx)) = synInstrToStruct FunCtx { ctxMod } (PlainInstr (SetGlobal globalIdx)) =
S.SetGlobal $ fromJust $ getGlobalIndex ctxMod globalIdx case getGlobalIndex ctxMod globalIdx of
synInstrToStruct _ (PlainInstr (I32Load memArg)) = S.I32Load memArg Just idx -> return $ S.SetGlobal idx
synInstrToStruct _ (PlainInstr (I64Load memArg)) = S.I64Load memArg Nothing -> Left "unknown global"
synInstrToStruct _ (PlainInstr (F32Load memArg)) = S.F32Load memArg synInstrToStruct _ (PlainInstr (I32Load memArg)) = return $ S.I32Load memArg
synInstrToStruct _ (PlainInstr (F64Load memArg)) = S.F64Load memArg synInstrToStruct _ (PlainInstr (I64Load memArg)) = return $ S.I64Load memArg
synInstrToStruct _ (PlainInstr (I32Load8S memArg)) = S.I32Load8S memArg synInstrToStruct _ (PlainInstr (F32Load memArg)) = return $ S.F32Load memArg
synInstrToStruct _ (PlainInstr (I32Load8U memArg)) = S.I32Load8U memArg synInstrToStruct _ (PlainInstr (F64Load memArg)) = return $ S.F64Load memArg
synInstrToStruct _ (PlainInstr (I32Load16S memArg)) = S.I32Load16S memArg synInstrToStruct _ (PlainInstr (I32Load8S memArg)) = return $ S.I32Load8S memArg
synInstrToStruct _ (PlainInstr (I32Load16U memArg)) = S.I32Load16U memArg synInstrToStruct _ (PlainInstr (I32Load8U memArg)) = return $ S.I32Load8U memArg
synInstrToStruct _ (PlainInstr (I64Load8S memArg)) = S.I64Load8S memArg synInstrToStruct _ (PlainInstr (I32Load16S memArg)) = return $ S.I32Load16S memArg
synInstrToStruct _ (PlainInstr (I64Load8U memArg)) = S.I64Load8U memArg synInstrToStruct _ (PlainInstr (I32Load16U memArg)) = return $ S.I32Load16U memArg
synInstrToStruct _ (PlainInstr (I64Load16S memArg)) = S.I64Load16S memArg synInstrToStruct _ (PlainInstr (I64Load8S memArg)) = return $ S.I64Load8S memArg
synInstrToStruct _ (PlainInstr (I64Load16U memArg)) = S.I64Load16U memArg synInstrToStruct _ (PlainInstr (I64Load8U memArg)) = return $ S.I64Load8U memArg
synInstrToStruct _ (PlainInstr (I64Load32S memArg)) = S.I64Load32S memArg synInstrToStruct _ (PlainInstr (I64Load16S memArg)) = return $ S.I64Load16S memArg
synInstrToStruct _ (PlainInstr (I64Load32U memArg)) = S.I64Load32U memArg synInstrToStruct _ (PlainInstr (I64Load16U memArg)) = return $ S.I64Load16U memArg
synInstrToStruct _ (PlainInstr (I32Store memArg)) = S.I32Store memArg synInstrToStruct _ (PlainInstr (I64Load32S memArg)) = return $ S.I64Load32S memArg
synInstrToStruct _ (PlainInstr (I64Store memArg)) = S.I64Store memArg synInstrToStruct _ (PlainInstr (I64Load32U memArg)) = return $ S.I64Load32U memArg
synInstrToStruct _ (PlainInstr (F32Store memArg)) = S.F32Store memArg synInstrToStruct _ (PlainInstr (I32Store memArg)) = return $ S.I32Store memArg
synInstrToStruct _ (PlainInstr (F64Store memArg)) = S.F64Store memArg synInstrToStruct _ (PlainInstr (I64Store memArg)) = return $ S.I64Store memArg
synInstrToStruct _ (PlainInstr (I32Store8 memArg)) = S.I32Store8 memArg synInstrToStruct _ (PlainInstr (F32Store memArg)) = return $ S.F32Store memArg
synInstrToStruct _ (PlainInstr (I32Store16 memArg)) = S.I32Store16 memArg synInstrToStruct _ (PlainInstr (F64Store memArg)) = return $ S.F64Store memArg
synInstrToStruct _ (PlainInstr (I64Store8 memArg)) = S.I64Store8 memArg synInstrToStruct _ (PlainInstr (I32Store8 memArg)) = return $ S.I32Store8 memArg
synInstrToStruct _ (PlainInstr (I64Store16 memArg)) = S.I64Store16 memArg synInstrToStruct _ (PlainInstr (I32Store16 memArg)) = return $ S.I32Store16 memArg
synInstrToStruct _ (PlainInstr (I64Store32 memArg)) = S.I64Store32 memArg synInstrToStruct _ (PlainInstr (I64Store8 memArg)) = return $ S.I64Store8 memArg
synInstrToStruct _ (PlainInstr CurrentMemory) = S.CurrentMemory synInstrToStruct _ (PlainInstr (I64Store16 memArg)) = return $ S.I64Store16 memArg
synInstrToStruct _ (PlainInstr GrowMemory) = S.GrowMemory synInstrToStruct _ (PlainInstr (I64Store32 memArg)) = return $ S.I64Store32 memArg
synInstrToStruct _ (PlainInstr (I32Const val)) = S.I32Const $ integerToWord32 val synInstrToStruct _ (PlainInstr CurrentMemory) = return $ S.CurrentMemory
synInstrToStruct _ (PlainInstr (I64Const val)) = S.I64Const $ integerToWord64 val synInstrToStruct _ (PlainInstr GrowMemory) = return $ S.GrowMemory
synInstrToStruct _ (PlainInstr (F32Const val)) = S.F32Const val synInstrToStruct _ (PlainInstr (I32Const val)) = return $ S.I32Const $ integerToWord32 val
synInstrToStruct _ (PlainInstr (F64Const val)) = S.F64Const val synInstrToStruct _ (PlainInstr (I64Const val)) = return $ S.I64Const $ integerToWord64 val
synInstrToStruct _ (PlainInstr (IUnOp sz op)) = S.IUnOp sz op synInstrToStruct _ (PlainInstr (F32Const val)) = return $ S.F32Const val
synInstrToStruct _ (PlainInstr (IBinOp sz op)) = S.IBinOp sz op synInstrToStruct _ (PlainInstr (F64Const val)) = return $ S.F64Const val
synInstrToStruct _ (PlainInstr I32Eqz) = S.I32Eqz synInstrToStruct _ (PlainInstr (IUnOp sz op)) = return $ S.IUnOp sz op
synInstrToStruct _ (PlainInstr I64Eqz) = S.I64Eqz synInstrToStruct _ (PlainInstr (IBinOp sz op)) = return $ S.IBinOp sz op
synInstrToStruct _ (PlainInstr (IRelOp sz op)) = S.IRelOp sz op synInstrToStruct _ (PlainInstr I32Eqz) = return $ S.I32Eqz
synInstrToStruct _ (PlainInstr (FUnOp sz op)) = S.FUnOp sz op synInstrToStruct _ (PlainInstr I64Eqz) = return $ S.I64Eqz
synInstrToStruct _ (PlainInstr (FBinOp sz op)) = S.FBinOp sz op synInstrToStruct _ (PlainInstr (IRelOp sz op)) = return $ S.IRelOp sz op
synInstrToStruct _ (PlainInstr (FRelOp sz op)) = S.FRelOp sz op synInstrToStruct _ (PlainInstr (FUnOp sz op)) = return $ S.FUnOp sz op
synInstrToStruct _ (PlainInstr I32WrapI64) = S.I32WrapI64 synInstrToStruct _ (PlainInstr (FBinOp sz op)) = return $ S.FBinOp sz op
synInstrToStruct _ (PlainInstr (ITruncFU sz sz')) = S.ITruncFU sz sz' synInstrToStruct _ (PlainInstr (FRelOp sz op)) = return $ S.FRelOp sz op
synInstrToStruct _ (PlainInstr (ITruncFS sz sz')) = S.ITruncFS sz sz' synInstrToStruct _ (PlainInstr I32WrapI64) = return $ S.I32WrapI64
synInstrToStruct _ (PlainInstr I64ExtendSI32) = S.I64ExtendSI32 synInstrToStruct _ (PlainInstr (ITruncFU sz sz')) = return $ S.ITruncFU sz sz'
synInstrToStruct _ (PlainInstr I64ExtendUI32) = S.I64ExtendUI32 synInstrToStruct _ (PlainInstr (ITruncFS sz sz')) = return $ S.ITruncFS sz sz'
synInstrToStruct _ (PlainInstr (FConvertIU sz sz')) = S.FConvertIU sz sz' synInstrToStruct _ (PlainInstr I64ExtendSI32) = return $ S.I64ExtendSI32
synInstrToStruct _ (PlainInstr (FConvertIS sz sz')) = S.FConvertIS sz sz' synInstrToStruct _ (PlainInstr I64ExtendUI32) = return $ S.I64ExtendUI32
synInstrToStruct _ (PlainInstr F32DemoteF64) = S.F32DemoteF64 synInstrToStruct _ (PlainInstr (FConvertIU sz sz')) = return $ S.FConvertIU sz sz'
synInstrToStruct _ (PlainInstr F64PromoteF32) = S.F64PromoteF32 synInstrToStruct _ (PlainInstr (FConvertIS sz sz')) = return $ S.FConvertIS sz sz'
synInstrToStruct _ (PlainInstr (IReinterpretF sz)) = S.IReinterpretF sz synInstrToStruct _ (PlainInstr F32DemoteF64) = return $ S.F32DemoteF64
synInstrToStruct _ (PlainInstr (FReinterpretI sz)) = S.FReinterpretI sz synInstrToStruct _ (PlainInstr F64PromoteF32) = return $ S.F64PromoteF32
synInstrToStruct _ (PlainInstr (IReinterpretF sz)) = return $ S.IReinterpretF sz
synInstrToStruct _ (PlainInstr (FReinterpretI sz)) = return $ S.FReinterpretI sz
synInstrToStruct ctx BlockInstr {label, resultType, body} = synInstrToStruct ctx BlockInstr {label, resultType, body} =
let ctx' = ctx { ctxLabels = label : ctxLabels ctx } in let ctx' = ctx { ctxLabels = label : ctxLabels ctx } in
S.Block resultType $ map (synInstrToStruct ctx') body S.Block resultType <$> mapM (synInstrToStruct ctx') body
synInstrToStruct ctx LoopInstr {label, resultType, body} = synInstrToStruct ctx LoopInstr {label, resultType, body} =
let ctx' = ctx { ctxLabels = label : ctxLabels ctx } in let ctx' = ctx { ctxLabels = label : ctxLabels ctx } in
S.Loop resultType $ map (synInstrToStruct ctx') body S.Loop resultType <$> mapM (synInstrToStruct ctx') body
synInstrToStruct ctx IfInstr {label, resultType, trueBranch, falseBranch} = synInstrToStruct ctx IfInstr {label, resultType, trueBranch, falseBranch} = do
let ctx' = ctx { ctxLabels = label : ctxLabels ctx } in let ctx' = ctx { ctxLabels = label : ctxLabels ctx }
let trueBranch' = map (synInstrToStruct ctx') trueBranch in trueBranch' <- mapM (synInstrToStruct ctx') trueBranch
let falseBranch' = map (synInstrToStruct ctx') falseBranch in falseBranch' <- mapM (synInstrToStruct ctx') falseBranch
S.If resultType trueBranch' falseBranch' return $ S.If resultType trueBranch' falseBranch'
synFunctionToStruct :: Module -> Function -> Either String S.Function synFunctionToStruct :: Module -> Function -> Either String S.Function
synFunctionToStruct mod Function { funcType, locals, body } = do synFunctionToStruct mod Function { funcType, locals, body } = do
@@ -1731,10 +1762,11 @@ desugarize fields = do
then let TypeDef _ FuncType { params } = types mod !! fromIntegral typeIdx in params then let TypeDef _ FuncType { params } = types mod !! fromIntegral typeIdx in params
else [] else []
let ctx = FunCtx mod [] locals params let ctx = FunCtx mod [] locals params
Right S.Function { instructions <- mapM (synInstrToStruct ctx) body
return S.Function {
S.funcType = typeIdx, S.funcType = typeIdx,
S.localTypes = map localType locals, S.localTypes = map localType locals,
S.body = map (synInstrToStruct ctx) body S.body = instructions
} }
extractFunction :: [Function] -> ModuleField -> [Function] extractFunction :: [Function] -> ModuleField -> [Function]
@@ -1815,10 +1847,10 @@ desugarize fields = do
getMemIndex Module { imports, mems } (Index idx) = Just idx getMemIndex Module { imports, mems } (Index idx) = Just idx
-- global -- global
synGlobalToStruct :: Module -> Global -> S.Global synGlobalToStruct :: Module -> Global -> Either String S.Global
synGlobalToStruct mod Global { globalType, initializer } = synGlobalToStruct mod Global { globalType, initializer } =
let ctx = FunCtx mod [] [] [] in let ctx = FunCtx mod [] [] [] in
S.Global globalType $ map (synInstrToStruct ctx) initializer S.Global globalType <$> mapM (synInstrToStruct ctx) initializer
extractGlobal :: [Global] -> ModuleField -> [Global] extractGlobal :: [Global] -> ModuleField -> [Global]
extractGlobal globals (MFGlobal global) = global : globals extractGlobal globals (MFGlobal global) = global : globals
@@ -1839,25 +1871,25 @@ desugarize fields = do
getGlobalIndex Module { imports, globals } (Index idx) = Just idx getGlobalIndex Module { imports, globals } (Index idx) = Just idx
-- elem segment -- elem segment
synElemToStruct :: Module -> ElemSegment -> S.ElemSegment synElemToStruct :: Module -> ElemSegment -> Either String S.ElemSegment
synElemToStruct mod ElemSegment { tableIndex, offset, funcIndexes } = synElemToStruct mod ElemSegment { tableIndex, offset, funcIndexes } =
let ctx = FunCtx mod [] [] [] in let ctx = FunCtx mod [] [] [] in
let offsetInstrs = map (synInstrToStruct ctx) offset in let offsetInstrs = mapM (synInstrToStruct ctx) offset in
let idx = fromJust $ getTableIndex mod tableIndex in let idx = fromJust $ getTableIndex mod tableIndex in
let indexes = map (fromJust . getFuncIndex mod) funcIndexes in let indexes = map (fromJust . getFuncIndex mod) funcIndexes in
S.ElemSegment idx offsetInstrs indexes S.ElemSegment idx <$> offsetInstrs <*> return indexes
extractElemSegment :: [ElemSegment] -> ModuleField -> [ElemSegment] extractElemSegment :: [ElemSegment] -> ModuleField -> [ElemSegment]
extractElemSegment elems (MFElem elem) = elem : elems extractElemSegment elems (MFElem elem) = elem : elems
extractElemSegment elems _ = elems extractElemSegment elems _ = elems
-- data segment -- data segment
synDataToStruct :: Module -> DataSegment -> S.DataSegment synDataToStruct :: Module -> DataSegment -> Either String S.DataSegment
synDataToStruct mod DataSegment { memIndex, offset, datastring } = synDataToStruct mod DataSegment { memIndex, offset, datastring } =
let ctx = FunCtx mod [] [] [] in let ctx = FunCtx mod [] [] [] in
let offsetInstrs = map (synInstrToStruct ctx) offset in let offsetInstrs = mapM (synInstrToStruct ctx) offset in
let idx = fromJust $ getMemIndex mod memIndex in let idx = fromJust $ getMemIndex mod memIndex in
S.DataSegment idx offsetInstrs datastring S.DataSegment idx <$> offsetInstrs <*> return datastring
extractDataSegment :: [DataSegment] -> ModuleField -> [DataSegment] extractDataSegment :: [DataSegment] -> ModuleField -> [DataSegment]
extractDataSegment datas (MFData dataSegment) = dataSegment : datas extractDataSegment datas (MFData dataSegment) = dataSegment : datas