148 lines
3.4 KiB
Haskell
148 lines
3.4 KiB
Haskell
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
module Gyehoek.CPS.Eval
|
|
( evalProgram
|
|
, module Gyehoek.CPS.Syntax
|
|
, evalExp
|
|
) where
|
|
|
|
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
|
|
{ store :: HashMap Name Obj
|
|
}
|
|
deriving stock (Show, Generic, Data, Eq)
|
|
deriving (Semigroup, Monoid)
|
|
via Generically Env
|
|
|
|
emptyEnv = MkEnv
|
|
{ store = mempty
|
|
}
|
|
|
|
|
|
|
|
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|\#<procedure>|] :- 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)
|
|
|]
|