fix: closure-conversion of recursive functions

gyehoek.cabal

@@ -63,6 +63,7 @@ library
     Gyehoek.CPS.Stackify
     Gyehoek.CPS.Syntax
     Gyehoek.Driver
+    Gyehoek.Language
     Gyehoek.GenSym
     Gyehoek.Jalmot
     Gyehoek.Lift1

src/Gyehoek/CPS/Close.hs

@@ -12,29 +12,33 @@ import Gyehoek.Prelude
 close :: GenSym :> es => Exp -> Eff es Exp
 close = transformM \case
   ExpLetRec [(f, AbsLambda lam@(MkLambda bs kb m))] e -> do
-    f_code <- gensym' @Name $ f ^. _Wrapped'. to (<> "-code")
+    f_code <- gensym' @Name $ f ^. _Wrapped' . to (<> "-code")
     -- it would probably be most sane to generate a symbol for `env`,
     -- but we're reusing the lambda binding so we don't have to
     -- explicitly substitute recursive calls.
-    let frees = nub $ freeWithBound' [f] lam
+    let frees = nub $ free' lam
     let m' = ifoldr
-             (\n x q -> [cps|(prim (env-ref #{f} #{n})
-                                (κ (#{x}) #{q}))|])
+             (\n x q ->
+               let p = if x == f then PrimEnv @Val else PrimEnvRef n
+               in [cps|
+                 (prim #{p}
+                   (κ (#{x}) #{q}))
+             |])
              m frees
     pure [cps|
-      (letrec ((#{f_code} (λ (#{f} ##{bs} #{kb})
+      (letrec ((#{f_code} (λ (##{bs} #{kb})
                             #{m'})))
-        (prim (make-closure ($ #{f_code}) ##{frees})
+        (prim (make-closure #{f_code} ##{frees})
           (κ (#{f}) #{e})))
     |]
 
-  ExpApply f xs ktail -> do
-    code <- gensym' @Name "code"
-    pure [cps|
-      (prim (env-code #{f})
-        (κ (#{code})
-          (#{code} #{f} ##{xs} #{ktail})))
-    |]
+  -- ExpApply f xs ktail -> do
+  --   code <- gensym' @Name "code"
+  --   pure [cps|
+  --     (prim (env-code #{f})
+  --       (κ (#{code})
+  --         (#{code} #{f} ##{xs} #{ktail})))
+  --   |]
 
   e -> pure e
 

src/Gyehoek/CPS/Stackify.hs

@@ -27,7 +27,7 @@ runStackify = runWriter
 live :: Free a => Env -> a -> List Name
 -- TODO: free' should return an OSet lol
 live g e = nub (free' e) & filter \x ->
-  x `H.member` g.bound
+  x `elem` g.bound
   -- && not (x `elem` g.contStack)
 
 data BlockBuilder
@@ -48,14 +48,14 @@ stackify
   => Env -> Exp -> Eff es BlockBuilder
 
 stackify g (ExpLetRec [(f, AbsKappa kap)] e) = do
-  stackifyKappa g (MkLabel f) kap \g' kap' -> do
-    emitRoutine kap'
-    stackify g' e
+  kap' <- stackifyKappa g kap
+  emitRoutine (Stk.MkRoutine (MkLabel f) . buildBlock $ kap')
+  stackify g e
 
 stackify g (ExpLetRec [(f, AbsLambda lam)] e) = do
-  stackifyLambda g (MkLabel f) lam \g' lam' -> do
-    emitRoutine lam'
-    stackify g' e
+  lam' <- stackifyLambda g (MkLabel f) lam
+  emitRoutine lam'
+  stackify g e
 
 stackify g (ExpIf c t f) = do
   let c' = stackifyVal g c
@@ -63,96 +63,99 @@ stackify g (ExpIf c t f) = do
   f' <- buildBlock <$> stackify g f
   pure . Tail $ Stk.If c' t' f'
 
--- stackify g (ExpApply f xs ktail) = pure $
---     Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
---     Tail (Stk.TailCall (stackifyVal g f) (k : (stackifyVal g <$> xs)))
---   where
---     k = var g ktail
---     ls = fold $ (k ^? #ValImm . #ImmLabel)
---       >>= \klbl -> g ^. #liveness . at klbl
-
--- stackify g e@(ExpContinue k xs) = do
---   pure $
---     Code [ Stk.Push (Stk.ValReg l) | l <- ls ] $
---     Tail (Stk.TailCall k' (stackifyVal g <$> xs))
---   where
---     k' = stackifyVal g k
---     ls = fold $ (k' ^? #ValImm . #ImmLabel)
---       >>= \klbl -> g ^. #liveness . at klbl
-
-stackify g (ExpPrim p (MkKappa [x] e)) = do
-  e' <- stackify (g & #bound . at x ?~ Stk.ValReg (MkReg x)) e
+stackify g (ExpApply f xs ktail) = do
   pure $
-    Code [ Stk.Prim (MkReg x) (stackifyVal g <$> p) ] e'
+    Code [ Stk.Push $ stackifyVal g (ValVar ktail)
+         , Stk.Push $ stackifyVal g f
+         ] $
+    Code (pushArgs g xs) $
+    Tail (Stk.Call (length xs))
+
+-- assume that `k` is the continuation on top of the stack lol.
+stackify g e@(ExpContinue k xs)
+  | isn't (#_ValVar . only g.tail) k = pure $
+    Code [ Stk.Push (stackifyVal g k) ] $
+    Code (pushArgs g xs) $
+    Tail $ Stk.TailCall (length xs)
+  | otherwise = pure $
+    Code (pushArgs g xs) $
+    Tail (Stk.Return (length xs))
+
+stackify g (ExpPrim p kap) = do
+  kap' <- stackifyKappa g kap
+  pure $ Code [ Stk.Prim (stackifyVal g <$> p) ] kap'
 
 stackify _ e = error [i|unimplemented exp: #{e}|]
 
+loadArgs :: List Name -> List Stk.Instr
+loadArgs = imapOf itraversed \n x -> Stk.Load (MkReg x) n
+
+pushArgs :: Env -> List Val -> List Stk.Instr
+pushArgs g args = [ Stk.Push $ stackifyVal g x | x <- reverse args ]
+
 -- affine
 _ValName :: Traversal' Val Name
-_ValName = failing #ValVar (#ValImm . #ImmLabel . #MkLabel)
+_ValName = failing #_ValVar (#_ValImm . #_ImmLabel . #_MkLabel)
 
 stackifyKappa
   :: (Stackify :> es, GenSym :> es)
-  => Env -> Label -> Kappa
-  -> (Env -> Stk.Routine -> Eff es r)
-  -> Eff es r
-stackifyKappa g name kap@(MkKappa xs m) w = _
--- stackifyKappa g name kap@(MkKappa xs m) w = do
---   let vs = (name, Stk.ValLabel name) : (bindReg <$> xs)
---   let ls = live g kap
---   m' <- stackify (g & #bound <>~ H.fromList (vs ++ (bindReg <$> ls))) m
---   let g' = g & #bound . at name ?~ Stk.ValLabel name
---              & #liveness . at name ?~ live g kap
---   let rt = Stk.MkRoutine name xs . buildBlock $
---        -- pop in the opposite order we push
---        Code [Stk.Pop x | x <- reverse ls] m'
---   w g' rt
+  => Env -> Kappa
+  -> Eff es BlockBuilder
+stackifyKappa g (MkKappa xs m) = do
+  let g' = g & #bound <>:~ xs
+  Code (loadArgs g'.bound)
+    <$> stackify g' m
 
 stackifyLambda
   :: (Stackify :> es, GenSym :> es)
   => Env -> Label -> Lambda
-  -> (Env -> Stk.Routine -> Eff es r)
-  -> Eff es r
-stackifyLambda g name (MkLambda xs k m) w = do
-  let vs = [ (x, Stk.ValReg (MkReg x)) | x <- k:xs ]
-  m' <- stackify (g & #bound <>~ H.fromList vs) m
-  let g' = g & #bound . at (name ^. wrappedIso) ?~ Stk.ValLabel name
-  w g' $ Stk.MkRoutine name (buildBlock m')
+  -> Eff es Stk.Routine
+stackifyLambda g name (MkLambda xs k m) = do
+  m' <- stackify (g & #bound .~ xs & #tail .~ k) m
+  pure $
+    Stk.MkRoutine name . buildBlock $
+    Code (loadArgs xs) $
+    Code [Stk.Load (MkReg k) (length xs + 1)] m'
 
 stackifyVal :: Env -> Val -> Stk.Val
 stackifyVal g = \case
   ValImm imm -> Stk.ValImm imm
-  ValVar v -> var g v
+  ValVar v -> case regOf g v of
+    Just r -> Stk.ValReg r
+    Nothing -> Stk.ValLabel (MkLabel v)
   v -> error [i|unimplemented val: #{v}|]
 
-var :: Env -> Name -> Stk.Val
-var g v = case g ^. #bound . at v of
-  Just x -> x
-  Nothing -> Stk.ValLabel (MkLabel v)
-
-bindReg :: Name -> (Name, Stk.Val)
-bindReg x = (x, Stk.ValReg (MkReg x))
+regOf :: Env -> Name -> Maybe Reg
+regOf g x
+  | x `elem` g.bound || x == g.tail = Just . MkReg $ x
+  | otherwise                       = Nothing
 
 
 
 data Env = MkEnv
-  { bound :: HashMap Name Stk.Val
+  -- | `bound` tracks the stack lifetime of bound variables.
+  { bound :: List Name
   -- | for each locally-bound continuation @k@, @liveness@ has an
   -- entry @(k,ls)@ where @ls@ is the sequence of registers @k@
   -- expects to find saved on the stack.
-  , liveness :: HashMap Name (List Name)
+  , liveness :: HashMap Label (List Name)
+  , tail :: Name
   }
   deriving (Show, Generic)
 
 emptyEnv :: Env
-emptyEnv = MkEnv mempty mempty
+emptyEnv = MkEnv
+  { bound = mempty
+  , liveness = mempty
+  , tail = "halt"
+  }
 
 
 
 stackifyProgram :: GenSym :> es => Program -> Eff es Stk.Program
 stackifyProgram (MkProgram lam) = do
   let g = emptyEnv
-  (_,p) <- runStackify $ stackifyLambda g "start" lam (const emitRoutine)
+  (_,p) <- runStackify $ emitRoutine =<< stackifyLambda g "start" lam
   pure p
 
 letfn :: Program
@@ -168,3 +171,21 @@ letfn = [cps|
       (continue let-body6 lambda-body1))))
 |]
 
+blah :: Program
+blah = [cps|
+(λ (ktail0)
+          (letrec ((fac (λ (n ktail)
+                             (prim (zero? n)
+                               (κ (x0)
+                                 (if x0
+                                   (continue ktail 1)
+                                   (prim (- n 1)
+                                     (κ (x1)
+                                       (letrec ((fac-k0
+                                                  (κ (x2)
+                                                    (prim (* n x2)
+                                                      (κ (x3)
+                                                        (continue ktail x3))))))
+                                         (fac x1 fac-k0))))))))))
+               (fac 6 halt)))
+|]

src/Gyehoek/Language.hs

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

src/Gyehoek/Scheme/Syntax.hs

@@ -81,7 +81,8 @@ data Prim e
   | PrimZeroP e
   | PrimNewline
   | PrimMakeClosure { code :: e, env :: List e }
-  | PrimEnvRef e Int
+  | PrimEnv
+  | PrimEnvRef Int
   | PrimEnvCode e
   | PrimCallCC e
   | PrimCaptureCC
@@ -167,7 +168,8 @@ primDatumIso namefn a = S.match
     $ S.With (. ht1 "zero?")
     $ S.With (. ht0 "newline")
     $ S.With (. ht1' "make-closure")
-    $ S.With (. S.headTagged2 (namefn "env-ref") a S.int)
+    $ S.With (. ht0 "env")
+    $ S.With (. S.headTagged1 (namefn "env-ref") S.int)
     $ S.With (. ht1 "env-code")
     $ S.With (. ht1 "call/cc")
     $ S.With (. ht0 "capture/cc")

src/Gyehoek/Stack/Syntax.hs

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

src/Gyehoek/Stack/VM.hs

@@ -45,15 +45,12 @@ newtype Frame = MkFrame { locals :: List Obj }
   deriving stock (Show, Generic)
 
 -- affine
-returnAddress :: Traversal' Frame Label
-returnAddress = #locals . _last . #ObjImm . #ImmLabel
+returnAddress :: Traversal' Frame Obj
+returnAddress = #locals . _last
 
 -- affine
-activeProcedure :: Traversal' Frame Label
-activeProcedure = #locals . _init . _last . #ObjImm . #ImmLabel
-
-callStack :: Traversal' Stack Label
-callStack = each . activeProcedure
+activeProcedure :: Traversal' Frame Obj
+activeProcedure = #locals . _init . _last
 
 newtype Stack = MkStack { frames :: NonEmpty Frame }
   deriving stock (Show, Generic)
@@ -122,39 +119,7 @@ stepI e vm (Load r j) = do
 stepI e vm (Push v) = traverseOf activeFrame push vm
   where push xs = cons <$> evalVal e vm v <*> pure xs
 
-stepI e vm (Prim r p) = traverse (evalVal e vm) p >>= \case
-  PrimZeroP x -> case x of
-    ObjImm (ImmInt n) -> ret . ObjImm . ImmBool $ n == 0
-    _ -> vmerror [i|bad arg to zero?: #{x}|]
-  PrimAdd x y -> arith_binop (+) x y
-  PrimMul x y -> arith_binop (*) x y
-  PrimSub x y -> arith_binop (-) x y
-  PrimDiv x y -> arith_binop div x y
-  PrimMakeClosure f env ->
-    case f of
-      ObjImm (ImmLabel l) -> ret . ObjHob $ HobClosure l env
-      _ -> vmerror [i|expected label, got #{f}|]
-  PrimEnvCode env ->
-    case env of
-      ObjHob (HobClosure l _) -> ret . ObjImm . ImmLabel $ l
-      _ -> vmerror [i|expected closure, got #{env}|]
-  PrimEnvRef env n ->
-    case env of
-      ObjHob (HobClosure _ xs) -> ret $ xs ^?! ix n
-      _ -> vmerror [i|expected closure, got #{env}|]
-  PrimCons x y -> ret $ ObjHob $ HobPair x y
-  PrimCar x -> case x of
-      ObjHob (HobPair car _) -> ret car
-      _ -> vmerror [i|expected pair, got ${x}|]
-  PrimCdr x -> case x of
-      ObjHob (HobPair _ cdr) -> ret cdr
-      _ -> vmerror [i|expected pair, got ${x}|]
-  x -> vmerror [i|unimplemented prim: #{p}|]
-  where
-    ret v = pure $ vm & #registers . at r ?~ v
-    arith_binop op (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
-      ret $ ObjImm (ImmInt (op x y))
-    arith_binop _ x y = vmerror [i|bad arith: #{x}, #{y}|]
+stepI g vm (Prim p) = stepP g vm p
 
 stepI e vm (Pop r) = case vm ^? activeFrame . _Cons of
   Nothing -> vmerror "empty stack"
@@ -167,9 +132,9 @@ 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|#{show tc}|] _Just 
+    & expectOf [i|bad call: #{show tc}|] _Just 
   rt <- getRoutine g f
-  let newFrame = MkFrame $ args ++ [ObjLabel f,ObjLabel ret]
+  let newFrame = MkFrame $ args ++ [f,ret]
   pure $ vm
     & jumpToRoutine rt
     & activeFrame .~ frm
@@ -180,31 +145,32 @@ stepT g vm tc@(Call nargs) = do
 
 stepT g vm tc@(Return nret) = do
   (xs,_) <- splitAtExact nret (vm ^. activeFrame . #locals)
-    & expectOf [i|"#{show tc}"|] _Just
-  expectOf [i||] (activeFrame . returnAddress) vm >>= \case
-    "halt" -> pure $ vm & #result ?~ xs
+    & 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|#{show tc}|] _Just
+    & expectOf [i|bad call: #{show tc}|] _Just
   case f of
-    "halt" -> pure $ vm & #result ?~ args
+    ObjLabel "halt" -> pure $ vm & #result ?~ args
     _ -> do
-      rt <- case g ^. #labels . at f of
-        Nothing -> vmerror [i|undefined label #{f}|]
-        Just x -> pure x
-      let newFrame = MkFrame $ args ++ [ObjLabel f, ObjLabel ra]
+      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.
+        -- 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
@@ -213,6 +179,46 @@ stepT g vm (If c t f) = do
       _ -> t
   pure $ jumpToBlock branch vm
 
+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}|]
+  PrimEnvCode env ->
+    case env of
+      ObjHob (HobClosure l _) -> ret1 . ObjImm . ImmLabel $ l
+      _ -> vmerror [i|expected closure, got #{env}|]
+  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}|]
+  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)
@@ -230,17 +236,23 @@ jumpToRoutine rt vm = vm
   & jumpToBlock rt.start
   & #debug . #activeRoutine .~ rt.label
 
-getRoutine :: (HasCallStack, Jalmot :> es) => Env -> Label -> Eff es Routine
-getRoutine g l = case g ^. #labels . at l of
-  Just rt -> pure rt
-  Nothing -> vmerror [i|undefined label #{l}|]
+getLabel :: Obj -> Maybe Label
+getLabel = \case
+  ObjHob (HobClosure {label}) -> Just label
+  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 s = case s ^? l of
-  Just x -> pure x
-  Nothing -> vmerror [i|bad stack, expecting #{msg}|]
+expectOf msg l = maybe (vmerror msg) pure . preview l
 
 evalToLabel :: Jalmot :> es => Env -> VM -> Val -> Eff es Label
 evalToLabel e vm v =
@@ -265,20 +277,17 @@ takeExact n xs = case compareLength xs n of
   (EQ;GT) -> Just $ take n xs
   LT -> Nothing
 
-parseCall :: Int -> Frame -> Maybe (List Obj, Label, Label, Frame)
+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
-  f' <- f ^? #ObjImm . #ImmLabel
-  ret' <- ret ^? #ObjImm . #ImmLabel
-  pure (xs',f',ret',MkFrame ys)
+  pure (xs',f,ret,MkFrame ys)
 
-parseTailCall :: Int -> Frame -> Maybe (List Obj, Label, Label)
+parseTailCall :: Int -> Frame -> Maybe (List Obj, Obj, Obj)
 parseTailCall nargs frm = do
   (xs,_) <- splitAtExact (nargs+1) (frm ^. #locals)
   let (xs',f) = xs ^?! _Snoc
-  f' <- f ^? #ObjImm . #ImmLabel
-  pure (xs',f',frm ^?! returnAddress)
+  pure (xs',f,frm ^?! returnAddress)
 
 initialVM :: VM
 initialVM = MkVM
@@ -380,6 +389,11 @@ ppDoc p t =
         .syn-paren-2 { color: green; }
         .syn-paren-3 { color: navy; }
         .syn-paren-4 { color: purple; }
+        .stack-frame
+        { display: inline-flex
+        ; flex-direction: row
+        ; column-gap: 0.5em
+        }
       """
     body_ do
       details_ do
@@ -432,11 +446,26 @@ ppVM vm = do
     td_ do
       code_ curi
     td_ do
-      let xs = vm ^.. activeFrame . each . to ppDatum
-      sequence_ $ intersperse " | " xs
+      ppStack vm.stack
   where
     curi = vm ^?! failing (#code . _head . to ppDatum) (#tail . to ppDatum)
 
+ppStack :: Stack -> Html ()
+ppStack stk = do
+  span_ [class_ "stack"] do
+    stk ^.. each
+      & fmap ppFrame
+      & intersperse " | "
+      & sequence_
+
+ppFrame :: Frame -> Html ()
+ppFrame frm = do
+  span_ [class_ "stack-frame"] do
+    sequence_ $ frm ^.. #locals . each . to ppDatum
+
+ppData :: S.DataIso a => a -> Html ()
+ppData = htmlData . runJalmotUnsafe . S.toData S.dataIso
+
 ppDatum :: S.DatumIso a => a -> Html ()
 ppDatum = htmlDatum . runJalmotUnsafe . S.toDatum S.datumIso
 

test/Gyehoek/Test/CPS/Stackify.hs

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

test/Gyehoek/Test/Golden.hs

@@ -30,9 +30,15 @@ brokenWasmTests =
 brokenStackifyTests :: List String
 brokenStackifyTests =
   [ "callcc-early-exit-1"
+  , "callcc-early-exit-2"
+  , "callcc-early-exit-3"
   , "callcc-early-exit-4"
   , "callcc-early-exit-5"
   , "callcc-early-exit-6"
+  , "callcc-nested-1"
+  , "callcc-nested-2"
+  , "callcc-discard"
+  , "callcc-constant"
   ]
 
 test_root :: IO TestTree

test/Gyehoek/Test/Stack/VM.hs

@@ -76,8 +76,7 @@ test_root = testGroup "stack machine"
           (tail-call 1))
         (define $square
           (pop! %x)
-          (prim %x2 (* %x %x))
-          (push! %x2)
+          (prim (* %x %x))
           (return 1))
       |]
   , testGroup "factorial"
@@ -90,20 +89,19 @@ test_root = testGroup "stack machine"
             (tail-call 1))
           (define $fac
             (load %n 0)
-            (prim %x0 (zero? %n))
+            (prim (zero? %n))
+            (pop! %x0)
             (if %x0
                 (then (push! 1)
                       (return 1))
-                (else (prim %x1 (- %n 1))
-                      (push! $fac-c0)
+                (else (push! $fac-c0)
                       (push! $fac)
-                      (push! %x1)
+                      (prim (- %n 1))
                       (call 1))))
           (define $fac-c0
             (pop! %x2)
             (pop! %n)
-            (prim %x3 (* %n %x2))
-            (push! %x3)
+            (prim (* %n %x2))
             (return 1))
       |]
         mkcase n = testCase [i|#{n}|] do