diff --git a/src/Language/Wasm/Builder.hs b/src/Language/Wasm/Builder.hs index 0998e81..94439dc 100644 --- a/src/Language/Wasm/Builder.hs +++ b/src/Language/Wasm/Builder.hs @@ -70,13 +70,13 @@ data FuncDef = FuncDef { newtype GenFun a = GenFun { unGenFun :: ReaderT Natural (State FuncDef) a } deriving (Functor, Applicative, Monad) -newtype Loc t = Loc Natural deriving (Show, Eq) +newtype Loc m (t :: ValueType) = Loc Natural deriving (Show, Eq) class (Monad m) => GenFunMonad m where appendExpr :: Expression -> m () inner :: m a -> m Expression - param :: (ValueTypeable t) => Proxy t -> m (Loc t) - local :: (ValueTypeable t) => Proxy t -> m (Loc t) + param :: (ValueTypeable t) => Proxy t -> m (Loc m t) + local :: (ValueTypeable t) => Proxy t -> m (Loc m t) deep :: m Natural instance GenFunMonad GenFun where @@ -103,33 +103,6 @@ instance GenFunMonad GenFun where return $ Loc $ fromIntegral $ length args + length locals deep = GenFun ask --- type GenFun = ReaderT Natural (State FuncDef) - --- genExpr :: Natural -> GenFun a -> Expression --- genExpr deep gen = instrs $ flip execState (FuncDef [] [] [] []) $ runReaderT gen deep - --- param :: (ValueTypeable t) => Proxy t -> GenFun (Loc t) --- param t = do --- f@FuncDef { args } <- get --- put $ f { args = args ++ [getValueType t] } --- return $ Loc $ fromIntegral $ length args - --- local :: (ValueTypeable t) => Proxy t -> GenFun (Loc t) --- local t = do --- f@FuncDef { args, locals } <- get --- put $ f { locals = locals ++ [getValueType t]} --- return $ Loc $ fromIntegral $ length args + length locals - --- appendExpr :: Expression -> GenFun () --- appendExpr expr = do --- modify $ \def -> def { instrs = instrs def ++ expr } --- return () - --- after :: Expression -> GenFun a -> GenFun a --- after instr expr = do --- res <- expr --- modify $ \def -> def { instrs = instrs def ++ instr } --- return res after :: (GenFunMonad m) => Expression -> m a -> m a after instr expr = do @@ -143,66 +116,46 @@ data TypedExpr m | ExprF32 (m (Proxy F32)) | ExprF64 (m (Proxy F64)) -data ProducerType - = LocProd - | GlobProd - | ExprProd - -type family GetProdType a :: ProducerType where - GetProdType (Loc t) = 'LocProd - GetProdType (Glob t) = 'GlobProd - GetProdType a = 'ExprProd - -class (GenFunMonad m) => ProducerHelp (prodType :: ProducerType) m expr where - type OutTypeHelp prodType expr - asTypedExprHelp :: expr -> TypedExpr m - produceHelp :: expr -> m (OutTypeHelp prodType expr) - -instance (GenFunMonad m, ValueTypeable t) => ProducerHelp 'LocProd m (Loc t) where - type OutTypeHelp 'LocProd (Loc t) = Proxy t - asTypedExprHelp e = case getValueType (t e) of - I32 -> ExprI32 (produceHelp @'LocProd e >> return Proxy) - I64 -> ExprI64 (produceHelp @'LocProd e >> return Proxy) - F32 -> ExprF32 (produceHelp @'LocProd e >> return Proxy) - F64 -> ExprF64 (produceHelp @'LocProd e >> return Proxy) - where - t :: Loc t -> Proxy t - t _ = Proxy - produceHelp (Loc i) = appendExpr [GetLocal i] >> return Proxy - -instance (GenFunMonad m, ValueTypeable t) => ProducerHelp 'GlobProd m (Glob t) where - type OutTypeHelp 'GlobProd (Glob t) = Proxy t - asTypedExprHelp e = case getValueType (t e) of - I32 -> ExprI32 (produceHelp @'GlobProd e >> return Proxy) - I64 -> ExprI64 (produceHelp @'GlobProd e >> return Proxy) - F32 -> ExprF32 (produceHelp @'GlobProd e >> return Proxy) - F64 -> ExprF64 (produceHelp @'GlobProd e >> return Proxy) - where - t :: Glob t -> Proxy t - t _ = Proxy - produceHelp (Glob i) = appendExpr [GetGlobal i] >> return Proxy - -instance (GenFunMonad m, ValueTypeable t) => ProducerHelp 'ExprProd m (m (Proxy t)) where - type OutTypeHelp 'ExprProd (m (Proxy t)) = Proxy t - asTypedExprHelp e = case getValueType (t e) of - I32 -> ExprI32 (produceHelp @'ExprProd e >> return Proxy) - I64 -> ExprI64 (produceHelp @'ExprProd e >> return Proxy) - F32 -> ExprF32 (produceHelp @'ExprProd e >> return Proxy) - F64 -> ExprF64 (produceHelp @'ExprProd e >> return Proxy) - where - t :: (GenFunMonad m) => m (Proxy t) -> Proxy t - t _ = Proxy - produceHelp = id - class (GenFunMonad m) => Producer m expr where type OutType expr asTypedExpr :: expr -> TypedExpr m produce :: expr -> m (OutType expr) -instance (GenFunMonad m, ProducerHelp (GetProdType (m a)) m (m a)) => Producer m (m a) where - type OutType (m a) = OutTypeHelp (GetProdType (m a)) (m a) - asTypedExpr = asTypedExprHelp @(GetProdType (m a)) - produce = produceHelp @(GetProdType (m a)) +instance (GenFunMonad m, ValueTypeable t) => Producer m (Loc m t) where + type OutType (Loc m 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 :: Loc m t -> Proxy t + 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 + 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 _ = Proxy + produce (Glob i) = appendExpr [GetGlobal i] >> return Proxy + +instance (GenFunMonad m, ValueTypeable t) => Producer m (m (Proxy t)) where + type OutType (m (Proxy 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 :: (GenFunMonad m) => m (Proxy t) -> Proxy t + t _ = Proxy + produce = id ret :: (Producer m expr) => expr -> m (OutType expr) ret = produce @@ -221,7 +174,7 @@ type family IsInt i :: Bool where IsInt (Proxy I64) = True IsInt any = False -nop :: GenFun () +nop :: (GenFunMonad m) => m () nop = appendExpr [Nop] asValueType :: forall m a . (GenFunMonad m, Producer m a) => a -> ValueType @@ -259,6 +212,7 @@ sub a b = do F32 -> after [FBinOp BS32 FSub] (produce b) F64 -> after [FBinOp BS64 FSub] (produce b) + -- dec :: (GenFunMonad m, Consumer m a, Producer m a, Integral i) => i -> a -> m () -- dec i a = case asTypedExpr a of -- ExprI32 e -> a .= (e `sub` i32c i) @@ -630,12 +584,12 @@ class (GenFunMonad m) => Consumer m loc where infixr 2 .= (.=) :: (Producer m expr) => loc -> expr -> m () -instance (GenFunMonad m) => Consumer m (Loc t) where - type InputType (Loc t) = Proxy t +instance (GenFunMonad m) => Consumer m (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 t) where - type InputType (Glob t) = Proxy t +instance (GenFunMonad m) => Consumer m (Glob M t) where + type InputType (Glob M t) = Proxy t (.=) (Glob i) expr = produce expr >> appendExpr [SetGlobal i] typedef :: FuncType -> GenMod Natural @@ -700,7 +654,7 @@ importFunction mod name res params = do } return (Fn funcIdx) -importGlobal :: (ValueTypeable t) => TL.Text -> TL.Text -> Proxy t -> GenMod (Glob t) +importGlobal :: (ValueTypeable t) => TL.Text -> TL.Text -> Proxy t -> GenMod (Glob C t) importGlobal mod name t = do st@GenModState { target = m@Module { imports }, globIdx } <- get put $ st { @@ -741,8 +695,8 @@ instance Exportable (Fn t) where } return (Fn funIdx) -instance Exportable (Glob t) where - type AfterExport (Glob t) = Glob t +instance Exportable (Glob C t) where + type AfterExport (Glob C t) = Glob C t export name g@(Glob idx) = do modify $ \(st@GenModState { target = m }) -> st { target = m { exports = exports m ++ [Export name $ ExportGlobal idx] } @@ -795,18 +749,35 @@ i64 = Proxy @I64 f32 = Proxy @F32 f64 = Proxy @F64 -newtype Glob t = Glob Natural deriving (Show, Eq) +data GlobMut = M | C -global :: (ValueTypeable t) => (ValueType -> GlobalType) -> Proxy t -> (ValType t) -> GenMod (Glob t) -global mkType t val = do +globMut :: Proxy M +globMut = Proxy + +globConst :: Proxy C +globConst = Proxy + +class GlobalMutability mut where + globalTypeCtor :: Proxy mut -> ValueType -> GlobalType + +instance GlobalMutability M where + globalTypeCtor _ = Mut + +instance GlobalMutability C where + globalTypeCtor _ = Const + +newtype Glob (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 globMut t val = do idx <- gets globIdx modify $ \(st@GenModState { target = m }) -> st { - target = m { globals = globals m ++ [Global (mkType $ getValueType t) (initWith t val)] }, + target = m { globals = globals m ++ [Global (globalTypeCtor globMut $ getValueType t) (initWith t val)] }, globIdx = idx + 1 } return $ Glob idx -setGlobalInitializer :: forall t . (ValueTypeable t) => Glob t -> (ValType t) -> GenMod () +setGlobalInitializer :: forall t mut . (ValueTypeable t) => Glob mut t -> (ValType t) -> GenMod () setGlobalInitializer (Glob idx) val = do modify $ \(st@GenModState { target = m }) -> let globImpsLen = length $ filter isGlobalImport $ imports m in @@ -854,34 +825,34 @@ rts = genMod $ do gc <- importFunction "rts" "gc" () [I32] memory 10 Nothing - stackStart <- global Const i32 0 - stackEnd <- global Const i32 0 - stackBase <- global Mut i32 0 - stackTop <- global Mut i32 0 + stackStart <- global globConst i32 0 + stackEnd <- global globConst i32 0 + stackBase <- global globMut i32 0 + stackTop <- global globMut i32 0 - retReg <- global Mut i32 0 - tmpReg <- global Mut i32 0 + retReg <- global globMut i32 0 + tmpReg <- global globMut i32 0 - heapStart <- global Mut i32 0 - heapNext <- global Mut i32 0 - heapEnd <- global Mut i32 0 + heapStart <- global globMut i32 0 + heapNext <- global globMut i32 0 + heapEnd <- global globMut i32 0 aligned <- fun i32 $ do size <- param i32 - (size `add` i32c 3) `and` i32c 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 @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] + -- ) return ()