return, pushcall

.dir-locals.el

@@ -9,9 +9,6 @@
       . (progn (defun apply-cabal-fmt-h ()
                  (haskell-mode-buffer-apply-command "cabal-fmt"))
                (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t)))))
- (scheme-mode
-  . ((eval . (dolist (s '(kappa κ prim))
-               (put s 'scheme-indent-function 1)))))
  (nil
   . ((eval
       . (progn (defun display-ansi ()

doc/closure-conversion.org

@@ -132,34 +132,3 @@ multiple ~env-ref~ calls could probably be replaced with a primitive that loads
                                  $code)
                      1))))
 #+end_src
-
-** example
-
-#+begin_src scheme
-  (λ (n m ktail)
-    (letrec ((f (λ (x ktail-0) (+ x n ktail-0)))
-             (g (λ (y ktail-1) (+ y g ktail-1))))
-      (prim (cons f g) ktail)))
-#+end_src
-
-#+begin_src scheme
-  (λ (n m ktail)
-    (letrec ((f-code (λ (x ktail-0)
-                       (prim (env-get 2)
-                         (κ (n)
-                           (+ x n ktail-0)))))
-             (g-code (λ (y ktail-1)
-                       (prim (env-get 3)
-                         (κ (m)
-                           (+ y m ktail-1))))))
-      (letrec ((with-closure-code
-                (κ (f g)
-                  (prim (get-env 0)
-                    (κ (ktail)
-                      (prim cons f g ktail))))))
-        (prim (make-shared-closure (with-closure-code)
-                                   ktail)
-          (κ (with-closure)
-            (prim (make-shared-closure (f-code g-code) n m)
-              with-closure))))))
-#+end_src

doc/liveness.org

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

golden/exec/cons-2/source.scm

@@ -1,2 +0,0 @@
-(let ((p (cons 123 456)))
-  (cons (cdr p) (car p)))

golden/exec/lit-int/exec

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

golden/exec/lit-int/source.scm

@@ -1 +0,0 @@
-123

gyehoek.cabal

@@ -58,16 +58,13 @@ library
   -- cabal-fmt: expand src
   exposed-modules:
     Gyehoek.CPS.Close
-    Gyehoek.CPS.Contify
     Gyehoek.CPS.Convert
     Gyehoek.CPS.Eval
-    Gyehoek.CPS.Hoist
     Gyehoek.CPS.Stackify
     Gyehoek.CPS.Syntax
     Gyehoek.Driver
     Gyehoek.GenSym
     Gyehoek.Jalmot
-    Gyehoek.Language
     Gyehoek.Lift1
     Gyehoek.Options
     Gyehoek.Prelude
@@ -102,7 +99,6 @@ library
     , hashable
     , invertible-grammar
     , lens
-    , lucid
     , megaparsec
     , mtl
     , optparse-applicative
@@ -110,7 +106,6 @@ library
     , pretty-simple
     , prettyprinter
     , prettyprinter-ansi-terminal
-    , prettyprinter-lucid
     , process
     , recursion-schemes
     , scientific
@@ -121,7 +116,8 @@ library
     , typed-process
     , unordered-containers
     , vector
-    , tardis
+    , lucid
+    , prettyprinter-lucid
 
   hs-source-dirs:   src
   default-language: GHC2024
@@ -174,7 +170,6 @@ test-suite doctest
   build-depends:
     , base
     , gyehoek
-
   default-extensions: CPP
   main-is:            doctest.hs
 

src/Gyehoek/CPS/Close.hs

@@ -7,49 +7,36 @@ import Gyehoek.CPS.Syntax
 import Data.List (nub)
 import Gyehoek.GenSym
 import Gyehoek.Prelude
-import Debug.Pretty.Simple
-import Gyehoek.Sexp qualified as S
-import Data.HashSet.Lens
-import Data.Traversable
 
 
-genCodeName :: GenSym :> es => Name -> Eff es Name
+close :: GenSym :> es => Exp -> Eff es Exp
-genCodeName f = gensym' @Name $ f ^. _Wrapped' . to (<> "-code")
+close = transformM \case
-
+  ExpLetRec [(f, AbsLambda lam@(MkLambda bs kb m))] e -> do
-bindEnv :: List Name -> Exp -> Exp
+    f_code <- gensym' @Name $ f ^. _Wrapped'. to (<> "-code")
-bindEnv frees m = [cps|
+    -- it would probably be most sane to generate a symbol for `env`,
-  (prim (get-env) (κ #{frees} #{m}))
+    -- but we're reusing the lambda binding so we don't have to
+    -- explicitly substitute recursive calls.
+    let frees = nub $ freeWithBound' [f] lam
+    let m' = ifoldr
+             (\n x q -> [cps|(prim (env-ref #{f} #{n})
+                                (κ (#{x}) #{q}))|])
+             m frees
+    pure [cps|
+      (letrec ((#{f_code} (λ (#{f} ##{bs} #{kb})
+                            #{m'})))
+        (prim (make-closure ($ #{f_code}) ##{frees})
+          (κ (#{f}) #{e})))
     |]
 
-close1 :: forall es. GenSym :> es => Exp -> Eff es Exp
+  ExpApply f xs ktail -> do
-close1 = \case
+    code <- gensym' @Name "code"
-  lr@(ExpLetRec bs e) -> do
-    let boundNames = bs ^.. each . _1
-    let boundNames' = setOf each boundNames
-    let frees = bs
-          & foldMapOf
-            (each . _2)
-            (freeWithBound' boundNames')
-          & nub
-    env_cont_l <- gensym' @Name "env-cont"
-    e_l <- gensym' @Name "letrec-body-cont"
-    bs' <- for bs \(f,ab) -> do
-      f_code_l <- genCodeName f
-      pure ( f_code_l
-           , ab & absBody %~ bindEnv (boundNames ++ frees)
-           )
-    let codes = bs' ^.. each . _1 . to MkLabel
     pure [cps|
-      (letrec #{bs'}
+      (prim (env-code #{f})
-        (prim (make-shared-closure #{codes} #{frees})
+        (κ (#{code})
-          (κ #{boundNames}
+          (#{code} #{f} ##{xs} #{ktail})))
-            #{e})))
     |]
 
   e -> pure e
 
-close :: forall es. GenSym :> es => Exp -> Eff es Exp
-close = transformM close1
-
 closeProgram :: GenSym :> es => Program -> Eff es Program
 closeProgram = traverseOf (#body . #body) close

src/Gyehoek/CPS/Contify.hs

@@ -1,67 +0,0 @@
-{-# LANGUAGE ApplicativeDo #-}
-module Gyehoek.CPS.Contify
-  ( contifyProgram
-  ) where
-
-import Control.Monad.Tardis
-import Gyehoek.CPS.Syntax
-import Gyehoek.Prelude
-import qualified Data.HashSet as HS
-import Control.Lens.Unsound (adjoin)
-import Debug.Pretty.Simple
-import qualified Data.HashMap.Strict as H
-import Control.Monad.Writer.Lazy
-import Control.Monad.Trans.Tardis (liftTardisT)
-
-
--- | ain't no way...
--- type T = WriterT (HashSet Name) (Tardis (HashSet Name) (HashSet Name))
-type T = TardisT (HashSet Name) (HashSet Name) (Writer (HashSet Name))
-
-evalT :: T a -> a
--- evalT = (`evalTardis` (mempty,mempty)) . fmap fst . runWriterT
-evalT = fst . runWriter . (`evalTardisT` (mempty,mempty))
-
-runT :: T a -> (a, HashSet Name)
--- runT = (`evalTardis` (mempty,mempty)) . runWriterT
-runT = runWriter . (`evalTardisT` (mempty,mempty))
-
--- | inline function if it hasn't been used in the past, and won't
--- be used in the future.
-tryInline :: Name -> Kappa -> T Kexp
-tryInline kname kap = do
-  modifyBackwards (HS.insert kname)
-  p <- getsPast (HS.member kname)
-  modifyForwards (HS.insert kname)
-  q <- getsFuture (HS.member kname)
-  let c = p || q
-  liftTardisT . tell $ if c then HS.singleton kname else mempty
-  pure $ if c
-    then KexpVar kname
-    else KexpKappa kap
-
-getKap :: HashMap Name Abs -> Name -> Maybe Kappa
-getKap g kname = g ^? ix kname . #AbsKappa
-
-contify :: HashMap Name Abs -> Exp -> T Exp
-contify g = transformM \case
-  ExpApply f xs (KexpVar kname) | Just kap <- getKap g kname
-   -> ExpApply f xs <$> tryInline kname kap
-  ExpPrim p (KexpVar kname) | Just kap <- getKap g kname
-   -> ExpPrim p <$> tryInline kname kap
-  e -> pure e
-
-contifyProgram :: HoistedProgram -> Eff es HoistedProgram
-contifyProgram p = do
-  let g = p.bindings
-  let (p',contifiedVars) =
-        runT $
-          traverseOf
-            (adjoin
-              (#bindings . each . body)
-              (#body . body))
-            (contify g)
-            p
-  pTraceShowM contifiedVars
-  -- pure $ p' & #bindings %~ H.filterWithKey \k _ -> HS.member k contifiedVars
-  pure p'

src/Gyehoek/CPS/Convert.hs

@@ -46,18 +46,26 @@ convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
   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 <- 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})))
+--     |]
+
+-- ...while all other prims are left as-is for later stages to
+-- handle..
 convert (Scm.ExpPrim p) k =
   telescope (convert1 @es) p \p' -> do
-    r_l <- gensym' "r"
+    r <- gensym' "r"
-    -- k_l <- gensym' @Name "prim-k"
+    ExpPrim p' . MkKappa [r] <$> k [ValVar r]
-    m <- k [ValVar r_l]
-    pure [cps|
-      (prim #{p'} (κ (#{r_l}) #{m}))
-    |]
-    -- pure [cps|
-    --   (letrec ((#{k_l} (κ (#{r_l}) #{m})))
-    --     (prim #{p'} #{k_l}))
-    -- |]
 
 convert (Scm.ExpLambda xs e) k = do
   f <- gensym' "lambda-body"
@@ -70,25 +78,17 @@ convert (Scm.ExpLambda xs e) k = do
 
 convert (Scm.ExpApply f xs) k =
   telescope (convert1 @es) (f:|xs) \(f':|xs') -> do
-    r <- gensym' @Name "r"
+    r <- gensym' "r"
     x <- gensym' "x"
     m <- k [ValVar x]
     pure $ ExpLetRec [(r, AbsKappa' [x] m)] $
-      ExpApply f' xs' (KexpVar r)
+      ExpApply f' xs' r
 
 convert (Scm.ExpBegin xs) k = telescope (convert @es) xs (k . NE.last)
 
 convert (Scm.ExpIf c t f) k =
-  convert1 c \c' -> do
+  convert1 c \c' ->
-    t_l <- gensym' @Name "truthy-cont"
+    ExpIf c' <$> convert t k <*> convert f k
-    f_l <- gensym' @Name "falsey-cont"
-    t' <- convert t k
-    f' <- convert f k
-    pure [cps|
-      (letrec ((#{t_l} (κ () #{t'}))
-               (#{f_l} (κ () #{f'})))
-        (if #{c'} #{t_l} #{f_l}))
-    |]
 
 -- let-bindings are desugared into continuation calls whose parameters
 -- are the left-hand sides and whose arguments are the right-hand

src/Gyehoek/CPS/Eval.hs

@@ -1,259 +1,104 @@
 {-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE OverloadedLists #-}
 module Gyehoek.CPS.Eval
   ( evalProgram
   , module Gyehoek.CPS.Syntax
   , evalExp
-  , eGrammar
   ) where
 
-import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..), cont)
+import Gyehoek.CPS.Syntax
-import Gyehoek.Sexp qualified as S
+import Control.Lens
-import Control.Lens hiding (assign)
 import Data.Maybe (fromMaybe)
 import Text.Show.Functions ()
 import qualified Data.HashMap.Strict as H
-import Gyehoek.Prelude hiding (assign)
+import Gyehoek.Prelude
 import Debug.Pretty.Simple
-import Gyehoek.Jalmot
-import Control.Monad.Cont
-import Gyehoek.Sexp qualified as S
-import GHC.Generics (Generically(..))
-import Gyehoek.Sexp ((:-)(..))
-import Data.List (nub, mapAccumR, compareLength)
-import Data.HashSet.Lens (setOf)
-import Data.IntMap.Strict (IntMap)
-import Data.IntMap.Strict qualified as IM
-import Data.Monoid
-import Control.Monad.State
-import Data.Traversable (for)
-import Data.Foldable (traverse_)
 
 
-newtype Loc = MkLoc { getLoc :: Int }
+data Env = MkEnv
-  deriving stock (Generic, Data)
+  { vars :: HashMap Name Obj
-  deriving newtype (Show, Eq, Ord, Enum)
+  , labels :: HashMap Name (Env, Abs)
-
-data Store = MkStore
-  { nextLoc :: Loc
-  , heap :: IntMap E
   }
-  deriving stock (Show, Generic)
-
-type instance Index Store = Loc
-type instance IxValue Store = E
-
-instance Ixed Store where ix (MkLoc j) = #heap . ix j
-instance At Store where at (MkLoc j) = #heap . at j
-
-emptyStore :: Store
-emptyStore = MkStore
-  { nextLoc = MkLoc 0
-  , heap = mempty
-  }
-
-newtype Env = MkEnv { getEnv :: HashMap Name Loc }
-  deriving stock (Show, Generic, Data)
-  deriving newtype (Semigroup, Monoid)
-
-emptyEnv :: Env
-emptyEnv = mempty
-
-type instance Index Env = Name
-type instance IxValue Env = Loc
-
-instance Ixed Env where ix j = #getEnv . ix j
-instance At Env where at j = #getEnv . at j
-
-update :: Loc -> E -> Store -> Store
-update (MkLoc loc) v = #heap %~ IM.alter f loc
-  where
-    f (Just _) = Just v
-    f Nothing = error "segfault lol"
-
-updates :: Foldable f => f (Loc, E) -> Store -> Store
-updates = alaf Endo foldMap (uncurry update)
-
-fetch :: Loc -> M r E
-fetch (MkLoc loc) = gets (^?! #heap . ix loc)
-
-new :: M r Loc
-new = state \st -> (st.nextLoc, st & #nextLoc %~ succ)
-
-new' :: E -> M r Loc
-new' e = state \st ->
-  ( st.nextLoc
-  , st & #nextLoc %~ succ & at st.nextLoc ?~ e
-  )
-
-defines :: Traversable t => t (Name, E) -> M Answer Env
-defines = alaf Ap foldMap \(name,e) -> do
-  l <- new' e
-  pure $ bind name l
-
-var :: HasCallStack => Env -> Name -> M Answer Loc
-var g x = case g ^. at x of
-  Just l -> pure l
-  Nothing -> wrong [i|unbound variable #{x}|]
-
-type CmdCont = Store -> Answer
-type ExpCont = List E -> CmdCont
-
-type M r = ContT r (State Store)
-
-data Answer
-  = AnswerValues (List E)
-  | AnswerError AJalmot
   deriving (Show, Generic)
 
-data Mutability
+eval :: Env -> Exp -> List Obj
-  = Mut
-  | NoMut
-  deriving (Show, Generic, Data, Eq)
 
-wrong :: Text -> M Answer a
+eval g (Halt xs) = evalVal g <$> xs
-wrong s = ContT \_ -> pure . AnswerError . EvalError $ s
 
-bind :: Name -> Loc -> Env
+eval g (ExpContinue k xs) =
-bind k = MkEnv . H.singleton k
+  case g ^. #labels . at k' of
-
+    Just (h, AbsKappa' bs m) -> eval h' m
-extends :: Foldable f => f (Name, Loc) -> Env -> Env
-extends xs g = g <> foldMap (uncurry bind) xs
-
-assign :: Loc -> E -> M Answer ()
-assign l e = do
-  use (at l) >>= \case
-    Just _ -> at l ?= e
-    Nothing -> wrong [i|#{e}에서 #{l}이라는 주소는 없다|]
-
-
-
--- | The denotation of an expressed value.
-data E
-  = ESymbol Text
-  | ECharacter Char
-  | EInt Int
-  | EBool Bool
-  | EUndefined
-  | EUnspecified
-  | ENull
-  | EPair Loc Loc Mutability
-  | EVec (List Loc) Mutability
-  | EString (List Loc) Mutability
-  | EProcedure Procedure
-  deriving stock (Show, Generic)
-
-type Procedure = List E -> DynPoints -> M Answer (List E)
-
-eGrammar :: Store -> S.DatumGrammar E
-eGrammar st = S.partialOsi (const . Left $ mempty) go
       where
-    gofetch x = go $ st ^?! ix x
+        h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
-    go = \case
+    _ -> error [i|not a kappa: #{k}|]
-      ESymbol s -> S.Symbol s
-      ECharacter c -> S.Character c
-      EInt n -> S.Number (fromIntegral n)
-      EBool b -> S.Boolean b
-      EUndefined -> S.Unreadable "#<undefined>"
-      EUnspecified -> S.Unreadable "#<unspecified>"
-      ENull -> S.List []
-      EPair car cdr _mut -> S.DotList [gofetch car] (gofetch cdr)
-      EVec xs _mut -> S.Vector . fmap gofetch $ xs
-      EString xs _mut -> S.String _
-
-data DynPoints = MkDynPoints
-  deriving (Generic, Data)
-
-
-
-evalVal :: Env -> Val -> M Answer E
-
-evalVal g (ValVar x) = var g x >>= fetch
-
-evalVal g (ValImm imm) = pure case imm of
-  ImmLabel l -> error [i|#{l}|]
-  ImmInt n -> EInt n
-  ImmBool b -> EBool b
-  ImmUndefined -> EUndefined
-
-evalKexp :: Env -> Kexp -> M Answer E
-evalKexp g (KexpVar x) = var g x >>= fetch
-evalKexp g (KexpKappa kap) = evalAbs g (AbsKappa kap)
-
-evalAbs :: Env -> Abs -> M Answer E
-evalAbs g (MkAbs formals ktail e) = pure . EProcedure $ \xs dps ->
-  let
-    formals' = formals ++ foldMap (:[]) ktail
-    lformals = length formals'
-    lxs = length xs
-  in if lformals /= lxs
-  then wrong [i|함수는 #{lformals}개의 인자를 필요로 하는데 #{lxs}개 받았다.|]
-  else do
-    ls <- xs & traverse new'
-    let g' = g & extends (zip formals' ls)
-    eval g' dps e
-
-eval :: Env -> DynPoints -> Exp -> M Answer (List E)
-
-eval g dps (ExpJump f xs ktail) = do
-  f' <- evalVal g f
-  xs' <- traverse (evalVal g) xs
-  ktail' <- traverse (evalKexp g) (ktail ^.. _Just)
-  case f' of
-    EProcedure p -> p (xs' ++ ktail') dps
-    _ -> wrong "bad procedure"
-
-eval g dps (ExpLetRec bs e) = do
-  ls <- for bs . const $ new' EUndefined
-  let g' = g & extends (zip (bs ^.. each . _1) ls)
-  bs' <- forOf (each . _2) bs (evalAbs g')
-  traverse_ (uncurry assign) $ zip ls (bs' ^.. each . _2)
-  eval g' dps e
-
-eval g dps (ExpPrim p k) = do
-  p' <- evalPrim g =<< traverse (evalVal g) p
-  evalKexp g k >>= \case
-    EProcedure fp -> fp p' dps
-    _ -> wrong [i|prim(#{p})의 계속을 나쁘다|]
-
-eval g dps e = error [i|unimplemented #{e}|]
-
-evalPrim :: Env -> Prim E -> M Answer (List E)
-evalPrim g = \case
-  PrimAdd x y -> arith2 (+) x y
-  PrimMul x y -> arith2 (*) x y
-  PrimSub x y -> arith2 (-) x y
-  PrimDiv x y -> arith2 div x y
-  PrimValues xs -> pure xs
-  p -> wrong [i|prim(#{p})은 벌써 나지 않다|]
   where
-    arith2 f (EInt x) (EInt y) = pure [EInt $ f x y]
+    k' = case evalVal g k of
-    arith2 f x y = wrong [i|나쁜 인자: #{x}, #{y}|]
+      ObjImm (ImmLabel x) -> x
+      x -> error [i|expected label, got #{x}|]
 
-
+eval g (ExpApply f xs ktail) =
-
+  case g ^?! #labels . at f' of
-evalExp :: Jalmot :> es => Exp -> Eff es _
+    Just (h,AbsLambda' bs kb m) -> eval h' m
-evalExp e = _
+      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
-
+                   & #labels . at kb .~ (g ^. #labels . at ktail)
-evalProgram :: Jalmot :> es => Program -> Eff es (List S.Datum)
+    Nothing -> error [i|undefined label: #{f}|]
-evalProgram (MkProgram lam) = case run (pure . AnswerValues) of
-  (AnswerError jm, _) -> throwError jm
-  (AnswerValues vs, st) -> traverse (S.toDatum $ eGrammar st) vs
   where
-    run f = (`runState` emptyStore) . (`runContT` f) $ do
+    f' = case evalVal g f of
-      g <- setup
+      ObjImm (ImmLabel x) -> x
-      eval g MkDynPoints (ExpLetRec
+      x -> error [i|expected label, got #{x}|]
-        [("_start",AbsLambda lam)]
-        (ExpApply (ValVar "_start") [] (KexpVar "halt")))
 
-
+eval g (ExpLetRec [(b, ab)] e) = eval g' e
+  where g' = g & #labels . at b ?~ ab
 
-setup :: M Answer Env
+eval g (ExpPrim p (MkKappa bs e)) = case evalVal g <$> p of
-setup = defines @List
+  PrimAdd x y -> arithBinop (+) x y
-  [ ("halt", EProcedure prim_halt)
+  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}|]
+  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
+        (g & #vars <>~ envOfBinds bs rs)
+        e
+    arithBinop f (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
+      ret [ObjImm . ImmInt $ f x y]
+    arithBinop _ x y = error [i|bad arith: #{x}, #{y}|]
 
-prim_halt :: Procedure
+eval _ e = error [i|unimplemented case: #{e}|]
-prim_halt xs _dps = ContT \_ -> pure $ AnswerValues xs
+
+envOfBinds bs xs = foldMap (uncurry H.singleton) (zip bs xs)
+
+evalVal :: Env -> Val -> Obj
+evalVal g = \case
+  ValVar x -> fromMaybe (error [i|unbound: #{x}|]) $ g ^?! #vars . at x
+  ValImm x -> ObjImm x
+
+emptyEnv :: Env
+emptyEnv = MkEnv
+  { vars = mempty
+  -- a kinda silly hack to make sure `halt` is handled correctly when
+  -- it appears as the tail continuation of an application. the
+  -- 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"]
+  }
+
+evalExp :: Exp -> List Obj
+evalExp = eval emptyEnv
+
+evalProgram :: Program -> List Obj
+evalProgram (MkProgram lam) = eval emptyEnv [cps|
+  (letrec ((start #{lam}))
+    (start halt))
+|]

src/Gyehoek/CPS/Hoist.hs

@@ -1,24 +0,0 @@
-module Gyehoek.CPS.Hoist
-  ( hoistProgram
-  ) where
-
-import Gyehoek.CPS.Syntax
-import Gyehoek.Prelude
-import qualified Data.HashMap.Strict as H
-import Effectful.Writer.Static.Local
-import Data.Foldable
-
-
-type Hoist = Writer (HashMap Label Abs)
-
-hoist :: Hoist :> es => Exp -> Eff es Exp
-hoist = transformM \case
-  ExpLetRec bs m -> do
-    traverse_ (\(k,v) -> tell $ H.singleton (MkLabel k) v) bs
-    pure m
-  e -> pure e
-
-hoistProgram :: Program -> Eff es HoistedProgram
-hoistProgram p = do
-  (body,bindings) <- runWriter $ traverseOf #body hoist p.body
-  pure $ MkHoistedProgram {body,bindings}

src/Gyehoek/CPS/Stackify.hs

@@ -12,14 +12,24 @@ import Gyehoek.GenSym
 import Effectful.Writer.Static.Shared
 import Data.Foldable
 import qualified Data.HashMap.Strict as H
-import Data.List (elemIndex, nub, intersect)
+import Data.List (elemIndex, nub)
 import Data.Text qualified as T
 import Gyehoek.Prelude
 import Debug.Pretty.Simple
 import qualified Gyehoek.Sexp as S
-import Data.Monoid
 
 
+type Stackify = Writer Stk.Program
+
+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 `H.member` g.bound
+  -- && not (x `elem` g.contStack)
+
 data BlockBuilder
   = Code (List Stk.Instr) BlockBuilder
   | Tail Stk.Tail
@@ -30,137 +40,131 @@ buildBlock = go [] where
   go acc (Code xs bb) = go (acc ++ xs) bb
   go acc (Tail t) = Stk.MkBlock acc t
 
--- affine
+emitRoutine :: Stackify :> es => Stk.Routine -> Eff es ()
-_ValName :: Traversal' Val Name
+emitRoutine rt = tell [rt]
-_ValName = failing #_ValVar (#_ValImm . #_ImmLabel . #_MkLabel)
 
 stackify
-  :: forall es. (GenSym :> es)
+  :: (GenSym :> es, Stackify :> es)
   => Env -> Exp -> Eff es BlockBuilder
 
-stackify _ (ExpContinue (ValVar k) xs) =
+stackify g (ExpLetRec [(f, AbsKappa kap)] e) = do
-  Code [ ] _
+  stackifyKappa g (MkLabel f) kap \g' kap' -> do
+    emitRoutine kap'
+    stackify g' e
 
-stackify _ (ExpPrim p k) = _
+stackify g (ExpLetRec [(f, AbsLambda lam)] e) = do
+  stackifyLambda g (MkLabel f) lam \g' lam' -> do
+    emitRoutine lam'
+    stackify g' e
+
+stackify g (ExpIf c t f) = do
+  let c' = stackifyVal g c
+  t' <- buildBlock <$> stackify g t
+  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
+--   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
+
+stackify g (ExpPrim p (MkKappa [x] e)) = do
+  e' <- stackify (g & #bound . at x ?~ Stk.ValReg (MkReg x)) e
+  pure $
+    Code [ Stk.Prim (MkReg x) (stackifyVal g <$> p) ] e'
 
 stackify _ e = error [i|unimplemented exp: #{e}|]
 
-stackifyAbs :: (GenSym :> es) => Env -> Label -> Abs -> Eff es Stk.Routine
+-- affine
+_ValName :: Traversal' Val Name
+_ValName = failing #ValVar (#ValImm . #ImmLabel . #MkLabel)
 
-stackifyAbs g lbl (MkAbs xs mtail e) =
+stackifyKappa
-  Stk.MkRoutine lbl . buildBlock . preamble <$> stackify g e
+  :: (Stackify :> es, GenSym :> es)
-  where
+  => Env -> Label -> Kappa
-    preamble = Code (popArgs $ (mtail ^.. _Just) ++ xs)
+  -> (Env -> Stk.Routine -> Eff es r)
+  -> Eff es r
+stackifyKappa g name kap@(MkKappa xs m) w = _
+-- 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
 
-popArgs :: List Name -> List Stk.Instr
+stackifyLambda
-popArgs = fmap (Stk.Pop . MkReg) . reverse
+  :: (Stackify :> es, GenSym :> es)
+  => Env -> Label -> Lambda
+  -> (Env -> Stk.Routine -> Eff es r)
+  -> Eff es r
+stackifyLambda g name (MkLambda xs k m) w = do
+  let vs = [ (x, Stk.ValReg (MkReg x)) | x <- k:xs ]
+  m' <- stackify (g & #bound <>~ H.fromList vs) m
+  let g' = g & #bound . at (name ^. wrappedIso) ?~ Stk.ValLabel name
+  w g' $ Stk.MkRoutine name (buildBlock m')
 
-pushArgs :: List Name -> List Stk.Instr
+stackifyVal :: Env -> Val -> Stk.Val
-pushArgs = _
+stackifyVal g = \case
+  ValImm imm -> Stk.ValImm imm
+  ValVar v -> var g 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 (MkLabel v)
+
+bindReg :: Name -> (Name, Stk.Val)
+bindReg x = (x, Stk.ValReg (MkReg x))
 
 
 
 data Env = MkEnv
-  {
+  { 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 Name (List Name)
   }
   deriving (Show, Generic)
 
 emptyEnv :: Env
-emptyEnv = MkEnv
+emptyEnv = MkEnv mempty mempty
-  {
-  }
 
 
 
-stackifyProgram
+stackifyProgram :: GenSym :> es => Program -> Eff es Stk.Program
-  :: forall es. GenSym :> es
+stackifyProgram (MkProgram lam) = do
-  => HoistedProgram -> Eff es Stk.Program
+  let g = emptyEnv
-stackifyProgram p = p
+  (_,p) <- runStackify $ stackifyLambda g "start" lam (const emitRoutine)
-  & ifoldMapOf
+  pure p
-    ((#bindings . itraversed)
-     <> (#body . to (H.singleton "start" . AbsLambda) . itraversed))
-    (\l -> Ap . stackifyBinding l)
-  & getAp
-  where
-    g = emptyEnv
-    stackifyBinding lbl ab =
-      Stk.MkProgram . H.singleton lbl <$> stackifyAbs @es g lbl ab
 
-p :: HoistedProgram
+letfn :: Program
-p = [cps|
+letfn = [cps|
-(letrec (($r12-code32
-          (κ (x13)
-            (prim
-             (get-env)
-             (κ (r12 start-ktail0)
-               (continue start-ktail0 x13)))))
-         ($prim-k7-code22
-          (κ (r6)
-            (prim
-             (get-env)
-             (κ (prim-k7 lambda-tail1 n fac)
-               (prim
-                (make-shared-closure ($r8-code19) (lambda-tail1 n))
-                (κ (r8)
-                  (fac r6 r8)))))))
-         ($prim-k11-code16
-          (κ (r10)
-            (prim
-             (get-env)
-             (κ (prim-k11 lambda-tail1)
-               (continue lambda-tail1 r10)))))
-         ($falsey-cont5-code26
-          (κ ()
-            (prim
-             (get-env)
-             (κ (truthy-cont4 falsey-cont5 lambda-tail1 n fac)
-               (prim
-                (make-shared-closure ($prim-k7-code22) (lambda-tail1 n fac))
-                (κ (prim-k7)
-                  (prim (- n 1) prim-k7)))))))
-         ($r8-code19
-          (κ (x9)
-            (prim
-             (get-env)
-             (κ (r8 lambda-tail1 n)
-               (prim
-                (make-shared-closure ($prim-k11-code16) (lambda-tail1))
-                (κ (prim-k11)
-                  (prim (* n x9) prim-k11)))))))
-         ($truthy-cont4-code25
-          (κ ()
-            (prim
-             (get-env)
-             (κ (truthy-cont4 falsey-cont5 lambda-tail1 n fac)
-               (continue lambda-tail1 1)))))
-         ($fac-code35
-          (λ (n lambda-tail1)
-            (prim
-             (get-env)
-             (κ (fac)
-               (prim
-                (make-shared-closure ($prim-k3-code29) (lambda-tail1 n fac))
-                (κ (prim-k3)
-                  (prim (zero? n) prim-k3)))))))
-         ($prim-k3-code29
-          (κ (r2)
-            (prim
-             (get-env)
-             (κ (prim-k3 lambda-tail1 n fac)
-               (prim
-                (make-shared-closure
-                 ($truthy-cont4-code25 $falsey-cont5-code26)
-                 (lambda-tail1 n fac))
-                (κ (truthy-cont4 falsey-cont5)
-                  (if r2
-                    truthy-cont4
-                    falsey-cont5))))))))
 (λ (start-ktail0)
-    (prim
+  (letrec ((lambda-body1
-     (make-shared-closure ($fac-code35) ())
+            (λ (x lambda-tail2)
-     (κ (fac)
+              (prim (* x x) (κ (r3) (continue lambda-tail2 r3))))))
-       (prim
+    (letrec ((let-body6
-        (make-shared-closure ($r12-code32) (start-ktail0))
+              (κ (square)
-        (κ (r12)
+                (letrec ((r4 (κ (x5) (continue start-ktail0 x5))))
-          (fac 20 r12)))))))
+                  (square 4 r4)))))
+      (continue let-body6 lambda-body1))))
 |]
+

src/Gyehoek/CPS/Syntax.hs

@@ -10,12 +10,10 @@ module Gyehoek.CPS.Syntax
   , Kappa(..)
   , Lambda(..)
   , Exp(..)
-  , Kexp(..)
   , ExpF(..)
   , Name(..)
   , Prim(..)
   , Program(..)
-  , HoistedProgram(..)
   , Lit(..)
   , Imm(..)
   , Obj(..)
@@ -41,12 +39,6 @@ module Gyehoek.CPS.Syntax
   , Free(..)
   , pattern ValLabel
   , pattern ObjLabel
-  , absBody
-  , pattern MkAbs
-  , _MkAbs
-  , unhoist
-  , pattern ExpJump
-  , _ExpJump
   )
   where
 
@@ -64,10 +56,6 @@ import Gyehoek.Sexp (G, (:-)(..))
 import qualified Data.InvertibleGrammar.Base as IG
 import Gyehoek.GenSym (Gen)
 import Data.String (IsString)
-import Control.Applicative
-import qualified Data.HashMap.Strict as H
-import GHC.Records (HasField (..))
-import Data.Bifunctor
 
 -- Data types
 
@@ -108,8 +96,6 @@ 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
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
@@ -125,60 +111,24 @@ data Abs
   | AbsLambda Lambda
   deriving (Show, Generic, Data, Eq)
 
-pattern AbsKappa' :: List Name -> Exp -> Abs
+pattern AbsKappa' :: [Name] -> Exp -> Abs
 pattern AbsKappa' xs e = AbsKappa (MkKappa xs e)
 
-pattern AbsLambda' :: List Name -> Name -> Exp -> Abs
+pattern AbsLambda' :: [Name] -> Name -> Exp -> Abs
 pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
 
-{-# COMPLETE AbsKappa', AbsLambda' #-}
-
-_MkAbs :: Iso' Abs (List Name, Maybe Name, Exp)
-_MkAbs = iso
-  (\case
-    AbsKappa' xs e -> (xs,Nothing,e)
-    AbsLambda' xs ktail e -> (xs,Just ktail,e))
-  (\(xs,ktail,e) -> case ktail of
-    Just k -> AbsLambda' xs k e
-    Nothing -> AbsKappa' xs e)
-
-pattern MkAbs :: List Name -> Maybe Name -> Exp -> Abs
-pattern MkAbs xs ktail body <- (view _MkAbs -> (xs,ktail,body))
-  where MkAbs xs ktail body = review _MkAbs (xs,ktail,body)
-
-{-# COMPLETE MkAbs #-}
-
-_ExpJump :: Prism' Exp (Val, List Val, Maybe Kexp)
-_ExpJump = prism'
-  (\(f,xs,ktail) -> case ktail of
-    Just k -> ExpApply f xs k
-    Nothing -> ExpContinue f xs)
-  \case
-    ExpApply f xs ktail -> Just (f,xs,Just ktail)
-    ExpContinue f xs -> Just (f,xs,Nothing)
-    _ -> Nothing
-
-pattern ExpJump :: Val -> List Val -> Maybe Kexp -> Exp
-pattern ExpJump f xs ktail <- (preview _ExpJump -> Just (f,xs,ktail))
-  where ExpJump f xs ktail = review _ExpJump (f,xs,ktail)
-
 data Exp
-  = ExpPrim (Prim Val) Kexp
+  = ExpPrim (Prim Val) Kappa
   | ExpLetRec { binders :: List (Name, Abs), body :: Exp }
   | ExpContinue Val (List Val)
-  | ExpIf Val Name Name
+  | ExpIf Val Exp Exp
   | ExpApply
     { op :: Val
     , args :: List Val
-    , cont :: Kexp
+    , cont :: Name
     }
   deriving (Show, Generic, Data, Eq)
 
-data Kexp
-  = KexpVar Name
-  | KexpKappa Kappa
-  deriving (Show, Generic, Data, Eq)
-
 pattern Halt :: List Val -> Exp
 pattern Halt xs = ExpContinue (ValLabel "halt") xs
 
@@ -193,22 +143,6 @@ data Program = MkProgram
   }
   deriving (Show, Generic, Data)
 
-data HoistedProgram = MkHoistedProgram
-  { bindings :: HashMap Label Abs
-  , body :: Lambda
-  }
-  deriving stock (Show, Generic, Data)
-
-type instance Index HoistedProgram = Label
-type instance IxValue HoistedProgram = Abs
-
-instance Ixed HoistedProgram where ix j = #bindings . ix j
-
-instance At HoistedProgram where at j = #bindings . at j
-
-instance Each HoistedProgram HoistedProgram Abs Abs where
-  each = #bindings . each
-
 makePrisms ''Kappa
 makePrisms ''Exp
 makeFieldsId ''Exp
@@ -232,21 +166,6 @@ _AbsLambda' = prism'
 
 instance Plated Exp where plate = uniplate
 
-absBody :: Lens' Abs Exp
-absBody = lens
-  (\case
-    AbsLambda lam -> lam.body
-    AbsKappa kap -> kap.body)
-  (\cases
-    (AbsLambda lam) b -> AbsLambda $ lam & #body .~ b
-    (AbsKappa kap) b -> AbsKappa $ kap & #body .~ b)
-
-unhoist :: HoistedProgram -> Program
-unhoist p =
-  MkProgram $ p.body & body %~ ExpLetRec
-    (p ^.. #bindings . itraversed . withIndex
-      . to (\(MkLabel l, ab) -> (l,ab)))
-
 
 -- DatumIso instances
 
@@ -289,7 +208,6 @@ instance S.DatumIso Reg where
 instance S.DatumIso Hob where
   datumIso = S.match
     $ S.With (. closure)
-    $ S.With (. cont)
     $ S.With (. conspair)
     $ S.End
     where
@@ -297,13 +215,7 @@ instance S.DatumIso Hob where
       -- closures can be printed, but not parsed.
       closure :: G (Datum :- t) (List Obj :- Label :- t)
       closure = IG.Flip $ IG.PartialIso
-        (\(env:-code:-t) -> S.Unreadable [i|\#<procedure $#{code}>|] :- t)
+        (\(env:-code:-t) -> S.Unreadable "#<procedure>" :- 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
@@ -350,51 +262,30 @@ instance S.DatumIso Exp where
       if_ = S.ifLike "if"
         S.datumIso S.datumIso S.datumIso
       app :: forall t.
-        G (Datum :- t) (Kexp :- List Val :- Val :- t)
+        G (Datum :- t) (Name :- ([Val] :- (Val :- t)))
-      app = S.list $
+      app = S.list $ S.el (S.datumIso @Val)
-        S.flipped (S.PartialIso
+        -- >>> S.flipped Gyehoek.Datum.nonEmptyGrammar
-          (\(S.MkListContext ctx :- t) ->
-            case ctx of
-              f:kexp:xs -> S.MkListContext (f : snoc xs kexp) :- t
-              _ -> error "unreachable")
-          (\(S.MkListContext ctx :- t) ->
-            case unsnoc ctx of
-              Just (f:xs,kexp) -> Right $ S.MkListContext (f:kexp:xs) :- t
-              _ -> Left $ S.expected "continuation arg"))
-        >>> S.el (S.datumIso @Val)
-        >>> S.el (S.datumIso @Kexp)
         >>> S.rest (S.datumIso @Val)
-        >>> S.onTail S.swap
+        -- >>> _
+        >>> S.onTail (S.flipped $ IG.PartialIso
+                      (\(karg :- args :- op :- t) ->
+                         (args ++ [ValVar karg]) :- op :- t)
+                      (\(xs :- op :- t) -> case xs ^? _Snoc of
+                          Just (args,preview #ValVar -> Just karg) ->
+                            Right $ karg:- args :- op :- t
+                          _ -> Left $ S.expected "continuation arg"
+                      ))
+      -- prim = S.headTagged2 "prim"
+      --   (primDatumIso id (S.datumIso @Val))
+      --   (S.datumIso @Kappa)
       prim = S.list $
         S.el (S.decorate S.SynBuiltin >>> S.sym "prim")
         >>> S.el (primDatumIso id (S.datumIso @Val))
         >>> S.el S.datumIso
 
-instance S.DatumIso Kexp where
-  datumIso = S.match
-    $ S.With (S.datumIso @Name >>>)
-    $ S.With (S.datumIso @Kappa >>>)
-    $ S.End
-
 instance S.DatumIso Program where
   datumIso = S.with \prog -> S.datumIso @Lambda >>> prog
 
--- the printed representation is pretty dishonest in its current
--- state. consider the following hoisted program:
--- 
---  (letrec ((k (κ () (continue start-ktail 123))))
---    (λ (start-ktail)
---      (continue k)))
--- 
--- here, `start-ktail` is bound in `k`, but the printed representation
--- fails to reflect that.
-instance S.DatumIso HoistedProgram where
-  datumIso = S.with \prog ->
-    S.letLike "letrec"
-      (S.datumIso @Label) (S.datumIso @Abs) (S.datumIso @Lambda)
-    >>> S.onTail (S.iso H.fromList H.toList)
-    >>> prog
-
 
 -- quasiquoters
 
@@ -407,7 +298,6 @@ instance CPS Kappa where toCPS = S.fromDatumUnsafe S.datumIso
 instance CPS Lambda where toCPS = S.fromDatumUnsafe S.datumIso
 instance CPS Abs where toCPS = S.fromDatumUnsafe S.datumIso
 instance CPS Program where toCPS = S.fromDatumUnsafe S.datumIso
-instance CPS HoistedProgram where toCPS = S.fromDatumUnsafe S.datumIso
 
 cps :: S.QuasiQuoter
 cps = S.makeSx' [| toCPS |]
@@ -430,8 +320,7 @@ class Free a where
   freeWithBound :: HashSet Name -> a -> HashSet Name
   freeWithBound bound = HS.fromList . freeWithBound' bound
 
-  -- | Free variables given in the same left-to-right order they
+  -- | Free variables given in the order of their appearance.
-  -- appear.
   free' :: a -> List Name
   free' = freeWithBound' mempty
 
@@ -441,21 +330,11 @@ instance Free Abs where
   freeWithBound' bound (AbsKappa kap) = freeWithBound' bound kap
   freeWithBound' bound (AbsLambda lam) = freeWithBound' bound lam
 
-mif :: Alternative f => (a -> Bool) -> a -> f a
-mif p a
-  | p a = pure a
-  | otherwise = empty
-
-instance Free Kexp where
-  freeWithBound' bound = \case
-    KexpVar x -> mif (`notElem` bound) x
-    KexpKappa kap -> freeWithBound' bound kap
-
 instance Free Exp where
   freeWithBound' bound = \case
     ExpPrim p k ->
-      (p ^.. folded . #ValVar . filtered (`notElem` bound))
+      p & toListOf (folded . #ValVar . filtered (`notElem` bound))
-      ++ freeWithBound' bound k
+        & (<> freeWithBound' bound k)
     ExpLetRec bs m ->
       foldMapOf (each . _2) (freeWithBound' bound') bs
       <> freeWithBound' bound' m
@@ -463,10 +342,10 @@ instance Free Exp where
     ExpContinue k xs -> filter (`notElem` bound) ((k:xs) ^.. each . #ValVar)
     ExpIf c t f ->
       (c ^.. #ValVar . filtered (`notElem` bound))
-      <> mif (`notElem` bound) t <> mif (`notElem` bound) f
+      <> freeWithBound' bound t <> freeWithBound' bound f
     ExpApply f xs k ->
       (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
-      <> freeWithBound' bound k
+      <> (k ^.. filtered (`notElem` bound))
 
 instance Free Kappa where
   freeWithBound' bound (MkKappa xs m) =

src/Gyehoek/Driver.hs

@@ -1,5 +1,5 @@
 module Gyehoek.Driver
-  (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e, eval_cps_e2e, eval_cps2_e2e)
+  (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e)
   where
 
 import Gyehoek.Options
@@ -35,8 +35,6 @@ import Control.Arrow ((>>>))
 import Gyehoek.Prelude
 import Gyehoek.Jalmot
 import qualified Gyehoek.Sexp as S
-import Gyehoek.CPS.Hoist (hoistProgram)
-import Gyehoek.CPS.Contify (contifyProgram)
 
 
 main :: IO ()
@@ -120,35 +118,29 @@ driver opts = do
     hPutStrLn FS.stdout . view strict . pShowNoColor $ scm
   cps <- convertProgram scm
   when opts.dumpCPS do
-     S.writeDatum cps
+     hPutStrLn FS.stdout =<< S.encodeWith S.datumIso cps
   closedCps <- closeProgram cps
   when opts.dumpClosed do
-    S.writeDatum closedCps
+    hPutStrLn FS.stdout =<< S.encodeWith S.datumIso closedCps
-  hoistedCps <- hoistProgram closedCps
-  when opts.dumpHoisted do
-    S.writeDatum hoistedCps
-  -- contifiedCps <- contifyProgram hoistedCps
-  -- when opts.dumpContified do
-  --   hPutStrLn FS.stdout =<< S.encodeWith S.datumIso contifiedCps
   let rt_is p = is (_Just . p) opts.runtime
   dumpOrRun opts.dumpStackified (rt_is #Stackify)
-    (stackifyProgram hoistedCps)
+    (stackifyProgram closedCps)
     (hPutStrLn FS.stdout <=< S.encodeDataWith S.dataIso)
     (eval >=> fmap writeObj
          >>> T.unwords
          >>> hPutStrLn FS.stdout)
-  when (rt_is #HigherOrderCPS) do
-    CPS.evalProgram cps
-      >>= S.writeData
   when (rt_is #CPS) do
-    CPS.evalProgram closedCps
+    closedCps
-      >>= S.writeData
+      & CPS.evalProgram
+      & 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 hoistedCps >>= traceEval
+    stackifyProgram closedCps >>= traceEval
 
 parse_e2e :: FilePath -> IO Scm.Program
 parse_e2e = runJalmotIO . runFileSystem . readScm
@@ -166,19 +158,3 @@ eval_e2e :: FilePath -> IO (List Obj)
 eval_e2e fp = runJalmotIO . runFileSystem . runGenSym $ do
   stk <- stackifyProgram <=< closeProgram <=< convertProgram <=< readScm $ fp
   eval stk
-
-eval_cps_e2e :: FilePath -> IO Text
-eval_cps_e2e fp = runJalmotIO . runFileSystem . runGenSym $
-  readScm fp
-   >>= convertProgram
-   >>= closeProgram
-   >>= CPS.evalProgram
-   >>= pure . S.encodeOrShowData' S.dataIso
-
-eval_cps2_e2e :: FilePath -> IO Text
-eval_cps2_e2e fp = runJalmotIO . runFileSystem . runGenSym $
-  readScm fp
-   >>= convertProgram
-   -- >>= closeProgram
-   >>= CPS.evalProgram
-   >>= pure . S.encodeOrShowData' S.dataIso

src/Gyehoek/Jalmot.hs

@@ -31,7 +31,6 @@ data AJalmot
   = ReaderError (ParseErrorBundle Text Void)
   | GrammarError (Grammar.ErrorMessage Ann)
   | VMError Text
-  | EvalError Text
   deriving (Show, Generic, Data)
 
 data AJalmotCS = MkAJalmotCS !CallStack !AJalmot
@@ -67,7 +66,6 @@ instance Exception AJalmot where
         & layoutPretty defaultLayoutOptions
         & renderString
     VMError err -> [i|#{err}|]
-    EvalError 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

@@ -13,7 +13,7 @@ import Data.Foldable
 import Gyehoek.Prelude hiding (argument)
 
 
-data Runtime = Stackify | Wasm | CPS | HigherOrderCPS
+data Runtime = Stackify | Wasm | CPS
   deriving (Show, Generic, Eq)
 
 data Language
@@ -29,10 +29,7 @@ data Options = MkOptions
   , dumpCPS :: Bool
   , dumpParsed :: Bool
   , dumpStackified :: Bool
-  , dumpHoisted :: Bool
-  , dumpContified :: Bool
   , traceStackified :: Bool
-  , noColour :: Bool
   , runtime :: Maybe Runtime
   , inspectWasm :: Bool
   , output :: FilePath
@@ -54,8 +51,7 @@ runtimeValues = ["stackify","wasm","cps","none"]
 runtimeReader = maybeReader \case
   "stackify" -> Just (Just Stackify)
   "wasm" -> Just (Just Wasm)
-  "cps1" -> Just (Just CPS)
+  "cps" -> Just (Just CPS)
-  ("cps";"higher-order-cps") -> Just (Just HigherOrderCPS)
   "none" -> Just Nothing
   _ -> Nothing
 
@@ -65,20 +61,14 @@ parser = do
   dumpCPS <- switch (long "dump-cps")
   dumpStackified <- switch (long "dump-stackified")
   dumpParsed <- switch (long "dump-parsed")
-  dumpHoisted <- switch (long "dump-hoisted")
-  dumpContified <- switch (long "dump-contified")
   traceStackified <- switch (long "trace-stackified")
-  noColour <- switch . fold $
-    [ long "no-colour"
-    , long "no-color"
-    ]
   inspectWasm <- switch $ long "inspect-wasm" <> short 'p'
   runtime <- option runtimeReader . fold $
     [ long "runtime"
     , short 'R'
-    , value (Just HigherOrderCPS)
+    , value (Just Stackify)
     , completeWith runtimeValues
-    , showDefaultWith $ const "higher-order-cps"
+    , showDefaultWith $ const "stackify"
     , metavar "RUNTIME"
     ]
   sourceLanguage <- option languageReader . fold $

src/Gyehoek/Scheme/Syntax.hs

@@ -81,13 +81,10 @@ data Prim e
   | PrimZeroP e
   | PrimNewline
   | PrimMakeClosure { code :: e, env :: List e }
-  | PrimMakeSharedClosure { codes :: List e, env :: List e }
+  | PrimEnvRef e Int
-  | PrimGetEnv
+  | 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)
@@ -170,15 +167,10 @@ primDatumIso namefn a = S.match
     $ S.With (. ht1 "zero?")
     $ S.With (. ht0 "newline")
     $ S.With (. ht1' "make-closure")
-    $ S.With (. S.headTagged2 (namefn "make-shared-closure")
+    $ S.With (. S.headTagged2 (namefn "env-ref") a S.int)
-      (S.list $ S.rest a)
+    $ S.With (. ht1 "env-code")
-      (S.list $ S.rest a))
-    $ S.With (. ht0 "get-env")
-    $ 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

src/Gyehoek/Sexp/Grammar.hs

@@ -15,7 +15,6 @@ module Gyehoek.Sexp.Grammar
   , encodeDataTest
   , encodeDataTestColour
   , encodeOrShow'
-  , encodeOrShowData'
   , decodeDataWith
   , encodeDataWith'
   , decodeTest
@@ -29,8 +28,6 @@ module Gyehoek.Sexp.Grammar
   , fromDatumUnsafe
   , Control.Category.id
   , fromDataUnsafe
-  , writeDatum
-  , writeData
   )
   where
 
@@ -48,7 +45,6 @@ import qualified Control.Category
 import qualified Data.Vector as V
 import Data.String (IsString (fromString))
 import qualified Data.Text as T
-import System.Environment (lookupEnv)
 
 
 toDatum :: Jalmot :> es => DatumGrammar a -> a -> Eff es Datum
@@ -130,39 +126,6 @@ encodeOrShow' g x = fromString $
     Left _ -> show x
     Right t -> T.unpack t
 
-encodeOrShow :: (IsString s, Show a) => DatumGrammar a -> a -> s
-encodeOrShow g x = fromString $
-  case runPureEff . runJalmot . encodeWith g $ x of
-    Left _ -> show x
-    Right t -> T.unpack t
-
-encodeOrShowData' :: (IsString s, Show a) => DataGrammar a -> a -> s
-encodeOrShowData' g x = fromString $
-  case runPureEff . runJalmot . encodeDataWith' g $ x of
-    Left _ -> show x
-    Right t -> T.unpack t
-
-encodeOrShowData :: (IsString s, Show a) => DataGrammar a -> a -> s
-encodeOrShowData g x = fromString $
-  case runPureEff . runJalmot . encodeDataWith g $ x of
-    Left _ -> show x
-    Right t -> T.unpack t
-
-useColour :: IO Bool
-useColour = maybe True (const False) <$> lookupEnv "NO_COLOR"
-
-writeDatum :: (Show a, DatumIso a, MonadIO m) => a -> m ()
-writeDatum x = do
-  c <- liftIO useColour 
-  let f = if c then encodeOrShow else encodeOrShow'
-  liftIO . TIO.putStrLn . f datumIso $ x
-
-writeData :: (Show a, DataIso a, MonadIO m) => a -> m ()
-writeData x = do
-  c <- liftIO useColour 
-  let f = if c then encodeOrShowData else encodeOrShowData'
-  liftIO . TIO.putStrLn . f dataIso $ x
-
 class DatumIso a where
   datumIso :: DatumGrammar a
 

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -9,7 +9,7 @@ module Gyehoek.Sexp.Grammar.Base
   , DatumGrammar
   , DataGrammar
   , Grammar
-  , ListContext(..)
+  , ListContext
   , (:-)((:-))
   -- * lists
   , list

src/Gyehoek/Stack/Syntax.hs

@@ -68,14 +68,13 @@ data Tail
   | Call Int
   | If Val Block Block
   | Return Int
-  | CallCC
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
 data Instr
   = Pop Reg
   | Push Val
-  | Load Reg Int
+  | Load Reg
   | Prim Reg (Prim Val)
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
@@ -98,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.headTagged2 "load" S.datumIso S.datumIso >>>)
+    $ S.With (S.headTagged1 "load!" S.datumIso >>>)
     $ S.With (S.headTagged2 "prim" S.datumIso S.datumIso >>>)
     $ S.End
     where
@@ -117,7 +116,6 @@ instance S.DatumIso Tail where
     $ 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

src/Gyehoek/Stack/VM.hs

@@ -1,6 +1,4 @@
 {-# LANGUAGE ViewPatterns, MultilineStrings #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DeriveAnyClass #-}
 module Gyehoek.Stack.VM
   ( VM(..)
   , Env(..)
@@ -30,30 +28,22 @@ 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
+  { currentRoutine :: Label
   }
   deriving (Show, Generic)
 
 newtype Frame = MkFrame { locals :: List Obj }
-  deriving stock (Show, Generic)
+  deriving (Show, Generic)
 
--- affine
+returnAddress :: Traversal' Frame Label
-returnAddress :: Traversal' Frame Obj
+returnAddress = #locals . _last . #ObjImm . #ImmLabel
-returnAddress = #locals . _last
-
--- affine
-activeProcedure :: Traversal' Frame Obj
-activeProcedure = #locals . _init . _last
 
 newtype Stack = MkStack { frames :: NonEmpty Frame }
-  deriving stock (Show, Generic)
+  deriving (Show, Generic)
 
 data VM = MkVM
   { stack :: Stack
@@ -66,12 +56,6 @@ data VM = MkVM
   }
   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))
@@ -79,10 +63,6 @@ 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
 
@@ -112,82 +92,12 @@ vmerror = throwError . VMError
 
 stepI :: Jalmot :> es => Env -> VM -> Instr -> Eff es VM
 
-stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|]
+stepI e vm (Push v) = traverseOf activeFrame push vm
+  where push xs = cons <$> evalVal e vm v <*> pure xs
 
-stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM
+stepI e vm (Prim r p) = traverse (evalVal e vm) p >>= \case
-
-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) -> ret1 . ObjImm . ImmBool $ n == 0
+    ObjImm (ImmInt n) -> ret . 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
@@ -195,70 +105,114 @@ stepP g vm p = traverse (evalVal g vm) p >>= \case
   PrimDiv x y -> arith_binop div x y
   PrimMakeClosure f env ->
     case f of
-      ObjImm (ImmLabel l) -> ret1 . ObjHob $ HobClosure l env
+      ObjImm (ImmLabel l) -> ret . ObjHob $ HobClosure l env
       _ -> vmerror [i|expected label, got #{f}|]
-  PrimEnv -> do
+  PrimEnvCode env ->
-    x <- vm & expectOf "expected closure" (activeFrame . activeProcedure)
+    case env of
-    ret1 x
+      ObjHob (HobClosure l _) -> ret . ObjImm . ImmLabel $ l
-  PrimEnvRef n -> do
+      _ -> vmerror [i|expected closure, got #{env}|]
-    (label,env) <- vm & expectOf "expected closure"
+  PrimEnvRef env n ->
-        (activeFrame . activeProcedure . #_ObjHob . #_HobClosure) 
+    case env of
-    x <- env & expectOf "expected upval" (ix n)
+      ObjHob (HobClosure _ xs) -> ret $ xs ^?! ix n
-    ret1 x
+      _ -> vmerror [i|expected closure, got #{env}|]
-  PrimCons x y -> ret1 $ ObjHob $ HobPair x y
+  PrimCons x y -> ret $ ObjHob $ HobPair x y
   PrimCar x -> case x of
-      ObjHob (HobPair car _) -> ret1 car
+      ObjHob (HobPair car _) -> ret car
       _ -> vmerror [i|expected pair, got ${x}|]
   PrimCdr x -> case x of
-      ObjHob (HobPair _ cdr) -> ret1 cdr
+      ObjHob (HobPair _ cdr) -> ret 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 vs = pure $ vm & activeFrame . #locals <>:~ vs
+    ret v = pure $ vm & #registers . at r ?~ v
-    ret1 v = ret [v]
     arith_binop op (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
-      ret1 $ ObjImm (ImmInt (op x y))
+      ret $ ObjImm (ImmInt (op x y))
     arith_binop _ x y = vmerror [i|bad arith: #{x}, #{y}|]
 
-
+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
 
-popFrame :: (HasCallStack, Jalmot :> es) => Stack -> Eff es (Frame, Stack)
+stepI e vm ins = vmerror [i|unimplemented instruction: #{ins}|]
-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
+stepT :: Jalmot :> es => Env -> VM -> Tail -> Eff es VM
-jumpToBlock b vm = vm
-  & #code .~ b.code
-  & #tail .~ b.tail
 
-jumpToRoutine :: Routine -> VM -> VM
+stepT g vm tc@(Call nargs) =
-jumpToRoutine rt vm = vm
+  case parseCall nargs (vm ^. activeFrame) of
-  & jumpToBlock rt.start
+    Nothing -> vmerror "bla"
-  & #debug . #activeRoutine .~ rt.label
+    Just (args,f,ret,frm) ->
+      case g ^. #labels . at ret of
+        Nothing -> vmerror [i|undefined label #{ret}|]
+        Just rt -> do
+          let newFrame = MkFrame $ args ++ [ObjLabel f,ObjLabel ret]
+          pure $ vm
+            & #code .~ rt.start.code
+            & #tail .~ rt.start.tail
+            & activeFrame .~ frm
+            & #stack %~ pushFrame newFrame
+            & #registers .~ mempty
 
-getLabel :: Obj -> Maybe Label
+stepT g vm tc@(Return nret) =
-getLabel = \case
+  case splitAtExact nret (vm ^. activeFrame . #locals) of
-  ObjHob (HobClosure {label}) -> Just label
+    Nothing -> vmerror [i|bad stack at #{tc}|]
-  ObjHob (HobContinuation {cont}) -> getLabel cont
+    Just (xs,_) ->
-  ObjImm (ImmLabel label) -> Just label
+      case vm ^? activeFrame . returnAddress of
-  x -> Nothing
+        Nothing -> vmerror [i|bad stack #{tc}|]
+        Just "halt" -> pure $ vm & #result ?~ xs
+        Just ra ->
+          case g ^. #labels . at ra of
+            Nothing -> vmerror [i|undefined label #{ra}|]
+            Just rt -> vm
+              & traverseOf (#stack . #frames) \st -> case NE.uncons st of
+                (_, Nothing) -> vmerror "explode"
+                (f, Just fs) -> pure $ fs & _NonEmpty . _1 %~ pushes xs
 
-getRoutine :: (HasCallStack, Jalmot :> es) => Env -> Obj -> Eff es Routine
+stepT g vm tc@(TailCall nargs) =
-getRoutine g f = do
+  case parseTailCall nargs (vm ^. activeFrame) of
-  l <- getLabel f & expectOf [i|no label for #{f}|] _Just
+    Nothing -> vmerror [i|bad stack at #{tc}|]
-  case g ^. #labels . at l of
+    Just (args,"halt",_) -> pure $ vm & #result ?~ args
-    Just rt -> pure rt
+    Just (args,f,ra) -> do
-    Nothing -> vmerror [i|undefined label #{l}|]
+      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
+        & #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
 
-expectOf
+-- stepT g vm tc@(TailCall nargs) =
-  :: (HasCallStack, Jalmot :> es)
+--   case setupCall nargs (vm ^. stack) of
-  => Text -> Getting (First a) s a -> s -> Eff es a
+--     Nothing -> vmerror [i|bad stack at #{tc}|]
-expectOf msg l = maybe (vmerror msg) pure . preview l
+--     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
 
 evalToLabel :: Jalmot :> es => Env -> VM -> Val -> Eff es Label
 evalToLabel e vm v =
@@ -283,22 +237,20 @@ takeExact n xs = case compareLength xs n of
   (EQ;GT) -> Just $ take n xs
   LT -> Nothing
 
-parseCallCC :: Frame -> Maybe (Obj, Obj, Frame)
+parseCall :: Int -> Frame -> Maybe (List Obj, Label, Label, 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)
+  f' <- f ^? #ObjImm . #ImmLabel
+  ret' <- ret ^? #ObjImm . #ImmLabel
+  pure (xs',f',ret',MkFrame ys)
 
-parseTailCall :: Int -> Frame -> Maybe (List Obj, Obj, Obj)
+parseTailCall :: Int -> Frame -> Maybe (List Obj, Label, Label)
 parseTailCall nargs frm = do
   (xs,_) <- splitAtExact (nargs+1) (frm ^. #locals)
   let (xs',f) = xs ^?! _Snoc
-  pure (xs',f,frm ^?! returnAddress)
+  f' <- f ^? #ObjImm . #ImmLabel
+  pure (xs',f',frm ^?! returnAddress)
 
 initialVM :: VM
 initialVM = MkVM
@@ -313,7 +265,7 @@ initialVM = MkVM
   , stdout = ""
   , result = Nothing
   , debug = MkDebugVM
-    { activeRoutine = "<nowhere>"
+    { currentRoutine = "<nowhere>"
     }
   }
 
@@ -400,11 +352,6 @@ ppDoc p t =
         .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
@@ -418,7 +365,7 @@ ppTrace trace =
   table_ do
     thead_ $ tr_ do
       traverse_ (th_ [scope_ "col"])
-        ["routine","next instruction","stack frame"]
+        ["location","instruction","stack"]
     tbody_ do
       go trace
   where
@@ -450,58 +397,29 @@ ppVM vm = do
     td_ do
       details_ do
         summary_ do
-          var_ [class_ "loc"] do
+          var_ [class_ "loc"] . toHtml $ vm ^. #debug . #currentRoutine
-            vm ^. #debug . #activeRoutine . to ppDatum
+            . re (prefixed "$" . _Unwrapped' . _Unwrapped')
         pre_ do
           code_ . toHtml . pShowNoColor $ vm
     td_ do
       code_ curi
     td_ do
-      ppStack vm.stack
+      let xs = _
+      sequence_ $ intersperse " | " xs
   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|
+blah = [stkP|
+        (define $id
+          (return 1))
+        (define $c
+          (return 1))
         (define $start
-  (push! $fac)
+          (push! $c)
-  (push! #{n})
+          (push! $id)
-  (tail-call 1))
+          (push! 123)
-
+          (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

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

test/Gyehoek/Test/CPS/Eval.hs

@@ -5,75 +5,53 @@ 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, expectFail)
+import Test.Tasty.ExpectedFailure (ignoreTestBecause)
-import System.Directory (listDirectory)
-import Test.Tasty.Silver
-import System.FilePath
-import Control.Exception
-import qualified Gyehoek.Driver as Driver
-import Control.DeepSeq (($!!))
-import System.Exit (ExitCode(..))
-import qualified Data.Text as T
-import Data.Function (applyWhen)
-import Gyehoek.Prelude
 
 
-brokenEvalTests :: List String
+test_cpsInterpreter =
-brokenEvalTests =
+  ignoreTestBecause "i forgorrrr" $
-  []
+  testGroup "cps interpreter" $
-  -- [ "adder"
+  [ primitives
-  -- , "apply2"
+  , testCase "halt with constant" do
-  -- , "apply-twice"
+      evalsTo [ObjImm (ImmInt 123)] [cps|
-  -- , "arith"
+        (continue halt 123)
-  -- , "begin-1"
+      |]
-  -- , "callcc-constant"
+  , testCase "identity cont" do
-  -- , "callcc-discard"
+      evalsTo [ObjImm (ImmInt 154)] [cps|
-  -- , "callcc-early-exit-1"
+        (letrec ((id (κ (x)
-  -- , "callcc-early-exit-2"
+                       (continue halt x))))
-  -- , "callcc-early-exit-3"
+          (continue id 154))
-  -- , "callcc-early-exit-4"
+      |]
-  -- , "callcc-early-exit-5"
+  , testCase "identity function" do
-  -- , "callcc-early-exit-6"
+      evalsTo [ObjImm (ImmInt 456)] [cps|
-  -- , "callcc-nested-1"
+        (letrec ((id (λ (x ktail)
-  -- , "callcc-nested-2"
+                       (continue ktail x))))
-  -- , "complicated-1"
+          (id 456 halt))
-  -- , "cons-1"
+      |]
-  -- , "factorial"
+  , testCase "square" do
-  -- , "false"
+      evalsTo [ObjImm (ImmInt 81)] [cps|
-  -- , "fn-of-fn"
+        (letrec ((square (λ (x ktail)
-  -- , "if-false"
+                           (prim (* x x)
-  -- , "if-number"
+                             (κ (r) (continue ktail r))))))
-  -- , "if-true"
+          (square 9 halt))
-  -- , "lambda"
+      |]
-  -- , "letrec-fn"
-  -- , "let-fn"
-  -- , "lit-int"
-  -- , "square"
-  -- , "true"
-  -- ]
-
-test_eval :: IO TestTree
-test_eval = do
-  cs <- listDirectory "golden/exec"
-      <&> fmap ("golden/exec" </>)
-  pure $ testGroup "cps interpreter"
-    [ testGroup "higher-order" $ cpsCase Driver.eval_cps2_e2e <$> cs
-    , testGroup "first-order" $ cpsCase Driver.eval_cps_e2e <$> cs
   ]
 
-maybeBroken name broken = applyWhen (name `elem` broken) expectFail
+evalsTo :: HasCallStack => List Obj -> Sut.Exp -> Assertion
+evalsTo rs e = Sut.evalExp e @?= rs
 
-cpsCase :: (FilePath -> IO Text) -> FilePath -> TestTree
+primitives = testGroup "primitives"
-cpsCase f test =
+  [ testGroup "arith"
-  maybeBroken testName brokenEvalTests $
+    [ testCase "basic 1" do
-    goldenVsAction testName resultFile action printProcResult
+        evalsTo [ObjImm (ImmInt 20)] [cps|
-  where
+          (prim (* 4 5)
-    testName = takeFileName test
+            (κ (x) (continue halt x)))
-    resultFile = test </> "exec"
+          |]
-    sourceFile = test </> "source.scm"
+    , testCase "basic 2" do
-    action = catch @SomeException
+        evalsTo [ObjImm (ImmInt 35)] [cps|
-      (do r <- f sourceFile
+          (prim (* 2 16)
-          pure $!! ( ExitSuccess
+            (κ (x) (prim (+ x 3)
-                   , r
+                      (κ (r) (continue halt r)))))
-                   , "" ))
+          |]
-      \e -> pure (ExitFailure 1, "", T.pack $ displayException e)
+    ]
+  ]

test/Gyehoek/Test/CPS/Stackify.hs

@@ -10,87 +10,81 @@ import Gyehoek.GenSym (runGenSym)
 import Effectful
 import Gyehoek.Prelude
 import Gyehoek.Jalmot
-import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause)
 
 
--- test_stackify =
+test_stackify =
---   [ trivialReturn
+  [ trivialReturn
---   , tailCall
+  , tailCall
---   , prim
+  , prim
---   , condition
+  , condition
---   , procedure
+  , procedure
---   ]
+  ]
 
--- evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion
+evalsTo :: List Obj -> Sut.Exp -> Assertion
--- evalsTo rs e = runJalmotUnsafe (Stk.eval e') @?= rs
+evalsTo rs e = runJalmotUnsafe (Stk.eval e') @?= rs
---   where
+  where
---     e' = e & Sut.stackifyProgram & runGenSym & runPureEff
+    e' = e & CPS.MkLambda [] "_ktail"
+      & CPS.MkProgram
+      & Sut.stackifyProgram & runGenSym & runPureEff
 
--- trivialReturn = testGroup "trivial return"
+trivialReturn = testGroup "trivial return"
---   [ testCase "return int" do
+  [ testCase "return int" do
---       evalsTo [ObjImm (ImmInt 4)]
+      evalsTo [ObjImm (ImmInt 4)]
---         [cps|(λ (ktail) (continue ktail 4))|]
+        [cps|(continue halt 4)|]
---   , testCase "return bool" do
+  , testCase "return bool" do
---       evalsTo [ObjImm (ImmBool True)]
+      evalsTo [ObjImm (ImmBool True)]
---         [cps|(λ (ktail) (continue ktail #t))|]
+        [cps|(continue halt #t)|]
---       evalsTo [ObjImm (ImmBool False)]
+      evalsTo [ObjImm (ImmBool False)]
---         [cps|(λ (ktail) (continue ktail #f))|]
+        [cps|(continue halt #f)|]
---   ]
+  ]
 
--- tailCall = testGroup "tail call"
+tailCall = testGroup "tail call"
---   [ testCase "square" do
+  [ testCase "square" do
---       evalsTo [ObjImm (ImmInt 16)] [cps|
+      evalsTo [ObjImm (ImmInt 16)]
---         (λ (ktail0)
+        [cps|(letrec ((square (λ (x ktail)
---           (letrec ((square (λ (x ktail)
+                                (prim (* x x)
---                              (prim (* x x)
+                                  (κ (x0) (continue ktail x0))))))
---                                (κ (x0) (continue ktail x0))))))
+               (square 4 halt))|]
---             (square 4 halt)))
+  ]
---       |]
---   ]
 
--- prim = testGroup "prim"
+prim = testGroup "prim"
---   [ testCase "multiply" do
+  [ testCase "multiply" do
---       evalsTo [ObjImm (ImmInt 20)]
+      evalsTo [ObjImm (ImmInt 20)]
---         [cps|(λ (ktail0)
+        [cps|(prim (* 4 5)
---             (prim (* 4 5)
+               (κ (x) (continue halt x)))|]
---                (κ (x) (continue ktail0 x))))|]
+  , testCase "add" do
---   , testCase "add" do
+      evalsTo [ObjImm (ImmInt 9)]
---       evalsTo [ObjImm (ImmInt 9)]
+        [cps|(prim (+ 4 5)
---         [cps|(λ (ktail0)
+               (κ (x) (continue halt x)))|]
---         (prim (+ 4 5)
+  -- , testGroup "call/cc"
---                (κ (x) (continue ktail0 x))))|]
+  --   [ testCase "trivial" do
---   -- , testGroup "call/cc"
---   --   [ testCase "trivial" do
---   --       evalsTo [ObjImm (ImmInt 123)]
---   --         [cps|(letrec ((f (λ (cc ktail) (continue cc 123))))
---   --                (prim (call/cc f)))|]
---   --   ]
---   ]
-
--- condition = testCase "if" do
   --       evalsTo [ObjImm (ImmInt 123)]
---     [cps|(λ (ktail0)
+  --         [cps|(letrec ((f (λ (cc ktail) (continue cc 123))))
---       (if #t (continue ktail0 123) (continue ktail0 456)))|]
+  --                (prim (call/cc f)))|]
---   evalsTo [ObjImm (ImmInt 456)]
---     [cps|(λ (ktail0)
---       (if #f (continue ktail0 123) (continue ktail0 456)))|]
-
--- procedure = testGroup "procedure"
---   [ testCase "factorial" do
---       evalsTo [ObjImm (ImmInt 720)]
---         [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)))|]
   --   ]
+  ]
+
+condition = testCase "if" do
+  evalsTo [ObjImm (ImmInt 123)]
+    [cps|(if #t (continue halt 123) (continue halt 456))|]
+  evalsTo [ObjImm (ImmInt 456)]
+    [cps|(if #f (continue halt 123) (continue halt 456))|]
+
+procedure = testGroup "procedure"
+  [ testCase "factorial" do
+      evalsTo [ObjImm (ImmInt 720)]
+        [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))|]
+  ]

test/Gyehoek/Test/CPS/Syntax.hs

@@ -46,9 +46,9 @@ qq = testGroup "parser"
   , testCase "application" do
       assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
                      [Sut.ValVar "x",Sut.ValVar "y"]
-                     (Sut.KexpVar "k"))
+                     "k")
         [cps|(f x y k)|]
       assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
-                     [] (Sut.KexpVar "k"))
+                     [] "k")
         [cps|(f k)|]
   ]

test/Gyehoek/Test/Golden.hs

@@ -29,7 +29,10 @@ brokenWasmTests =
 
 brokenStackifyTests :: List String
 brokenStackifyTests =
-  [
+  [ "callcc-early-exit-1"
+  , "callcc-early-exit-4"
+  , "callcc-early-exit-5"
+  , "callcc-early-exit-6"
   ]
 
 test_root :: IO TestTree
@@ -40,8 +43,7 @@ test_root = do
   testGroup "execution" <$> sequenceA
     [ ignoreTestBecause "wasm codegen is on the backburner"
       <$> wasmTests tests
-    , ignoreTestBecause "i'm killing myself"
+    , stackifyTests tests
-      <$> stackifyTests tests
     ]
 
 maybeBroken name broken = applyWhen (name `elem` broken) expectFail

test/Gyehoek/Test/Stack/VM.hs

@@ -7,14 +7,12 @@ import Gyehoek.Stack.Syntax
 import Gyehoek.Stack.VM qualified as Sut
 import Data.List (List)
 import Gyehoek.Jalmot
-import Gyehoek.Prelude (i)
-import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause)
 
 
 evalsTo :: List Obj -> Program -> Assertion
 evalsTo rs p = runJalmotUnsafe (Sut.eval p) @?= rs
 
-test_root = ignoreTestBecause "i'm super-killing myself" $ testGroup "stack machine"
+test_root = testGroup "stack machine"
   [ testCase "immediate halt" do
       evalsTo [] [stkP|
         (define $start
@@ -38,75 +36,59 @@ test_root = ignoreTestBecause "i'm super-killing myself" $ testGroup "stack mach
           (push! 123)
           (call 1))
       |]
-  , testCase "tail identity function" do
+  -- , testCase "return constant" do
-      evalsTo [ObjImm (ImmInt 123)] [stkP|
+  --     evalsTo [ObjImm (ImmInt 123)] [stkP|
-        (define $id
+  --       (define ($start %ktail)
-          (return 1))
+  --         (tail-call $silly %ktail))
-        (define $start
+  --       (define ($silly %ktail)
-          (push! $id)
+  --         (tail-call %ktail 123))
-          (push! 123)
+  --     |]
-          (tail-call 1))
+  -- , testCase "identity continuation" do
-      |]
+  --     evalsTo [ObjImm (ImmInt 45)] [stkP|
-  , testCase "return constant" do
+  --       (define ($start %ktail)
-      evalsTo [ObjImm (ImmInt 123)] [stkP|
+  --         (push! %ktail)
-        (define $start
+  --         (tail-call $id 45))
-          (push! $silly)
+  --       (define ($id %x)
-          (tail-call 1))
+  --         (pop! %ktail)
-        (define $silly
+  --         (tail-call %ktail %x))
-          (push! 123)
+  --     |]
-          (return 1))
+  -- , testCase "identity function" do
-      |]
+  --     evalsTo [ObjImm (ImmInt 45)] [stkP|
-  , testCase "return multiple" do
+  --       (define ($start %ktail)
-      evalsTo [ObjImm (ImmInt n) | n <- [1,2,3]] [stkP|
+  --         (tail-call $id 45 %ktail))
-        (define $start
+  --       (define ($id %x %ktail)
-          (push! 3)
+  --         (tail-call %ktail %x))
-          (push! 2)
+  --     |]
-          (push! 1)
+  -- , testCase "square" do
-          (return 3))
+  --     evalsTo [ObjImm (ImmInt 16)] [stkP|
-      |]
+  --       (define ($start %ktail)
-  , testCase "return none" do
+  --         (tail-call $square 4 %ktail))
-      evalsTo [] [stkP|
+  --       (define ($square %x %ktail)
-        (define $start
+  --         (prim %x2 (* %x %x))
-          (return 0))
+  --         (tail-call %ktail %x2))
-      |]
+  --     |]
-  , testCase "square" do
+  -- , testCase "factorial" do
-      evalsTo [ObjImm (ImmInt 16)] [stkP|
+  --     let hsfac (n :: Int) = foldr (*) (1) [1..n]
-        (define $start
+  --     let fac (n :: Int) = [stkP|
-          (push! $square)
+  --           (define ($fac %n %ktail)
-          (push! 4)
+  --             (prim %x0 (zero? %n))
-          (tail-call 1))
+  --             (if %x0
-        (define $square
+  --               (then (tail-call %ktail 1))
-          (pop! %x)
+  --               (else (push! %n)
-          (prim (* %x %x))
+  --                     (push! %ktail)
-          (return 1))
+  --                     (prim %x1 (- %n 1))
-      |]
+  --                     (tail-call $fac %x1 $fac-k0))))
-  , testGroup "factorial"
+  --           (define ($fac-k0 %x2)
-      let
+  --             (pop! %ktail)
-        hsfac (n :: Int) = foldr @List (*) 1 [1..n]
+  --             (pop! %n)
-        fac (n :: Int) = [stkP|
+  --             (prim %x3 (* %x2 %n))
-          (define $start
+  --             (tail-call %ktail %x3))
-            (push! $fac)
+  --           (define ($start %ktail)
-            (push! #{n})
+  --             (tail-call $fac #{n} %ktail))
-            (tail-call 1))
+  --         |]
-          (define $fac
+  --     evalsTo [ObjImm (ImmInt 1)] $ fac 0
-            (load %n 0)
+  --     evalsTo [ObjImm (ImmInt 1)] $ fac 1
-            (prim (zero? %n))
+  --     evalsTo [ObjImm (ImmInt 720)] $ fac 6
-            (pop! %x0)
+  --     -- 20 is the greatest `n` for which n! ≤ maxBount @Int
-            (if %x0
+  --     evalsTo [ObjImm (ImmInt 2432902008176640000)] $ fac 20
-                (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
-      in [ mkcase n | n <- [0,1,6,20] ]
   ]