mirror of
https://github.com/tweag/asterius.git
synced 2024-09-19 21:07:55 +03:00
Finish work for #34 (+8 squashed commit)
This commit is contained in:
Shao Cheng
parent
900e09a6d0
commit
9c7500e6ba
@ -65,123 +65,116 @@ async function newAsteriusInstance(req) {
|
||||
);
|
||||
return p0;
|
||||
},
|
||||
__asterius_memory_trap_trigger: (p_lo, p_hi) =>
|
||||
console.error(
|
||||
"[ERROR] Uninitialized memory trapped at 0x" +
|
||||
__asterius_newI64(p_lo, p_hi)
|
||||
.toString(16)
|
||||
.padStart(8, "0")
|
||||
),
|
||||
__asterius_load_i64: (p_lo, p_hi, v_lo, v_hi) =>
|
||||
__asterius_load_i64: (p_lo, p_hi, o, v_lo, v_hi) =>
|
||||
console.log(
|
||||
"[INFO] Loading i64 at 0x" +
|
||||
__asterius_newI64(p_lo, p_hi)
|
||||
.toString(16)
|
||||
.padStart(8, "0") +
|
||||
", value: 0x" +
|
||||
"+" + o + ", value: 0x" +
|
||||
__asterius_newI64(v_lo, v_hi)
|
||||
.toString(16)
|
||||
.padStart(8, "0")
|
||||
),
|
||||
__asterius_store_i64: (p_lo, p_hi, v_lo, v_hi) =>
|
||||
__asterius_store_i64: (p_lo, p_hi, o, v_lo, v_hi) =>
|
||||
console.log(
|
||||
"[INFO] Storing i64 at 0x" +
|
||||
__asterius_newI64(p_lo, p_hi)
|
||||
.toString(16)
|
||||
.padStart(8, "0") +
|
||||
", value: 0x" +
|
||||
"+" + o + ", value: 0x" +
|
||||
__asterius_newI64(v_lo, v_hi)
|
||||
.toString(16)
|
||||
.padStart(8, "0")
|
||||
),
|
||||
__asterius_load_i8: (p_lo, p_hi, v) =>
|
||||
__asterius_load_i8: (p_lo, p_hi, o, v) =>
|
||||
console.log(
|
||||
"[INFO] Loading i8 at 0x" +
|
||||
__asterius_newI64(p_lo, p_hi)
|
||||
.toString(16)
|
||||
.padStart(8, "0") +
|
||||
", value: " +
|
||||
"+" + o + ", value: " +
|
||||
v
|
||||
),
|
||||
__asterius_store_i8: (p_lo, p_hi, v) =>
|
||||
__asterius_store_i8: (p_lo, p_hi, o, v) =>
|
||||
console.log(
|
||||
"[INFO] Storing i8 at 0x" +
|
||||
__asterius_newI64(p_lo, p_hi)
|
||||
.toString(16)
|
||||
.padStart(8, "0") +
|
||||
", value: " +
|
||||
"+" + o + ", value: " +
|
||||
v
|
||||
),
|
||||
__asterius_load_i16: (p_lo, p_hi, v) =>
|
||||
__asterius_load_i16: (p_lo, p_hi, o, v) =>
|
||||
console.log(
|
||||
"[INFO] Loading i16 at 0x" +
|
||||
__asterius_newI64(p_lo, p_hi)
|
||||
.toString(16)
|
||||
.padStart(8, "0") +
|
||||
", value: " +
|
||||
"+" + o + ", value: " +
|
||||
v
|
||||
),
|
||||
__asterius_store_i16: (p_lo, p_hi, v) =>
|
||||
__asterius_store_i16: (p_lo, p_hi, o, v) =>
|
||||
console.log(
|
||||
"[INFO] Storing i16 at 0x" +
|
||||
__asterius_newI64(p_lo, p_hi)
|
||||
.toString(16)
|
||||
.padStart(8, "0") +
|
||||
", value: " +
|
||||
"+" + o + ", value: " +
|
||||
v
|
||||
),
|
||||
__asterius_load_i32: (p_lo, p_hi, v) =>
|
||||
__asterius_load_i32: (p_lo, p_hi, o, v) =>
|
||||
console.log(
|
||||
"[INFO] Loading i32 at 0x" +
|
||||
__asterius_newI64(p_lo, p_hi)
|
||||
.toString(16)
|
||||
.padStart(8, "0") +
|
||||
", value: " +
|
||||
"+" + o + ", value: " +
|
||||
v
|
||||
),
|
||||
__asterius_store_i32: (p_lo, p_hi, v) =>
|
||||
__asterius_store_i32: (p_lo, p_hi, o, v) =>
|
||||
console.log(
|
||||
"[INFO] Storing i32 at 0x" +
|
||||
__asterius_newI64(p_lo, p_hi)
|
||||
.toString(16)
|
||||
.padStart(8, "0") +
|
||||
", value: " +
|
||||
"+" + o + ", value: " +
|
||||
v
|
||||
),
|
||||
__asterius_load_f32: (p_lo, p_hi, v) =>
|
||||
__asterius_load_f32: (p_lo, p_hi, o, v) =>
|
||||
console.log(
|
||||
"[INFO] Loading f32 at 0x" +
|
||||
__asterius_newI64(p_lo, p_hi)
|
||||
.toString(16)
|
||||
.padStart(8, "0") +
|
||||
", value: " +
|
||||
"+" + o + ", value: " +
|
||||
v
|
||||
),
|
||||
__asterius_store_f32: (p_lo, p_hi, v) =>
|
||||
__asterius_store_f32: (p_lo, p_hi, o, v) =>
|
||||
console.log(
|
||||
"[INFO] Storing f32 at 0x" +
|
||||
__asterius_newI64(p_lo, p_hi)
|
||||
.toString(16)
|
||||
.padStart(8, "0") +
|
||||
", value: " +
|
||||
"+" + o + ", value: " +
|
||||
v
|
||||
),
|
||||
__asterius_load_f64: (p_lo, p_hi, v) =>
|
||||
__asterius_load_f64: (p_lo, p_hi, o, v) =>
|
||||
console.log(
|
||||
"[INFO] Loading f64 at 0x" +
|
||||
__asterius_newI64(p_lo, p_hi)
|
||||
.toString(16)
|
||||
.padStart(8, "0") +
|
||||
", value: " +
|
||||
"+" + o + ", value: " +
|
||||
v
|
||||
),
|
||||
__asterius_store_f64: (p_lo, p_hi, v) =>
|
||||
__asterius_store_f64: (p_lo, p_hi, o, v) =>
|
||||
console.log(
|
||||
"[INFO] Storing f64 at 0x" +
|
||||
__asterius_newI64(p_lo, p_hi)
|
||||
.toString(16)
|
||||
.padStart(8, "0") +
|
||||
", value: " +
|
||||
"+" + o + ", value: " +
|
||||
v
|
||||
),
|
||||
__asterius_traceCmm: f =>
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -129,7 +129,7 @@ marshalCmmStatic st =
|
||||
GHC.CmmLabel clbl -> UnresolvedStatic <$> marshalCLabel clbl
|
||||
GHC.CmmLabelOff clbl o -> do
|
||||
sym <- marshalCLabel clbl
|
||||
pure $ UnresolvedOffStatic sym o
|
||||
pure $ SymbolStatic sym o
|
||||
_ -> throwError $ UnsupportedCmmLit $ showSBS lit
|
||||
GHC.CmmUninitialised s -> pure $ Uninitialized s
|
||||
GHC.CmmString s -> pure $ Serialized $ SBS.pack s <> "\0"
|
||||
@ -187,10 +187,16 @@ marshalCmmLit lit =
|
||||
(ConstF64 $ fromRational x, F64)
|
||||
GHC.CmmLabel clbl -> do
|
||||
sym <- marshalCLabel clbl
|
||||
pure (Unresolved {unresolvedSymbol = sym}, I64)
|
||||
pure
|
||||
( Symbol
|
||||
{unresolvedSymbol = sym, symbolOffset = 0, resolvedSymbol = Nothing}
|
||||
, I64)
|
||||
GHC.CmmLabelOff clbl o -> do
|
||||
sym <- marshalCLabel clbl
|
||||
pure (UnresolvedOff {unresolvedSymbol = sym, offset' = o}, I64)
|
||||
pure
|
||||
( Symbol
|
||||
{unresolvedSymbol = sym, symbolOffset = o, resolvedSymbol = Nothing}
|
||||
, I64)
|
||||
_ -> throwError $ UnsupportedCmmLit $ showSBS lit
|
||||
|
||||
marshalCmmLoad :: GHC.CmmExpr -> GHC.CmmType -> CodeGen (Expression, ValueType)
|
||||
@ -240,11 +246,11 @@ marshalCmmReg r =
|
||||
( case gr_k of
|
||||
GCEnter1 ->
|
||||
emitErrorMessage
|
||||
I64
|
||||
[I64]
|
||||
"GetGlobal instruction: attempting to read GCEnter1"
|
||||
GCFun ->
|
||||
emitErrorMessage
|
||||
I64
|
||||
[I64]
|
||||
"GetGlobal instruction: attempting to read GCFun"
|
||||
_ -> UnresolvedGetGlobal {unresolvedGlobalReg = gr_k}
|
||||
, unresolvedGlobalRegType gr_k)
|
||||
@ -565,7 +571,7 @@ marshalCmmUnMathPrimCall op vt r x = do
|
||||
CallImport
|
||||
{ target' = "__asterius_" <> op <> "_" <> showSBS vt
|
||||
, operands = [xe]
|
||||
, valueType = vt
|
||||
, callImportReturnTypes = [vt]
|
||||
}
|
||||
}
|
||||
]
|
||||
@ -588,7 +594,7 @@ marshalCmmBinMathPrimCall op vt r x y = do
|
||||
CallImport
|
||||
{ target' = "__asterius_" <> op <> "_" <> showSBS vt
|
||||
, operands = [xe, ye]
|
||||
, valueType = vt
|
||||
, callImportReturnTypes = [vt]
|
||||
}
|
||||
}
|
||||
]
|
||||
@ -737,20 +743,21 @@ marshalCmmUnsafeCall ::
|
||||
marshalCmmUnsafeCall p@(GHC.CmmLit (GHC.CmmLabel clbl)) f rs xs = do
|
||||
sym <- marshalCLabel clbl
|
||||
if entityName sym == "barf"
|
||||
then pure [emitErrorMessage None "barf() is invoked"]
|
||||
then pure [emitErrorMessage [] "barf() is invoked"]
|
||||
else do
|
||||
xes <-
|
||||
for xs $ \x -> do
|
||||
(xe, _) <- marshalCmmExpr x
|
||||
pure xe
|
||||
case rs of
|
||||
[] -> pure [Call {target = sym, operands = xes, valueType = None}]
|
||||
[] -> pure [Call {target = sym, operands = xes, callReturnTypes = []}]
|
||||
[r] -> do
|
||||
(lr, vt) <- marshalCmmLocalReg r
|
||||
pure
|
||||
[ UnresolvedSetLocal
|
||||
{ unresolvedLocalReg = lr
|
||||
, value = Call {target = sym, operands = xes, valueType = vt}
|
||||
, value =
|
||||
Call {target = sym, operands = xes, callReturnTypes = [vt]}
|
||||
}
|
||||
]
|
||||
_ ->
|
||||
@ -817,7 +824,7 @@ marshalCmmBlockBranch instr =
|
||||
case instr of
|
||||
GHC.CmmBranch lbl -> do
|
||||
k <- marshalLabel lbl
|
||||
pure ([], Nothing, [AddBranch {to = k, condition = Null, code = Null}])
|
||||
pure ([], Nothing, [AddBranch {to = k, addBranchCondition = Nothing}])
|
||||
GHC.CmmCondBranch {..} -> do
|
||||
c <- marshalAndCastCmmExpr cml_pred I32
|
||||
kf <- marshalLabel cml_false
|
||||
@ -825,8 +832,8 @@ marshalCmmBlockBranch instr =
|
||||
pure
|
||||
( []
|
||||
, Nothing
|
||||
, [AddBranch {to = kt, condition = c, code = Null} | kt /= kf] <>
|
||||
[AddBranch {to = kf, condition = Null, code = Null}])
|
||||
, [AddBranch {to = kt, addBranchCondition = Just c} | kt /= kf] <>
|
||||
[AddBranch {to = kf, addBranchCondition = Nothing}])
|
||||
GHC.CmmSwitch cml_arg st -> do
|
||||
a <- marshalAndCastCmmExpr cml_arg I64
|
||||
brs <-
|
||||
@ -852,11 +859,11 @@ marshalCmmBlockBranch instr =
|
||||
, operand1 = ConstI64 $ fromIntegral l
|
||||
}
|
||||
}
|
||||
, [ AddBranchForSwitch {to = dest, indexes = tags, code = Null}
|
||||
, [ AddBranchForSwitch {to = dest, indexes = tags}
|
||||
| (dest, tags) <- M.toList $ M.fromListWith (<>) brs
|
||||
, dest /= dest_def
|
||||
] <>
|
||||
[AddBranch {to = dest_def, condition = Null, code = Null}])
|
||||
[AddBranch {to = dest_def, addBranchCondition = Nothing}])
|
||||
GHC.CmmCall {..} -> do
|
||||
t <- marshalAndCastCmmExpr cml_target I64
|
||||
pure ([SetLocal {index = 2, value = t}], Nothing, [])
|
||||
@ -893,7 +900,7 @@ marshalCmmBlock inner_nodes exit_node = do
|
||||
case es of
|
||||
[] -> Nop
|
||||
[e] -> e
|
||||
_ -> Block {name = "", bodys = es, valueType = None}
|
||||
_ -> Block {name = "", bodys = es, blockReturnTypes = []}
|
||||
|
||||
marshalCmmProc :: GHC.CmmGraph -> CodeGen AsteriusFunction
|
||||
marshalCmmProc GHC.CmmGraph {g_graph = GHC.GMany _ body _, ..} = do
|
||||
@ -910,7 +917,7 @@ marshalCmmProc GHC.CmmGraph {g_graph = GHC.GMany _ body _, ..} = do
|
||||
AddBlock
|
||||
{ code =
|
||||
emitErrorMessage
|
||||
None
|
||||
[]
|
||||
"__asterius_unreachable block is entered"
|
||||
}
|
||||
, addBranches = []
|
||||
@ -936,7 +943,7 @@ marshalCmmProc GHC.CmmGraph {g_graph = GHC.GMany _ body _, ..} = do
|
||||
]
|
||||
pure
|
||||
AsteriusFunction
|
||||
{ functionType = FunctionType {returnType = I64, paramTypes = []}
|
||||
{ functionType = FunctionType {paramTypes = [], returnTypes = [I64]}
|
||||
, body =
|
||||
Block
|
||||
{ name = ""
|
||||
@ -949,7 +956,7 @@ marshalCmmProc GHC.CmmGraph {g_graph = GHC.GMany _ body _, ..} = do
|
||||
}
|
||||
, GetLocal {index = 2, valueType = I64}
|
||||
]
|
||||
, valueType = I64
|
||||
, blockReturnTypes = [I64]
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@ -11,7 +11,7 @@ module Asterius.EDSL
|
||||
, LVal
|
||||
, getLVal
|
||||
, putLVal
|
||||
, setReturnType
|
||||
, setReturnTypes
|
||||
, mutParam
|
||||
, mutLocal
|
||||
, param
|
||||
@ -102,7 +102,6 @@ module Asterius.EDSL
|
||||
|
||||
import Asterius.Internals
|
||||
import Asterius.Types
|
||||
import Asterius.TypesConv
|
||||
import Control.Monad.Fail
|
||||
import Control.Monad.State.Strict
|
||||
import qualified Data.ByteString.Short as SBS
|
||||
@ -118,7 +117,7 @@ fromDList :: DList a -> [a]
|
||||
fromDList = ($ []) . appEndo
|
||||
|
||||
data EDSLState = EDSLState
|
||||
{ retType :: ValueType
|
||||
{ retTypes :: [ValueType]
|
||||
, paramBuf :: DList ValueType
|
||||
, paramNum, localNum, labelNum :: Int
|
||||
, exprBuf :: DList Expression
|
||||
@ -127,7 +126,7 @@ data EDSLState = EDSLState
|
||||
initialEDSLState :: EDSLState
|
||||
initialEDSLState =
|
||||
EDSLState
|
||||
{ retType = None
|
||||
{ retTypes = []
|
||||
, paramBuf = mempty
|
||||
, paramNum = 0
|
||||
, localNum = 0
|
||||
@ -152,19 +151,19 @@ emit :: Expression -> EDSL ()
|
||||
emit e =
|
||||
EDSL $ modify' $ \s@EDSLState {..} -> s {exprBuf = exprBuf `dListSnoc` e}
|
||||
|
||||
bundleExpressions :: ValueType -> [Expression] -> Expression
|
||||
bundleExpressions vt el =
|
||||
bundleExpressions :: [ValueType] -> [Expression] -> Expression
|
||||
bundleExpressions vts el =
|
||||
case el of
|
||||
[] -> Nop
|
||||
[e] -> e
|
||||
_ -> Block {name = mempty, bodys = el, valueType = vt}
|
||||
_ -> Block {name = mempty, bodys = el, blockReturnTypes = vts}
|
||||
|
||||
runEDSL :: ValueType -> EDSL () -> AsteriusFunction
|
||||
runEDSL vt (EDSL m) =
|
||||
runEDSL :: [ValueType] -> EDSL () -> AsteriusFunction
|
||||
runEDSL vts (EDSL m) =
|
||||
AsteriusFunction
|
||||
{ functionType =
|
||||
FunctionType {returnType = retType, paramTypes = fromDList paramBuf}
|
||||
, body = bundleExpressions vt $ fromDList exprBuf
|
||||
FunctionType {paramTypes = fromDList paramBuf, returnTypes = retTypes}
|
||||
, body = bundleExpressions vts $ fromDList exprBuf
|
||||
}
|
||||
where
|
||||
EDSLState {..} = execState m initialEDSLState
|
||||
@ -174,8 +173,8 @@ data LVal = LVal
|
||||
, putLVal :: Expression -> EDSL ()
|
||||
}
|
||||
|
||||
setReturnType :: ValueType -> EDSL ()
|
||||
setReturnType vt = EDSL $ modify' $ \s -> s {retType = vt}
|
||||
setReturnTypes :: [ValueType] -> EDSL ()
|
||||
setReturnTypes vts = EDSL $ modify' $ \s -> s {retTypes = vts}
|
||||
|
||||
mutParam, mutLocal :: ValueType -> EDSL LVal
|
||||
mutParam vt =
|
||||
@ -237,18 +236,24 @@ pointer :: ValueType -> BinaryenIndex -> Expression -> Int -> LVal
|
||||
pointer vt b bp o =
|
||||
LVal
|
||||
{ getLVal =
|
||||
Load {signed = False, bytes = b, offset = 0, valueType = vt, ptr = p}
|
||||
Load
|
||||
{ signed = False
|
||||
, bytes = b
|
||||
, offset = fromIntegral o
|
||||
, valueType = vt
|
||||
, ptr = wrapInt64 bp
|
||||
}
|
||||
, putLVal =
|
||||
\v ->
|
||||
emit $
|
||||
Store {bytes = b, offset = 0, ptr = p, value = v, valueType = vt}
|
||||
Store
|
||||
{ bytes = b
|
||||
, offset = fromIntegral o
|
||||
, ptr = wrapInt64 bp
|
||||
, value = v
|
||||
, valueType = vt
|
||||
}
|
||||
}
|
||||
where
|
||||
p =
|
||||
wrapInt64 $
|
||||
case o of
|
||||
0 -> bp
|
||||
_ -> bp `addInt64` constI64 o
|
||||
|
||||
pointerI64, pointerI32, pointerI16, pointerI8, pointerF64, pointerF32 ::
|
||||
Expression -> Int -> LVal
|
||||
@ -293,35 +298,38 @@ storeF64 bp o = putLVal $ pointerF64 bp o
|
||||
storeF32 bp o = putLVal $ pointerF32 bp o
|
||||
|
||||
call :: AsteriusEntitySymbol -> [Expression] -> EDSL ()
|
||||
call f xs = emit Call {target = f, operands = xs, valueType = None}
|
||||
call f xs = emit Call {target = f, operands = xs, callReturnTypes = []}
|
||||
|
||||
call' :: AsteriusEntitySymbol -> [Expression] -> ValueType -> EDSL Expression
|
||||
call' f xs vt = do
|
||||
lr <- mutLocal vt
|
||||
putLVal lr Call {target = f, operands = xs, valueType = vt}
|
||||
putLVal lr Call {target = f, operands = xs, callReturnTypes = [vt]}
|
||||
pure $ getLVal lr
|
||||
|
||||
callImport :: SBS.ShortByteString -> [Expression] -> EDSL ()
|
||||
callImport f xs = emit CallImport {target' = f, operands = xs, valueType = None}
|
||||
callImport f xs =
|
||||
emit CallImport {target' = f, operands = xs, callImportReturnTypes = []}
|
||||
|
||||
callImport' ::
|
||||
SBS.ShortByteString -> [Expression] -> ValueType -> EDSL Expression
|
||||
callImport' f xs vt = do
|
||||
lr <- mutLocal vt
|
||||
putLVal lr CallImport {target' = f, operands = xs, valueType = vt}
|
||||
putLVal
|
||||
lr
|
||||
CallImport {target' = f, operands = xs, callImportReturnTypes = [vt]}
|
||||
pure $ getLVal lr
|
||||
|
||||
callIndirect' :: Expression -> [Expression] -> FunctionType -> EDSL Expression
|
||||
callIndirect' f xs ft = do
|
||||
lr <- mutLocal (returnType ft)
|
||||
callIndirect' f xs ft@FunctionType {returnTypes = [rt]} = do
|
||||
lr <- mutLocal rt
|
||||
putLVal
|
||||
lr
|
||||
CallIndirect
|
||||
{ indirectTarget = wrapInt64 f
|
||||
, operands = xs
|
||||
, typeName = generateWasmFunctionTypeName ft
|
||||
}
|
||||
{indirectTarget = wrapInt64 f, operands = xs, functionType = ft}
|
||||
pure $ getLVal lr
|
||||
callIndirect' _ _ ft =
|
||||
Control.Monad.Fail.fail $
|
||||
"callIndirect': unsupported function type: " <> show ft
|
||||
|
||||
newtype Label = Label
|
||||
{ unLabel :: SBS.ShortByteString
|
||||
@ -340,61 +348,61 @@ newScope m = do
|
||||
m
|
||||
EDSL $ state $ \s@EDSLState {..} -> (exprBuf, s {exprBuf = orig_buf})
|
||||
|
||||
block', loop' :: ValueType -> (Label -> EDSL ()) -> EDSL ()
|
||||
block' vt cont = do
|
||||
block', loop' :: [ValueType] -> (Label -> EDSL ()) -> EDSL ()
|
||||
block' vts cont = do
|
||||
lbl <- newLabel
|
||||
es <- newScope $ cont lbl
|
||||
emit Block {name = unLabel lbl, bodys = fromDList es, valueType = vt}
|
||||
emit Block {name = unLabel lbl, bodys = fromDList es, blockReturnTypes = vts}
|
||||
|
||||
blockWithLabel :: ValueType -> Label -> EDSL () -> EDSL ()
|
||||
blockWithLabel vt lbl m = do
|
||||
blockWithLabel :: [ValueType] -> Label -> EDSL () -> EDSL ()
|
||||
blockWithLabel vts lbl m = do
|
||||
es <- newScope m
|
||||
emit Block {name = unLabel lbl, bodys = fromDList es, valueType = vt}
|
||||
emit Block {name = unLabel lbl, bodys = fromDList es, blockReturnTypes = vts}
|
||||
|
||||
loop' vt cont = do
|
||||
loop' vts cont = do
|
||||
lbl <- newLabel
|
||||
es <- newScope $ cont lbl
|
||||
emit Loop {name = unLabel lbl, body = bundleExpressions vt $ fromDList es}
|
||||
emit Loop {name = unLabel lbl, body = bundleExpressions vts $ fromDList es}
|
||||
|
||||
if' :: ValueType -> Expression -> EDSL () -> EDSL () -> EDSL ()
|
||||
if' vt cond t f = do
|
||||
if' :: [ValueType] -> Expression -> EDSL () -> EDSL () -> EDSL ()
|
||||
if' vts cond t f = do
|
||||
t_es <- newScope t
|
||||
f_es <- newScope f
|
||||
emit
|
||||
If
|
||||
{ condition = cond
|
||||
, ifTrue = bundleExpressions vt $ fromDList t_es
|
||||
, ifFalse = bundleExpressions vt $ fromDList f_es
|
||||
, ifTrue = bundleExpressions vts $ fromDList t_es
|
||||
, ifFalse = Just $ bundleExpressions vts $ fromDList f_es
|
||||
}
|
||||
|
||||
break' :: Label -> Expression -> EDSL ()
|
||||
break' (Label lbl) cond = emit Break {name = lbl, condition = cond}
|
||||
break' :: Label -> Maybe Expression -> EDSL ()
|
||||
break' (Label lbl) cond = emit Break {name = lbl, breakCondition = cond}
|
||||
|
||||
whileLoop :: ValueType -> Expression -> EDSL () -> EDSL ()
|
||||
whileLoop vt cond body =
|
||||
loop' vt $ \lbl -> if' vt cond (body *> break' lbl Null) mempty
|
||||
whileLoop :: [ValueType] -> Expression -> EDSL () -> EDSL ()
|
||||
whileLoop vts cond body =
|
||||
loop' vts $ \lbl -> if' vts cond (body *> break' lbl Nothing) mempty
|
||||
|
||||
switchI64 :: Expression -> (EDSL () -> ([(Int, EDSL ())], EDSL ())) -> EDSL ()
|
||||
switchI64 cond make_clauses =
|
||||
block' None $ \switch_lbl ->
|
||||
let exit_switch = break' switch_lbl Null
|
||||
block' [] $ \switch_lbl ->
|
||||
let exit_switch = break' switch_lbl Nothing
|
||||
(clauses, def_clause) = make_clauses exit_switch
|
||||
switch_block = do
|
||||
switch_def_lbl <- newLabel
|
||||
blockWithLabel None switch_def_lbl $ do
|
||||
blockWithLabel [] switch_def_lbl $ do
|
||||
clause_seq <-
|
||||
for (reverse clauses) $ \(clause_i, clause_m) -> do
|
||||
clause_lbl <- newLabel
|
||||
pure (clause_i, clause_lbl, clause_m)
|
||||
foldr
|
||||
(\(_, clause_lbl, clause_m) tot_m -> do
|
||||
blockWithLabel None clause_lbl tot_m
|
||||
blockWithLabel [] clause_lbl tot_m
|
||||
clause_m)
|
||||
(foldr
|
||||
(\(clause_i, clause_lbl, _) br_m -> do
|
||||
break' clause_lbl $ cond `eqInt64` constI64 clause_i
|
||||
break' clause_lbl $ Just $ cond `eqInt64` constI64 clause_i
|
||||
br_m)
|
||||
(break' switch_def_lbl Null)
|
||||
(break' switch_def_lbl Nothing)
|
||||
clause_seq)
|
||||
clause_seq
|
||||
def_clause
|
||||
@ -418,7 +426,7 @@ convertUInt64ToFloat64 = Unary ConvertUInt64ToFloat64
|
||||
|
||||
truncUFloat64ToInt64 = Unary TruncUFloat64ToInt64
|
||||
|
||||
growMemory x = Host {hostOp = GrowMemory, name = "", operands = [x]}
|
||||
growMemory x = Host {hostOp = GrowMemory, operands = [x]}
|
||||
|
||||
roundupBytesToWords n = (n `addInt64` constI64 7) `divUInt64` constI64 8
|
||||
|
||||
@ -465,7 +473,8 @@ andInt32 = Binary AndInt32
|
||||
orInt32 = Binary OrInt32
|
||||
|
||||
symbol :: AsteriusEntitySymbol -> Expression
|
||||
symbol = Unresolved
|
||||
symbol sym =
|
||||
Symbol {unresolvedSymbol = sym, symbolOffset = 0, resolvedSymbol = Nothing}
|
||||
|
||||
constI32, constI64 :: Int -> Expression
|
||||
constI32 = ConstI32 . fromIntegral
|
||||
|
||||
@ -153,11 +153,12 @@ marshalToFFIValueType (GHC.unLoc -> t) =
|
||||
| GHC.occNameString tv == "JSRef" -> pure FFI_JSREF
|
||||
_ -> empty
|
||||
|
||||
marshalToFFIResultType ::
|
||||
(GHC.HasOccName (GHC.IdP p)) => GHC.LHsType p -> Maybe (Maybe FFIValueType)
|
||||
marshalToFFIResultType (GHC.unLoc -> GHC.HsParTy _ t) = marshalToFFIResultType t
|
||||
marshalToFFIResultType (GHC.unLoc -> GHC.HsTupleTy _ _ []) = pure Nothing
|
||||
marshalToFFIResultType t = Just <$> marshalToFFIValueType t
|
||||
marshalToFFIResultTypes ::
|
||||
(GHC.HasOccName (GHC.IdP p)) => GHC.LHsType p -> Maybe [FFIValueType]
|
||||
marshalToFFIResultTypes (GHC.unLoc -> GHC.HsParTy _ t) =
|
||||
marshalToFFIResultTypes t
|
||||
marshalToFFIResultTypes (GHC.unLoc -> GHC.HsTupleTy _ _ []) = pure []
|
||||
marshalToFFIResultTypes t = (: []) <$> marshalToFFIValueType t
|
||||
|
||||
marshalToFFIFunctionType ::
|
||||
(GHC.HasOccName (GHC.IdP p)) => GHC.LHsType p -> Maybe FFIFunctionType
|
||||
@ -171,14 +172,15 @@ marshalToFFIFunctionType (GHC.unLoc -> ty) =
|
||||
pure ft {ffiParamTypes = vt : ffiParamTypes ft}
|
||||
GHC.HsAppTy _ (GHC.unLoc -> (GHC.HsTyVar _ _ (GHC.occName . GHC.unLoc -> io))) t
|
||||
| io == GHC.occName GHC.ioTyConName -> do
|
||||
r <- marshalToFFIResultType t
|
||||
r <- marshalToFFIResultTypes t
|
||||
pure $
|
||||
FFIFunctionType
|
||||
{ffiParamTypes = [], ffiResultType = r, ffiInIO = True}
|
||||
{ffiParamTypes = [], ffiResultTypes = r, ffiInIO = True}
|
||||
_ -> do
|
||||
r <- marshalToFFIResultType (GHC.noLoc ty)
|
||||
r <- marshalToFFIResultTypes (GHC.noLoc ty)
|
||||
pure
|
||||
FFIFunctionType {ffiParamTypes = [], ffiResultType = r, ffiInIO = False}
|
||||
FFIFunctionType
|
||||
{ffiParamTypes = [], ffiResultTypes = r, ffiInIO = False}
|
||||
|
||||
rewriteJSRef :: (Monad m, Data a) => a -> m a
|
||||
rewriteJSRef t =
|
||||
@ -191,32 +193,30 @@ rewriteJSRef t =
|
||||
_ -> pure t
|
||||
_ -> gmapM rewriteJSRef t
|
||||
|
||||
recoverWasmImportValueType :: Maybe FFIValueType -> ValueType
|
||||
recoverWasmImportValueType :: FFIValueType -> ValueType
|
||||
recoverWasmImportValueType vt =
|
||||
case vt of
|
||||
Just FFI_VAL {..} -> ffiJSValueType
|
||||
Just FFI_JSREF -> I32
|
||||
Nothing -> None
|
||||
FFI_VAL {..} -> ffiJSValueType
|
||||
FFI_JSREF -> I32
|
||||
|
||||
recoverWasmWrapperValueType :: Maybe FFIValueType -> ValueType
|
||||
recoverWasmWrapperValueType :: FFIValueType -> ValueType
|
||||
recoverWasmWrapperValueType vt =
|
||||
case vt of
|
||||
Just FFI_VAL {..} -> ffiWasmValueType
|
||||
Just FFI_JSREF -> I64
|
||||
Nothing -> None
|
||||
FFI_VAL {..} -> ffiWasmValueType
|
||||
FFI_JSREF -> I64
|
||||
|
||||
recoverWasmImportFunctionType :: FFIFunctionType -> FunctionType
|
||||
recoverWasmImportFunctionType FFIFunctionType {..} =
|
||||
FunctionType
|
||||
{ returnType = recoverWasmImportValueType ffiResultType
|
||||
, paramTypes = [recoverWasmImportValueType $ Just t | t <- ffiParamTypes]
|
||||
{ paramTypes = [recoverWasmImportValueType t | t <- ffiParamTypes]
|
||||
, returnTypes = map recoverWasmImportValueType ffiResultTypes
|
||||
}
|
||||
|
||||
recoverWasmWrapperFunctionType :: FFIFunctionType -> FunctionType
|
||||
recoverWasmWrapperFunctionType FFIFunctionType {..} =
|
||||
FunctionType
|
||||
{ returnType = recoverWasmWrapperValueType ffiResultType
|
||||
, paramTypes = [recoverWasmWrapperValueType $ Just t | t <- ffiParamTypes]
|
||||
{ paramTypes = [recoverWasmWrapperValueType t | t <- ffiParamTypes]
|
||||
, returnTypes = map recoverWasmWrapperValueType ffiResultTypes
|
||||
}
|
||||
|
||||
recoverWasmImportFunctionName :: AsteriusModuleSymbol -> Int -> String
|
||||
@ -385,11 +385,11 @@ addFFIProcessor c = do
|
||||
, generateFFIWrapperModule $ ffi_states ! mod_sym))
|
||||
|
||||
generateImplicitCastExpression ::
|
||||
Bool -> ValueType -> ValueType -> Expression -> Expression
|
||||
generateImplicitCastExpression signed src_t dest_t src_expr =
|
||||
case (src_t, dest_t) of
|
||||
(I64, I32) -> Unary {unaryOp = WrapInt64, operand0 = src_expr}
|
||||
(I32, I64) ->
|
||||
Bool -> [ValueType] -> [ValueType] -> Expression -> Expression
|
||||
generateImplicitCastExpression signed src_ts dest_ts src_expr =
|
||||
case (src_ts, dest_ts) of
|
||||
([I64], [I32]) -> Unary {unaryOp = WrapInt64, operand0 = src_expr}
|
||||
([I32], [I64]) ->
|
||||
Unary
|
||||
{ unaryOp =
|
||||
if signed
|
||||
@ -398,10 +398,11 @@ generateImplicitCastExpression signed src_t dest_t src_expr =
|
||||
, operand0 = src_expr
|
||||
}
|
||||
_
|
||||
| src_t == dest_t -> src_expr
|
||||
| src_ts == dest_ts -> src_expr
|
||||
| otherwise ->
|
||||
error $
|
||||
"Unsupported implicit cast from " <> show src_t <> " to " <> show dest_t
|
||||
"Unsupported implicit cast from " <> show src_ts <> " to " <>
|
||||
show dest_ts
|
||||
|
||||
generateFFIImportWrapperFunction ::
|
||||
AsteriusModuleSymbol -> Int -> FFIImportDecl -> AsteriusFunction
|
||||
@ -410,11 +411,11 @@ generateFFIImportWrapperFunction mod_sym k FFIImportDecl {..} =
|
||||
{ functionType = recoverWasmWrapperFunctionType ffiFunctionType
|
||||
, body =
|
||||
generateImplicitCastExpression
|
||||
(case ffiResultType ffiFunctionType of
|
||||
Just FFI_VAL {..} -> signed
|
||||
(case ffiResultTypes ffiFunctionType of
|
||||
[FFI_VAL {..}] -> signed
|
||||
_ -> False)
|
||||
(returnType import_func_type)
|
||||
(returnType wrapper_func_type) $
|
||||
(returnTypes import_func_type)
|
||||
(returnTypes wrapper_func_type) $
|
||||
CallImport
|
||||
{ target' = fromString $ recoverWasmImportFunctionName mod_sym k
|
||||
, operands =
|
||||
@ -422,8 +423,8 @@ generateFFIImportWrapperFunction mod_sym k FFIImportDecl {..} =
|
||||
(case param_t of
|
||||
FFI_VAL {..} -> signed
|
||||
_ -> False)
|
||||
wrapper_param_t
|
||||
import_param_t
|
||||
[wrapper_param_t]
|
||||
[import_param_t]
|
||||
GetLocal {index = i, valueType = wrapper_param_t}
|
||||
| (i, param_t, wrapper_param_t, import_param_t) <-
|
||||
zip4
|
||||
@ -432,7 +433,7 @@ generateFFIImportWrapperFunction mod_sym k FFIImportDecl {..} =
|
||||
(paramTypes wrapper_func_type)
|
||||
(paramTypes import_func_type)
|
||||
]
|
||||
, valueType = returnType import_func_type
|
||||
, callImportReturnTypes = returnTypes import_func_type
|
||||
}
|
||||
}
|
||||
where
|
||||
@ -453,7 +454,7 @@ generateFFIExportFunction FFIExportDecl {..} =
|
||||
Call
|
||||
{ target = "allocate"
|
||||
, operands = [cap, ConstI64 1]
|
||||
, valueType = I64
|
||||
, callReturnTypes = [I64]
|
||||
}
|
||||
}
|
||||
, Call
|
||||
@ -484,29 +485,33 @@ generateFFIExportFunction FFIExportDecl {..} =
|
||||
, GetLocal
|
||||
{ index = ffi_param_i
|
||||
, valueType =
|
||||
recoverWasmWrapperValueType $
|
||||
Just ffi_param_t
|
||||
recoverWasmWrapperValueType
|
||||
ffi_param_t
|
||||
}
|
||||
]
|
||||
, valueType = I64
|
||||
, callReturnTypes = [I64]
|
||||
}
|
||||
]
|
||||
, valueType = I64
|
||||
, callReturnTypes = [I64]
|
||||
})
|
||||
Unresolved {unresolvedSymbol = ffiExportClosure}
|
||||
Symbol
|
||||
{ unresolvedSymbol = ffiExportClosure
|
||||
, symbolOffset = 0
|
||||
, resolvedSymbol = Nothing
|
||||
}
|
||||
(zip [0 ..] $ ffiParamTypes ffiFunctionType)
|
||||
, UnresolvedGetLocal {unresolvedLocalReg = ret}
|
||||
]
|
||||
, valueType = None
|
||||
, callReturnTypes = []
|
||||
}
|
||||
, Call
|
||||
{ target = "rts_checkSchedStatus"
|
||||
, operands = [cap]
|
||||
, valueType = None
|
||||
, callReturnTypes = []
|
||||
}
|
||||
] <>
|
||||
case ffiResultType ffiFunctionType of
|
||||
Just ffi_result_t ->
|
||||
case ffiResultTypes ffiFunctionType of
|
||||
[ffi_result_t] ->
|
||||
[ Call
|
||||
{ target =
|
||||
AsteriusEntitySymbol
|
||||
@ -526,17 +531,22 @@ generateFFIExportFunction FFIExportDecl {..} =
|
||||
}
|
||||
}
|
||||
]
|
||||
, valueType =
|
||||
recoverWasmWrapperValueType $ Just ffi_result_t
|
||||
, callReturnTypes =
|
||||
[recoverWasmWrapperValueType ffi_result_t]
|
||||
}
|
||||
]
|
||||
_ -> []
|
||||
, valueType =
|
||||
recoverWasmWrapperValueType $ ffiResultType ffiFunctionType
|
||||
, blockReturnTypes =
|
||||
map recoverWasmWrapperValueType $ ffiResultTypes ffiFunctionType
|
||||
}
|
||||
}
|
||||
where
|
||||
cap = Unresolved {unresolvedSymbol = "MainCapability"}
|
||||
cap =
|
||||
Symbol
|
||||
{ unresolvedSymbol = "MainCapability"
|
||||
, symbolOffset = 0
|
||||
, resolvedSymbol = Nothing
|
||||
}
|
||||
ret = UniqueLocalReg 0 I64
|
||||
|
||||
generateFFIWrapperModule :: FFIMarshalState -> AsteriusModule
|
||||
@ -569,9 +579,9 @@ generateFFIWrapperModule mod_ffi_state@FFIMarshalState {..} =
|
||||
| (k, f) <- export_funcs
|
||||
]
|
||||
|
||||
generateFFIFunctionImports :: FFIMarshalState -> [AsteriusFunctionImport]
|
||||
generateFFIFunctionImports :: FFIMarshalState -> [FunctionImport]
|
||||
generateFFIFunctionImports FFIMarshalState {..} =
|
||||
[ AsteriusFunctionImport
|
||||
[ FunctionImport
|
||||
{ internalName = fn
|
||||
, externalModuleName = "jsffi"
|
||||
, externalBaseName = fn
|
||||
@ -587,8 +597,8 @@ generateFFILambda FFIImportDecl {ffiFunctionType = FFIFunctionType {..}, ..} =
|
||||
"((" <>
|
||||
mconcat (intersperse "," ["_" <> intDec i | i <- [1 .. length ffiParamTypes]]) <>
|
||||
")=>" <>
|
||||
(case ffiResultType of
|
||||
Just FFI_JSREF -> "__asterius_jsffi.newJSRef("
|
||||
(case ffiResultTypes of
|
||||
[FFI_JSREF] -> "__asterius_jsffi.newJSRef("
|
||||
_ -> "(") <>
|
||||
mconcat
|
||||
[ case chunk of
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# OPTIONS_GHC -Wno-overflowed-literals #-}
|
||||
|
||||
module Asterius.Marshal
|
||||
( MarshalError(..)
|
||||
@ -10,6 +11,7 @@ module Asterius.Marshal
|
||||
|
||||
import Asterius.Internals
|
||||
import Asterius.Types
|
||||
import Asterius.TypesConv
|
||||
import Bindings.Binaryen.Raw
|
||||
import Control.Exception
|
||||
import qualified Data.ByteString as BS
|
||||
@ -17,6 +19,7 @@ import qualified Data.ByteString.Short as SBS
|
||||
import qualified Data.ByteString.Unsafe as BS
|
||||
import Data.Foldable
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Set as Set
|
||||
import Data.Traversable
|
||||
import Foreign
|
||||
import Foreign.C
|
||||
@ -38,12 +41,20 @@ marshalBool flag =
|
||||
marshalValueType :: ValueType -> BinaryenType
|
||||
marshalValueType t =
|
||||
case t of
|
||||
None -> c_BinaryenTypeNone
|
||||
I32 -> c_BinaryenTypeInt32
|
||||
I64 -> c_BinaryenTypeInt64
|
||||
F32 -> c_BinaryenTypeFloat32
|
||||
F64 -> c_BinaryenTypeFloat64
|
||||
|
||||
marshalReturnTypes :: [ValueType] -> IO BinaryenType
|
||||
marshalReturnTypes vts =
|
||||
case vts of
|
||||
[] -> pure c_BinaryenTypeNone
|
||||
[vt] -> pure $ marshalValueType vt
|
||||
_ ->
|
||||
fail $
|
||||
"binaryen doesn't support multi-value yet: failed to marshal " <> show vts
|
||||
|
||||
marshalUnaryOp :: UnaryOp -> BinaryenOp
|
||||
marshalUnaryOp op =
|
||||
case op of
|
||||
@ -189,8 +200,9 @@ marshalFunctionType ::
|
||||
-> IO BinaryenFunctionTypeRef
|
||||
marshalFunctionType pool m k FunctionType {..} = do
|
||||
(pts, ptl) <- marshalV pool $ map marshalValueType paramTypes
|
||||
rts <- marshalReturnTypes returnTypes
|
||||
np <- marshalSBS pool k
|
||||
c_BinaryenAddFunctionType m np (marshalValueType returnType) pts ptl
|
||||
c_BinaryenAddFunctionType m np rts pts ptl
|
||||
|
||||
marshalExpression ::
|
||||
Pool -> BinaryenModuleRef -> Expression -> IO BinaryenExpressionRef
|
||||
@ -200,18 +212,19 @@ marshalExpression pool m e =
|
||||
bs <- forM bodys $ marshalExpression pool m
|
||||
(bsp, bl) <- marshalV pool bs
|
||||
np <- marshalSBS pool name
|
||||
c_BinaryenBlock m np bsp bl (marshalValueType valueType)
|
||||
rts <- marshalReturnTypes blockReturnTypes
|
||||
c_BinaryenBlock m np bsp bl rts
|
||||
If {..} -> do
|
||||
c <- marshalExpression pool m condition
|
||||
t <- marshalExpression pool m ifTrue
|
||||
f <- marshalExpression pool m ifFalse
|
||||
f <- marshalMaybeExpression pool m ifFalse
|
||||
c_BinaryenIf m c t f
|
||||
Loop {..} -> do
|
||||
b <- marshalExpression pool m body
|
||||
np <- marshalSBS pool name
|
||||
c_BinaryenLoop m np b
|
||||
Break {..} -> do
|
||||
c <- marshalExpression pool m condition
|
||||
c <- marshalMaybeExpression pool m breakCondition
|
||||
np <- marshalSBS pool name
|
||||
c_BinaryenBreak m np c nullPtr
|
||||
Switch {..} -> do
|
||||
@ -224,17 +237,19 @@ marshalExpression pool m e =
|
||||
os <- forM operands $ marshalExpression pool m
|
||||
(ops, osl) <- marshalV pool os
|
||||
tp <- marshalSBS pool (entityName target)
|
||||
c_BinaryenCall m tp ops osl (marshalValueType valueType)
|
||||
rts <- marshalReturnTypes callReturnTypes
|
||||
c_BinaryenCall m tp ops osl rts
|
||||
CallImport {..} -> do
|
||||
os <- forM operands $ marshalExpression pool m
|
||||
(ops, osl) <- marshalV pool os
|
||||
tp <- marshalSBS pool target'
|
||||
c_BinaryenCall m tp ops osl (marshalValueType valueType)
|
||||
rts <- marshalReturnTypes callImportReturnTypes
|
||||
c_BinaryenCall m tp ops osl rts
|
||||
CallIndirect {..} -> do
|
||||
t <- marshalExpression pool m indirectTarget
|
||||
os <- forM operands $ marshalExpression pool m
|
||||
(ops, osl) <- marshalV pool os
|
||||
tp <- marshalSBS pool typeName
|
||||
tp <- marshalSBS pool $ showSBS functionType
|
||||
c_BinaryenCallIndirect m t ops osl tp
|
||||
GetLocal {..} -> c_BinaryenGetLocal m index $ marshalValueType valueType
|
||||
SetLocal {..} -> do
|
||||
@ -268,14 +283,21 @@ marshalExpression pool m e =
|
||||
Host {..} -> do
|
||||
xs <- forM operands $ marshalExpression pool m
|
||||
(es, en) <- marshalV pool xs
|
||||
np <- marshalSBS pool name
|
||||
c_BinaryenHost m (marshalHostOp hostOp) np es en
|
||||
c_BinaryenHost m (marshalHostOp hostOp) nullPtr es en
|
||||
Nop -> c_BinaryenNop m
|
||||
Unreachable -> c_BinaryenUnreachable m
|
||||
CFG {..} -> relooperRun pool m graph
|
||||
Null -> pure nullPtr
|
||||
Symbol {resolvedSymbol = Just x, ..} ->
|
||||
c_BinaryenConstInt64 m (x + fromIntegral symbolOffset)
|
||||
_ -> throwIO $ UnsupportedExpression e
|
||||
|
||||
marshalMaybeExpression ::
|
||||
Pool -> BinaryenModuleRef -> Maybe Expression -> IO BinaryenExpressionRef
|
||||
marshalMaybeExpression pool m x =
|
||||
case x of
|
||||
Just e -> marshalExpression pool m e
|
||||
_ -> pure nullPtr
|
||||
|
||||
marshalFunction ::
|
||||
Pool
|
||||
-> BinaryenModuleRef
|
||||
@ -332,7 +354,7 @@ marshalMemory pool m Memory {..} = do
|
||||
c_BinaryenSetMemory
|
||||
m
|
||||
initialPages
|
||||
maximumPages
|
||||
(-1)
|
||||
enp
|
||||
cp
|
||||
ofs
|
||||
@ -341,17 +363,18 @@ marshalMemory pool m Memory {..} = do
|
||||
0
|
||||
|
||||
marshalModule :: Pool -> Module -> IO BinaryenModuleRef
|
||||
marshalModule pool Module {..} = do
|
||||
marshalModule pool hs_mod@Module {..} = do
|
||||
let fts = generateWasmFunctionTypeSet hs_mod
|
||||
m <- c_BinaryenModuleCreate
|
||||
ftps <-
|
||||
fmap M.fromList $
|
||||
for (M.toList functionTypeMap) $ \(k, ft) -> do
|
||||
ftp <- marshalFunctionType pool m k ft
|
||||
pure (k, ftp)
|
||||
for (Set.toList fts) $ \ft -> do
|
||||
ftp <- marshalFunctionType pool m (showSBS ft) ft
|
||||
pure (ft, ftp)
|
||||
for_ (M.toList functionMap') $ \(k, f@Function {..}) ->
|
||||
marshalFunction pool m k (ftps ! functionTypeName) f
|
||||
marshalFunction pool m k (ftps ! functionType) f
|
||||
forM_ functionImports $ \fi@FunctionImport {..} ->
|
||||
marshalFunctionImport pool m (ftps ! functionTypeName) fi
|
||||
marshalFunctionImport pool m (ftps ! functionType) fi
|
||||
forM_ functionExports $ marshalFunctionExport pool m
|
||||
marshalFunctionTable pool m functionTable
|
||||
marshalMemory pool m memory
|
||||
@ -383,13 +406,11 @@ relooperAddBranch ::
|
||||
relooperAddBranch pool m bm k ab =
|
||||
case ab of
|
||||
AddBranch {..} -> do
|
||||
_cond <- marshalExpression pool m condition
|
||||
_code <- marshalExpression pool m code
|
||||
c_RelooperAddBranch (bm ! k) (bm ! to) _cond _code
|
||||
_cond <- marshalMaybeExpression pool m addBranchCondition
|
||||
c_RelooperAddBranch (bm ! k) (bm ! to) _cond nullPtr
|
||||
AddBranchForSwitch {..} -> do
|
||||
c <- marshalExpression pool m code
|
||||
(idp, idn) <- marshalV pool indexes
|
||||
c_RelooperAddBranchForSwitch (bm ! k) (bm ! to) idp idn c
|
||||
c_RelooperAddBranchForSwitch (bm ! k) (bm ! to) idp idn nullPtr
|
||||
|
||||
relooperRun ::
|
||||
Pool -> BinaryenModuleRef -> RelooperRun -> IO BinaryenExpressionRef
|
||||
|
||||
@ -45,8 +45,8 @@ addMemoryTrapDeep t =
|
||||
(F32, 4) -> "__asterius_Load_F32"
|
||||
(F64, 8) -> "__asterius_Load_F64"
|
||||
_ -> error $ "Unsupported instruction: " <> show t
|
||||
, operands = [new_i64_ptr]
|
||||
, valueType = valueType
|
||||
, operands = [new_i64_ptr, ConstI32 $ fromIntegral offset]
|
||||
, callReturnTypes = [valueType]
|
||||
}
|
||||
Store {ptr = Unary {unaryOp = WrapInt64, operand0 = i64_ptr}, ..} -> do
|
||||
new_i64_ptr <- addMemoryTrapDeep i64_ptr
|
||||
@ -62,22 +62,23 @@ addMemoryTrapDeep t =
|
||||
(F32, 4) -> "__asterius_Store_F32"
|
||||
(F64, 8) -> "__asterius_Store_F64"
|
||||
_ -> error $ "Unsupported instruction: " <> show t
|
||||
, operands = [new_i64_ptr, new_value]
|
||||
, valueType = None
|
||||
, operands =
|
||||
[new_i64_ptr, ConstI32 $ fromIntegral offset, new_value]
|
||||
, callReturnTypes = []
|
||||
}
|
||||
Host {hostOp = CurrentMemory} ->
|
||||
pure
|
||||
CallImport
|
||||
{ target' = "__asterius_current_memory"
|
||||
, operands = [t]
|
||||
, valueType = I32
|
||||
, callImportReturnTypes = [I32]
|
||||
}
|
||||
Host {hostOp = GrowMemory, ..} ->
|
||||
pure
|
||||
CallImport
|
||||
{ target' = "__asterius_grow_memory"
|
||||
, operands = [t, head operands]
|
||||
, valueType = I32
|
||||
, callImportReturnTypes = [I32]
|
||||
}
|
||||
_ -> go
|
||||
_ -> go
|
||||
|
||||
@ -12,12 +12,14 @@ import Asterius.Internals
|
||||
import qualified Asterius.Internals.DList as DList
|
||||
import Asterius.TypeInfer
|
||||
import Asterius.Types
|
||||
import Asterius.TypesConv
|
||||
import Control.Exception
|
||||
import Control.Monad.Except
|
||||
import qualified Data.ByteString.Short as SBS
|
||||
import Data.Coerce
|
||||
import Data.List
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Set as Set
|
||||
import Data.Traversable
|
||||
import Data.Word
|
||||
import qualified Language.WebAssembly.WireFormat as Wasm
|
||||
@ -33,51 +35,46 @@ data MarshalError
|
||||
instance Exception MarshalError
|
||||
|
||||
data ModuleSymbolTable = ModuleSymbolTable
|
||||
{ functionTypeSymbols :: Map.Map SBS.ShortByteString Wasm.FunctionTypeIndex
|
||||
{ functionTypeSymbols :: Map.Map FunctionType Wasm.FunctionTypeIndex
|
||||
, functionSymbols :: Map.Map SBS.ShortByteString Wasm.FunctionIndex
|
||||
}
|
||||
|
||||
makeModuleSymbolTable ::
|
||||
MonadError MarshalError m => Module -> m ModuleSymbolTable
|
||||
makeModuleSymbolTable Module {..} = do
|
||||
makeModuleSymbolTable m@Module {..} = do
|
||||
let _has_dup l = length l /= length (nub l)
|
||||
_func_import_syms =
|
||||
[internalName | FunctionImport {..} <- functionImports]
|
||||
_func_syms = Map.keys functionMap'
|
||||
_func_conflict_syms = _func_import_syms `intersect` _func_syms
|
||||
_func_types = generateWasmFunctionTypeSet m
|
||||
if _has_dup _func_import_syms
|
||||
then throwError DuplicateFunctionImport
|
||||
else pure
|
||||
ModuleSymbolTable
|
||||
{ functionTypeSymbols =
|
||||
Map.fromDistinctAscList $
|
||||
zip (Map.keys functionTypeMap) (coerce [0 :: Word32 ..])
|
||||
zip (Set.toList _func_types) (coerce [0 :: Word32 ..])
|
||||
, functionSymbols =
|
||||
Map.fromList $
|
||||
zip (_func_import_syms <> _func_syms) (coerce [0 :: Word32 ..])
|
||||
}
|
||||
|
||||
makeResultType :: ValueType -> [Wasm.ValueType]
|
||||
makeResultType vt =
|
||||
makeValueType :: ValueType -> Wasm.ValueType
|
||||
makeValueType vt =
|
||||
case vt of
|
||||
None -> []
|
||||
I32 -> [Wasm.I32]
|
||||
I64 -> [Wasm.I64]
|
||||
F32 -> [Wasm.F32]
|
||||
F64 -> [Wasm.F64]
|
||||
I32 -> Wasm.I32
|
||||
I64 -> Wasm.I64
|
||||
F32 -> Wasm.F32
|
||||
F64 -> Wasm.F64
|
||||
|
||||
makeTypeSection :: MonadError MarshalError m => Module -> m Wasm.Section
|
||||
makeTypeSection Module {..} = do
|
||||
makeTypeSection ::
|
||||
MonadError MarshalError m => Module -> ModuleSymbolTable -> m Wasm.Section
|
||||
makeTypeSection Module {..} ModuleSymbolTable {..} = do
|
||||
_func_types <-
|
||||
for (Map.elems functionTypeMap) $ \FunctionType {..} -> do
|
||||
_param_types <-
|
||||
for paramTypes $ \case
|
||||
None -> throwError InvalidParameterType
|
||||
I32 -> pure Wasm.I32
|
||||
I64 -> pure Wasm.I64
|
||||
F32 -> pure Wasm.F32
|
||||
F64 -> pure Wasm.F64
|
||||
let _result_type = makeResultType returnType
|
||||
for (Map.keys functionTypeSymbols) $ \FunctionType {..} -> do
|
||||
let _param_types = map makeValueType paramTypes
|
||||
_result_type = map makeValueType returnTypes
|
||||
pure
|
||||
Wasm.FunctionType
|
||||
{parameterTypes = _param_types, resultTypes = _result_type}
|
||||
@ -93,7 +90,7 @@ makeImportSection Module {..} ModuleSymbolTable {..} =
|
||||
{ moduleName = coerce externalModuleName
|
||||
, importName = coerce externalBaseName
|
||||
, importDescription =
|
||||
Wasm.ImportFunction $ functionTypeSymbols ! functionTypeName
|
||||
Wasm.ImportFunction $ functionTypeSymbols ! functionType
|
||||
}
|
||||
| FunctionImport {..} <- functionImports
|
||||
]
|
||||
@ -105,7 +102,7 @@ makeFunctionSection Module {..} ModuleSymbolTable {..} =
|
||||
pure
|
||||
Wasm.FunctionSection
|
||||
{ functionTypeIndices =
|
||||
[ functionTypeSymbols ! functionTypeName
|
||||
[ functionTypeSymbols ! functionType
|
||||
| Function {..} <- Map.elems functionMap'
|
||||
]
|
||||
}
|
||||
@ -143,9 +140,7 @@ makeMemorySection Module {..} =
|
||||
Wasm.MemoryType
|
||||
{ memoryLimits =
|
||||
Wasm.Limits
|
||||
{ minLimit = initialPages
|
||||
, maxLimit = Just maximumPages
|
||||
}
|
||||
{minLimit = initialPages, maxLimit = Nothing}
|
||||
}
|
||||
}
|
||||
]
|
||||
@ -244,8 +239,7 @@ makeLocalContext Module {..} Function {..} =
|
||||
(arity, emptyLocalContext) $
|
||||
sort $ zip varTypes [arity ..]
|
||||
where
|
||||
arity =
|
||||
fromIntegral $ length $ paramTypes (functionTypeMap ! functionTypeName)
|
||||
arity = fromIntegral $ length $ paramTypes functionType
|
||||
|
||||
lookupLocalContext :: LocalContext -> BinaryenIndex -> Wasm.LocalIndex
|
||||
lookupLocalContext LocalContext {..} i =
|
||||
@ -276,7 +270,7 @@ makeInstructions _module_symtable@ModuleSymbolTable {..} _de_bruijn_ctx _local_c
|
||||
pure $
|
||||
DList.singleton
|
||||
Wasm.Block
|
||||
{ blockResultType = makeResultType valueType
|
||||
{ blockResultType = map makeValueType blockReturnTypes
|
||||
, blockInstructions = DList.toList $ mconcat bs
|
||||
}
|
||||
If {..} -> do
|
||||
@ -287,12 +281,16 @@ makeInstructions _module_symtable@ModuleSymbolTable {..} _de_bruijn_ctx _local_c
|
||||
makeInstructions _module_symtable _new_de_bruijn_ctx _local_ctx ifTrue
|
||||
f <-
|
||||
DList.toList <$>
|
||||
makeInstructions _module_symtable _new_de_bruijn_ctx _local_ctx ifFalse
|
||||
makeInstructionsMaybe
|
||||
_module_symtable
|
||||
_new_de_bruijn_ctx
|
||||
_local_ctx
|
||||
ifFalse
|
||||
pure $
|
||||
c <>
|
||||
DList.singleton
|
||||
Wasm.If
|
||||
{ ifResultType = makeResultType $ infer ifTrue
|
||||
{ ifResultType = map makeValueType $ infer ifTrue
|
||||
, thenInstructions = t
|
||||
, elseInstructions =
|
||||
case f of
|
||||
@ -307,16 +305,11 @@ makeInstructions _module_symtable@ModuleSymbolTable {..} _de_bruijn_ctx _local_c
|
||||
Wasm.Loop {loopResultType = [], loopInstructions = DList.toList b}
|
||||
Break {..} -> do
|
||||
let _lbl = extractLabel _de_bruijn_ctx name
|
||||
case condition of
|
||||
Null -> pure $ DList.singleton Wasm.Branch {branchLabel = _lbl}
|
||||
_ -> do
|
||||
c <-
|
||||
makeInstructions
|
||||
_module_symtable
|
||||
_de_bruijn_ctx
|
||||
_local_ctx
|
||||
condition
|
||||
case breakCondition of
|
||||
Just cond -> do
|
||||
c <- makeInstructions _module_symtable _de_bruijn_ctx _local_ctx cond
|
||||
pure $ c <> DList.singleton Wasm.BranchIf {branchIfLabel = _lbl}
|
||||
_ -> pure $ DList.singleton Wasm.Branch {branchLabel = _lbl}
|
||||
Switch {..} -> do
|
||||
c <- makeInstructions _module_symtable _de_bruijn_ctx _local_ctx condition
|
||||
pure $
|
||||
@ -356,7 +349,7 @@ makeInstructions _module_symtable@ModuleSymbolTable {..} _de_bruijn_ctx _local_c
|
||||
mconcat xs <> f <>
|
||||
DList.singleton
|
||||
Wasm.CallIndirect
|
||||
{callIndirectFuctionTypeIndex = functionTypeSymbols ! typeName}
|
||||
{callIndirectFuctionTypeIndex = functionTypeSymbols ! functionType}
|
||||
GetLocal {..} ->
|
||||
pure $
|
||||
DList.singleton
|
||||
@ -563,22 +556,37 @@ makeInstructions _module_symtable@ModuleSymbolTable {..} _de_bruijn_ctx _local_c
|
||||
pure $ mconcat xs <> op
|
||||
Nop -> pure $ DList.singleton Wasm.Nop
|
||||
Unreachable -> pure $ DList.singleton Wasm.Unreachable
|
||||
Null -> pure mempty
|
||||
Symbol {resolvedSymbol = Just x, ..} ->
|
||||
pure $
|
||||
DList.singleton
|
||||
Wasm.I64Const {i64ConstValue = x + fromIntegral symbolOffset}
|
||||
_ -> throwError $ UnsupportedExpression expr
|
||||
|
||||
makeInstructionsMaybe ::
|
||||
MonadError MarshalError m
|
||||
=> ModuleSymbolTable
|
||||
-> DeBruijnContext
|
||||
-> LocalContext
|
||||
-> Maybe Expression
|
||||
-> m (DList.DList Wasm.Instruction)
|
||||
makeInstructionsMaybe _module_symtable _de_bruijn_ctx _local_ctx m_expr =
|
||||
case m_expr of
|
||||
Just expr ->
|
||||
makeInstructions _module_symtable _de_bruijn_ctx _local_ctx expr
|
||||
_ -> pure mempty
|
||||
|
||||
makeCodeSection ::
|
||||
MonadError MarshalError m => Module -> ModuleSymbolTable -> m Wasm.Section
|
||||
makeCodeSection _mod@Module {..} _module_symtable =
|
||||
fmap Wasm.CodeSection $
|
||||
for (Map.elems functionMap') $ \_func@Function {..} -> do
|
||||
let _local_ctx@LocalContext {..} = makeLocalContext _mod _func
|
||||
_locals <-
|
||||
for (Map.toList localCount) $ \case
|
||||
(None, _) -> throwError InvalidLocalType
|
||||
(I32, c) -> pure (Wasm.I32, c)
|
||||
(I64, c) -> pure (Wasm.I64, c)
|
||||
(F32, c) -> pure (Wasm.F32, c)
|
||||
(F64, c) -> pure (Wasm.F64, c)
|
||||
_locals =
|
||||
flip map (Map.toList localCount) $ \case
|
||||
(I32, c) -> (Wasm.I32, c)
|
||||
(I64, c) -> (Wasm.I64, c)
|
||||
(F32, c) -> (Wasm.F32, c)
|
||||
(F64, c) -> (Wasm.F64, c)
|
||||
_body <-
|
||||
makeInstructions _module_symtable emptyDeBruijnContext _local_ctx body
|
||||
pure
|
||||
@ -614,7 +622,7 @@ makeDataSection Module {..} _module_symtable =
|
||||
makeModule :: MonadError MarshalError m => Module -> m Wasm.Module
|
||||
makeModule m = do
|
||||
_module_symtable <- makeModuleSymbolTable m
|
||||
_type_sec <- makeTypeSection m
|
||||
_type_sec <- makeTypeSection m _module_symtable
|
||||
_import_sec <- makeImportSection m _module_symtable
|
||||
_func_sec <- makeFunctionSection m _module_symtable
|
||||
_table_sec <- makeTableSection m
|
||||
|
||||
@ -37,24 +37,27 @@ relooper RelooperRun {..} = result_expr
|
||||
M.foldlWithKey'
|
||||
(\(tot_expr, residule_exprs) lbl RelooperBlock {..} ->
|
||||
( Block
|
||||
{name = lbl, bodys = tot_expr : residule_exprs, valueType = None}
|
||||
{ name = lbl
|
||||
, bodys = tot_expr : residule_exprs
|
||||
, blockReturnTypes = []
|
||||
}
|
||||
, case addBlock of
|
||||
AddBlock {..} ->
|
||||
code :
|
||||
(case addBranches of
|
||||
[] -> [Break {name = exit_lbl, condition = Null}]
|
||||
[] -> [Break {name = exit_lbl, breakCondition = Nothing}]
|
||||
branches ->
|
||||
foldr
|
||||
(\AddBranch {condition, to} e ->
|
||||
(\AddBranch {addBranchCondition = Just cond, to} e ->
|
||||
If
|
||||
{ condition = condition
|
||||
{ condition = cond
|
||||
, ifTrue = set_block_lbl to
|
||||
, ifFalse = e
|
||||
, ifFalse = Just e
|
||||
})
|
||||
(set_block_lbl $ to def_branch)
|
||||
(init branches) :
|
||||
[Break {name = loop_lbl, condition = Null}]
|
||||
where def_branch@AddBranch {condition = Null, code = Null} =
|
||||
[Break {name = loop_lbl, breakCondition = Nothing}]
|
||||
where def_branch@AddBranch {addBranchCondition = Nothing} =
|
||||
last branches)
|
||||
AddBlockWithSwitch {..} ->
|
||||
[code, SetLocal {index = 1, value = condition}] <>
|
||||
@ -73,13 +76,13 @@ relooper RelooperRun {..} = result_expr
|
||||
| tag <- indexes
|
||||
]
|
||||
, ifTrue = set_block_lbl to
|
||||
, ifFalse = e
|
||||
, ifFalse = Just e
|
||||
})
|
||||
(set_block_lbl $ to def_branch)
|
||||
(init branches) :
|
||||
[Break {name = loop_lbl, condition = Null}])
|
||||
[Break {name = loop_lbl, breakCondition = Nothing}])
|
||||
where branches = addBranches
|
||||
def_branch@AddBranch {condition = Null, code = Null} =
|
||||
def_branch@AddBranch {addBranchCondition = Nothing} =
|
||||
last branches))
|
||||
(initial_expr, [])
|
||||
blockMap
|
||||
@ -94,11 +97,11 @@ relooper RelooperRun {..} = result_expr
|
||||
Block
|
||||
{ name = ""
|
||||
, bodys = blocks_expr : last_block_residule_exprs
|
||||
, valueType = None
|
||||
, blockReturnTypes = []
|
||||
}
|
||||
}
|
||||
]
|
||||
, valueType = None
|
||||
, blockReturnTypes = []
|
||||
}
|
||||
|
||||
relooperDeep :: (Monad m, Data a) => a -> m a
|
||||
|
||||
@ -113,10 +113,10 @@ resolveGlobalRegs x =
|
||||
UnresolvedGetGlobal {..}
|
||||
| unresolvedGlobalReg == BaseReg ->
|
||||
pure
|
||||
Binary
|
||||
{ binaryOp = AddInt64
|
||||
, operand0 = Unresolved {unresolvedSymbol = "MainCapability"}
|
||||
, operand1 = ConstI64 $ fromIntegral offset_Capability_r
|
||||
Symbol
|
||||
{ unresolvedSymbol = "MainCapability"
|
||||
, symbolOffset = offset_Capability_r
|
||||
, resolvedSymbol = Nothing
|
||||
}
|
||||
| otherwise ->
|
||||
pure
|
||||
@ -131,7 +131,7 @@ resolveGlobalRegs x =
|
||||
| unresolvedGlobalReg == BaseReg ->
|
||||
pure $
|
||||
emitErrorMessage
|
||||
None
|
||||
[]
|
||||
"SetGlobal instruction: attempting to assign to BaseReg"
|
||||
| otherwise -> do
|
||||
new_value <- resolveGlobalRegs value
|
||||
@ -150,12 +150,10 @@ resolveGlobalRegs x =
|
||||
Unary
|
||||
{ unaryOp = WrapInt64
|
||||
, operand0 =
|
||||
Binary
|
||||
{ binaryOp = AddInt64
|
||||
, operand0 = Unresolved {unresolvedSymbol = "MainCapability"}
|
||||
, operand1 =
|
||||
ConstI64 $
|
||||
fromIntegral $ offset_Capability_r + globalRegOffset gr
|
||||
Symbol
|
||||
{ unresolvedSymbol = "MainCapability"
|
||||
, symbolOffset = offset_Capability_r + globalRegOffset gr
|
||||
, resolvedSymbol = Nothing
|
||||
}
|
||||
}
|
||||
go = gmapM resolveGlobalRegs x
|
||||
@ -294,9 +292,11 @@ mergeSymbols debug AsteriusStore {..} root_syms export_funcs = do
|
||||
, AsteriusFunction
|
||||
{ functionType =
|
||||
FunctionType
|
||||
{returnType = I64, paramTypes = []}
|
||||
{ paramTypes = []
|
||||
, returnTypes = [I64]
|
||||
}
|
||||
, body =
|
||||
emitErrorMessage I64 $
|
||||
emitErrorMessage [I64] $
|
||||
entityName i_staging_sym <>
|
||||
" failed: it was marked as broken by code generator, with error message: " <>
|
||||
showSBS
|
||||
@ -361,7 +361,6 @@ makeMemory debug AsteriusModule {..} last_o sym_map =
|
||||
{ initialPages =
|
||||
fromIntegral $
|
||||
roundup (fromIntegral last_o) mblock_size `div` wasmPageSize
|
||||
, maximumPages = 65535
|
||||
, exportName = "mem"
|
||||
, dataSegments =
|
||||
if debug
|
||||
@ -413,9 +412,8 @@ resolveEntitySymbols sym_table = f
|
||||
case eqTypeRep (typeOf t) (typeRep :: TypeRep Expression) of
|
||||
Just HRefl ->
|
||||
case t of
|
||||
Unresolved {..} -> pure $ ConstI64 $ subst unresolvedSymbol
|
||||
UnresolvedOff {..} ->
|
||||
pure $ ConstI64 $ subst unresolvedSymbol + fromIntegral offset'
|
||||
Symbol {..} ->
|
||||
pure t {resolvedSymbol = Just $ subst unresolvedSymbol}
|
||||
_ -> go
|
||||
_ ->
|
||||
case eqTypeRep (typeOf t) (typeRep :: TypeRep AsteriusStatic) of
|
||||
@ -423,26 +421,17 @@ resolveEntitySymbols sym_table = f
|
||||
case t of
|
||||
UnresolvedStatic unresolvedSymbol ->
|
||||
pure $ Serialized (encodeStorable (subst unresolvedSymbol))
|
||||
UnresolvedOffStatic unresolvedSymbol offset' ->
|
||||
SymbolStatic unresolvedSymbol symbolOffset ->
|
||||
pure $
|
||||
Serialized
|
||||
(encodeStorable
|
||||
(subst unresolvedSymbol + fromIntegral offset'))
|
||||
(subst unresolvedSymbol + fromIntegral symbolOffset))
|
||||
_ -> pure t
|
||||
_ -> go
|
||||
where
|
||||
go = gmapM f t
|
||||
subst = (sym_table !)
|
||||
|
||||
resolveFunctionImport :: AsteriusFunctionImport -> FunctionImport
|
||||
resolveFunctionImport AsteriusFunctionImport {..} =
|
||||
FunctionImport
|
||||
{ internalName = internalName
|
||||
, externalModuleName = externalModuleName
|
||||
, externalBaseName = externalBaseName
|
||||
, functionTypeName = generateWasmFunctionTypeName functionType
|
||||
}
|
||||
|
||||
collectErrorMessages :: Data a => a -> S.Set ErrorMessage
|
||||
collectErrorMessages = collect proxy#
|
||||
|
||||
@ -467,11 +456,11 @@ rewriteEmitErrorMessage x = do
|
||||
[ CallImport
|
||||
{ target' = "__asterius_errorI32"
|
||||
, operands = [ConstI32 $ msg_lookup errorMessage]
|
||||
, valueType = None
|
||||
, callImportReturnTypes = []
|
||||
}
|
||||
, Unreachable
|
||||
]
|
||||
, valueType = valueType
|
||||
, blockReturnTypes = phantomReturnTypes
|
||||
}
|
||||
_ -> go
|
||||
_ -> go
|
||||
@ -495,8 +484,7 @@ resolveAsteriusModule debug bundled_ffi_state export_funcs m_globals_resolved =
|
||||
resolve_syms = resolveEntitySymbols (func_sym_map <> ss_sym_map)
|
||||
m_globals_syms_resolved <- resolve_syms m_globals_resolved
|
||||
let func_imports =
|
||||
rtsAsteriusFunctionImports debug <>
|
||||
generateFFIFunctionImports bundled_ffi_state
|
||||
rtsFunctionImports debug <> generateFFIFunctionImports bundled_ffi_state
|
||||
new_function_map <-
|
||||
fmap M.fromList $
|
||||
for (M.toList $ functionMap m_globals_syms_resolved) $ \(func_sym, AsteriusFunction {..}) -> do
|
||||
@ -504,7 +492,7 @@ resolveAsteriusModule debug bundled_ffi_state export_funcs m_globals_resolved =
|
||||
resolveLocalRegs (length $ paramTypes functionType) body
|
||||
let func =
|
||||
Function
|
||||
{ functionTypeName = generateWasmFunctionTypeName functionType
|
||||
{ functionType = functionType
|
||||
, varTypes = local_types
|
||||
, body = body_locals_resolved
|
||||
}
|
||||
@ -517,18 +505,8 @@ resolveAsteriusModule debug bundled_ffi_state export_funcs m_globals_resolved =
|
||||
(new_mod, err_msgs) <-
|
||||
rewriteEmitErrorMessage
|
||||
Module
|
||||
{ functionTypeMap =
|
||||
M.fromList
|
||||
[ (generateWasmFunctionTypeName ft, ft)
|
||||
| ft <-
|
||||
[functionType | AsteriusFunctionImport {..} <- func_imports] <>
|
||||
[ functionType
|
||||
| AsteriusFunction {..} <-
|
||||
M.elems $ functionMap m_globals_syms_resolved
|
||||
]
|
||||
]
|
||||
, functionMap' = new_function_map
|
||||
, functionImports = [resolveFunctionImport imp | imp <- func_imports]
|
||||
{ functionMap' = new_function_map
|
||||
, functionImports = func_imports
|
||||
, functionExports =
|
||||
rtsAsteriusFunctionExports debug <>
|
||||
[ FunctionExport
|
||||
|
||||
@ -40,7 +40,7 @@ addTracingModule func_sym_map func_sym func_type func
|
||||
new_body <- f body
|
||||
pure
|
||||
Function
|
||||
{ functionTypeName = functionTypeName
|
||||
{ functionType = functionType
|
||||
, varTypes = varTypes
|
||||
, body =
|
||||
Block
|
||||
@ -49,11 +49,11 @@ addTracingModule func_sym_map func_sym func_type func
|
||||
[ CallImport
|
||||
{ target' = "__asterius_traceCmm"
|
||||
, operands = [func_idx]
|
||||
, valueType = None
|
||||
, callImportReturnTypes = []
|
||||
}
|
||||
, new_body
|
||||
]
|
||||
, valueType = infer new_body
|
||||
, blockReturnTypes = infer new_body
|
||||
}
|
||||
}
|
||||
_ ->
|
||||
@ -83,11 +83,11 @@ addTracingModule func_sym_map func_sym func_type func
|
||||
[ func_idx
|
||||
, lbl_to_idx lbl
|
||||
]
|
||||
, valueType = None
|
||||
, callImportReturnTypes = []
|
||||
}
|
||||
, new_code
|
||||
]
|
||||
, valueType = infer new_code
|
||||
, blockReturnTypes = infer new_code
|
||||
}
|
||||
}
|
||||
})
|
||||
@ -109,11 +109,11 @@ addTracingModule func_sym_map func_sym func_type func
|
||||
[ func_idx
|
||||
, lbl_to_idx lbl
|
||||
]
|
||||
, valueType = None
|
||||
, callImportReturnTypes = []
|
||||
}
|
||||
, new_code
|
||||
]
|
||||
, valueType = infer new_code
|
||||
, blockReturnTypes = infer new_code
|
||||
}
|
||||
, condition = condition
|
||||
}
|
||||
@ -137,10 +137,10 @@ addTracingModule func_sym_map func_sym func_type func
|
||||
[func_idx, ConstI32 $ fromIntegral index] <>
|
||||
cutI64
|
||||
GetLocal {index = index, valueType = I64}
|
||||
, valueType = None
|
||||
, callImportReturnTypes = []
|
||||
}
|
||||
]
|
||||
, valueType = None
|
||||
, blockReturnTypes = []
|
||||
}
|
||||
where params = paramTypes func_type
|
||||
param_num = length params
|
||||
|
||||
@ -6,47 +6,45 @@ module Asterius.TypeInfer
|
||||
|
||||
import Asterius.Types
|
||||
|
||||
infer :: Expression -> ValueType
|
||||
infer :: Expression -> [ValueType]
|
||||
infer expr =
|
||||
case expr of
|
||||
Block {..} -> valueType
|
||||
Block {..} -> blockReturnTypes
|
||||
If {..} -> infer ifTrue
|
||||
Loop {} -> None
|
||||
Break {} -> None
|
||||
Switch {} -> None
|
||||
Call {..} -> valueType
|
||||
CallImport {..} -> valueType
|
||||
CallIndirect {} -> I64
|
||||
GetLocal {..} -> valueType
|
||||
SetLocal {..} -> None
|
||||
Load {..} -> valueType
|
||||
Store {} -> None
|
||||
ConstI32 {} -> I32
|
||||
ConstI64 {} -> I64
|
||||
ConstF32 {} -> F32
|
||||
ConstF64 {} -> F64
|
||||
Unary {unaryOp = WrapInt64} -> I32
|
||||
Unary {unaryOp = ExtendUInt32} -> I64
|
||||
Host {..} -> I32
|
||||
Nop -> None
|
||||
Unreachable -> None
|
||||
CFG {} -> None
|
||||
Unresolved {} -> I64
|
||||
UnresolvedOff {} -> I64
|
||||
Loop {} -> []
|
||||
Break {} -> []
|
||||
Switch {} -> []
|
||||
Call {..} -> callReturnTypes
|
||||
CallImport {..} -> callImportReturnTypes
|
||||
CallIndirect {} -> [I64]
|
||||
GetLocal {..} -> [valueType]
|
||||
SetLocal {..} -> []
|
||||
Load {..} -> [valueType]
|
||||
Store {} -> []
|
||||
ConstI32 {} -> [I32]
|
||||
ConstI64 {} -> [I64]
|
||||
ConstF32 {} -> [F32]
|
||||
ConstF64 {} -> [F64]
|
||||
Unary {unaryOp = WrapInt64} -> [I32]
|
||||
Unary {unaryOp = ExtendUInt32} -> [I64]
|
||||
Host {..} -> [I32]
|
||||
Nop -> []
|
||||
Unreachable -> []
|
||||
CFG {} -> []
|
||||
Symbol {} -> [I64]
|
||||
UnresolvedGetLocal {..} ->
|
||||
case unresolvedLocalReg of
|
||||
UniqueLocalReg _ vt -> vt
|
||||
QuotRemI32X -> I32
|
||||
QuotRemI32Y -> I32
|
||||
QuotRemI64X -> I64
|
||||
QuotRemI64Y -> I64
|
||||
UnresolvedSetLocal {} -> None
|
||||
UniqueLocalReg _ vt -> [vt]
|
||||
QuotRemI32X -> [I32]
|
||||
QuotRemI32Y -> [I32]
|
||||
QuotRemI64X -> [I64]
|
||||
QuotRemI64Y -> [I64]
|
||||
UnresolvedSetLocal {} -> []
|
||||
UnresolvedGetGlobal {..} ->
|
||||
case unresolvedGlobalReg of
|
||||
FloatReg {} -> F32
|
||||
DoubleReg {} -> F64
|
||||
_ -> I64
|
||||
UnresolvedSetGlobal {..} -> None
|
||||
EmitErrorMessage {..} -> valueType
|
||||
Null -> None
|
||||
FloatReg {} -> [F32]
|
||||
DoubleReg {} -> [F64]
|
||||
_ -> [I64]
|
||||
UnresolvedSetGlobal {..} -> []
|
||||
EmitErrorMessage {..} -> phantomReturnTypes
|
||||
_ -> error $ "Asterius.TypeInfer.infer: " <> show expr
|
||||
|
||||
@ -3,11 +3,7 @@
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Asterius.Types
|
||||
( BinaryenIndex
|
||||
@ -15,7 +11,6 @@ module Asterius.Types
|
||||
, AsteriusStatic(..)
|
||||
, AsteriusStatics(..)
|
||||
, AsteriusFunction(..)
|
||||
, AsteriusFunctionImport(..)
|
||||
, AsteriusModule(..)
|
||||
, AsteriusModuleSymbol(..)
|
||||
, AsteriusEntitySymbol(..)
|
||||
@ -80,8 +75,8 @@ instance Exception AsteriusCodeGenError
|
||||
|
||||
data AsteriusStatic
|
||||
= UnresolvedStatic AsteriusEntitySymbol
|
||||
| UnresolvedOffStatic AsteriusEntitySymbol
|
||||
Int
|
||||
| SymbolStatic AsteriusEntitySymbol
|
||||
Int
|
||||
| Uninitialized Int
|
||||
| Serialized SBS.ShortByteString
|
||||
deriving (Eq, Ord, Show, Generic, Data)
|
||||
@ -101,13 +96,6 @@ data AsteriusFunction = AsteriusFunction
|
||||
|
||||
instance Binary AsteriusFunction
|
||||
|
||||
data AsteriusFunctionImport = AsteriusFunctionImport
|
||||
{ internalName, externalModuleName, externalBaseName :: SBS.ShortByteString
|
||||
, functionType :: FunctionType
|
||||
} deriving (Eq, Show, Generic, Data)
|
||||
|
||||
instance Binary AsteriusFunctionImport
|
||||
|
||||
data AsteriusModule = AsteriusModule
|
||||
{ staticsMap :: M.Map AsteriusEntitySymbol AsteriusStatics
|
||||
, staticsErrorMap :: M.Map AsteriusEntitySymbol AsteriusCodeGenError
|
||||
@ -201,8 +189,7 @@ deriving newtype instance Show ErrorMessage
|
||||
instance Binary ErrorMessage
|
||||
|
||||
data ValueType
|
||||
= None
|
||||
| I32
|
||||
= I32
|
||||
| I64
|
||||
| F32
|
||||
| F64
|
||||
@ -211,8 +198,7 @@ data ValueType
|
||||
instance Binary ValueType
|
||||
|
||||
data FunctionType = FunctionType
|
||||
{ returnType :: ValueType
|
||||
, paramTypes :: [ValueType]
|
||||
{ paramTypes, returnTypes :: [ValueType]
|
||||
} deriving (Eq, Ord, Show, Generic, Data)
|
||||
|
||||
instance Binary FunctionType
|
||||
@ -360,24 +346,25 @@ instance Binary HostOp
|
||||
data Expression
|
||||
= Block { name :: SBS.ShortByteString
|
||||
, bodys :: [Expression]
|
||||
, valueType :: ValueType }
|
||||
| If { condition, ifTrue, ifFalse :: Expression }
|
||||
, blockReturnTypes :: [ValueType] }
|
||||
| If { condition, ifTrue :: Expression
|
||||
, ifFalse :: Maybe Expression }
|
||||
| Loop { name :: SBS.ShortByteString
|
||||
, body :: Expression }
|
||||
| Break { name :: SBS.ShortByteString
|
||||
, condition :: Expression }
|
||||
, breakCondition :: Maybe Expression }
|
||||
| Switch { names :: [SBS.ShortByteString]
|
||||
, defaultName :: SBS.ShortByteString
|
||||
, condition :: Expression }
|
||||
| Call { target :: AsteriusEntitySymbol
|
||||
, operands :: [Expression]
|
||||
, valueType :: ValueType }
|
||||
, callReturnTypes :: [ValueType] }
|
||||
| CallImport { target' :: SBS.ShortByteString
|
||||
, operands :: [Expression]
|
||||
, valueType :: ValueType }
|
||||
, callImportReturnTypes :: [ValueType] }
|
||||
| CallIndirect { indirectTarget :: Expression
|
||||
, operands :: [Expression]
|
||||
, typeName :: SBS.ShortByteString }
|
||||
, functionType :: FunctionType }
|
||||
| GetLocal { index :: BinaryenIndex
|
||||
, valueType :: ValueType }
|
||||
| SetLocal { index :: BinaryenIndex
|
||||
@ -398,14 +385,13 @@ data Expression
|
||||
| Binary { binaryOp :: BinaryOp
|
||||
, operand0, operand1 :: Expression }
|
||||
| Host { hostOp :: HostOp
|
||||
, name :: SBS.ShortByteString
|
||||
, operands :: [Expression] }
|
||||
| Nop
|
||||
| Unreachable
|
||||
| CFG { graph :: RelooperRun }
|
||||
| Unresolved { unresolvedSymbol :: AsteriusEntitySymbol }
|
||||
| UnresolvedOff { unresolvedSymbol :: AsteriusEntitySymbol
|
||||
, offset' :: Int }
|
||||
| Symbol { unresolvedSymbol :: AsteriusEntitySymbol
|
||||
, symbolOffset :: Int
|
||||
, resolvedSymbol :: Maybe Int64 }
|
||||
| UnresolvedGetLocal { unresolvedLocalReg :: UnresolvedLocalReg }
|
||||
| UnresolvedSetLocal { unresolvedLocalReg :: UnresolvedLocalReg
|
||||
, value :: Expression }
|
||||
@ -413,14 +399,13 @@ data Expression
|
||||
| UnresolvedSetGlobal { unresolvedGlobalReg :: UnresolvedGlobalReg
|
||||
, value :: Expression }
|
||||
| EmitErrorMessage { errorMessage :: ErrorMessage
|
||||
, valueType :: ValueType }
|
||||
| Null
|
||||
, phantomReturnTypes :: [ValueType] }
|
||||
deriving (Eq, Show, Generic, Data)
|
||||
|
||||
instance Binary Expression
|
||||
|
||||
data Function = Function
|
||||
{ functionTypeName :: SBS.ShortByteString
|
||||
{ functionType :: FunctionType
|
||||
, varTypes :: [ValueType]
|
||||
, body :: Expression
|
||||
} deriving (Eq, Show, Generic, Data)
|
||||
@ -428,7 +413,8 @@ data Function = Function
|
||||
instance Binary Function
|
||||
|
||||
data FunctionImport = FunctionImport
|
||||
{ internalName, externalModuleName, externalBaseName, functionTypeName :: SBS.ShortByteString
|
||||
{ internalName, externalModuleName, externalBaseName :: SBS.ShortByteString
|
||||
, functionType :: FunctionType
|
||||
} deriving (Eq, Show, Data, Generic)
|
||||
|
||||
instance Binary FunctionImport
|
||||
@ -453,7 +439,7 @@ data DataSegment = DataSegment
|
||||
instance Binary DataSegment
|
||||
|
||||
data Memory = Memory
|
||||
{ initialPages, maximumPages :: BinaryenIndex
|
||||
{ initialPages :: BinaryenIndex
|
||||
, exportName :: SBS.ShortByteString
|
||||
, dataSegments :: [DataSegment]
|
||||
} deriving (Eq, Show, Data, Generic)
|
||||
@ -461,8 +447,7 @@ data Memory = Memory
|
||||
instance Binary Memory
|
||||
|
||||
data Module = Module
|
||||
{ functionTypeMap :: M.Map SBS.ShortByteString FunctionType
|
||||
, functionMap' :: M.Map SBS.ShortByteString Function
|
||||
{ functionMap' :: M.Map SBS.ShortByteString Function
|
||||
, functionImports :: [FunctionImport]
|
||||
, functionExports :: [FunctionExport]
|
||||
, functionTable :: FunctionTable
|
||||
@ -480,10 +465,9 @@ instance Binary RelooperAddBlock
|
||||
|
||||
data RelooperAddBranch
|
||||
= AddBranch { to :: SBS.ShortByteString
|
||||
, condition, code :: Expression }
|
||||
, addBranchCondition :: Maybe Expression }
|
||||
| AddBranchForSwitch { to :: SBS.ShortByteString
|
||||
, indexes :: [BinaryenIndex]
|
||||
, code :: Expression }
|
||||
, indexes :: [BinaryenIndex] }
|
||||
deriving (Eq, Show, Generic, Data)
|
||||
|
||||
instance Binary RelooperAddBranch
|
||||
@ -520,8 +504,7 @@ data FFIValueType
|
||||
instance Binary FFIValueType
|
||||
|
||||
data FFIFunctionType = FFIFunctionType
|
||||
{ ffiParamTypes :: [FFIValueType]
|
||||
, ffiResultType :: Maybe FFIValueType
|
||||
{ ffiParamTypes, ffiResultTypes :: [FFIValueType]
|
||||
, ffiInIO :: Bool
|
||||
} deriving (Eq, Show, Generic, Data)
|
||||
|
||||
|
||||
@ -5,7 +5,7 @@
|
||||
module Asterius.TypesConv
|
||||
( marshalToModuleSymbol
|
||||
, zEncodeModuleSymbol
|
||||
, generateWasmFunctionTypeName
|
||||
, generateWasmFunctionTypeSet
|
||||
, asmPpr
|
||||
, asmPrint
|
||||
) where
|
||||
@ -15,12 +15,14 @@ import Asterius.Types
|
||||
import qualified Data.ByteString.Char8 as CBS
|
||||
import qualified Data.ByteString.Short as SBS
|
||||
import Data.List
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified GhcPlugins as GHC
|
||||
import Prelude hiding (IO)
|
||||
import qualified Pretty as GHC
|
||||
import System.IO (IOMode(WriteMode), withFile)
|
||||
|
||||
{-# INLINEABLE marshalToModuleSymbol #-}
|
||||
{-# INLINE marshalToModuleSymbol #-}
|
||||
marshalToModuleSymbol :: GHC.Module -> AsteriusModuleSymbol
|
||||
marshalToModuleSymbol (GHC.Module u m) =
|
||||
AsteriusModuleSymbol
|
||||
@ -30,7 +32,7 @@ marshalToModuleSymbol (GHC.Module u m) =
|
||||
CBS.splitWith (== '.') $ GHC.fs_bs $ GHC.moduleNameFS m
|
||||
}
|
||||
|
||||
{-# INLINEABLE zEncodeModuleSymbol #-}
|
||||
{-# INLINE zEncodeModuleSymbol #-}
|
||||
zEncodeModuleSymbol :: AsteriusModuleSymbol -> String
|
||||
zEncodeModuleSymbol AsteriusModuleSymbol {..} =
|
||||
GHC.zString $
|
||||
@ -39,18 +41,17 @@ zEncodeModuleSymbol AsteriusModuleSymbol {..} =
|
||||
SBS.fromShort unitId <> "_" <>
|
||||
CBS.intercalate "." [SBS.fromShort mod_chunk | mod_chunk <- moduleName]
|
||||
|
||||
{-# INLINEABLE generateWasmFunctionTypeName #-}
|
||||
generateWasmFunctionTypeName :: FunctionType -> SBS.ShortByteString
|
||||
generateWasmFunctionTypeName FunctionType {..} =
|
||||
showSBS returnType <> "(" <>
|
||||
mconcat (intersperse "," [showSBS t | t <- paramTypes]) <>
|
||||
")"
|
||||
{-# INLINE generateWasmFunctionTypeSet #-}
|
||||
generateWasmFunctionTypeSet :: Module -> Set.Set FunctionType
|
||||
generateWasmFunctionTypeSet Module {..} =
|
||||
Set.fromList [functionType | FunctionImport {..} <- functionImports] <>
|
||||
Set.fromList [functionType | Function {..} <- Map.elems functionMap']
|
||||
|
||||
{-# INLINEABLE asmPpr #-}
|
||||
{-# INLINE asmPpr #-}
|
||||
asmPpr :: GHC.Outputable a => GHC.DynFlags -> a -> String
|
||||
asmPpr dflags = GHC.showSDoc dflags . GHC.pprCode GHC.AsmStyle . GHC.ppr
|
||||
|
||||
{-# INLINEABLE asmPrint #-}
|
||||
{-# INLINE asmPrint #-}
|
||||
asmPrint :: GHC.Outputable a => GHC.DynFlags -> FilePath -> a -> IO ()
|
||||
asmPrint dflags p a =
|
||||
withFile p WriteMode $ \h ->
|
||||
|
||||
@ -24,7 +24,7 @@ patchWritePtrArrayOp t =
|
||||
new_bodys <- w bodys
|
||||
pure t {bodys = new_bodys}
|
||||
where w :: Monad m => [Expression] -> m [Expression]
|
||||
w (e0@Store {value = Unresolved {unresolvedSymbol = "stg_MUT_ARR_PTRS_DIRTY_info"}}:Store {bytes = 1}:es) = do
|
||||
w (e0@Store {value = Symbol {unresolvedSymbol = "stg_MUT_ARR_PTRS_DIRTY_info"}}:Store {bytes = 1}:es) = do
|
||||
new_es <- w es
|
||||
pure $ e0 : new_es
|
||||
w (e0:e1:es) = do
|
||||
@ -56,7 +56,7 @@ maskUnknownCCallTargets export_funcs = f
|
||||
| not $ has_call_target target ->
|
||||
pure $
|
||||
emitErrorMessage
|
||||
valueType
|
||||
callReturnTypes
|
||||
(entityName target <>
|
||||
" failed: unimplemented stub function entered")
|
||||
| target == "createIOThread" ->
|
||||
|
||||
@ -11,28 +11,25 @@ import Foreign
|
||||
import qualified Language.WebAssembly.WireFormat as Wasm
|
||||
|
||||
main :: IO ()
|
||||
main
|
||||
-- c_BinaryenSetAPITracing 1
|
||||
= do
|
||||
main = do
|
||||
c_BinaryenSetOptimizeLevel 0
|
||||
c_BinaryenSetShrinkLevel 0
|
||||
m <-
|
||||
withPool $ \pool ->
|
||||
marshalModule pool $
|
||||
Module
|
||||
{ functionTypeMap = [("func_type", FunctionType I32 [])]
|
||||
, functionMap' =
|
||||
{ functionMap' =
|
||||
[ ( "func"
|
||||
, Function "func_type" [I32, I64, I64, I32] $
|
||||
, Function (FunctionType [] [I32]) [I32, I64, I64, I32] $
|
||||
Block
|
||||
mempty
|
||||
[Block mempty [Block mempty [GetLocal 3 I32] I32] I32]
|
||||
I32)
|
||||
[Block mempty [Block mempty [GetLocal 3 I32] [I32]] [I32]]
|
||||
[I32])
|
||||
]
|
||||
, functionImports = []
|
||||
, functionExports = []
|
||||
, functionTable = FunctionTable []
|
||||
, memory = Memory 1 1 mempty mempty
|
||||
, memory = Memory 1 mempty mempty
|
||||
}
|
||||
c_BinaryenModuleValidate m >>= print
|
||||
buf <- LBS.fromStrict <$> serializeModule m
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
import Asterius.Internals
|
||||
@ -41,14 +42,14 @@ shrinkExpression =
|
||||
pure expr {bodys = _new_bodys}
|
||||
If {..} -> do
|
||||
_new_ifTrue <- shrinkExpression ifTrue
|
||||
_new_ifFalse <- shrinkExpression ifFalse
|
||||
_new_ifFalse <- shrinkMaybeExpression ifFalse
|
||||
pure expr {ifTrue = _new_ifTrue, ifFalse = _new_ifFalse}
|
||||
Loop {..} -> do
|
||||
_new_body <- shrinkExpression body
|
||||
pure Loop {name = name, body = _new_body}
|
||||
Break {..} -> do
|
||||
_new_condition <- shrinkExpression condition
|
||||
pure Break {name = name, condition = _new_condition}
|
||||
_new_condition <- shrinkMaybeExpression breakCondition
|
||||
pure Break {name = name, breakCondition = _new_condition}
|
||||
Switch {..} -> do
|
||||
_new_condition <- shrinkExpression condition
|
||||
pure
|
||||
@ -90,6 +91,12 @@ shrinkExpression =
|
||||
pure expr {operands = _new_operands}
|
||||
_ -> mempty
|
||||
|
||||
shrinkMaybeExpression :: Shrink (Maybe Expression)
|
||||
shrinkMaybeExpression =
|
||||
preserve Nothing $ \case
|
||||
Just expr -> Just <$> shrinkExpression expr
|
||||
_ -> mempty
|
||||
|
||||
shrinkModule' :: Shrink Module
|
||||
shrinkModule' m@Module {..} = _shrink_funcs {-_shrink_memory <> _shrink_exports <>-}
|
||||
where
|
||||
@ -121,7 +128,7 @@ shrinkModule' m@Module {..} = _shrink_funcs {-_shrink_memory <> _shrink_exports
|
||||
Map.insert
|
||||
_func_to_shrink_key
|
||||
Function
|
||||
{ functionTypeName = functionTypeName
|
||||
{ functionType = functionType
|
||||
, varTypes = varTypes
|
||||
, body = Unreachable
|
||||
}
|
||||
@ -138,7 +145,7 @@ shrinkModule' m@Module {..} = _shrink_funcs {-_shrink_memory <> _shrink_exports
|
||||
Map.insert
|
||||
_func_to_shrink_key
|
||||
Function
|
||||
{ functionTypeName = functionTypeName
|
||||
{ functionType = functionType
|
||||
, varTypes = varTypes
|
||||
, body = _shrink_expr
|
||||
}
|
||||
|
||||
@ -31,7 +31,6 @@ module Language.WebAssembly.WireFormat
|
||||
, Global(..)
|
||||
, ExportDescription(..)
|
||||
, Export(..)
|
||||
, Start(..)
|
||||
, Element(..)
|
||||
, Locals(..)
|
||||
, Function(..)
|
||||
@ -1103,16 +1102,6 @@ putExport Export {..} = do
|
||||
putName exportName
|
||||
putExportDescription exportDescription
|
||||
|
||||
newtype Start = Start
|
||||
{ startFunctionIndex :: FunctionIndex
|
||||
} deriving (Eq, Generic, Ord, Show)
|
||||
|
||||
getStart :: Get Start
|
||||
getStart = coerce getFunctionIndex
|
||||
|
||||
putStart :: Start -> Put
|
||||
putStart = coerce putFunctionIndex
|
||||
|
||||
data Element = Element
|
||||
{ tableIndex :: TableIndex
|
||||
, tableOffset :: Expression
|
||||
@ -1333,7 +1322,7 @@ data Section
|
||||
| MemorySection { memories :: [Memory] }
|
||||
| GlobalSection { globals :: [Global] }
|
||||
| ExportSection { exports :: [Export] }
|
||||
| StartSection { start :: Start }
|
||||
| StartSection { startFunctionIndex :: FunctionIndex }
|
||||
| ElementSection { elements :: [Element] }
|
||||
| CodeSection { functions' :: [Function] }
|
||||
| DataSection { dataSegments :: [DataSegment] }
|
||||
@ -1400,7 +1389,7 @@ getSection = do
|
||||
5 -> getCheckedRegion (MemorySection <$> getVec getMemory)
|
||||
6 -> getCheckedRegion (GlobalSection <$> getVec getGlobal)
|
||||
7 -> getCheckedRegion (ExportSection <$> getVec getExport)
|
||||
8 -> getCheckedRegion (StartSection <$> getStart)
|
||||
8 -> getCheckedRegion (StartSection <$> getFunctionIndex)
|
||||
9 -> getCheckedRegion (ElementSection <$> getVec getElement)
|
||||
10 ->
|
||||
getCheckedRegion (CodeSection <$> getVec (getCheckedRegion getFunction))
|
||||
@ -1465,7 +1454,7 @@ putSection sec =
|
||||
putWithLength $ putVec putExport exports
|
||||
StartSection {..} -> do
|
||||
putWord8 8
|
||||
putWithLength $ putStart start
|
||||
putWithLength $ putFunctionIndex startFunctionIndex
|
||||
ElementSection {..} -> do
|
||||
putWord8 9
|
||||
putWithLength $ putVec putElement elements
|
||||
@ -1560,16 +1549,16 @@ getVS64 :: Get Int64
|
||||
getVS64 = getVSN 64
|
||||
|
||||
getF32 :: Get Float
|
||||
getF32 = getFloatle
|
||||
getF32 = getFloathost
|
||||
|
||||
putF32 :: Float -> Put
|
||||
putF32 = putFloatle
|
||||
putF32 = putFloathost
|
||||
|
||||
getF64 :: Get Double
|
||||
getF64 = getDoublele
|
||||
getF64 = getDoublehost
|
||||
|
||||
putF64 :: Double -> Put
|
||||
putF64 = putDoublele
|
||||
putF64 = putDoublehost
|
||||
|
||||
getVec :: Get a -> Get [a]
|
||||
getVec g = do
|
||||
|
||||
@ -408,13 +408,6 @@ instance Arbitrary Export where
|
||||
arbitrary = genExport
|
||||
shrink = genericShrink
|
||||
|
||||
genStart :: Gen Start
|
||||
genStart = coerce genFunctionIndex
|
||||
|
||||
instance Arbitrary Start where
|
||||
arbitrary = genStart
|
||||
shrink = genericShrink
|
||||
|
||||
genElement :: Gen Element
|
||||
genElement =
|
||||
Element <$> genTableIndex <*> genExpression <*> listOf genFunctionIndex
|
||||
@ -545,7 +538,7 @@ genSection =
|
||||
, MemorySection <$> listOf genMemory
|
||||
, GlobalSection <$> listOf genGlobal
|
||||
, ExportSection <$> listOf genExport
|
||||
, StartSection <$> genStart
|
||||
, StartSection <$> genFunctionIndex
|
||||
, ElementSection <$> listOf genElement
|
||||
, CodeSection <$> listOf genFunction
|
||||
, DataSection <$> listOf genDataSegment
|
||||
|
||||
Loading…
Reference in New Issue
Block a user