fix runtime parsing lol

golden/exec/cons-2/source.scm

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

golden/exec/lit-int/exec

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

golden/exec/lit-int/source.scm

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

src/Gyehoek/CPS/Close.hs

@@ -31,7 +31,6 @@ close1 = \case
             (each . _2)
             (freeWithBound' boundNames')
           & nub
-    pTraceShowM frees
     env_cont_l <- gensym' @Name "env-cont"
     e_l <- gensym' @Name "letrec-body-cont"
     bs' <- for bs \(f,ab) -> do
@@ -54,39 +53,3 @@ close = transformM close1
 
 closeProgram :: GenSym :> es => Program -> Eff es Program
 closeProgram = traverseOf (#body . #body) close
-
-prog :: Program
-prog = [cps|
-(λ (start-ktail0)
-  (letrec ((fac
-            (λ (n lambda-tail1)
-              (letrec ((prim-k3
-                        (κ (r2)
-                          (letrec ((truthy-cont4
-                                    (κ ()
-                                      (continue lambda-tail1 1)))
-                                   (falsey-cont5
-                                    (κ ()
-                                      (letrec ((prim-k7
-                                                (κ (r6)
-                                                  (letrec
-                                                      ((r8
-                                                        (κ (x9)
-                                                          (letrec
-                                                              ((prim-k11
-                                                                (κ (r10)
-                                                                  (continue
-                                                                   lambda-tail1
-                                                                   r10))))
-                                                            (prim
-                                                             (* n x9)
-                                                             prim-k11)))))
-                                                    (fac r6 r8)))))
-                                        (prim (- n 1) prim-k7)))))
-                            (if r2
-                              truthy-cont4
-                              falsey-cont5)))))
-                (prim (zero? n) prim-k3)))))
-    (letrec ((r12 (κ (x13) (continue start-ktail0 x13))))
-      (fac 20 r12))))
-|]

src/Gyehoek/CPS/Convert.hs

@@ -49,12 +49,15 @@ convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
 convert (Scm.ExpPrim p) k =
   telescope (convert1 @es) p \p' -> do
     r_l <- gensym' "r"
-    k_l <- gensym' @Name "prim-k"
+    -- k_l <- gensym' @Name "prim-k"
     m <- k [ValVar r_l]
     pure [cps|
-      (letrec ((#{k_l} (κ (#{r_l}) #{m})))
+      (prim #{p'} (κ (#{r_l}) #{m}))
-        (prim #{p'} #{k_l}))
     |]
+    -- pure [cps|
+    --   (letrec ((#{k_l} (κ (#{r_l}) #{m})))
+    --     (prim #{p'} #{k_l}))
+    -- |]
 
 convert (Scm.ExpLambda xs e) k = do
   f <- gensym' "lambda-body"

src/Gyehoek/CPS/Eval.hs

@@ -1,99 +1,259 @@
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedLists #-}
 module Gyehoek.CPS.Eval
   ( evalProgram
   , module Gyehoek.CPS.Syntax
   , evalExp
+  , eGrammar
   ) where
 
-import Gyehoek.CPS.Syntax
+import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..), cont)
-import Control.Lens
+import Gyehoek.Sexp qualified as S
+import Control.Lens hiding (assign)
 import Data.Maybe (fromMaybe)
 import Text.Show.Functions ()
 import qualified Data.HashMap.Strict as H
-import Gyehoek.Prelude
+import Gyehoek.Prelude hiding (assign)
 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_)
 
 
-data Env = MkEnv
+newtype Loc = MkLoc { getLoc :: Int }
-  { vars :: HashMap Name Obj
+  deriving stock (Generic, Data)
-  , labels :: HashMap Name (Env, Abs)
+  deriving newtype (Show, Eq, Ord, Enum)
+
+data Store = MkStore
+  { nextLoc :: Loc
+  , heap :: IntMap E
   }
-  deriving (Show, Generic)
+  deriving stock (Show, Generic)
 
-eval :: Env -> Exp -> List Obj
+type instance Index Store = Loc
+type instance IxValue Store = E
 
-eval g (Halt xs) = evalVal g <$> xs
+instance Ixed Store where ix (MkLoc j) = #heap . ix j
+instance At Store where at (MkLoc j) = #heap . at j
 
-eval g (ExpContinue k xs) =
+emptyStore :: Store
-  case g ^. #labels . at k' of
+emptyStore = MkStore
-    Just (h, AbsKappa' bs m) -> eval h' m
+  { nextLoc = MkLoc 0
-      where
+  , heap = mempty
-        h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
+  }
-    _ -> error [i|not a kappa: #{k}|]
-  where
-    k' = case evalVal g k of
-      ObjImm (ImmLabel x) -> x
-      x -> error [i|expected label, got #{x}|]
 
-eval g (ExpApply f xs ktail) =
+newtype Env = MkEnv { getEnv :: HashMap Name Loc }
-  case g ^?! #labels . at f' of
+  deriving stock (Show, Generic, Data)
-    Just (h,AbsLambda' bs kb m) -> eval h' m
+  deriving newtype (Semigroup, Monoid)
-      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
-                   & #labels . at kb .~ (g ^. #labels . at ktail)
-    Nothing -> error [i|undefined label: #{f}|]
-  where
-    f' = case evalVal g f of
-      ObjImm (ImmLabel x) -> x
-      x -> error [i|expected label, got #{x}|]
-
-eval g (ExpLetRec [(b, ab)] e) = eval g' e
-  where g' = g & #labels . at b ?~ ab
-
-eval g (ExpPrim p (MkKappa bs e)) = case evalVal g <$> p of
-  PrimAdd x y -> arithBinop (+) x y
-  PrimMul x y -> arithBinop (*) x y
-  PrimSub x y -> arithBinop (-) x y
-  PrimDiv x y -> arithBinop div x y
-  PrimMakeClosure x env -> ret [ObjHob (HobClosure lbl env) ]
-    where
-      lbl = case x of
-        ObjImm (ImmLabel l) -> l
-        _ -> error [i|expected label, got #{x}|]
-  _ -> error [i|unhandled prim: #{p}|]
-  where
-    ret rs = eval
-        (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}|]
-
-eval _ e = error [i|unimplemented case: #{e}|]
-
-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
+emptyEnv = mempty
-  { 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
+type instance Index Env = Name
-evalExp = eval emptyEnv
+type instance IxValue Env = Loc
 
-evalProgram :: Program -> List Obj
+instance Ixed Env where ix j = #getEnv . ix j
-evalProgram (MkProgram lam) = eval emptyEnv [cps|
+instance At Env where at j = #getEnv . at j
-  (letrec ((start #{lam}))
+
-    (start halt))
+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
+  = Mut
+  | NoMut
+  deriving (Show, Generic, Data, Eq)
+
+wrong :: Text -> M Answer a
+wrong s = ContT \_ -> pure . AnswerError . EvalError $ s
+
+bind :: Name -> Loc -> Env
+bind k = MkEnv . H.singleton k
+
+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
+    go = \case
+      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]
+    arith2 f x y = wrong [i|나쁜 인자: #{x}, #{y}|]
+
+
+
+evalExp :: Jalmot :> es => Exp -> Eff es _
+evalExp e = _
+
+evalProgram :: Jalmot :> es => Program -> Eff es (List S.Datum)
+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
+      g <- setup
+      eval g MkDynPoints (ExpLetRec
+        [("_start",AbsLambda lam)]
+        (ExpApply (ValVar "_start") [] (KexpVar "halt")))
+
+
+
+setup :: M Answer Env
+setup = defines @List
+  [ ("halt", EProcedure prim_halt)
+  ]
+
+prim_halt :: Procedure
+prim_halt xs _dps = ContT \_ -> pure $ AnswerValues xs

src/Gyehoek/CPS/Hoist.hs

@@ -9,12 +9,12 @@ import Effectful.Writer.Static.Local
 import Data.Foldable
 
 
-type Hoist = Writer (HashMap Name Abs)
+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 k v) bs
+    traverse_ (\(k,v) -> tell $ H.singleton (MkLabel k) v) bs
     pure m
   e -> pure e
 

src/Gyehoek/CPS/Stackify.hs

@@ -17,29 +17,9 @@ 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 `elem` g.bound
-  -- && not (x `elem` g.contStack)
-
--- | The expression @load g e r n@ emits a 'Stk.Load' instruction if
--- stack variable @n@ is live-out in expression @e@. Otherwise, a
--- 'Stk.Pop' instruction is emitted.
-load :: Free a => Env -> a -> Reg -> Int -> Stk.Instr
-load g e r 0
-  | Just x <- g ^? #bound . _head
-  , x `elem` free e
-  = Stk.Pop r
-load g e r n = Stk.Load r n
-
 data BlockBuilder
   = Code (List Stk.Instr) BlockBuilder
   | Tail Stk.Tail
@@ -50,231 +30,137 @@ buildBlock = go [] where
   go acc (Code xs bb) = go (acc ++ xs) bb
   go acc (Tail t) = Stk.MkBlock acc t
 
-emitRoutine :: Stackify :> es => Stk.Routine -> Eff es ()
-emitRoutine rt = tell [rt]
-
-stackify
-  :: forall es. (GenSym :> es, Stackify :> es)
-  => Env -> Exp -> Eff es BlockBuilder
-
-stackify g (ExpLetRec bs e) = do
-  for_ bs \(f,a) ->
-    emitRoutine =<< case a of
-      AbsKappa kap -> stackifyKappa g (MkLabel f) kap
-      AbsLambda lam -> stackifyLambda g (MkLabel f) lam
-  stackify g e
-
-stackify g (ExpIf c t f) = do
-  let c' = stackifyVal g c
-  let jump l =
-       Stk.MkBlock
-         [Stk.Push . Stk.ValLabel . MkLabel $ l]
-         (Stk.TailCall 0)
-  pure . Tail $ Stk.If c' (jump t) (jump f)
-
-stackify g (ExpApply f xs ktail) = do
-  pure $
-    Code [ Stk.Push $ stackifyVal g (ValVar $ ktail ^?! #KexpVar)
-         , Stk.Push $ stackifyVal g f
-         ] $
-    Code (pushArgs g xs) $
-    Tail (Stk.Call (length xs))
-
-stackify g e@(ExpContinue k xs)
-  | isn't (#_ValVar . only g.tail) k = pure $
-    Code [ Stk.Push (stackifyVal g k) ] $
-    Code (pushArgs g xs) $
-    Tail $ Stk.TailCall (length xs)
-  | otherwise = pure $
-    Code (pushArgs g xs) $
-    Tail (Stk.Return (length xs))
-
-stackify g (ExpPrim (PrimCallCC withcc) cc) = do
-  let cc' = cc ^?! #KexpVar . to MkLabel
-  cc_l <- gensym' @Label "cc"
-  pure $
-    Code [ Stk.Push $ stackifyVal g withcc
-         , Stk.Push $ stackifyVal g (ValLabel cc')
-         ] $
-    Tail Stk.CallCC
-
-stackify g (ExpPrim p cc) = pure $
-  Code [ Stk.Push (Stk.ValLabel . MkLabel $ cc ^?! #KexpVar)
-       , Stk.Prim (stackifyVal g <$> p)
-       ] $
-  Tail $ Stk.TailCall 1
-
-stackify _ e = error [i|unimplemented exp: #{e}|]
-
-loadArgs :: List Name -> List Stk.Instr
-loadArgs = imapOf itraversed \n x -> Stk.Load (MkReg x) n
-
-pushArgs :: Env -> List Val -> List Stk.Instr
-pushArgs g args = [ Stk.Push $ stackifyVal g x | x <- reverse args ]
-
 -- affine
 _ValName :: Traversal' Val Name
 _ValName = failing #_ValVar (#_ValImm . #_ImmLabel . #_MkLabel)
 
-stackifyKappa
+stackify
-  :: (Stackify :> es, GenSym :> es)
+  :: forall es. (GenSym :> es)
-  => Env -> Label -> Kappa
+  => Env -> Exp -> Eff es BlockBuilder
-  -> Eff es Stk.Routine
-stackifyKappa g kname (MkKappa xs m) = do
-  let g' = g & #bound <>:~ xs
-  m' <- stackify g' m
-  pure $
-    Stk.MkRoutine kname . buildBlock $
-    Code (loadArgs xs) $
-    Code [ Stk.Load (MkReg r) j
-         | v <- g ^.. #liveness . ix kname . each
-         , (j,r) <- itoListOf (#bound . itraversed) g
-         , r == v
-         ] $
-    m'
 
-stackifyLambda
+stackify _ (ExpContinue (ValVar k) xs) =
-  :: (Stackify :> es, GenSym :> es)
+  Code [ ] _
-  => 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
+stackify _ (ExpPrim p k) = _
-stackifyVal g = \case
-  ValImm imm -> Stk.ValImm imm
-  ValVar v -> case regOf g v of
-    Just r -> Stk.ValReg r
-    Nothing -> Stk.ValLabel (MkLabel v)
-  v -> error [i|unimplemented val: #{v}|]
 
-regOf :: Env -> Name -> Maybe Reg
+stackify _ e = error [i|unimplemented exp: #{e}|]
-regOf g x
+
-  | x `elem` g.bound || x == g.tail = Just . MkReg $ x
+stackifyAbs :: (GenSym :> es) => Env -> Label -> Abs -> Eff es Stk.Routine
-  | otherwise                       = Nothing
+
+stackifyAbs g lbl (MkAbs xs mtail e) =
+  Stk.MkRoutine lbl . buildBlock . preamble <$> stackify g e
+  where
+    preamble = Code (popArgs $ (mtail ^.. _Just) ++ xs)
+
+popArgs :: List Name -> List Stk.Instr
+popArgs = fmap (Stk.Pop . MkReg) . reverse
+
+pushArgs :: List Name -> List Stk.Instr
+pushArgs = _
 
 
 
 data Env = MkEnv
-  -- | `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 Label (List Name)
-  , tail :: Name
   }
   deriving (Show, Generic)
 
 emptyEnv :: Env
 emptyEnv = MkEnv
-  { bound = mempty
+  {
-  , liveness = mempty
-  , tail = "halt"
   }
 
 
 
-stackifyProgram :: GenSym :> es => HoistedProgram -> Eff es Stk.Program
+stackifyProgram
-stackifyProgram p = do
+  :: forall es. GenSym :> es
-  let liveness = p & foldMapOf
+  => HoistedProgram -> Eff es Stk.Program
-        (#bindings . itraversed . withIndex . aside #AbsKappa)
+stackifyProgram p = p
-        \(kname,kap) -> H.singleton
+  & ifoldMapOf
-          (MkLabel kname)
+    ((#bindings . itraversed)
-          (nub $ freeWithBound' (H.keysSet p.bindings) kap)
+     <> (#body . to (H.singleton "start" . AbsLambda) . itraversed))
-  let g = MkEnv
+    (\l -> Ap . stackifyBinding l)
-        { bound = mempty
+  & getAp
-        , liveness
+  where
-        , tail = p.body.ktail }
+    g = emptyEnv
-  let e = p.body & #body %~ ExpLetRec (H.toList p.bindings)
+    stackifyBinding lbl ab =
-  (_,p') <- runStackify $ emitRoutine =<< stackifyLambda g "start" e
+      Stk.MkProgram . H.singleton lbl <$> stackifyAbs @es g lbl ab
-  pure p'
-
-blah :: HoistedProgram
-blah = [cps|
-(letrec ((prim-k3 (κ (r2) (if r2 truthy-cont4 falsey-cont5)))
-         (prim-k7 (κ (r6) (fac r6 r8)))
-         (make-closure-cont15 (κ (fac) (fac 20 r12)))
-         (falsey-cont5 (κ () (prim (- n 1) prim-k7)))
-         (r12 (κ (x13) (continue start-ktail0 x13)))
-         (truthy-cont4 (κ () (continue lambda-tail1 1)))
-         (prim-k11 (κ (r10) (continue lambda-tail1 r10)))
-         (r8 (κ (x9) (prim (* n x9) prim-k11)))
-         (fac-code14 (λ (n lambda-tail1) (prim (zero? n) prim-k3))))
-  (λ (start-ktail0)
-    (prim (make-closure $fac-code14) make-closure-cont15)))
-|]
 
 p :: HoistedProgram
 p = [cps|
-(letrec ((r12-code32 (κ (r12 start-ktail0 x13) (continue start-ktail0 x13)))
+(letrec (($r12-code32
-         (prim-k7-code22
+          (κ (x13)
-          (κ (prim-k7 fac r6 r8 n x9 prim-k11 lambda-tail1 r10)
             (prim
-             (make-shared-closure (r8) (n x9 prim-k11 lambda-tail1 r10))
+             (get-env)
-             letrec-body-cont18)))
+             (κ (r12 start-ktail0)
-         (letrec-body-cont24
+               (continue start-ktail0 x13)))))
-          (κ (truthy-cont4 falsey-cont5)
+         ($prim-k7-code22
-            (if r2
+          (κ (r6)
-              truthy-cont4
-              falsey-cont5)))
-         (letrec-body-cont18 (κ (r8) (fac r6 r8)))
-         (prim-k11-code16
-          (κ (prim-k11 lambda-tail1 r10)
-            (continue lambda-tail1 r10)))
-         (falsey-cont5-code26
-          (κ (truthy-cont4 falsey-cont5 lambda-tail1 n prim-k7
-              fac r6 r8 x9 prim-k11 r10)
             (prim
-             (make-shared-closure
+             (get-env)
-              (prim-k7)
+             (κ (prim-k7 lambda-tail1 n fac)
-              (fac r6 r8 n x9 prim-k11 lambda-tail1 r10))
+               (prim
-             letrec-body-cont21)))
+                (make-shared-closure ($r8-code19) (lambda-tail1 n))
-         (letrec-body-cont31 (κ (r12) (fac 20 r12)))
+                (κ (r8)
-         (r8-code19
+                  (fac r6 r8)))))))
-          (κ (r8 n x9 prim-k11 lambda-tail1 r10)
+         ($prim-k11-code16
+          (κ (r10)
             (prim
-             (make-shared-closure (prim-k11) (lambda-tail1 r10))
+             (get-env)
-             letrec-body-cont15)))
+             (κ (prim-k11 lambda-tail1)
-         (letrec-body-cont28 (κ (prim-k3) (prim (zero? n) prim-k3)))
+               (continue lambda-tail1 r10)))))
-         (truthy-cont4-code25
+         ($falsey-cont5-code26
-          (κ (truthy-cont4 falsey-cont5 lambda-tail1 n prim-k7 fac
+          (κ ()
-              r6 r8 x9 prim-k11 r10)
-            (continue lambda-tail1 1)))
-         (fac-code35
-          (κ (fac n prim-k3 r2 truthy-cont4 falsey-cont5 lambda-tail1
-              prim-k7 r6 r8 x9 prim-k11 r10)
             (prim
-             (make-shared-closure
+             (get-env)
-              (prim-k3)
+             (κ (truthy-cont4 falsey-cont5 lambda-tail1 n fac)
-              (r2 truthy-cont4 falsey-cont5 lambda-tail1 n prim-k7
+               (prim
-               fac r6 r8 x9 prim-k11 r10))
+                (make-shared-closure ($prim-k7-code22) (lambda-tail1 n fac))
-             letrec-body-cont28)))
+                (κ (prim-k7)
-         (prim-k3-code29
+                  (prim (- n 1) prim-k7)))))))
-          (κ (prim-k3 r2 truthy-cont4 falsey-cont5 lambda-tail1 n prim-k7
+         ($r8-code19
-              fac r6 r8 x9 prim-k11 r10)
+          (κ (x9)
             (prim
-             (make-shared-closure
+             (get-env)
-              (truthy-cont4 falsey-cont5)
+             (κ (r8 lambda-tail1 n)
-              (lambda-tail1 n prim-k7 fac r6 r8 x9 prim-k11 r10))
+               (prim
-             letrec-body-cont24)))
+                (make-shared-closure ($prim-k11-code16) (lambda-tail1))
-         (letrec-body-cont21 (κ (prim-k7) (prim (- n 1) prim-k7)))
+                (κ (prim-k11)
-         (letrec-body-cont15 (κ (prim-k11) (prim (* n x9) prim-k11)))
+                  (prim (* n x9) prim-k11)))))))
-         (letrec-body-cont34
+         ($truthy-cont4-code25
-          (κ (fac)
+          (κ ()
             (prim
-             (make-shared-closure (r12) (start-ktail0 x13))
+             (get-env)
-             letrec-body-cont31))))
+             (κ (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
-     (make-shared-closure
+     (make-shared-closure ($fac-code35) ())
-      (fac)
+     (κ (fac)
-      (n prim-k3 r2 truthy-cont4 falsey-cont5 lambda-tail1
+       (prim
-       prim-k7 r6 r8 x9 prim-k11 r10))
+        (make-shared-closure ($r12-code32) (start-ktail0))
-     letrec-body-cont34)))
+        (κ (r12)
+          (fac 20 r12)))))))
 |]

src/Gyehoek/CPS/Syntax.hs

@@ -42,6 +42,11 @@ module Gyehoek.CPS.Syntax
   , pattern ValLabel
   , pattern ObjLabel
   , absBody
+  , pattern MkAbs
+  , _MkAbs
+  , unhoist
+  , pattern ExpJump
+  , _ExpJump
   )
   where
 
@@ -62,6 +67,7 @@ import Data.String (IsString)
 import Control.Applicative
 import qualified Data.HashMap.Strict as H
 import GHC.Records (HasField (..))
+import Data.Bifunctor
 
 -- Data types
 
@@ -125,6 +131,37 @@ pattern AbsKappa' xs e = AbsKappa (MkKappa xs e)
 pattern AbsLambda' :: List 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
   | ExpLetRec { binders :: List (Name, Abs), body :: Exp }
@@ -139,7 +176,6 @@ data Exp
 
 data Kexp
   = KexpVar Name
-  -- | Only to be used after contification.
   | KexpKappa Kappa
   deriving (Show, Generic, Data, Eq)
 
@@ -158,12 +194,12 @@ data Program = MkProgram
   deriving (Show, Generic, Data)
 
 data HoistedProgram = MkHoistedProgram
-  { bindings :: HashMap Name Abs
+  { bindings :: HashMap Label Abs
   , body :: Lambda
   }
   deriving stock (Show, Generic, Data)
 
-type instance Index HoistedProgram = Name
+type instance Index HoistedProgram = Label
 type instance IxValue HoistedProgram = Abs
 
 instance Ixed HoistedProgram where ix j = #bindings . ix j
@@ -196,7 +232,6 @@ _AbsLambda' = prism'
 
 instance Plated Exp where plate = uniplate
 
-
 absBody :: Lens' Abs Exp
 absBody = lens
   (\case
@@ -206,6 +241,12 @@ absBody = lens
     (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
 
@@ -350,7 +391,7 @@ instance S.DatumIso Program where
 instance S.DatumIso HoistedProgram where
   datumIso = S.with \prog ->
     S.letLike "letrec"
-      (S.datumIso @Name) (S.datumIso @Abs) (S.datumIso @Lambda)
+      (S.datumIso @Label) (S.datumIso @Abs) (S.datumIso @Lambda)
     >>> S.onTail (S.iso H.fromList H.toList)
     >>> prog
 

src/Gyehoek/Driver.hs

@@ -1,5 +1,5 @@
 module Gyehoek.Driver
-  (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e)
+  (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e, eval_cps_e2e, eval_cps2_e2e)
   where
 
 import Gyehoek.Options
@@ -120,13 +120,13 @@ driver opts = do
     hPutStrLn FS.stdout . view strict . pShowNoColor $ scm
   cps <- convertProgram scm
   when opts.dumpCPS do
-     hPutStrLn FS.stdout =<< S.encodeWith S.datumIso cps
+     S.writeDatum cps
   closedCps <- closeProgram cps
   when opts.dumpClosed do
-    hPutStrLn FS.stdout =<< S.encodeWith S.datumIso closedCps
+    S.writeDatum closedCps
   hoistedCps <- hoistProgram closedCps
   when opts.dumpHoisted do
-    hPutStrLn FS.stdout =<< S.encodeWith S.datumIso hoistedCps
+    S.writeDatum hoistedCps
   -- contifiedCps <- contifyProgram hoistedCps
   -- when opts.dumpContified do
   --   hPutStrLn FS.stdout =<< S.encodeWith S.datumIso contifiedCps
@@ -137,12 +137,12 @@ driver opts = do
     (eval >=> fmap writeObj
          >>> T.unwords
          >>> hPutStrLn FS.stdout)
+  when (rt_is #HigherOrderCPS) do
+    CPS.evalProgram cps
+      >>= S.writeData
   when (rt_is #CPS) do
-    closedCps
+    CPS.evalProgram closedCps
-      & CPS.evalProgram
+      >>= S.writeData
-      & fmap writeObj
-      & T.unwords
-      & hPutStrLn FS.stdout
   -- dumpOrRun opts.inspectWasm (rt_is #Wasm)
   --   (lowerProgram cps)
   --   inspectWasm
@@ -166,3 +166,19 @@ 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,6 +31,7 @@ data AJalmot
   = ReaderError (ParseErrorBundle Text Void)
   | GrammarError (Grammar.ErrorMessage Ann)
   | VMError Text
+  | EvalError Text
   deriving (Show, Generic, Data)
 
 data AJalmotCS = MkAJalmotCS !CallStack !AJalmot
@@ -66,6 +67,7 @@ instance Exception AJalmot where
         & layoutPretty defaultLayoutOptions
         & renderString
     VMError err -> [i|#{err}|]
+    EvalError err -> [i|#{err}|]
 
 instance Exception AJalmotCS where
   backtraceDesired = const False

src/Gyehoek/Options.hs

@@ -13,7 +13,7 @@ import Data.Foldable
 import Gyehoek.Prelude hiding (argument)
 
 
-data Runtime = Stackify | Wasm | CPS
+data Runtime = Stackify | Wasm | CPS | HigherOrderCPS
   deriving (Show, Generic, Eq)
 
 data Language
@@ -32,6 +32,7 @@ data Options = MkOptions
   , dumpHoisted :: Bool
   , dumpContified :: Bool
   , traceStackified :: Bool
+  , noColour :: Bool
   , runtime :: Maybe Runtime
   , inspectWasm :: Bool
   , output :: FilePath
@@ -53,7 +54,8 @@ runtimeValues = ["stackify","wasm","cps","none"]
 runtimeReader = maybeReader \case
   "stackify" -> Just (Just Stackify)
   "wasm" -> Just (Just Wasm)
-  "cps" -> Just (Just CPS)
+  "cps1" -> Just (Just CPS)
+  ("cps";"higher-order-cps") -> Just (Just HigherOrderCPS)
   "none" -> Just Nothing
   _ -> Nothing
 
@@ -66,13 +68,17 @@ parser = do
   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 Stackify)
+    , value (Just HigherOrderCPS)
     , completeWith runtimeValues
-    , showDefaultWith $ const "stackify"
+    , showDefaultWith $ const "higher-order-cps"
     , metavar "RUNTIME"
     ]
   sourceLanguage <- option languageReader . fold $

src/Gyehoek/Sexp/Grammar.hs

@@ -15,6 +15,7 @@ module Gyehoek.Sexp.Grammar
   , encodeDataTest
   , encodeDataTestColour
   , encodeOrShow'
+  , encodeOrShowData'
   , decodeDataWith
   , encodeDataWith'
   , decodeTest
@@ -28,6 +29,8 @@ module Gyehoek.Sexp.Grammar
   , fromDatumUnsafe
   , Control.Category.id
   , fromDataUnsafe
+  , writeDatum
+  , writeData
   )
   where
 
@@ -45,6 +48,7 @@ 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
@@ -126,6 +130,39 @@ 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/Stack/Syntax.hs

@@ -76,7 +76,7 @@ data Instr
   = Pop Reg
   | Push Val
   | Load Reg Int
-  | Prim (Prim Val)
+  | Prim Reg (Prim Val)
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
@@ -99,7 +99,7 @@ instance S.DatumIso Instr where
     $ 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 "prim" S.datumIso >>>)
+    $ S.With (S.headTagged2 "prim" S.datumIso S.datumIso >>>)
     $ S.End
     where
 

src/Gyehoek/Stack/VM.hs

@@ -112,20 +112,6 @@ vmerror = throwError . VMError
 
 stepI :: Jalmot :> es => Env -> VM -> Instr -> Eff es VM
 
-stepI e vm (Load r j) = do
-  x <- expectOf [i|object at index #{j}|] (activeFrame . ix j) vm
-  pure $ vm & #registers . at r ?~ x
-
-stepI e vm (Push v) = traverseOf activeFrame push vm
-  where push xs = cons <$> evalVal e vm v <*> pure xs
-
-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

test/Gyehoek/Test/CPS/Eval.hs

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

test/Gyehoek/Test/CPS/Stackify.hs

@@ -10,86 +10,87 @@ 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 :: HasCallStack => List Obj -> Sut.Program -> 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 & 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|(λ (ktail) (continue ktail 4))|]
-  , testCase "return bool" do
+--   , testCase "return bool" do
-      evalsTo [ObjImm (ImmBool True)]
+--       evalsTo [ObjImm (ImmBool True)]
-        [cps|(λ (ktail) (continue ktail #t))|]
+--         [cps|(λ (ktail) (continue ktail #t))|]
-      evalsTo [ObjImm (ImmBool False)]
+--       evalsTo [ObjImm (ImmBool False)]
-        [cps|(λ (ktail) (continue ktail #f))|]
+--         [cps|(λ (ktail) (continue ktail #f))|]
-  ]
+--   ]
 
-tailCall = testGroup "tail call"
+-- tailCall = testGroup "tail call"
-  [ testCase "square" do
+--   [ testCase "square" do
-      evalsTo [ObjImm (ImmInt 16)] [cps|
+--       evalsTo [ObjImm (ImmInt 16)] [cps|
-        (λ (ktail0)
+--         (λ (ktail0)
-          (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|(λ (ktail0)
-            (prim (* 4 5)
+--             (prim (* 4 5)
-               (κ (x) (continue ktail0 x))))|]
+--                (κ (x) (continue ktail0 x))))|]
-  , testCase "add" do
+--   , testCase "add" do
-      evalsTo [ObjImm (ImmInt 9)]
+--       evalsTo [ObjImm (ImmInt 9)]
-        [cps|(λ (ktail0)
+--         [cps|(λ (ktail0)
-        (prim (+ 4 5)
+--         (prim (+ 4 5)
-               (κ (x) (continue ktail0 x))))|]
+--                (κ (x) (continue ktail0 x))))|]
-  -- , testGroup "call/cc"
+--   -- , testGroup "call/cc"
-  --   [ testCase "trivial" do
+--   --   [ testCase "trivial" do
-  --       evalsTo [ObjImm (ImmInt 123)]
+--   --       evalsTo [ObjImm (ImmInt 123)]
-  --         [cps|(letrec ((f (λ (cc ktail) (continue cc 123))))
+--   --         [cps|(letrec ((f (λ (cc ktail) (continue cc 123))))
-  --                (prim (call/cc f)))|]
+--   --                (prim (call/cc f)))|]
-  --   ]
+--   --   ]
-  ]
+--   ]
 
-condition = testCase "if" do
+-- condition = testCase "if" do
-  evalsTo [ObjImm (ImmInt 123)]
+--   evalsTo [ObjImm (ImmInt 123)]
-    [cps|(λ (ktail0)
+--     [cps|(λ (ktail0)
-      (if #t (continue ktail0 123) (continue ktail0 456)))|]
+--       (if #t (continue ktail0 123) (continue ktail0 456)))|]
-  evalsTo [ObjImm (ImmInt 456)]
+--   evalsTo [ObjImm (ImmInt 456)]
-    [cps|(λ (ktail0)
+--     [cps|(λ (ktail0)
-      (if #f (continue ktail0 123) (continue ktail0 456)))|]
+--       (if #f (continue ktail0 123) (continue ktail0 456)))|]
 
-procedure = testGroup "procedure"
+-- procedure = testGroup "procedure"
-  [ testCase "factorial" do
+--   [ testCase "factorial" do
-      evalsTo [ObjImm (ImmInt 720)]
+--       evalsTo [ObjImm (ImmInt 720)]
-        [cps|(λ (ktail0)
+--         [cps|(λ (ktail0)
-          (letrec ((fac (λ (n ktail)
+--           (letrec ((fac (λ (n ktail)
-                             (prim (zero? n)
+--                              (prim (zero? n)
-                               (κ (x0)
+--                                (κ (x0)
-                                 (if x0
+--                                  (if x0
-                                   (continue ktail 1)
+--                                    (continue ktail 1)
-                                   (prim (- n 1)
+--                                    (prim (- n 1)
-                                     (κ (x1)
+--                                      (κ (x1)
-                                       (letrec ((fac-k0
+--                                        (letrec ((fac-k0
-                                                  (κ (x2)
+--                                                   (κ (x2)
-                                                    (prim (* n x2)
+--                                                     (prim (* n x2)
-                                                      (κ (x3)
+--                                                       (κ (x3)
-                                                        (continue ktail x3))))))
+--                                                         (continue ktail x3))))))
-                                         (fac x1 fac-k0))))))))))
+--                                          (fac x1 fac-k0))))))))))
-               (fac 6 halt)))|]
+--                (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"]
-                     "k")
+                     (Sut.KexpVar "k"))
         [cps|(f x y k)|]
       assertEqual "" (Sut.ExpApply (Sut.ValVar "f")
-                     [] "k")
+                     [] (Sut.KexpVar "k"))
         [cps|(f k)|]
   ]

test/Gyehoek/Test/Golden.hs

@@ -40,7 +40,8 @@ test_root = do
   testGroup "execution" <$> sequenceA
     [ ignoreTestBecause "wasm codegen is on the backburner"
       <$> wasmTests tests
-    , stackifyTests tests
+    , ignoreTestBecause "i'm killing myself"
+      <$> stackifyTests tests
     ]
 
 maybeBroken name broken = applyWhen (name `elem` broken) expectFail

test/Gyehoek/Test/Stack/VM.hs

@@ -8,12 +8,13 @@ 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 = testGroup "stack machine"
+test_root = ignoreTestBecause "i'm super-killing myself" $ testGroup "stack machine"
   [ testCase "immediate halt" do
       evalsTo [] [stkP|
         (define $start