hoist

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
+    , tardis
-    , prettyprinter-lucid
 
   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
 

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
+  ExpLetRec bs e -> do
-    f_code <- gensym' @Name $ f ^. _Wrapped' . to (<> "-code")
+    let boundNames = bs ^.. each . _1
-    -- it would probably be most sane to generate a symbol for `env`,
+    let frees = bs
-    -- but we're reusing the lambda binding so we don't have to
+          & foldMapOf
-    -- explicitly substitute recursive calls.
+            (each . _2 . absBody)
-    let frees = nub $ free' lam
+            (freeWithBound' $ setOf (each . _1) bs)
-    m' <- ifoldrM @_ @_ @(Eff es)
+          & nub
-             (\n x q -> do
+    env_cont_l <- gensym' @Name "env-cont"
-               q_l <- gensym' @Name "env-cont"
+    e_l <- gensym' @Name "letrec-body-cont"
-               let p = if x == f then PrimEnv @Val else PrimEnvRef n
+    -- let ab' = ab & absBody .~ m'
-               pure [cps|
+    bs' <- for bs \(f,ab) -> do
-                 (letrec ((#{q_l} (κ (#{x}) #{q})))
+      f_code_l <- genCodeName f
-                   (prim #{p}
+      pure
-                     #{q_l}))
+        ( f_code_l
-               |])
+        , ab & absBody %~ bindEnv f_code_l (boundNames ++ frees)
-             m frees
+        )
-    e_l <- gensym' @Name "make-closure-cont"
     pure [cps|
-      (letrec ((#{f_code} (λ (##{bs} #{kb})
+      (letrec #{bs'}
-                            #{m'})))
+        (letrec ((#{e_l} (κ #{boundNames} #{e})))
-        (letrec ((#{e_l} (κ (#{f}) #{e})))
+          (prim (make-shared-closure #{boundNames} #{frees})
-          (prim (make-closure #{f_code} ##{frees})
             #{e_l})))
     |]
 

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'

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}

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
+stackify g (ExpLetRec bs e) = do
-  kap' <- stackifyKappa g kap
+  for_ bs \(f,a) ->
-  emitRoutine . Stk.MkRoutine (MkLabel f) . buildBlock $ kap'
+    emitRoutine =<< case a of
-  stackify g e
+      AbsKappa kap -> stackifyKappa g (MkLabel f) kap
-
+      AbsLambda lam -> stackifyLambda g (MkLabel f) lam
-stackify g (ExpLetRec [(f, AbsLambda lam)] e) = do
-  lam' <- stackifyLambda g (MkLabel f) lam
-  emitRoutine lam'
   stackify g e
 
 stackify g (ExpIf c t f) = do
   let c' = stackifyVal g c
-  t' <- buildBlock <$> stackify g t
+  let jump l =
-  f' <- buildBlock <$> stackify g f
+       Stk.MkBlock
-  pure . Tail $ Stk.If c' t' f'
+         [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
+stackify g (ExpPrim p cc) = pure $
-  _
+  Code [ Stk.Push (Stk.ValLabel . MkLabel $ cc ^?! #KexpVar)
-  pure $ Code [ Stk.Prim (stackifyVal g <$> p) ] _
+       , 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 :: List Name -> List Stk.Instr
-loadArgs g e = imapOf itraversed \n x -> load g e (MkReg x) n
+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
+  => Env -> Label -> Kappa
-  -> Eff es BlockBuilder
+  -> Eff es Stk.Routine
-stackifyKappa g (MkKappa xs m) = do
+stackifyKappa g kname (MkKappa xs m) = do
   let g' = g & #bound <>:~ xs
-  Code [ _ | x <- g'.bound `intersect` free' m ]
+  m' <- stackify g' 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 :: GenSym :> es => HoistedProgram -> Eff es Stk.Program
-stackifyProgram (MkProgram lam) = do
+stackifyProgram p = do
-  let g = emptyEnv
+  let liveness = p & foldMapOf
-  (_,p) <- runStackify $ emitRoutine =<< stackifyLambda g "start" lam
+        (#bindings . itraversed . withIndex . aside #AbsKappa)
-  pure p
+        \(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
+blah :: HoistedProgram
-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 = [cps|
-(λ (ktail0)
+(letrec ((prim-k3 (κ (r2) (if r2 truthy-cont4 falsey-cont5)))
-          (letrec ((fac (λ (n ktail)
+         (prim-k7 (κ (r6) (fac r6 r8)))
-                             (prim (zero? n)
+         (make-closure-cont15 (κ (fac) (fac 20 r12)))
-                               (κ (x0)
+         (falsey-cont5 (κ () (prim (- n 1) prim-k7)))
-                                 (if x0
+         (r12 (κ (x13) (continue start-ktail0 x13)))
-                                   (continue ktail 1)
+         (truthy-cont4 (κ () (continue lambda-tail1 1)))
-                                   (prim (- n 1)
+         (prim-k11 (κ (r10) (continue lambda-tail1 r10)))
-                                     (κ (x1)
+         (r8 (κ (x9) (prim (* n x9) prim-k11)))
-                                       (letrec ((fac-k0
+         (fac-code14 (λ (n lambda-tail1) (prim (zero? n) prim-k3))))
-                                                  (κ (x2)
+  (λ (start-ktail0)
-                                                    (prim (* n x2)
+    (prim (make-closure $fac-code14) make-closure-cont15)))
-                                                      (κ (x3)
+|]
-                                                        (continue ktail x3))))))
+
-                                         (fac x1 fac-k0))))))))))
+p :: HoistedProgram
-               (fac 6 halt)))
+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)))
 |]

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 |]

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

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 $

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")