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
+-- convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
-  convert1 withcc \withcc' -> do
+--   convert1 withcc \withcc' -> do
-    cc_l <- gensym' @Name "cc"
+--     cc_l <- gensym' @Name "cc"
-    r1_l <- gensym' @Name "r"
+--     r1_l <- gensym' @Name "r"
-    r2_l <- gensym' @Name "r"
+--     r2_l <- gensym' @Name "r"
-    ccish_l <- gensym' @Name "ccish"
+--     ccish_l <- gensym' @Name "ccish"
-    reified_cc_l <- gensym' @Name "reified-cc"
+--     reified_cc_l <- gensym' @Name "reified-cc"
-    pure [cps|
+--     m <- k [ValVar r1_l]
-      (prim (capture/cc)
+--     pure [cps|
-        (κ (#{reified_cc_l})
+-- (letrec ((#{cc_l} (κ (#{r1_l})
-          (letrec ((#{ccish_l}
+--                      #{m})))
-                    (λ (#{r1_l} #{cc_l})
+--   (prim (capture/cc)
-                      (prim (invoke/cc #{reified_cc_l} #{r1_l})
+--        (κ (#{reified_cc_l})
-                        (κ (#{r2_l})
+--           (#{withcc'} #{reified_cc_l} #{cc_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..

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'

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

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