wip: call/cc primitives

src/Gyehoek/CPS/Convert.hs

@@ -47,18 +47,18 @@ 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 <- gensym' @Name "cc"
+--     cc <- gensym' @Name "cc"
-    r <- gensym' "r"
+--     r <- gensym' "r"
-    m <- k . one $ ValVar r
+--     m <- k . one $ ValVar r
-    ccish <- gensym' @Name "cc-ish"
+--     ccish <- gensym' @Name "cc-ish"
-    x <- gensym' @Name "x"
+--     x <- gensym' @Name "x"
-    pure [cps|
+--     pure [cps|
-      (letrec ((#{cc} (κ (#{r}) #{m})))
+--       (letrec ((#{cc} (κ (#{r}) #{m})))
-        (letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x}))))
+--         (letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x}))))
-          (#{withcc'} #{ccish} #{cc})))
+--           (#{withcc'} #{ccish} #{cc})))
-    |]
+--     |]
 
 -- ...while all other prims are left as-is for later stages to
 -- handle..

src/Gyehoek/CPS/Stackify.hs

@@ -86,7 +86,7 @@ stackify g e@(ExpContinue k xs) = do
 --   stackifyKappa g cc_l cc \g' rt -> do
 --     emitRoutine rt
 --     pure $
---       Code [ Stk.Prim rcc_l $ PrimReifyCC (Stk.ValLabel cc_l) ] $
+--       Code [ Stk.Prim rcc_l PrimCaptureCC ] $
 --       Tail (Stk.TailCall (stackifyVal g' withcc) [Stk.ValLabel rcc_l])
 
 stackify g (ExpPrim p (MkKappa [x] e)) = do

src/Gyehoek/Scheme/Syntax.hs

@@ -84,6 +84,7 @@ data Prim e
   | PrimEnvRef e Int
   | PrimEnvCode e
   | PrimCallCC e
+  | PrimCaptureCC
   | PrimValues (List e)
   | PrimCallWithValues e e
   deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
@@ -164,17 +165,18 @@ primDatumIso namefn a = S.match
     $ S.With (. ht1 "integer?")
     $ S.With (. ht1 "write")
     $ S.With (. ht1 "zero?")
-    $ S.With (. nullop "newline")
+    $ S.With (. ht0 "newline")
     $ S.With (. ht1' "make-closure")
     $ S.With (. S.headTagged2 (namefn "env-ref") a S.int)
     $ S.With (. ht1 "env-code")
     $ S.With (. ht1 "call/cc")
+    $ S.With (. ht0 "capture/cc")
     $ S.With (. ht0' "values")
     $ S.With (. ht2 "call-with-values")
     $ S.End
     where
       idn = S.el . S.sym . namefn
-      nullop s = S.list $ idn s
+      ht0 s = S.list $ idn s
       ht1 s = S.headTagged1 (namefn s) a
       ht2 s = S.headTagged2 (namefn s) a a
       ht1' s = S.headTagged1' (namefn s) a a

src/Gyehoek/Stack/Syntax.hs

@@ -61,6 +61,8 @@ data Block = MkBlock
 data Tail
   = TailCall Val (List Val)
   | If Val Block Block
+  -- | Invoke a reified continuation.
+  | InvokeC Val
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
@@ -105,6 +107,7 @@ instance S.DatumIso Tail where
   datumIso = S.match
     $ S.With (S.headTagged1' "tail-call" S.datumIso S.datumIso >>>)
     $ S.With (if_ >>>)
+    $ S.With (S.headTagged1 "invoke/c" S.datumIso >>>)
     $ S.End
     where
       if_ = S.ifLike "if" (S.datumIso @Val) (branch "then") (branch "else")