superfuck

doc/libraries.org

@@ -1,9 +0,0 @@
-#+title: on libraries
-
-R⁷RS leaves it unspecified how exactly libraries correspond to files:
-
-#+begin_quote
-Programs and libraries are typically stored in files, although in some implementations they can be entered interactively into a running Scheme system. Other paradigms are possible. Implementations which store libraries in files should document the mapping from the name of a library to its location in the file system.
-#+end_quote
-
-thus the implementation of ~define-library~ is open to much interpretation. we could possibly define libraries as first-class objects, or deal with them statically. the former case is appealing to me, as it could massively simplify interactive use.

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

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

golden/exec/cons-2/exec

@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > (456 . 123)

golden/exec/map/exec

@@ -1,2 +0,0 @@
-ret > ExitSuccess
-out > (0 . (1 . (4 . (9 . (16 . ())))))

golden/exec/map/source.scm

@@ -1,7 +0,0 @@
-(letrec ((my-map (λ (f l)
-                   (if (pair? l)
-                       (cons (f (car l))
-                             (my-map f (cdr l)))
-                       (list)))))
-  (my-map (λ (x) (* x x))
-          (list 0 1 2 3 4)))

gyehoek.cabal

@@ -58,9 +58,11 @@ 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
@@ -77,6 +79,9 @@ library
     Gyehoek.Sexp.QQ
     Gyehoek.Sexp.Read
     Gyehoek.Sexp.Syntax
+    Gyehoek.Stack.Lower
+    Gyehoek.Stack.Syntax
+    Gyehoek.Stack.VM
     Gyehoek.Wasm
 
   build-depends:
@@ -131,11 +136,14 @@ test-suite test
   -- cabal-fmt: expand test -Main
   other-modules:
     Gyehoek.Test.CPS.Eval
+    Gyehoek.Test.CPS.Stackify
     Gyehoek.Test.CPS.Syntax
+    Gyehoek.Test.Golden
     Gyehoek.Test.Scheme.Syntax
     Gyehoek.Test.Sexp.Print
     Gyehoek.Test.Sexp.QQ
     Gyehoek.Test.Sexp.Read
+    Gyehoek.Test.Stack.VM
     Gyehoek.TestUtil
     Root
 

src/Gyehoek/CPS/Contify.hs

@@ -0,0 +1,67 @@
+{-# 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/Eval.hs

@@ -9,57 +9,37 @@ module Gyehoek.CPS.Eval
   , eGrammar
   ) where
 
-import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..), cont)
+import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..))
 import Gyehoek.Sexp qualified as S
-import Control.Lens hiding (assign)
+import Control.Lens
-import Data.Maybe (fromMaybe, isJust)
+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 Control.Monad.Cont qualified as Cont
 import Gyehoek.Sexp qualified as S
 import GHC.Generics (Generically(..))
 import Gyehoek.Sexp ((:-)(..))
-import Data.List (nub, mapAccumR, compareLength)
+import Data.List (nub)
 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_, foldrM)
 
 
 newtype Loc = MkLoc { getLoc :: Int }
   deriving stock (Generic, Data)
-  deriving newtype (Show, Eq, Ord, Enum)
+  deriving newtype (Show, Eq, Ord)
 
 data Store = MkStore
   { nextLoc :: Loc
   , heap :: IntMap E
   }
-  deriving stock (Show, Generic)
+  deriving stock (Show, Generic, Data)
-
-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
@@ -73,67 +53,42 @@ update (MkLoc loc) v = #heap %~ IM.alter f loc
     f (Just _) = Just v
     f Nothing = error "segfault lol"
 
-updates :: Foldable f => f (Loc, E) -> Store -> Store
+fetch :: Loc -> Store -> E
-updates = alaf Endo foldMap (uncurry update)
+fetch (MkLoc loc) st = st ^?! #heap . ix loc
 
-fetch :: Loc -> M r E
+new :: Store -> Loc
-fetch (MkLoc loc) = gets (^?! #heap . ix loc)
+new = _
 
-new :: M r Loc
+var :: HasCallStack => Env -> Name -> Loc
-new = state \st -> (st.nextLoc, st & #nextLoc %~ succ)
+var g x = g ^?! ix x
-
-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
+  | AnswerError Text
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 data Mutability
   = Mut
   | NoMut
   deriving (Show, Generic, Data, Eq)
 
-wrong :: Text -> M Answer a
+wrong :: Text -> CmdCont
-wrong s = ContT \_ -> pure . AnswerError . EvalError $ s
+wrong = const . AnswerError
 
-orWrong
+single :: (E -> CmdCont) -> ExpCont
-  :: Getting (First a) s a
+single k = \case
-  -> Text -> s -> M Answer a
+  [x] -> k x
-orWrong p msg s = case getFirst . getConst $ p (Const . First . Just) s of
+  _ -> wrong "wrong number of return values"
-  Nothing -> wrong msg
-  Just x -> pure x
 
-bind :: Name -> Loc -> Env
+send :: E -> ExpCont -> CmdCont
-bind k = MkEnv . H.singleton k
+send e k = k [e]
 
-extends :: Foldable f => f (Name, Loc) -> Env -> Env
+-- | Continue with the value located at a given 'Loc'.
-extends xs g = g <> foldMap (uncurry bind) xs
+hold :: Loc -> ExpCont -> CmdCont
-
+hold loc k st = send (fetch loc st) k st
-assign :: Loc -> E -> M Answer ()
-assign l e = do
-  use (at l) >>= \case
-    Just _ -> at l ?= e
-    Nothing -> wrong [i|#{e}에서 #{l}이라는 주소는 없다|]
 
 
 
@@ -141,163 +96,79 @@ assign l e = do
 data E
   = ESymbol Text
   | ECharacter Char
-  | EInt Int
+  | EInteger Int
   | EBool Bool
   | EUndefined
   | EUnspecified
   | ENull
-  | EPair Mutability Loc Loc
+  | EPair Loc Loc Mutability
-  | EVec Mutability (List Loc)
+  | EVec (List Loc) Mutability
-  | EString Mutability (List Loc)
+  | EString (List Loc) Mutability
-  | EProcedure Procedure
+  | EProcedure Loc (List E -> DynPoints -> ExpCont -> CmdCont)
-  deriving stock (Show, Generic)
+  deriving stock (Show, Generic, Data)
-
-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
+    gofetch x = go $ fetch x st
     go = \case
       ESymbol s -> S.Symbol s
       ECharacter c -> S.Character c
-      EInt n -> S.Number (fromIntegral n)
+      EInteger n -> S.Number (fromIntegral n)
       EBool b -> S.Boolean b
       EUndefined -> S.Unreadable "#<undefined>"
       EUnspecified -> S.Unreadable "#<unspecified>"
-      EProcedure _ -> S.Unreadable "#<procedure>"
       ENull -> S.List []
-      EPair _mut car cdr -> S.DotList [gofetch car] (gofetch cdr)
+      EPair car cdr _mut -> S.DotList [gofetch car] (gofetch cdr)
-      EVec _mut xs -> S.Vector . fmap gofetch $ xs
+      EVec xs _mut -> S.Vector . fmap gofetch $ xs
-      EString _mut xs -> S.String _
+      EString xs _mut -> S.String _
 
 data DynPoints = MkDynPoints
   deriving (Generic, Data)
 
 
 
-truthy :: E -> Bool
+-- 뻘짓이어라
-truthy (EBool False) = False
+telescope
-truthy _ = True
+  :: Traversable t
+  => (a -> (b -> r) -> r)
+  -> t a -> (t b -> r) -> r
+telescope f = Cont.runCont . traverse (Cont.cont . f)
 
 
 
-evalVal :: Env -> Val -> M Answer E
+evalVal :: Env -> Val -> ExpCont -> CmdCont
+evalVal g (ValVar x) k = hold (var g x) $ single \case
+  EUndefined -> wrong "undefined variable"
+  e -> send e k
 
-evalVal g (ValVar x) = var g x >>= fetch
+evalVal1 :: Env -> Val -> (E -> CmdCont) -> CmdCont
+evalVal1 g v k = evalVal g v (single k)
 
-evalVal g (ValImm imm) = case imm of
+evalKexp :: Env -> Kexp -> ExpCont -> CmdCont
-  ImmLabel (MkLabel l) -> var g l >>= fetch
-  ImmInt n -> pure $ EInt n
-  ImmBool b -> pure $ EBool b
-  ImmUndefined -> pure EUndefined
 
-evalKexp :: Env -> Kexp -> M Answer E
+evalKexp g (KexpVar x) k = evalVal g (ValVar x) k
-evalKexp g (KexpVar x) = var g x >>= fetch
-evalKexp g (KexpKappa kap) = evalAbs g (AbsKappa kap)
 
-evalAbs :: Env -> Abs -> M Answer E
+evalKexp g (KexpKappa kap) k = _
-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 :: Env -> DynPoints -> Exp -> ExpCont -> CmdCont
 
-eval g dps (ExpJump f xs ktail) = do
+eval g dps (ExpContinue f xs) k =
-  f' <- evalVal g f
+  telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
-  xs' <- traverse (evalVal g) xs
+    case f' of
-  ktail' <- traverse (evalKexp g) (ktail ^.. _Just)
+      EProcedure _loc fp -> fp xs' dps k
-  case f' of
+      _ -> wrong "bad procedure"
-    EProcedure p -> p (xs' ++ ktail') dps
-    _ -> wrong "bad procedure"
 
-eval g dps (ExpLetRec bs e) = do
+eval g dps (ExpApply f xs ktail) k =
-  ls <- for bs . const $ new' EUndefined
+  telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
-  let g' = g & extends (zip (bs ^.. each . _1) ls)
+    case f' of
-  bs' <- forOf (each . _2) bs (evalAbs g')
+      EProcedure _loc fp -> fp xs' dps k
-  traverse_ (uncurry assign) $ zip ls (bs' ^.. each . _2)
+      _ -> wrong "bad procedure"
-  eval g' dps e
-
-eval g dps (ExpPrim (PrimCallCC withcc) k) = do
-  withcc' <- evalVal g withcc >>= orWrong #_EProcedure
-    [i|call/cc: 함수가 아닌 것을 받았다|]
-  k' <- evalKexp g k
-  kproc <- orWrong #_EProcedure [i|call/cc: 몰라...|] k'
-  let cc = EProcedure \xs dps -> case unsnoc xs of
-        Just (xs',_) -> kproc xs' dps
-        Nothing -> wrong [i|call/cc: 잘못하는데!|]
-  withcc' [cc,k'] dps
-
-eval g dps (ExpPrim p k) = do
-  p' <- evalPrim g dps =<< traverse (evalVal g) p
-  evalKexp g k >>= \case
-    EProcedure fp -> fp p' dps
-    _ -> wrong [i|prim(#{p})의 계속을 나쁘다|]
-
-eval g dps (ExpIf c t f) = do
-  c' <- evalVal g c
-  let b = if truthy c' then t else f
-  var g b >>= fetch >>= \case
-    EProcedure fp -> fp [] dps
-    _ -> wrong [i|if의 계속을 나쁘다|]
-
-eval g dps e = error [i|unimplemented #{e}|]
-
-evalPrim :: Env -> DynPoints -> Prim E -> M Answer (List E)
-evalPrim g dps = \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
-  PrimZeroP x -> pure1 . EBool . isJust $ x ^? #EInt . only 0
-  PrimCons x y -> pcons x y >>= pure1
-  PrimCar p -> cr p _2
-  PrimCdr p -> cr p _3
-  PrimPairP p -> pure1 . EBool . maybe False (const True) $
-    p ^? #_EPair
-  PrimValues xs -> pure xs
-  PrimList xs -> foldrM pcons ENull xs >>= pure1
-  p -> wrong [i|prim(#{p})은 벌써 나지 않다|]
-  where
-    pure1 x = pure [x]
-    pcons x y = do
-      (x',y') <- traverseOf both new' (x,y)
-      pure $ EPair Mut x' y'
-    arith2 f (EInt x) (EInt y) = pure [EInt $ f x y]
-    arith2 f x y = wrong [i|나쁜 인자: #{x}, #{y}|]
-    cr p l = orWrong (#_EPair . l) [i|car/cdr는 pair을 받지 않다|] p
-      >>= fmap (:[]) . fetch
 
 
 
 evalExp :: Jalmot :> es => Exp -> Eff es _
 evalExp e = _
 
-evalProgram :: Jalmot :> es => Program -> Eff es (List S.Datum)
+evalProgram :: Jalmot :> es => Program -> Eff es _
-evalProgram (MkProgram lam) = case run (pure . AnswerValues) of
+evalProgram (MkProgram lam) = _
-  (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/Stackify.hs

@@ -0,0 +1,166 @@
+{-# LANGUAGE OverloadedLists #-}
+module Gyehoek.CPS.Stackify
+  ( stackifyProgram
+  , module Gyehoek.CPS.Syntax
+  ) where
+
+import Gyehoek.CPS.Syntax
+import Gyehoek.Stack.Syntax qualified as Stk
+import Data.Sequence (Seq)
+import Data.Sequence qualified as Seq
+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.Text qualified as T
+import Gyehoek.Prelude
+import Debug.Pretty.Simple
+import qualified Gyehoek.Sexp as S
+import Data.Monoid
+
+
+data BlockBuilder
+  = Code (List Stk.Instr) BlockBuilder
+  | Tail Stk.Tail
+  deriving (Show, Generic)
+
+buildBlock :: BlockBuilder -> Stk.Block
+buildBlock = go [] where
+  go acc (Code xs bb) = go (acc ++ xs) bb
+  go acc (Tail t) = Stk.MkBlock acc t
+
+-- affine
+_ValName :: Traversal' Val Name
+_ValName = failing #_ValVar (#_ValImm . #_ImmLabel . #_MkLabel)
+
+stackify
+  :: forall es. (GenSym :> es)
+  => Env -> Exp -> Eff es BlockBuilder
+
+stackify _ (ExpContinue (ValVar k) xs) =
+  Code [ ] _
+
+stackify _ (ExpPrim p k) = _
+
+stackify _ e = error [i|unimplemented exp: #{e}|]
+
+stackifyAbs :: (GenSym :> es) => Env -> Label -> Abs -> Eff es Stk.Routine
+
+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
+  {
+  }
+  deriving (Show, Generic)
+
+emptyEnv :: Env
+emptyEnv = MkEnv
+  {
+  }
+
+
+
+stackifyProgram
+  :: forall es. GenSym :> es
+  => HoistedProgram -> Eff es Stk.Program
+stackifyProgram p = p
+  & ifoldMapOf
+    ((#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
+p = [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
+     (make-shared-closure ($fac-code35) ())
+     (κ (fac)
+       (prim
+        (make-shared-closure ($r12-code32) (start-ktail0))
+        (κ (r12)
+          (fac 20 r12)))))))
+|]

src/Gyehoek/Driver.hs

@@ -1,5 +1,5 @@
 module Gyehoek.Driver
-  (main, convert_e2e, parse_e2e, readScm, eval_cps1_e2e, eval_cps2_e2e)
+  (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e, eval_cps_e2e, eval_cps2_e2e)
   where
 
 import Gyehoek.Options
@@ -17,6 +17,7 @@ import qualified Data.Text.Encoding as T
 import System.IO (Handle)
 import System.IO qualified as IO
 import Gyehoek.CPS.Convert
+import Gyehoek.Stack.Lower
 import Gyehoek.CPS.Eval qualified as CPS
 import Control.Monad
 import Text.Pretty.Simple (pShowNoColor)
@@ -24,7 +25,10 @@ import System.Process.Typed
 import System.Environment.Blank (getEnvDefault)
 import qualified Data.Text.IO as TIO
 import qualified Data.ByteString.Lazy as BS
+import Gyehoek.CPS.Stackify (stackifyProgram)
+import Gyehoek.Stack.VM (eval, writeObj, Obj, traceEval)
 import qualified Data.Text as T
+import Gyehoek.Stack.Syntax qualified as Stk
 import Gyehoek.CPS.Close (closeProgram)
 import Control.Lens.Extras (is)
 import Control.Arrow ((>>>))
@@ -32,6 +36,7 @@ import Gyehoek.Prelude
 import Gyehoek.Jalmot
 import qualified Gyehoek.Sexp as S
 import Gyehoek.CPS.Hoist (hoistProgram)
+import Gyehoek.CPS.Contify (contifyProgram)
 
 
 main :: IO ()
@@ -122,13 +127,28 @@ driver opts = do
   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)
+    (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
       >>= S.writeData
+  -- 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
 
 parse_e2e :: FilePath -> IO Scm.Program
 parse_e2e = runJalmotIO . runFileSystem . readScm
@@ -137,8 +157,18 @@ convert_e2e :: FilePath -> IO CPS.Program
 convert_e2e = runJalmotIO . runFileSystem . runGenSym
   . (closeProgram <=< convertProgram <=< readScm)
 
-eval_cps1_e2e :: FilePath -> IO Text
+lower_e2e :: FilePath -> IO Text
-eval_cps1_e2e fp = runJalmotIO . runFileSystem . runGenSym $
+lower_e2e =
+  runJalmotIO . runFileSystem . runGenSym
+  . (lowerProgram <=< closeProgram <=< convertProgram <=< readScm)
+
+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

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/Options.hs

@@ -13,13 +13,14 @@ import Data.Foldable
 import Gyehoek.Prelude hiding (argument)
 
 
-data Runtime = Wasm | CPS | HigherOrderCPS
+data Runtime = Stackify | Wasm | CPS | HigherOrderCPS
   deriving (Show, Generic, Eq)
 
 data Language
   = LanguageScheme
   | LanguageCPS
   | LanguageClosed
+  | LanguageStackified
   | LanguageWasm
   deriving (Show, Generic, Eq)
 
@@ -27,30 +28,34 @@ data Options = MkOptions
   { dumpClosed :: Bool
   , dumpCPS :: Bool
   , dumpParsed :: Bool
+  , dumpStackified :: Bool
   , dumpHoisted :: Bool
+  , dumpContified :: Bool
+  , traceStackified :: Bool
   , noColour :: Bool
   , runtime :: Maybe Runtime
   , inspectWasm :: Bool
   , output :: FilePath
   , sourceFile :: FilePath
   , sourceLanguage :: Language
-  , targetLanguage :: Language
   }
   deriving (Show, Generic)
 
-languageValues = ["scheme","cps","closed","wasm"]
+languageValues = ["scheme","cps","closed","stackified","wasm"]
 languageReader = maybeReader \case
   "scheme" -> Just LanguageScheme
   "cps" -> Just LanguageCPS
   "closed" -> Just LanguageClosed
+  "stackified" -> Just LanguageStackified
   "wasm" -> Just LanguageWasm
   _ -> Nothing
 
 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)
+  ("cps2";"higher-order-cps") -> Just (Just CPS)
   "none" -> Just Nothing
   _ -> Nothing
 
@@ -58,8 +63,11 @@ parser :: Parser Options
 parser = do
   dumpClosed <- switch (long "dump-closed")
   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"
@@ -81,14 +89,6 @@ parser = do
     , showDefaultWith $ const "scheme"
     , metavar "LANGUAGE"
     ]
-  targetLanguage <- option languageReader . fold $
-    [ long "target"
-    , short 'T'
-    , value LanguageCPS
-    , completeWith languageValues
-    , showDefaultWith $ const "cps"
-    , metavar "LANGUAGE"
-    ]
   output <- strOption . fold $
     [ long "output"
     , short 'o'

src/Gyehoek/Scheme/Syntax.hs

@@ -10,7 +10,6 @@
 {-# LANGUAGE OrPatterns #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE ViewPatterns #-}
 module Gyehoek.Scheme.Syntax
   ( Name(..)
   , Prim(..)
@@ -54,8 +53,6 @@ import Gyehoek.Sexp.Grammar qualified as Sexp
 import Gyehoek.Sexp.Grammar qualified as S
 import Gyehoek.Sexp.Grammar (DatumIso, G, DataIso, (:-)((:-)))
 import Gyehoek.Prelude
-import Control.Lens.Extras (is)
-import qualified Data.Scientific as Sci
 
 
 newtype Name = MkName { inner :: Text }
@@ -93,8 +90,6 @@ data Prim e
   | PrimInvokeCC e (List e)
   | PrimValues (List e)
   | PrimCallWithValues e e
-  | PrimPairP e
-  | PrimList (List e)
   deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
   deriving anyclass (NFData)
 
@@ -133,37 +128,8 @@ data CommandOrDef
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
-newtype LibName = MkLibName { inner :: NonEmpty Name }
+newtype Program = MkProgram
-  deriving stock (Show, Generic, Data)
+  { commandsAndDefs :: List CommandOrDef
-  deriving anyclass (NFData)
-
-data ImportSet
-  = ImportLib LibName
-  | ImportOnly ImportSet (NonEmpty Name)
-  | ImportExcept ImportSet (NonEmpty Name)
-  | ImportPrefix ImportSet Name
-  | ImportRename ImportSet (NonEmpty (Name, Name))
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-newtype ImportDecl = MkImportDecl (NonEmpty ImportSet)
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data LibDecl
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Lib = MkLib
-  { name :: LibName
-  , decls :: List LibDecl
-  }
-  deriving stock (Show, Generic, Data)
-  deriving anyclass (NFData)
-
-data Program = MkProgram
-  { imports :: List ImportDecl
-  , commandsAndDefs :: List CommandOrDef
   }
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
@@ -215,8 +181,6 @@ primDatumIso namefn a = S.match
     $ S.With (. ht1' "invoke/cc")
     $ S.With (. ht0' "values")
     $ S.With (. ht2 "call-with-values")
-    $ S.With (. ht1 "pair?")
-    $ S.With (. ht0' "list")
     $ S.End
     where
       idn = S.el . S.sym . namefn
@@ -276,58 +240,8 @@ instance DatumIso CommandOrDef where
     $ S.With (\_Begin -> _Begin . S.beginLike "begin" (S.rest S.datumIso))
     $ S.End
 
-instance DatumIso LibName where
-  datumIso = S.with \g ->
-    S.list (S.restData $ S.nonEmptyData comp)
-    >>> g
-    where
-      comp = S.partialOsi
-        (\case
-          S.Symbol s -> Right $ MkName s
-          S.Number (Sci.floatingOrInteger @Double @Int -> Right n)
-            | n > 0 -> Right $ MkName [i|#{n}|]
-          _ -> Left $ S.expected "library name part"
-          )
-        \(MkName s) -> S.Symbol s
-
-instance DatumIso ImportSet where
-  datumIso = S.match
-    $ S.With (S.datumIso @LibName >>>)
-    $ S.With (imp "only" >>>)
-    $ S.With (imp "except" >>>)
-    $ S.With (imp' "prefix" >>>)
-    $ S.With (imp "rename" >>>)
-    $ S.End
-    where
-      imp s = S.list $ S.el (S.symBuiltin s)
-        >>> S.el S.datumIso >>> S.restData S.dataIso
-      imp' s = S.list $
-        S.el (S.symBuiltin s)
-        >>> S.el S.datumIso
-        >>> S.el S.datumIso
-
-instance DatumIso ImportDecl where
-  datumIso = S.with \decl ->
-    S.list (S.el (S.symBuiltin "import") >>> S.restData S.dataIso)
-    >>> decl
-
 instance DataIso Program where
-  dataIso = S.with \g ->
+  dataIso = S.dataIso @(List CommandOrDef) >>> S.iso coerce coerce
-    splitG
-    >>> S.onHead (S.sealed S.dataIso)
-    >>> S.onTail (S.onHead . S.sealed $ S.dataIso)
-    >>> g
-    where
-      isImport = \case
-        S.List (S.Symbol "import" : _) -> True
-        _ -> False
-      splitG :: G (List S.Datum :- t) (List S.Datum :- List S.Datum :- t)
-      splitG = S.Iso
-        (\(xs:-t) ->
-          let (ys,zs) = span isImport xs
-          in zs :- ys :- t
-        )
-        \(zs:-ys:-t) -> (ys ++ zs) :- t
 
 
 -- utilities

src/Gyehoek/Sexp/Grammar.hs

@@ -49,7 +49,6 @@ import qualified Data.Vector as V
 import Data.String (IsString (fromString))
 import qualified Data.Text as T
 import System.Environment (lookupEnv)
-import Data.Foldable (toList)
 
 
 toDatum :: Jalmot :> es => DatumGrammar a -> a -> Eff es Datum
@@ -188,8 +187,5 @@ instance DatumIso a => DataIso (V.Vector a) where
   dataIso = iso fromList V.toList
     >>> (onHead . traversed . sealed $ datumIso @a)
 
-instance DatumIso a => DataIso (NonEmpty a) where
-  dataIso = nonEmptyData datumIso
-
 instance (DatumIso a, DatumIso b) => DatumIso (a, b) where
   datumIso = with \tup2 -> list (el datumIso >>> el datumIso) >>> tup2

src/Gyehoek/Sexp/Grammar/Base.hs

@@ -17,7 +17,6 @@ module Gyehoek.Sexp.Grammar.Base
   , el
   , rest
   , restData
-  , nonEmptyData
   , headTagged0'
   , headTagged0
   , headTagged1'
@@ -33,8 +32,6 @@ module Gyehoek.Sexp.Grammar.Base
   , integer
   , int
   , unreadable
-  -- ** symbols
-  , symBuiltin
   -- * TODO: sort lol
   , prismIso
   , isoIso, decorate
@@ -52,7 +49,7 @@ import Data.InvertibleGrammar.Base
 import Data.InvertibleGrammar.Base as Re
   ( Grammar(..))
 import Data.InvertibleGrammar.Combinators
-import Gyehoek.Prelude hiding (traversed, iso, cons, coerced, Iso, Simple, simple)
+import Gyehoek.Prelude hiding (iso, cons, coerced, Iso, Simple, simple)
 import Gyehoek.Sexp.Syntax hiding (position)
 import Gyehoek.Sexp.Print (printDatum')
 import Data.Scientific (Scientific)
@@ -60,7 +57,6 @@ import qualified Data.Scientific as Sci
 import qualified Data.Text as T
 import Control.Monad.RWS (modify)
 import qualified Data.List.NonEmpty as NE
-import Data.Foldable (toList)
 
 
 -- $setup
@@ -242,14 +238,6 @@ restData g =
   >>> g
   >>> push (MkListContext []) (const True) mempty
 
-nonEmptyData :: DatumGrammar a -> DataGrammar (NonEmpty a)
-nonEmptyData g = partialOsi
-    (\case
-      [] -> Left $ expected "non-empty sequence"
-      x:xs -> Right $ x:|xs)
-    toList
-  >>> (onHead . traversed . sealed $ g)
-
 snoced
   :: Snoc s s a a
   => Grammar p (s :- a :- t) (s :- t)

src/Gyehoek/Stack/Lower.hs

@@ -0,0 +1,29 @@
+module Gyehoek.Stack.Lower
+  ( lowerProgram
+  ) where
+
+import Gyehoek.Stack.Syntax
+import Gyehoek.Wasm qualified as Wasm
+import Gyehoek.Prelude
+import Gyehoek.Wasm (wat, watM)
+
+
+lowerRoutine :: Routine -> Wasm.Function
+lowerRoutine rt = _
+
+lowerBlock :: Block -> Wasm.Expr
+lowerBlock = _
+
+lowerInstr :: Instr -> Wasm.Expr
+lowerInstr = \case
+  -- PopCont ktail -> [wat|
+    
+  -- |]
+
+lowerProgram :: Program -> Eff es Wasm.Module
+lowerProgram p = pure [watM|
+  (module
+    ##{rs})
+|]
+  where
+    rs = p ^.. #routines . each . to lowerRoutine

src/Gyehoek/Stack/Syntax.hs

@@ -0,0 +1,150 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveAnyClass #-}
+module Gyehoek.Stack.Syntax
+  ( Program(..)
+  , Routine(..)
+  , Instr(..)
+  , Block(..)
+  , Tail(..)
+  , Val(..)
+  , Lit(..)
+  , Obj(..)
+  , Imm(..)
+  , Hob(..)
+  , Prim(..)
+  , Name(..)
+  , Reg(..)
+  , Label(..)
+  , pattern ValLabel
+  , pattern ObjLabel
+  , stkP
+  ) where
+
+import Control.Lens
+import qualified Gyehoek.Sexp as S
+import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..))
+import GHC.Exts (IsList(..))
+import Data.List (intersperse)
+import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), pattern ObjLabel, Reg, Label)
+import Gyehoek.Prelude
+import Gyehoek.Sexp ((:-)((:-)))
+
+
+newtype Program = MkProgram
+  { routines :: HashMap Label Routine
+  }
+  deriving stock (Show, Generic, Data)
+  deriving newtype (Semigroup, Monoid)
+  deriving anyclass (NFData)
+
+instance IsList Program where
+  type Item Program = Routine
+  fromList rs = MkProgram
+    { routines = fromList [ (r.label, r) | r <- rs ]
+    }
+  toList = toListOf $ #routines . each
+
+data Routine = MkRoutine
+  { label :: Label
+  , start :: Block
+  }
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Block = MkBlock
+  { code :: List Instr
+  , tail :: Tail
+  }
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Tail
+  -- | call the procedure at stack index `n` supplied with `n`
+  -- arguments on top of the stack, then return by calling the
+  -- continuation at stack index `n+1`.
+  = TailCall Int
+  | Call Int
+  | If Val Block Block
+  | Return Int
+  | CallCC
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Instr
+  = Pop Reg
+  | Push Val
+  | Load Reg Int
+  | Prim Reg (Prim Val)
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (NFData)
+
+data Val
+  = ValReg Reg
+  | ValImm Imm
+  deriving stock (Show, Generic, Data, Eq)
+  deriving anyclass (NFData)
+
+pattern ValLabel :: Label -> Val
+pattern ValLabel x = ValImm (ImmLabel x)
+
+
+--- sexp work
+
+pure []
+
+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.headTagged2 "prim" S.datumIso S.datumIso >>>)
+    $ S.End
+    where
+
+instance S.DataIso Block where
+  dataIso = S.with \g ->
+    S.flipped S.snoced
+    >>> S.onHead (S.traversed $ S.sealed S.datumIso)
+    >>> S.onTail (S.datumIso @Tail)
+    >>> S.swap
+    >>> g
+
+instance S.DatumIso Tail where
+  datumIso = S.match
+    $ S.With (S.headTagged1 "tail-call" S.datumIso >>>)
+    $ S.With (S.headTagged1 "call" S.datumIso >>>)
+    $ S.With (if_ >>>)
+    $ S.With (S.headTagged1 "return" S.datumIso >>>)
+    $ S.With (S.headTagged0 "call/cc" >>>)
+    $ S.End
+    where
+      -- if_ = S.ifLike "if" (S.datumIso @Val) S.datumIso S.datumIso
+      if_ = S.ifLike "if" (S.datumIso @Val) (branch "then") (branch "else")
+      branch :: Text -> S.DatumGrammar Block
+      branch s =
+        S.listWithIndentation (S.NSpecial 0) $
+            S.el (S.decorate S.SynBuiltin >>> S.sym s)
+            >>> S.restData (S.dataIso @Block)
+
+instance S.DatumIso Val where
+  datumIso = S.match
+    $ S.With (S.datumIso >>>)
+    $ S.With (S.datumIso >>>)
+    $ S.End
+
+instance S.DatumIso Routine where
+  datumIso = S.with \rout ->
+      S.listWithIndentation (S.NSpecial 1)
+       ( S.el (S.decorate S.SynBuiltin >>> S.sym "define")
+       >>> S.el (S.datumIso @Label)
+       >>> S.restData (S.dataIso @Block)
+       )
+      >>> rout
+
+instance S.DataIso Program where
+  dataIso = S.dataIso @(List Routine) >>> S.iso fromList toList
+
+stkP :: S.QuasiQuoter
+stkP = S.makeSxs [|| S.fromDataUnsafe (S.dataIso @Program) ||]

src/Gyehoek/Stack/VM.hs

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

src/Gyehoek/Wasm.hs

@@ -1,3 +1,4 @@
+{- HLINT ignore "Use newtype instead of data" -}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE TemplateHaskellQuotes #-}

test/Gyehoek/Test/CPS/Eval.hs

@@ -58,7 +58,7 @@ test_eval = do
       <&> fmap ("golden/exec" </>)
   pure $ testGroup "cps interpreter"
     [ testGroup "higher-order" $ cpsCase Driver.eval_cps2_e2e <$> cs
-    -- , testGroup "first-order" $ cpsCase Driver.eval_cps1_e2e <$> cs
+    , testGroup "first-order" $ cpsCase Driver.eval_cps_e2e <$> cs
     ]
 
 maybeBroken name broken = applyWhen (name `elem` broken) expectFail

test/Gyehoek/Test/CPS/Stackify.hs

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

test/Gyehoek/Test/Golden.hs

@@ -0,0 +1,85 @@
+module Gyehoek.Test.Golden where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Silver
+import Gyehoek.Driver qualified as Driver
+import System.FilePath
+import Data.List (List)
+import Data.Functor ((<&>))
+import System.Directory
+import Data.Function
+import System.Environment.Blank (getEnvDefault)
+import qualified System.Process.Text as PT
+import Control.Exception (SomeException (SomeException), Exception (..), catch)
+import Gyehoek.Stack.VM (writeObj)
+import Data.Text qualified as T
+import System.Exit (ExitCode(..))
+import Test.Tasty.ExpectedFailure (expectFail, ignoreTestBecause)
+import Control.DeepSeq (($!!))
+import Text.Pretty.Simple (pShow, pShowNoColor)
+import Control.Lens (strict, view)
+import Gyehoek.Sexp.Read qualified as Read
+import Effectful
+
+
+brokenWasmTests :: List String
+brokenWasmTests =
+  [
+  ]
+
+brokenStackifyTests :: List String
+brokenStackifyTests =
+  [
+  ]
+
+test_root :: IO TestTree
+test_root = do
+  all_cases <- listDirectory "golden/exec"
+  let tests = all_cases
+            & fmap ("golden/exec"</>)
+  testGroup "execution" <$> sequenceA
+    [ ignoreTestBecause "wasm codegen is on the backburner"
+      <$> wasmTests tests
+    , ignoreTestBecause "i'm killing myself"
+      <$> stackifyTests tests
+    ]
+
+maybeBroken name broken = applyWhen (name `elem` broken) expectFail
+
+wasmTests :: List FilePath -> IO TestTree
+wasmTests files = do
+  cmd <- getEnvDefault "GYEHOEK_WASM_RUNTIME"
+    "runtime/target/debug/gyehoek-wasm-runtime"
+  pure $ testGroup "wasm" $ files <&> \test ->
+    let testname = takeFileName test
+        scmfile = test </> "source.scm"
+        resultfile = test </> "exec"
+        action = do
+          t <- Driver.lower_e2e scmfile
+          PT.readProcessWithExitCode cmd ["-"] t
+    in maybeBroken testname brokenWasmTests $
+      goldenVsAction
+       testname
+       resultfile
+       action
+       printProcResult
+
+stackifyTests :: List FilePath -> IO TestTree
+stackifyTests files = do
+  pure $ testGroup "stackified" $ files <&> \test ->
+    let testname = takeFileName test
+        scmfile = test </> "source.scm"
+        resultfile = test </> "exec"
+        action =
+          catch @SomeException
+            (do rs <- Driver.eval_e2e scmfile
+                pure $!! ( ExitSuccess
+                     , T.unwords . fmap writeObj $ rs
+                     , "" ))
+            \e -> pure (ExitFailure 1, "", T.pack $ displayException e)
+    in maybeBroken testname brokenStackifyTests $
+     goldenVsAction
+       testname
+       resultfile
+       action
+       printProcResult

test/Gyehoek/Test/Stack/VM.hs

@@ -0,0 +1,112 @@
+{-# LANGUAGE OverloadedLists #-}
+module Gyehoek.Test.Stack.VM where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import Gyehoek.Stack.Syntax
+import Gyehoek.Stack.VM qualified as Sut
+import Data.List (List)
+import Gyehoek.Jalmot
+import Gyehoek.Prelude (i)
+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"
+  [ testCase "immediate halt" do
+      evalsTo [] [stkP|
+        (define $start
+          (return 0))
+      |]
+  , testCase "lit int" do
+      evalsTo [ObjImm (ImmInt 3)] [stkP|
+        (define $start
+          (push! 3)
+          (return 1))
+      |]
+  , testCase "non-tail identity function" do
+      evalsTo [ObjImm (ImmInt 123)] [stkP|
+        (define $id
+          (return 1))
+        (define $c
+          (return 1))
+        (define $start
+          (push! $c)
+          (push! $id)
+          (push! 123)
+          (call 1))
+      |]
+  , testCase "tail identity function" do
+      evalsTo [ObjImm (ImmInt 123)] [stkP|
+        (define $id
+          (return 1))
+        (define $start
+          (push! $id)
+          (push! 123)
+          (tail-call 1))
+      |]
+  , testCase "return constant" do
+      evalsTo [ObjImm (ImmInt 123)] [stkP|
+        (define $start
+          (push! $silly)
+          (tail-call 1))
+        (define $silly
+          (push! 123)
+          (return 1))
+      |]
+  , testCase "return multiple" do
+      evalsTo [ObjImm (ImmInt n) | n <- [1,2,3]] [stkP|
+        (define $start
+          (push! 3)
+          (push! 2)
+          (push! 1)
+          (return 3))
+      |]
+  , testCase "return none" do
+      evalsTo [] [stkP|
+        (define $start
+          (return 0))
+      |]
+  , testCase "square" do
+      evalsTo [ObjImm (ImmInt 16)] [stkP|
+        (define $start
+          (push! $square)
+          (push! 4)
+          (tail-call 1))
+        (define $square
+          (pop! %x)
+          (prim (* %x %x))
+          (return 1))
+      |]
+  , testGroup "factorial"
+      let
+        hsfac (n :: Int) = foldr @List (*) 1 [1..n]
+        fac (n :: Int) = [stkP|
+          (define $start
+            (push! $fac)
+            (push! #{n})
+            (tail-call 1))
+          (define $fac
+            (load %n 0)
+            (prim (zero? %n))
+            (pop! %x0)
+            (if %x0
+                (then (push! 1)
+                      (return 1))
+                (else (push! $fac-c0)
+                      (push! $fac)
+                      (prim (- %n 1))
+                      (call 1))))
+          (define $fac-c0
+            (pop! %x2)
+            (pop! %n)
+            (prim (* %n %x2))
+            (return 1))
+      |]
+        mkcase n = testCase [i|#{n}|] do
+          evalsTo [ObjImm . ImmInt $ hsfac n] $ fac n
+      -- 20 is the greatest `n` for which n! ≤ maxBount @Int
+      in [ mkcase n | n <- [0,1,6,20] ]
+  ]