diff --git a/gyehoek.cabal b/gyehoek.cabal index 4d50143..c0f3264 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -58,14 +58,16 @@ library -- cabal-fmt: expand src exposed-modules: Gyehoek.CPS.Close + Gyehoek.CPS.Contify Gyehoek.CPS.Convert Gyehoek.CPS.Eval + Gyehoek.CPS.Hoist Gyehoek.CPS.Stackify Gyehoek.CPS.Syntax Gyehoek.Driver - Gyehoek.Language Gyehoek.GenSym Gyehoek.Jalmot + Gyehoek.Language Gyehoek.Lift1 Gyehoek.Options Gyehoek.Prelude @@ -100,6 +102,7 @@ library , hashable , invertible-grammar , lens + , lucid , megaparsec , mtl , optparse-applicative @@ -107,6 +110,7 @@ library , pretty-simple , prettyprinter , prettyprinter-ansi-terminal + , prettyprinter-lucid , process , recursion-schemes , scientific @@ -117,8 +121,7 @@ library , typed-process , unordered-containers , vector - , lucid - , prettyprinter-lucid + , tardis hs-source-dirs: src default-language: GHC2024 @@ -171,6 +174,7 @@ test-suite doctest build-depends: , base , gyehoek + default-extensions: CPP main-is: doctest.hs diff --git a/src/Gyehoek/CPS/Close.hs b/src/Gyehoek/CPS/Close.hs index 619a046..d715c2c 100644 --- a/src/Gyehoek/CPS/Close.hs +++ b/src/Gyehoek/CPS/Close.hs @@ -7,32 +7,43 @@ import Gyehoek.CPS.Syntax import Data.List (nub) import Gyehoek.GenSym import Gyehoek.Prelude +import Debug.Pretty.Simple +import Gyehoek.Sexp qualified as S +import Data.HashSet.Lens +import Data.Traversable +genCodeName :: GenSym :> es => Name -> Eff es Name +genCodeName f = gensym' @Name $ f ^. _Wrapped' . to (<> "-code") + +bindEnv :: Name -> List Name -> Exp -> Exp +bindEnv l frees m = [cps| + (letrec ((#{l} (κ #{frees} #{m}))) + (prim (get-env) #{l})) +|] + 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") - -- it would probably be most sane to generate a symbol for `env`, - -- but we're reusing the lambda binding so we don't have to - -- explicitly substitute recursive calls. - let frees = nub $ free' lam - 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 - pure [cps| - (letrec ((#{q_l} (κ (#{x}) #{q}))) - (prim #{p} - #{q_l})) - |]) - m frees - e_l <- gensym' @Name "make-closure-cont" + ExpLetRec bs e -> do + let boundNames = bs ^.. each . _1 + let frees = bs + & foldMapOf + (each . _2 . absBody) + (freeWithBound' $ setOf (each . _1) bs) + & nub + env_cont_l <- gensym' @Name "env-cont" + e_l <- gensym' @Name "letrec-body-cont" + -- let ab' = ab & absBody .~ m' + bs' <- for bs \(f,ab) -> do + f_code_l <- genCodeName f + pure + ( f_code_l + , ab & absBody %~ bindEnv f_code_l (boundNames ++ frees) + ) pure [cps| - (letrec ((#{f_code} (λ (##{bs} #{kb}) - #{m'}))) - (letrec ((#{e_l} (κ (#{f}) #{e}))) - (prim (make-closure #{f_code} ##{frees}) + (letrec #{bs'} + (letrec ((#{e_l} (κ #{boundNames} #{e}))) + (prim (make-shared-closure #{boundNames} #{frees}) #{e_l}))) |] diff --git a/src/Gyehoek/CPS/Contify.hs b/src/Gyehoek/CPS/Contify.hs new file mode 100644 index 0000000..a481e46 --- /dev/null +++ b/src/Gyehoek/CPS/Contify.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE ApplicativeDo #-} +module Gyehoek.CPS.Contify + ( contifyProgram + ) where + +import Control.Monad.Tardis +import Gyehoek.CPS.Syntax +import Gyehoek.Prelude +import qualified Data.HashSet as HS +import Control.Lens.Unsound (adjoin) +import Debug.Pretty.Simple +import qualified Data.HashMap.Strict as H +import Control.Monad.Writer.Lazy +import Control.Monad.Trans.Tardis (liftTardisT) + + +-- | ain't no way... +-- type T = WriterT (HashSet Name) (Tardis (HashSet Name) (HashSet Name)) +type T = TardisT (HashSet Name) (HashSet Name) (Writer (HashSet Name)) + +evalT :: T a -> a +-- evalT = (`evalTardis` (mempty,mempty)) . fmap fst . runWriterT +evalT = fst . runWriter . (`evalTardisT` (mempty,mempty)) + +runT :: T a -> (a, HashSet Name) +-- runT = (`evalTardis` (mempty,mempty)) . runWriterT +runT = runWriter . (`evalTardisT` (mempty,mempty)) + +-- | inline function if it hasn't been used in the past, and won't +-- be used in the future. +tryInline :: Name -> Kappa -> T Kexp +tryInline kname kap = do + modifyBackwards (HS.insert kname) + p <- getsPast (HS.member kname) + modifyForwards (HS.insert kname) + q <- getsFuture (HS.member kname) + let c = p || q + liftTardisT . tell $ if c then HS.singleton kname else mempty + pure $ if c + then KexpVar kname + else KexpKappa kap + +getKap :: HashMap Name Abs -> Name -> Maybe Kappa +getKap g kname = g ^? ix kname . #AbsKappa + +contify :: HashMap Name Abs -> Exp -> T Exp +contify g = transformM \case + ExpApply f xs (KexpVar kname) | Just kap <- getKap g kname + -> ExpApply f xs <$> tryInline kname kap + ExpPrim p (KexpVar kname) | Just kap <- getKap g kname + -> ExpPrim p <$> tryInline kname kap + e -> pure e + +contifyProgram :: HoistedProgram -> Eff es HoistedProgram +contifyProgram p = do + let g = p.bindings + let (p',contifiedVars) = + runT $ + traverseOf + (adjoin + (#bindings . each . body) + (#body . body)) + (contify g) + p + pTraceShowM contifiedVars + -- pure $ p' & #bindings %~ H.filterWithKey \k _ -> HS.member k contifiedVars + pure p' diff --git a/src/Gyehoek/CPS/Hoist.hs b/src/Gyehoek/CPS/Hoist.hs new file mode 100644 index 0000000..0031132 --- /dev/null +++ b/src/Gyehoek/CPS/Hoist.hs @@ -0,0 +1,24 @@ +module Gyehoek.CPS.Hoist + ( hoistProgram + ) where + +import Gyehoek.CPS.Syntax +import Gyehoek.Prelude +import qualified Data.HashMap.Strict as H +import Effectful.Writer.Static.Local +import Data.Foldable + + +type Hoist = Writer (HashMap Name Abs) + +hoist :: Hoist :> es => Exp -> Eff es Exp +hoist = transformM \case + ExpLetRec bs m -> do + traverse_ (\(k,v) -> tell $ H.singleton k v) bs + pure m + e -> pure e + +hoistProgram :: Program -> Eff es HoistedProgram +hoistProgram p = do + (body,bindings) <- runWriter $ traverseOf #body hoist p.body + pure $ MkHoistedProgram {body,bindings} diff --git a/src/Gyehoek/CPS/Stackify.hs b/src/Gyehoek/CPS/Stackify.hs index 8085347..4896873 100644 --- a/src/Gyehoek/CPS/Stackify.hs +++ b/src/Gyehoek/CPS/Stackify.hs @@ -54,28 +54,27 @@ emitRoutine :: Stackify :> es => Stk.Routine -> Eff es () emitRoutine rt = tell [rt] stackify - :: (GenSym :> es, Stackify :> es) + :: forall es. (GenSym :> es, Stackify :> es) => Env -> Exp -> Eff es BlockBuilder -stackify g (ExpLetRec [(f, AbsKappa kap)] e) = do - kap' <- stackifyKappa g kap - emitRoutine . Stk.MkRoutine (MkLabel f) . buildBlock $ kap' - stackify g e - -stackify g (ExpLetRec [(f, AbsLambda lam)] e) = do - lam' <- stackifyLambda g (MkLabel f) lam - emitRoutine lam' +stackify g (ExpLetRec bs e) = do + for_ bs \(f,a) -> + emitRoutine =<< case a of + AbsKappa kap -> stackifyKappa g (MkLabel f) kap + AbsLambda lam -> stackifyLambda g (MkLabel f) lam stackify g e stackify g (ExpIf c t f) = do let c' = stackifyVal g c - t' <- buildBlock <$> stackify g t - f' <- buildBlock <$> stackify g f - pure . Tail $ Stk.If c' t' f' + let jump l = + Stk.MkBlock + [Stk.Push . Stk.ValLabel . MkLabel $ l] + (Stk.TailCall 0) + pure . Tail $ Stk.If c' (jump t) (jump f) stackify g (ExpApply f xs ktail) = do pure $ - Code [ Stk.Push $ stackifyVal g (ValVar ktail) + Code [ Stk.Push $ stackifyVal g (ValVar $ ktail ^?! #KexpVar) , Stk.Push $ stackifyVal g f ] $ Code (pushArgs g xs) $ @@ -91,23 +90,24 @@ stackify g e@(ExpContinue k xs) Tail (Stk.Return (length xs)) stackify g (ExpPrim (PrimCallCC withcc) cc) = do - cc' <- stackifyKappa g cc + let cc' = cc ^?! #KexpVar . to MkLabel 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) + , Stk.Push $ stackifyVal g (ValLabel cc') ] $ Tail Stk.CallCC -stackify g (ExpPrim p (MkKappa rs e)) = do - _ - pure $ Code [ Stk.Prim (stackifyVal g <$> p) ] _ +stackify g (ExpPrim p cc) = pure $ + Code [ Stk.Push (Stk.ValLabel . MkLabel $ cc ^?! #KexpVar) + , Stk.Prim (stackifyVal g <$> p) + ] $ + Tail $ Stk.TailCall 1 stackify _ e = error [i|unimplemented exp: #{e}|] -loadArgs :: Free a => Env -> a -> List Name -> List Stk.Instr -loadArgs g e = imapOf itraversed \n x -> load g e (MkReg x) n +loadArgs :: List Name -> List Stk.Instr +loadArgs = imapOf itraversed \n x -> Stk.Load (MkReg x) n pushArgs :: Env -> List Val -> List Stk.Instr pushArgs g args = [ Stk.Push $ stackifyVal g x | x <- reverse args ] @@ -118,12 +118,20 @@ _ValName = failing #_ValVar (#_ValImm . #_ImmLabel . #_MkLabel) stackifyKappa :: (Stackify :> es, GenSym :> es) - => Env -> Kappa - -> Eff es BlockBuilder -stackifyKappa g (MkKappa xs m) = do + => Env -> Label -> Kappa + -> Eff es Stk.Routine +stackifyKappa g kname (MkKappa xs m) = do let g' = g & #bound <>:~ xs - Code [ _ | x <- g'.bound `intersect` free' m ] - <$> stackify g' m + m' <- stackify g' m + pure $ + Stk.MkRoutine kname . buildBlock $ + Code (loadArgs xs) $ + Code [ Stk.Load (MkReg r) j + | v <- g ^.. #liveness . ix kname . each + , (j,r) <- itoListOf (#bound . itraversed) g + , r == v + ] $ + m' stackifyLambda :: (Stackify :> es, GenSym :> es) @@ -134,7 +142,8 @@ stackifyLambda g name (MkLambda xs k m) = do pure $ Stk.MkRoutine name . buildBlock $ Code (loadArgs xs) $ - Code [Stk.Load (MkReg k) (length xs + 1)] m' + -- Code [Stk.Load (MkReg k) (length xs + 1)] $ + m' stackifyVal :: Env -> Val -> Stk.Val stackifyVal g = \case @@ -171,40 +180,101 @@ emptyEnv = MkEnv -stackifyProgram :: GenSym :> es => Program -> Eff es Stk.Program -stackifyProgram (MkProgram lam) = do - let g = emptyEnv - (_,p) <- runStackify $ emitRoutine =<< stackifyLambda g "start" lam - pure p +stackifyProgram :: GenSym :> es => HoistedProgram -> Eff es Stk.Program +stackifyProgram p = do + let liveness = p & foldMapOf + (#bindings . itraversed . withIndex . aside #AbsKappa) + \(kname,kap) -> H.singleton + (MkLabel kname) + (nub $ freeWithBound' (H.keysSet p.bindings) kap) + let g = MkEnv + { bound = mempty + , liveness + , tail = p.body.ktail } + let e = p.body & #body %~ ExpLetRec (H.toList p.bindings) + (_,p') <- runStackify $ emitRoutine =<< stackifyLambda g "start" e + pure p' -letfn :: Program -letfn = [cps| -(λ (start-ktail0) - (letrec ((lambda-body1 - (λ (x lambda-tail2) - (prim (* x x) (κ (r3) (continue lambda-tail2 r3)))))) - (letrec ((let-body6 - (κ (square) - (letrec ((r4 (κ (x5) (continue start-ktail0 x5)))) - (square 4 r4))))) - (continue let-body6 lambda-body1)))) -|] - -blah :: Program +blah :: HoistedProgram blah = [cps| -(λ (ktail0) - (letrec ((fac (λ (n ktail) - (prim (zero? n) - (κ (x0) - (if x0 - (continue ktail 1) - (prim (- n 1) - (κ (x1) - (letrec ((fac-k0 - (κ (x2) - (prim (* n x2) - (κ (x3) - (continue ktail x3)))))) - (fac x1 fac-k0)))))))))) - (fac 6 halt))) +(letrec ((prim-k3 (κ (r2) (if r2 truthy-cont4 falsey-cont5))) + (prim-k7 (κ (r6) (fac r6 r8))) + (make-closure-cont15 (κ (fac) (fac 20 r12))) + (falsey-cont5 (κ () (prim (- n 1) prim-k7))) + (r12 (κ (x13) (continue start-ktail0 x13))) + (truthy-cont4 (κ () (continue lambda-tail1 1))) + (prim-k11 (κ (r10) (continue lambda-tail1 r10))) + (r8 (κ (x9) (prim (* n x9) prim-k11))) + (fac-code14 (λ (n lambda-tail1) (prim (zero? n) prim-k3)))) + (λ (start-ktail0) + (prim (make-closure $fac-code14) make-closure-cont15))) +|] + +p :: HoistedProgram +p = [cps| +(letrec ((r12-code32 (κ (r12 start-ktail0 x13) (continue start-ktail0 x13))) + (prim-k7-code22 + (κ (prim-k7 fac r6 r8 n x9 prim-k11 lambda-tail1 r10) + (prim + (make-shared-closure (r8) (n x9 prim-k11 lambda-tail1 r10)) + letrec-body-cont18))) + (letrec-body-cont24 + (κ (truthy-cont4 falsey-cont5) + (if r2 + truthy-cont4 + falsey-cont5))) + (letrec-body-cont18 (κ (r8) (fac r6 r8))) + (prim-k11-code16 + (κ (prim-k11 lambda-tail1 r10) + (continue lambda-tail1 r10))) + (falsey-cont5-code26 + (κ (truthy-cont4 falsey-cont5 lambda-tail1 n prim-k7 + fac r6 r8 x9 prim-k11 r10) + (prim + (make-shared-closure + (prim-k7) + (fac r6 r8 n x9 prim-k11 lambda-tail1 r10)) + letrec-body-cont21))) + (letrec-body-cont31 (κ (r12) (fac 20 r12))) + (r8-code19 + (κ (r8 n x9 prim-k11 lambda-tail1 r10) + (prim + (make-shared-closure (prim-k11) (lambda-tail1 r10)) + letrec-body-cont15))) + (letrec-body-cont28 (κ (prim-k3) (prim (zero? n) prim-k3))) + (truthy-cont4-code25 + (κ (truthy-cont4 falsey-cont5 lambda-tail1 n prim-k7 fac + r6 r8 x9 prim-k11 r10) + (continue lambda-tail1 1))) + (fac-code35 + (κ (fac n prim-k3 r2 truthy-cont4 falsey-cont5 lambda-tail1 + prim-k7 r6 r8 x9 prim-k11 r10) + (prim + (make-shared-closure + (prim-k3) + (r2 truthy-cont4 falsey-cont5 lambda-tail1 n prim-k7 + fac r6 r8 x9 prim-k11 r10)) + letrec-body-cont28))) + (prim-k3-code29 + (κ (prim-k3 r2 truthy-cont4 falsey-cont5 lambda-tail1 n prim-k7 + fac r6 r8 x9 prim-k11 r10) + (prim + (make-shared-closure + (truthy-cont4 falsey-cont5) + (lambda-tail1 n prim-k7 fac r6 r8 x9 prim-k11 r10)) + letrec-body-cont24))) + (letrec-body-cont21 (κ (prim-k7) (prim (- n 1) prim-k7))) + (letrec-body-cont15 (κ (prim-k11) (prim (* n x9) prim-k11))) + (letrec-body-cont34 + (κ (fac) + (prim + (make-shared-closure (r12) (start-ktail0 x13)) + letrec-body-cont31)))) + (λ (start-ktail0) + (prim + (make-shared-closure + (fac) + (n prim-k3 r2 truthy-cont4 falsey-cont5 lambda-tail1 + prim-k7 r6 r8 x9 prim-k11 r10)) + letrec-body-cont34))) |] diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index 011814c..409853e 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -15,6 +15,7 @@ module Gyehoek.CPS.Syntax , Name(..) , Prim(..) , Program(..) + , HoistedProgram(..) , Lit(..) , Imm(..) , Obj(..) @@ -40,6 +41,7 @@ module Gyehoek.CPS.Syntax , Free(..) , pattern ValLabel , pattern ObjLabel + , absBody ) where @@ -58,6 +60,8 @@ import qualified Data.InvertibleGrammar.Base as IG import Gyehoek.GenSym (Gen) import Data.String (IsString) import Control.Applicative +import qualified Data.HashMap.Strict as H +import GHC.Records (HasField (..)) -- Data types @@ -135,6 +139,7 @@ data Exp data Kexp = KexpVar Name + -- | Only to be used after contification. | KexpKappa Kappa deriving (Show, Generic, Data, Eq) @@ -152,6 +157,22 @@ data Program = MkProgram } deriving (Show, Generic, Data) +data HoistedProgram = MkHoistedProgram + { bindings :: HashMap Name Abs + , body :: Lambda + } + deriving stock (Show, Generic, Data) + +type instance Index HoistedProgram = Name +type instance IxValue HoistedProgram = Abs + +instance Ixed HoistedProgram where ix j = #bindings . ix j + +instance At HoistedProgram where at j = #bindings . at j + +instance Each HoistedProgram HoistedProgram Abs Abs where + each = #bindings . each + makePrisms ''Kappa makePrisms ''Exp makeFieldsId ''Exp @@ -175,6 +196,16 @@ _AbsLambda' = prism' instance Plated Exp where plate = uniplate + +absBody :: Lens' Abs Exp +absBody = lens + (\case + AbsLambda lam -> lam.body + AbsKappa kap -> kap.body) + (\cases + (AbsLambda lam) b -> AbsLambda $ lam & #body .~ b + (AbsKappa kap) b -> AbsKappa $ kap & #body .~ b) + -- DatumIso instances @@ -307,6 +338,22 @@ instance S.DatumIso Kexp where instance S.DatumIso Program where datumIso = S.with \prog -> S.datumIso @Lambda >>> prog +-- the printed representation is pretty dishonest in its current +-- state. consider the following hoisted program: +-- +-- (letrec ((k (κ () (continue start-ktail 123)))) +-- (λ (start-ktail) +-- (continue k))) +-- +-- here, `start-ktail` is bound in `k`, but the printed representation +-- fails to reflect that. +instance S.DatumIso HoistedProgram where + datumIso = S.with \prog -> + S.letLike "letrec" + (S.datumIso @Name) (S.datumIso @Abs) (S.datumIso @Lambda) + >>> S.onTail (S.iso H.fromList H.toList) + >>> prog + -- quasiquoters @@ -319,6 +366,7 @@ instance CPS Kappa where toCPS = S.fromDatumUnsafe S.datumIso instance CPS Lambda where toCPS = S.fromDatumUnsafe S.datumIso instance CPS Abs where toCPS = S.fromDatumUnsafe S.datumIso instance CPS Program where toCPS = S.fromDatumUnsafe S.datumIso +instance CPS HoistedProgram where toCPS = S.fromDatumUnsafe S.datumIso cps :: S.QuasiQuoter cps = S.makeSx' [| toCPS |] diff --git a/src/Gyehoek/Driver.hs b/src/Gyehoek/Driver.hs index 65497cb..8fd1397 100644 --- a/src/Gyehoek/Driver.hs +++ b/src/Gyehoek/Driver.hs @@ -35,6 +35,8 @@ import Control.Arrow ((>>>)) import Gyehoek.Prelude import Gyehoek.Jalmot import qualified Gyehoek.Sexp as S +import Gyehoek.CPS.Hoist (hoistProgram) +import Gyehoek.CPS.Contify (contifyProgram) main :: IO () @@ -122,9 +124,15 @@ driver opts = do closedCps <- closeProgram cps when opts.dumpClosed do hPutStrLn FS.stdout =<< S.encodeWith S.datumIso closedCps + hoistedCps <- hoistProgram closedCps + when opts.dumpHoisted do + hPutStrLn FS.stdout =<< S.encodeWith S.datumIso hoistedCps + -- contifiedCps <- contifyProgram hoistedCps + -- when opts.dumpContified do + -- hPutStrLn FS.stdout =<< S.encodeWith S.datumIso contifiedCps let rt_is p = is (_Just . p) opts.runtime dumpOrRun opts.dumpStackified (rt_is #Stackify) - (stackifyProgram closedCps) + (stackifyProgram hoistedCps) (hPutStrLn FS.stdout <=< S.encodeDataWith S.dataIso) (eval >=> fmap writeObj >>> T.unwords @@ -140,7 +148,7 @@ driver opts = do -- inspectWasm -- (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat) when opts.traceStackified do - stackifyProgram closedCps >>= traceEval + stackifyProgram hoistedCps >>= traceEval parse_e2e :: FilePath -> IO Scm.Program parse_e2e = runJalmotIO . runFileSystem . readScm diff --git a/src/Gyehoek/Options.hs b/src/Gyehoek/Options.hs index 4ecf008..eb15c2a 100644 --- a/src/Gyehoek/Options.hs +++ b/src/Gyehoek/Options.hs @@ -29,6 +29,8 @@ data Options = MkOptions , dumpCPS :: Bool , dumpParsed :: Bool , dumpStackified :: Bool + , dumpHoisted :: Bool + , dumpContified :: Bool , traceStackified :: Bool , runtime :: Maybe Runtime , inspectWasm :: Bool @@ -61,6 +63,8 @@ parser = do dumpCPS <- switch (long "dump-cps") dumpStackified <- switch (long "dump-stackified") dumpParsed <- switch (long "dump-parsed") + dumpHoisted <- switch (long "dump-hoisted") + dumpContified <- switch (long "dump-contified") traceStackified <- switch (long "trace-stackified") inspectWasm <- switch $ long "inspect-wasm" <> short 'p' runtime <- option runtimeReader . fold $ diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index 2e9ba42..49555b7 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -81,6 +81,8 @@ data Prim e | PrimZeroP e | PrimNewline | PrimMakeClosure { code :: e, env :: List e } + | PrimMakeSharedClosure { codes :: List e, env :: List e } + | PrimGetEnv | PrimEnv | PrimEnvRef Int | PrimCallCC e @@ -168,6 +170,10 @@ primDatumIso namefn a = S.match $ S.With (. ht1 "zero?") $ S.With (. ht0 "newline") $ S.With (. ht1' "make-closure") + $ S.With (. S.headTagged2 (namefn "make-shared-closure") + (S.list $ S.rest a) + (S.list $ S.rest a)) + $ S.With (. ht0 "get-env") $ S.With (. ht0 "env") $ S.With (. S.headTagged1 (namefn "env-ref") S.int) $ S.With (. ht1 "call/cc") diff --git a/stack.rnote b/stack.rnote new file mode 100644 index 0000000..7efa3ee Binary files /dev/null and b/stack.rnote differ