From 25f1f008bdfb8e19e217736b55c06e2af2d40073 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Sun, 30 Aug 2026 03:33:26 -0600 Subject: [PATCH] =?UTF-8?q?wip:=20call/cc=20=3D=20capture/cc=20=C3=97=20in?= =?UTF-8?q?voke/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 | 19 +++++++++++-------- src/Gyehoek/CPS/Eval.hs | 5 ----- src/Gyehoek/CPS/Stackify.hs | 12 +++++++++++- src/Gyehoek/CPS/Syntax.hs | 9 ++++++++- src/Gyehoek/Scheme/Syntax.hs | 4 ++-- src/Gyehoek/Stack/VM.hs | 8 ++++---- test/Gyehoek/Test/Golden.hs | 11 +---------- 8 files changed, 37 insertions(+), 39 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..eb29bfa 100644 --- a/src/Gyehoek/CPS/Convert.hs +++ b/src/Gyehoek/CPS/Convert.hs @@ -49,15 +49,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 -- 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" +-- 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} (κ (#{r}) #{m}))) --- (letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x})))) --- (#{withcc'} #{ccish} #{cc}))) +-- (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 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..e9decad 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 @@ -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 "#" :- t) + (\(env:-code:-t) -> S.Unreadable [i|\#|] :- t) + (const . Left $ mempty) + cont :: G (Datum :- t) (Label :- t) + cont = IG.Flip $ IG.PartialIso + (\(l :- t) -> S.Unreadable [i|\#|]:- t) (const . Left $ mempty) instance S.DatumIso Lambda where 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..ab63f4f 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 @@ -211,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 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