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..54e4948 100644 --- a/src/Gyehoek/CPS/Eval.hs +++ b/src/Gyehoek/CPS/Eval.hs @@ -1,12 +1,16 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedLists #-} module Gyehoek.CPS.Eval ( evalProgram , module Gyehoek.CPS.Syntax , evalExp + , eGrammar ) where import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..)) +import Gyehoek.Sexp qualified as S import Control.Lens import Data.Maybe (fromMaybe) import Text.Show.Functions () @@ -18,150 +22,231 @@ import Control.Monad.Cont qualified as Cont import Gyehoek.Sexp qualified as S import GHC.Generics (Generically(..)) import Gyehoek.Sexp ((:-)(..)) +import Data.List (nub, mapAccumR) +import Data.HashSet.Lens (setOf) +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IM +import Data.Monoid -data Env = MkEnv - { store :: HashMap Name Obj - } - deriving stock (Show, Generic, Data, Eq) - deriving (Semigroup, Monoid) - via Generically Env +newtype Loc = MkLoc { getLoc :: Int } + deriving stock (Generic, Data) + deriving newtype (Show, Eq, Ord, Enum) -emptyEnv = MkEnv - { store = mempty +data Store = MkStore + { nextLoc :: Loc + , heap :: IntMap E + } + deriving stock (Show, Generic, Data) + +emptyStore :: Store +emptyStore = MkStore + { nextLoc = 0 + , heap = mempty } - +newtype Env = MkEnv { getEnv :: HashMap Name Loc } + deriving stock (Show, Generic, Data) + deriving newtype (Semigroup, Monoid) -data Obj - = ObjImm Imm - | ObjHob Hob - deriving stock (Show, Generic, Data, Eq) +emptyEnv :: Env +emptyEnv = mempty --- | a heap object. -data Hob - = HobClosure { code :: Abs, env :: Env} - -- should a continuation have a label, or an Obj? - | HobPair Obj Obj - deriving stock (Show, Generic, Data, Eq) +type instance Index Env = Name +type instance IxValue Env = Loc -instance S.DatumIso Obj where - datumIso = S.match - $ S.With (S.datumIso @Imm >>>) - $ S.With (S.datumIso @Hob >>>) - $ S.End +instance Ixed Env where ix j = #getEnv . ix j +instance At Env where at j = #getEnv . at j -instance S.DatumIso Hob where - datumIso = S.match - $ S.With (closure >>>) - $ S.With (conspair >>>) - $ S.End - 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.Flip $ S.PartialIso - (\(_:-_:-t) -> S.Unreadable [i|\#|] :- t) - (const . Left $ mempty) +update :: Loc -> E -> Store -> Store +update (MkLoc loc) v = #heap %~ IM.alter f loc + where + f (Just _) = Just v + f Nothing = error "segfault lol" + +updates :: Foldable f => f (Loc, E) -> Store -> Store +updates = alaf Endo foldMap (uncurry update) + +fetch :: Loc -> Store -> E +fetch (MkLoc loc) st = st ^?! #heap . ix loc + +new :: Store -> (Store, Loc) +new st = (st & #nextLoc %~ succ, st.nextLoc) + +new' :: E -> Store -> (Store, Loc) +new' e st = (update l e st', l) + where + (st',l) = new st + +news' :: Traversable t => t E -> Store -> (Store, Loc) +news' es st = mapAccumR _ st es + where + (st',l) = new st + +var :: HasCallStack => Env -> Name -> Loc +var g x = g ^?! ix x + +type CmdCont = Store -> Answer +type ExpCont = List E -> CmdCont + +data Answer + = AnswerValues Store (List E) + | AnswerError Text + deriving (Show, Generic, Data) + +data Mutability + = Mut + | NoMut + deriving (Show, Generic, Data, Eq) + +wrong :: Text -> CmdCont +wrong = const . AnswerError + +single :: (E -> CmdCont) -> ExpCont +single k = \case + [x] -> k x + _ -> wrong "wrong number of return values" + +send :: E -> ExpCont -> CmdCont +send e k = k [e] + +-- | Continue with the value located at a given 'Loc'. +hold :: Loc -> ExpCont -> CmdCont +hold loc k st = send (fetch loc st) k st + +tievals :: Traversable t => t E -> (t Loc -> CmdCont) -> CmdCont +tievals es f st0 = f ls stn + where + (stn,ls) = mapAccumR (flip new') st0 es + +bind :: Name -> Loc -> Env +bind k = MkEnv . H.singleton k + +extends :: Foldable f => f (Name, Loc) -> Env -> Env +extends xs g = g <> foldMap (uncurry bind) xs -err :: Jalmot :> es => Text -> Eff es a -err = throwError . VMError +-- | The denotation of an expressed value. +data E + = ESymbol Text + | ECharacter Char + | EInteger Int + | EBool Bool + | EUndefined + | EUnspecified + | ENull + | EPair Loc Loc Mutability + | EVec (List Loc) Mutability + | EString (List Loc) Mutability + | EProcedure Loc Procedure + deriving stock (Show, Generic, Data) -eval1 :: Jalmot :> es => Env -> Exp -> Eff es Obj -eval1 g e = eval g e >>= \case - [r] -> pure r - rs -> err [i|expected one value, but got #{rs}|] +type Procedure = List E -> DynPoints -> ExpCont -> CmdCont -pure1 :: Applicative f => a -> f (List a) -pure1 = pure . (:[]) - -eval - :: Jalmot :> es - => Env -> Exp - -> Eff es (List Obj) - -eval g (ExpLetRec bs e) = eval g' e +eGrammar :: Store -> S.DatumGrammar E +eGrammar st = S.partialOsi (const . Left $ mempty) go where - g' = g <> foldMap - (\(f,ab) -> mempty & #store . at f ?~ - ObjHob (HobClosure ab g')) - bs + gofetch x = go $ fetch x st + go = \case + ESymbol s -> S.Symbol s + ECharacter c -> S.Character c + EInteger n -> S.Number (fromIntegral n) + EBool b -> S.Boolean b + EUndefined -> S.Unreadable "#" + EUnspecified -> S.Unreadable "#" + ENull -> S.List [] + EPair car cdr _mut -> S.DotList [gofetch car] (gofetch cdr) + EVec xs _mut -> S.Vector . fmap gofetch $ xs + EString xs _mut -> S.String _ -eval g (Halt rs) = traverse (evalVal g) rs +data DynPoints = MkDynPoints + deriving (Generic, Data) -eval g (ExpContinue k xs) = - case k of - ValVar x -> continueWith g (KexpVar x) xs + -eval g (ExpApply f xs ktail) = do - f' <- evalVal g f - xs' <- traverse (evalVal g) xs - ktail' <- evalKexp g ktail - case f' of - ObjHob (HobClosure {code,env}) -> eval env' e - where - MkAbs bxs bktail e = code - env' = env - & #store <>~ H.fromList (zip bxs xs') - & maybe id (\b -> #store . at b ?~ ktail') bktail +-- 뻘짓이어라 +telescope + :: Traversable t + => (a -> (b -> r) -> r) + -> t a -> (t b -> r) -> r +telescope f = Cont.runCont . traverse (Cont.cont . f) -eval g (ExpPrim p k) = traverse (evalVal g) p >>= \case - PrimAdd x y -> arith2 (+) x y - PrimMul x y -> arith2 (*) x y - PrimSub x y -> arith2 (-) x y - PrimDiv x y -> arith2 div x y + + +procedure :: Env -> Procedure -> (E -> CmdCont) -> CmdCont +procedure = _ + +evalVal :: Env -> Val -> ExpCont -> CmdCont +evalVal g (ValVar x) k = hold (var g x) $ single \case + EUndefined -> wrong "undefined variable" + e -> send e k + +evalVal1 :: Env -> Val -> (E -> CmdCont) -> CmdCont +evalVal1 g v k = evalVal g v (single k) + +evalKexp :: Env -> Kexp -> ExpCont -> CmdCont + +evalKexp g (KexpVar x) k = evalVal g (ValVar x) k + +evalKexp g (KexpKappa kap) k = evalAbs g (AbsKappa kap) k + +evalAbs :: Env -> Abs -> ExpCont -> CmdCont +evalAbs g (MkAbs formals mtail e) k st = send ab k st' where - arith2 f (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) = - pure1 . ObjImm . ImmInt $ f x y + (st',l) = new' EUnspecified st + ab = EProcedure l \args dps k' -> + tievals args \argLocs -> + let argEnv = zip (formals ++ foldMap (:[]) mtail) argLocs + g' = g <> foldMap (uncurry bind) argEnv + in eval g' dps e k' -eval g e = err [i|unimplemented exp: #{S.encodeOrShow' @Text S.datumIso e}|] +eval :: Env -> DynPoints -> Exp -> ExpCont -> CmdCont -continueWith :: Jalmot :> es => Env -> Kexp -> List Val -> Eff es (List Obj) -continueWith g kexp xs = do - xs' <- traverse (evalVal g) xs - evalKexp g kexp >>= \case - ObjImm (ImmLabel "halt") -> traverse (evalVal g) xs - ObjHob (HobClosure {code,env}) -> eval env' e - where - MkAbs bxs bktail e = code - env' = env & #store <>~ H.fromList (zip bxs xs') +eval g dps (ExpLetRec bs e) k = \st0 -> + let + rhss = bs ^.. each . _2 + (st',ls) = mapAccumR (\st _ -> new st) st0 bs + g' = g & extends (zip (bs ^.. each . _1) ls) + f :: List E -> CmdCont + f = \rhss' -> eval g' dps e k . updates (zip ls rhss') + in telescope (\ab -> evalAbs g' ab . single) rhss f st' -evalKexp :: Jalmot :> es => Env -> Kexp -> Eff es Obj -evalKexp g = \case - KexpVar x -> var g x - KexpKappa kap -> pure . ObjHob $ HobClosure (AbsKappa kap) g +eval g dps (ExpJump f xs ktail) k = + telescope (evalVal1 g) (f:|xs) \(f':|xs') -> + telescope (\ke -> evalKexp g ke . single) (ktail ^.. each) \ktail' -> + case f' of + EProcedure _loc fp -> fp xs' dps k + _ -> wrong "bad procedure" -evalVal - :: Jalmot :> es - => Env -> Val - -> Eff es Obj -evalVal g (ValImm imm) = pure $ ObjImm imm -evalVal g (ValVar x) = var g x +eval g dps (ExpContinue f xs) k = + telescope (evalVal1 g) (f:|xs) \(f':|xs') -> + case f' of + EProcedure _loc fp -> fp xs' dps k + _ -> wrong "bad procedure" -var :: Jalmot :> es => Env -> Name -> Eff es Obj -var _ "halt" = pure . ObjImm . ImmLabel $ "halt" -var g x = case g ^. #store . at x of - Just o -> pure o - Nothing -> err [i|unbound var #{x}|] +eval g dps (ExpApply f xs ktail) k = + telescope (evalVal1 g) (f:|xs) \(f':|xs') -> + evalKexp g ktail . single $ \ktail' -> + case f' of + EProcedure _loc fp -> fp (xs' ++ [ktail']) dps k + _ -> wrong "bad procedure" -evalExp :: Jalmot :> es => Exp -> Eff es (List Obj) -evalExp e = eval emptyEnv e + -evalProgram :: Jalmot :> es => Program -> Eff es (List Obj) -evalProgram (MkProgram lam) = evalExp [cps| - (letrec ((start #{lam})) - (start halt)) -|] +prim_halt :: Procedure +prim_halt xs _dps _k st = AnswerValues st xs -p :: Program -p = [cps| - (λ (ktail) - (continue ktail 123)) -|] +setup :: (Env -> CmdCont) -> CmdCont +setup k = tievals (defs ^.. each) _ + where + defs :: HashMap Name E + defs = + [ ("halt", EProcedure _ prim_halt) + ] -e1 :: Exp -e1 = [cps| - (continue $halt 123) -|] +evalExp :: Jalmot :> es => Exp -> Eff es _ +evalExp e = _ + +evalProgram :: Jalmot :> es => Program -> Eff es (List E) +evalProgram (MkProgram lam) = _ diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index 26b7153..9295205 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -45,6 +45,8 @@ module Gyehoek.CPS.Syntax , pattern MkAbs , _MkAbs , unhoist + , pattern ExpJump + , _ExpJump ) where @@ -146,6 +148,20 @@ pattern MkAbs xs ktail body <- (view _MkAbs -> (xs,ktail,body)) {-# COMPLETE MkAbs #-} +_ExpJump :: Prism' Exp (Val, List Val, Maybe Kexp) +_ExpJump = prism' + (\(f,xs,ktail) -> case ktail of + Just k -> ExpApply f xs k + Nothing -> ExpContinue f xs) + \case + ExpApply f xs ktail -> Just (f,xs,Just ktail) + ExpContinue f xs -> Just (f,xs,Nothing) + _ -> Nothing + +pattern ExpJump :: Val -> List Val -> Maybe Kexp -> Exp +pattern ExpJump f xs ktail <- (preview _ExpJump -> Just (f,xs,ktail)) + where ExpJump f xs ktail = review _ExpJump (f,xs,ktail) + data Exp = ExpPrim (Prim Val) Kexp | ExpLetRec { binders :: List (Name, Abs), body :: Exp } 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 , "" ))