idk

golden/adder/source.scm

@@ -0,0 +1,4 @@
+(let ((make-adder (lambda (x)
+                    (lambda (y)
+                      (+ x y)))))
+  ((make-adder 4) 5))

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

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

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

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")
+    (@gyehoek begin pushArg)
-    (global.get $arg-array)
-    (i32.const #{n})
     ##{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")
+  (@gyehoek begin popArg)
-  (global.get $arg-array)
+  (global.get #{reg})
-  (i32.const #{n})
-  (array.get $arg-array-type)
   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
+    l = getArgRegister . fromIntegral . 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)
---   |]
 
 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
+  -- arg registers
-  Wasm.defineType [wat|
+  Wasm.defineGlobals [wats|
-    (type $arg-array-type (array (mut (ref null eq))))
+    (global $arg0 (mut (ref null eq)) (ref.null eq))
-  |]
+    (global $arg1 (mut (ref null eq)) (ref.null eq))
-  Wasm.defineGlobal [wat|
+    (global $arg2 (mut (ref null eq)) (ref.null eq))
-    (global $arg-array (ref $arg-array-type)
+    (global $arg3 (mut (ref null eq)) (ref.null eq))
-            (array.new_default $arg-array-type (i32.const 32)))
+    (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|

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
+class Free a where
-free = go where
+  free :: a -> HashSet Name
-  gokap (MkKappa xs m) = go m & deleteFrom xs
+  free = freeWithBound mempty
-  golam (MkLambda xs k m) = go m & deleteFrom xs & sans k
+
-  goabs = \case
+  freeWithBound :: HashSet Name -> a -> HashSet Name
-    AbsKappa kap -> gokap kap
+  freeWithBound bound = HS.fromList . freeWithBound' bound
-    AbsLambda lam -> golam lam
+
-  go = \case
+  -- | 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)
+      p & toListOf (folded . #ValVar . filtered (`notElem` bound))
-        & HS.union (gokap k)
+        & (<> freeWithBound' bound k)
     ExpLetRec bs m ->
-      foldMapOf (each . _2) goabs bs <> go m
+      foldMapOf (each . _2) (freeWithBound' bound') bs
-      & deleteFrom (bs ^.. each . _1)
+      <> freeWithBound' bound' m
-    ExpContinue k xs -> HS.fromList $ k : xs ^.. each . #ValVar
+      where bound' = bound & insertFrom (bs ^.. each . _1)
-    ExpIf c t f -> toHashSetOf #ValVar c <> go t <> go f
+    ExpContinue k xs -> filter (`notElem` bound) (k : xs ^.. each . #ValVar)
-    ExpApply f xs k -> toHashSetOf (each . #ValVar) (f:xs) <> HS.singleton k
+    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.
+instance Free Kappa where
-free' :: Exp -> List Name
+  freeWithBound' bound (MkKappa xs m) =
-free' = nubOrd . goFree HS.empty where
+    freeWithBound' (bound & insertFrom xs) m
 
-goFreeKap bound (MkKappa xs m) = goFree (bound & insertFrom xs) m
+instance Free Lambda where
-goFreeLam bound (MkLambda xs k m) = goFree (bound & insertFrom (k:xs)) m
+  freeWithBound' bound (MkLambda xs k m) =
-goFreeAbs bound = \case
+    freeWithBound' (bound & insertFrom (k:xs)) m
-  AbsKappa kap -> goFreeKap bound kap
-  AbsLambda lam -> goFreeLam bound lam
 
-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
+class Vars a where
-freeLambda (MkLambda {binders,ktail,body}) = _
+  -- | 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 = _

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 ->
-    withFile opts.output FS.WriteMode \h ->
+    hPutStrLn h wat
-      hPutStrLn h wat
+  when opts.inspectWasm do
-  else
     inspectWasm wat
 
 parse_e2e :: FilePath -> IO Scm.Program

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_)

t.scm

@@ -1 +1,3 @@
-(values 1 2)
+(letrec ((x 3)
+         (y 4))
+  (values x y))

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 $arg0 (mut (ref null eq)) (ref.null eq))
-  (global
+  (global $arg1 (mut (ref null eq)) (ref.null eq))
-    $arg-array
+  (global $arg2 (mut (ref null eq)) (ref.null eq))
-    (ref $arg-array-type)
+  (global $arg3 (mut (ref null eq)) (ref.null eq))
-    (array.new_default $arg-array-type (i32.const 32)))
+  (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")
+    (@gyehoek begin popArg)
-    (global.get $arg-array)
+    (global.get $arg0)
-    (i32.const 0)
-    (array.get $arg-array-type)
     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")
+    (@gyehoek
-    (global.get $arg-array)
+      :origin
-    (i32.const 0)
+      "(prim (* x x) (κ (r2) (continue λ-tail1 r2)))")
-    (array.get $arg-array-type)
+    (global.get $arg1)
-    ref.as_non_null
+    (i31.get_s (ref.cast (ref i31)))
-    (local.set 1)
+    (i32.const 1)
-    (@gyehoek :origin "(continue λ-tail1 x5)")
+    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")
+    (@gyehoek begin pushArg)
-    (global.get $arg-array)
+    (global.get $arg2)
-    (i32.const 0)
+    (global.set $arg0)
-    (local.get 4)
+    (@gyehoek end pushArg)
-    (array.set $arg-array-type)
     (@gyehoek "nargs")
     (i32.const 1)
     (@gyehoek "pop cont stack")
@@ -69,58 +91,26 @@
   (elem declare funcref (ref.func 3))
   (func
     (param i32)
-    (@gyehoek
+    (@gyehoek :origin "(κ (x4) (continue halt x4))")
-      :origin
-      "(κ (x3) (letrec ((r4 (κ (x5) (continue λ-tail1 x5)))) (f x3 r4)))")
     (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-    (@gyehoek "pop argument")
+    (@gyehoek begin pushArg)
-    (global.get $arg-array)
+    (global.get $arg2)
-    (i32.const 0)
+    (global.set $arg0)
-    (array.get $arg-array-type)
+    (@gyehoek end pushArg)
-    ref.as_non_null
+    (return_call $halt (i32.const 1)))
-    (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))
   (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.func 3)
-    ref.as_non_null
+    (struct.new $closure)
-    (local.set 1)
+    (global.set $arg1)
-    (@gyehoek "pop argument")
+    (@gyehoek :origin "(λ-body0 5 r3)")
-    (global.get $arg-array)
-    (i32.const 1)
-    (array.get $arg-array-type)
-    ref.as_non_null
-    (local.set 2)
-    (@gyehoek :origin "(f x r2)")
     (@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")
+    (@gyehoek begin pushArg)
-    (global.get $arg-array)
+    (i32.const 5)
-    (i32.const 0)
+    (@gyehoek "construct small fixnum")
-    (local.get 2)
-    (array.set $arg-array-type)
     (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))
+    (return_call_ref $cont-type)
-  (elem declare funcref (ref.func 5))
+    (@gyehoek todo (f' (global.get $arg1)) (ktail 1)))
-  (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))
   (func
     (export "main")
     (call $scm-entry (i32.const 0))

test/Gyehoek/Test/CPS/Syntax.hs

@@ -18,15 +18,17 @@ root = pure . testGroup "cps syntax" $
   ]
 
 freeTree :: TestTree
-freeTree = testCase "free" do
+freeTree = testGroup "free"
-  Sut.free [cps|
+  [ testCase "lambda" do
-    (letrec ((x (lambda (r k1) (continue k1 y)))
+    Sut.free' @Sut.Lambda [cps|
-             (y (lambda (r k2) (continue k2 x))))
+      (lambda (x y z k1) (continue k1 x a b c y))
-      (continue x y k3))|] @=? ["k3"]
+    |] @=? ["a","b","c"]
-  Sut.free' [cps|
+  , testCase "exp" do
-    (letrec ((x (lambda (r k1) (continue k1 y)))
+    Sut.free' @Sut.Exp [cps|
-             (y (lambda (r k2) (continue k2 x))))
+      (letrec ((x (lambda (r k1) (continue k1 y)))
-      (continue x y k3))|] @=? ["k3"]
+               (y (lambda (r k2) (continue k2 x))))
+        (continue x y k3))|] @=? ["k3"]
+  ]
 
 qqTree :: TestTree
 qqTree = testGroup "parser"