.gitignore

@@ -8,5 +8,4 @@ dist-newstyle
 *.tix
 .direnv
 result
-play/
-trace.html
+play/

doc/make-vm-stackier.org

@@ -1,100 +0,0 @@
-* rationale?
-
-previously, the VM's stack was used for storing local variables across blocks; a Scheme procedure was split into several low-level routines (one for the procedure itself and one for each continuation), and the stack was used as a communication channel for these separate routines. in contrast, registers were local to each routine. this aligns with Wasm's model of functions pretty well, with Wasm /locals/ acting as the VM's /registers/, and a global mutable stack serving as fallback.
-
-this worked quite well until it became time to implement ~call/cc~.
-
-we are considering making the following alterations to the VM:
-- explicitly segment the stack into frames.
-- passing procedures and return addresses on the stack.
-- new instructions:
-  + ~(tail-call /n/)~
-  + ~(call /n/)~
-  + ~(load /r/ /n/)~
-  + ~(return /n/)~
-
-* scratchpad
-
-#+begin_src scheme
-  (letrec ((fac (λ (n)
-                (if (zero? n)
-                    1
-                    (* n (fac (- n 1)))))))
-  (fac 3))
-#+end_src
-
-#+begin_src scheme
-  (λ (ktail0)
-  (letrec ((fac
-            (λ (n ktail1)
-              (zero?
-               n
-               (κ (x0)
-                  (if x0
-                      (continue ktail1 1)
-                      (- n 1
-                         (κ (x1)
-                            (fac x1
-                                 (κ (x2)
-                                    (* n x2 ktail1)))))))))))
-    (fac 3)))
-#+end_src
-
-#+begin_example
-n ktail1
-| |
-| | x0
-| | |
-| | ^
-| |
-| | x1
-| | |
-| | ^
-| | 
-| | x2
-| | |
-^ ^ ^
-#+end_example
-
-#+begin_src scheme
-  (define $fac-c0
-    (pop! %x0 0) ; [ x0 $fac-c0 n $fac ktail1 ]
-    (if %x0 ; [ $fac-c0 n $fac ktail1 ]
-        ;; every variable but `ktail1' is dead so we pop them all.
-        ;; this probably means that `if' should take two continuations
-        ;; rather than two blocks.
-        (then (push! 1) ; [ $fac-c0 n $fac ktail1 ]
-              (return 1)) ; [ 1 $fac-c0 n $fac ktail1 ]
-        (else (load %n 1) ; [ $fac-c0 n $fac ktail1 ]
-              (prim %x1 (- %n 1)) ; [ $fac-c0 n $fac ktail1 ]
-              (push! $fac-c1) ; [ $fac-c0 n $fac ktail1 ]
-              (push! $fac) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
-              (push! %x1) ; [ $fac $fac-c1 $fac-c0 n $fac ktail1 ]
-              (call 1) ; [ x1 $fac $fac-c1 $fac-c0 n $fac ktail1 ]
-              )))
-
-  (define $fac-c1
-    (pop! %x2) ; [ x2 $fac-c1 $fac-c0 n $fac ktail1 ]
-    (load %n 3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
-    (prim %x3 (* %n %x2))
-    (push! %x3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
-    (return 1) ; [ x3 $fac-c1 $fac-c0 n $fac ktail1 ]
-    )
-
-  (define $fac
-    (load %ktail1 2) ; [ n $fac ktail1 ]
-    (load %n 0) ; [ n $fac ktail1 ]
-    (push! $fac-c0) ; [ n $fac ktail1 ]
-    (push! $zero?) ; [ $fac-c0 n $fac ktail1 ]
-    (push! %n) ; [ $zero? $fac-c0 n $fac ktail1 ]
-    (call 1) ; [ n $zero? $fac-c0 n $fac ktail1 ]
-    )
-
-  (define $start
-    (push! $fac) ; [ $start ktail0 ]
-    (push! 3) ; [ $fac $start ktail0 ]
-    (tail-call 1) ; [ 3 $fac $start ktail0 ]
-    ;; ↑ `tail-call' knows how to dispose of the caller's stack frame.
-    )
-#+end_src
-

golden/exec/begin-1/source.scm

@@ -1 +0,0 @@
-(begin 123 456) ; => 456

golden/exec/callcc-early-exit-1/exec

@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > #t

golden/exec/callcc-early-exit-1/source.scm

@@ -1,12 +0,0 @@
-(letrec ((iter (λ (n f)
-                 (if (zero? n)
-                     #f
-                     (begin (f n)
-                            (iter (- n 1) f))))))
-  (call/cc
-   (λ (k)
-     (iter 10 (λ (n)
-                ;; i don't feel like implementing (= n 5) right now lmfao
-                (if (zero? (- n 5))
-                    (k #t)
-                    #f))))))

golden/exec/callcc-early-exit-2/exec

@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > #t

golden/exec/callcc-early-exit-2/source.scm

@@ -1,4 +0,0 @@
-(call/cc
- (λ (k)
-   (begin (k #t)
-          #f)))

golden/exec/callcc-early-exit-3/exec

@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > #t

golden/exec/callcc-early-exit-3/source.scm

@@ -1,5 +0,0 @@
-;; confer ../callcc-early-exit-4
-(letrec ((app (λ (f x)
-                (begin (f x)
-                       #f))))
-  (call/cc (λ (k) (app k #t))))

golden/exec/callcc-early-exit-4/exec

@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > #t

golden/exec/callcc-early-exit-4/source.scm

@@ -1,5 +0,0 @@
-;; confer ../callcc-early-exit-3
-(letrec ((app (λ (f x)
-                (begin (f x)
-                       #f))))
-  (call/cc (λ (k) (app (λ (x) (k x)) #t))))

golden/exec/callcc-early-exit-5/exec

@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > #t

golden/exec/callcc-early-exit-5/source.scm

@@ -1,4 +0,0 @@
-(call/cc
- (λ (k)
-   (begin ((λ () (k #t)))
-          #f)))

golden/exec/callcc-early-exit-6/exec

@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > 12

golden/exec/callcc-early-exit-6/source.scm

@@ -1,4 +0,0 @@
-(* 2 (call/cc
-      (λ (k)
-        (begin (k 6)
-               3))))

golden/exec/callcc-nested-2/exec

@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > 456

golden/exec/complicated-1/exec

@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > 155

golden/exec/complicated-1/source.scm

@@ -1,10 +0,0 @@
-(letrec ((factorial (λ (n)
-                      (if (zero? n)
-                          1
-                          (* n (factorial (- n 1)))))))
-  (letrec ((sum-of-factorials
-            (λ (n)
-              (if (zero? n)
-                  0
-                  (+ (factorial n) (sum-of-factorials (- n 1)))))))
-    (+ 2 (sum-of-factorials 5))))

golden/exec/cons-1/exec

@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > (6 . 7)

golden/exec/cons-1/source.scm

@@ -1 +0,0 @@
-(cons 6 7)

gyehoek.cabal

@@ -63,7 +63,6 @@ library
     Gyehoek.CPS.Stackify
     Gyehoek.CPS.Syntax
     Gyehoek.Driver
-    Gyehoek.Language
     Gyehoek.GenSym
     Gyehoek.Jalmot
     Gyehoek.Lift1
@@ -117,8 +116,6 @@ library
     , typed-process
     , unordered-containers
     , vector
-    , lucid
-    , prettyprinter-lucid
 
   hs-source-dirs:   src
   default-language: GHC2024
@@ -168,9 +165,7 @@ test-suite doctest
   import:             ghcstuffs, ghcstuffs-dev
   type:               exitcode-stdio-1.0
   hs-source-dirs:     test
-  build-depends:
-    , base
-    , gyehoek
+  build-depends:      base
   default-extensions: CPP
   main-is:            doctest.hs
 

src/Gyehoek/CPS/Close.hs

@@ -4,7 +4,6 @@ module Gyehoek.CPS.Close
   ) where
 
 import Gyehoek.CPS.Syntax
-import Data.List (nub)
 import Gyehoek.GenSym
 import Gyehoek.Prelude
 
@@ -12,27 +11,31 @@ import Gyehoek.Prelude
 close :: 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")
+    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
+    let frees = freeWithBound' [f] lam
     let m' = ifoldr
-             (\n x q ->
-               let p = if x == f then PrimEnv @Val else PrimEnvRef n
-               in [cps|
-                 (prim #{p}
-                   (κ (#{x}) #{q}))
-             |])
+             (\n x q -> [cps|(prim (env-ref #{f} #{n})
+                                (κ (#{x}) #{q}))|])
              m frees
     pure [cps|
-      (letrec ((#{f_code} (λ (##{bs} #{kb})
+      (letrec ((#{f_code} (λ (#{f} ##{bs} #{kb})
                             #{m'})))
-        (prim (make-closure #{f_code} ##{frees})
+        (prim (make-closure ($ #{f_code}) ##{frees})
           (κ (#{f}) #{e})))
     |]
 
+  ExpApply f xs ktail -> do
+    code <- gensym' @Name "code"
+    pure [cps|
+      (prim (env-code #{f})
+        (κ (#{code})
+          (#{code} #{f} ##{xs} #{ktail})))
+    |]
+
   e -> pure e
 
 closeProgram :: GenSym :> es => Program -> Eff es Program
-closeProgram = traverseOf (#body . #body) close
+closeProgram = traverseOf #body close

src/Gyehoek/CPS/Convert.hs

@@ -12,7 +12,6 @@ import Data.List.NonEmpty (NonEmpty((:|)))
 import Control.Monad.Cont qualified as Cont
 import qualified Data.List.NonEmpty as NE
 import Gyehoek.Prelude
-import Debug.Pretty.Simple
 
 
 -- 뻘짓이어라
@@ -24,73 +23,58 @@ telescope f = Cont.runCont . traverse (Cont.cont . f)
 
 
 
-one :: a -> List a
-one a = [a]
-
-oneOrUndefined :: List Val -> Val
-oneOrUndefined = \case
-  [x] -> x
-  _ -> ValImm ImmUndefined
-
-convert1 :: (GenSym :> es) => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
-convert1 e k = convert e (k . oneOrUndefined)
-
 -- | Transform an expression with a meta-continuation.
 convert
   :: forall es. (GenSym :> es)
-  => Scm.Exp -> (List Val -> Eff es Exp) -> Eff es Exp
+  => Scm.Exp -> (Val -> Eff es Exp) -> Eff es Exp
 
-convert (Scm.ExpVar x) k = k [ValVar x]
-convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
+convert (Scm.ExpVar x) k = k $ ValVar x
+convert (Scm.ExpLit l) k = k . ValImm $ case l of
   LitInt n -> ImmInt n
   LitBool b -> ImmBool b
   _ -> _
 
 -- special case: call/cc is desugared during cps-conversion...
--- convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
---   convert1 withcc \withcc' -> do
---     cc_l <- gensym' @Name "cc"
---     r1_l <- gensym' @Name "r"
---     r2_l <- gensym' @Name "r"
---     ccish_l <- gensym' @Name "ccish"
---     reified_cc_l <- gensym' @Name "reified-cc"
---     m <- k [ValVar r1_l]
---     pure [cps|
--- (letrec ((#{cc_l} (κ (#{r1_l})
---                      #{m})))
---   (prim (capture/cc)
---        (κ (#{reified_cc_l})
---           (#{withcc'} #{reified_cc_l} #{cc_l}))))
---     |]
+convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
+  convert withcc \withcc' -> do
+    cc <- gensym' @Name "cc"
+    r <- gensym' "r"
+    m <- k $ ValVar r
+    ccish <- gensym' @Name "cc-ish"
+    x <- gensym' @Name "x"
+    pure [cps|
+      (letrec ((#{cc} (κ (#{r}) #{m})))
+        (letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x}))))
+          (#{withcc'} #{ccish} #{cc})))
+    |]
 
 -- ...while all other prims are left as-is for later stages to
 -- handle..
 convert (Scm.ExpPrim p) k =
-  telescope (convert1 @es) p \p' -> do
+  telescope (convert @es) p \p' -> do
     r <- gensym' "r"
-    ExpPrim p' . MkKappa [r] <$> k [ValVar r]
+    ExpPrim p' . MkKappa [r] <$> k (ValVar r)
 
 convert (Scm.ExpLambda xs e) k = do
   f <- gensym' "lambda-body"
   lam <- convertLambda xs e
-  ke <- k [ValVar f]
+  ke <- k $ ValVar f
   pure [cps|
     (letrec ((#{f} #{lam}))
       #{ke})
   |]
 
 convert (Scm.ExpApply f xs) k =
-  telescope (convert1 @es) (f:|xs) \(f':|xs') -> do
+  telescope (convert @es) (f:|xs) \(f':|xs') -> do
     r <- gensym' "r"
     x <- gensym' "x"
-    m <- k [ValVar x]
-    pure $ ExpLetRec [(r, AbsKappa' [x] m)] $
-      ExpApply f' xs' r
+    m <- k (ValVar x)
+    pure $ ExpLetRec [(r, AbsKappa' [x] m)] $ ExpApply f' xs' r
 
-convert (Scm.ExpBegin xs) k = telescope (convert @es) xs (k . NE.last)
+convert (Scm.ExpBegin xs) k = _
 
 convert (Scm.ExpIf c t f) k =
-  convert1 c \c' ->
+  convert c \c' ->
     ExpIf c' <$> convert t k <*> convert f k
 
 -- let-bindings are desugared into continuation calls whose parameters
@@ -98,7 +82,7 @@ convert (Scm.ExpIf c t f) k =
 -- sides.
 convert (Scm.ExpLet bs e) k =
   let rhss = bs ^.. each . _2
-  in telescope (convert1 @es) rhss \rhss' -> do
+  in telescope (convert @es) rhss \rhss' -> do
     e' <- convert e k
     kbody <- gensym' @Name "let-body"
     let bs' = bs ^.. each . _1
@@ -121,15 +105,12 @@ convertLambda
   => List Name -> Scm.Exp -> Eff es Lambda
 convertLambda bs m = do
   ktail <- gensym' "lambda-tail"
-  m' <- convert1 m $ pure . ExpContinue (ValVar ktail) . (:[])
+  m' <- convert m $ pure . ExpContinue ktail . (:[])
   pure [cps|(λ (##{bs} #{ktail}) #{m'})|]
 
 convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
-convertProgram p = do
-  ktail <- gensym' "start-ktail"
-  m <- telescope (convert1 @es) (p ^.. each . _Left)
-        (pure . ExpContinue (ValVar ktail))
-  pure . MkProgram $ MkLambda [] ktail m
+convertProgram p =
+  MkProgram <$> telescope (convert @es) (p ^.. each . _Left) (pure . Halt)
 
 convertExp :: forall es. (GenSym :> es) => Scm.Exp -> Eff es Exp
-convertExp e = convert e (pure . Halt)
+convertExp e = convert e (pure . Halt1)

src/Gyehoek/CPS/Eval.hs

@@ -2,7 +2,6 @@
 module Gyehoek.CPS.Eval
   ( evalProgram
   , module Gyehoek.CPS.Syntax
-  , evalExp
   ) where
 
 import Gyehoek.CPS.Syntax
@@ -11,7 +10,6 @@ import Data.Maybe (fromMaybe)
 import Text.Show.Functions ()
 import qualified Data.HashMap.Strict as H
 import Gyehoek.Prelude
-import Debug.Pretty.Simple
 
 
 data Env = MkEnv
@@ -25,40 +23,26 @@ eval :: Env -> Exp -> List Obj
 eval g (Halt xs) = evalVal g <$> xs
 
 eval g (ExpContinue k xs) =
-  case g ^. #labels . at k' of
+  case g ^. #labels . at k of
     Just (h, AbsKappa' bs m) -> eval h' m
-      where
-        h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
+      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
     _ -> error [i|not a kappa: #{k}|]
-  where
-    k' = case evalVal g k of
-      ObjImm (ImmLabel x) -> x
-      x -> error [i|expected label, got #{x}|]
 
-eval g (ExpApply f xs ktail) =
-  case g ^?! #labels . at f' of
+eval g (ExpApply ((^?! #ValVar) -> f) xs ktail) =
+  case g ^?! #labels . at f of
     Just (h,AbsLambda' bs kb m) -> eval h' m
       where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
                    & #labels . at kb .~ (g ^. #labels . at ktail)
     Nothing -> error [i|undefined label: #{f}|]
-  where
-    f' = case evalVal g f of
-      ObjImm (ImmLabel x) -> x
-      x -> error [i|expected label, got #{x}|]
 
 eval g (ExpLetRec [(b, ab)] e) = eval g' e
-  where g' = g & #labels . at b ?~ ab
+  where g' = g & #labels . at b ?~ (g,ab)
 
 eval g (ExpPrim p (MkKappa bs e)) = case evalVal g <$> p of
   PrimAdd x y -> arithBinop (+) x y
   PrimMul x y -> arithBinop (*) x y
   PrimSub x y -> arithBinop (-) x y
   PrimDiv x y -> arithBinop div x y
-  PrimMakeClosure x env -> ret [ObjHob (HobClosure lbl env) ]
-    where
-      lbl = case x of
-        ObjImm (ImmLabel l) -> l
-        _ -> error [i|expected label, got #{x}|]
   _ -> error [i|unhandled prim: #{p}|]
   where
     ret rs = eval
@@ -85,15 +69,11 @@ emptyEnv = MkEnv
   -- special case of `eval` responsible for `halt` only covers terms
   -- of the form `(continue $halt xs …)`; other terms such as
   -- `($some-fn xs $halt)` just see an undefined label `$halt`.
-  , labels = H.singleton "halt" $
-     AbsKappa' ["h0"] $ Halt [ValVar "h0"]
+  , labels = H.singleton "halt"
+    ( emptyEnv
+    , AbsKappa' ["h0"] $ Halt [ValVar "h0"]
+    )
   }
 
-evalExp :: Exp -> List Obj
-evalExp = eval emptyEnv
-
 evalProgram :: Program -> List Obj
-evalProgram (MkProgram lam) = eval emptyEnv [cps|
-  (letrec ((start #{lam}))
-    (start halt))
-|]
+evalProgram (MkProgram e) = eval emptyEnv e

src/Gyehoek/CPS/Stackify.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedLists #-}
 module Gyehoek.CPS.Stackify
-  ( stackifyProgram
+  ( stackifyExp
+  , stackifyProgram
   , module Gyehoek.CPS.Syntax
   ) where
 
@@ -12,11 +13,8 @@ import Gyehoek.GenSym
 import Effectful.Writer.Static.Shared
 import Data.Foldable
 import qualified Data.HashMap.Strict as H
-import Data.List (elemIndex, nub)
-import Data.Text qualified as T
+import Data.List (elemIndex)
 import Gyehoek.Prelude
-import Debug.Pretty.Simple
-import qualified Gyehoek.Sexp as S
 
 
 type Stackify = Writer Stk.Program
@@ -25,10 +23,9 @@ 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)
+live g e = free' e & filter \x ->
+  x `H.member` g.bound
+  && not (x `elem` g.contStack)
 
 data BlockBuilder
   = Code (List Stk.Instr) BlockBuilder
@@ -47,14 +44,22 @@ stackify
   :: (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, kap@(AbsKappa' xs m))] e) = do
+  let vs = (f, Stk.ValLabel f) : (bindReg <$> xs)
+  let ls = live g kap
+  m' <- stackify (g & #bound .~ H.fromList (vs ++ (bindReg <$> ls))) m
+  emitRoutine $
+    Stk.MkRoutine f xs . buildBlock $
+      Code [Stk.Pop x | x <- ls] m'
+  let g' = g & #bound . at f ?~ Stk.ValLabel f
+             & #liveness . at f ?~ ls
+  stackify g' e
 
-stackify g (ExpLetRec [(f, AbsLambda lam)] e) = do
-  lam' <- stackifyLambda g (MkLabel f) lam
-  emitRoutine lam'
+stackify g (ExpLetRec [(f, AbsLambda' xs k m)] e) = do
+  let vs = (k:xs) <&> \x -> (x, Stk.ValReg x)
+  m' <- stackify (g & #bound .~ H.fromList vs
+                    & #contStack %~ (k:)) m
+  emitRoutine $ Stk.MkRoutine f xs (buildBlock m')
   stackify g e
 
 stackify g (ExpIf c t f) = do
@@ -63,138 +68,92 @@ stackify g (ExpIf c t f) = do
   f' <- buildBlock <$> stackify g f
   pure . Tail $ Stk.If c' t' f'
 
-stackify g (ExpApply f xs ktail) = do
+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))
+  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
+
+stackify g (ExpPrim p (MkKappa [x] e)) = do
+  e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e
   pure $
-    Code [ Stk.Push $ stackifyVal g (ValVar ktail)
-         , 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
-  cc' <- stackifyKappa g cc
-  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)
-         ] $
-    Tail Stk.CallCC
-
-stackify g (ExpPrim p kap) = do
-  kap' <- stackifyKappa g kap
-  pure $ Code [ Stk.Prim (stackifyVal g <$> p) ] kap'
+    Code [ Stk.Prim x (stackifyVal g <$> p) ] $
+    e'
 
 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 -> Kappa
-  -> Eff es BlockBuilder
-stackifyKappa g (MkKappa xs m) = do
-  let g' = g & #bound <>:~ xs
-  Code (loadArgs g'.bound)
-    <$> stackify g' 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'
-
 stackifyVal :: Env -> Val -> Stk.Val
 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)
+  ValVar v -> var g v
   v -> error [i|unimplemented val: #{v}|]
 
-regOf :: Env -> Name -> Maybe Reg
-regOf g x
-  | x `elem` g.bound || x == g.tail = Just . MkReg $ x
-  | otherwise                       = Nothing
+var :: Env -> Name -> Stk.Val
+var g v = case g ^. #bound . at v of
+  Just x -> x
+  Nothing -> Stk.ValLabel v
+
+bindReg :: Name -> (Name, Stk.Val)
+bindReg x = (x, Stk.ValReg x)
 
 
 
 data Env = MkEnv
-  -- | `bound` tracks the stack lifetime of bound variables.
-  { bound :: List Name
+  { bound :: HashMap Name Stk.Val
   -- | 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
+  , liveness :: HashMap Name (List Name)
+  , contStack :: List Name
   }
   deriving (Show, Generic)
 
 emptyEnv :: Env
-emptyEnv = MkEnv
-  { bound = mempty
-  , liveness = mempty
-  , tail = "halt"
-  }
+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) ]
+
 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 (MkProgram e) = stackifyExp "main" e
 
-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 = [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)))
+fac :: Program
+fac = [cps|
+  (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))
 |]

src/Gyehoek/CPS/Syntax.hs

@@ -18,8 +18,6 @@ module Gyehoek.CPS.Syntax
   , Imm(..)
   , Obj(..)
   , Hob(..)
-  , Label(..)
-  , Reg(..)
   , pattern Halt
   , pattern Halt1
   , _MkKappa
@@ -38,7 +36,7 @@ module Gyehoek.CPS.Syntax
   , Abs(..)
   , Free(..)
   , pattern ValLabel
-  , pattern ObjLabel
+  , labelName -- don't like that this is part of the api
   )
   where
 
@@ -54,8 +52,6 @@ import Gyehoek.Prelude hiding (op)
 import Gyehoek.Sexp (Datum)
 import Gyehoek.Sexp (G, (:-)(..))
 import qualified Data.InvertibleGrammar.Base as IG
-import Gyehoek.GenSym (Gen)
-import Data.String (IsString)
 
 -- Data types
 
@@ -64,24 +60,13 @@ data Val
   | ValVar Name
   deriving (Show, Generic, Data, Eq)
 
-pattern ValLabel :: Label -> Val
+pattern ValLabel :: Name -> Val
 pattern ValLabel x = ValImm (ImmLabel x)
 
-newtype Label = MkLabel { inner :: Name }
-  deriving stock (Generic, Data)
-  deriving newtype (Show, Eq, Gen, IsString, Hashable)
-  deriving anyclass (NFData, Wrapped)
-
-newtype Reg = MkReg { inner :: Name }
-  deriving stock (Generic, Data)
-  deriving newtype (Show, Eq, Gen, IsString, Hashable)
-  deriving anyclass (NFData, Wrapped)
-
 data Imm
   = ImmInt Int
   | ImmBool Bool
-  | ImmLabel Label
-  | ImmUndefined
+  | ImmLabel Name
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
@@ -91,14 +76,9 @@ data Obj
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
-pattern ObjLabel l = ObjImm (ImmLabel l)
-
 -- | a heap object.
 data Hob
-  = HobClosure { label :: Label, env :: List Obj }
-  -- should a continuation have a label, or an Obj?
-  | HobContinuation { cont :: Obj, stack :: NonEmpty (List Obj) }
-  | HobPair Obj Obj
+  = HobClosure { label :: Name, env :: List Obj }
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
@@ -122,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 Val (List Val)
+  | ExpContinue Name (List Val)
   | ExpIf Val Exp Exp
   | ExpApply
     { op :: Val
@@ -132,16 +112,16 @@ data Exp
   deriving (Show, Generic, Data, Eq)
 
 pattern Halt :: List Val -> Exp
-pattern Halt xs = ExpContinue (ValLabel "halt") xs
+pattern Halt xs = ExpContinue "halt" xs
 
 pattern Halt1 :: Val -> Exp
-pattern Halt1 x = ExpContinue (ValLabel "halt") [x]
+pattern Halt1 x = ExpContinue "halt" [x]
 
 data Def = DefConstant Name Exp
   deriving (Show, Generic, Data)
 
 data Program = MkProgram
-  { body :: Lambda
+  { body :: Exp
   }
   deriving (Show, Generic, Data)
 
@@ -187,64 +167,51 @@ instance S.DatumIso Imm where
   datumIso = S.match
     $ S.With (. S.int)
     $ S.With (. S.datumIso)
-    $ S.With (. S.datumIso)
-    $ S.With (. S.unreadable (const "#<undefined>"))
+    $ S.With (. labelName)
     $ S.End
 
-instance S.DatumIso Label where
-  datumIso = S.with \g -> S.coproduct
-    [ S.decorate S.SynConstant >>> S.datumIso @Name >>> S.prismIso
-          (S.expected "label")
-          (prefixed @Name "$")
-    , S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @Name)
-    ]
-    >>> g
-
-instance S.DatumIso Reg where
-  datumIso = S.with \g ->
-    S.decorate S.SynVariable >>> S.datumIso @Name >>> S.prismIso
-      (S.expected "register")
-      (prefixed @Name "%")
-    >>> g
+labelName :: S.DatumGrammar Name
+labelName = S.coproduct
+  [ S.decorate S.SynConstant >>> S.datumIso @Name >>> S.prismIso
+        (S.expected "label")
+        (prefixed @Name "$")
+  , S.list $ S.el (S.sym "$") >>> S.el (S.datumIso @Name)
+  ]
 
 instance S.DatumIso Hob where
   datumIso = S.match
     $ S.With (. closure)
-    $ S.With (. cont)
-    $ S.With (. conspair)
     $ S.End
     where
-      conspair = S.dottedList (S.el S.datumIso) S.datumIso
       -- closures can be printed, but not parsed.
-      closure :: G (Datum :- t) (List Obj :- Label :- t)
+      closure :: G (Datum :- t) (List Obj :- Name :- t)
       closure = IG.Flip $ IG.PartialIso
-        (\(env:-code:-t) -> S.Unreadable [i|\#<procedure $#{code}>|] :- t)
-        (const . Left $ mempty)
-      cont :: G (Datum :- t) (NonEmpty (List Obj) :- _ :- t)
-      cont = IG.Flip $ IG.PartialIso
-        (\(_ :- l :- t) -> 
-          let x = S.encodeOrShow' @Text S.datumIso l
-          in S.Unreadable [i|\#<continuation #{x}>|] :- t)
+        (\(env:-code:-t) -> [S.sx|(<closure> #{code} ##{env})|] :- t)
         (const . Left $ mempty)
 
 instance S.DatumIso Lambda where
-  datumIso = S.with (lam >>>)
+  datumIso = S.match
+    $ S.With (. lambda)
+    $ S.End
     where
-      lam :: forall t. G (Datum :- t) (Exp :- Name :- List Name :- t)
-      lam = S.lambdaLike
-        S.lambdaKeyword
-        binders
-        (S.el $ S.datumIso @Exp)
+      lambda = S.list $
+        S.el S.lambdaKeyword
+        >>> S.el binders
+        >>> S.el S.datumIso
       binders :: forall t. G (Datum :- t) (Name :- List Name :- t)
-      binders =
-        S.list (S.rest $ S.datumIso @Name)
-        >>> S.flipped S.snoced
-        >>> S.swap
+      binders = S.list $
+        S.rest (S.datumIso @Name)
+        >>> S.onTail (S.flipped $ IG.PartialIso
+                     (\(ktail:-args:-t) -> (args ++ [ktail]) :- t)
+                     (\(args:-t) -> case args ^? _Snoc of
+                         Just (args',ktail) -> Right $ ktail :- args' :- t
+                         Nothing -> Left $ S.expected "cont param")
+                     )
 
 instance S.DatumIso Kappa where
   datumIso = S.with \g ->
     S.lambdaLike S.kappaKeyword
-      (S.datumIso @(List Name))
+      (S.list $ S.rest (S.datumIso @Name))
       (S.el $ S.datumIso @Exp)
     >>> g
 
@@ -293,13 +260,13 @@ instance S.DatumIso Exp where
         >>> S.el S.datumIso
 
 instance S.DatumIso Program where
-  datumIso = S.with \prog -> S.datumIso @Lambda >>> prog
+  datumIso = S.with \prog -> S.datumIso @Exp >>> prog
 
 
 -- quasiquoters
 
 class Data a => CPS a where
-  toCPS :: HasCallStack => Datum -> a
+  toCPS :: Datum -> a
 
 instance CPS Exp where toCPS = S.fromDatumUnsafe S.datumIso
 instance CPS Val where toCPS = S.fromDatumUnsafe S.datumIso
@@ -348,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
@@ -363,3 +330,21 @@ 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.Stack.Lower
+import Gyehoek.CPS.Lower
 import Gyehoek.CPS.Eval qualified as CPS
 import Control.Monad
 import Text.Pretty.Simple (pShowNoColor)
@@ -26,7 +26,7 @@ import System.Environment.Blank (getEnvDefault)
 import qualified Data.Text.IO as TIO
 import qualified Data.ByteString.Lazy as BS
 import Gyehoek.CPS.Stackify (stackifyProgram)
-import Gyehoek.Stack.VM (eval, writeObj, Obj, traceEval)
+import Gyehoek.Stack.VM (eval, writeObj, Obj)
 import qualified Data.Text as T
 import Gyehoek.Stack.Syntax qualified as Stk
 import Gyehoek.CPS.Close (closeProgram)
@@ -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
@@ -126,7 +126,7 @@ driver opts = do
   dumpOrRun opts.dumpStackified (rt_is #Stackify)
     (stackifyProgram closedCps)
     (hPutStrLn FS.stdout <=< S.encodeDataWith S.dataIso)
-    (eval >=> fmap writeObj
+    (eval >>> fmap writeObj
          >>> T.unwords
          >>> hPutStrLn FS.stdout)
   when (rt_is #CPS) do
@@ -135,12 +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)
-  when opts.traceStackified do
-    stackifyProgram closedCps >>= traceEval
+  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
@@ -157,4 +155,4 @@ lower_e2e =
 eval_e2e :: FilePath -> IO (List Obj)
 eval_e2e fp = runJalmotIO . runFileSystem . runGenSym $ do
   stk <- stackifyProgram <=< closeProgram <=< convertProgram <=< readScm $ fp
-  eval stk
+  pure . eval $ stk

src/Gyehoek/Jalmot.hs

@@ -8,7 +8,6 @@ module Gyehoek.Jalmot
   , runJalmotIO
   , runJalmotIOE
   , runJalmotUnsafe
-  , runJalmotCS
   )
   where
 
@@ -30,7 +29,6 @@ deriving instance Data p => Data (Grammar.ErrorMessage p)
 data AJalmot
   = ReaderError (ParseErrorBundle Text Void)
   | GrammarError (Grammar.ErrorMessage Ann)
-  | VMError Text
   deriving (Show, Generic, Data)
 
 data AJalmotCS = MkAJalmotCS !CallStack !AJalmot
@@ -41,9 +39,6 @@ type Jalmot = Error AJalmot
 runJalmot :: Eff (Jalmot : es) a -> Eff es (Either (CallStack, AJalmot) a)
 runJalmot = runError
 
-runJalmotCS :: Eff (Jalmot : es) a -> Eff es (Either AJalmotCS a)
-runJalmotCS = (mapped . _Left %~ uncurry MkAJalmotCS) . runError
-
 runJalmotIOE :: IOE :> es => Eff (Jalmot : es) a -> Eff es a
 runJalmotIOE eff =
   runJalmot eff >>= \case
@@ -65,7 +60,6 @@ instance Exception AJalmot where
         pretty err
         & layoutPretty defaultLayoutOptions
         & renderString
-    VMError err -> [i|#{err}|]
 
 instance Exception AJalmotCS where
   backtraceDesired = const False

src/Gyehoek/Language.hs

@@ -1,4 +0,0 @@
-module Gyehoek.Language
-  (
-  ) where
-

src/Gyehoek/Options.hs

@@ -29,7 +29,6 @@ data Options = MkOptions
   , dumpCPS :: Bool
   , dumpParsed :: Bool
   , dumpStackified :: Bool
-  , traceStackified :: Bool
   , runtime :: Maybe Runtime
   , inspectWasm :: Bool
   , output :: FilePath
@@ -61,7 +60,6 @@ parser = do
   dumpCPS <- switch (long "dump-cps")
   dumpStackified <- switch (long "dump-stackified")
   dumpParsed <- switch (long "dump-parsed")
-  traceStackified <- switch (long "trace-stackified")
   inspectWasm <- switch $ long "inspect-wasm" <> short 'p'
   runtime <- option runtimeReader . fold $
     [ long "runtime"

src/Gyehoek/Prelude.hs

@@ -19,7 +19,6 @@ module Gyehoek.Prelude
   , (>>>)
   , (>=>)
   , (<=<)
-  , wrappedIso
   ) where
 
 import Control.Lens hiding (List, (:<))
@@ -41,5 +40,4 @@ import Data.List.NonEmpty (NonEmpty((:|)))
 import Numeric.Natural (Natural)
 import Control.Category ((>>>))
 import Control.Monad
-import Data.Generics.Wrapped (Wrapped(..))
 

src/Gyehoek/Scheme/Syntax.hs

@@ -51,7 +51,7 @@ import qualified Effectful.FileSystem.IO.ByteString as FB
 import qualified Data.Set.Ordered as O
 import Gyehoek.Sexp.Grammar qualified as Sexp
 import Gyehoek.Sexp.Grammar qualified as S
-import Gyehoek.Sexp.Grammar (DatumIso, G, DataIso, (:-)((:-)))
+import Gyehoek.Sexp.Grammar (DatumIso, DataIso)
 import Gyehoek.Prelude
 
 
@@ -81,13 +81,9 @@ data Prim e
   | PrimZeroP e
   | PrimNewline
   | PrimMakeClosure { code :: e, env :: List e }
-  | PrimEnv
-  | PrimEnvRef Int
+  | PrimEnvRef e Int
+  | PrimEnvCode e
   | PrimCallCC e
-  | PrimCaptureCC
-  | PrimInvokeCC e (List e)
-  | PrimValues (List e)
-  | PrimCallWithValues e e
   deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
   deriving anyclass (NFData)
 
@@ -110,7 +106,7 @@ data Exp
   = ExpLet (List (Name, Exp)) Exp
   | ExpLetRec (List (Name, Exp)) Exp
   | ExpPrim (Prim Exp)
-  | ExpBegin (NonEmpty Exp)
+  | ExpBegin (List Exp)
   | ExpIf Exp Exp Exp
   | ExpLit Lit
   | ExpLambda (List Name) Exp
@@ -166,25 +162,21 @@ primDatumIso namefn a = S.match
     $ S.With (. ht1 "integer?")
     $ S.With (. ht1 "write")
     $ S.With (. ht1 "zero?")
-    $ S.With (. ht0 "newline")
+    $ S.With (. nullop "newline")
     $ S.With (. ht1' "make-closure")
-    $ S.With (. ht0 "env")
-    $ S.With (. S.headTagged1 (namefn "env-ref") S.int)
+    $ S.With (. S.headTagged2 (namefn "env-ref") a S.int)
+    $ S.With (. ht1 "env-code")
     $ S.With (. ht1 "call/cc")
-    $ S.With (. ht0 "capture/cc")
-    $ S.With (. ht1' "invoke/cc")
-    $ S.With (. ht0' "values")
-    $ S.With (. ht2 "call-with-values")
     $ S.End
     where
       idn = S.el . S.sym . namefn
-      ht0 s = S.list $ idn s
+      nullop s = S.list $ idn s
       ht1 s = S.headTagged1 (namefn s) a
       ht2 s = S.headTagged2 (namefn s) a a
       ht1' s = S.headTagged1' (namefn s) a a
-      ht0' s = S.headTagged0' (namefn s) a
 
 instance DatumIso a => DatumIso (Prim a) where
+  -- datumIso = primDatumIso ("prim:"<>) datumIso
   datumIso = primDatumIso id S.datumIso
 
 instance DatumIso Lit where
@@ -211,7 +203,7 @@ instance DatumIso Exp where
     $ S.With (. S.letLike "let" S.datumIso S.datumIso S.datumIso)
     $ S.With (. S.letLike "letrec" S.datumIso S.datumIso S.datumIso)
     $ S.With (. S.datumIso)
-    $ S.With (. begin)
+    $ S.With (. S.beginLike "begin" S.datumIso)
     $ S.With (. S.ifLike "if" S.datumIso S.datumIso S.datumIso)
     $ S.With (. S.datumIso)
     $ S.With (. lam)
@@ -220,18 +212,12 @@ instance DatumIso Exp where
     $ S.End
     where
       lam = S.lambdaLike S.lambdaKeyword S.datumIso (S.el S.datumIso)
-      begin :: forall t. G (S.Datum :- t) (NonEmpty Exp :- t)
-      begin = S.beginLike "begin" $
-        S.el (S.datumIso @Exp) >>> S.rest (S.datumIso @Exp)
-        >>> S.onTail (S.Iso
-          (\(xs:-x:-t) -> (x:|xs):-t)
-          (\((x:|xs):-t) -> xs:-x:-t))
 
 instance DatumIso CommandOrDef where
   datumIso = S.match
     $ S.With (\_Command -> _Command . S.datumIso)
     $ S.With (\_Definition -> _Definition . S.datumIso)
-    $ S.With (\_Begin -> _Begin . S.beginLike "begin" (S.rest S.datumIso))
+    $ S.With (\_Begin -> _Begin . S.beginLike "begin" S.datumIso)
     $ S.End
 
 instance DataIso Program where

src/Gyehoek/Sexp/Grammar.hs

@@ -59,21 +59,19 @@ toData g =
   >>> runGrammar noAnn
   >>> either (throwError . GrammarError) pure
 
-fromDatum :: (HasCallStack, Jalmot :> es) => DatumGrammar a -> Datum -> Eff es a
+fromDatum :: Jalmot :> es => DatumGrammar a -> Datum -> Eff es a
 fromDatum g =
   forward (sealed g)
   >>> runGrammar noAnn
   >>> either (throwError . GrammarError) pure
 
-fromDatumUnsafe :: HasCallStack => DatumGrammar a -> Datum -> a
+fromDatumUnsafe :: DatumGrammar a -> Datum -> a
 fromDatumUnsafe g = runJalmotUnsafe . fromDatum g
 
-fromDataUnsafe :: HasCallStack => DataGrammar a -> List Datum -> a
+fromDataUnsafe :: DataGrammar a -> List Datum -> a
 fromDataUnsafe g = runJalmotUnsafe . fromData g
 
-fromData
-  :: (HasCallStack, Jalmot :> es)
-  => DataGrammar a -> List Datum -> Eff es a
+fromData :: Jalmot :> es => DataGrammar a -> List Datum -> Eff es a
 fromData g =
   forward (sealed g)
   >>> runGrammar noAnn

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -31,7 +31,6 @@ module Gyehoek.Sexp.Grammar.Base
   , number
   , integer
   , int
-  , unreadable
   -- * TODO: sort lol
   , prismIso
   , isoIso, decorate
@@ -41,7 +40,7 @@ module Gyehoek.Sexp.Grammar.Base
   , lambdaLike
   , lambdaKeyword
   , kappaKeyword
-  , beginLike, headTagged2', dottedList
+  , beginLike
   ) where
 
 import Data.InvertibleGrammar
@@ -56,7 +55,6 @@ import Data.Scientific (Scientific)
 import qualified Data.Scientific as Sci
 import qualified Data.Text as T
 import Control.Monad.RWS (modify)
-import qualified Data.List.NonEmpty as NE
 
 
 -- $setup
@@ -106,39 +104,6 @@ list
   -> G (Datum :- t) t'
 list = listWithIndentation Ordinary
 
--- |
--- >>> let grammar = with \g -> dottedList (el int) int >>> g
--- >>> decodeTest @(Int,Int) grammar "(1 . 2)"
--- ( 1
--- , 2
--- )
--- >>> let grammar = with \g -> dottedList (el int >>> el int) int >>> g
--- >>> decodeTest @(Int,Int,Int) grammar "(1 2 . 3)"
--- ( 1
--- , 2
--- , 3
--- )
-dottedList
-  :: forall t t' t''. G (ListContext :- t) (ListContext :- t')
-  -> G (Datum :- t') t''
-  -> G (Datum :- t) t''
-dottedList g final = begin >>> Dive (onTail (g >>> end) >>> final)
-  where
-    begin = locate >>> Flip (PartialIso
-      (\(x:-MkListContext xs:-t) -> case NE.nonEmpty xs of
-          Just xs' -> DotList xs' x :- t
-          Nothing -> error "fuck")
-      (\case
-          DotList xs x :- t -> Right $ x :- MkListContext (NE.toList xs) :- t
-          _ -> Left $ expected "dotted list"))
-    end :: Grammar Ann (ListContext :- t') t'
-    end = Flip $ PartialIso
-      (\t -> MkListContext [] :- t)
-      (\(MkListContext lst :- t) ->
-         case lst of
-           [] -> Right t
-           d:_ -> Left $ unexpectedDatum d)
-
 listWithIndentation
   :: Indentation
   -> G (ListContext :- t) (ListContext :- t')
@@ -360,13 +325,6 @@ 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
@@ -400,9 +358,9 @@ letLike kw name rhs e = listWithIndentation (NSpecial 1) $
 
 lambdaLike
   :: (forall t. G (Datum :- t) t)
-  -> G (Datum :- t1) (a :- t2)
-  -> G (ListContext :- a :- t2) (ListContext :- t3)
-  -> G (Datum :- t1) t3
+  -> DatumGrammar a
+  -> G (ListContext :- a :- t) (ListContext :- t')
+  -> G (Datum :- t) t'
 lambdaLike kw formals body = listWithIndentation (NSpecial 1) $
   el (decorate SynBuiltin >>> kw)
   >>> el formals
@@ -416,19 +374,11 @@ kappaKeyword = coproduct [ sym "κ", sym "kappa" ]
 
 beginLike
   :: Text
-  -> G (ListContext :- t) (ListContext :- t')
-  -> G (Datum :- t) t'
+  -> DatumGrammar a
+  -> G (Datum :- t) (List a :- t)
 beginLike kw g =
   listWithIndentation (NSpecial 0) $
-    el (symBuiltin kw) >>> g
-
--- | define a printed syntax for an object which cannot be read.
-unreadable
-  :: (t -> Text)
-  -> G (Datum :- t) t
-unreadable f = Flip $ PartialIso
-  (\t -> Unreadable (f t) :- t)
-  (const $ Left mempty)
+    el (symBuiltin kw) >>> rest g
 
 isoIso :: Iso' s a -> Grammar p (s :- t) (a :- t)
 isoIso l = iso (view l) (review l)

src/Gyehoek/Sexp/Print.hs

@@ -4,26 +4,21 @@ module Gyehoek.Sexp.Print
   , printDatum'
   , printData
   , printData'
-  , htmlDatum
-  , htmlData
   ) where
 
 import Gyehoek.Sexp.Syntax
-import Prettyprinter
+import Data.Text.Prettyprint.Doc
 import Data.Functor.Foldable
 import qualified Control.Comonad.Trans.Cofree as F
 import Prettyprinter.Util
 import Gyehoek.Prelude hiding (Simple, (:<))
-import Data.Foldable (traverse_, toList)
+import Data.Foldable (traverse_)
 import qualified Prettyprinter.Render.Terminal as ANSI
 import System.IO (stdout)
 import Prettyprinter.Render.Terminal (Color(..), color, italicized, AnsiStyle, bold, colorDull)
 import Prettyprinter.Render.Text (renderStrict)
 import qualified Data.Scientific as Sci
 import Data.List (intersperse)
-import Lucid
-import Prettyprinter.Render.Util.SimpleDocTree (treeForm)
-import Prettyprinter.Lucid (renderHtml)
 
 
 printDatum' :: Datum -> Text
@@ -36,31 +31,6 @@ printDatum' =
       { layoutPageWidth = AvailablePerLine 80 1.0
       }
 
-htmlDatum :: Datum -> Html ()
-htmlDatum =
-  prettyDatum 0
-  >>> layoutPretty opts
-  >>> treeForm
-  >>> fmap highlightHtml
-  >>> renderHtml
-  where
-    opts = LayoutOptions
-      { layoutPageWidth = AvailablePerLine 80 1.0
-      }
-
-htmlData :: Foldable f => f Datum -> Html ()
-htmlData =
-  foldr f mempty
-  >>> layoutPretty opts
-  >>> treeForm
-  >>> fmap highlightHtml
-  >>> renderHtml
-  where
-    f x y = prettyDatum 0 x <> hardline <> hardline <> y
-    opts = LayoutOptions
-      { layoutPageWidth = AvailablePerLine 80 1.0
-      }
-
 printDatum :: Datum -> Text
 printDatum = printDatumW 80
 
@@ -74,7 +44,7 @@ printDatumW :: Int -> Datum -> Text
 printDatumW w =
   prettyDatum 0
   >>> layoutSmart opts
-  >>> reAnnotateS highlightAnsi
+  >>> reAnnotateS highlight
   >>> ANSI.renderStrict
   where
     opts = LayoutOptions
@@ -84,13 +54,6 @@ printDatumW w =
 prettyDatum :: Int -> Datum -> Doc Syn
 prettyDatum depth datum = case datum of
   Simple simp -> annotate (datum ^. syntax) $ prettySimple depth simp
-  DotList xs x ->
-    pparen depth . group . align $
-      vsep [ vsep (prettyDatum (depth+1) <$> toList xs)
-           , "."
-           , prettyDatum (depth+1) x
-           ]
-      
   List' indent xs ->
     case indent of
       NSpecial n | keyword:args <- xs ->
@@ -124,14 +87,13 @@ prettySimple depth = \case
     & annotate SynConstant
   SimpleString s -> annotate SynString $ viaShow s
   SimpleSymbol s -> pretty s
-  SimpleUnreadable s -> pretty s
 
 putDoc :: Doc Syn -> IO ()
 putDoc = ANSI.renderIO stdout
-  . reAnnotateS highlightAnsi . layoutSmart defaultLayoutOptions . (<>"\n")
+  . reAnnotateS highlight . layoutSmart defaultLayoutOptions . (<>"\n")
 
-highlightAnsi :: Syn -> AnsiStyle
-highlightAnsi = \case
+highlight :: Syn -> AnsiStyle
+highlight = \case
   (SynBuiltin; SynMacro) -> color Magenta <> italicized <> bold
   SynProcedure -> color Blue
   SynConstant -> color Yellow
@@ -139,16 +101,3 @@ highlightAnsi = \case
   _ -> mempty
   where
     rainbow = cycle [Red,Yellow,Green,Blue,Magenta,Cyan]
-
-highlightHtml :: Syn -> Html () -> Html ()
-highlightHtml syn = span_ [class_ synClass]
-  where
-    synClass = case syn of
-      SynBuiltin -> "syn-builtin"
-      SynMacro -> "syn-macro"
-      SynConstant -> "syn-constant"
-      SynString -> "syn-string"
-      SynProcedure -> "syn-procedure"
-      SynVariable -> "syn-variable"
-      SynNone -> "syn-none"
-      SynParen n -> [i|syn-paren-#{mod n 5}|]

src/Gyehoek/Sexp/Syntax.hs

@@ -29,7 +29,6 @@ module Gyehoek.Sexp.Syntax
   , indentation
   , adorn
   , indentWith
-  , pattern Unreadable
   , pattern Bytevector
   , pattern Symbol
   , pattern String
@@ -80,7 +79,6 @@ data Simple
   | SimpleString Text
   | SimpleSymbol Text
   | SimpleBytevector ByteString
-  | SimpleUnreadable Text
   deriving stock (Show, Eq, Data, Generic, Lift)
   deriving anyclass (NFData)
 
@@ -232,7 +230,6 @@ pattern Character a = Simple (SimpleCharacter a)
 pattern String a = Simple (SimpleString a)
 pattern Symbol a = Simple (SimpleSymbol a)
 pattern Bytevector a = Simple (SimpleBytevector a)
-pattern Unreadable a = Simple (SimpleUnreadable a)
 
 
 --- Lift1 instances

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

@@ -14,11 +14,8 @@ module Gyehoek.Stack.Syntax
   , Imm(..)
   , Hob(..)
   , Prim(..)
-  , Name(..)
-  , Reg(..)
-  , Label(..)
+  , Name
   , pattern ValLabel
-  , pattern ObjLabel
   , stkP
   ) where
 
@@ -27,13 +24,13 @@ import qualified Gyehoek.Sexp as S
 import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..))
 import GHC.Exts (IsList(..))
 import Data.List (intersperse)
-import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), pattern ObjLabel, Reg, Label)
+import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), labelName)
 import Gyehoek.Prelude
 import Gyehoek.Sexp ((:-)((:-)))
 
 
 newtype Program = MkProgram
-  { routines :: HashMap Label Routine
+  { routines :: HashMap Name Routine
   }
   deriving stock (Show, Generic, Data)
   deriving newtype (Semigroup, Monoid)
@@ -47,7 +44,8 @@ instance IsList Program where
   toList = toListOf $ #routines . each
 
 data Routine = MkRoutine
-  { label :: Label
+  { label :: Name
+  , params :: List Name
   , start :: Block
   }
   deriving stock (Show, Generic, Data)
@@ -61,32 +59,27 @@ data Block = MkBlock
   deriving anyclass (NFData)
 
 data Tail
-  -- | call the procedure at stack index `n` supplied with `n`
-  -- arguments on top of the stack, then return by calling the
-  -- continuation at stack index `n+1`.
-  = TailCall Int
-  | Call Int
+  = TailCall Val (List Val)
   | If Val Block Block
-  | Return Int
-  | CallCC
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
 data Instr
-  = Pop Reg
+  = Pop Name
   | Push Val
-  | Load Reg Int
-  | Prim (Prim Val)
+  | PopCont Name
+  | PushCont Val
+  | Prim Name (Prim Val)
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
 data Val
-  = ValReg Reg
+  = ValReg Name
   | ValImm Imm
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
-pattern ValLabel :: Label -> Val
+pattern ValLabel :: Name -> Val
 pattern ValLabel x = ValImm (ImmLabel x)
 
 
@@ -96,10 +89,11 @@ pure []
 
 instance S.DatumIso Instr where
   datumIso = S.match
-    $ S.With (S.headTagged1 "pop!" S.datumIso >>>)
+    $ S.With (S.headTagged1 "pop!" regName >>>)
     $ 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.headTagged1 "pop-cont!" regName >>>)
+    $ S.With (S.headTagged1 "push-cont!" S.datumIso >>>)
+    $ S.With (S.headTagged2 "prim" regName S.datumIso >>>)
     $ S.End
     where
 
@@ -113,14 +107,10 @@ instance S.DataIso Block where
 
 instance S.DatumIso Tail where
   datumIso = S.match
-    $ S.With (S.headTagged1 "tail-call" S.datumIso >>>)
-    $ S.With (S.headTagged1 "call" S.datumIso >>>)
+    $ S.With (S.headTagged1' "tail-call" S.datumIso S.datumIso >>>)
     $ S.With (if_ >>>)
-    $ S.With (S.headTagged1 "return" S.datumIso >>>)
-    $ S.With (S.headTagged0 "call/cc" >>>)
     $ S.End
     where
-      -- if_ = S.ifLike "if" (S.datumIso @Val) S.datumIso S.datumIso
       if_ = S.ifLike "if" (S.datumIso @Val) (branch "then") (branch "else")
       branch :: Text -> S.DatumGrammar Block
       branch s =
@@ -130,7 +120,7 @@ instance S.DatumIso Tail where
 
 instance S.DatumIso Val where
   datumIso = S.match
-    $ S.With (S.datumIso >>>)
+    $ S.With (regName >>>)
     $ S.With (S.datumIso >>>)
     $ S.End
 
@@ -138,11 +128,16 @@ instance S.DatumIso Routine where
   datumIso = S.with \rout ->
       S.listWithIndentation (S.NSpecial 1)
        ( S.el (S.decorate S.SynBuiltin >>> S.sym "define")
-       >>> S.el (S.datumIso @Label)
+       >>> S.el (S.list $ S.el labelName >>> S.rest regName)
        >>> S.restData (S.dataIso @Block)
        )
       >>> rout
 
+regName :: S.DatumGrammar Name
+regName = S.decorate S.SynVariable >>> S.datumIso @Name >>> S.prismIso
+  (S.expected "register")
+  (prefixed @Name "%")
+
 instance S.DataIso Program where
   dataIso = S.dataIso @(List Routine) >>> S.iso fromList toList
 

src/Gyehoek/Stack/VM.hs

@@ -1,6 +1,4 @@
-{-# LANGUAGE ViewPatterns, MultilineStrings #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE ViewPatterns #-}
 module Gyehoek.Stack.VM
   ( VM(..)
   , Env(..)
@@ -8,327 +6,122 @@ module Gyehoek.Stack.VM
   , trace
   , module Gyehoek.Stack.Syntax
   , writeObj
-  , traceEval
   ) where
 
 import Gyehoek.Stack.Syntax
 import Control.Lens
 import qualified Data.HashMap.Strict as H
-import Data.List (unfoldr, intersperse, compareLength)
+import Data.List (unfoldr)
 import Gyehoek.Prelude
-import qualified Data.List.NonEmpty as NE
-import Lucid
-import Data.Foldable (traverse_)
-import qualified Gyehoek.Sexp as S
-import Gyehoek.Jalmot
-import Text.Pretty.Simple (pStringNoColor, pShowNoColor)
-import Effectful.State.Static.Local (runState, evalState, get)
-import Data.Traversable
-import Control.Applicative (Alternative(..))
-import Gyehoek.Sexp.Print (htmlData)
-import Control.DeepSeq (deepseq, ($!!))
-import Gyehoek.Sexp.Print (htmlData, htmlDatum)
-import Control.DeepSeq (deepseq, ($!!))
-import Data.String (fromString)
-import Data.Monoid (First)
-import GHC.Stack (popCallStack)
-import Data.Maybe (fromMaybe)
 
 
--- | non-essential information maintained only to aide in debugging.
-data DebugVM = MkDebugVM
-  { activeRoutine :: Label
-  }
-  deriving (Show, Generic)
-
-newtype Frame = MkFrame { locals :: List Obj }
-  deriving stock (Show, Generic)
-
--- affine
-returnAddress :: Traversal' Frame Obj
-returnAddress = #locals . _last
-
--- affine
-activeProcedure :: Traversal' Frame Obj
-activeProcedure = #locals . _init . _last
-
-newtype Stack = MkStack { frames :: NonEmpty Frame }
-  deriving stock (Show, Generic)
-
 data VM = MkVM
-  { stack :: Stack
+  { stack :: List Obj
+  , kstack :: List Name
   , code :: List Instr
   , tail :: Tail
-  , registers :: HashMap Reg Obj
+  , registers :: HashMap Name Obj
   , stdout :: Text
   , result :: Maybe (List Obj)
-  , debug :: DebugVM
   }
   deriving (Show, Generic)
 
-type instance Index Frame = Int
-type instance IxValue Frame = Obj
-
-instance Ixed Frame where
-  ix j = wrappedIso . ix j
-
-instance Cons Frame Frame Obj Obj where
-  _Cons = prism'
-    (\(x,MkFrame xs) -> MkFrame (x:xs))
-    \case
-      MkFrame (x:xs) -> Just (x, MkFrame xs)
-      MkFrame [] -> Nothing
-
-instance Each Frame Frame Obj Obj where each = wrappedIso . each
-
-instance Each Stack Stack Frame Frame where each = wrappedIso . each
-
-pushes :: Foldable f => f Obj -> Frame -> Frame
-pushes = flip $ foldr cons
-
-_NonEmpty :: Iso (NonEmpty a) (NonEmpty b) (a, List a) (b, List b)
-_NonEmpty = iso
-  (\(x:|xs) -> (x,xs))
-  (\(x,xs) -> x:|xs)
-
-pushFrame :: Frame -> Stack -> Stack
-pushFrame f (MkStack xs) = MkStack $ NE.cons f xs
-
-activeFrame :: Lens' VM Frame
-activeFrame = #stack . #frames . _NonEmpty . _1
-
 data Env = MkEnv
-  { labels :: HashMap Label Routine
+  { labels :: HashMap Name Routine
   }
   deriving (Show, Generic)
 
-step :: Jalmot :> es => Env -> VM -> Eff es VM
+step :: Env -> VM -> VM
 step g vm = case vm ^. #code of
   c:cs -> stepI g (vm & #code .~ cs) c
   [] -> stepT g vm vm.tail
 
-vmerror :: (HasCallStack, Jalmot :> es) => Text -> Eff es a
-vmerror = throwError . VMError
+stepI :: Env -> VM -> Instr -> VM
 
-stepI :: Jalmot :> es => Env -> VM -> Instr -> Eff es VM
+stepI e vm (Push v) = vm & #stack %~ (evalVal e vm v :)
 
-stepI e vm (Load r j) = do
-  x <- expectOf [i|object at index #{j}|] (activeFrame . ix j) vm
-  pure $ vm & #registers . at r ?~ x
+stepI e vm (PushCont k) = vm & #kstack %~ (evalToLabel e vm k :)
 
-stepI e vm (Push v) = traverseOf activeFrame push vm
-  where push xs = cons <$> evalVal e vm v <*> pure xs
-
-stepI g vm (Prim p) = stepP g vm p
-
-stepI e vm (Pop r) = case vm ^? activeFrame . _Cons of
-  Nothing -> vmerror "empty stack"
-  Just (x,xs) -> pure $ vm & #registers . at r ?~ x
-               & activeFrame .~ xs
-
-stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|]
-
-stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM
-
-stepT g vm tc@(Call nargs) = do
-  (args,f,ret,frm) <- parseCall nargs (vm ^. activeFrame)
-    & expectOf [i|bad call: #{show tc}|] _Just
-  rt <- getRoutine g f
-  let newFrame = MkFrame $ args ++ [f,ret]
-  pure $ vm
-    & jumpToRoutine rt
-    & activeFrame .~ frm
-    -- it is not essential we clear the registers, but it'll
-    -- make bugs more obvious.
-    & #registers .~ mempty
-    & #stack %~ \stk ->
-      case f of
-        ObjHob (HobContinuation {stack}) ->
-          coerce $ stack & _NonEmpty . _1 <>:~ (args ++ [f])
-        _ -> pushFrame newFrame stk
-
-stepT g vm tc@(Return nret) = do
-  (xs,_) <- splitAtExact nret (vm ^. activeFrame . #locals)
-    & expectOf [i|bad return: #{show tc}|] _Just
-  expectOf [i|no return addr|] (activeFrame . returnAddress) vm >>= \case
-    ObjLabel "halt" -> pure $ vm & #result ?~ xs
-    ra -> do
-      rt <- getRoutine g ra
-      vm & traverseOf #stack (fmap snd . popFrame)
-         & mapped . activeFrame %~ pushes xs
-         & mapped %~ jumpToRoutine rt
-         -- it is not essential we clear the registers, but it'll make
-         -- bugs more obvious.
-         & mapped . #registers .~ mempty
-
-stepT g vm tc@(TailCall nargs) = do
-  (args,f,ra) <- parseTailCall nargs (vm ^. activeFrame)
-    & expectOf [i|bad call: #{show tc}|] _Just
-  case f of
-    ObjLabel "halt" -> pure $ vm & #result ?~ args
-    _ -> do
-      rt <- getRoutine g f
-      let newFrame = MkFrame $ args ++ [f, ra]
-      pure $ vm
-        & jumpToRoutine rt
-        -- replace the active frame; don't push a new one.
-        & activeFrame .~ newFrame
-        -- it is not essential we clear the registers, but it'll make
-        -- bugs more obvious.
-        & #registers .~ mempty
-
-stepT g vm (If c t f) = do
-  branch <- evalVal g vm c <&> \case
-      ObjImm (ImmBool False) -> f
-      _ -> t
-  pure $ jumpToBlock branch vm
-
-stepT g vm CallCC = do
-  (cc,withcc,frm) <- parseCallCC (vm ^. activeFrame)
-    & expectOf "bad call/cc" _Just
-  let stk = vm.stack & #frames . _NonEmpty . _1 .~ frm
-  let reified_cc = ObjHob $ HobContinuation cc (coerce stk)
-  let newFrame = MkFrame [reified_cc, withcc, cc]
-  rt <- getRoutine g withcc
-  pure $ vm
-    & jumpToRoutine rt
-    -- replace the active frame; don't push a new one.
-    & activeFrame .~ newFrame
-    -- it is not essential we clear the registers, but it'll make
-    -- bugs more obvious.
-    & #registers .~ mempty
-
-stepP :: Jalmot :> es => Env -> VM -> Prim Val -> Eff es VM
-stepP g vm p = traverse (evalVal g vm) p >>= \case
+stepI e vm (Prim r p) = case evalVal e vm <$> p of
   PrimZeroP x -> case x of
-    ObjImm (ImmInt n) -> ret1 . ObjImm . ImmBool $ n == 0
-    _ -> vmerror [i|bad arg to zero?: #{x}|]
+    ObjImm (ImmInt n) -> ret . ObjImm . ImmBool $ n == 0
+    _ -> error [i|bad arg to zero?: #{x}|]
   PrimAdd x y -> arith_binop (+) x y
   PrimMul x y -> arith_binop (*) x y
   PrimSub x y -> arith_binop (-) x y
   PrimDiv x y -> arith_binop div x y
   PrimMakeClosure f env ->
     case f of
-      ObjImm (ImmLabel l) -> ret1 . ObjHob $ HobClosure l env
-      _ -> vmerror [i|expected label, got #{f}|]
-  PrimEnv -> do
-    x <- vm & expectOf "expected closure" (activeFrame . activeProcedure)
-    ret1 x
-  PrimEnvRef n -> do
-    (label,env) <- vm & expectOf "expected closure"
-        (activeFrame . activeProcedure . #_ObjHob . #_HobClosure) 
-    x <- env & expectOf "expected upval" (ix n)
-    ret1 x
-  PrimCons x y -> ret1 $ ObjHob $ HobPair x y
-  PrimCar x -> case x of
-      ObjHob (HobPair car _) -> ret1 car
-      _ -> vmerror [i|expected pair, got ${x}|]
-  PrimCdr x -> case x of
-      ObjHob (HobPair _ cdr) -> ret1 cdr
-      _ -> vmerror [i|expected pair, got ${x}|]
-  -- PrimCaptureCC -> do
-  --   label <- vm & expectOf [i|bad stack, no return addr|]
-  --     (activeFrame . returnAddress . #_ObjImm . #_ImmLabel)
-  --   ret1 . ObjHob $ HobContinuation { label }
-  x -> vmerror [i|unimplemented prim: #{p}|]
+      ObjImm (ImmLabel l) -> ret . ObjHob $ HobClosure l env
+      _ -> error [i|expected label, got #{f}|]
+  PrimEnvCode env ->
+    case env of
+      ObjHob (HobClosure l _) -> ret . ObjImm . ImmLabel $ l
+      _ -> error [i|expected closure, got #{env}|]
+  PrimEnvRef env n ->
+    case env of
+      ObjHob (HobClosure _ xs) -> ret $ xs ^?! ix n
+      _ -> error [i|expected closure, got #{env}|]
+  x -> error [i|unimplemented prim: #{p}|]
   where
-    ret vs = pure $ vm & activeFrame . #locals <>:~ vs
-    ret1 v = ret [v]
+    ret v = vm & #registers . at r ?~ v
     arith_binop op (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
-      ret1 $ ObjImm (ImmInt (op x y))
-    arith_binop _ x y = vmerror [i|bad arith: #{x}, #{y}|]
+      ret $ ObjImm (ImmInt (op x y))
+    arith_binop _ x y = error [i|bad arith: #{x}, #{y}|]
 
-
+stepI e vm (Pop r) = case vm ^. #stack of
+  [] -> error "empty stack"
+  (x:xs) -> vm & #registers . at r ?~ x
+               & #stack .~ xs
 
-popFrame :: (HasCallStack, Jalmot :> es) => Stack -> Eff es (Frame, Stack)
-popFrame stk = case stk ^. #frames . to NE.uncons of
-  (_, Nothing) -> vmerror "no frame to pop"
-  (f, Just fs) -> pure (f, stk & #frames .~ fs)
+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
 
-jumpToBlock :: Block -> VM -> VM
-jumpToBlock b vm = vm
-  & #code .~ b.code
-  & #tail .~ b.tail
+stepI e vm ins = error [i|unimplemented instruction: #{ins}|]
 
-jumpToRoutine :: Routine -> VM -> VM
-jumpToRoutine rt vm = vm
-  & jumpToBlock rt.start
-  & #debug . #activeRoutine .~ rt.label
+stepT :: Env -> VM -> Tail -> VM
 
-getLabel :: Obj -> Maybe Label
-getLabel = \case
-  ObjHob (HobClosure {label}) -> Just label
-  ObjHob (HobContinuation {cont}) -> getLabel cont
-  ObjImm (ImmLabel label) -> Just label
-  x -> Nothing
+stepT g vm (TailCall f xs) =
+  case evalToLabel g vm f of
+    "halt" -> vm & #result ?~ fmap (evalVal g vm) xs
+    l -> vm & #code .~ rt.start.code
+            & #tail .~ rt.start.tail
+            & #registers .~
+              fmap (evalVal g vm) (H.fromList $ rt.params `zip` xs)
+      where
+        rt = case g ^. #labels . at l of
+          Nothing -> error [i|undefined label: #{l}|]
+          Just x -> x
 
-getRoutine :: (HasCallStack, Jalmot :> es) => Env -> Obj -> Eff es Routine
-getRoutine g f = do
-  l <- getLabel f & expectOf [i|no label for #{f}|] _Just
-  case g ^. #labels . at l of
-    Just rt -> pure rt
-    Nothing -> vmerror [i|undefined label #{l}|]
+stepT g vm (If c t f) = vm & #code .~ branch.code & #tail .~ branch.tail
+  where
+    branch = case evalVal g vm c of
+      ObjImm (ImmBool False) -> f
+      _ -> t
 
-expectOf
-  :: (HasCallStack, Jalmot :> es)
-  => Text -> Getting (First a) s a -> s -> Eff es a
-expectOf msg l = maybe (vmerror msg) pure . preview l
-
-evalToLabel :: Jalmot :> es => Env -> VM -> Val -> Eff es Label
 evalToLabel e vm v =
-  evalVal e vm v >>= \case
-    ObjImm (ImmLabel x) -> pure x
-    x -> vmerror [i|not a label: #{x}|]
+  case evalVal e vm v of
+    ObjImm (ImmLabel x) -> x
+    x -> error [i|not a label: #{x}|]
 
-evalVal :: Jalmot :> es => Env -> VM -> Val -> Eff es Obj
+evalVal :: Env -> VM -> Val -> Obj
 evalVal e vm = \case
-  ValImm imm -> pure $ ObjImm imm
+  ValImm imm -> ObjImm imm
   ValReg r -> case vm ^. #registers . at r of
-    Just x -> pure x
-    Nothing -> vmerror [i|undefined register: #{r}|]
-
-splitAtExact :: Int -> List a -> Maybe (List a, List a)
-splitAtExact n xs = case compareLength xs n of
-  (EQ;GT) -> Just $ splitAt n xs
-  LT -> Nothing
-
-takeExact :: Int -> List a -> Maybe (List a)
-takeExact n xs = case compareLength xs n of
-  (EQ;GT) -> Just $ take n xs
-  LT -> Nothing
-
-parseCallCC :: Frame -> Maybe (Obj, Obj, Frame)
-parseCallCC frm = do
-  ([cc,withcc],ys) <- splitAtExact 2 (frm ^. #locals)
-  pure (cc,withcc,MkFrame ys)
-
-parseCall :: Int -> Frame -> Maybe (List Obj, Obj, Obj, Frame)
-parseCall nargs frm = do
-  (xs,ys) <- splitAtExact (nargs+2) (frm ^. #locals)
-  let (xs',[f,ret]) = splitAt nargs xs
-  pure (xs',f,ret,MkFrame ys)
-
-parseTailCall :: Int -> Frame -> Maybe (List Obj, Obj, Obj)
-parseTailCall nargs frm = do
-  (xs,_) <- splitAtExact (nargs+1) (frm ^. #locals)
-  let (xs',f) = xs ^?! _Snoc
-  pure (xs',f,frm ^?! returnAddress)
+    Just x -> x
+    Nothing -> error [i|undefined register: #{r}|]
 
 initialVM :: VM
 initialVM = MkVM
-  { stack = MkStack . NE.singleton . MkFrame $
-    [ ObjLabel "start"
-    , ObjLabel "<nowhere at all>"
-    , ObjLabel "halt"
-    ]
-  , tail = TailCall 0
+  { stack = []
+  , kstack = ["halt"]
   , code = []
+  , tail = TailCall (ValLabel "main") []
   , registers = mempty
   , stdout = ""
   , result = Nothing
-  , debug = MkDebugVM
-    { activeRoutine = "<nowhere>"
-    }
   }
 
 initialEnv :: Program -> Env
@@ -341,181 +134,23 @@ loop f a = case f a of
   Right a' -> loop f a'
   Left b -> b
 
-loopM :: Monad m => (a -> m (Either b a)) -> a -> m b
-loopM f a = f a >>= \case
-  Right a' -> loopM f a'
-  Left b -> pure b
+eval :: Program -> List Obj
+eval p = initialVM & loop \vm -> case vm ^. #result of
+  Nothing -> Right $ step (initialEnv p) vm
+  Just rs -> Left rs
 
-eval :: Jalmot :> es => Program -> Eff es (List Obj)
-eval p = initialVM & loopM \vm -> case vm ^. #result of
-  Nothing -> Right <$> step (initialEnv p) vm
-  Just rs -> pure . Left $ rs
-
-data Trace
-  = Step { vm :: VM, next :: Trace }
-  | StepToSuccess { vm :: VM, result :: List Obj }
-  | StepToFailure { vm :: VM, err :: AJalmotCS }
-  deriving (Show)
-
-trace :: Program -> Trace
-trace p = go (initialEnv p) initialVM
-  where
-    go g vm =
-      case vm.result of
-        Just rs -> StepToSuccess vm rs
-        Nothing ->
-          case runPureEff . runJalmotCS $ step g vm of
-            Left err -> StepToFailure vm err
-            Right vm' -> Step vm (go g vm')
+trace :: Program -> List VM
+trace p = initialVM & unfoldr \vm ->
+    case vm.result of
+      Just _ -> Nothing
+      Nothing -> Just (vm, step e vm)
+  where e = initialEnv p
 
 writeObj :: Obj -> Text
-writeObj = runJalmotUnsafe . S.encodeWith' S.datumIso
-
-traceEval :: IOE :> es => Program -> Eff es ()
-traceEval p = do
-  let t = trace p
-  liftIO . renderToFile "trace.html" . ppDoc p $ t
-
-ppDoc :: Program -> Trace -> Html ()
-ppDoc p t =
-  html_ do
-    head_ do
-      title_ "stackify trace"
-      style_ """
-        pre {
-          max-width: 95vw;
-          overflow: scroll;
-        }
-        table {
-          max-width: 95vw;
-        }
-        tbody > tr:nth-of-type(even) {
-            background-color: rgb(237 238 242);
-        }
-        .loc {
-            font-size: 0.8rem;
-        }
-        .syn-builtin, .syn-macro {
-            color: purple;
-            font-style: italic;
-            font-weight: bold;
-        }
-        .syn-constant {
-            color: olive;
-        }
-        .syn-procedure {
-            color: teal;
-        }
-        td pre {
-          display: inline
-        }
-        .syn-paren-0 { color: maroon; }
-        .syn-paren-1 { color: olive; }
-        .syn-paren-2 { color: green; }
-        .syn-paren-3 { color: navy; }
-        .syn-paren-4 { color: purple; }
-        .stack-frame
-        { display: inline-flex
-        ; flex-direction: row
-        ; column-gap: 0.5em
-        }
-      """
-    body_ do
-      details_ do
-        summary_ "stack code"
-        pre_ $ code_ do
-          htmlData . runJalmotUnsafe . S.toData S.dataIso $ p
-      ppTrace t
-
-ppTrace :: Trace -> Html ()
-ppTrace trace =
-  table_ do
-    thead_ $ tr_ do
-      traverse_ (th_ [scope_ "col"])
-        ["routine","next instruction","stack frame"]
-    tbody_ do
-      go trace
-  where
-    go :: Trace -> Html ()
-    go = \case
-      Step vm next -> ppVM vm >> go next
-      StepToSuccess vm rs -> do
-        tr_ [class_ "trace-result"] do
-          td_ do
-            details_ do
-              summary_ "result"
-              pre_ do
-                code_ . toHtml . pShowNoColor $ vm
-          td_ [colspan_ "2"] do
-            sequence_ . intersperse " | " $ code_ . ppDatum <$> rs
-      StepToFailure vm err -> do
-        ppVM vm
-        tr_ [class_ "trace-failure"] do
-          td_ [colspan_ "3"] do
-            details_ do
-              summary_ "error"
-              pre_ do
-                samp_ do
-                  fromString $ displayException err
-
-ppVM :: VM -> Html ()
-ppVM vm = do
-  tr_ do
-    td_ do
-      details_ do
-        summary_ do
-          var_ [class_ "loc"] do
-            vm ^. #debug . #activeRoutine . to ppDatum
-        pre_ do
-          code_ . toHtml . pShowNoColor $ vm
-    td_ do
-      code_ curi
-    td_ do
-      ppStack vm.stack
-  where
-    curi = vm ^?! failing (#code . _head . to ppDatum) (#tail . to ppDatum)
-
-ppStack :: Stack -> Html ()
-ppStack stk = do
-  span_ [class_ "stack"] do
-    stk ^.. each
-      & fmap ppFrame
-      & intersperse " | "
-      & sequence_
-
-ppFrame :: Frame -> Html ()
-ppFrame frm = do
-  span_ [class_ "stack-frame"] do
-    sequence_ $ frm ^.. #locals . each . to ppDatum
-
-ppData :: S.DataIso a => a -> Html ()
-ppData = htmlData . runJalmotUnsafe . S.toData S.dataIso
-
-ppDatum :: S.DatumIso a => a -> Html ()
-ppDatum = htmlDatum . runJalmotUnsafe . S.toDatum S.datumIso
-
-fac (n :: Int) = [stkP|
-(define $start
-  (push! $fac)
-  (push! #{n})
-  (tail-call 1))
-
-(define $fac
-  (load %n 0)
-  (prim %x0 (zero? %n))
-  (if %x0
-      (then (push! 1)
-            (return 1))
-      (else (prim %x1 (- %n 1))
-            (push! $fac-c0)
-            (push! $fac)
-            (push! %x1)
-            (call 1))))
-
-(define $fac-c0
-  (pop! %x2)
-  (pop! %n)
-  (prim %x3 (* %n %x2))
-  (push! %x3)
-  (return 1))
-|]
+writeObj (ObjImm im) = case im of
+  ImmInt n -> [i|#{n}|]
+  ImmBool True -> "#t"
+  ImmBool False -> "#f"
+  ImmLabel l -> "#<procedure>"
+writeObj (ObjHob h) = case h of
+  HobClosure code env -> "#<procedure>"

t.scm

@@ -1,5 +0,0 @@
-((λ ()
-   (* 2 (call/cc
-         (λ (k)
-           (begin (k 6)
-                  3))))))

test/Gyehoek/Test/CPS/Eval.hs

@@ -5,12 +5,9 @@ import Test.Tasty.HUnit
 import Gyehoek.CPS.Syntax (cps, Obj(..), Hob(..), Imm(..))
 import Gyehoek.CPS.Eval qualified as Sut
 import Data.List (List)
-import Test.Tasty.ExpectedFailure (ignoreTestBecause)
 
 
-test_cpsInterpreter =
-  ignoreTestBecause "i forgorrrr" $
-  testGroup "cps interpreter" $
+test_cpsInterpreter = testGroup "cps interpreter" $
   [ primitives
   , testCase "halt with constant" do
       evalsTo [ObjImm (ImmInt 123)] [cps|
@@ -37,8 +34,8 @@ test_cpsInterpreter =
       |]
   ]
 
-evalsTo :: HasCallStack => List Obj -> Sut.Exp -> Assertion
-evalsTo rs e = Sut.evalExp e @?= rs
+evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion
+evalsTo rs p = Sut.evalProgram p @?= rs
 
 primitives = testGroup "primitives"
   [ testGroup "arith"

test/Gyehoek/Test/CPS/Stackify.hs

@@ -4,12 +4,10 @@ import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit
 import qualified Gyehoek.CPS.Stackify as Sut
 import Gyehoek.Stack.VM as Stk
+import Data.List (List)
 import Gyehoek.CPS.Syntax (cps)
-import Gyehoek.CPS.Syntax qualified as CPS
 import Gyehoek.GenSym (runGenSym)
 import Effectful
-import Gyehoek.Prelude
-import Gyehoek.Jalmot
 
 
 test_stackify =
@@ -20,44 +18,40 @@ test_stackify =
   , procedure
   ]
 
-evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion
-evalsTo rs e = runJalmotUnsafe (Stk.eval e') @?= rs
-  where
-    e' = e & Sut.stackifyProgram & runGenSym & runPureEff
+evalsTo :: List Obj -> Sut.Exp -> Assertion
+evalsTo rs e =
+  Stk.eval e' @?= rs
+  where e' = runPureEff . runGenSym $ Sut.stackifyExp "main" e
 
 trivialReturn = testGroup "trivial return"
   [ testCase "return int" do
       evalsTo [ObjImm (ImmInt 4)]
-        [cps|(λ (ktail) (continue ktail 4))|]
+        [cps|(continue halt 4)|]
   , testCase "return bool" do
       evalsTo [ObjImm (ImmBool True)]
-        [cps|(λ (ktail) (continue ktail #t))|]
+        [cps|(continue halt #t)|]
       evalsTo [ObjImm (ImmBool False)]
-        [cps|(λ (ktail) (continue ktail #f))|]
+        [cps|(continue halt #f)|]
   ]
 
 tailCall = testGroup "tail call"
   [ testCase "square" do
-      evalsTo [ObjImm (ImmInt 16)] [cps|
-        (λ (ktail0)
-          (letrec ((square (λ (x ktail)
-                             (prim (* x x)
-                               (κ (x0) (continue ktail x0))))))
-            (square 4 halt)))
-      |]
+      evalsTo [ObjImm (ImmInt 16)]
+        [cps|(letrec ((square (λ (x ktail)
+                                (prim (* x x)
+                                  (κ (x0) (continue ktail x0))))))
+               (square 4 halt))|]
   ]
 
 prim = testGroup "prim"
   [ testCase "multiply" do
       evalsTo [ObjImm (ImmInt 20)]
-        [cps|(λ (ktail0)
-            (prim (* 4 5)
-               (κ (x) (continue ktail0 x))))|]
+        [cps|(prim (* 4 5)
+               (κ (x) (continue halt x)))|]
   , testCase "add" do
       evalsTo [ObjImm (ImmInt 9)]
-        [cps|(λ (ktail0)
-        (prim (+ 4 5)
-               (κ (x) (continue ktail0 x))))|]
+        [cps|(prim (+ 4 5)
+               (κ (x) (continue halt x)))|]
   -- , testGroup "call/cc"
   --   [ testCase "trivial" do
   --       evalsTo [ObjImm (ImmInt 123)]
@@ -68,17 +62,14 @@ prim = testGroup "prim"
 
 condition = testCase "if" do
   evalsTo [ObjImm (ImmInt 123)]
-    [cps|(λ (ktail0)
-      (if #t (continue ktail0 123) (continue ktail0 456)))|]
+    [cps|(if #t (continue halt 123) (continue halt 456))|]
   evalsTo [ObjImm (ImmInt 456)]
-    [cps|(λ (ktail0)
-      (if #f (continue ktail0 123) (continue ktail0 456)))|]
+    [cps|(if #f (continue halt 123) (continue halt 456))|]
 
 procedure = testGroup "procedure"
   [ testCase "factorial" do
       evalsTo [ObjImm (ImmInt 720)]
-        [cps|(λ (ktail0)
-          (letrec ((fac (λ (n ktail)
+        [cps|(letrec ((fac (λ (n ktail)
                              (prim (zero? n)
                                (κ (x0)
                                  (if x0
@@ -91,5 +82,5 @@ procedure = testGroup "procedure"
                                                       (κ (x3)
                                                         (continue ktail x3))))))
                                          (fac x1 fac-k0))))))))))
-               (fac 6 halt)))|]
+               (fac 6 halt))|]
   ]

test/Gyehoek/Test/CPS/Syntax.hs

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

test/Gyehoek/Test/Golden.hs

@@ -29,8 +29,11 @@ brokenWasmTests =
 
 brokenStackifyTests :: List String
 brokenStackifyTests =
-  [
-  ]
+  []
+  -- [ "adder"
+  -- , "let-fn"
+  -- , "callcc-nested1" -- requires closure-conversion
+  -- ]
 
 test_root :: IO TestTree
 test_root = do

test/Gyehoek/Test/Stack/VM.hs

@@ -6,106 +6,70 @@ import Test.Tasty.HUnit
 import Gyehoek.Stack.Syntax
 import Gyehoek.Stack.VM qualified as Sut
 import Data.List (List)
-import Gyehoek.Jalmot
-import Gyehoek.Prelude (i)
 
 
 evalsTo :: List Obj -> Program -> Assertion
-evalsTo rs p = runJalmotUnsafe (Sut.eval p) @?= rs
+evalsTo rs p = Sut.eval p @?= rs
 
 test_root = testGroup "stack machine"
-  [ testCase "immediate halt" do
-      evalsTo [] [stkP|
-        (define $start
-          (return 0))
-      |]
-  , testCase "lit int" do
+  [ testCase "lit int" do
       evalsTo [ObjImm (ImmInt 3)] [stkP|
-        (define $start
-          (push! 3)
-          (return 1))
-      |]
-  , testCase "non-tail identity function" do
-      evalsTo [ObjImm (ImmInt 123)] [stkP|
-        (define $id
-          (return 1))
-        (define $c
-          (return 1))
-        (define $start
-          (push! $c)
-          (push! $id)
-          (push! 123)
-          (call 1))
-      |]
-  , testCase "tail identity function" do
-      evalsTo [ObjImm (ImmInt 123)] [stkP|
-        (define $id
-          (return 1))
-        (define $start
-          (push! $id)
-          (push! 123)
-          (tail-call 1))
+        (define ($main)
+          (pop-cont! %ktail)
+          (tail-call %ktail 3))
       |]
   , testCase "return constant" do
       evalsTo [ObjImm (ImmInt 123)] [stkP|
-        (define $start
-          (push! $silly)
-          (tail-call 1))
-        (define $silly
-          (push! 123)
-          (return 1))
+        (define ($main)
+          (tail-call $silly))
+        (define ($silly)
+          (pop-cont! %ktail)
+          (tail-call %ktail 123))
       |]
-  , testCase "return multiple" do
-      evalsTo [ObjImm (ImmInt n) | n <- [1,2,3]] [stkP|
-        (define $start
-          (push! 3)
-          (push! 2)
-          (push! 1)
-          (return 3))
-      |]
-  , testCase "return none" do
-      evalsTo [] [stkP|
-        (define $start
-          (return 0))
+  , testCase "identity function" do
+      evalsTo [ObjImm (ImmInt 45)] [stkP|
+        (define ($main)
+          (tail-call $id 45))
+        (define ($id %x)
+          (pop-cont! %ktail)
+          (tail-call %ktail %x))
       |]
+  -- , testCase "square" do
+  --     evalsTo [ObjImm (ImmInt 16)] [stkP|
+  --       (define ($main))
+  --     |]
   , testCase "square" do
       evalsTo [ObjImm (ImmInt 16)] [stkP|
-        (define $start
-          (push! $square)
-          (push! 4)
-          (tail-call 1))
-        (define $square
-          (pop! %x)
-          (prim (* %x %x))
-          (return 1))
+        (define ($main)
+          (tail-call $square 4))
+        (define ($square %x)
+          (prim %x2 (* %x %x))
+          (pop-cont! %ktail)
+          (tail-call %ktail %x2))
       |]
-  , testGroup "factorial"
-      let
-        hsfac (n :: Int) = foldr @List (*) 1 [1..n]
-        fac (n :: Int) = [stkP|
-          (define $start
-            (push! $fac)
-            (push! #{n})
-            (tail-call 1))
-          (define $fac
-            (load %n 0)
-            (prim (zero? %n))
-            (pop! %x0)
-            (if %x0
-                (then (push! 1)
-                      (return 1))
-                (else (push! $fac-c0)
-                      (push! $fac)
-                      (prim (- %n 1))
-                      (call 1))))
-          (define $fac-c0
-            (pop! %x2)
-            (pop! %n)
-            (prim (* %n %x2))
-            (return 1))
-      |]
-        mkcase n = testCase [i|#{n}|] do
-          evalsTo [ObjImm . ImmInt $ hsfac n] $ fac n
+  , testCase "factorial" do
+      let hsfac (n :: Int) = foldr (*) (1) [1..n]
+      let fac (n :: Int) = [stkP|
+            (define ($fac %n)
+              (prim %x0 (zero? %n))
+              (if %x0
+                (then (pop-cont! %ktail)
+                      (tail-call %ktail 1))
+                (else (push! %n)
+                      (prim %x1 (- %n 1))
+                      (push-cont! $fac-k0)
+                      (tail-call $fac %x1))))
+            (define ($fac-k0 %x2)
+              (pop! %n)
+              (prim %x3 (* %x2 %n))
+              (pop-cont! %ktail)
+              (tail-call %ktail %x3))
+            (define ($main)
+              (tail-call $fac #{n}))
+          |]
+      evalsTo [ObjImm (ImmInt 1)] $ fac 0
+      evalsTo [ObjImm (ImmInt 1)] $ fac 1
+      evalsTo [ObjImm (ImmInt 720)] $ fac 6
       -- 20 is the greatest `n` for which n! ≤ maxBount @Int
-      in [ mkcase n | n <- [0,1,6,20] ]
+      evalsTo [ObjImm (ImmInt 2432902008176640000)] $ fac 20
   ]