From c3c4866fa8ebb27ae3c51ea50d86a39c8d5e1839 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Wed, 22 Jul 2026 23:47:33 -0600 Subject: [PATCH] idk --- golden/adder/source.scm | 4 + gyehoek.cabal | 5 +- src/Gyehoek/CPS/Close.hs | 29 ++++ src/Gyehoek/CPS/Convert.hs | 15 ++ src/Gyehoek/CPS/Lower.hs | 88 +++++------ src/Gyehoek/CPS/Syntax.hs | 142 +++++++++++------ src/Gyehoek/Driver.hs | 9 +- src/Gyehoek/Scheme/Syntax.hs | 5 + t.scm | 4 +- t.wat | 259 +++++++++----------------------- test/Gyehoek/Test/CPS/Syntax.hs | 20 +-- 11 files changed, 286 insertions(+), 294 deletions(-) create mode 100644 golden/adder/source.scm create mode 100644 src/Gyehoek/CPS/Close.hs diff --git a/golden/adder/source.scm b/golden/adder/source.scm new file mode 100644 index 0000000..d3cfa40 --- /dev/null +++ b/golden/adder/source.scm @@ -0,0 +1,4 @@ +(let ((make-adder (lambda (x) + (lambda (y) + (+ x y))))) + ((make-adder 4) 5)) diff --git a/gyehoek.cabal b/gyehoek.cabal index ece1ef0..91a6714 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -52,6 +52,7 @@ library -- cabal-fmt: expand src exposed-modules: + Gyehoek.CPS.Close Gyehoek.CPS.Convert Gyehoek.CPS.Lower Gyehoek.CPS.Syntax @@ -65,8 +66,8 @@ library build-depends: , base ^>=4.21.2.0 , binary + , bytestring , containers - , typed-process , effectful , effectful-core , effectful-plugin @@ -87,9 +88,9 @@ library , template-haskell , text , text-short + , typed-process , unordered-containers , vector - , bytestring hs-source-dirs: src default-language: GHC2024 diff --git a/src/Gyehoek/CPS/Close.hs b/src/Gyehoek/CPS/Close.hs new file mode 100644 index 0000000..20e9ded --- /dev/null +++ b/src/Gyehoek/CPS/Close.hs @@ -0,0 +1,29 @@ +module Gyehoek.CPS.Close + ( closeProgram + ) where + +import Gyehoek.CPS.Syntax +import Effectful +import Data.Functor.Foldable +import Control.Monad ((>=>)) +import Control.Lens +import Data.List.NonEmpty (NonEmpty) +import qualified Data.HashSet as HS + + +cataM + :: (Monad m, Traversable (Base t), Recursive t) + => (Base t a -> m a) -> t -> m a +cataM f = cata (sequenceA >=> f) + +close :: Exp -> Exp +close = cata \case + ExpLetRecF {bindersF,bodyF} -> ExpLetRec binders bodyF + where + binders = bindersF & (each . _2 . _AbsLambda' . _3) %~ \e -> _ + e -> embed e + + -- let frees = freeWithBound' (HS.fromList $ ktail : bs) e' + +closeProgram :: Program -> Eff es Program +closeProgram (MkProgram e) = pure . MkProgram . close $ e diff --git a/src/Gyehoek/CPS/Convert.hs b/src/Gyehoek/CPS/Convert.hs index 368bd9c..80232d0 100644 --- a/src/Gyehoek/CPS/Convert.hs +++ b/src/Gyehoek/CPS/Convert.hs @@ -65,6 +65,21 @@ convert (Scm.ExpIf c t f) k = convert c \c' -> ExpIf c' <$> convert t k <*> convert f k +-- let-bindings are desugared into continuation calls whose parameters +-- are the left-hand sides and whose arguments are the right-hand +-- sides. +convert (Scm.ExpLet bs e) k = + let rhss = bs ^.. each . _2 + in telescope (convert @es) rhss \rhss' -> do + e' <- convert e k + kbody <- gensym' @Name "letrec-body" + let bs' = bs ^.. each . _1 + pure [cps| + (letrec ((#{kbody} (魏 #{bs'} #{e'}))) + (continue #{kbody} ##{rhss'})) + |] + + convert _ k = _ convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program diff --git a/src/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs index 4e77b7a..fdd49c3 100644 --- a/src/Gyehoek/CPS/Lower.hs +++ b/src/Gyehoek/CPS/Lower.hs @@ -26,9 +26,12 @@ import Language.Sexp.Located qualified as SL import Control.Monad.Fix import qualified Gyehoek.Sexp import Data.Text qualified as T +import Data.List qualified import Data.Foldable (fold) import Gyehoek.Sexp (encodeOrShow, toSexp) import Debug.Pretty.Simple +import GHC.Stack (HasCallStack) +import Data.String.Interpolate data Env = MkEnv @@ -58,31 +61,34 @@ makeSmallFixnum = [expr| ref.i31 |] +getArgRegister :: Natural -> SL.Sexp +getArgRegister n = SL.Symbol [i|$arg#{n}|] + -- | 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 :: Natural -> Wasm.Expr -> Wasm.Expr pushArg n e = [expr| - (@gyehoek "push argument") - (global.get $arg-array) - (i32.const #{n}) + (@gyehoek begin pushArg) ##{e} - (array.set $arg-array-type) + (global.set #{reg}) + (@gyehoek end pushArg) |] + where reg = getArgRegister n -- | Pop the nth arg from the arg-passing array onto the stack. -popArg :: Int -> Wasm.Expr +popArg :: Natural -> Wasm.Expr popArg n = [expr| - (@gyehoek "pop argument") - (global.get $arg-array) - (i32.const #{n}) - (array.get $arg-array-type) + (@gyehoek begin popArg) + (global.get #{reg}) ref.as_non_null + (@gyehoek end popArg) |] + where reg = getArgRegister n -lowerVal :: GenMod :> es => Env -> Val -> Eff es Wasm.Expr +lowerVal :: (HasCallStack, GenMod :> es) => Env -> Val -> Eff es Wasm.Expr lowerVal g (ValLit l) = pure $ case l of @@ -97,17 +103,10 @@ lowerVal g (ValLit l) = where b' :: Int = if b then 0b11 else 0b01 _ -> _ -lowerVal g (ValVar x) = pure $ [expr|(local.get #{l})|] +lowerVal g (ValVar x) = do + pure [expr|(global.get #{l})|] where - l = succ $ V.elemIndex x g.vars ^?! _Just - --- lowerVal g (ValLambda lam) = do --- idx <- lowerLambda g lam --- pure [expr| --- (i32.const 0) --- (ref.func #{idx}) --- (struct.new $closure) --- |] + l = getArgRegister . fromIntegral . succ $ V.elemIndex x g.vars ^?! _Just lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr @@ -159,11 +158,12 @@ lower' g (ExpLetRec [(r,AbsLambda lam)] e) = do let g' = g & #vars <>~ [r] let n = succ $ length g.vars e' <- lower' g' e + let reg = getArgRegister . fromIntegral $ n pure [expr| (i32.const 0) (ref.func #{idx}) (struct.new $closure) - (local.set #{n}) + (global.set #{reg}) ##{e'} |] @@ -219,20 +219,14 @@ lower' g e = error $ case Gyehoek.Sexp.encode e of lowerKappa :: GenMod :> es => Env -> Kappa -> Eff es Idx lowerKappa g e@(MkKappa xs m) = do - let g' = g & #vars .~ V.fromList xs + let g' = g & #vars <>~ V.fromList xs m' <- lower' g' m - let body = mconcat - [ xs & ifoldMap \n _ -> - let n' = succ n - in popArg n <> [expr|(local.set #{n'})|] - , m' - ] let origin = encodeOrShow @_ @Text e idx <- Wasm.defineFunction [wat| (func (param i32) (@gyehoek :origin #{origin}) (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - ##{body}) + ##{m'}) |] Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|] pure idx @@ -242,18 +236,12 @@ lowerLambda g e@(MkLambda xs ktail m) = do let g' = g & #vars .~ V.fromList xs & #kvars <>~ [ktail] m' <- lower' g' m - let body = mconcat - [ xs & ifoldMap \n _ -> - let n' = succ n - in popArg n <> [expr|(local.set #{n'})|] - , m' - ] let origin = encodeOrShow @_ @Text e idx <- Wasm.defineFunction [wat| (func (param i32) (@gyehoek :origin #{origin}) (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - ##{body}) + ##{m'}) |] Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|] pure idx @@ -265,6 +253,7 @@ lowerBinOp op g x y (MkKappa [r] e) = do let op' = SL.Symbol op let g' = g & #vars <>~ [r] let n = succ $ length (g ^. #vars) + let reg = getArgRegister . fromIntegral $ n x' <- lowerVal g x y' <- lowerVal g y e' <- lower' g' e @@ -279,7 +268,7 @@ lowerBinOp op g x y (MkKappa [r] e) = do i32.shr_u #{op'} ##{makeSmallFixnum} - (local.set #{n}) + (global.set #{reg}) ##{e'} |] @@ -306,13 +295,24 @@ emitRuntime = mfix \runtime -> do (global $cont-stack (ref $cont-stack-type) (array.new_default $cont-stack-type (i32.const 128))) |] - -- arg array - Wasm.defineType [wat| - (type $arg-array-type (array (mut (ref null eq)))) - |] - Wasm.defineGlobal [wat| - (global $arg-array (ref $arg-array-type) - (array.new_default $arg-array-type (i32.const 32))) + -- arg registers + Wasm.defineGlobals [wats| + (global $arg0 (mut (ref null eq)) (ref.null eq)) + (global $arg1 (mut (ref null eq)) (ref.null eq)) + (global $arg2 (mut (ref null eq)) (ref.null eq)) + (global $arg3 (mut (ref null eq)) (ref.null eq)) + (global $arg4 (mut (ref null eq)) (ref.null eq)) + (global $arg5 (mut (ref null eq)) (ref.null eq)) + (global $arg6 (mut (ref null eq)) (ref.null eq)) + (global $arg7 (mut (ref null eq)) (ref.null eq)) + (global $arg8 (mut (ref null eq)) (ref.null eq)) + (global $arg9 (mut (ref null eq)) (ref.null eq)) + (global $arg10 (mut (ref null eq)) (ref.null eq)) + (global $arg11 (mut (ref null eq)) (ref.null eq)) + (global $arg12 (mut (ref null eq)) (ref.null eq)) + (global $arg13 (mut (ref null eq)) (ref.null eq)) + (global $arg14 (mut (ref null eq)) (ref.null eq)) + (global $arg15 (mut (ref null eq)) (ref.null eq)) |] -- other things 馃樇 Wasm.defineGlobal [wat| diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index 10915b5..419aa20 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -9,6 +9,7 @@ module Gyehoek.CPS.Syntax , Kappa(..) , Lambda(..) , Exp(..) + , ExpF(..) , Name(..) , Prim(..) , Program(..) @@ -20,6 +21,7 @@ module Gyehoek.CPS.Syntax , _ExpPrim , _ExpLetRec , _ExpApply + , _AbsLambda' , binders , body , op @@ -29,8 +31,9 @@ module Gyehoek.CPS.Syntax , pattern AbsLambda' , pattern AbsKappa' , Abs(..) - , free - , free' + , Free(..) + , Vars(..) + , Subst(..) ) where @@ -55,6 +58,8 @@ import qualified Data.HashSet as HS import Data.Hashable (Hashable) import Data.Monoid (Endo) import Data.Containers.ListUtils (nubOrd) +import Data.Functor.Foldable.TH +import Data.Functor.Foldable (Recursive(..), Corecursive (..)) -- Data types @@ -114,6 +119,7 @@ makePrisms ''Exp makeFieldsId ''Exp makeFieldsId ''Kappa makeFieldsId ''Lambda +makeBaseFunctor ''Exp instance HasBinders Abs (List Name) where binders k (AbsKappa kap) = AbsKappa <$> binders k kap @@ -123,6 +129,12 @@ instance HasBody Abs Exp where body k (AbsKappa kap) = AbsKappa <$> body k kap body k (AbsLambda lam) = AbsLambda <$> body k lam +_AbsLambda' :: Prism' Abs (List Name, Name, Exp) +_AbsLambda' = prism' + (\(bs,ktail,e) -> AbsLambda' bs ktail e) + (\case AbsLambda' bs ktail e -> Just (bs,ktail,e) + _ -> Nothing) + -- SexpIso instances @@ -234,49 +246,95 @@ insertFrom = flip $ foldr HS.insert toHashSetOf :: Hashable a => Getting (Endo (HashSet a)) s a -> s -> HashSet a toHashSetOf l = foldrOf l HS.insert mempty -free :: Exp -> HashSet Name -free = go where - gokap (MkKappa xs m) = go m & deleteFrom xs - golam (MkLambda xs k m) = go m & deleteFrom xs & sans k - goabs = \case - AbsKappa kap -> gokap kap - AbsLambda lam -> golam lam - go = \case +class Free a where + free :: a -> HashSet Name + free = freeWithBound mempty + + freeWithBound :: HashSet Name -> a -> HashSet Name + freeWithBound bound = HS.fromList . freeWithBound' bound + + -- | Free variables given in the order of their appearance. + free' :: a -> List Name + free' = freeWithBound' mempty + + freeWithBound' :: HashSet Name -> a -> List Name + +instance Free Abs where + freeWithBound' bound (AbsKappa kap) = freeWithBound' bound kap + freeWithBound' bound (AbsLambda lam) = freeWithBound' bound lam + +instance Free Exp where + freeWithBound' bound = \case ExpPrim p k -> - p & toHashSetOf (folded . #ValVar) - & HS.union (gokap k) + p & toListOf (folded . #ValVar . filtered (`notElem` bound)) + & (<> freeWithBound' bound k) ExpLetRec bs m -> - foldMapOf (each . _2) goabs bs <> go m - & deleteFrom (bs ^.. each . _1) - ExpContinue k xs -> HS.fromList $ k : xs ^.. each . #ValVar - ExpIf c t f -> toHashSetOf #ValVar c <> go t <> go f - ExpApply f xs k -> toHashSetOf (each . #ValVar) (f:xs) <> HS.singleton k + foldMapOf (each . _2) (freeWithBound' bound') bs + <> freeWithBound' bound' m + where bound' = bound & insertFrom (bs ^.. each . _1) + ExpContinue k xs -> filter (`notElem` bound) (k : xs ^.. each . #ValVar) + ExpIf c t f -> + (c ^.. #ValVar . filtered (`notElem` bound)) + <> freeWithBound' bound t <> freeWithBound' bound f + ExpApply f xs k -> + (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound)) + <> (k ^.. filtered (`notElem` bound)) --- | Free variables given in the order of their appearance. -free' :: Exp -> List Name -free' = nubOrd . goFree HS.empty where +instance Free Kappa where + freeWithBound' bound (MkKappa xs m) = + freeWithBound' (bound & insertFrom xs) m -goFreeKap bound (MkKappa xs m) = goFree (bound & insertFrom xs) m -goFreeLam bound (MkLambda xs k m) = goFree (bound & insertFrom (k:xs)) m -goFreeAbs bound = \case - AbsKappa kap -> goFreeKap bound kap - AbsLambda lam -> goFreeLam bound lam +instance Free Lambda where + freeWithBound' bound (MkLambda xs k m) = + freeWithBound' (bound & insertFrom (k:xs)) m -goFree :: HashSet Name -> Exp -> List Name -goFree bound = \case - ExpPrim p k -> - p & toListOf (folded . #ValVar . filtered (`notElem` bound)) - & (<> goFreeKap bound k) - ExpLetRec bs m -> - foldMapOf (each . _2) (goFreeAbs bound') bs <> goFree bound' m - where bound' = bound & insertFrom (bs ^.. each . _1) - ExpContinue k xs -> filter (`notElem` bound) (k : xs ^.. each . #ValVar) - ExpIf c t f -> - (c ^.. #ValVar . filtered (`notElem` bound)) - <> goFree bound t <> goFree bound f - ExpApply f xs k -> - (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound)) - <> (k ^.. filtered (`notElem` bound)) + -freeLambda :: Lambda -> List Name -freeLambda (MkLambda {binders,ktail,body}) = _ +class Vars a where + -- | Traverse the immediate variables of an expression. + vars :: Traversal' a Name + +instance Vars Val where + vars k (ValVar x) = ValVar <$> k x + vars _ x = pure x + +instance Vars a => Vars (Prim a) where + vars k p = traverseOf (each . vars) k p + +instance Vars Exp where + vars k (ExpPrim p kap) = ExpPrim <$> vars k p <*> pure kap + vars k (ExpContinue kname xs) = ExpContinue <$> k kname <*> pure xs + vars _ e = pure e + + + +data Scope + = Bind (List Name) Scope + | Use (List Name) Scope + | Leaf + deriving (Show, Eq) + +makeBaseFunctor ''Scope + +class Subst a where + substWith :: (Name -> Val) -> a -> a + +instance Subst Exp where + substWith sub = cata \e -> + _ + +class Scoped a where + scope :: a -> Scope + +instance Scoped Kappa where + scope (MkKappa bs e) = + Bind bs (scope e) + +instance Scoped Val where + scope = \case + ValVar x -> Use [x] Leaf + _ -> Leaf + +instance Scoped Exp where + scope = \case + ExpApply f xs k = _ diff --git a/src/Gyehoek/Driver.hs b/src/Gyehoek/Driver.hs index 4e71747..9ddbd63 100644 --- a/src/Gyehoek/Driver.hs +++ b/src/Gyehoek/Driver.hs @@ -1,5 +1,5 @@ module Gyehoek.Driver - (main, lower_e2e, convert_e2e, parse_e2e) + (main, lower_e2e, convert_e2e, parse_e2e, readScm) where import Gyehoek.Options @@ -102,10 +102,9 @@ driver opts = do when opts.dumpCPS do hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right wat <- lowerProgram cps - if not opts.inspectWasm then - withFile opts.output FS.WriteMode \h -> - hPutStrLn h wat - else + withFile opts.output FS.WriteMode \h -> + hPutStrLn h wat + when opts.inspectWasm do inspectWasm wat parse_e2e :: FilePath -> IO Scm.Program diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index d918742..f173d46 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -72,6 +72,7 @@ data Prim e | PrimWrite e | PrimZeroP e | PrimNewline + | PrimMakeClosure { code :: e, upvals :: List e } deriving (Show, Generic, Functor, Foldable, Traversable, Data, Eq) instance Each (Prim e) (Prim e') e e' @@ -94,6 +95,7 @@ data Def data Exp = ExpLet (NonEmpty (Name, Exp)) Exp + | ExpLetRec (NonEmpty (Name, Exp)) Exp | ExpPrim (Prim Exp) | ExpBegin (List Exp) | ExpIf Exp Exp Exp @@ -154,12 +156,14 @@ primSexpIso namefn a = match $ With (. unop "write") $ With (. unop "zero?") $ With (. nullop "newline") + $ With (. mkclosure) $ End where idn s = el (sym (namefn s)) nullop s = list $ idn s unop s = list $ idn s >>> el a binop s = list $ idn s >>> el a >>> el a + mkclosure = list $ idn "make-closure" >>> el a >>> rest a instance SexpIso a => SexpIso (Prim a) where -- sexpIso = primSexpIso ("prim:"<>) sexpIso @@ -203,6 +207,7 @@ instance SexpIso Def where instance SexpIso Exp where sexpIso = match $ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso) + $ With (. Gyehoek.Sexp.let_ "letrec" sexpIso sexpIso sexpIso) $ With (. sexpIso) $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso)) $ With (. if_) diff --git a/t.scm b/t.scm index fe84f87..ac4a5ee 100644 --- a/t.scm +++ b/t.scm @@ -1 +1,3 @@ -(values 1 2) +(letrec ((x 3) + (y 4)) + (values x y)) diff --git a/t.wat b/t.wat index 8b4601f..b0bad4e 100644 --- a/t.wat +++ b/t.wat @@ -22,38 +22,60 @@ $cont-stack (ref $cont-stack-type) (array.new_default $cont-stack-type (i32.const 128))) - (type $arg-array-type (array (mut (ref null eq)))) - (global - $arg-array - (ref $arg-array-type) - (array.new_default $arg-array-type (i32.const 32))) + (global $arg0 (mut (ref null eq)) (ref.null eq)) + (global $arg1 (mut (ref null eq)) (ref.null eq)) + (global $arg2 (mut (ref null eq)) (ref.null eq)) + (global $arg3 (mut (ref null eq)) (ref.null eq)) + (global $arg4 (mut (ref null eq)) (ref.null eq)) + (global $arg5 (mut (ref null eq)) (ref.null eq)) + (global $arg6 (mut (ref null eq)) (ref.null eq)) + (global $arg7 (mut (ref null eq)) (ref.null eq)) + (global $arg8 (mut (ref null eq)) (ref.null eq)) + (global $arg9 (mut (ref null eq)) (ref.null eq)) + (global $arg10 (mut (ref null eq)) (ref.null eq)) + (global $arg11 (mut (ref null eq)) (ref.null eq)) + (global $arg12 (mut (ref null eq)) (ref.null eq)) + (global $arg13 (mut (ref null eq)) (ref.null eq)) + (global $arg14 (mut (ref null eq)) (ref.null eq)) + (global $arg15 (mut (ref null eq)) (ref.null eq)) (global $result (mut (ref null eq)) (ref.null eq)) (func $halt (param i32) - (@gyehoek "pop argument") - (global.get $arg-array) - (i32.const 0) - (array.get $arg-array-type) + (@gyehoek begin popArg) + (global.get $arg0) ref.as_non_null + (@gyehoek end popArg) (global.set $result)) (func (param i32) - (@gyehoek :origin "(魏 (x5) (continue 位-tail1 x5))") + (@gyehoek + :origin + "(位 (x 位-tail1) (prim (* x x) (魏 (r2) (continue 位-tail1 r2))))") (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - (@gyehoek "pop argument") - (global.get $arg-array) - (i32.const 0) - (array.get $arg-array-type) - ref.as_non_null - (local.set 1) - (@gyehoek :origin "(continue 位-tail1 x5)") + (@gyehoek + :origin + "(prim (* x x) (魏 (r2) (continue 位-tail1 r2)))") + (global.get $arg1) + (i31.get_s (ref.cast (ref i31))) + (i32.const 1) + i32.shr_u + (global.get $arg1) + (i31.get_s (ref.cast (ref i31))) + (i32.const 1) + i32.shr_u + i32.mul + (@gyehoek "construct small fixnum") + (i32.const 1) + i32.shl + ref.i31 + (global.set $arg2) + (@gyehoek :origin "(continue 位-tail1 r2)") (@gyehoek "push args") - (@gyehoek "push argument") - (global.get $arg-array) - (i32.const 0) - (local.get 4) - (array.set $arg-array-type) + (@gyehoek begin pushArg) + (global.get $arg2) + (global.set $arg0) + (@gyehoek end pushArg) (@gyehoek "nargs") (i32.const 1) (@gyehoek "pop cont stack") @@ -69,58 +91,26 @@ (elem declare funcref (ref.func 3)) (func (param i32) - (@gyehoek - :origin - "(魏 (x3) (letrec ((r4 (魏 (x5) (continue 位-tail1 x5)))) (f x3 r4)))") + (@gyehoek :origin "(魏 (x4) (continue halt x4))") (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - (@gyehoek "pop argument") - (global.get $arg-array) - (i32.const 0) - (array.get $arg-array-type) - ref.as_non_null - (local.set 1) - (@gyehoek :origin "(f x3 r4)") - (@gyehoek "push cont" :idx 3) - (array.set - $cont-stack-type - (global.get $cont-stack) - (global.get $cont-stack-top) - (ref.func 3)) - (global.set - $cont-stack-top - (i32.add (global.get $cont-stack-top) (i32.const 1))) - (@gyehoek :origin "(f x3 r4)") - (@gyehoek "load args") - (@gyehoek "push argument") - (global.get $arg-array) - (i32.const 0) - (local.get 3) - (array.set $arg-array-type) - (i32.const 1) - (local.get 1) - (ref.cast (ref $closure)) - (struct.get $closure $code) - (return_call_ref $cont-type)) + (@gyehoek begin pushArg) + (global.get $arg2) + (global.set $arg0) + (@gyehoek end pushArg) + (return_call $halt (i32.const 1))) (elem declare funcref (ref.func 4)) (func + $scm-entry (param i32) (@gyehoek :origin - "(位 (f x 位-tail1) (letrec ((r2 (魏 (x3) (letrec ((r4 (魏 (x5) (continue 位-tail1 x5)))) (f x3 r4))))) (f x r2)))") + "(letrec ((位-body0 (位 (x 位-tail1) (prim (* x x) (魏 (r2) (continue 位-tail1 r2)))))) (letrec ((r3 (魏 (x4) (continue halt x4)))) (位-body0 5 r3)))") (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - (@gyehoek "pop argument") - (global.get $arg-array) (i32.const 0) - (array.get $arg-array-type) - ref.as_non_null - (local.set 1) - (@gyehoek "pop argument") - (global.get $arg-array) - (i32.const 1) - (array.get $arg-array-type) - ref.as_non_null - (local.set 2) - (@gyehoek :origin "(f x r2)") + (ref.func 3) + (struct.new $closure) + (global.set $arg1) + (@gyehoek :origin "(位-body0 5 r3)") (@gyehoek "push cont" :idx 4) (array.set $cont-stack-type @@ -130,135 +120,22 @@ (global.set $cont-stack-top (i32.add (global.get $cont-stack-top) (i32.const 1))) - (@gyehoek :origin "(f x r2)") + (@gyehoek :origin "(位-body0 5 r3)") (@gyehoek "load args") - (@gyehoek "push argument") - (global.get $arg-array) - (i32.const 0) - (local.get 2) - (array.set $arg-array-type) + (@gyehoek begin pushArg) + (i32.const 5) + (@gyehoek "construct small fixnum") (i32.const 1) - (local.get 1) + i32.shl + ref.i31 + (global.set $arg0) + (@gyehoek end pushArg) + (i32.const 1) + (global.get $arg1) (ref.cast (ref $closure)) (struct.get $closure $code) - (return_call_ref $cont-type)) - (elem declare funcref (ref.func 5)) - (func - (param i32) - (@gyehoek - :origin - "(位 (x 位-tail7) (prim (+ x 4) (魏 (r8) (continue 位-tail7 r8))))") - (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - (@gyehoek "pop argument") - (global.get $arg-array) - (i32.const 0) - (array.get $arg-array-type) - ref.as_non_null - (local.set 1) - (@gyehoek - :origin - "(prim (+ x 4) (魏 (r8) (continue 位-tail7 r8)))") - (local.get 1) - (i31.get_s (ref.cast (ref i31))) - (i32.const 1) - i32.shr_u - (i32.const 4) - (@gyehoek "construct small fixnum") - (i32.const 1) - i32.shl - ref.i31 - (i31.get_s (ref.cast (ref i31))) - (i32.const 1) - i32.shr_u - i32.add - (@gyehoek "construct small fixnum") - (i32.const 1) - i32.shl - ref.i31 - (local.set 2) - (@gyehoek :origin "(continue 位-tail7 r8)") - (@gyehoek "push args") - (@gyehoek "push argument") - (global.get $arg-array) - (i32.const 0) - (local.get 2) - (array.set $arg-array-type) - (@gyehoek "nargs") - (i32.const 1) - (@gyehoek "pop cont stack") - (global.get $cont-stack-top) - (i32.const 1) - i32.sub - (global.set $cont-stack-top) - (global.get $cont-stack) - (global.get $cont-stack-top) - (array.get $cont-stack-type) - ref.as_non_null - (return_call_ref $cont-type)) - (elem declare funcref (ref.func 6)) - (func - (param i32) - (@gyehoek :origin "(魏 (x10) (continue halt x10))") - (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - (@gyehoek "pop argument") - (global.get $arg-array) - (i32.const 0) - (array.get $arg-array-type) - ref.as_non_null - (local.set 1) - (@gyehoek "push argument") - (global.get $arg-array) - (i32.const 0) - (local.get 3) - (array.set $arg-array-type) - (return_call $halt (i32.const 1))) - (elem declare funcref (ref.func 7)) - (func - $scm-entry - (param i32) - (@gyehoek - :origin - "(letrec ((位-body0 (位 (f x 位-tail1) (letrec ((r2 (魏 (x3) (letrec ((r4 (魏 (x5) (continue 位-tail1 x5)))) (f x3 r4))))) (f x r2))))) (letrec ((位-body6 (位 (x 位-tail7) (prim (+ x 4) (魏 (r8) (continue 位-tail7 r8)))))) (letrec ((r9 (魏 (x10) (continue halt x10)))) (位-body0 位-body6 9 r9))))") - (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - (i32.const 0) - (ref.func 5) - (struct.new $closure) - (local.set 1) - (i32.const 0) - (ref.func 6) - (struct.new $closure) - (local.set 2) - (@gyehoek :origin "(位-body0 位-body6 9 r9)") - (@gyehoek "push cont" :idx 7) - (array.set - $cont-stack-type - (global.get $cont-stack) - (global.get $cont-stack-top) - (ref.func 7)) - (global.set - $cont-stack-top - (i32.add (global.get $cont-stack-top) (i32.const 1))) - (@gyehoek :origin "(位-body0 位-body6 9 r9)") - (@gyehoek "load args") - (@gyehoek "push argument") - (global.get $arg-array) - (i32.const 0) - (local.get 2) - (array.set $arg-array-type) - (@gyehoek "push argument") - (global.get $arg-array) - (i32.const 1) - (i32.const 9) - (@gyehoek "construct small fixnum") - (i32.const 1) - i32.shl - ref.i31 - (array.set $arg-array-type) - (i32.const 1) - (local.get 1) - (ref.cast (ref $closure)) - (struct.get $closure $code) - (return_call_ref $cont-type)) + (return_call_ref $cont-type) + (@gyehoek todo (f' (global.get $arg1)) (ktail 1))) (func (export "main") (call $scm-entry (i32.const 0)) diff --git a/test/Gyehoek/Test/CPS/Syntax.hs b/test/Gyehoek/Test/CPS/Syntax.hs index d866891..6393c0b 100644 --- a/test/Gyehoek/Test/CPS/Syntax.hs +++ b/test/Gyehoek/Test/CPS/Syntax.hs @@ -18,15 +18,17 @@ root = pure . testGroup "cps syntax" $ ] freeTree :: TestTree -freeTree = testCase "free" do - Sut.free [cps| - (letrec ((x (lambda (r k1) (continue k1 y))) - (y (lambda (r k2) (continue k2 x)))) - (continue x y k3))|] @=? ["k3"] - Sut.free' [cps| - (letrec ((x (lambda (r k1) (continue k1 y))) - (y (lambda (r k2) (continue k2 x)))) - (continue x y k3))|] @=? ["k3"] +freeTree = testGroup "free" + [ testCase "lambda" do + Sut.free' @Sut.Lambda [cps| + (lambda (x y z k1) (continue k1 x a b c y)) + |] @=? ["a","b","c"] + , testCase "exp" do + Sut.free' @Sut.Exp [cps| + (letrec ((x (lambda (r k1) (continue k1 y))) + (y (lambda (r k2) (continue k2 x)))) + (continue x y k3))|] @=? ["k3"] + ] qqTree :: TestTree qqTree = testGroup "parser"