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

add fundeps to infer monad instance from producer

Browse Source
This commit is contained in:
Ilya Rezvov
2018-05-30 11:01:29 -07:00
parent 6cc280f7e1
commit 3425547639
1 changed files with 41 additions and 40 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Language/Wasm/Builder.hs
+41 -40
View File
@@ -17,6 +17,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FunctionalDependencies #-}
module Language.Wasm.Builder (
GenMod,
@@ -116,7 +117,7 @@ data TypedExpr m
| ExprF32 (m (Proxy F32))
| ExprF64 (m (Proxy F64))
class (GenFunMonad m) => Producer m expr where
class (GenFunMonad m) => Producer m expr | expr -> m where
type OutType expr
asTypedExpr :: expr -> TypedExpr m
produce :: expr -> m (OutType expr)
@@ -133,15 +134,15 @@ instance (GenFunMonad m, ValueTypeable t) => Producer m (Loc m t) where
t _ = Proxy
produce (Loc i) = appendExpr [GetLocal i] >> return Proxy
instance (GenFunMonad m, ValueTypeable t) => Producer m (Glob mut t) where
type OutType (Glob mut t) = Proxy t
instance (GenFunMonad m, ValueTypeable t) => Producer m (Glob m mut t) where
type OutType (Glob m mut t) = Proxy t
asTypedExpr e = case getValueType (t e) of
I32 -> ExprI32 (produce e >> return Proxy)
I64 -> ExprI64 (produce e >> return Proxy)
F32 -> ExprF32 (produce e >> return Proxy)
F64 -> ExprF64 (produce e >> return Proxy)
where
t :: Glob mut t -> Proxy t
t :: Glob m mut t -> Proxy t
t _ = Proxy
produce (Glob i) = appendExpr [GetGlobal i] >> return Proxy
@@ -579,17 +580,17 @@ trap t = do
unreachable :: (GenFunMonad m) => m ()
unreachable = appendExpr [Unreachable]
class (GenFunMonad m) => Consumer m loc where
class Consumer loc where
type InputType loc
infixr 2 .=
(.=) :: (Producer m expr) => loc -> expr -> m ()
(.=) :: (GenFunMonad m, Producer m expr, InputType loc ~ OutType expr) => loc -> expr -> m ()
instance (GenFunMonad m) => Consumer m (Loc m t) where
instance (GenFunMonad m) => Consumer (Loc m t) where
type InputType (Loc m t) = Proxy t
(.=) (Loc i) expr = produce expr >> appendExpr [SetLocal i]
instance (GenFunMonad m) => Consumer m (Glob M t) where
type InputType (Glob M t) = Proxy t
instance (GenFunMonad m) => Consumer (Glob m M t) where
type InputType (Glob m M t) = Proxy t
(.=) (Glob i) expr = produce expr >> appendExpr [SetGlobal i]
typedef :: FuncType -> GenMod Natural
@@ -654,7 +655,7 @@ importFunction mod name res params = do
}
return (Fn funcIdx)
importGlobal :: (ValueTypeable t) => TL.Text -> TL.Text -> Proxy t -> GenMod (Glob C t)
importGlobal :: (ValueTypeable t) => TL.Text -> TL.Text -> Proxy t -> (forall m . GenFunMonad m => GenMod (Glob m C t))
importGlobal mod name t = do
st@GenModState { target = m@Module { imports }, globIdx } <- get
put $ st {
@@ -695,8 +696,8 @@ instance Exportable (Fn t) where
}
return (Fn funIdx)
instance Exportable (Glob C t) where
type AfterExport (Glob C t) = Glob C t
instance Exportable (Glob m C t) where
type AfterExport (Glob m C t) = Glob m C t
export name g@(Glob idx) = do
modify $ \(st@GenModState { target = m }) -> st {
target = m { exports = exports m ++ [Export name $ ExportGlobal idx] }
@@ -766,9 +767,9 @@ instance GlobalMutability M where
instance GlobalMutability C where
globalTypeCtor _ = Const
newtype Glob (mut :: GlobMut) (t :: ValueType) = Glob Natural deriving (Show, Eq)
newtype Glob m (mut :: GlobMut) (t :: ValueType) = Glob Natural deriving (Show, Eq)
global :: (ValueTypeable t, GlobalMutability mut) => Proxy mut -> Proxy t -> (ValType t) -> GenMod (Glob mut t)
global :: (ValueTypeable t, GlobalMutability mut) => Proxy mut -> Proxy t -> (ValType t) -> (forall m . GenFunMonad m => GenMod (Glob m mut t))
global globMut t val = do
idx <- gets globIdx
modify $ \(st@GenModState { target = m }) -> st {
@@ -777,7 +778,7 @@ global globMut t val = do
}
return $ Glob idx
setGlobalInitializer :: forall t mut . (ValueTypeable t) => Glob mut t -> (ValType t) -> GenMod ()
setGlobalInitializer :: forall m t mut . (ValueTypeable t) => Glob m mut t -> (ValType t) -> GenMod ()
setGlobalInitializer (Glob idx) val = do
modify $ \(st@GenModState { target = m }) ->
let globImpsLen = length $ filter isGlobalImport $ imports m in
@@ -825,34 +826,34 @@ rts = genMod $ do
gc <- importFunction "rts" "gc" () [I32]
memory 10 Nothing
stackStart <- global globConst i32 0
stackEnd <- global globConst i32 0
stackBase <- global globMut i32 0
stackTop <- global globMut i32 0
stackStart <- global globConst i32 0 @GenFun
stackEnd <- global globConst i32 0 @GenFun
stackBase <- global globMut i32 0 @GenFun
stackTop <- global globMut i32 0 @GenFun
retReg <- global globMut i32 0
tmpReg <- global globMut i32 0
retReg <- global globMut i32 0 @GenFun
tmpReg <- global globMut i32 0 @GenFun
heapStart <- global globMut i32 0
heapNext <- global globMut i32 0
heapEnd <- global globMut i32 0
heapStart <- global globMut i32 0 @GenFun
heapNext <- global globMut i32 0 @GenFun
heapEnd <- global globMut i32 0 @GenFun
aligned <- fun i32 $ do
size <- param i32
(size `add` i32c @GenFun 3) `and` i32c @GenFun 0xFFFFFFFC
-- alloc <- funRec i32 $ \self -> do
-- size <- param i32
-- alignedSize <- local i32
-- addr <- local i32
-- alignedSize .= call aligned [arg size]
-- if' i32 ((heapNext `add` alignedSize) `lt_u` heapEnd)
-- (do
-- addr .= heapNext
-- heapNext .= heapNext `add` alignedSize
-- ret addr
-- )
-- (do
-- call gc []
-- call self [arg size]
-- )
(size `add` i32c 3) `and` i32c @GenFun 0xFFFFFFFC
alloc <- funRec i32 $ \self -> do
size <- param i32
alignedSize <- local i32
addr <- local i32
alignedSize .= call aligned [arg size]
if' i32 ((heapNext `add` alignedSize) `lt_u` heapEnd)
(do
addr .= heapNext
heapNext .= heapNext `add` alignedSize
ret addr
)
(do
call gc []
call self [arg size]
)
return ()