stupid

src/Gyehoek/CPS/Stackify.hs

@@ -71,7 +71,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,13 +82,13 @@ stackify g e@(ExpContinue k xs)
 
 stackify g (ExpPrim (PrimCallCC withcc) cc) = do
   cc' <- stackifyKappa g cc
-  cc_l <- gensym' @Name "cc"
-  reified_cc_l <- gensym' @Name "reified-cc"
-  emitRoutine . Stk.MkRoutine (MkLabel cc_l) . buildBlock $ cc'
-  stackify g $
-    ExpPrim PrimCaptureCC $
-    MkKappa [reified_cc_l] $
-    ExpApply withcc [ValVar reified_cc_l] cc_l
+  cc_l <- gensym' @Label "cc"
+  emitRoutine . Stk.MkRoutine cc_l . buildBlock $ cc'
+  pure $
+    Code [ Stk.Push $ stackifyVal g withcc
+         , Stk.Push $ stackifyVal g (ValLabel cc_l)
+         ] $
+    Tail Stk.CallCC
 
 stackify g (ExpPrim p kap) = do
   kap' <- stackifyKappa g kap

src/Gyehoek/CPS/Syntax.hs

@@ -97,7 +97,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)
@@ -220,9 +220,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

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

@@ -132,16 +132,20 @@ 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 
+    & expectOf [i|bad call: #{show tc}|] _Just
   rt <- getRoutine g f
   let newFrame = MkFrame $ args ++ [f,ret]
   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
-    label <- vm & expectOf [i|bad stack, no return addr|]
-      (activeFrame . returnAddress . #_ObjImm . #_ImmLabel)
-    ret1 . ObjHob $ HobContinuation { label }
+  -- 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
@@ -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))))))