stupid

src/Gyehoek/CPS/Close.hs

@@ -9,7 +9,7 @@ import Gyehoek.GenSym
 import Gyehoek.Prelude
 
 
-close :: GenSym :> es => Exp -> Eff es Exp
+close :: forall es. 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")
@@ -17,19 +17,23 @@ close = transformM \case
     -- but we're reusing the lambda binding so we don't have to
     -- explicitly substitute recursive calls.
     let frees = nub $ free' lam
-    let m' = ifoldr
+    m' <- ifoldrM @_ @_ @(Eff es)
-             (\n x q ->
+             (\n x q -> do
+               q_l <- gensym' @Name "env-cont"
                let p = if x == f then PrimEnv @Val else PrimEnvRef n
-               in [cps|
+               pure [cps|
-                 (prim #{p}
+                 (letrec ((#{q_l} (κ (#{x}) #{q})))
-                   (κ (#{x}) #{q}))
+                   (prim #{p}
-             |])
+                     #{q_l}))
+               |])
              m frees
+    e_l <- gensym' @Name "make-closure-cont"
     pure [cps|
       (letrec ((#{f_code} (λ (##{bs} #{kb})
                             #{m'})))
-        (prim (make-closure #{f_code} ##{frees})
+        (letrec ((#{e_l} (κ (#{f}) #{e})))
-          (κ (#{f}) #{e})))
+          (prim (make-closure #{f_code} ##{frees})
+            #{e_l})))
     |]
 
   e -> pure e

src/Gyehoek/CPS/Convert.hs

@@ -46,29 +46,15 @@ convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
   LitBool b -> ImmBool b
   _ -> _
 
--- special case: call/cc is desugared during cps-conversion...
--- convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
---   convert1 withcc \withcc' -> do
---     cc_l <- gensym' @Name "cc"
---     r1_l <- gensym' @Name "r"
---     r2_l <- gensym' @Name "r"
---     ccish_l <- gensym' @Name "ccish"
---     reified_cc_l <- gensym' @Name "reified-cc"
---     m <- k [ValVar r1_l]
---     pure [cps|
--- (letrec ((#{cc_l} (κ (#{r1_l})
---                      #{m})))
---   (prim (capture/cc)
---        (κ (#{reified_cc_l})
---           (#{withcc'} #{reified_cc_l} #{cc_l}))))
---     |]
-
--- ...while all other prims are left as-is for later stages to
--- handle..
 convert (Scm.ExpPrim p) k =
   telescope (convert1 @es) p \p' -> do
-    r <- gensym' "r"
+    r_l <- gensym' "r"
-    ExpPrim p' . MkKappa [r] <$> k [ValVar r]
+    k_l <- gensym' @Name "prim-k"
+    m <- k [ValVar r_l]
+    pure [cps|
+      (letrec ((#{k_l} (κ (#{r_l}) #{m})))
+        (prim #{p'} #{k_l}))
+    |]
 
 convert (Scm.ExpLambda xs e) k = do
   f <- gensym' "lambda-body"
@@ -90,8 +76,16 @@ convert (Scm.ExpApply f xs) k =
 convert (Scm.ExpBegin xs) k = telescope (convert @es) xs (k . NE.last)
 
 convert (Scm.ExpIf c t f) k =
-  convert1 c \c' ->
+  convert1 c \c' -> do
-    ExpIf c' <$> convert t k <*> convert f k
+    t_l <- gensym' @Name "truthy-cont"
+    f_l <- gensym' @Name "falsey-cont"
+    t' <- convert t k
+    f' <- convert f k
+    pure [cps|
+      (letrec ((#{t_l} (κ () #{t'}))
+               (#{f_l} (κ () #{f'})))
+        (if #{c'} #{t_l} #{f_l}))
+    |]
 
 -- let-bindings are desugared into continuation calls whose parameters
 -- are the left-hand sides and whose arguments are the right-hand

src/Gyehoek/CPS/Stackify.hs

@@ -12,7 +12,7 @@ import Gyehoek.GenSym
 import Effectful.Writer.Static.Shared
 import Data.Foldable
 import qualified Data.HashMap.Strict as H
-import Data.List (elemIndex, nub)
+import Data.List (elemIndex, nub, intersect)
 import Data.Text qualified as T
 import Gyehoek.Prelude
 import Debug.Pretty.Simple
@@ -30,6 +30,16 @@ 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
@@ -71,7 +81,6 @@ stackify g (ExpApply f xs ktail) = do
     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) ] $
@@ -83,22 +92,22 @@ stackify g e@(ExpContinue k xs)
 
 stackify g (ExpPrim (PrimCallCC withcc) cc) = do
   cc' <- stackifyKappa g cc
-  cc_l <- gensym' @Name "cc"
+  cc_l <- gensym' @Label "cc"
-  reified_cc_l <- gensym' @Name "reified-cc"
+  emitRoutine . Stk.MkRoutine cc_l . buildBlock $ cc'
-  emitRoutine . Stk.MkRoutine (MkLabel cc_l) . buildBlock $ cc'
+  pure $
-  stackify g $
+    Code [ Stk.Push $ stackifyVal g withcc
-    ExpPrim PrimCaptureCC $
+         , Stk.Push $ stackifyVal g (ValLabel cc_l)
-    MkKappa [reified_cc_l] $
+         ] $
-    ExpApply withcc [ValVar reified_cc_l] cc_l
+    Tail Stk.CallCC
 
-stackify g (ExpPrim p kap) = do
+stackify g (ExpPrim p (MkKappa rs e)) = do
-  kap' <- stackifyKappa g kap
+  _
-  pure $ Code [ Stk.Prim (stackifyVal g <$> p) ] kap'
+  pure $ Code [ Stk.Prim (stackifyVal g <$> p) ] _
 
 stackify _ e = error [i|unimplemented exp: #{e}|]
 
-loadArgs :: List Name -> List Stk.Instr
+loadArgs :: Free a => Env -> a -> List Name -> List Stk.Instr
-loadArgs = imapOf itraversed \n x -> Stk.Load (MkReg x) n
+loadArgs g e = imapOf itraversed \n x -> load g e (MkReg x) n
 
 pushArgs :: Env -> List Val -> List Stk.Instr
 pushArgs g args = [ Stk.Push $ stackifyVal g x | x <- reverse args ]
@@ -113,7 +122,7 @@ stackifyKappa
   -> Eff es BlockBuilder
 stackifyKappa g (MkKappa xs m) = do
   let g' = g & #bound <>:~ xs
-  Code (loadArgs g'.bound)
+  Code [ _ | x <- g'.bound `intersect` free' m ]
     <$> stackify g' m
 
 stackifyLambda

src/Gyehoek/CPS/Syntax.hs

@@ -56,6 +56,7 @@ import Gyehoek.Sexp (G, (:-)(..))
 import qualified Data.InvertibleGrammar.Base as IG
 import Gyehoek.GenSym (Gen)
 import Data.String (IsString)
+import Control.Applicative
 
 -- Data types
 
@@ -97,7 +98,7 @@ pattern ObjLabel l = ObjImm (ImmLabel l)
 data Hob
   = HobClosure { label :: Label, env :: List Obj }
   -- should a continuation have a label, or an Obj?
-  | HobContinuation { label :: Label }
+  | HobContinuation { cont :: Obj, stack :: NonEmpty (List Obj) }
   | HobPair Obj Obj
   deriving stock (Show, Generic, Data, Eq)
   deriving anyclass (NFData)
@@ -113,17 +114,17 @@ data Abs
   | AbsLambda Lambda
   deriving (Show, Generic, Data, Eq)
 
-pattern AbsKappa' :: [Name] -> Exp -> Abs
+pattern AbsKappa' :: List Name -> Exp -> Abs
 pattern AbsKappa' xs e = AbsKappa (MkKappa xs e)
 
-pattern AbsLambda' :: [Name] -> Name -> Exp -> Abs
+pattern AbsLambda' :: List Name -> Name -> Exp -> Abs
 pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
 
 data Exp
-  = ExpPrim (Prim Val) Kappa
+  = ExpPrim (Prim Val) Name
   | ExpLetRec { binders :: List (Name, Abs), body :: Exp }
   | ExpContinue Val (List Val)
-  | ExpIf Val Exp Exp
+  | ExpIf Val Name Name
   | ExpApply
     { op :: Val
     , args :: List Val
@@ -220,9 +221,11 @@ instance S.DatumIso Hob where
       closure = IG.Flip $ IG.PartialIso
         (\(env:-code:-t) -> S.Unreadable [i|\#<procedure $#{code}>|] :- t)
         (const . Left $ mempty)
-      cont :: G (Datum :- t) (Label :- t)
+      cont :: G (Datum :- t) (NonEmpty (List Obj) :- _ :- t)
       cont = IG.Flip $ IG.PartialIso
-        (\(l :- t) -> S.Unreadable [i|\#<continuation $#{l}>|]:- t)
+        (\(_ :- l :- t) -> 
+          let x = S.encodeOrShow' @Text S.datumIso l
+          in S.Unreadable [i|\#<continuation #{x}>|] :- t)
         (const . Left $ mempty)
 
 instance S.DatumIso Lambda where
@@ -327,7 +330,8 @@ class Free a where
   freeWithBound :: HashSet Name -> a -> HashSet Name
   freeWithBound bound = HS.fromList . freeWithBound' bound
 
-  -- | Free variables given in the order of their appearance.
+  -- | Free variables given in the same left-to-right order they
+  -- appear.
   free' :: a -> List Name
   free' = freeWithBound' mempty
 
@@ -337,11 +341,16 @@ instance Free Abs where
   freeWithBound' bound (AbsKappa kap) = freeWithBound' bound kap
   freeWithBound' bound (AbsLambda lam) = freeWithBound' bound lam
 
+mif :: Alternative f => (a -> Bool) -> a -> f a
+mif p a
+  | p a = pure a
+  | otherwise = empty
+
 instance Free Exp where
   freeWithBound' bound = \case
     ExpPrim p k ->
-      p & toListOf (folded . #ValVar . filtered (`notElem` bound))
+      (p ^.. folded . #ValVar . filtered (`notElem` bound))
-        & (<> freeWithBound' bound k)
+      ++ mif (`notElem` bound) k
     ExpLetRec bs m ->
       foldMapOf (each . _2) (freeWithBound' bound') bs
       <> freeWithBound' bound' m
@@ -349,10 +358,10 @@ instance Free Exp where
     ExpContinue k xs -> filter (`notElem` bound) ((k:xs) ^.. each . #ValVar)
     ExpIf c t f ->
       (c ^.. #ValVar . filtered (`notElem` bound))
-      <> freeWithBound' bound t <> freeWithBound' bound f
+      <> mif (`notElem` bound) t <> mif (`notElem` bound) f
     ExpApply f xs k ->
       (f:xs) ^.. (each . #ValVar . filtered (`notElem` bound))
-      <> (k ^.. filtered (`notElem` bound))
+      <> mif (`notElem` bound) k
 
 instance Free Kappa where
   freeWithBound' bound (MkKappa xs m) =

src/Gyehoek/Stack/Syntax.hs

@@ -68,6 +68,7 @@ data Tail
   | Call Int
   | If Val Block Block
   | Return Int
+  | CallCC
   deriving stock (Show, Generic, Data)
   deriving anyclass (NFData)
 
@@ -116,6 +117,7 @@ instance S.DatumIso Tail where
     $ S.With (S.headTagged1 "call" S.datumIso >>>)
     $ S.With (if_ >>>)
     $ S.With (S.headTagged1 "return" S.datumIso >>>)
+    $ S.With (S.headTagged0 "call/cc" >>>)
     $ S.End
     where
       -- if_ = S.ifLike "if" (S.datumIso @Val) S.datumIso S.datumIso

src/Gyehoek/Stack/VM.hs

@@ -138,10 +138,14 @@ stepT g vm tc@(Call nargs) = do
   pure $ vm
     & jumpToRoutine rt
     & activeFrame .~ frm
-    & #stack %~ pushFrame newFrame
     -- 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)
@@ -179,6 +183,21 @@ stepT g vm (If c t f) = do
       _ -> 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
@@ -207,10 +226,10 @@ stepP g vm p = traverse (evalVal g vm) p >>= \case
   PrimCdr x -> case x of
       ObjHob (HobPair _ cdr) -> ret1 cdr
       _ -> vmerror [i|expected pair, got ${x}|]
-  PrimCaptureCC -> do
+  -- PrimCaptureCC -> do
-    label <- vm & expectOf [i|bad stack, no return addr|]
+  --   label <- vm & expectOf [i|bad stack, no return addr|]
-      (activeFrame . returnAddress . #_ObjImm . #_ImmLabel)
+  --     (activeFrame . returnAddress . #_ObjImm . #_ImmLabel)
-    ret1 . ObjHob $ HobContinuation { label }
+  --   ret1 . ObjHob $ HobContinuation { label }
   x -> vmerror [i|unimplemented prim: #{p}|]
   where
     ret vs = pure $ vm & activeFrame . #locals <>:~ vs
@@ -239,6 +258,7 @@ jumpToRoutine rt vm = vm
 getLabel :: Obj -> Maybe Label
 getLabel = \case
   ObjHob (HobClosure {label}) -> Just label
+  ObjHob (HobContinuation {cont}) -> getLabel cont
   ObjImm (ImmLabel label) -> Just label
   x -> Nothing
 
@@ -277,6 +297,11 @@ 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)

t.scm

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