2026-09-03 08:21:50 -06:00
parent dfb44f06ba
commit faae86801b
4 changed files with 100 additions and 238 deletions
@@ -54,39 +54,3 @@ close = transformM close1

 closeProgram :: GenSym :> es => Program -> Eff es Program
 closeProgram = traverseOf (#body . #body) close
-
-prog :: Program
-prog = [cps|
-(λ (start-ktail0)
-  (letrec ((fac
-            (λ (n lambda-tail1)
-              (letrec ((prim-k3
-                        (κ (r2)
-                          (letrec ((truthy-cont4
-                                    (κ ()
-                                      (continue lambda-tail1 1)))
-                                   (falsey-cont5
-                                    (κ ()
-                                      (letrec ((prim-k7
-                                                (κ (r6)
-                                                  (letrec
-                                                      ((r8
-                                                        (κ (x9)
-                                                          (letrec
-                                                              ((prim-k11
-                                                                (κ (r10)
-                                                                  (continue
-                                                                   lambda-tail1
-                                                                   r10))))
-                                                            (prim
-                                                             (* n x9)
-                                                             prim-k11)))))
-                                                    (fac r6 r8)))))
-                                        (prim (- n 1) prim-k7)))))
-                            (if r2
-                              truthy-cont4
-                              falsey-cont5)))))
-                (prim (zero? n) prim-k3)))))
-    (letrec ((r12 (κ (x13) (continue start-ktail0 x13))))
-      (fac 20 r12))))
-|]
@@ -9,12 +9,12 @@ import Effectful.Writer.Static.Local
 import Data.Foldable


-type Hoist = Writer (HashMap Name Abs)
+type Hoist = Writer (HashMap Label Abs)

 hoist :: Hoist :> es => Exp -> Eff es Exp
 hoist = transformM \case
  ExpLetRec bs m -> do
-    traverse_ (\(k,v) -> tell $ H.singleton k v) bs
+    traverse_ (\(k,v) -> tell $ H.singleton (MkLabel k) v) bs
    pure m
  e -> pure e

@@ -19,27 +19,6 @@ import Debug.Pretty.Simple
 import qualified Gyehoek.Sexp as S


-type Stackify = Writer Stk.Program
-
-runStackify :: Eff (Stackify : es) a -> Eff es (a, Stk.Program)
-runStackify = runWriter
-
-live :: Free a => Env -> a -> List Name
-- TODO: free' should return an OSet lol
-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
@@ -50,100 +29,22 @@ buildBlock = go [] where
  go acc (Code xs bb) = go (acc ++ xs) bb
  go acc (Tail t) = Stk.MkBlock acc t

-emitRoutine :: Stackify :> es => Stk.Routine -> Eff es ()
-emitRoutine rt = tell [rt]
-
 stackify
-  :: forall es. (GenSym :> es, Stackify :> es)
+  :: forall es. (GenSym :> es)
  => Env -> Exp -> Eff es BlockBuilder

-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
-  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 ^?! #KexpVar)
-         , Stk.Push $ stackifyVal g f
-         ] $
-    Code (pushArgs g xs) $
-    Tail (Stk.Call (length xs))
-
-stackify g e@(ExpContinue k xs)
-  | isn't (#_ValVar . only g.tail) k = pure $
-    Code [ Stk.Push (stackifyVal g k) ] $
-    Code (pushArgs g xs) $
-    Tail $ Stk.TailCall (length xs)
-  | otherwise = pure $
-    Code (pushArgs g xs) $
-    Tail (Stk.Return (length xs))
-
-stackify g (ExpPrim (PrimCallCC withcc) cc) = do
-  let cc' = cc ^?! #KexpVar . to MkLabel
-  cc_l <- gensym' @Label "cc"
-  pure $
-    Code [ Stk.Push $ stackifyVal g withcc
-         , Stk.Push $ stackifyVal g (ValLabel cc')
-         ] $
-    Tail Stk.CallCC
-
-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 :: 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 ]
-
 -- affine
 _ValName :: Traversal' Val Name
 _ValName = failing #_ValVar (#_ValImm . #_ImmLabel . #_MkLabel)

-stackifyKappa
-  :: (Stackify :> es, GenSym :> es)
-  => Env -> Label -> Kappa
+stackifyAbs
+  :: (GenSym :> es)
+  => Env -> Abs
  -> Eff es Stk.Routine
-stackifyKappa g kname (MkKappa xs m) = do
-  let g' = g & #bound <>:~ xs
-  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)
-  => Env -> Label -> Lambda
-  -> Eff es Stk.Routine
-stackifyLambda g name (MkLambda xs k m) = do
-  m' <- stackify (g & #bound .~ xs & #tail .~ k) m
-  pure $
-    Stk.MkRoutine name . buildBlock $
-    Code (loadArgs xs) $
-    -- Code [Stk.Load (MkReg k) (length xs + 1)] $
-    m'
+stackifyAbs g (MkAbs xs _ _) = _

 stackifyVal :: Env -> Val -> Stk.Val
 stackifyVal g = \case
@@ -161,120 +62,99 @@ regOf g x


 data Env = MkEnv
-  -- | `bound` tracks the stack lifetime of bound variables.
-  { bound :: List Name
-  -- | for each locally-bound continuation @k@, @liveness@ has an
-  -- entry @(k,ls)@ where @ls@ is the sequence of registers @k@
-  -- expects to find saved on the stack.
-  , liveness :: HashMap Label (List Name)
-  , tail :: Name
+  {
  }
  deriving (Show, Generic)

 emptyEnv :: Env
 emptyEnv = MkEnv
-  { bound = mempty
-  , liveness = mempty
-  , tail = "halt"
+  {
  }



 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)
+  let liveness = _
+  let g = emptyEnv
  (_,p') <- runStackify $ emitRoutine =<< stackifyLambda g "start" e
  pure p'

-blah :: HoistedProgram
-blah = [cps|
-(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)
+(letrec (($r12-code32
+          (κ (x13)
            (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)
+             (get-env)
+             (κ (r12 start-ktail0)
+               (continue start-ktail0 x13)))))
+         ($prim-k7-code22
+          (κ (r6)
            (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)
+             (get-env)
+             (κ (prim-k7 lambda-tail1 n fac)
+               (prim
+                (make-shared-closure ($r8-code19) (lambda-tail1 n))
+                (κ (r8)
+                  (fac r6 r8)))))))
+         ($prim-k11-code16
+          (κ (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)
+             (get-env)
+             (κ (prim-k11 lambda-tail1)
+               (continue lambda-tail1 r10)))))
+         ($falsey-cont5-code26
+          (κ ()
            (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)
+             (get-env)
+             (κ (truthy-cont4 falsey-cont5 lambda-tail1 n fac)
+               (prim
+                (make-shared-closure ($prim-k7-code22) (lambda-tail1 n fac))
+                (κ (prim-k7)
+                  (prim (- n 1) prim-k7)))))))
+         ($r8-code19
+          (κ (x9)
            (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)
+             (get-env)
+             (κ (r8 lambda-tail1 n)
+               (prim
+                (make-shared-closure ($prim-k11-code16) (lambda-tail1))
+                (κ (prim-k11)
+                  (prim (* n x9) prim-k11)))))))
+         ($truthy-cont4-code25
+          (κ ()
            (prim
-             (make-shared-closure (r12) (start-ktail0 x13))
-             letrec-body-cont31))))
+             (get-env)
+             (κ (truthy-cont4 falsey-cont5 lambda-tail1 n fac)
+               (continue lambda-tail1 1)))))
+         ($fac-code35
+          (λ (n lambda-tail1)
+            (prim
+             (get-env)
+             (κ (fac)
+               (prim
+                (make-shared-closure ($prim-k3-code29) (lambda-tail1 n fac))
+                (κ (prim-k3)
+                  (prim (zero? n) prim-k3)))))))
+         ($prim-k3-code29
+          (κ (r2)
+            (prim
+             (get-env)
+             (κ (prim-k3 lambda-tail1 n fac)
+               (prim
+                (make-shared-closure
+                 ($truthy-cont4-code25 $falsey-cont5-code26)
+                 (lambda-tail1 n fac))
+                (κ (truthy-cont4 falsey-cont5)
+                  (if r2
+                    truthy-cont4
+                    falsey-cont5))))))))
  (λ (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)))
+     (make-shared-closure ($fac-code35) ())
+     (κ (fac)
+       (prim
+        (make-shared-closure ($r12-code32) (start-ktail0))
+        (κ (r12)
+          (fac 20 r12)))))))
 |]
@@ -42,6 +42,8 @@ module Gyehoek.CPS.Syntax
  , pattern ValLabel
  , pattern ObjLabel
  , absBody
+  , pattern MkAbs
+  , _MkAbs
  )
  where

@@ -125,6 +127,23 @@ pattern AbsKappa' xs e = AbsKappa (MkKappa xs e)
 pattern AbsLambda' :: List Name -> Name -> Exp -> Abs
 pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)

+{-# COMPLETE AbsKappa', AbsLambda' #-}
+
+_MkAbs :: Iso' Abs (List Name, Maybe Name, Exp)
+_MkAbs = iso
+  (\case
+    AbsKappa' xs e -> (xs,Nothing,e)
+    AbsLambda' xs ktail e -> (xs,Just ktail,e))
+  (\(xs,ktail,e) -> case ktail of
+    Just k -> AbsLambda' xs k e
+    Nothing -> AbsKappa' xs e)
+
+pattern MkAbs :: List Name -> Maybe Name -> Exp -> Abs
+pattern MkAbs xs ktail body <- (view _Abs' -> (xs,ktail,body))
+  where MkAbs xs ktail body = review _Abs' (xs,ktail,body)
+
+{-# COMPLETE MkAbs #-}
+
 data Exp
  = ExpPrim (Prim Val) Kexp
  | ExpLetRec { binders :: List (Name, Abs), body :: Exp }
@@ -158,12 +177,12 @@ data Program = MkProgram
  deriving (Show, Generic, Data)

 data HoistedProgram = MkHoistedProgram
-  { bindings :: HashMap Name Abs
+  { bindings :: HashMap Label Abs
  , body :: Lambda
  }
  deriving stock (Show, Generic, Data)

-type instance Index HoistedProgram = Name
+type instance Index HoistedProgram = Label
 type instance IxValue HoistedProgram = Abs

 instance Ixed HoistedProgram where ix j = #bindings . ix j
@@ -196,7 +215,6 @@ _AbsLambda' = prism'

 instance Plated Exp where plate = uniplate

-
 absBody :: Lens' Abs Exp
 absBody = lens
  (\case
@@ -350,7 +368,7 @@ instance S.DatumIso Program where
 instance S.DatumIso HoistedProgram where
  datumIso = S.with \prog ->
    S.letLike "letrec"
-      (S.datumIso @Name) (S.datumIso @Abs) (S.datumIso @Lambda)
+      (S.datumIso @Label) (S.datumIso @Abs) (S.datumIso @Lambda)
    >>> S.onTail (S.iso H.fromList H.toList)
    >>> prog