src/Gyehoek/CPS/Stackify.hs

@@ -17,6 +17,7 @@ import Data.Text qualified as T
 import Gyehoek.Prelude
 import Debug.Pretty.Simple
 import qualified Gyehoek.Sexp as S
+import Data.Monoid
 
 
 data BlockBuilder
@@ -29,35 +30,33 @@ buildBlock = go [] where
   go acc (Code xs bb) = go (acc ++ xs) bb
   go acc (Tail t) = Stk.MkBlock acc t
 
-stackify
-  :: forall es. (GenSym :> es)
-  => Env -> Exp -> Eff es BlockBuilder
-
-stackify _ e = error [i|unimplemented exp: #{e}|]
-
 -- affine
 _ValName :: Traversal' Val Name
 _ValName = failing #_ValVar (#_ValImm . #_ImmLabel . #_MkLabel)
 
-stackifyAbs
+stackify
-  :: (GenSym :> es)
+  :: forall es. (GenSym :> es)
-  => Env -> Abs
+  => Env -> Exp -> Eff es BlockBuilder
-  -> Eff es Stk.Routine
 
-stackifyAbs g (MkAbs xs _ _) = _
+stackify _ (ExpContinue (ValVar k) xs) =
+  Code [ ] _
 
-stackifyVal :: Env -> Val -> Stk.Val
+stackify _ (ExpPrim p k) = _
-stackifyVal g = \case
-  ValImm imm -> Stk.ValImm imm
-  ValVar v -> case regOf g v of
-    Just r -> Stk.ValReg r
-    Nothing -> Stk.ValLabel (MkLabel v)
-  v -> error [i|unimplemented val: #{v}|]
 
-regOf :: Env -> Name -> Maybe Reg
+stackify _ e = error [i|unimplemented exp: #{e}|]
-regOf g x
+
-  | x `elem` g.bound || x == g.tail = Just . MkReg $ x
+stackifyAbs :: (GenSym :> es) => Env -> Label -> Abs -> Eff es Stk.Routine
-  | otherwise                       = Nothing
+
+stackifyAbs g lbl (MkAbs xs mtail e) =
+  Stk.MkRoutine lbl . buildBlock . preamble <$> stackify g e
+  where
+    preamble = Code (popArgs $ (mtail ^.. _Just) ++ xs)
+
+popArgs :: List Name -> List Stk.Instr
+popArgs = fmap (Stk.Pop . MkReg) . reverse
+
+pushArgs :: List Name -> List Stk.Instr
+pushArgs = _
 
 
 
@@ -73,12 +72,19 @@ emptyEnv = MkEnv
 
 
 
-stackifyProgram :: GenSym :> es => HoistedProgram -> Eff es Stk.Program
+stackifyProgram
-stackifyProgram p = do
+  :: forall es. GenSym :> es
-  let liveness = _
+  => HoistedProgram -> Eff es Stk.Program
-  let g = emptyEnv
+stackifyProgram p = p
-  (_,p') <- runStackify $ emitRoutine =<< stackifyLambda g "start" e
+  & ifoldMapOf
-  pure p'
+    ((#bindings . itraversed)
+     <> (#body . to (H.singleton "start" . AbsLambda) . itraversed))
+    (\l -> Ap . stackifyBinding l)
+  & getAp
+  where
+    g = emptyEnv
+    stackifyBinding lbl ab =
+      Stk.MkProgram . H.singleton lbl <$> stackifyAbs @es g lbl ab
 
 p :: HoistedProgram
 p = [cps|

src/Gyehoek/Stack/Syntax.hs

@@ -76,7 +76,7 @@ data Instr
   = Pop Reg
   | Push Val
   | Load Reg Int
-  | Prim (Prim Val)
+  | Prim Reg (Prim Val)
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
@@ -99,7 +99,7 @@ instance S.DatumIso Instr where
     $ S.With (S.headTagged1 "pop!" S.datumIso >>>)
     $ S.With (S.headTagged1 "push!" S.datumIso >>>)
     $ S.With (S.headTagged2 "load" S.datumIso S.datumIso >>>)
-    $ S.With (S.headTagged1 "prim" S.datumIso >>>)
+    $ S.With (S.headTagged2 "prim" S.datumIso S.datumIso >>>)
     $ S.End
     where