From 75e6c963c773b127986dff054adb16fb6a9e1ef6 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/Close.hs | 22 +++++++++++--------- src/Gyehoek/CPS/Convert.hs | 40 ++++++++++++++++--------------------- src/Gyehoek/CPS/Stackify.hs | 39 ++++++++++++++++++++++-------------- src/Gyehoek/CPS/Syntax.hs | 33 +++++++++++++++++++----------- src/Gyehoek/Stack/Syntax.hs | 2 ++ src/Gyehoek/Stack/VM.hs | 37 ++++++++++++++++++++++++++++------ t.scm | 5 +++++ 7 files changed, 113 insertions(+), 65 deletions(-) create mode 100644 t.scm diff --git a/src/Gyehoek/CPS/Close.hs b/src/Gyehoek/CPS/Close.hs index ebbeb75..619a046 100644 --- a/src/Gyehoek/CPS/Close.hs +++ b/src/Gyehoek/CPS/Close.hs @@ -9,7 +9,7 @@ import Gyehoek.GenSym import Gyehoek.Prelude -close :: GenSym :> es => Exp -> Eff es Exp +close :: forall es. GenSym :> es => Exp -> Eff es Exp close = transformM \case ExpLetRec [(f, AbsLambda lam@(MkLambda bs kb m))] e -> do f_code <- gensym' @Name $ f ^. _Wrapped' . to (<> "-code") @@ -17,19 +17,23 @@ close = transformM \case -- but we're reusing the lambda binding so we don't have to -- explicitly substitute recursive calls. let frees = nub $ free' lam - let m' = ifoldr - (\n x q -> + m' <- ifoldrM @_ @_ @(Eff es) + (\n x q -> do + q_l <- gensym' @Name "env-cont" let p = if x == f then PrimEnv @Val else PrimEnvRef n - in [cps| - (prim #{p} - (κ (#{x}) #{q})) - |]) + pure [cps| + (letrec ((#{q_l} (κ (#{x}) #{q}))) + (prim #{p} + #{q_l})) + |]) m frees + e_l <- gensym' @Name "make-closure-cont" pure [cps| (letrec ((#{f_code} (λ (##{bs} #{kb}) #{m'}))) - (prim (make-closure #{f_code} ##{frees}) - (κ (#{f}) #{e}))) + (letrec ((#{e_l} (κ (#{f}) #{e}))) + (prim (make-closure #{f_code} ##{frees}) + #{e_l}))) |] e -> pure e diff --git a/src/Gyehoek/CPS/Convert.hs b/src/Gyehoek/CPS/Convert.hs index eb29bfa..876ee9e 100644 --- a/src/Gyehoek/CPS/Convert.hs +++ b/src/Gyehoek/CPS/Convert.hs @@ -46,29 +46,15 @@ convert (Scm.ExpLit l) k = k . one . ValImm $ case l of LitBool b -> ImmBool b _ -> _ --- special case: call/cc is desugared during cps-conversion... --- 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" --- m <- k [ValVar r1_l] --- pure [cps| --- (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 --- handle.. convert (Scm.ExpPrim p) k = telescope (convert1 @es) p \p' -> do - r <- gensym' "r" - ExpPrim p' . MkKappa [r] <$> k [ValVar r] + r_l <- gensym' "r" + k_l <- gensym' @Name "prim-k" + m <- k [ValVar r_l] + pure [cps| + (letrec ((#{k_l} (κ (#{r_l}) #{m}))) + (prim #{p'} #{k_l})) + |] convert (Scm.ExpLambda xs e) k = do f <- gensym' "lambda-body" @@ -90,8 +76,16 @@ convert (Scm.ExpApply f xs) k = convert (Scm.ExpBegin xs) k = telescope (convert @es) xs (k . NE.last) convert (Scm.ExpIf c t f) k = - convert1 c \c' -> - ExpIf c' <$> convert t k <*> convert f k + convert1 c \c' -> do + t_l <- gensym' @Name "truthy-cont" + f_l <- gensym' @Name "falsey-cont" + t' <- convert t k + f' <- convert f k + pure [cps| + (letrec ((#{t_l} (κ () #{t'})) + (#{f_l} (κ () #{f'}))) + (if #{c'} #{t_l} #{f_l})) + |] -- let-bindings are desugared into continuation calls whose parameters -- are the left-hand sides and whose arguments are the right-hand diff --git a/src/Gyehoek/CPS/Stackify.hs b/src/Gyehoek/CPS/Stackify.hs index e9decad..8085347 100644 --- a/src/Gyehoek/CPS/Stackify.hs +++ b/src/Gyehoek/CPS/Stackify.hs @@ -12,7 +12,7 @@ import Gyehoek.GenSym import Effectful.Writer.Static.Shared import Data.Foldable import qualified Data.HashMap.Strict as H -import Data.List (elemIndex, nub) +import Data.List (elemIndex, nub, intersect) import Data.Text qualified as T import Gyehoek.Prelude import Debug.Pretty.Simple @@ -30,6 +30,16 @@ live g e = nub (free' e) & filter \x -> x `elem` g.bound -- && not (x `elem` g.contStack) +-- | The expression @load g e r n@ emits a 'Stk.Load' instruction if +-- stack variable @n@ is live-out in expression @e@. Otherwise, a +-- 'Stk.Pop' instruction is emitted. +load :: Free a => Env -> a -> Reg -> Int -> Stk.Instr +load g e r 0 + | Just x <- g ^? #bound . _head + , x `elem` free e + = Stk.Pop r +load g e r n = Stk.Load r n + data BlockBuilder = Code (List Stk.Instr) BlockBuilder | Tail Stk.Tail @@ -71,7 +81,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,22 +92,22 @@ 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 - pure $ Code [ Stk.Prim (stackifyVal g <$> p) ] kap' +stackify g (ExpPrim p (MkKappa rs e)) = do + _ + pure $ Code [ Stk.Prim (stackifyVal g <$> p) ] _ stackify _ e = error [i|unimplemented exp: #{e}|] -loadArgs :: List Name -> List Stk.Instr -loadArgs = imapOf itraversed \n x -> Stk.Load (MkReg x) n +loadArgs :: Free a => Env -> a -> List Name -> List Stk.Instr +loadArgs g e = imapOf itraversed \n x -> load g e (MkReg x) n pushArgs :: Env -> List Val -> List Stk.Instr pushArgs g args = [ Stk.Push $ stackifyVal g x | x <- reverse args ] @@ -113,7 +122,7 @@ stackifyKappa -> Eff es BlockBuilder stackifyKappa g (MkKappa xs m) = do let g' = g & #bound <>:~ xs - Code (loadArgs g'.bound) + Code [ _ | x <- g'.bound `intersect` free' m ] <$> stackify g' m stackifyLambda diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index e859d5d..1ca0f25 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -56,6 +56,7 @@ import Gyehoek.Sexp (G, (:-)(..)) import qualified Data.InvertibleGrammar.Base as IG import Gyehoek.GenSym (Gen) import Data.String (IsString) +import Control.Applicative -- Data types @@ -97,7 +98,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) @@ -113,17 +114,17 @@ data Abs | AbsLambda Lambda deriving (Show, Generic, Data, Eq) -pattern AbsKappa' :: [Name] -> Exp -> Abs +pattern AbsKappa' :: List Name -> Exp -> Abs pattern AbsKappa' xs e = AbsKappa (MkKappa xs e) -pattern AbsLambda' :: [Name] -> Name -> Exp -> Abs +pattern AbsLambda' :: List Name -> Name -> Exp -> Abs pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail) data Exp - = ExpPrim (Prim Val) Kappa + = ExpPrim (Prim Val) Name | ExpLetRec { binders :: List (Name, Abs), body :: Exp } | ExpContinue Val (List Val) - | ExpIf Val Exp Exp + | ExpIf Val Name Name | ExpApply { op :: Val , args :: List Val @@ -220,9 +221,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 @@ -327,7 +330,8 @@ class Free a where freeWithBound :: HashSet Name -> a -> HashSet Name freeWithBound bound = HS.fromList . freeWithBound' bound - -- | Free variables given in the order of their appearance. + -- | Free variables given in the same left-to-right order they + -- appear. free' :: a -> List Name free' = freeWithBound' mempty @@ -337,11 +341,16 @@ instance Free Abs where freeWithBound' bound (AbsKappa kap) = freeWithBound' bound kap freeWithBound' bound (AbsLambda lam) = freeWithBound' bound lam +mif :: Alternative f => (a -> Bool) -> a -> f a +mif p a + | p a = pure a + | otherwise = empty + instance Free Exp where freeWithBound' bound = \case ExpPrim p k -> - p & toListOf (folded . #ValVar . filtered (`notElem` bound)) - & (<> freeWithBound' bound k) + (p ^.. folded . #ValVar . filtered (`notElem` bound)) + ++ mif (`notElem` bound) k ExpLetRec bs m -> foldMapOf (each . _2) (freeWithBound' bound') bs <> freeWithBound' bound' m @@ -349,10 +358,10 @@ instance Free Exp where ExpContinue k xs -> filter (`notElem` bound) ((k:xs) ^.. each . #ValVar) ExpIf c t f -> (c ^.. #ValVar . filtered (`notElem` bound)) - <> freeWithBound' bound t <> freeWithBound' bound f + <> mif (`notElem` bound) t <> mif (`notElem` bound) f ExpApply f xs k -> (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound)) - <> (k ^.. filtered (`notElem` bound)) + <> mif (`notElem` bound) k instance Free Kappa where freeWithBound' bound (MkKappa xs m) = 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))))))