stupid

.gitignore

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

doc/make-vm-stackier.org

@@ -0,0 +1,100 @@
+* 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
+

gyehoek.cabal

@@ -63,6 +63,7 @@ library
     Gyehoek.CPS.Stackify
     Gyehoek.CPS.Syntax
     Gyehoek.Driver
+    Gyehoek.Language
     Gyehoek.GenSym
     Gyehoek.Jalmot
     Gyehoek.Lift1
@@ -167,7 +168,9 @@ test-suite doctest
   import:             ghcstuffs, ghcstuffs-dev
   type:               exitcode-stdio-1.0
   hs-source-dirs:     test
-  build-depends:      base
+  build-depends:
+    , base
+    , gyehoek
   default-extensions: CPP
   main-is:            doctest.hs
 

src/Gyehoek/CPS/Close.hs

@@ -12,30 +12,26 @@ 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 $ freeWithBound' [f] lam
+    let frees = nub $ free' lam
     let m' = ifoldr
-             (\n x q -> [cps|(prim (env-ref #{f} #{n})
-                                (κ (#{x}) #{q}))|])
+             (\n x q ->
+               let p = if x == f then PrimEnv @Val else PrimEnvRef n
+               in [cps|
+                 (prim #{p}
+                   (κ (#{x}) #{q}))
+             |])
              m frees
     pure [cps|
-      (letrec ((#{f_code} (λ (#{f} ##{bs} #{kb})
+      (letrec ((#{f_code} (λ (##{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

src/Gyehoek/CPS/Convert.hs

@@ -47,18 +47,21 @@ convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
   _ -> _
 
 -- special case: call/cc is desugared during cps-conversion...
-convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
-  convert1 withcc \withcc' -> do
-    cc <- gensym' @Name "cc"
-    r <- gensym' "r"
-    m <- k . one $ 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})))
-    |]
+-- 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}))))
+--     |]
 
 -- ...while all other prims are left as-is for later stages to
 -- handle..

src/Gyehoek/CPS/Eval.hs

@@ -59,11 +59,6 @@ eval g (ExpPrim p (MkKappa bs e)) = case evalVal g <$> p of
       lbl = case x of
         ObjImm (ImmLabel l) -> l
         _ -> error [i|expected label, got #{x}|]
-  PrimEnvCode x -> ret . (:[]) . ObjImm . ImmLabel $ code
-    where
-      code = case x of
-        ObjHob (HobClosure lbl _) -> lbl
-        _ -> error [i|expected closure, got #{x}|]
   _ -> error [i|unhandled prim: #{p}|]
   where
     ret rs = eval

src/Gyehoek/CPS/Stackify.hs

@@ -27,7 +27,7 @@ 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 `H.member` g.bound
+  x `elem` g.bound
   -- && not (x `elem` g.contStack)
 
 data BlockBuilder
@@ -48,14 +48,14 @@ stackify
   => Env -> Exp -> Eff es BlockBuilder
 
 stackify g (ExpLetRec [(f, AbsKappa kap)] e) = do
-  stackifyKappa g f kap \g' kap' -> do
-    emitRoutine kap'
-    stackify g' e
+  kap' <- stackifyKappa g kap
+  emitRoutine . Stk.MkRoutine (MkLabel f) . buildBlock $ kap'
+  stackify g e
 
 stackify g (ExpLetRec [(f, AbsLambda lam)] e) = do
-  stackifyLambda g f lam \g' lam' -> do
-    emitRoutine lam'
-    stackify g' e
+  lam' <- stackifyLambda g (MkLabel f) lam
+  emitRoutine lam'
+  stackify g e
 
 stackify g (ExpIf c t f) = do
   let c' = stackifyVal g c
@@ -63,104 +63,108 @@ 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) = pure $
-    Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
-    Tail (Stk.TailCall (stackifyVal g f) (k : (stackifyVal g <$> xs)))
-  where
-    k = var g ktail
-    ls = fold $ (k ^? #ValImm . #ImmLabel)
-      >>= \klbl -> g ^. #liveness . at klbl
-
-stackify g e@(ExpContinue k xs) = do
+stackify g (ExpApply f xs ktail) = do
   pure $
-    Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
-    Tail (Stk.TailCall k' (stackifyVal g <$> xs))
-  where
-    k' = stackifyVal g k
-    ls = fold $ (k' ^? #ValImm . #ImmLabel)
-      >>= \klbl -> g ^. #liveness . at klbl
+    Code [ Stk.Push $ stackifyVal g (ValVar ktail)
+         , Stk.Push $ stackifyVal g f
+         ] $
+    Code (pushArgs g xs) $
+    Tail (Stk.Call (length xs))
 
--- stackify g (ExpPrim (PrimCallCC withcc) cc) = do
---   cc_l <- gensym' "cc"
---   rcc_l <- gensym' "reified-cc"
---   stackifyKappa g cc_l cc \g' rt -> do
---     emitRoutine rt
---     pure $
---       Code [ Stk.Prim rcc_l $ PrimReifyCC (Stk.ValLabel cc_l) ] $
---       Tail (Stk.TailCall (stackifyVal g' withcc) [Stk.ValLabel rcc_l])
+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 p (MkKappa [x] e)) = do
-  e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e
+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.Prim x (stackifyVal g <$> p) ] e'
+    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'
 
 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)
+_ValName = failing #_ValVar (#_ValImm . #_ImmLabel . #_MkLabel)
 
 stackifyKappa
   :: (Stackify :> es, GenSym :> es)
-  => Env -> Name -> Kappa
-  -> (Env -> Stk.Routine -> Eff es r)
-  -> Eff es r
-stackifyKappa g name kap@(MkKappa xs m) w = do
-  let vs = (name, Stk.ValLabel name) : (bindReg <$> xs)
-  let ls = live g kap
-  m' <- stackify (g & #bound <>~ H.fromList (vs ++ (bindReg <$> ls))) m
-  let g' = g & #bound . at name ?~ Stk.ValLabel name
-             & #liveness . at name ?~ live g kap
-  let rt = Stk.MkRoutine name xs . buildBlock $
-       -- pop in the opposite order we push
-       Code [Stk.Pop x | x <- reverse ls] m'
-  w g' rt
+  => 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 -> Name -> Lambda
-  -> (Env -> Stk.Routine -> Eff es r)
-  -> Eff es r
-stackifyLambda g name (MkLambda xs k m) w = do
-  let vs = [ (x, Stk.ValReg x) | x <- k:xs ]
-  m' <- stackify (g & #bound <>~ H.fromList vs) m
-  let g' = g & #bound . at name ?~ Stk.ValLabel name
-  w g' $ Stk.MkRoutine name (k:xs) (buildBlock m')
+  => 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 -> var g v
+  ValVar v -> case regOf g v of
+    Just r -> Stk.ValReg r
+    Nothing -> Stk.ValLabel (MkLabel v)
   v -> error [i|unimplemented val: #{v}|]
 
-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)
+regOf :: Env -> Name -> Maybe Reg
+regOf g x
+  | x `elem` g.bound || x == g.tail = Just . MkReg $ x
+  | otherwise                       = Nothing
 
 
 
 data Env = MkEnv
-  { bound :: HashMap Name Stk.Val
+  -- | `bound` tracks the stack lifetime of bound variables.
+  { bound :: List Name
   -- | for each locally-bound continuation @k@, @liveness@ has an
   -- entry @(k,ls)@ where @ls@ is the sequence of registers @k@
   -- expects to find saved on the stack.
-  , liveness :: HashMap Name (List Name)
+  , liveness :: HashMap Label (List Name)
+  , tail :: Name
   }
   deriving (Show, Generic)
 
 emptyEnv :: Env
-emptyEnv = MkEnv mempty mempty
+emptyEnv = MkEnv
+  { bound = mempty
+  , liveness = mempty
+  , tail = "halt"
+  }
 
 
 
 stackifyProgram :: GenSym :> es => Program -> Eff es Stk.Program
 stackifyProgram (MkProgram lam) = do
   let g = emptyEnv
-  (_,p) <- runStackify $ stackifyLambda g "start" lam (const emitRoutine)
+  (_,p) <- runStackify $ emitRoutine =<< stackifyLambda g "start" lam
   pure p
 
 letfn :: Program
@@ -176,3 +180,21 @@ letfn = [cps|
       (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)))
+|]

src/Gyehoek/CPS/Syntax.hs

@@ -18,6 +18,8 @@ module Gyehoek.CPS.Syntax
   , Imm(..)
   , Obj(..)
   , Hob(..)
+  , Label(..)
+  , Reg(..)
   , pattern Halt
   , pattern Halt1
   , _MkKappa
@@ -36,7 +38,7 @@ module Gyehoek.CPS.Syntax
   , Abs(..)
   , Free(..)
   , pattern ValLabel
-  , labelName -- don't like that this is part of the api
+  , pattern ObjLabel
   )
   where
 
@@ -52,6 +54,8 @@ 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
 
@@ -60,13 +64,23 @@ data Val
   | ValVar Name
   deriving (Show, Generic, Data, Eq)
 
-pattern ValLabel :: Name -> Val
+pattern ValLabel :: Label -> 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 Name
+  | ImmLabel Label
   | ImmUndefined
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
@@ -77,9 +91,13 @@ data Obj
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
+pattern ObjLabel l = ObjImm (ImmLabel l)
+
 -- | a heap object.
 data Hob
-  = HobClosure { label :: Name, env :: List Obj }
+  = 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
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
@@ -169,29 +187,44 @@ instance S.DatumIso Imm where
   datumIso = S.match
     $ S.With (. S.int)
     $ S.With (. S.datumIso)
-    $ S.With (. labelName)
+    $ S.With (. S.datumIso)
     $ S.With (. S.unreadable (const "#<undefined>"))
     $ S.End
 
-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 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
 
 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 :- Name :- t)
+      closure :: G (Datum :- t) (List Obj :- Label :- t)
       closure = IG.Flip $ IG.PartialIso
-        (\(env:-code:-t) -> S.Unreadable "#<procedure>" :- t)
+        (\(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)
         (const . Left $ mempty)
 
 instance S.DatumIso Lambda where

src/Gyehoek/Language.hs

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

src/Gyehoek/Prelude.hs

@@ -19,6 +19,7 @@ module Gyehoek.Prelude
   , (>>>)
   , (>=>)
   , (<=<)
+  , wrappedIso
   ) where
 
 import Control.Lens hiding (List, (:<))
@@ -40,4 +41,5 @@ 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

@@ -81,9 +81,11 @@ data Prim e
   | PrimZeroP e
   | PrimNewline
   | PrimMakeClosure { code :: e, env :: List e }
-  | PrimEnvRef e Int
-  | PrimEnvCode e
+  | PrimEnv
+  | PrimEnvRef Int
   | PrimCallCC e
+  | PrimCaptureCC
+  | PrimInvokeCC e (List e)
   | PrimValues (List e)
   | PrimCallWithValues e e
   deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
@@ -164,17 +166,19 @@ primDatumIso namefn a = S.match
     $ S.With (. ht1 "integer?")
     $ S.With (. ht1 "write")
     $ S.With (. ht1 "zero?")
-    $ S.With (. nullop "newline")
+    $ S.With (. ht0 "newline")
     $ S.With (. ht1' "make-closure")
-    $ S.With (. S.headTagged2 (namefn "env-ref") a S.int)
-    $ S.With (. ht1 "env-code")
+    $ S.With (. ht0 "env")
+    $ S.With (. S.headTagged1 (namefn "env-ref") S.int)
     $ 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
-      nullop s = S.list $ idn s
+      ht0 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

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -107,7 +107,17 @@ list
 list = listWithIndentation Ordinary
 
 -- |
--- >>> decodeTest @(Int,Int) (with \g -> dottedList (el int) int >>> g) "(1 . 2)"
+-- >>> 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''

src/Gyehoek/Stack/Syntax.hs

@@ -14,8 +14,11 @@ module Gyehoek.Stack.Syntax
   , Imm(..)
   , Hob(..)
   , Prim(..)
-  , Name
+  , Name(..)
+  , Reg(..)
+  , Label(..)
   , pattern ValLabel
+  , pattern ObjLabel
   , stkP
   ) where
 
@@ -24,13 +27,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(..), labelName)
+import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), pattern ObjLabel, Reg, Label)
 import Gyehoek.Prelude
 import Gyehoek.Sexp ((:-)((:-)))
 
 
 newtype Program = MkProgram
-  { routines :: HashMap Name Routine
+  { routines :: HashMap Label Routine
   }
   deriving stock (Show, Generic, Data)
   deriving newtype (Semigroup, Monoid)
@@ -44,8 +47,7 @@ instance IsList Program where
   toList = toListOf $ #routines . each
 
 data Routine = MkRoutine
-  { label :: Name
-  , params :: List Name
+  { label :: Label
   , start :: Block
   }
   deriving stock (Show, Generic, Data)
@@ -59,25 +61,32 @@ data Block = MkBlock
   deriving anyclass (NFData)
 
 data Tail
-  = TailCall Val (List Val)
+  -- | 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
   | If Val Block Block
+  | Return Int
+  | CallCC
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
 data Instr
-  = Pop Name
+  = Pop Reg
   | Push Val
-  | Prim Name (Prim Val)
+  | Load Reg Int
+  | Prim (Prim Val)
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
 data Val
-  = ValReg Name
+  = ValReg Reg
   | ValImm Imm
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
 
-pattern ValLabel :: Name -> Val
+pattern ValLabel :: Label -> Val
 pattern ValLabel x = ValImm (ImmLabel x)
 
 
@@ -87,9 +96,10 @@ pure []
 
 instance S.DatumIso Instr where
   datumIso = S.match
-    $ S.With (S.headTagged1 "pop!" regName >>>)
+    $ S.With (S.headTagged1 "pop!" S.datumIso >>>)
     $ S.With (S.headTagged1 "push!" S.datumIso >>>)
-    $ S.With (S.headTagged2 "prim" regName S.datumIso >>>)
+    $ S.With (S.headTagged2 "load" S.datumIso S.datumIso >>>)
+    $ S.With (S.headTagged1 "prim" S.datumIso >>>)
     $ S.End
     where
 
@@ -103,10 +113,14 @@ instance S.DataIso Block where
 
 instance S.DatumIso Tail where
   datumIso = S.match
-    $ S.With (S.headTagged1' "tail-call" S.datumIso S.datumIso >>>)
+    $ S.With (S.headTagged1 "tail-call" S.datumIso >>>)
+    $ S.With (S.headTagged1 "call" 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 =
@@ -116,7 +130,7 @@ instance S.DatumIso Tail where
 
 instance S.DatumIso Val where
   datumIso = S.match
-    $ S.With (regName >>>)
+    $ S.With (S.datumIso >>>)
     $ S.With (S.datumIso >>>)
     $ S.End
 
@@ -124,16 +138,11 @@ 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.list $ S.el labelName >>> S.rest regName)
+       >>> S.el (S.datumIso @Label)
        >>> 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,4 +1,6 @@
 {-# LANGUAGE ViewPatterns, MultilineStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveAnyClass #-}
 module Gyehoek.Stack.VM
   ( VM(..)
   , Env(..)
@@ -12,7 +14,7 @@ module Gyehoek.Stack.VM
 import Gyehoek.Stack.Syntax
 import Control.Lens
 import qualified Data.HashMap.Strict as H
-import Data.List (unfoldr, intersperse)
+import Data.List (unfoldr, intersperse, compareLength)
 import Gyehoek.Prelude
 import qualified Data.List.NonEmpty as NE
 import Lucid
@@ -28,27 +30,75 @@ 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)
 
 
--- | inessential information maintained only to aide in debugging.
+-- | 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 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 :: List Obj
+  { 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))
+    \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 Name Routine
+  { labels :: HashMap Label Routine
   }
   deriving (Show, Generic)
 
@@ -62,12 +112,96 @@ vmerror = throwError . VMError
 
 stepI :: Jalmot :> es => Env -> VM -> Instr -> Eff es VM
 
-stepI e vm (Push v) = traverseOf #stack push vm
-  where push xs = (:) <$> evalVal e vm v <*> pure xs
+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 (Prim r p) = traverse (evalVal e vm) p >>= \case
+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
   PrimZeroP x -> case x of
-    ObjImm (ImmInt n) -> ret . ObjImm . ImmBool $ n == 0
+    ObjImm (ImmInt n) -> ret1 . ObjImm . ImmBool $ n == 0
     _ -> vmerror [i|bad arg to zero?: #{x}|]
   PrimAdd x y -> arith_binop (+) x y
   PrimMul x y -> arith_binop (*) x y
@@ -75,59 +209,72 @@ stepI e vm (Prim r p) = traverse (evalVal e vm) p >>= \case
   PrimDiv x y -> arith_binop div x y
   PrimMakeClosure f env ->
     case f of
-      ObjImm (ImmLabel l) -> ret . ObjHob $ HobClosure l env
+      ObjImm (ImmLabel l) -> ret1 . ObjHob $ HobClosure l env
       _ -> vmerror [i|expected label, got #{f}|]
-  PrimEnvCode env ->
-    case env of
-      ObjHob (HobClosure l _) -> ret . ObjImm . ImmLabel $ l
-      _ -> vmerror [i|expected closure, got #{env}|]
-  PrimEnvRef env n ->
-    case env of
-      ObjHob (HobClosure _ xs) -> ret $ xs ^?! ix n
-      _ -> vmerror [i|expected closure, got #{env}|]
-  PrimCons x y -> ret $ ObjHob $ HobPair x y
+  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 _) -> ret car
+      ObjHob (HobPair car _) -> ret1 car
       _ -> vmerror [i|expected pair, got ${x}|]
   PrimCdr x -> case x of
-      ObjHob (HobPair _ cdr) -> ret cdr
+      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}|]
   where
-    ret v = pure $ vm & #registers . at r ?~ v
+    ret vs = pure $ vm & activeFrame . #locals <>:~ vs
+    ret1 v = ret [v]
     arith_binop op (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
-      ret $ ObjImm (ImmInt (op x y))
+      ret1 $ ObjImm (ImmInt (op x y))
     arith_binop _ x y = vmerror [i|bad arith: #{x}, #{y}|]
 
-stepI e vm (Pop r) = case vm ^. #stack of
-  [] -> vmerror "empty stack"
-  (x:xs) -> pure $ vm & #registers . at r ?~ x
-               & #stack .~ xs
+
 
-stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|]
+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)
 
-stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM
+jumpToBlock :: Block -> VM -> VM
+jumpToBlock b vm = vm
+  & #code .~ b.code
+  & #tail .~ b.tail
 
-stepT g vm (TailCall f xs) = do
-  xs' <- traverse (evalVal g vm) xs
-  evalToLabel g vm f >>= \case
-    "halt" -> pure $ vm & #result ?~ xs'
-    l -> do
-      rt <- case g ^. #labels . at l of
-          Nothing -> vmerror [i|undefined label: #{l}|]
-          Just x -> pure x
-      pure $ vm & #code .~ rt.start.code
-            & #tail .~ rt.start.tail
-            & #registers .~ H.fromList (rt.params `zip` xs')
-            & #debug . #currentRoutine .~ rt.label
+jumpToRoutine :: Routine -> VM -> VM
+jumpToRoutine rt vm = vm
+  & jumpToBlock rt.start
+  & #debug . #activeRoutine .~ 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
+getLabel :: Obj -> Maybe Label
+getLabel = \case
+  ObjHob (HobClosure {label}) -> Just label
+  ObjHob (HobContinuation {cont}) -> getLabel cont
+  ObjImm (ImmLabel label) -> Just label
+  x -> Nothing
 
-evalToLabel :: Jalmot :> es => Env -> VM -> Val -> Eff es Name
+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}|]
+
+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
@@ -140,16 +287,47 @@ evalVal e vm = \case
     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)
+
 initialVM :: VM
 initialVM = MkVM
-  { stack = []
+  { stack = MkStack . NE.singleton . MkFrame $
+    [ ObjLabel "start"
+    , ObjLabel "<nowhere at all>"
+    , ObjLabel "halt"
+    ]
+  , tail = TailCall 0
   , code = []
-  , tail = TailCall (ValLabel "start") [ValLabel "halt"]
   , registers = mempty
   , stdout = ""
   , result = Nothing
   , debug = MkDebugVM
-    { currentRoutine = "<nowhere>"
+    { activeRoutine = "<nowhere>"
     }
   }
 
@@ -228,11 +406,19 @@ ppDoc p t =
         .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
@@ -246,7 +432,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
@@ -254,9 +440,14 @@ ppTrace trace =
     go = \case
       Step vm next -> ppVM vm >> go next
       StepToSuccess vm rs -> do
-        ppVM vm
-        tr_ [colspan_ "3",class_ "trace-result"] do
-          sequence_ . intersperse " | " $ code_ . ppDatum <$> rs
+        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
@@ -273,17 +464,58 @@ ppVM vm = do
     td_ do
       details_ do
         summary_ do
-          var_ [class_ "loc"] . toHtml $ vm ^. #debug . #currentRoutine
-            . re (_Unwrapped' . prefixed "$")
+          var_ [class_ "loc"] do
+            vm ^. #debug . #activeRoutine . to ppDatum
         pre_ do
           code_ . toHtml . pShowNoColor $ vm
     td_ do
       code_ curi
     td_ do
-      let xs = code_ . ppDatum <$> (vm ^. #stack)
-      sequence_ $ intersperse " | " xs
+      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))
+|]

t.scm

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

test/Gyehoek/Test/CPS/Stackify.hs

@@ -20,42 +20,44 @@ test_stackify =
   , procedure
   ]
 
-evalsTo :: List Obj -> Sut.Exp -> Assertion
+evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion
 evalsTo rs e = runJalmotUnsafe (Stk.eval e') @?= rs
   where
-    e' = e & CPS.MkLambda [] "_ktail"
-      & CPS.MkProgram
-      & Sut.stackifyProgram & runGenSym & runPureEff
+    e' = e & Sut.stackifyProgram & runGenSym & runPureEff
 
 trivialReturn = testGroup "trivial return"
   [ testCase "return int" do
       evalsTo [ObjImm (ImmInt 4)]
-        [cps|(continue halt 4)|]
+        [cps|(λ (ktail) (continue ktail 4))|]
   , testCase "return bool" do
       evalsTo [ObjImm (ImmBool True)]
-        [cps|(continue halt #t)|]
+        [cps|(λ (ktail) (continue ktail #t))|]
       evalsTo [ObjImm (ImmBool False)]
-        [cps|(continue halt #f)|]
+        [cps|(λ (ktail) (continue ktail #f))|]
   ]
 
 tailCall = testGroup "tail call"
   [ testCase "square" do
-      evalsTo [ObjImm (ImmInt 16)]
-        [cps|(letrec ((square (λ (x ktail)
-                                (prim (* x x)
-                                  (κ (x0) (continue ktail x0))))))
-               (square 4 halt))|]
+      evalsTo [ObjImm (ImmInt 16)] [cps|
+        (λ (ktail0)
+          (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|(prim (* 4 5)
-               (κ (x) (continue halt x)))|]
+        [cps|(λ (ktail0)
+            (prim (* 4 5)
+               (κ (x) (continue ktail0 x))))|]
   , testCase "add" do
       evalsTo [ObjImm (ImmInt 9)]
-        [cps|(prim (+ 4 5)
-               (κ (x) (continue halt x)))|]
+        [cps|(λ (ktail0)
+        (prim (+ 4 5)
+               (κ (x) (continue ktail0 x))))|]
   -- , testGroup "call/cc"
   --   [ testCase "trivial" do
   --       evalsTo [ObjImm (ImmInt 123)]
@@ -66,14 +68,17 @@ prim = testGroup "prim"
 
 condition = testCase "if" do
   evalsTo [ObjImm (ImmInt 123)]
-    [cps|(if #t (continue halt 123) (continue halt 456))|]
+    [cps|(λ (ktail0)
+      (if #t (continue ktail0 123) (continue ktail0 456)))|]
   evalsTo [ObjImm (ImmInt 456)]
-    [cps|(if #f (continue halt 123) (continue halt 456))|]
+    [cps|(λ (ktail0)
+      (if #f (continue ktail0 123) (continue ktail0 456)))|]
 
 procedure = testGroup "procedure"
   [ testCase "factorial" do
       evalsTo [ObjImm (ImmInt 720)]
-        [cps|(letrec ((fac (λ (n ktail)
+        [cps|(λ (ktail0)
+          (letrec ((fac (λ (n ktail)
                              (prim (zero? n)
                                (κ (x0)
                                  (if x0
@@ -86,5 +91,5 @@ procedure = testGroup "procedure"
                                                       (κ (x3)
                                                         (continue ktail x3))))))
                                          (fac x1 fac-k0))))))))))
-               (fac 6 halt))|]
+               (fac 6 halt)))|]
   ]

test/Gyehoek/Test/Golden.hs

@@ -29,11 +29,8 @@ 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

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