wip: call/cc = capture/cc × invoke/cc

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

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..

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

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

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

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

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