From 57b1cc830d373729e83ff129501c0e9b362b1a5c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= <msyds@deertopia.net>
Date: Sun, 30 Aug 2026 03:33:26 -0600
Subject: [PATCH 1/3] =?UTF-8?q?wip:=20call/cc=20=3D=20capture/cc=20=C3=97?=
 =?UTF-8?q?=20invoke/cc?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 src/Gyehoek/CPS/Close.hs     |  8 --------
 src/Gyehoek/CPS/Convert.hs   | 29 +++++++++++++++++------------
 src/Gyehoek/CPS/Eval.hs      |  5 -----
 src/Gyehoek/CPS/Stackify.hs  |  2 +-
 src/Gyehoek/Scheme/Syntax.hs |  4 ++--
 src/Gyehoek/Stack/VM.hs      |  4 ----
 test/Gyehoek/Test/Golden.hs  | 11 +----------
 7 files changed, 21 insertions(+), 42 deletions(-)

diff --git a/src/Gyehoek/CPS/Close.hs b/src/Gyehoek/CPS/Close.hs
index e04e869..ebbeb75 100644
--- a/src/Gyehoek/CPS/Close.hs
+++ b/src/Gyehoek/CPS/Close.hs
@@ -32,14 +32,6 @@ close = transformM \case
           (κ (#{f}) #{e})))
     |]
 
-  -- ExpApply f xs ktail -> do
-  --   code <- gensym' @Name "code"
-  --   pure [cps|
-  --     (prim (env-code #{f})
-  --       (κ (#{code})
-  --         (#{code} #{f} ##{xs} #{ktail})))
-  --   |]
-
   e -> pure e
 
 closeProgram :: GenSym :> es => Program -> Eff es Program
diff --git a/src/Gyehoek/CPS/Convert.hs b/src/Gyehoek/CPS/Convert.hs
index fa93e68..99de7cb 100644
--- a/src/Gyehoek/CPS/Convert.hs
+++ b/src/Gyehoek/CPS/Convert.hs
@@ -47,18 +47,23 @@ convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
   _ -> _
 
 -- special case: call/cc is desugared during cps-conversion...
--- convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
---   convert1 withcc \withcc' -> do
---     cc <- gensym' @Name "cc"
---     r <- gensym' "r"
---     m <- k . one $ ValVar r
---     ccish <- gensym' @Name "cc-ish"
---     x <- gensym' @Name "x"
---     pure [cps|
---       (letrec ((#{cc} (κ (#{r}) #{m})))
---         (letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x}))))
---           (#{withcc'} #{ccish} #{cc})))
---     |]
+convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
+  convert1 withcc \withcc' -> do
+    cc_l <- gensym' @Name "cc"
+    r1_l <- gensym' @Name "r"
+    r2_l <- gensym' @Name "r"
+    ccish_l <- gensym' @Name "ccish"
+    reified_cc_l <- gensym' @Name "reified-cc"
+    pure [cps|
+      (prim (capture/cc)
+        (κ (#{reified_cc_l})
+          (letrec ((#{ccish_l}
+                    (λ (#{r1_l} #{cc_l})
+                      (prim (invoke/cc #{reified_cc_l} #{r1_l})
+                        (κ (#{r2_l})
+                          (continue #{cc_l} #{r2_l}))))))
+            (#{withcc'} #{reified_cc_l} #{cc_l}))))
+    |]
 
 -- ...while all other prims are left as-is for later stages to
 -- handle..
diff --git a/src/Gyehoek/CPS/Eval.hs b/src/Gyehoek/CPS/Eval.hs
index 26b8556..05071d9 100644
--- a/src/Gyehoek/CPS/Eval.hs
+++ b/src/Gyehoek/CPS/Eval.hs
@@ -59,11 +59,6 @@ eval g (ExpPrim p (MkKappa bs e)) = case evalVal g <$> p of
       lbl = case x of
         ObjImm (ImmLabel l) -> l
         _ -> error [i|expected label, got #{x}|]
-  PrimEnvCode x -> ret . (:[]) . ObjImm . ImmLabel $ code
-    where
-      code = case x of
-        ObjHob (HobClosure lbl _) -> lbl
-        _ -> error [i|expected closure, got #{x}|]
   _ -> error [i|unhandled prim: #{p}|]
   where
     ret rs = eval
diff --git a/src/Gyehoek/CPS/Stackify.hs b/src/Gyehoek/CPS/Stackify.hs
index 5a46364..2d2f637 100644
--- a/src/Gyehoek/CPS/Stackify.hs
+++ b/src/Gyehoek/CPS/Stackify.hs
@@ -49,7 +49,7 @@ stackify
 
 stackify g (ExpLetRec [(f, AbsKappa kap)] e) = do
   kap' <- stackifyKappa g kap
-  emitRoutine (Stk.MkRoutine (MkLabel f) . buildBlock $ kap')
+  emitRoutine . Stk.MkRoutine (MkLabel f) . buildBlock $ kap'
   stackify g e
 
 stackify g (ExpLetRec [(f, AbsLambda lam)] e) = do
diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs
index d928c58..2e9ba42 100644
--- a/src/Gyehoek/Scheme/Syntax.hs
+++ b/src/Gyehoek/Scheme/Syntax.hs
@@ -83,9 +83,9 @@ data Prim e
   | PrimMakeClosure { code :: e, env :: List e }
   | PrimEnv
   | PrimEnvRef Int
-  | PrimEnvCode e
   | PrimCallCC e
   | PrimCaptureCC
+  | PrimInvokeCC e (List e)
   | PrimValues (List e)
   | PrimCallWithValues e e
   deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
@@ -170,9 +170,9 @@ primDatumIso namefn a = S.match
     $ S.With (. ht1' "make-closure")
     $ S.With (. ht0 "env")
     $ S.With (. S.headTagged1 (namefn "env-ref") S.int)
-    $ S.With (. ht1 "env-code")
     $ S.With (. ht1 "call/cc")
     $ S.With (. ht0 "capture/cc")
+    $ S.With (. ht1' "invoke/cc")
     $ S.With (. ht0' "values")
     $ S.With (. ht2 "call-with-values")
     $ S.End
diff --git a/src/Gyehoek/Stack/VM.hs b/src/Gyehoek/Stack/VM.hs
index 85b0164..b267bf7 100644
--- a/src/Gyehoek/Stack/VM.hs
+++ b/src/Gyehoek/Stack/VM.hs
@@ -192,10 +192,6 @@ stepP g vm p = traverse (evalVal g vm) p >>= \case
     case f of
       ObjImm (ImmLabel l) -> ret1 . ObjHob $ HobClosure l env
       _ -> vmerror [i|expected label, got #{f}|]
-  PrimEnvCode env ->
-    case env of
-      ObjHob (HobClosure l _) -> ret1 . ObjImm . ImmLabel $ l
-      _ -> vmerror [i|expected closure, got #{env}|]
   PrimEnv -> do
     x <- vm & expectOf "expected closure" (activeFrame . activeProcedure)
     ret1 x
diff --git a/test/Gyehoek/Test/Golden.hs b/test/Gyehoek/Test/Golden.hs
index a929937..8850f68 100644
--- a/test/Gyehoek/Test/Golden.hs
+++ b/test/Gyehoek/Test/Golden.hs
@@ -29,16 +29,7 @@ brokenWasmTests =
 
 brokenStackifyTests :: List String
 brokenStackifyTests =
-  [ "callcc-early-exit-1"
-  , "callcc-early-exit-2"
-  , "callcc-early-exit-3"
-  , "callcc-early-exit-4"
-  , "callcc-early-exit-5"
-  , "callcc-early-exit-6"
-  , "callcc-nested-1"
-  , "callcc-nested-2"
-  , "callcc-discard"
-  , "callcc-constant"
+  [
   ]
 
 test_root :: IO TestTree
-- 
2.55.0


From 64641bb25848bc89e9794223d1b2e4e0470bc49d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= <msyds@deertopia.net>
Date: Sun, 30 Aug 2026 05:39:13 -0600
Subject: [PATCH 2/3]

---
 src/Gyehoek/CPS/Convert.hs  | 32 +++++++++++++++-----------------
 src/Gyehoek/CPS/Stackify.hs | 10 ++++++++++
 src/Gyehoek/CPS/Syntax.hs   |  9 ++++++++-
 src/Gyehoek/Stack/VM.hs     |  4 ++++
 4 files changed, 37 insertions(+), 18 deletions(-)

diff --git a/src/Gyehoek/CPS/Convert.hs b/src/Gyehoek/CPS/Convert.hs
index 99de7cb..eb29bfa 100644
--- a/src/Gyehoek/CPS/Convert.hs
+++ b/src/Gyehoek/CPS/Convert.hs
@@ -47,23 +47,21 @@ convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
   _ -> _
 
 -- special case: call/cc is desugared during cps-conversion...
-convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
-  convert1 withcc \withcc' -> do
-    cc_l <- gensym' @Name "cc"
-    r1_l <- gensym' @Name "r"
-    r2_l <- gensym' @Name "r"
-    ccish_l <- gensym' @Name "ccish"
-    reified_cc_l <- gensym' @Name "reified-cc"
-    pure [cps|
-      (prim (capture/cc)
-        (κ (#{reified_cc_l})
-          (letrec ((#{ccish_l}
-                    (λ (#{r1_l} #{cc_l})
-                      (prim (invoke/cc #{reified_cc_l} #{r1_l})
-                        (κ (#{r2_l})
-                          (continue #{cc_l} #{r2_l}))))))
-            (#{withcc'} #{reified_cc_l} #{cc_l}))))
-    |]
+-- convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
+--   convert1 withcc \withcc' -> do
+--     cc_l <- gensym' @Name "cc"
+--     r1_l <- gensym' @Name "r"
+--     r2_l <- gensym' @Name "r"
+--     ccish_l <- gensym' @Name "ccish"
+--     reified_cc_l <- gensym' @Name "reified-cc"
+--     m <- k [ValVar r1_l]
+--     pure [cps|
+-- (letrec ((#{cc_l} (κ (#{r1_l})
+--                      #{m})))
+--   (prim (capture/cc)
+--        (κ (#{reified_cc_l})
+--           (#{withcc'} #{reified_cc_l} #{cc_l}))))
+--     |]
 
 -- ...while all other prims are left as-is for later stages to
 -- handle..
diff --git a/src/Gyehoek/CPS/Stackify.hs b/src/Gyehoek/CPS/Stackify.hs
index 2d2f637..e9decad 100644
--- a/src/Gyehoek/CPS/Stackify.hs
+++ b/src/Gyehoek/CPS/Stackify.hs
@@ -81,6 +81,16 @@ stackify g e@(ExpContinue k xs)
     Code (pushArgs g xs) $
     Tail (Stk.Return (length xs))
 
+stackify g (ExpPrim (PrimCallCC withcc) cc) = do
+  cc' <- stackifyKappa g cc
+  cc_l <- gensym' @Name "cc"
+  reified_cc_l <- gensym' @Name "reified-cc"
+  emitRoutine . Stk.MkRoutine (MkLabel cc_l) . buildBlock $ cc'
+  stackify g $
+    ExpPrim PrimCaptureCC $
+    MkKappa [reified_cc_l] $
+    ExpApply withcc [ValVar reified_cc_l] cc_l
+
 stackify g (ExpPrim p kap) = do
   kap' <- stackifyKappa g kap
   pure $ Code [ Stk.Prim (stackifyVal g <$> p) ] kap'
diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs
index e7137e5..e859d5d 100644
--- a/src/Gyehoek/CPS/Syntax.hs
+++ b/src/Gyehoek/CPS/Syntax.hs
@@ -96,6 +96,8 @@ pattern ObjLabel l = ObjImm (ImmLabel l)
 -- | a heap object.
 data Hob
   = HobClosure { label :: Label, env :: List Obj }
+  -- should a continuation have a label, or an Obj?
+  | HobContinuation { label :: Label }
   | HobPair Obj Obj
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
@@ -208,6 +210,7 @@ instance S.DatumIso Reg where
 instance S.DatumIso Hob where
   datumIso = S.match
     $ S.With (. closure)
+    $ S.With (. cont)
     $ S.With (. conspair)
     $ S.End
     where
@@ -215,7 +218,11 @@ instance S.DatumIso Hob where
       -- closures can be printed, but not parsed.
       closure :: G (Datum :- t) (List Obj :- Label :- t)
       closure = IG.Flip $ IG.PartialIso
-        (\(env:-code:-t) -> S.Unreadable "#<procedure>" :- t)
+        (\(env:-code:-t) -> S.Unreadable [i|\#<procedure $#{code}>|] :- t)
+        (const . Left $ mempty)
+      cont :: G (Datum :- t) (Label :- t)
+      cont = IG.Flip $ IG.PartialIso
+        (\(l :- t) -> S.Unreadable [i|\#<continuation $#{l}>|]:- t)
         (const . Left $ mempty)
 
 instance S.DatumIso Lambda where
diff --git a/src/Gyehoek/Stack/VM.hs b/src/Gyehoek/Stack/VM.hs
index b267bf7..ab63f4f 100644
--- a/src/Gyehoek/Stack/VM.hs
+++ b/src/Gyehoek/Stack/VM.hs
@@ -207,6 +207,10 @@ stepP g vm p = traverse (evalVal g vm) p >>= \case
   PrimCdr x -> case x of
       ObjHob (HobPair _ cdr) -> ret1 cdr
       _ -> vmerror [i|expected pair, got ${x}|]
+  PrimCaptureCC -> do
+    label <- vm & expectOf [i|bad stack, no return addr|]
+      (activeFrame . returnAddress . #_ObjImm . #_ImmLabel)
+    ret1 . ObjHob $ HobContinuation { label }
   x -> vmerror [i|unimplemented prim: #{p}|]
   where
     ret vs = pure $ vm & activeFrame . #locals <>:~ vs
-- 
2.55.0


From 35e1b0cbe2c0ff0faff8b85c61a2aba53871477c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= <msyds@deertopia.net>
Date: Sun, 30 Aug 2026 10:31:43 -0600
Subject: [PATCH 3/3] stupid

---
 src/Gyehoek/CPS/Stackify.hs | 15 +++++++--------
 src/Gyehoek/CPS/Syntax.hs   |  8 +++++---
 src/Gyehoek/Stack/Syntax.hs |  2 ++
 src/Gyehoek/Stack/VM.hs     | 37 +++++++++++++++++++++++++++++++------
 t.scm                       |  5 +++++
 5 files changed, 50 insertions(+), 17 deletions(-)
 create mode 100644 t.scm

diff --git a/src/Gyehoek/CPS/Stackify.hs b/src/Gyehoek/CPS/Stackify.hs
index e9decad..c292880 100644
--- a/src/Gyehoek/CPS/Stackify.hs
+++ b/src/Gyehoek/CPS/Stackify.hs
@@ -71,7 +71,6 @@ stackify g (ExpApply f xs ktail) = do
     Code (pushArgs g xs) $
     Tail (Stk.Call (length xs))
 
--- assume that `k` is the continuation on top of the stack lol.
 stackify g e@(ExpContinue k xs)
   | isn't (#_ValVar . only g.tail) k = pure $
     Code [ Stk.Push (stackifyVal g k) ] $
@@ -83,13 +82,13 @@ stackify g e@(ExpContinue k xs)
 
 stackify g (ExpPrim (PrimCallCC withcc) cc) = do
   cc' <- stackifyKappa g cc
-  cc_l <- gensym' @Name "cc"
-  reified_cc_l <- gensym' @Name "reified-cc"
-  emitRoutine . Stk.MkRoutine (MkLabel cc_l) . buildBlock $ cc'
-  stackify g $
-    ExpPrim PrimCaptureCC $
-    MkKappa [reified_cc_l] $
-    ExpApply withcc [ValVar reified_cc_l] cc_l
+  cc_l <- gensym' @Label "cc"
+  emitRoutine . Stk.MkRoutine cc_l . buildBlock $ cc'
+  pure $
+    Code [ Stk.Push $ stackifyVal g withcc
+         , Stk.Push $ stackifyVal g (ValLabel cc_l)
+         ] $
+    Tail Stk.CallCC
 
 stackify g (ExpPrim p kap) = do
   kap' <- stackifyKappa g kap
diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs
index e859d5d..06c25b8 100644
--- a/src/Gyehoek/CPS/Syntax.hs
+++ b/src/Gyehoek/CPS/Syntax.hs
@@ -97,7 +97,7 @@ pattern ObjLabel l = ObjImm (ImmLabel l)
 data Hob
   = HobClosure { label :: Label, env :: List Obj }
   -- should a continuation have a label, or an Obj?
-  | HobContinuation { label :: Label }
+  | HobContinuation { cont :: Obj, stack :: NonEmpty (List Obj) }
   | HobPair Obj Obj
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
@@ -220,9 +220,11 @@ instance S.DatumIso Hob where
       closure = IG.Flip $ IG.PartialIso
         (\(env:-code:-t) -> S.Unreadable [i|\#<procedure $#{code}>|] :- t)
         (const . Left $ mempty)
-      cont :: G (Datum :- t) (Label :- t)
+      cont :: G (Datum :- t) (NonEmpty (List Obj) :- _ :- t)
       cont = IG.Flip $ IG.PartialIso
-        (\(l :- t) -> S.Unreadable [i|\#<continuation $#{l}>|]:- t)
+        (\(_ :- l :- t) -> 
+          let x = S.encodeOrShow' @Text S.datumIso l
+          in S.Unreadable [i|\#<continuation #{x}>|] :- t)
         (const . Left $ mempty)
 
 instance S.DatumIso Lambda where
diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs
index 1dce092..08199de 100644
--- a/src/Gyehoek/Stack/Syntax.hs
+++ b/src/Gyehoek/Stack/Syntax.hs
@@ -68,6 +68,7 @@ data Tail
   | Call Int
   | If Val Block Block
   | Return Int
+  | CallCC
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
@@ -116,6 +117,7 @@ instance S.DatumIso Tail where
     $ S.With (S.headTagged1 "call" S.datumIso >>>)
     $ S.With (if_ >>>)
     $ S.With (S.headTagged1 "return" S.datumIso >>>)
+    $ S.With (S.headTagged0 "call/cc" >>>)
     $ S.End
     where
       -- if_ = S.ifLike "if" (S.datumIso @Val) S.datumIso S.datumIso
diff --git a/src/Gyehoek/Stack/VM.hs b/src/Gyehoek/Stack/VM.hs
index ab63f4f..3bf78b8 100644
--- a/src/Gyehoek/Stack/VM.hs
+++ b/src/Gyehoek/Stack/VM.hs
@@ -132,16 +132,20 @@ stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM
 
 stepT g vm tc@(Call nargs) = do
   (args,f,ret,frm) <- parseCall nargs (vm ^. activeFrame)
-    & expectOf [i|bad call: #{show tc}|] _Just 
+    & expectOf [i|bad call: #{show tc}|] _Just
   rt <- getRoutine g f
   let newFrame = MkFrame $ args ++ [f,ret]
   pure $ vm
     & jumpToRoutine rt
     & activeFrame .~ frm
-    & #stack %~ pushFrame newFrame
     -- it is not essential we clear the registers, but it'll
     -- make bugs more obvious.
     & #registers .~ mempty
+    & #stack %~ \stk ->
+      case f of
+        ObjHob (HobContinuation {stack}) ->
+          coerce $ stack & _NonEmpty . _1 <>:~ (args ++ [f])
+        _ -> pushFrame newFrame stk
 
 stepT g vm tc@(Return nret) = do
   (xs,_) <- splitAtExact nret (vm ^. activeFrame . #locals)
@@ -179,6 +183,21 @@ stepT g vm (If c t f) = do
       _ -> t
   pure $ jumpToBlock branch vm
 
+stepT g vm CallCC = do
+  (cc,withcc,frm) <- parseCallCC (vm ^. activeFrame)
+    & expectOf "bad call/cc" _Just
+  let stk = vm.stack & #frames . _NonEmpty . _1 .~ frm
+  let reified_cc = ObjHob $ HobContinuation cc (coerce stk)
+  let newFrame = MkFrame [reified_cc, withcc, cc]
+  rt <- getRoutine g withcc
+  pure $ vm
+    & jumpToRoutine rt
+    -- replace the active frame; don't push a new one.
+    & activeFrame .~ newFrame
+    -- it is not essential we clear the registers, but it'll make
+    -- bugs more obvious.
+    & #registers .~ mempty
+
 stepP :: Jalmot :> es => Env -> VM -> Prim Val -> Eff es VM
 stepP g vm p = traverse (evalVal g vm) p >>= \case
   PrimZeroP x -> case x of
@@ -207,10 +226,10 @@ stepP g vm p = traverse (evalVal g vm) p >>= \case
   PrimCdr x -> case x of
       ObjHob (HobPair _ cdr) -> ret1 cdr
       _ -> vmerror [i|expected pair, got ${x}|]
-  PrimCaptureCC -> do
-    label <- vm & expectOf [i|bad stack, no return addr|]
-      (activeFrame . returnAddress . #_ObjImm . #_ImmLabel)
-    ret1 . ObjHob $ HobContinuation { label }
+  -- PrimCaptureCC -> do
+  --   label <- vm & expectOf [i|bad stack, no return addr|]
+  --     (activeFrame . returnAddress . #_ObjImm . #_ImmLabel)
+  --   ret1 . ObjHob $ HobContinuation { label }
   x -> vmerror [i|unimplemented prim: #{p}|]
   where
     ret vs = pure $ vm & activeFrame . #locals <>:~ vs
@@ -239,6 +258,7 @@ jumpToRoutine rt vm = vm
 getLabel :: Obj -> Maybe Label
 getLabel = \case
   ObjHob (HobClosure {label}) -> Just label
+  ObjHob (HobContinuation {cont}) -> getLabel cont
   ObjImm (ImmLabel label) -> Just label
   x -> Nothing
 
@@ -277,6 +297,11 @@ takeExact n xs = case compareLength xs n of
   (EQ;GT) -> Just $ take n xs
   LT -> Nothing
 
+parseCallCC :: Frame -> Maybe (Obj, Obj, Frame)
+parseCallCC frm = do
+  ([cc,withcc],ys) <- splitAtExact 2 (frm ^. #locals)
+  pure (cc,withcc,MkFrame ys)
+
 parseCall :: Int -> Frame -> Maybe (List Obj, Obj, Obj, Frame)
 parseCall nargs frm = do
   (xs,ys) <- splitAtExact (nargs+2) (frm ^. #locals)
diff --git a/t.scm b/t.scm
new file mode 100644
index 0000000..ccd981e
--- /dev/null
+++ b/t.scm
@@ -0,0 +1,5 @@
+((λ ()
+   (* 2 (call/cc
+         (λ (k)
+           (begin (k 6)
+                  3))))))
-- 
2.55.0