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