From 45ec076dc07d6ab17dbcda28a5bd5f89949da590 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Thu, 3 Sep 2026 12:03:39 -0600 Subject: [PATCH] ughhh evaluate cps --- golden/exec/lit-int/source.scm | 1 + src/Gyehoek/CPS/Eval.hs | 134 ++++++++++++++++++++++++++++++--- src/Gyehoek/CPS/Syntax.hs | 12 ++- src/Gyehoek/Driver.hs | 7 +- 4 files changed, 138 insertions(+), 16 deletions(-) create mode 100644 golden/exec/lit-int/source.scm diff --git a/golden/exec/lit-int/source.scm b/golden/exec/lit-int/source.scm new file mode 100644 index 0000000..190a180 --- /dev/null +++ b/golden/exec/lit-int/source.scm @@ -0,0 +1 @@ +123 diff --git a/src/Gyehoek/CPS/Eval.hs b/src/Gyehoek/CPS/Eval.hs index 9ec7298..33ca68c 100644 --- a/src/Gyehoek/CPS/Eval.hs +++ b/src/Gyehoek/CPS/Eval.hs @@ -1,33 +1,147 @@ {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} module Gyehoek.CPS.Eval ( evalProgram , module Gyehoek.CPS.Syntax , evalExp ) where -import Gyehoek.CPS.Syntax +import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..)) import Control.Lens import Data.Maybe (fromMaybe) import Text.Show.Functions () import qualified Data.HashMap.Strict as H import Gyehoek.Prelude import Debug.Pretty.Simple +import Gyehoek.Jalmot +import Control.Monad.Cont qualified as Cont +import Gyehoek.Sexp qualified as S +import GHC.Generics (Generically(..)) +import Gyehoek.Sexp ((:-)(..)) data Env = MkEnv - { vars :: HashMap Name Obj - , labels :: HashMap Name (Env, Abs) + { store :: HashMap Name Obj } - deriving (Show, Generic) + deriving stock (Show, Generic, Data, Eq) + deriving (Semigroup, Monoid) + via Generically Env -eval :: Env -> Exp -> List Obj -eval = _ +emptyEnv = MkEnv + { store = mempty + } -evalExp :: Exp -> List Obj -evalExp = _ + -evalProgram :: Program -> List Obj -evalProgram (MkProgram lam) = eval emptyEnv [cps| +data Obj + = ObjImm Imm + | ObjHob Hob + deriving stock (Show, Generic, Data, Eq) + +-- | 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) + +instance S.DatumIso Obj where + datumIso = S.match + $ S.With (S.datumIso @Imm >>>) + $ S.With (S.datumIso @Hob >>>) + $ S.End + +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) + + + +err :: Jalmot :> es => Text -> Eff es a +err = throwError . VMError + +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}|] + +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 + where + g' = g <> foldMap + (\(f,ab) -> mempty & #store . at f ?~ + ObjHob (HobClosure ab g')) + bs + +eval g (Halt rs) = traverse (evalVal g) rs + +eval g (ExpContinue k xs) = evalVal g k >>= \case + ObjImm (ImmLabel "halt") -> traverse (evalVal g) 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 + +eval g e = err [i|unimplemented exp: #{S.encodeOrShow' @Text S.datumIso e}|] + +evalKexp :: Jalmot :> es => Env -> Kexp -> Eff es Obj +evalKexp g = \case + KexpVar x -> var g x + KexpKappa kap -> _ + +evalVal + :: Jalmot :> es + => Env -> Val + -> Eff es Obj +evalVal g (ValImm imm) = pure $ ObjImm imm +evalVal g (ValVar x) = var g x + +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}|] + +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)) |] + +p :: Program +p = [cps| + (λ (ktail) + (continue ktail 123)) +|] + +e1 :: Exp +e1 = [cps| + (continue $halt 123) +|] diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index 93b595c..26b7153 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -44,6 +44,7 @@ module Gyehoek.CPS.Syntax , absBody , pattern MkAbs , _MkAbs + , unhoist ) where @@ -64,6 +65,7 @@ import Data.String (IsString) import Control.Applicative import qualified Data.HashMap.Strict as H import GHC.Records (HasField (..)) +import Data.Bifunctor -- Data types @@ -139,8 +141,8 @@ _MkAbs = iso Nothing -> AbsKappa' xs e) pattern MkAbs :: List Name -> Maybe Name -> Exp -> Abs -pattern MkAbs xs ktail body <- (view _Abs' -> (xs,ktail,body)) - where MkAbs xs ktail body = review _Abs' (xs,ktail,body) +pattern MkAbs xs ktail body <- (view _MkAbs -> (xs,ktail,body)) + where MkAbs xs ktail body = review _MkAbs (xs,ktail,body) {-# COMPLETE MkAbs #-} @@ -223,6 +225,12 @@ absBody = lens (AbsLambda lam) b -> AbsLambda $ lam & #body .~ b (AbsKappa kap) b -> AbsKappa $ kap & #body .~ b) +unhoist :: HoistedProgram -> Program +unhoist p = + MkProgram $ p.body & body %~ ExpLetRec + (p ^.. #bindings . itraversed . withIndex + . to (\(MkLabel l, ab) -> (l,ab))) + -- DatumIso instances diff --git a/src/Gyehoek/Driver.hs b/src/Gyehoek/Driver.hs index 88dd873..0b4f0cc 100644 --- a/src/Gyehoek/Driver.hs +++ b/src/Gyehoek/Driver.hs @@ -138,10 +138,9 @@ driver opts = do >>> T.unwords >>> hPutStrLn FS.stdout) when (rt_is #CPS) do - closedCps - & CPS.evalProgram - & S.encodeDataWith S.dataIso - & hPutStrLn FS.stdout + CPS.evalProgram closedCps + >>= S.encodeDataWith S.dataIso + >>= hPutStrLn FS.stdout -- dumpOrRun opts.inspectWasm (rt_is #Wasm) -- (lowerProgram cps) -- inspectWasm