diff --git a/src/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs index 79d1513..f3264e1 100644 --- a/src/Gyehoek/CPS/Lower.hs +++ b/src/Gyehoek/CPS/Lower.hs @@ -4,6 +4,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultilineStrings #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ApplicativeDo #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} module Gyehoek.CPS.Lower (lower, lowerProgram) where @@ -33,6 +34,7 @@ import Gyehoek.Wasm qualified as Wasm import Gyehoek.Wasm hiding (Expr) import Language.Sexp.Located (pattern ParenList) import Debug.Pretty.Simple +import Control.Monad.Fix data Env = MkEnv @@ -55,6 +57,8 @@ data Runtime = MkRuntime , contStackType :: Idx , contStackTop :: Idx , contStack :: Idx + , result :: Idx + , halt :: Idx } deriving (Show, Generic) @@ -103,13 +107,16 @@ lowerVal g (ValLit l) = <> ins "ref.i31" [] _ -> _ -lowerVal g (ValVar x) = ins "local.get" [sxp l] +lowerVal g (ValVar x) = ins "local.get" [sxp (1+l)] where l = V.elemIndex x g.vars ^?! _Just lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr -lower' g (Halt [e]) = pure $ lowerVal g e +lower' g (Halt [v]) = pure . mconcat $ + [ pushArg g.runtime 0 (lowerVal g v) + , ins "return_call" [sxp @Int 1] + ] lower' g (ExpPrim p rs e) = case p of @@ -144,16 +151,22 @@ lower' g (ExpContinue k [x]) = pure . mconcat $ l = V.elemIndex k g.kvars ^?! _Just lower' g (ExpLet [(r,MkLambda xs ktail m)] e) = do - idx <- defun [i32] [] (replicate 5 scm) \_ -> + idx <- defun [i32] [] (replicate 5 scm) \_ -> do let g' = g & #vars <>~ V.fromList xs & #kvars <>~ [ktail] - in lower' g' m + m' <- lower' g' m + pure . mconcat $ + [ xs & ifoldMap \n _ -> + popArg g.runtime n <> ins "local.set" [sxp (1+n)] + , m' + ] + declareFuncref idx 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] + , ins "local.set" [sxp (n+1)] , e' ] @@ -173,7 +186,7 @@ lowerBinOp op g x y r e = do , ins "i31.get_s" [] , ins op [] , ins "ref.i31" [] - , ins "local.set" [sxp n] + , ins "local.set" [sxp (1+n)] , e' ] where @@ -187,31 +200,50 @@ scm = ref eq emitRuntime :: GenMod :> es => Eff es Runtime -emitRuntime = do +emitRuntime = mfix \runtime -> do heapObjectIdx <- Wasm.deftypeNamed "$heap-object" $ Wasm.sub [] $ Wasm.struct [ Wasm.mut i32 ] -- cont stack contType <- Wasm.deftype $ Wasm.func [i32] [] - contStackType <- Wasm.deftype $ array (refnull (fromIdx contType)) - contStackTop <- Wasm.defglobal i32 $ ins "i32.const" [sxp @Int 0] + contStackType <- Wasm.deftype $ array $ mut $ refnull (fromIdx contType) + contStackTop <- Wasm.defglobal (mut 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 - argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) _ + argArrayType <- Wasm.deftype $ Wasm.array $ mut $ refnull eq + argArray <- Wasm.defglobal (ref (Wasm.fromIdx argArrayType)) $ + ins "i32.const" [sxp @Int 32] + <> ins "array.new_default" [sxp argArrayType] -- consIdx <- Wasm.defun _ _ _ _ + result <- Wasm.defglobal (mut (refnull eq)) $ ins "ref.null" [sxp eq] + halt <- Wasm.defun [i32] [] (replicate 5 scm) \_ -> + pure . mconcat $ + [ popArg runtime 0 + , ins "global.set" [sxp result] + ] pure $ MkRuntime {argArray,argArrayType - ,contStack,contStackTop,contStackType,contType} + ,contStack,contStackTop,contStackType,contType + ,result,halt} -- pure $ error "todo" lower :: Exp -> Eff es Text lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do runtime <- emitRuntime - let env = MkEnv runtime mempty mempty + let g = MkEnv runtime mempty mempty + scm_entry <- Wasm.defun [i32] [] (replicate 5 scm) \_ -> + lower' g e main <- Wasm.defun [] [scm] [scm, scm, scm, scm, scm] \_ -> - lower' env e + pure . mconcat $ + -- push return cont + [-- ins "ref.func" [sxp halt] + -- make call + ins "i32.const" [sxp @Int 0] + , ins "call" [sxp scm_entry] + , ins "global.get" [sxp runtime.result] + , ins "ref.as_non_null" [] + ] Wasm.export "main" "func" main lowerProgram :: Program -> Eff es Text diff --git a/src/Gyehoek/Wasm.hs b/src/Gyehoek/Wasm.hs index b0537ef..3a42084 100644 --- a/src/Gyehoek/Wasm.hs +++ b/src/Gyehoek/Wasm.hs @@ -358,6 +358,7 @@ instance SexpIso Module where ParenList $ [ Symbol "module" ] <> (m ^.. #types . each . to sxp) + <> (m ^.. #globals . each . to sxp) <> (m ^.. #funcrefs . each . to sxp) <> (m ^.. #functions . each . to sxp) <> (m ^.. #exports . each . to sxp) diff --git a/t.wat b/t.wat index e3c5a8a..4764b38 100644 --- a/t.wat +++ b/t.wat @@ -1,15 +1,34 @@ (module (type $heap-object (sub (struct (field (mut i32))))) (type (func (param i32) (result))) - (type (array (ref null 1))) - (type (array (ref eq))) + (type (array (mut (ref null 1)))) + (type (array (mut (ref null eq)))) + (global (mut i32) (i32.const 0)) + (global (ref 2) (i32.const 128) (array.new_default 2)) + (global (ref 3) (i32.const 32) (array.new_default 3)) + (global (mut (ref null eq)) (ref.null eq)) + (elem declare funcref (ref.func 1)) (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.get 3) + ref.as_non_null + (global.set 3)) + (func + (param i32) + (result) + (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + (global.get 2) + (i32.const 0) + (array.get 3) + ref.as_non_null + (local.set 1) + (global.get 2) + (i32.const 0) + (local.get 1) (array.set 3) (i32.const 1) (global.get 1) @@ -21,11 +40,23 @@ i32.sub (global.set 0) (return_call_ref 1)) + (func + (param i32) + (result) + (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + (ref.func 1) + (local.set 1) + (global.get 2) + (i32.const 0) + (local.get 1) + (array.set 3) + (return_call 1)) (func (param) (result (ref eq)) (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - (ref.func 0) - (local.set 0) - (local.get 0)) - (export "main" (func 0))) + (i32.const 0) + (call 1) + (global.get 3) + ref.as_non_null) + (export "main" (func 3)))