From 1f401207405d06fe1f7c27de0dcba507b9d47fba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Wed, 26 Aug 2026 05:29:40 -0600 Subject: [PATCH] dotted list and such --- golden/exec/begin-1/exec | 2 + golden/exec/callcc-early-exit-6/exec | 2 + golden/exec/callcc-early-exit-6/source.scm | 4 ++ golden/exec/complicated-1/exec | 2 + golden/exec/complicated-1/source.scm | 10 ++++ golden/exec/cons-1/exec | 2 + golden/exec/cons-1/source.scm | 1 + src/Gyehoek/CPS/Stackify.hs | 58 +++++++++++++++------- src/Gyehoek/CPS/Syntax.hs | 5 +- src/Gyehoek/Scheme/Syntax.hs | 1 - src/Gyehoek/Sexp/Grammar/Base.hs | 26 +++++++++- src/Gyehoek/Sexp/Print.hs | 9 +++- src/Gyehoek/Stack/VM.hs | 15 +++--- 13 files changed, 108 insertions(+), 29 deletions(-) create mode 100644 golden/exec/begin-1/exec create mode 100644 golden/exec/callcc-early-exit-6/exec create mode 100644 golden/exec/callcc-early-exit-6/source.scm create mode 100644 golden/exec/complicated-1/exec create mode 100644 golden/exec/complicated-1/source.scm create mode 100644 golden/exec/cons-1/exec create mode 100644 golden/exec/cons-1/source.scm diff --git a/golden/exec/begin-1/exec b/golden/exec/begin-1/exec new file mode 100644 index 0000000..6901ce2 --- /dev/null +++ b/golden/exec/begin-1/exec @@ -0,0 +1,2 @@ +ret > ExitSuccess +out > 456 diff --git a/golden/exec/callcc-early-exit-6/exec b/golden/exec/callcc-early-exit-6/exec new file mode 100644 index 0000000..903c723 --- /dev/null +++ b/golden/exec/callcc-early-exit-6/exec @@ -0,0 +1,2 @@ +ret > ExitSuccess +out > 12 \ No newline at end of file diff --git a/golden/exec/callcc-early-exit-6/source.scm b/golden/exec/callcc-early-exit-6/source.scm new file mode 100644 index 0000000..5c79fd9 --- /dev/null +++ b/golden/exec/callcc-early-exit-6/source.scm @@ -0,0 +1,4 @@ +(* 2 (call/cc + (λ (k) + (begin (k 6) + 3)))) diff --git a/golden/exec/complicated-1/exec b/golden/exec/complicated-1/exec new file mode 100644 index 0000000..421060e --- /dev/null +++ b/golden/exec/complicated-1/exec @@ -0,0 +1,2 @@ +ret > ExitSuccess +out > 155 diff --git a/golden/exec/complicated-1/source.scm b/golden/exec/complicated-1/source.scm new file mode 100644 index 0000000..26b7410 --- /dev/null +++ b/golden/exec/complicated-1/source.scm @@ -0,0 +1,10 @@ +(letrec ((factorial (λ (n) + (if (zero? n) + 1 + (* n (factorial (- n 1))))))) + (letrec ((sum-of-factorials + (λ (n) + (if (zero? n) + 0 + (+ (factorial n) (sum-of-factorials (- n 1))))))) + (+ 2 (sum-of-factorials 5)))) diff --git a/golden/exec/cons-1/exec b/golden/exec/cons-1/exec new file mode 100644 index 0000000..3083118 --- /dev/null +++ b/golden/exec/cons-1/exec @@ -0,0 +1,2 @@ +ret > ExitSuccess +out > (6 . 7) diff --git a/golden/exec/cons-1/source.scm b/golden/exec/cons-1/source.scm new file mode 100644 index 0000000..249c6c0 --- /dev/null +++ b/golden/exec/cons-1/source.scm @@ -0,0 +1 @@ +(cons 6 7) diff --git a/src/Gyehoek/CPS/Stackify.hs b/src/Gyehoek/CPS/Stackify.hs index 2b7345d..ac3abcf 100644 --- a/src/Gyehoek/CPS/Stackify.hs +++ b/src/Gyehoek/CPS/Stackify.hs @@ -47,21 +47,15 @@ stackify :: (GenSym :> es, Stackify :> es) => Env -> Exp -> Eff es BlockBuilder -stackify g (ExpLetRec [(f, kap@(AbsKappa' xs m))] e) = do - let vs = (f, Stk.ValLabel f) : (bindReg <$> xs) - let ls = live g kap - m' <- stackify (g & #bound <>~ H.fromList (vs ++ (bindReg <$> ls))) m - emitRoutine $ - Stk.MkRoutine f xs . buildBlock $ - -- pop in the opposite order we push - Code [Stk.Pop x | x <- reverse ls] m' - let g' = g & #bound . at f ?~ Stk.ValLabel f - & #liveness . at f ?~ ls - stackify g' e +stackify g (ExpLetRec [(f, AbsKappa kap)] e) = do + stackifyKappa g f kap \g' kap' -> do + emitRoutine kap' + stackify g' e stackify g (ExpLetRec [(f, AbsLambda lam)] e) = do - emitRoutine =<< stackifyLambda g f lam - stackify (g & #bound . at f ?~ Stk.ValLabel f) e + stackifyLambda g f lam \g' lam' -> do + emitRoutine lam' + stackify g' e stackify g (ExpIf c t f) = do let c' = stackifyVal g c @@ -86,6 +80,15 @@ stackify g e@(ExpContinue k xs) = do ls = fold $ (k' ^? #ValImm . #ImmLabel) >>= \klbl -> g ^. #liveness . at klbl +-- stackify g (ExpPrim (PrimCallCC withcc) cc) = do +-- cc_l <- gensym' "cc" +-- rcc_l <- gensym' "reified-cc" +-- stackifyKappa g cc_l cc \g' rt -> do +-- emitRoutine rt +-- pure $ +-- Code [ Stk.Prim rcc_l $ PrimReifyCC (Stk.ValLabel cc_l) ] $ +-- Tail (Stk.TailCall (stackifyVal g' withcc) [Stk.ValLabel rcc_l]) + stackify g (ExpPrim p (MkKappa [x] e)) = do e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e pure $ @@ -97,13 +100,32 @@ stackify _ e = error [i|unimplemented exp: #{e}|] _ValName :: Traversal' Val Name _ValName = failing #ValVar (#ValImm . #ImmLabel) +stackifyKappa + :: (Stackify :> es, GenSym :> es) + => Env -> Name -> Kappa + -> (Env -> Stk.Routine -> Eff es r) + -> Eff es r +stackifyKappa g name kap@(MkKappa xs m) w = do + let vs = (name, Stk.ValLabel name) : (bindReg <$> xs) + let ls = live g kap + m' <- stackify (g & #bound <>~ H.fromList (vs ++ (bindReg <$> ls))) m + let g' = g & #bound . at name ?~ Stk.ValLabel name + & #liveness . at name ?~ live g kap + let rt = Stk.MkRoutine name xs . buildBlock $ + -- pop in the opposite order we push + Code [Stk.Pop x | x <- reverse ls] m' + w g' rt + stackifyLambda :: (Stackify :> es, GenSym :> es) - => Env -> Name -> Lambda -> Eff es Stk.Routine -stackifyLambda g name (MkLambda xs k m) = do + => Env -> Name -> Lambda + -> (Env -> Stk.Routine -> Eff es r) + -> Eff es r +stackifyLambda g name (MkLambda xs k m) w = do let vs = [ (x, Stk.ValReg x) | x <- k:xs ] m' <- stackify (g & #bound <>~ H.fromList vs) m - pure $ Stk.MkRoutine name (k:xs) (buildBlock m') + let g' = g & #bound . at name ?~ Stk.ValLabel name + w g' $ Stk.MkRoutine name (k:xs) (buildBlock m') stackifyVal :: Env -> Val -> Stk.Val stackifyVal g = \case @@ -138,8 +160,8 @@ emptyEnv = MkEnv mempty mempty stackifyProgram :: GenSym :> es => Program -> Eff es Stk.Program stackifyProgram (MkProgram lam) = do let g = emptyEnv - (start,p) <- runStackify $ stackifyLambda g "start" lam - pure $ p <> [ start ] + (_,p) <- runStackify $ stackifyLambda g "start" lam (const emitRoutine) + pure p letfn :: Program letfn = [cps| diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index 8709932..955ae80 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -80,6 +80,7 @@ data Obj -- | a heap object. data Hob = HobClosure { label :: Name, env :: List Obj } + | HobPair Obj Obj deriving stock (Show, Generic, Data, Eq) deriving anyclass (NFData) @@ -183,12 +184,14 @@ labelName = S.coproduct instance S.DatumIso Hob where datumIso = S.match $ S.With (. closure) + $ S.With (. conspair) $ S.End where + conspair = S.dottedList (S.el S.datumIso) S.datumIso -- closures can be printed, but not parsed. closure :: G (Datum :- t) (List Obj :- Name :- t) closure = IG.Flip $ IG.PartialIso - (\(env:-code:-t) -> [S.sx|( #{code} ##{env})|] :- t) + (\(env:-code:-t) -> S.Unreadable "#" :- t) (const . Left $ mempty) instance S.DatumIso Lambda where diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index 1e51e8c..90f4d37 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -181,7 +181,6 @@ primDatumIso namefn a = S.match ht0' s = S.headTagged0' (namefn s) a instance DatumIso a => DatumIso (Prim a) where - -- datumIso = primDatumIso ("prim:"<>) datumIso datumIso = primDatumIso id S.datumIso instance DatumIso Lit where diff --git a/src/Gyehoek/Sexp/Grammar/Base.hs b/src/Gyehoek/Sexp/Grammar/Base.hs index f5abf6a..9e788e3 100644 --- a/src/Gyehoek/Sexp/Grammar/Base.hs +++ b/src/Gyehoek/Sexp/Grammar/Base.hs @@ -41,7 +41,7 @@ module Gyehoek.Sexp.Grammar.Base , lambdaLike , lambdaKeyword , kappaKeyword - , beginLike, headTagged2' + , beginLike, headTagged2', dottedList ) where import Data.InvertibleGrammar @@ -56,6 +56,7 @@ import Data.Scientific (Scientific) import qualified Data.Scientific as Sci import qualified Data.Text as T import Control.Monad.RWS (modify) +import qualified Data.List.NonEmpty as NE -- $setup @@ -105,6 +106,29 @@ list -> G (Datum :- t) t' list = listWithIndentation Ordinary +-- | +-- >>> decodeTest @(Int,Int) (with \g -> dottedList (el int) int >>> g) "(1 . 2)" +dottedList + :: forall t t' t''. G (ListContext :- t) (ListContext :- t') + -> G (Datum :- t') t'' + -> G (Datum :- t) t'' +dottedList g final = begin >>> Dive (onTail (g >>> end) >>> final) + where + begin = locate >>> Flip (PartialIso + (\(x:-MkListContext xs:-t) -> case NE.nonEmpty xs of + Just xs' -> DotList xs' x :- t + Nothing -> error "fuck") + (\case + DotList xs x :- t -> Right $ x :- MkListContext (NE.toList xs) :- t + _ -> Left $ expected "dotted list")) + end :: Grammar Ann (ListContext :- t') t' + end = Flip $ PartialIso + (\t -> MkListContext [] :- t) + (\(MkListContext lst :- t) -> + case lst of + [] -> Right t + d:_ -> Left $ unexpectedDatum d) + listWithIndentation :: Indentation -> G (ListContext :- t) (ListContext :- t') diff --git a/src/Gyehoek/Sexp/Print.hs b/src/Gyehoek/Sexp/Print.hs index 1baeaf8..b78e337 100644 --- a/src/Gyehoek/Sexp/Print.hs +++ b/src/Gyehoek/Sexp/Print.hs @@ -14,7 +14,7 @@ import Data.Functor.Foldable import qualified Control.Comonad.Trans.Cofree as F import Prettyprinter.Util import Gyehoek.Prelude hiding (Simple, (:<)) -import Data.Foldable (traverse_) +import Data.Foldable (traverse_, toList) import qualified Prettyprinter.Render.Terminal as ANSI import System.IO (stdout) import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle, bold, colorDull) @@ -84,6 +84,13 @@ printDatumW w = prettyDatum :: Int -> Datum -> Doc Syn prettyDatum depth datum = case datum of Simple simp -> annotate (datum ^. syntax) $ prettySimple depth simp + DotList xs x -> + pparen depth . group . align $ + vsep [ vsep (prettyDatum (depth+1) <$> toList xs) + , "." + , prettyDatum (depth+1) x + ] + List' indent xs -> case indent of NSpecial n | keyword:args <- xs -> diff --git a/src/Gyehoek/Stack/VM.hs b/src/Gyehoek/Stack/VM.hs index 37f30b9..c819a6d 100644 --- a/src/Gyehoek/Stack/VM.hs +++ b/src/Gyehoek/Stack/VM.hs @@ -77,6 +77,13 @@ stepI e vm (Prim r p) = case evalVal e vm <$> p of case env of ObjHob (HobClosure _ xs) -> ret $ xs ^?! ix n _ -> error [i|expected closure, got #{env}|] + PrimCons x y -> ret $ ObjHob $ HobPair x y + PrimCar x -> case x of + ObjHob (HobPair car _) -> ret car + _ -> error [i|expected pair, got ${x}|] + PrimCdr x -> case x of + ObjHob (HobPair _ cdr) -> ret cdr + _ -> error [i|expected pair, got ${x}|] x -> error [i|unimplemented prim: #{p}|] where ret v = vm & #registers . at r ?~ v @@ -160,13 +167,7 @@ trace p = initialVM & NE.unfoldr \vm -> where e = initialEnv p writeObj :: Obj -> Text -writeObj (ObjImm im) = case im of - ImmInt n -> [i|#{n}|] - ImmBool True -> "#t" - ImmBool False -> "#f" - ImmLabel l -> "#" -writeObj (ObjHob h) = case h of - HobClosure code env -> "#" +writeObj = runJalmotUnsafe . S.encodeWith' S.datumIso traceEval :: IOE :> es => Program -> Eff es (List Obj) traceEval p = do