From 08b8bc50d6e46d54dd61a5af2b87f954876c3143 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Wed, 15 Jul 2026 02:12:15 -0600 Subject: [PATCH] idk --- src/Gyehoek/CPS/Lower.hs | 60 ++++++++++++++++++------ src/Gyehoek/Wasm.hs | 1 + t.wat | 98 ++++++++++++++++++++++++++++------------ t2.wat | 65 ++++++++++++++++++++++++++ 4 files changed, 180 insertions(+), 44 deletions(-) create mode 100644 t2.wat 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..733234c 100644 --- a/t.wat +++ b/t.wat @@ -1,31 +1,69 @@ (module - (type $heap-object (sub (struct (field (mut i32))))) - (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)) - (ref.func 0) - (local.set 0) - (local.get 0)) - (export "main" (func 0))) + (type $heap-object (sub (struct (field (mut i32))))) + (type $open-procedure (func (param i32))) + (type $closure (sub $heap-object + (struct (field (mut i32)) + (field (ref $open-procedure))))) + (type $cont-stack-type (array (mut (ref null $open-procedure)))) + (type $arg-array-type (array (mut (ref null eq)))) + (global $cont-stack-top (mut i32) (i32.const 0)) + (global $cont-stack (ref $cont-stack-type) + (i32.const 128) + (array.new_default $cont-stack-type)) + (global $arg-array (ref $arg-array-type) + (i32.const 32) + (array.new_default $arg-array-type)) + (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) + (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) + (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 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)) + (i32.const 0) + (call 1) + (global.get 3) + ref.as_non_null) + (export "main" (func 3))) diff --git a/t2.wat b/t2.wat new file mode 100644 index 0000000..bd27cf8 --- /dev/null +++ b/t2.wat @@ -0,0 +1,65 @@ +(module + (type $heap-object (sub (struct (field (mut i32))))) + (type $open-procedure (func (param i32))) + (type $closure (sub $heap-object + (struct (field (mut i32)) + (field (ref $open-procedure))))) + (type $cont-stack-type (array (mut (ref null $open-procedure)))) + (type $arg-array-type (array (mut eqref))) + (type (func (result (ref eq)))) + (global $cont-stack-top (mut i32) (i32.const 0)) + (global $cont-stack (ref $cont-stack-type) + (array.new_default $cont-stack-type (i32.const 128))) + (global $arg-array (ref $arg-array-type) + (array.new_default $arg-array-type (i32.const 32))) + (global (mut eqref) (ref.null eq)) + (elem declare funcref (ref.func 1)) + (func $halt (param i32) + (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + (global.set 3 + (ref.as_non_null + (array.get $arg-array-type + (global.get $arg-array) + (i32.const 0))))) + (func $f1 (param i32) + (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + ;; pop arg 0 + (local.set + 1 + (ref.as_non_null + (array.get $arg-array-type + (global.get $arg-array) + (i32.const 0)))) + ;; push arg 0 + (array.set $arg-array-type + (global.get $arg-array) + (i32.const 0) + (local.get 1)) + ;; pop continuation + (return_call_ref + $open-procedure + (i32.const 1) + (ref.as_non_null (array.get $cont-stack-type + (global.get $cont-stack) + (global.get $cont-stack-top))) + (global.set $cont-stack-top + (i32.sub + (global.get $cont-stack-top) + (i32.const 1))))) + (func $f2 (type $open-procedure) (param i32) + (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + (local.set 1 + (struct.new $closure + (i32.const 0) + (ref.func $f1))) + (array.set $arg-array-type + (global.get $arg-array) + (i32.const 0) + (local.get 1)) + (i32.const 1) + (return_call $f1)) + (func $main (export "main") (result (ref eq)) + (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + (call $f2 (i32.const 0)) + (ref.as_non_null + (global.get 3))))