+135
-143
@@ -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 ()
|
||||
@@ -20,163 +24,151 @@ import GHC.Generics (Generically(..))
|
||||
import Gyehoek.Sexp ((:-)(..))
|
||||
import Data.List (nub)
|
||||
import Data.HashSet.Lens (setOf)
|
||||
import Data.IntMap.Strict (IntMap)
|
||||
import Data.IntMap.Strict qualified as IM
|
||||
|
||||
|
||||
data Env = MkEnv
|
||||
{ store :: HashMap Name Obj
|
||||
newtype Loc = MkLoc { getLoc :: Int }
|
||||
deriving stock (Generic, Data)
|
||||
deriving newtype (Show, Eq, Ord)
|
||||
|
||||
data Store = MkStore
|
||||
{ nextLoc :: Loc
|
||||
, heap :: IntMap E
|
||||
}
|
||||
deriving stock (Show, Generic, Data, Eq)
|
||||
deriving (Semigroup, Monoid)
|
||||
via Generically Env
|
||||
deriving stock (Show, Generic, Data)
|
||||
|
||||
emptyEnv = MkEnv
|
||||
{ store = mempty
|
||||
}
|
||||
newtype Env = MkEnv { getEnv :: HashMap Name Loc }
|
||||
deriving stock (Show, Generic, Data)
|
||||
|
||||
|
||||
type instance Index Env = Name
|
||||
type instance IxValue Env = Loc
|
||||
|
||||
data Obj
|
||||
= ObjImm Imm
|
||||
| ObjHob Hob
|
||||
deriving stock (Show, Generic, Data, Eq)
|
||||
instance Ixed Env where ix j = #getEnv . ix j
|
||||
instance At Env where at j = #getEnv . at j
|
||||
|
||||
-- | a heap object.
|
||||
data Hob
|
||||
= HobClosure { code :: Abs, env :: List Obj }
|
||||
-- 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) (List Obj :- 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) = 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) =<< 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 (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
|
||||
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}|]
|
||||
update :: Loc -> E -> Store -> Store
|
||||
update (MkLoc loc) v = #heap %~ IM.alter f loc
|
||||
where
|
||||
ret1 = continueWith g k . (:[])
|
||||
arith2 f (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
|
||||
ret1 . ObjImm . ImmInt $ f x y
|
||||
f (Just _) = Just v
|
||||
f Nothing = error "segfault lol"
|
||||
|
||||
eval g e = err [i|unimplemented exp: #{S.encodeOrShow' @Text S.datumIso e}|]
|
||||
fetch :: Loc -> Store -> E
|
||||
fetch (MkLoc loc) st = st ^?! #heap . ix loc
|
||||
|
||||
continueWith :: Jalmot :> es => Env -> Kexp -> List Obj -> Eff es (List Obj)
|
||||
continueWith g kexp xs =
|
||||
evalKexp g kexp >>= \case
|
||||
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)
|
||||
new :: Store -> Loc
|
||||
new = _
|
||||
|
||||
evalKexp :: Jalmot :> es => Env -> Kexp -> Eff es Obj
|
||||
evalKexp g = \case
|
||||
KexpVar x -> var g x
|
||||
KexpKappa kap -> pure . ObjHob $ HobClosure (AbsKappa kap) g
|
||||
var :: HasCallStack => Env -> Name -> Loc
|
||||
var g x = g ^?! ix x
|
||||
|
||||
evalVal
|
||||
:: Jalmot :> es
|
||||
=> Env -> Val
|
||||
-> Eff es Obj
|
||||
evalVal g (ValImm imm) = pure $ ObjImm imm
|
||||
evalVal g (ValVar x) = var g x
|
||||
type CmdCont = Store -> Answer
|
||||
type ExpCont = List E -> CmdCont
|
||||
|
||||
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}|]
|
||||
data Answer
|
||||
= AnswerValues (List E)
|
||||
| AnswerError Text
|
||||
deriving (Show, Generic, Data)
|
||||
|
||||
evalExp :: Jalmot :> es => Exp -> Eff es (List Obj)
|
||||
evalExp e = eval emptyEnv e
|
||||
data Mutability
|
||||
= Mut
|
||||
| NoMut
|
||||
deriving (Show, Generic, Data, Eq)
|
||||
|
||||
evalProgram :: Jalmot :> es => Program -> Eff es (List Obj)
|
||||
evalProgram (MkProgram lam) = evalExp [cps|
|
||||
(letrec ((start #{lam}))
|
||||
(start halt))
|
||||
|]
|
||||
wrong :: Text -> CmdCont
|
||||
wrong = const . AnswerError
|
||||
|
||||
p :: Program
|
||||
p = [cps|
|
||||
(λ (ktail)
|
||||
(continue ktail 123))
|
||||
|]
|
||||
single :: (E -> CmdCont) -> ExpCont
|
||||
single k = \case
|
||||
[x] -> k x
|
||||
_ -> wrong "wrong number of return values"
|
||||
|
||||
e1 :: Exp
|
||||
e1 = [cps|
|
||||
(continue $halt 123)
|
||||
|]
|
||||
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
|
||||
|
||||
|
||||
|
||||
-- | 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 (List E -> DynPoints -> ExpCont -> CmdCont)
|
||||
deriving stock (Show, Generic, Data)
|
||||
|
||||
eGrammar :: Store -> S.DatumGrammar E
|
||||
eGrammar st = S.partialOsi (const . Left $ mempty) go
|
||||
where
|
||||
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 "#<undefined>"
|
||||
EUnspecified -> S.Unreadable "#<unspecified>"
|
||||
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 _
|
||||
|
||||
data DynPoints = MkDynPoints
|
||||
deriving (Generic, Data)
|
||||
|
||||
|
||||
|
||||
-- 뻘짓이어라
|
||||
telescope
|
||||
:: Traversable t
|
||||
=> (a -> (b -> r) -> r)
|
||||
-> t a -> (t b -> r) -> r
|
||||
telescope f = Cont.runCont . traverse (Cont.cont . f)
|
||||
|
||||
|
||||
|
||||
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 = _
|
||||
|
||||
eval :: Env -> DynPoints -> Exp -> ExpCont -> CmdCont
|
||||
|
||||
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 (ExpApply f xs ktail) k =
|
||||
telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
|
||||
case f' of
|
||||
EProcedure _loc fp -> fp xs' dps k
|
||||
_ -> wrong "bad procedure"
|
||||
|
||||
|
||||
|
||||
evalExp :: Jalmot :> es => Exp -> Eff es _
|
||||
evalExp e = _
|
||||
|
||||
evalProgram :: Jalmot :> es => Program -> Eff es _
|
||||
evalProgram (MkProgram lam) = _
|
||||
|
||||
@@ -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 }
|
||||
|
||||
Reference in New Issue
Block a user