diff --git a/src/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs index 281a656..79d1513 100644 --- a/src/Gyehoek/CPS/Lower.hs +++ b/src/Gyehoek/CPS/Lower.hs @@ -32,17 +32,16 @@ import Data.String.Interpolate import Gyehoek.Wasm qualified as Wasm import Gyehoek.Wasm hiding (Expr) import Language.Sexp.Located (pattern ParenList) +import Debug.Pretty.Simple data Env = MkEnv { runtime :: Runtime , vars :: Vector Name + , kvars :: Vector Name } deriving (Show, Generic) -emptyEnv :: Env -emptyEnv = MkEnv (error "fuck") mempty - type instance Index Env = Natural type instance IxValue Env = Name @@ -50,11 +49,12 @@ instance Ixed Env where ix i = #vars . ix (fromIntegral i) data Runtime = MkRuntime - { argArrayIdx :: Idx + { argArrayType :: Idx + , argArray :: Idx , contType :: Idx , contStackType :: Idx - , contStackIndexIdx :: Idx - , contStackIdx :: Idx + , contStackTop :: Idx + , contStack :: Idx } deriving (Show, Generic) @@ -64,11 +64,31 @@ data Runtime = MkRuntime -- of the stack into the SCM unitype. makeSmallFixnum :: Wasm.Expr makeSmallFixnum = mconcat - [ ins "i32.const" [sxp @Int 2] + [ ins "i32.const" [sxp @Int 1] , ins "i32.shl" [] , ins "ref.i31" [] ] +-- | Given an expression @e@ leaving a @ref eq@ atop the stack, +-- @pushArg rt n e@ sets the nth slot of the arg-passing array to the +-- result of @e@. +pushArg :: Runtime -> Int -> Wasm.Expr -> Wasm.Expr +pushArg (MkRuntime {argArrayType,argArray}) n e = mconcat + [ ins "global.get" [sxp argArray] + , ins "i32.const" [sxp n] + , e + , ins "array.set" [sxp argArrayType] + ] + +-- | Pop the nth arg from the arg-passing array onto the stack. +popArg :: Runtime -> Int -> Wasm.Expr +popArg (MkRuntime {argArrayType,argArray}) n = mconcat + [ ins "global.get" [sxp argArray] + , ins "i32.const" [sxp n] + , ins "array.get" [sxp argArrayType] + , ins "ref.as_non_null" [] + ] + lowerVal :: Env -> Val -> Wasm.Expr @@ -104,23 +124,38 @@ lower' g (ExpIf c t f) = do pure $ lowerVal g c <> Wasm.if' (Wasm.result [i32]) t' f' +lower' g (ExpContinue k [x]) = pure . mconcat $ + [ pushArg rt 0 (lowerVal g x) + , ins "i32.const" [sxp @Int 1] -- nargs + -- get the return continuation. + , ins "global.get" [sxp rt.contStack] + , ins "global.get" [sxp rt.contStackTop] + , ins "array.get" [sxp rt.contStackType] + , ins "ref.as_non_null" [] + -- decrement contStackTop, completing the "pop." + , ins "global.get" [sxp rt.contStackTop] + , ins "i32.const" [sxp @Int (1 + l)] + , ins "i32.sub" [] + , ins "global.set" [sxp rt.contStackTop] + , ins "return_call_ref" [sxp rt.contType] + ] + where + rt = g.runtime + l = V.elemIndex k g.kvars ^?! _Just + lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do - _ <- defun [i32] [] [] \_ -> do - let stack = g.runtime.contStackIdx - let index = g.runtime.contStackIndexIdx - m' <- lower' g m - pure . mconcat $ - [ m' - , ins "global.get" [sxp index] - , ins "i32.const" [sxp @Int 1] - , ins "i32.sub" [] - , ins "global.set" [sxp index] - , ins "global.get" [sxp stack] - , ins "global.get" [sxp index] - , ins "array.get" [sxp g.runtime.contStackType] - , ins "return_call_ref" [sxp g.runtime.contType] - ] - _ + idx <- defun [i32] [] (replicate 5 scm) \_ -> + let g' = g & #vars <>~ V.fromList xs + & #kvars <>~ [ktail] + in lower' g' m + let g' = g & #vars <>~ [r] + let n = length g.vars + e' <- lower' g' e + pure . mconcat $ + [ ins "ref.func" [sxp idx] + , ins "local.set" [sxp n] + , e' + ] lower' g e = error . show $ e @@ -158,23 +193,23 @@ emitRuntime = do -- cont stack contType <- Wasm.deftype $ Wasm.func [i32] [] contStackType <- Wasm.deftype $ array (refnull (fromIdx contType)) - contStackIndexIdx <- Wasm.defglobal i32 $ ins "i32.const" [sxp @Int 0] - contStackIdx <- Wasm.defglobal (ref (Wasm.fromIdx contStackType)) $ + contStackTop <- Wasm.defglobal i32 $ ins "i32.const" [sxp @Int 0] + contStack <- Wasm.defglobal (ref (Wasm.fromIdx contStackType)) $ ins "i32.const" [sxp @Int 128] <> ins "array.new_default" [sxp contStackType] -- arg array argArrayType <- Wasm.deftype $ Wasm.array scm - argArrayIdx <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) _ + argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) _ -- consIdx <- Wasm.defun _ _ _ _ pure $ MkRuntime - {argArrayIdx - ,contStackIdx,contStackIndexIdx,contStackType,contType} + {argArray,argArrayType + ,contStack,contStackTop,contStackType,contType} -- pure $ error "todo" lower :: Exp -> Eff es Text lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do runtime <- emitRuntime - let env = MkEnv runtime mempty + let env = MkEnv runtime mempty mempty main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ -> lower' env e Wasm.export "main" "func" main diff --git a/src/Gyehoek/Wasm.hs b/src/Gyehoek/Wasm.hs index 4c665ae..b0537ef 100644 --- a/src/Gyehoek/Wasm.hs +++ b/src/Gyehoek/Wasm.hs @@ -47,6 +47,7 @@ module Gyehoek.Wasm , FromIdx(..) , func , refnull + , declareFuncref ) where @@ -85,6 +86,7 @@ import Data.Functor (void) data Module = MkModule { types :: Vector RecType , functions :: Vector Function + , funcrefs :: Vector Funcref , start :: Maybe Idx , exports :: Vector Export , globals :: Vector Global @@ -97,10 +99,15 @@ instance Semigroup Module where , functions = m1.functions <> m2.functions , start = m2.start <|> m1.start , exports = m1.exports <> m2.exports + , funcrefs = m1.funcrefs <> m2.funcrefs + , globals = m1.globals <> m2.globals } instance Monoid Module where - mempty = MkModule mempty mempty Nothing mempty mempty + mempty = MkModule mempty mempty mempty Nothing mempty mempty + +newtype Funcref = MkFuncref { inner :: Idx } + deriving (Show, Generic) data Global = MkGlobal { ty :: Type @@ -144,6 +151,7 @@ data GenMod :: Effect where Start :: Idx -> GenMod m () Export :: Text -> Text -> Idx -> GenMod m () DefGlobal :: Type -> Expr -> GenMod m Idx + DeclareFuncref :: Idx -> GenMod m () type instance DispatchOf GenMod = Dynamic @@ -174,6 +182,9 @@ defun -> Eff es Idx defun params res locals code = send $ Defun params res locals code +declareFuncref :: GenMod :> es => Idx -> Eff es () +declareFuncref = send . DeclareFuncref + -- defun -- :: (GenMod :> es) -- => List Type -> List Type -> List Type @@ -196,21 +207,22 @@ runGenMod = where e = MkExport $ ParenList [ "export", sxp name, ParenList [ "func", sxp idx ] ] env (Defun params result locals code) -> - localSeqUnlift env \unlift -> - stateM \m -> do - -- the least unused function index, computed as the number - -- of currently allocated functions. - let idx = IdxNumeric . fromIntegral . length $ m.functions - -- the body is computed with access to the newly allocated - -- index `idx` for the sake of recursive occurences. - body <- unlift $ code idx - let func = MkFunction {params,result,locals,body} - let m' = m & #functions <>~ V.singleton func - pure (idx, m') + localSeqUnlift env \unlift -> do + m <- get + -- the least unused function index, computed as the number + -- of currently allocated functions. + let idx = IdxNumeric . fromIntegral . length $ m.functions + -- the body is computed with access to the newly allocated + -- index `idx` for the sake of recursive occurences. + body <- unlift $ code idx + let func = MkFunction {params,result,locals,body} + #functions <>= V.singleton func + pure idx _ (DefGlobal t e) -> state \m -> let prev_n = IdxNumeric . fromIntegral . V.length $ m.globals m' = m & #globals <>~ V.singleton (MkGlobal t e) in (prev_n, m') + _ (DeclareFuncref idx) -> #funcrefs <>= V.singleton (MkFuncref idx) execGenMod = fmap snd . runGenMod @@ -346,9 +358,19 @@ instance SexpIso Module where ParenList $ [ Symbol "module" ] <> (m ^.. #types . each . to sxp) + <> (m ^.. #funcrefs . each . to sxp) <> (m ^.. #functions . each . to sxp) <> (m ^.. #exports . each . to sxp) +instance SexpIso Funcref where + sexpIso = with \funcref -> + list ( el (sym "elem") + >>> el (sym "declare") + >>> el (sym "funcref") + >>> el (list $ el (sym "ref.func") >>> el (sexpIso @Idx)) + ) + >>> funcref + instance SexpIso Sexp where sexpIso = Control.Category.id diff --git a/t.wat b/t.wat index 5f4e3bf..e3c5a8a 100644 --- a/t.wat +++ b/t.wat @@ -3,12 +3,29 @@ (type (func (param i32) (result))) (type (array (ref null 1))) (type (array (ref eq))) + (func + (param i32) + (result) + (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + (global.get 2) + (i32.const 0) + (local.get 0) + (array.set 3) + (i32.const 1) + (global.get 1) + (global.get 0) + (array.get 2) + ref.as_non_null + (global.get 0) + (i32.const 1) + i32.sub + (global.set 0) + (return_call_ref 1)) (func (param) (result (ref eq)) (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - (i32.const 1) - (i32.const 2) - i32.shl - ref.i31) + (ref.func 0) + (local.set 0) + (local.get 0)) (export "main" (func 0)))