src/Gyehoek/CPS/Convert.hs

@@ -105,12 +105,13 @@ convertLambda
   => List Name -> Scm.Exp -> Eff es Lambda
 convertLambda bs m = do
   ktail <- gensym' "lambda-tail"
-  m' <- convert m $ pure . ExpContinue ktail . (:[])
+  m' <- convert m $ pure . ExpContinue (ValVar ktail) . (:[])
   pure [cps|(λ (##{bs} #{ktail}) #{m'})|]
 
 convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
-convertProgram p =
-  MkProgram <$> telescope (convert @es) (p ^.. each . _Left) (pure . Halt)
+convertProgram p = do
+  MkProgram <$> telescope (convert @es) (p ^.. each . _Left) (pure . nothalt)
+  where nothalt = ExpContinue (ValVar "main-ktail")
 
 convertExp :: forall es. (GenSym :> es) => Scm.Exp -> Eff es Exp
 convertExp e = convert e (pure . Halt1)

src/Gyehoek/CPS/Stackify.hs

@@ -69,27 +69,15 @@ stackify g (ExpIf c t f) = do
   pure . Tail $ Stk.If c' t' f'
 
 stackify g (ExpApply f xs ktail) = pure $
-    Code [ Stk.PushCont k ] $
     Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
-    Tail (Stk.TailCall (stackifyVal g f) (stackifyVal g <$> xs))
+    Tail (Stk.PushCall k (stackifyVal g f) (stackifyVal g <$> xs))
   where
     k = var g ktail
     ls = fold $ (k ^? #ValImm . #ImmLabel)
       >>= \klbl -> g ^. #liveness . at klbl
 
 stackify g (ExpContinue k xs) =
-  -- return continuations require popping the stack. how do we know
-  -- when a continuation is a return continuation? is this a correct
-  -- test?
-  case elemIndex k g.contStack of
-    Nothing -> pure . Tail $ Stk.TailCall (Stk.ValLabel k) xs'
-    Just j -> do
-      ktail <- gensym' @Name $ k ^. _Wrapped'
-      pure $
-        Code (replicate j $ Stk.PopCont "_") $
-        Code [Stk.PopCont ktail] $
-        Tail (Stk.TailCall (Stk.ValReg ktail) xs')
-  where xs' = stackifyVal g <$> xs
+  pure . Tail $ Stk.TailCall (stackifyVal g k) (stackifyVal g <$> xs)
 
 stackify g (ExpPrim p (MkKappa [x] e)) = do
   e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e
@@ -132,8 +120,9 @@ emptyEnv = MkEnv mempty mempty ["halt"]
 
 stackifyExp :: GenSym :> es => Name -> Exp -> Eff es Stk.Program
 stackifyExp lbl e = do
-  (code,p) <- runStackify $ stackify emptyEnv e
-  pure $ p <> [ Stk.MkRoutine lbl [] (buildBlock code) ]
+  let g = emptyEnv & #bound . at "main-ktail" ?~ Stk.ValReg "main-ktail"
+  (code,p) <- runStackify $ stackify g e
+  pure $ p <> [ Stk.MkRoutine lbl ["main-ktail"] (buildBlock code) ]
 
 stackifyProgram :: GenSym :> es => Program -> Eff es Stk.Program
 stackifyProgram (MkProgram e) = stackifyExp "main" e

src/Gyehoek/CPS/Syntax.hs

@@ -102,7 +102,7 @@ pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
 data Exp
   = ExpPrim (Prim Val) Kappa
   | ExpLetRec { binders :: List (Name, Abs), body :: Exp }
-  | ExpContinue Name (List Val)
+  | ExpContinue Val (List Val)
   | ExpIf Val Exp Exp
   | ExpApply
     { op :: Val
@@ -112,10 +112,10 @@ data Exp
   deriving (Show, Generic, Data, Eq)
 
 pattern Halt :: List Val -> Exp
-pattern Halt xs = ExpContinue "halt" xs
+pattern Halt xs = ExpContinue (ValLabel "halt") xs
 
 pattern Halt1 :: Val -> Exp
-pattern Halt1 x = ExpContinue "halt" [x]
+pattern Halt1 x = ExpContinue (ValLabel "halt") [x]
 
 data Def = DefConstant Name Exp
   deriving (Show, Generic, Data)
@@ -315,7 +315,7 @@ instance Free Exp where
       foldMapOf (each . _2) (freeWithBound' bound') bs
       <> freeWithBound' bound' m
       where bound' = bound & insertFrom (bs ^.. each . _1)
-    ExpContinue k xs -> filter (`notElem` bound) (k : xs ^.. each . #ValVar)
+    ExpContinue k xs -> filter (`notElem` bound) ((k:xs) ^.. each . #ValVar)
     ExpIf c t f ->
       (c ^.. #ValVar . filtered (`notElem` bound))
       <> freeWithBound' bound t <> freeWithBound' bound f
@@ -330,21 +330,3 @@ instance Free Kappa where
 instance Free Lambda where
   freeWithBound' bound (MkLambda xs k m) =
     freeWithBound' (bound & insertFrom (k:xs)) m
-
-
-
-class Vars a where
-  -- | Traverse the immediate variables of an expression.
-  vars :: Traversal' a Name
-
-instance Vars Val where
-  vars k (ValVar x) = ValVar <$> k x
-  vars _ x = pure x
-
-instance Vars a => Vars (Prim a) where
-  vars k p = traverseOf (each . vars) k p
-
-instance Vars Exp where
-  vars k (ExpPrim p kap) = ExpPrim <$> vars k p <*> pure kap
-  vars k (ExpContinue kname xs) = ExpContinue <$> k kname <*> pure xs
-  vars _ e = pure e

src/Gyehoek/Driver.hs

@@ -1,7 +1,7 @@
 module Gyehoek.Driver
   (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e)
   where
-
+
 import Gyehoek.Options
 import Prelude hiding (readFile)
 import Options.Applicative
@@ -17,7 +17,7 @@ import qualified Data.Text.Encoding as T
 import System.IO (Handle)
 import System.IO qualified as IO
 import Gyehoek.CPS.Convert
-import Gyehoek.CPS.Lower
+import Gyehoek.Stack.Lower
 import Gyehoek.CPS.Eval qualified as CPS
 import Control.Monad
 import Text.Pretty.Simple (pShowNoColor)
@@ -35,14 +35,14 @@ import Control.Arrow ((>>>))
 import Gyehoek.Prelude
 import Gyehoek.Jalmot
 import qualified Gyehoek.Sexp as S
-
+
 
 main :: IO ()
 main = do
   opts <- execParser $ info (helper <*> parser) fullDesc
   runJalmotIO . runFileSystem . runGenSym . driver $ opts
 
-
+
 
 -- hPutStr :: FileSystem :> es => Handle -> Text -> Eff es ()
 -- hPutStr h = FB.hPutStr h . T.encodeUtf8
@@ -135,10 +135,10 @@ driver opts = do
       & fmap writeObj
       & T.unwords
       & hPutStrLn FS.stdout
-  dumpOrRun opts.inspectWasm (rt_is #Wasm)
-    (lowerProgram cps)
-    inspectWasm
-    (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat)
+  -- dumpOrRun opts.inspectWasm (rt_is #Wasm)
+  --   (lowerProgram cps)
+  --   inspectWasm
+  --   (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat)
 
 parse_e2e :: FilePath -> IO Scm.Program
 parse_e2e = runJalmotIO . runFileSystem . readScm

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -40,7 +40,7 @@ module Gyehoek.Sexp.Grammar.Base
   , lambdaLike
   , lambdaKeyword
   , kappaKeyword
-  , beginLike
+  , beginLike, headTagged2'
   ) where
 
 import Data.InvertibleGrammar
@@ -325,6 +325,13 @@ headTagged2
   -> G (Datum :- t) (b :- a :- t)
 headTagged2 s g1 g2 = list $ el (symProcedure s) >>> el g1 >>> el g2
 
+headTagged2'
+  :: Text
+  -> DatumGrammar a -> DatumGrammar b -> DatumGrammar c
+  -> G (Datum :- t) (List c :- b :- a :- t)
+headTagged2' s g1 g2 gt =
+  list $ el (symProcedure s) >>> el g1 >>> el g2 >>> rest gt
+
 ifLike
   -- | keyword
   :: Text

src/Gyehoek/Stack/Lower.hs

@@ -16,9 +16,9 @@ lowerBlock = _
 
 lowerInstr :: Instr -> Wasm.Expr
 lowerInstr = \case
-  PopCont ktail -> [wat|
+  -- PopCont ktail -> [wat|
     
-  |]
+  -- |]
 
 lowerProgram :: Program -> Eff es Wasm.Module
 lowerProgram p = pure [watM|

src/Gyehoek/Stack/Syntax.hs

@@ -60,6 +60,7 @@ data Block = MkBlock
 
 data Tail
   = TailCall Val (List Val)
+  | PushCall Val Val (List Val)
   | If Val Block Block
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
@@ -67,8 +68,6 @@ data Tail
 data Instr
   = Pop Name
   | Push Val
-  | PopCont Name
-  | PushCont Val
   | Prim Name (Prim Val)
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
@@ -91,8 +90,6 @@ instance S.DatumIso Instr where
   datumIso = S.match
     $ S.With (S.headTagged1 "pop!" regName >>>)
     $ S.With (S.headTagged1 "push!" S.datumIso >>>)
-    $ S.With (S.headTagged1 "pop-cont!" regName >>>)
-    $ S.With (S.headTagged1 "push-cont!" S.datumIso >>>)
     $ S.With (S.headTagged2 "prim" regName S.datumIso >>>)
     $ S.End
     where
@@ -108,6 +105,7 @@ instance S.DataIso Block where
 instance S.DatumIso Tail where
   datumIso = S.match
     $ S.With (S.headTagged1' "tail-call" S.datumIso S.datumIso >>>)
+    $ S.With (S.headTagged2' "push-call" S.datumIso S.datumIso S.datumIso >>>)
     $ S.With (if_ >>>)
     $ S.End
     where

src/Gyehoek/Stack/VM.hs

@@ -17,7 +17,6 @@ import Gyehoek.Prelude
 
 data VM = MkVM
   { stack :: List Obj
-  , kstack :: List Name
   , code :: List Instr
   , tail :: Tail
   , registers :: HashMap Name Obj
@@ -40,8 +39,6 @@ stepI :: Env -> VM -> Instr -> VM
 
 stepI e vm (Push v) = vm & #stack %~ (evalVal e vm v :)
 
-stepI e vm (PushCont k) = vm & #kstack %~ (evalToLabel e vm k :)
-
 stepI e vm (Prim r p) = case evalVal e vm <$> p of
   PrimZeroP x -> case x of
     ObjImm (ImmInt n) -> ret . ObjImm . ImmBool $ n == 0
@@ -74,11 +71,6 @@ stepI e vm (Pop r) = case vm ^. #stack of
   (x:xs) -> vm & #registers . at r ?~ x
                & #stack .~ xs
 
-stepI e vm ins@(PopCont r) = case vm ^. #kstack of
-  [] -> error [i|empty cont stack: #{ins}|]
-  (x:xs) -> vm & #registers . at r ?~ ObjImm (ImmLabel x)
-               & #kstack .~ xs
-
 stepI e vm ins = error [i|unimplemented instruction: #{ins}|]
 
 stepT :: Env -> VM -> Tail -> VM
@@ -95,6 +87,9 @@ stepT g vm (TailCall f xs) =
           Nothing -> error [i|undefined label: #{l}|]
           Just x -> x
 
+stepT g vm (PushCall k f xs) =
+  _
+
 stepT g vm (If c t f) = vm & #code .~ branch.code & #tail .~ branch.tail
   where
     branch = case evalVal g vm c of
@@ -116,9 +111,8 @@ evalVal e vm = \case
 initialVM :: VM
 initialVM = MkVM
   { stack = []
-  , kstack = ["halt"]
   , code = []
-  , tail = TailCall (ValLabel "main") []
+  , tail = TailCall (ValLabel "main") [ValLabel "halt"]
   , registers = mempty
   , stdout = ""
   , result = Nothing

test/Gyehoek/Test/CPS/Syntax.hs

@@ -29,14 +29,14 @@ qq :: TestTree
 qq = testGroup "parser"
   [ testCase "lambda" do
       assertEqual "" (Sut.MkLambda ["x","y"] "ktail"
-               (Sut.ExpContinue "ktail" [Sut.ValVar "x"]))
+               (Sut.ExpContinue (Sut.ValLabel "ktail") [Sut.ValVar "x"]))
         [cps|(λ (x y ktail) (continue ktail x))|]
       assertEqual "" (Sut.MkLambda [] "ktail"
-               (Sut.ExpContinue "ktail" [Sut.ValVar "x"]))
+               (Sut.ExpContinue (Sut.ValLabel "ktail") [Sut.ValVar "x"]))
         [cps|(λ (ktail) (continue ktail x))|]
   , testCase "kappa" do
       assertEqual "" (Sut.MkKappa ["x","y"]
-               (Sut.ExpContinue "k123" [Sut.ValVar "x", Sut.ValVar "y"]))
+               (Sut.ExpContinue (Sut.ValLabel "k123") [Sut.ValVar "x", Sut.ValVar "y"]))
         [cps|(κ (x y) (continue k123 x y))|]
   , testCase "application" do
       assertEqual "" (Sut.ExpApply (Sut.ValVar "f")