diff --git a/golden/callcc-trivial/exec b/golden/callcc-trivial/exec new file mode 100644 index 0000000..7e6cbaf --- /dev/null +++ b/golden/callcc-trivial/exec @@ -0,0 +1,2 @@ +ret > ExitSuccess +out > 123 diff --git a/golden/callcc-trivial/source.scm b/golden/callcc-trivial/source.scm new file mode 100644 index 0000000..52d0623 --- /dev/null +++ b/golden/callcc-trivial/source.scm @@ -0,0 +1 @@ +(call/cc (λ (cc) (cc 123))) diff --git a/src/Gyehoek/CPS/Convert.hs b/src/Gyehoek/CPS/Convert.hs index 0a77a66..6572749 100644 --- a/src/Gyehoek/CPS/Convert.hs +++ b/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" diff --git a/src/Gyehoek/CPS/Stackify.hs b/src/Gyehoek/CPS/Stackify.hs index ad619ab..9bc9391 100644 --- a/src/Gyehoek/CPS/Stackify.hs +++ b/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"] diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index b57f798..d51a90c 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/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 diff --git a/test/Gyehoek/Test/CPS/Stackify.hs b/test/Gyehoek/Test/CPS/Stackify.hs index d6e0d83..24f2618 100644 --- a/test/Gyehoek/Test/CPS/Stackify.hs +++ b/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 diff --git a/test/Gyehoek/Test/Golden.hs b/test/Gyehoek/Test/Golden.hs index 1355108..658155e 100644 --- a/test/Gyehoek/Test/Golden.hs +++ b/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