diff --git a/src/Gyehoek/CPS/Eval.hs b/src/Gyehoek/CPS/Eval.hs index 54e4948..1d780d8 100644 --- a/src/Gyehoek/CPS/Eval.hs +++ b/src/Gyehoek/CPS/Eval.hs @@ -9,24 +9,27 @@ module Gyehoek.CPS.Eval , eGrammar ) where -import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..)) +import Gyehoek.CPS.Syntax hiding (Hob(..), Obj(..), cont) import Gyehoek.Sexp qualified as S -import Control.Lens +import Control.Lens hiding (assign) import Data.Maybe (fromMaybe) import Text.Show.Functions () import qualified Data.HashMap.Strict as H -import Gyehoek.Prelude +import Gyehoek.Prelude hiding (assign) import Debug.Pretty.Simple import Gyehoek.Jalmot -import Control.Monad.Cont qualified as Cont +import Control.Monad.Cont import Gyehoek.Sexp qualified as S import GHC.Generics (Generically(..)) import Gyehoek.Sexp ((:-)(..)) -import Data.List (nub, mapAccumR) +import Data.List (nub, mapAccumR, compareLength) import Data.HashSet.Lens (setOf) import Data.IntMap.Strict (IntMap) import Data.IntMap.Strict qualified as IM import Data.Monoid +import Control.Monad.State +import Data.Traversable (for) +import Data.Foldable (traverse_) newtype Loc = MkLoc { getLoc :: Int } @@ -37,11 +40,17 @@ data Store = MkStore { nextLoc :: Loc , heap :: IntMap E } - deriving stock (Show, Generic, Data) + deriving stock (Show, Generic) + +type instance Index Store = Loc +type instance IxValue Store = E + +instance Ixed Store where ix (MkLoc j) = #heap . ix j +instance At Store where at (MkLoc j) = #heap . at j emptyStore :: Store emptyStore = MkStore - { nextLoc = 0 + { nextLoc = MkLoc 0 , heap = mempty } @@ -67,57 +76,45 @@ update (MkLoc loc) v = #heap %~ IM.alter f loc 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 +fetch :: Loc -> M r E +fetch (MkLoc loc) = gets (^?! #heap . ix loc) -new :: Store -> (Store, Loc) -new st = (st & #nextLoc %~ succ, st.nextLoc) +new :: M r Loc +new = state \st -> (st.nextLoc, st & #nextLoc %~ succ) -new' :: E -> Store -> (Store, Loc) -new' e st = (update l e st', l) - where - (st',l) = new st +new' :: E -> M r Loc +new' e = state \st -> + ( st.nextLoc + , st & #nextLoc %~ succ & at st.nextLoc ?~ e + ) -news' :: Traversable t => t E -> Store -> (Store, Loc) -news' es st = mapAccumR _ st es - where - (st',l) = new st +defines :: Traversable t => t (Name, E) -> M Answer Env +defines = alaf Ap foldMap \(name,e) -> do + l <- new' e + pure $ bind name l -var :: HasCallStack => Env -> Name -> Loc -var g x = g ^?! ix x +var :: HasCallStack => Env -> Name -> M Answer Loc +var g x = case g ^. at x of + Just l -> pure l + Nothing -> wrong [i|unbound variable #{x}|] type CmdCont = Store -> Answer type ExpCont = List E -> CmdCont +type M r = ContT r (State Store) + data Answer - = AnswerValues Store (List E) - | AnswerError Text - deriving (Show, Generic, Data) + = AnswerValues (List E) + | AnswerError AJalmot + deriving (Show, Generic) 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 +wrong :: Text -> M Answer a +wrong s = ContT \_ -> pure . AnswerError . EvalError $ s bind :: Name -> Loc -> Env bind k = MkEnv . H.singleton k @@ -125,13 +122,19 @@ bind k = MkEnv . H.singleton k extends :: Foldable f => f (Name, Loc) -> Env -> Env extends xs g = g <> foldMap (uncurry bind) xs +assign :: Loc -> E -> M Answer () +assign l e = do + use (at l) >>= \case + Just _ -> at l ?= e + Nothing -> wrong [i|#{e}에서 #{l}이라는 주소는 없다|] + -- | The denotation of an expressed value. data E = ESymbol Text | ECharacter Char - | EInteger Int + | EInt Int | EBool Bool | EUndefined | EUnspecified @@ -139,19 +142,19 @@ data E | EPair Loc Loc Mutability | EVec (List Loc) Mutability | EString (List Loc) Mutability - | EProcedure Loc Procedure - deriving stock (Show, Generic, Data) + | EProcedure Procedure + deriving stock (Show, Generic) -type Procedure = List E -> DynPoints -> ExpCont -> CmdCont +type Procedure = List E -> DynPoints -> M Answer (List E) eGrammar :: Store -> S.DatumGrammar E eGrammar st = S.partialOsi (const . Left $ mempty) go where - gofetch x = go $ fetch x st + gofetch x = go $ st ^?! ix x go = \case ESymbol s -> S.Symbol s ECharacter c -> S.Character c - EInteger n -> S.Number (fromIntegral n) + EInt n -> S.Number (fromIntegral n) EBool b -> S.Boolean b EUndefined -> S.Unreadable "#" EUnspecified -> S.Unreadable "#" @@ -165,88 +168,73 @@ data DynPoints = MkDynPoints --- 뻘짓이어라 -telescope - :: Traversable t - => (a -> (b -> r) -> r) - -> t a -> (t b -> r) -> r -telescope f = Cont.runCont . traverse (Cont.cont . f) +evalVal :: Env -> Val -> M Answer E - +evalVal g (ValVar x) = var g x >>= fetch -procedure :: Env -> Procedure -> (E -> CmdCont) -> CmdCont -procedure = _ +evalVal g (ValImm imm) = pure case imm of + ImmInt n -> EInt n + ImmBool b -> EBool b + ImmUndefined -> EUndefined -evalVal :: Env -> Val -> ExpCont -> CmdCont -evalVal g (ValVar x) k = hold (var g x) $ single \case - EUndefined -> wrong "undefined variable" - e -> send e k +evalKexp :: Env -> Kexp -> M Answer E +evalKexp g (KexpVar x) = var g x >>= fetch +evalKexp g (KexpKappa kap) = evalAbs g (AbsKappa kap) -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 - (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 :: Env -> DynPoints -> Exp -> ExpCont -> CmdCont - -eval g dps (ExpLetRec bs e) k = \st0 -> +evalAbs :: Env -> Abs -> M Answer E +evalAbs g (MkAbs formals ktail e) = pure . EProcedure $ \xs dps -> 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' + formals' = formals ++ foldMap (:[]) ktail + lformals = length formals' + lxs = length xs + in if lformals /= lxs + then wrong [i|함수는 #{lformals}개의 인자를 필요로 하는데 #{lxs}개 받았다.|] + else do + ls <- xs & traverse new' + let g' = g & extends (zip formals' ls) + eval g' dps e -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" +eval :: Env -> DynPoints -> Exp -> M Answer (List E) -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" +eval g dps (ExpJump f xs ktail) = do + f' <- evalVal g f + xs' <- traverse (evalVal g) xs + ktail' <- traverse (evalKexp g) (ktail ^.. _Just) + case f' of + EProcedure p -> p (xs' ++ ktail') dps + _ -> wrong "bad procedure" -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" +eval g dps (ExpLetRec bs e) = do + ls <- for bs . const $ new' EUndefined + let g' = g & extends (zip (bs ^.. each . _1) ls) + bs' <- forOf (each . _2) bs (evalAbs g') + traverse_ (uncurry assign) $ zip ls (bs' ^.. each . _2) + eval g' dps e + +eval g dps e = error [i|unimplemented #{e}|] -prim_halt :: Procedure -prim_halt xs _dps _k st = AnswerValues st xs - -setup :: (Env -> CmdCont) -> CmdCont -setup k = tievals (defs ^.. each) _ - where - defs :: HashMap Name E - defs = - [ ("halt", EProcedure _ prim_halt) - ] - evalExp :: Jalmot :> es => Exp -> Eff es _ evalExp e = _ -evalProgram :: Jalmot :> es => Program -> Eff es (List E) -evalProgram (MkProgram lam) = _ +evalProgram :: Jalmot :> es => Program -> Eff es (List S.Datum) +evalProgram (MkProgram lam) = case run (pure . AnswerValues) of + (AnswerError jm, _) -> throwError jm + (AnswerValues vs, st) -> traverse (S.toDatum $ eGrammar st) vs + where + run f = (`runState` emptyStore) . (`runContT` f) $ do + g <- setup + eval g MkDynPoints (ExpLetRec + [("_start",AbsLambda lam)] + (ExpApply (ValVar "_start") [] (KexpVar "halt"))) + + + +setup :: M Answer Env +setup = defines @List + [ ("halt", EProcedure prim_halt) + ] + +prim_halt :: Procedure +prim_halt xs _dps = ContT \_ -> pure $ AnswerValues xs diff --git a/src/Gyehoek/Jalmot.hs b/src/Gyehoek/Jalmot.hs index 9a86df6..3936a88 100644 --- a/src/Gyehoek/Jalmot.hs +++ b/src/Gyehoek/Jalmot.hs @@ -31,6 +31,7 @@ data AJalmot = ReaderError (ParseErrorBundle Text Void) | GrammarError (Grammar.ErrorMessage Ann) | VMError Text + | EvalError Text deriving (Show, Generic, Data) data AJalmotCS = MkAJalmotCS !CallStack !AJalmot @@ -66,6 +67,7 @@ instance Exception AJalmot where & layoutPretty defaultLayoutOptions & renderString VMError err -> [i|#{err}|] + EvalError err -> [i|#{err}|] instance Exception AJalmotCS where backtraceDesired = const False