From 35e1b0cbe2c0ff0faff8b85c61a2aba53871477c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Sun, 30 Aug 2026 10:31:43 -0600 Subject: [PATCH] stupid --- src/Gyehoek/CPS/Stackify.hs | 15 +++++++-------- src/Gyehoek/CPS/Syntax.hs | 8 +++++--- src/Gyehoek/Stack/Syntax.hs | 2 ++ src/Gyehoek/Stack/VM.hs | 37 +++++++++++++++++++++++++++++++------ t.scm | 5 +++++ 5 files changed, 50 insertions(+), 17 deletions(-) create mode 100644 t.scm diff --git a/src/Gyehoek/CPS/Stackify.hs b/src/Gyehoek/CPS/Stackify.hs index e9decad..c292880 100644 --- a/src/Gyehoek/CPS/Stackify.hs +++ b/src/Gyehoek/CPS/Stackify.hs @@ -71,7 +71,6 @@ stackify g (ExpApply f xs ktail) = do Code (pushArgs g xs) $ Tail (Stk.Call (length xs)) --- assume that `k` is the continuation on top of the stack lol. stackify g e@(ExpContinue k xs) | isn't (#_ValVar . only g.tail) k = pure $ Code [ Stk.Push (stackifyVal g k) ] $ @@ -83,13 +82,13 @@ stackify g e@(ExpContinue k 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 + cc_l <- gensym' @Label "cc" + emitRoutine . Stk.MkRoutine cc_l . buildBlock $ cc' + pure $ + Code [ Stk.Push $ stackifyVal g withcc + , Stk.Push $ stackifyVal g (ValLabel cc_l) + ] $ + Tail Stk.CallCC stackify g (ExpPrim p kap) = do kap' <- stackifyKappa g kap diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index e859d5d..06c25b8 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -97,7 +97,7 @@ pattern ObjLabel l = ObjImm (ImmLabel l) data Hob = HobClosure { label :: Label, env :: List Obj } -- should a continuation have a label, or an Obj? - | HobContinuation { label :: Label } + | HobContinuation { cont :: Obj, stack :: NonEmpty (List Obj) } | HobPair Obj Obj deriving stock (Show, Generic, Data, Eq) deriving anyclass (NFData) @@ -220,9 +220,11 @@ instance S.DatumIso Hob where closure = IG.Flip $ IG.PartialIso (\(env:-code:-t) -> S.Unreadable [i|\#|] :- t) (const . Left $ mempty) - cont :: G (Datum :- t) (Label :- t) + cont :: G (Datum :- t) (NonEmpty (List Obj) :- _ :- t) cont = IG.Flip $ IG.PartialIso - (\(l :- t) -> S.Unreadable [i|\#|]:- t) + (\(_ :- l :- t) -> + let x = S.encodeOrShow' @Text S.datumIso l + in S.Unreadable [i|\#|] :- t) (const . Left $ mempty) instance S.DatumIso Lambda where diff --git a/src/Gyehoek/Stack/Syntax.hs b/src/Gyehoek/Stack/Syntax.hs index 1dce092..08199de 100644 --- a/src/Gyehoek/Stack/Syntax.hs +++ b/src/Gyehoek/Stack/Syntax.hs @@ -68,6 +68,7 @@ data Tail | Call Int | If Val Block Block | Return Int + | CallCC deriving stock (Show, Generic, Data) deriving anyclass (NFData) @@ -116,6 +117,7 @@ instance S.DatumIso Tail where $ S.With (S.headTagged1 "call" S.datumIso >>>) $ S.With (if_ >>>) $ S.With (S.headTagged1 "return" S.datumIso >>>) + $ S.With (S.headTagged0 "call/cc" >>>) $ S.End where -- if_ = S.ifLike "if" (S.datumIso @Val) S.datumIso S.datumIso diff --git a/src/Gyehoek/Stack/VM.hs b/src/Gyehoek/Stack/VM.hs index ab63f4f..3bf78b8 100644 --- a/src/Gyehoek/Stack/VM.hs +++ b/src/Gyehoek/Stack/VM.hs @@ -132,16 +132,20 @@ stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM stepT g vm tc@(Call nargs) = do (args,f,ret,frm) <- parseCall nargs (vm ^. activeFrame) - & expectOf [i|bad call: #{show tc}|] _Just + & expectOf [i|bad call: #{show tc}|] _Just rt <- getRoutine g f let newFrame = MkFrame $ args ++ [f,ret] pure $ vm & jumpToRoutine rt & activeFrame .~ frm - & #stack %~ pushFrame newFrame -- it is not essential we clear the registers, but it'll -- make bugs more obvious. & #registers .~ mempty + & #stack %~ \stk -> + case f of + ObjHob (HobContinuation {stack}) -> + coerce $ stack & _NonEmpty . _1 <>:~ (args ++ [f]) + _ -> pushFrame newFrame stk stepT g vm tc@(Return nret) = do (xs,_) <- splitAtExact nret (vm ^. activeFrame . #locals) @@ -179,6 +183,21 @@ stepT g vm (If c t f) = do _ -> t pure $ jumpToBlock branch vm +stepT g vm CallCC = do + (cc,withcc,frm) <- parseCallCC (vm ^. activeFrame) + & expectOf "bad call/cc" _Just + let stk = vm.stack & #frames . _NonEmpty . _1 .~ frm + let reified_cc = ObjHob $ HobContinuation cc (coerce stk) + let newFrame = MkFrame [reified_cc, withcc, cc] + rt <- getRoutine g withcc + pure $ vm + & jumpToRoutine rt + -- replace the active frame; don't push a new one. + & activeFrame .~ newFrame + -- it is not essential we clear the registers, but it'll make + -- bugs more obvious. + & #registers .~ mempty + stepP :: Jalmot :> es => Env -> VM -> Prim Val -> Eff es VM stepP g vm p = traverse (evalVal g vm) p >>= \case PrimZeroP x -> case x of @@ -207,10 +226,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 } + -- 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 @@ -239,6 +258,7 @@ jumpToRoutine rt vm = vm getLabel :: Obj -> Maybe Label getLabel = \case ObjHob (HobClosure {label}) -> Just label + ObjHob (HobContinuation {cont}) -> getLabel cont ObjImm (ImmLabel label) -> Just label x -> Nothing @@ -277,6 +297,11 @@ takeExact n xs = case compareLength xs n of (EQ;GT) -> Just $ take n xs LT -> Nothing +parseCallCC :: Frame -> Maybe (Obj, Obj, Frame) +parseCallCC frm = do + ([cc,withcc],ys) <- splitAtExact 2 (frm ^. #locals) + pure (cc,withcc,MkFrame ys) + parseCall :: Int -> Frame -> Maybe (List Obj, Obj, Obj, Frame) parseCall nargs frm = do (xs,ys) <- splitAtExact (nargs+2) (frm ^. #locals) diff --git a/t.scm b/t.scm new file mode 100644 index 0000000..ccd981e --- /dev/null +++ b/t.scm @@ -0,0 +1,5 @@ +((λ () + (* 2 (call/cc + (λ (k) + (begin (k 6) + 3))))))