return, pushcall

doc/liveness.org

@@ -1,88 +0,0 @@
-* example
-
-#+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 (pop! %_) ; [ $fac-c0 n $fac ktail1 ]
-              (pop! %_) ; [ n $fac ktail1 ]
-              (pop! %_) ; [ $fac ktail1 ]
-              (push! 1) ; [ ktail1 ]
-              (return 1)) ; [ 1 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
-

doc/make-vm-stackier.org

@@ -7,62 +7,94 @@ 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
 
-** Scheme source
-
 #+begin_src scheme
-(* 2 (call/cc
+  (letrec ((fac (λ (n)
-      (λ (cc)
+                (if (zero? n)
-        (begin (cc 6)
+                    1
-               3))))
+                    (* n (fac (- n 1)))))))
+  (fac 3))
 #+end_src
 
-** CPS
-
 #+begin_src scheme
-(λ (ktail0)
+  (λ (ktail0)
-  (letrec ((with-cc
+  (letrec ((fac
-            (λ (cc ktail1)
+            (λ (n ktail1)
-              (letrec ((k0 (κ (_)
+              (zero?
-                              (continue ktail1 3))))
+               n
-                (cc 6 k0)))))
+               (κ (x0)
-    (prim (call/cc with-cc)
+                  (if x0
-          (κ (x1)
+                      (continue ktail1 1)
-             (prim (* 2 x1)
+                      (- n 1
-                   (κ (x2) (continue ktail0 x2)))))))
+                         (κ (x1)
+                            (fac x1
+                                 (κ (x2)
+                                    (* n x2 ktail1)))))))))))
+    (fac 3)))
 #+end_src
 
-** stack VM
+#+begin_example
+n ktail1
+| |
+| | x0
+| | |
+| | ^
+| |
+| | x1
+| | |
+| | ^
+| | 
+| | x2
+| | |
+^ ^ ^
+#+end_example
 
 #+begin_src scheme
-;; (call n) expects `n' values on the stack as arguments. then the
+  (define $fac-c0
-;; procedure is expected at index `n', and the return continuation
+    (pop! %x0 0) ; [ x0 $fac-c0 n $fac ktail1 ]
-;; should be at `n+1'.
+    (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 $k0
+  (define $fac-c1
-  (pop! %_) ; [ _ ret ]
+    (pop! %x2) ; [ x2 $fac-c1 $fac-c0 n $fac ktail1 ]
-  (push! 3) ; [ ret ]
+    (load %n 3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
-  (tail-call 1) ; [ 3 ret ]
+    (prim %x3 (* %n %x2))
-  )
+    (push! %x3) ; [ $fac-c1 $fac-c0 n $fac ktail1 ]
+    (return 1) ; [ x3 $fac-c1 $fac-c0 n $fac ktail1 ]
+    )
 
-(define $with-cc
+  (define $fac
-  (pop! %cc) ; [ cc ret ]
+    (load %ktail1 2) ; [ n $fac ktail1 ]
-  (push! $k0) ; [ ret ]
+    (load %n 0) ; [ n $fac ktail1 ]
-  (push! %cc) ; [ $k0 ret ]
+    (push! $fac-c0) ; [ n $fac ktail1 ]
-  (push! 6) ; [ cc $k0 ret ]
+    (push! $zero?) ; [ $fac-c0 n $fac ktail1 ]
-  ;; call a procedure with one argument.
+    (push! %n) ; [ $zero? $fac-c0 n $fac ktail1 ]
-  (call 1) ; [ 6 cc $k0 ret ]
+    (call 1) ; [ n $zero? $fac-c0 n $fac ktail1 ]
-  )
+    )
 
-(define $main
+  (define $start
-  (pop! %ktail0) ; [ ret ]
+    (push! $fac) ; [ $start ktail0 ]
-  (prim %x1 (call/cc $with-cc)) ; []
+    (push! 3) ; [ $fac $start ktail0 ]
-  (prim %x2 (* 2 %x1)) ; []
+    (tail-call 1) ; [ 3 $fac $start ktail0 ]
-  (push! %ktail0) ; []
+    ;; ↑ `tail-call' knows how to dispose of the caller's stack frame.
-  (push! %x2) ; [ ret ]
+    )
-  (tail-call 1) ; [ %x2 ret ]
-  )
 #+end_src
 

src/Gyehoek/CPS/Syntax.hs

@@ -70,12 +70,12 @@ 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)
+  deriving anyclass (NFData, Wrapped)
 
 newtype Reg = MkReg { inner :: Name }
   deriving stock (Generic, Data)
   deriving newtype (Show, Eq, Gen, IsString, Hashable)
-  deriving anyclass (NFData)
+  deriving anyclass (NFData, Wrapped)
 
 data Imm
   = ImmInt Int
@@ -95,7 +95,7 @@ pattern ObjLabel l = ObjImm (ImmLabel l)
 
 -- | a heap object.
 data Hob
-  = HobClosure { label :: Name, env :: List Obj }
+  = HobClosure { label :: Label, env :: List Obj }
   | HobPair Obj Obj
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
@@ -213,7 +213,7 @@ instance S.DatumIso Hob where
     where
       conspair = S.dottedList (S.el S.datumIso) S.datumIso
       -- closures can be printed, but not parsed.
-      closure :: G (Datum :- t) (List Obj :- Name :- t)
+      closure :: G (Datum :- t) (List Obj :- Label :- t)
       closure = IG.Flip $ IG.PartialIso
         (\(env:-code:-t) -> S.Unreadable "#<procedure>" :- t)
         (const . Left $ mempty)

src/Gyehoek/Stack/Syntax.hs

@@ -14,7 +14,9 @@ module Gyehoek.Stack.Syntax
   , Imm(..)
   , Hob(..)
   , Prim(..)
-  , Name
+  , Name(..)
+  , Reg(..)
+  , Label(..)
   , pattern ValLabel
   , pattern ObjLabel
   , stkP
@@ -72,7 +74,7 @@ data Tail
 data Instr
   = Pop Reg
   | Push Val
-  | Load Reg
+  | Load Reg Int
   | Prim Reg (Prim Val)
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
@@ -95,7 +97,7 @@ instance S.DatumIso Instr where
   datumIso = S.match
     $ S.With (S.headTagged1 "pop!" S.datumIso >>>)
     $ S.With (S.headTagged1 "push!" S.datumIso >>>)
-    $ S.With (S.headTagged1 "load!" S.datumIso >>>)
+    $ S.With (S.headTagged2 "load" S.datumIso S.datumIso >>>)
     $ S.With (S.headTagged2 "prim" S.datumIso S.datumIso >>>)
     $ S.End
     where

src/Gyehoek/Stack/VM.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE ViewPatterns, MultilineStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveAnyClass #-}
 module Gyehoek.Stack.VM
   ( VM(..)
   , Env(..)
@@ -28,34 +30,51 @@ 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
-  { currentRoutine :: Name
+  { activeRoutine :: Label
   }
   deriving (Show, Generic)
 
 newtype Frame = MkFrame { locals :: List Obj }
-  deriving (Show, Generic)
+  deriving stock (Show, Generic)
 
-returnAddress :: Traversal' Frame Name
+-- affine
+returnAddress :: Traversal' Frame Label
 returnAddress = #locals . _last . #ObjImm . #ImmLabel
 
+-- affine
+activeProcedure :: Traversal' Frame Label
+activeProcedure = #locals . _init . _last . #ObjImm . #ImmLabel
+
+callStack :: Traversal' Stack Label
+callStack = each . activeProcedure
+
 newtype Stack = MkStack { frames :: NonEmpty Frame }
-  deriving (Show, Generic)
+  deriving stock (Show, Generic)
 
 data VM = MkVM
   { stack :: Stack
   , code :: List Instr
   , tail :: Tail
-  , registers :: HashMap Name Obj
+  , registers :: HashMap Reg 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))
@@ -63,6 +82,13 @@ instance Cons Frame Frame Obj Obj where
       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))
@@ -75,7 +101,7 @@ activeFrame :: Lens' VM Frame
 activeFrame = #stack . #frames . _NonEmpty . _1
 
 data Env = MkEnv
-  { labels :: HashMap Name Routine
+  { labels :: HashMap Label Routine
   }
   deriving (Show, Generic)
 
@@ -89,6 +115,10 @@ vmerror = throwError . VMError
 
 stepI :: Jalmot :> es => Env -> VM -> Instr -> Eff es VM
 
+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 (Push v) = traverseOf activeFrame push vm
   where push xs = cons <$> evalVal e vm v <*> pure xs
 
@@ -135,58 +165,84 @@ stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|]
 
 stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM
 
-stepT g vm (Return nret) =
+stepT g vm tc@(Call nargs) = do
-  case splitAtExact nret (vm ^. activeFrame . #locals) of
+  (args,f,ret,frm) <- parseCall nargs (vm ^. activeFrame)
-    Nothing -> _
+    & expectOf [i|#{show tc}|] _Just 
-    Just (_,_) -> _
+  rt <- getRoutine g f
+  let newFrame = MkFrame $ args ++ [ObjLabel f,ObjLabel ret]
+  pure $ vm
+    & jumpToRoutine rt
+    & activeFrame .~ frm
+    & #stack %~ pushFrame newFrame
+    -- it is not essential we clear the registers, but it'll
+    -- make bugs more obvious.
+    & #registers .~ mempty
 
-stepT g vm tc@(TailCall nargs) =
+stepT g vm tc@(Return nret) = do
-  case parseTailCall nargs (vm ^. activeFrame) of
+  (xs,_) <- splitAtExact nret (vm ^. activeFrame . #locals)
-    Nothing -> vmerror [i|bad stack at #{tc}|]
+    & expectOf [i|"#{show tc}"|] _Just
-    Just (args,"halt",_) -> pure $ vm & #result ?~ args
+  expectOf [i||] (activeFrame . returnAddress) vm >>= \case
-    Just (args,f,ra) -> do
+    "halt" -> pure $ vm & #result ?~ xs
+    ra -> do
+      rt <- getRoutine g ra
+      vm & traverseOf #stack (fmap snd . popFrame)
+         & mapped . activeFrame %~ pushes xs
+         & mapped %~ jumpToRoutine rt
+
+stepT g vm tc@(TailCall nargs) = do
+  (args,f,ra) <- parseTailCall nargs (vm ^. activeFrame)
+    & expectOf [i|#{show tc}|] _Just
+  case f of
+    "halt" -> pure $ vm & #result ?~ args
+    _ -> do
       rt <- case g ^. #labels . at f of
         Nothing -> vmerror [i|undefined label #{f}|]
         Just x -> pure x
       let newFrame = MkFrame $ args ++ [ObjLabel f, ObjLabel ra]
       pure $ vm
-        & #code .~ rt.start.code
+        & jumpToRoutine rt
-        & #tail .~ rt.start.tail
         -- 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 tc@(TailCall nargs) =
---   case setupCall nargs (vm ^. stack) of
---     Nothing -> vmerror [i|bad stack at #{tc}|]
---     Just (xs,f,rest) ->
---       case f of
---         "halt" -> pure $ vm & #result ?~ xs
---         l -> do
---           rt <- case g ^. #labels . at l of
---             Nothing -> vmerror [i|undefined label: #{l}|]
---             Just x -> pure x
---           let ra = vm ^. #activeFrame . #returnAddress
---           let newFrame = MkFrame $ xs ++ [ObjLabel f, ra]
---           pure $ vm
---             & #code .~ rt.start.code
---             & #tail .~ rt.start.tail
---             & stack .~ rest
---             & #frames %~ NE.cons newFrame
---             -- it is not essential we clear the registers, but it'll
---             -- make bugs more obvious.
---             & #registers .~ mempty
---             & #debug . #currentRoutine .~ rt.label
-
 stepT g vm (If c t f) = do
   branch <- evalVal g vm c <&> \case
       ObjImm (ImmBool False) -> f
       _ -> t
-  pure $ vm & #code .~ branch.code & #tail .~ branch.tail
+  pure $ jumpToBlock branch vm
 
-evalToLabel :: Jalmot :> es => Env -> VM -> Val -> Eff es Name
+
+
+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)
+
+jumpToBlock :: Block -> VM -> VM
+jumpToBlock b vm = vm
+  & #code .~ b.code
+  & #tail .~ b.tail
+
+jumpToRoutine :: Routine -> VM -> VM
+jumpToRoutine rt vm = vm
+  & jumpToBlock rt.start
+  & #debug . #activeRoutine .~ rt.label
+
+getRoutine :: (HasCallStack, Jalmot :> es) => Env -> Label -> Eff es Routine
+getRoutine g l = case g ^. #labels . at l of
+  Just rt -> pure rt
+  Nothing -> vmerror [i|undefined label #{l}|]
+
+expectOf
+  :: (HasCallStack, Jalmot :> es)
+  => Text -> Getting (First a) s a -> s -> Eff es a
+expectOf msg l s = case s ^? l of
+  Just x -> pure x
+  Nothing -> vmerror [i|bad stack, expecting #{msg}|]
+
+evalToLabel :: Jalmot :> es => Env -> VM -> Val -> Eff es Label
 evalToLabel e vm v =
   evalVal e vm v >>= \case
     ObjImm (ImmLabel x) -> pure x
@@ -209,7 +265,15 @@ takeExact n xs = case compareLength xs n of
   (EQ;GT) -> Just $ take n xs
   LT -> Nothing
 
-parseTailCall :: Int -> Frame -> Maybe (List Obj, Name, Name)
+parseCall :: Int -> Frame -> Maybe (List Obj, Label, Label, Frame)
+parseCall nargs frm = do
+  (xs,ys) <- splitAtExact (nargs+2) (frm ^. #locals)
+  let (xs',[f,ret]) = splitAt nargs xs
+  f' <- f ^? #ObjImm . #ImmLabel
+  ret' <- ret ^? #ObjImm . #ImmLabel
+  pure (xs',f',ret',MkFrame ys)
+
+parseTailCall :: Int -> Frame -> Maybe (List Obj, Label, Label)
 parseTailCall nargs frm = do
   (xs,_) <- splitAtExact (nargs+1) (frm ^. #locals)
   let (xs',f) = xs ^?! _Snoc
@@ -229,7 +293,7 @@ initialVM = MkVM
   , stdout = ""
   , result = Nothing
   , debug = MkDebugVM
-    { currentRoutine = "<nowhere>"
+    { activeRoutine = "<nowhere>"
     }
   }
 
@@ -329,7 +393,7 @@ ppTrace trace =
   table_ do
     thead_ $ tr_ do
       traverse_ (th_ [scope_ "col"])
-        ["location","instruction","stack"]
+        ["routine","next instruction","stack frame"]
     tbody_ do
       go trace
   where
@@ -361,14 +425,14 @@ ppVM vm = do
     td_ do
       details_ do
         summary_ do
-          var_ [class_ "loc"] . toHtml $ vm ^. #debug . #currentRoutine
+          var_ [class_ "loc"] do
-            . re (_Unwrapped' . prefixed "$")
+            vm ^. #debug . #activeRoutine . to ppDatum
         pre_ do
           code_ . toHtml . pShowNoColor $ vm
     td_ do
       code_ curi
     td_ do
-      let xs = _
+      let xs = vm ^.. activeFrame . each . to ppDatum
       sequence_ $ intersperse " | " xs
   where
     curi = vm ^?! failing (#code . _head . to ppDatum) (#tail . to ppDatum)
@@ -376,7 +440,28 @@ ppVM vm = do
 ppDatum :: S.DatumIso a => a -> Html ()
 ppDatum = htmlDatum . runJalmotUnsafe . S.toDatum S.datumIso
 
-blah = [stkP|
+fac (n :: Int) = [stkP|
-        (define $start
+(define $start
-          (return 0))
+  (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))
+|]

test/Gyehoek/Test/Stack/VM.hs

@@ -7,6 +7,7 @@ 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
@@ -14,7 +15,7 @@ evalsTo rs p = runJalmotUnsafe (Sut.eval p) @?= rs
 
 test_root = testGroup "stack machine"
   [ testCase "immediate halt" do
-      evalsTo [ObjImm (ImmInt 3)] [stkP|
+      evalsTo [] [stkP|
         (define $start
           (return 0))
       |]
@@ -24,59 +25,89 @@ test_root = testGroup "stack machine"
           (push! 3)
           (return 1))
       |]
-  -- , testCase "return constant" do
+  , testCase "non-tail identity function" do
-  --     evalsTo [ObjImm (ImmInt 123)] [stkP|
+      evalsTo [ObjImm (ImmInt 123)] [stkP|
-  --       (define ($start %ktail)
+        (define $id
-  --         (tail-call $silly %ktail))
+          (return 1))
-  --       (define ($silly %ktail)
+        (define $c
-  --         (tail-call %ktail 123))
+          (return 1))
-  --     |]
+        (define $start
-  -- , testCase "identity continuation" do
+          (push! $c)
-  --     evalsTo [ObjImm (ImmInt 45)] [stkP|
+          (push! $id)
-  --       (define ($start %ktail)
+          (push! 123)
-  --         (push! %ktail)
+          (call 1))
-  --         (tail-call $id 45))
+      |]
-  --       (define ($id %x)
+  , testCase "tail identity function" do
-  --         (pop! %ktail)
+      evalsTo [ObjImm (ImmInt 123)] [stkP|
-  --         (tail-call %ktail %x))
+        (define $id
-  --     |]
+          (return 1))
-  -- , testCase "identity function" do
+        (define $start
-  --     evalsTo [ObjImm (ImmInt 45)] [stkP|
+          (push! $id)
-  --       (define ($start %ktail)
+          (push! 123)
-  --         (tail-call $id 45 %ktail))
+          (tail-call 1))
-  --       (define ($id %x %ktail)
+      |]
-  --         (tail-call %ktail %x))
+  , testCase "return constant" do
-  --     |]
+      evalsTo [ObjImm (ImmInt 123)] [stkP|
-  -- , testCase "square" do
+        (define $start
-  --     evalsTo [ObjImm (ImmInt 16)] [stkP|
+          (push! $silly)
-  --       (define ($start %ktail)
+          (tail-call 1))
-  --         (tail-call $square 4 %ktail))
+        (define $silly
-  --       (define ($square %x %ktail)
+          (push! 123)
-  --         (prim %x2 (* %x %x))
+          (return 1))
-  --         (tail-call %ktail %x2))
+      |]
-  --     |]
+  , testCase "return multiple" do
-  -- , testCase "factorial" do
+      evalsTo [ObjImm (ImmInt n) | n <- [1,2,3]] [stkP|
-  --     let hsfac (n :: Int) = foldr (*) (1) [1..n]
+        (define $start
-  --     let fac (n :: Int) = [stkP|
+          (push! 3)
-  --           (define ($fac %n %ktail)
+          (push! 2)
-  --             (prim %x0 (zero? %n))
+          (push! 1)
-  --             (if %x0
+          (return 3))
-  --               (then (tail-call %ktail 1))
+      |]
-  --               (else (push! %n)
+  , testCase "return none" do
-  --                     (push! %ktail)
+      evalsTo [] [stkP|
-  --                     (prim %x1 (- %n 1))
+        (define $start
-  --                     (tail-call $fac %x1 $fac-k0))))
+          (return 0))
-  --           (define ($fac-k0 %x2)
+      |]
-  --             (pop! %ktail)
+  , testCase "square" do
-  --             (pop! %n)
+      evalsTo [ObjImm (ImmInt 16)] [stkP|
-  --             (prim %x3 (* %x2 %n))
+        (define $start
-  --             (tail-call %ktail %x3))
+          (push! $square)
-  --           (define ($start %ktail)
+          (push! 4)
-  --             (tail-call $fac #{n} %ktail))
+          (tail-call 1))
-  --         |]
+        (define $square
-  --     evalsTo [ObjImm (ImmInt 1)] $ fac 0
+          (pop! %x)
-  --     evalsTo [ObjImm (ImmInt 1)] $ fac 1
+          (prim %x2 (* %x %x))
-  --     evalsTo [ObjImm (ImmInt 720)] $ fac 6
+          (push! %x2)
-  --     -- 20 is the greatest `n` for which n! ≤ maxBount @Int
+          (return 1))
-  --     evalsTo [ObjImm (ImmInt 2432902008176640000)] $ fac 20
+      |]
+  , 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 %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))
+      |]
+        mkcase n = testCase [i|#{n}|] do
+          evalsTo [ObjImm . ImmInt $ hsfac n] $ fac n
+      -- 20 is the greatest `n` for which n! ≤ maxBount @Int
+      in [ mkcase n | n <- [0,1,6,20] ]
   ]