diff --git a/golden/exec/cons-2/source.scm b/golden/exec/cons-2/source.scm new file mode 100644 index 0000000..c704ac5 --- /dev/null +++ b/golden/exec/cons-2/source.scm @@ -0,0 +1,2 @@ +(let ((p (cons 123 456))) + (cons (cdr p) (car p))) diff --git a/src/Gyehoek/CPS/Close.hs b/src/Gyehoek/CPS/Close.hs index 2080d05..9b297dd 100644 --- a/src/Gyehoek/CPS/Close.hs +++ b/src/Gyehoek/CPS/Close.hs @@ -31,7 +31,6 @@ close1 = \case (each . _2) (freeWithBound' boundNames') & nub - pTraceShowM frees env_cont_l <- gensym' @Name "env-cont" e_l <- gensym' @Name "letrec-body-cont" bs' <- for bs \(f,ab) -> do diff --git a/src/Gyehoek/CPS/Convert.hs b/src/Gyehoek/CPS/Convert.hs index 7f37702..a3da431 100644 --- a/src/Gyehoek/CPS/Convert.hs +++ b/src/Gyehoek/CPS/Convert.hs @@ -49,12 +49,15 @@ convert (Scm.ExpLit l) k = k . one . ValImm $ case l of convert (Scm.ExpPrim p) k = telescope (convert1 @es) p \p' -> do r_l <- gensym' "r" - k_l <- gensym' @Name "prim-k" + -- k_l <- gensym' @Name "prim-k" m <- k [ValVar r_l] pure [cps| - (letrec ((#{k_l} (κ (#{r_l}) #{m}))) - (prim #{p'} #{k_l})) + (prim #{p'} (κ (#{r_l}) #{m})) |] + -- pure [cps| + -- (letrec ((#{k_l} (κ (#{r_l}) #{m}))) + -- (prim #{p'} #{k_l})) + -- |] convert (Scm.ExpLambda xs e) k = do f <- gensym' "lambda-body" diff --git a/src/Gyehoek/CPS/Eval.hs b/src/Gyehoek/CPS/Eval.hs index 6c17b90..276d9d7 100644 --- a/src/Gyehoek/CPS/Eval.hs +++ b/src/Gyehoek/CPS/Eval.hs @@ -18,6 +18,8 @@ import Control.Monad.Cont qualified as Cont import Gyehoek.Sexp qualified as S import GHC.Generics (Generically(..)) import Gyehoek.Sexp ((:-)(..)) +import Data.List (nub) +import Data.HashSet.Lens (setOf) data Env = MkEnv @@ -40,7 +42,7 @@ data Obj -- | a heap object. data Hob - = HobClosure { code :: Abs, env :: Env} + = HobClosure { code :: Abs, env :: List Obj } -- should a continuation have a label, or an Obj? | HobPair Obj Obj deriving stock (Show, Generic, Data, Eq) @@ -59,7 +61,7 @@ instance S.DatumIso Hob where where conspair = S.dottedList (S.el S.datumIso) S.datumIso -- closures can be printed, but not parsed. - closure :: S.G (S.Datum :- t) (Env :- Abs :- t) + closure :: S.G (S.Datum :- t) (List Obj :- Abs :- t) closure = S.Flip $ S.PartialIso (\(_:-_:-t) -> S.Unreadable [i|\#|] :- t) (const . Left $ mempty) @@ -82,18 +84,23 @@ eval => Env -> Exp -> Eff es (List Obj) -eval g (ExpLetRec bs e) = eval g' e - where - g' = g <> foldMap - (\(f,ab) -> mempty & #store . at f ?~ - ObjHob (HobClosure ab g')) - bs +eval g (ExpLetRec bs e) = do + let boundNames = bs ^.. each . _1 + let boundNames' = setOf each boundNames + let frees = bs + & foldMapOf + (each . _2) + (freeWithBound' boundNames') + & nub + let g' = g & #store <>~ foldMap + _ + bs + eval g' e eval g (Halt rs) = traverse (evalVal g) rs -eval g (ExpContinue k xs) = - case k of - ValVar x -> continueWith g (KexpVar x) xs +eval g (ExpContinue k xs) = case k of + ValVar x -> continueWith g (KexpVar x) =<< traverse (evalVal g) xs eval g (ExpApply f xs ktail) = do f' <- evalVal g f @@ -112,21 +119,29 @@ eval g (ExpPrim p k) = traverse (evalVal g) p >>= \case PrimMul x y -> arith2 (*) x y PrimSub x y -> arith2 (-) x y PrimDiv x y -> arith2 div x y + PrimCons car cdr -> ret1 . ObjHob $ HobPair car cdr + PrimCar p -> case p of + ObjHob (HobPair x _) -> ret1 x + _ -> err "car" + PrimCdr p -> case p of + ObjHob (HobPair _ y) -> ret1 y + _ -> err "cdr" + p -> err [i|unimplemented prim #{p}|] where + ret1 = continueWith g k . (:[]) arith2 f (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) = - pure1 . ObjImm . ImmInt $ f x y + ret1 . ObjImm . ImmInt $ f x y eval g e = err [i|unimplemented exp: #{S.encodeOrShow' @Text S.datumIso e}|] -continueWith :: Jalmot :> es => Env -> Kexp -> List Val -> Eff es (List Obj) -continueWith g kexp xs = do - xs' <- traverse (evalVal g) xs +continueWith :: Jalmot :> es => Env -> Kexp -> List Obj -> Eff es (List Obj) +continueWith g kexp xs = evalKexp g kexp >>= \case - ObjImm (ImmLabel "halt") -> traverse (evalVal g) xs + ObjImm (ImmLabel "halt") -> pure xs ObjHob (HobClosure {code,env}) -> eval env' e where MkAbs bxs bktail e = code - env' = env & #store <>~ H.fromList (zip bxs xs') + env' = env & #store <>~ H.fromList (zip bxs xs) evalKexp :: Jalmot :> es => Env -> Kexp -> Eff es Obj evalKexp g = \case diff --git a/src/Gyehoek/Driver.hs b/src/Gyehoek/Driver.hs index e7d6f2c..ae3020c 100644 --- a/src/Gyehoek/Driver.hs +++ b/src/Gyehoek/Driver.hs @@ -1,5 +1,5 @@ module Gyehoek.Driver - (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e, eval_cps_e2e) + (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e, eval_cps_e2e, eval_cps2_e2e) where import Gyehoek.Options @@ -123,10 +123,10 @@ driver opts = do S.writeDatum cps closedCps <- closeProgram cps when opts.dumpClosed do - S.writeData closedCps + S.writeDatum closedCps hoistedCps <- hoistProgram closedCps when opts.dumpHoisted do - S.writeData hoistedCps + S.writeDatum hoistedCps -- contifiedCps <- contifyProgram hoistedCps -- when opts.dumpContified do -- hPutStrLn FS.stdout =<< S.encodeWith S.datumIso contifiedCps @@ -137,6 +137,9 @@ driver opts = do (eval >=> fmap writeObj >>> T.unwords >>> hPutStrLn FS.stdout) + when (rt_is #HigherOrderCPS) do + CPS.evalProgram cps + >>= S.writeData when (rt_is #CPS) do CPS.evalProgram closedCps >>= S.writeData @@ -166,6 +169,14 @@ eval_e2e fp = runJalmotIO . runFileSystem . runGenSym $ do eval_cps_e2e :: FilePath -> IO Text eval_cps_e2e fp = runJalmotIO . runFileSystem . runGenSym $ + readScm fp + >>= convertProgram + >>= closeProgram + >>= CPS.evalProgram + >>= pure . S.encodeOrShowData' S.dataIso + +eval_cps2_e2e :: FilePath -> IO Text +eval_cps2_e2e fp = runJalmotIO . runFileSystem . runGenSym $ readScm fp >>= convertProgram -- >>= closeProgram diff --git a/src/Gyehoek/Options.hs b/src/Gyehoek/Options.hs index 11002d5..2920180 100644 --- a/src/Gyehoek/Options.hs +++ b/src/Gyehoek/Options.hs @@ -13,7 +13,7 @@ import Data.Foldable import Gyehoek.Prelude hiding (argument) -data Runtime = Stackify | Wasm | CPS +data Runtime = Stackify | Wasm | CPS | HigherOrderCPS deriving (Show, Generic, Eq) data Language @@ -55,6 +55,7 @@ runtimeReader = maybeReader \case "stackify" -> Just (Just Stackify) "wasm" -> Just (Just Wasm) "cps" -> Just (Just CPS) + ("cps2";"higher-order-cps") -> Just (Just CPS) "none" -> Just Nothing _ -> Nothing @@ -75,9 +76,9 @@ parser = do runtime <- option runtimeReader . fold $ [ long "runtime" , short 'R' - , value (Just CPS) + , value (Just HigherOrderCPS) , completeWith runtimeValues - , showDefaultWith $ const "cps" + , showDefaultWith $ const "higher-order-cps" , metavar "RUNTIME" ] sourceLanguage <- option languageReader . fold $ diff --git a/src/Gyehoek/Sexp/Grammar.hs b/src/Gyehoek/Sexp/Grammar.hs index 034b833..c220703 100644 --- a/src/Gyehoek/Sexp/Grammar.hs +++ b/src/Gyehoek/Sexp/Grammar.hs @@ -132,7 +132,7 @@ encodeOrShow' g x = fromString $ encodeOrShow :: (IsString s, Show a) => DatumGrammar a -> a -> s encodeOrShow g x = fromString $ - case runPureEff . runJalmot . encodeWith' g $ x of + case runPureEff . runJalmot . encodeWith g $ x of Left _ -> show x Right t -> T.unpack t diff --git a/test/Gyehoek/Test/CPS/Eval.hs b/test/Gyehoek/Test/CPS/Eval.hs index 8725301..451f8f9 100644 --- a/test/Gyehoek/Test/CPS/Eval.hs +++ b/test/Gyehoek/Test/CPS/Eval.hs @@ -56,12 +56,15 @@ test_eval :: IO TestTree test_eval = do cs <- listDirectory "golden/exec" <&> fmap ("golden/exec" ) - pure $ testGroup "cps interpreter" $ cpsCase <$> cs + pure $ testGroup "cps interpreter" + [ testGroup "higher-order" $ cpsCase Driver.eval_cps2_e2e <$> cs + , testGroup "first-order" $ cpsCase Driver.eval_cps_e2e <$> cs + ] maybeBroken name broken = applyWhen (name `elem` broken) expectFail -cpsCase :: FilePath -> TestTree -cpsCase test = +cpsCase :: (FilePath -> IO Text) -> FilePath -> TestTree +cpsCase f test = maybeBroken testName brokenEvalTests $ goldenVsAction testName resultFile action printProcResult where @@ -69,7 +72,7 @@ cpsCase test = resultFile = test "exec" sourceFile = test "source.scm" action = catch @SomeException - (do r <- Driver.eval_cps_e2e sourceFile + (do r <- f sourceFile pure $!! ( ExitSuccess , r , "" ))