call/cc

golden/callcc-trivial/exec

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

golden/callcc-trivial/source.scm

@@ -0,0 +1 @@
+(call/cc (λ (cc) (cc 123)))

src/Gyehoek/CPS/Convert.hs

@@ -42,6 +42,23 @@ convert
 convert (Scm.ExpVar x) k = k $ ValVar x
 convert (Scm.ExpLit l) k = k $ ValLit l
 
+-- special case: call/cc is desugared during cps-conversion...
+convert (Scm.ExpPrim (PrimCallCC withcc)) k = do
+  convert withcc \withcc' -> do
+    callcc <- gensym' @Name "call/cc"
+    cc <- gensym' @Name "cc"
+    r <- gensym' "r"
+    m <- k $ ValVar r
+    ccish <- gensym' @Name "cc-ish"
+    x <- gensym' @Name "x"
+    pure [cps|
+      (letrec ((#{cc} (κ (#{r}) #{m})))
+        (letrec ((#{ccish} (λ (#{x} _) (continue #{cc} #{x}))))
+          (#{withcc'} #{ccish} #{cc})))
+    |]
+
+-- ...while all other prims are left as-is for later stages to
+-- handle..
 convert (Scm.ExpPrim p) k =
   telescope (convert @es) p \p' -> do
     r <- gensym' "r"

src/Gyehoek/CPS/Stackify.hs

@@ -14,13 +14,10 @@ import Effectful.Writer.Static.Shared
 import Control.Lens
 import Data.String.Interpolate
 import Gyehoek.Stack.Syntax (Imm(..))
-import Data.HashSet (HashSet)
-import qualified Data.HashSet as HS
 import GHC.Generics (Generic)
 import Data.Foldable
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as H
-import Data.HashSet.Lens (hashMap)
 import Data.List (List)
 import GHC.Exts (IsList(fromList))
 
@@ -31,7 +28,9 @@ runStackify :: Eff (Stackify : es) a -> Eff es (a, Stk.Program)
 runStackify = runWriter
 
 live :: Free a => Env -> a -> List Name
-live g e = free' e & filter \x -> x `H.member` g.bound && x /= g.returnLabel
+live g e = free' e & filter \x ->
+  x `H.member` g.bound
+  && not (x `elem` g.contStack)
 
 stackify
   :: (GenSym :> es, Stackify :> es)
@@ -52,7 +51,7 @@ stackify g (ExpLetRec [(f, AbsLambda' xs k m)] e) = do
   lam_body <- gensym' "lambda-body"
   m' <- stackify (g & #bound .~ H.fromList vs
                     & #bound . at f ?~ Stk.ValLabel lam_body
-                    & #returnLabel .~ k) m
+                    & #contStack %~ (k:)) m
   tell [Stk.MkBlock lam_body xs . toList $ m']
   stackify (g & #bound . at f ?~ Stk.ValLabel lam_body) e
 
@@ -63,21 +62,22 @@ stackify g (ExpIf c t f) = do
 
 stackify g (ExpApply f xs ktail) = do
   pure $
-    [ Stk.PushCont (Stk.ValLabel k) ]
+    [ Stk.PushCont k ]
     <> fromList [ Stk.Push (Stk.ValReg l) | l <- ls ]
     <> [ Stk.Call (stackifyVal g f) (stackifyVal g <$> xs) ]
   where
-    k = case var g ktail of
-      Stk.ValLabel x -> x
-      x -> error [i|expected a label, got #{x} (i guess)|]
-    ls = fold $ g ^. #liveness . at k
+    k = var g ktail
+    ls = fold $ (k ^? #ValImm . #ImmLabel)
+      >>= \klbl -> g ^. #liveness . at klbl
 
 -- this probably won't work for call/cc, for cps-converted code it'll
 -- be fine i think. notice how, instead of calling `var g k`, we just
 -- assume it's the return continuation on top of the stack.
 stackify g (ExpContinue k xs) = do
   ktail <- gensym' $ k ^. _Wrapped'
-  pure [ Stk.PopCont ktail
+  pure $
+    fromList [ Stk.PopCont "_" | _ <- takeWhile (/= k) g.contStack ]
+    <> [ Stk.PopCont ktail
        , Stk.Call (Stk.ValReg ktail) (stackifyVal g <$> xs)
        ]
 
@@ -106,16 +106,16 @@ bindReg x = (x, Stk.ValReg x)
 
 data Env = MkEnv
   { bound :: HashMap Name Stk.Val
-  , returnLabel :: 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)
+  , contStack :: List Name
   }
   deriving (Show, Generic)
 
 emptyEnv :: Env
-emptyEnv = MkEnv mempty "halt" mempty
+emptyEnv = MkEnv mempty mempty ["halt"]
 
 
 

src/Gyehoek/Scheme/Syntax.hs

@@ -40,7 +40,7 @@ import GHC.Generics (Generic)
 import Prelude hiding ((.), id)
 import Control.Category
 import Data.List.NonEmpty (NonEmpty)
-import Gyehoek.Sexp qualified
+import Gyehoek.Sexp qualified as GS
 import Gyehoek.GenSym (Gen)
 import Control.Lens
 import Data.Generics.Labels ()
@@ -85,7 +85,8 @@ data Prim e
   | PrimZeroP e
   | PrimNewline
   | PrimMakeClosure { code :: e, env :: List e }
-  | PriEnvRef e Int
+  | PrimEnvRef e Int
+  | PrimCallCC e
   deriving (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
 
 instance Each (Prim e) (Prim e') e e'
@@ -156,29 +157,29 @@ instance SexpIso Name where
 
 primSexpIso :: (Text -> Text) -> Sexp.SexpGrammar a -> Sexp.SexpGrammar (Prim a)
 primSexpIso namefn a = match
-    $ With (. binop "+")
-    $ With (. binop "-")
-    $ With (. binop "*")
-    $ With (. binop "/")
-    $ With (. binop "cons")
-    $ With (. unop "car")
-    $ With (. unop "cdr")
-    $ With (. unop "immediate?")
-    $ With (. unop "cons?")
-    $ With (. unop "integer?")
-    $ With (. unop "write")
-    $ With (. unop "zero?")
+    $ With (. ht2 "+")
+    $ With (. ht2 "-")
+    $ With (. ht2 "*")
+    $ With (. ht2 "/")
+    $ With (. ht2 "cons")
+    $ With (. ht1 "car")
+    $ With (. ht1 "cdr")
+    $ With (. ht1 "immediate?")
+    $ With (. ht1 "cons?")
+    $ With (. ht1 "integer?")
+    $ With (. ht1 "write")
+    $ With (. ht1 "zero?")
     $ With (. nullop "newline")
-    $ With (. mkclosure)
-    $ With (. envref)
+    $ With (. ht1' "make-closure")
+    $ With (. GS.headTagged2 (namefn "env-ref") a Sexp.int)
+    $ With (. ht1 "call/cc")
     $ End
     where
       idn s = el (sym (namefn s))
       nullop s = list $ idn s
-      unop s = list $ idn s >>> el a
-      binop s = list $ idn s >>> el a >>> el a
-      mkclosure = list $ idn "make-closure" >>> el a >>> rest a
-      envref = list $ idn "env-ref" >>> el a >>> el Sexp.int
+      ht1 s = GS.headTagged1 (namefn s) a
+      ht2 s = GS.headTagged2 (namefn s) a a
+      ht1' s = GS.headTagged1' (namefn s) a a
 
 instance SexpIso a => SexpIso (Prim a) where
   -- sexpIso = primSexpIso ("prim:"<>) sexpIso
@@ -188,14 +189,14 @@ instance SexpIso Lit where
   sexpIso = match
     $ With (. sexpIso)
     $ With (. sym "nil")
-    $ With (. Gyehoek.Sexp.schemeBool)
+    $ With (. GS.schemeBool)
     $ With (. sexpIso)
-    $ With (. Gyehoek.Sexp.prefixSugar "quote" Sexp.Quote sexpIso)
+    $ With (. GS.prefixSugar "quote" Sexp.Quote sexpIso)
     $ End
 
 instance SexpIso Sexp where
   sexpIso = match
-    $ With (\conss -> conss . Gyehoek.Sexp.todo)
+    $ With (\conss -> conss . GS.todo)
     $ With (\s -> s . symbol)
     $ With (\lit -> lit . sexpIso)
     $ End
@@ -212,8 +213,8 @@ instance SexpIso Def where
   
 instance SexpIso Exp where
   sexpIso = match
-    $ With (. Gyehoek.Sexp.let_ "let" sexpIso sexpIso sexpIso)
-    $ With (. Gyehoek.Sexp.let_ "letrec" sexpIso sexpIso sexpIso)
+    $ With (. GS.let_ "let" sexpIso sexpIso sexpIso)
+    $ With (. GS.let_ "letrec" sexpIso sexpIso sexpIso)
     $ With (. sexpIso)
     $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
     $ With (. if_)
@@ -225,7 +226,7 @@ instance SexpIso Exp where
     where
       if_ = list $ el (sym "if") >>> el sexpIso >>> el sexpIso >>> el sexpIso
       lam = list
-        ( el Gyehoek.Sexp.lambdaKeyword
+        ( el GS.lambdaKeyword
           >>> el (sexpIso @(List Name))
           >>> el sexpIso )
 
@@ -242,7 +243,7 @@ instance SexpIso CommandOrDef where
 -- utilities
 
 scm :: QuasiQuoter
-scm = Gyehoek.Sexp.makeSx [|| Gyehoek.Sexp.fromSexp @Exp ||]
+scm = GS.makeSx [|| GS.fromSexp @Exp ||]
 
 free :: Exp -> HashSet Name
 free = cata \case
@@ -278,7 +279,7 @@ hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
 readProgram :: IOE :> es => FilePath -> Eff es Program
 readProgram fp = runFileSystem $
   FS.withFile fp FS.ReadMode $ \h ->
-    Gyehoek.Sexp.parseSexps @CommandOrDef (fileName fp) <$> hGetContents h
+    GS.parseSexps @CommandOrDef (fileName fp) <$> hGetContents h
      >>= either error (pure . MkProgram)
 
 readExp :: IOE :> es => FilePath -> Eff es Exp

test/Gyehoek/Test/CPS/Stackify.hs

@@ -53,6 +53,12 @@ prim = testGroup "prim"
       evalsTo [ObjImm (ImmInt 9)]
         [cps|(prim (+ 4 5)
                (κ (x) (continue halt 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

test/Gyehoek/Test/Golden.hs

@@ -19,13 +19,7 @@ import Test.Tasty.ExpectedFailure (expectFail)
 
 brokenWasmTests :: List String
 brokenWasmTests =
-  [ "adder"
-  , "apply-twice"
-  , "square"
-  , "fn-of-fn"
-  , "let-fn"
-  , "apply2"
-  , "factorial"
+  [
   ]
 
 brokenStackifyTests :: List String
@@ -42,8 +36,8 @@ root = do
   let tests = all_cases
             & fmap ("golden"</>)
   testGroup "golden" <$> sequenceA
-    [ wasmTests tests
-    , stackifyTests tests
+    [ {-wasmTests tests
+    , -}stackifyTests tests
     ]
 
 maybeBroken name broken = applyWhen (name `elem` broken) expectFail