superfuck

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 ()
@@ -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
+newtype Loc = MkLoc { getLoc :: Int }
-  { store :: HashMap Name Obj
+  deriving stock (Generic, Data)
+  deriving newtype (Show, Eq, Ord)
+
+data Store = MkStore
+  { nextLoc :: Loc
+  , heap :: IntMap E
   }
-  deriving stock (Show, Generic, Data, Eq)
+  deriving stock (Show, Generic, Data)
-  deriving (Semigroup, Monoid)
-    via Generically Env
 
-emptyEnv = MkEnv
+newtype Env = MkEnv { getEnv :: HashMap Name Loc }
-  { store = mempty
+  deriving stock (Show, Generic, Data)
-  }
 
-
+type instance Index Env = Name
+type instance IxValue Env = Loc
 
-data Obj
+instance Ixed Env where ix j = #getEnv . ix j
-  = ObjImm Imm
+instance At Env where at j = #getEnv . at j
-  | ObjHob Hob
-  deriving stock (Show, Generic, Data, Eq)
 
--- | a heap object.
+update :: Loc -> E -> Store -> Store
-data Hob
+update (MkLoc loc) v = #heap %~ IM.alter f loc
-  = 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}|]
   where
-    ret1 = continueWith g k . (:[])
+    f (Just _) = Just v
-    arith2 f (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
+    f Nothing = error "segfault lol"
-      ret1 . ObjImm . ImmInt $ f x y
 
-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)
+new :: Store -> Loc
-continueWith g kexp xs =
+new = _
-  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)
 
-evalKexp :: Jalmot :> es => Env -> Kexp -> Eff es Obj
+var :: HasCallStack => Env -> Name -> Loc
-evalKexp g = \case
+var g x = g ^?! ix x
-  KexpVar x -> var g x
-  KexpKappa kap -> pure . ObjHob $ HobClosure (AbsKappa kap) g
 
-evalVal
+type CmdCont = Store -> Answer
-  :: Jalmot :> es
+type ExpCont = List E -> CmdCont
-  => 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
+data Answer
-var _ "halt" = pure . ObjImm . ImmLabel $ "halt"
+  = AnswerValues (List E)
-var g x = case g ^. #store . at x of
+  | AnswerError Text
-  Just o -> pure o
+  deriving (Show, Generic, Data)
-  Nothing -> err [i|unbound var #{x}|]
 
-evalExp :: Jalmot :> es => Exp -> Eff es (List Obj)
+data Mutability
-evalExp e = eval emptyEnv e
+  = Mut
+  | NoMut
+  deriving (Show, Generic, Data, Eq)
 
-evalProgram :: Jalmot :> es => Program -> Eff es (List Obj)
+wrong :: Text -> CmdCont
-evalProgram (MkProgram lam) = evalExp [cps|
+wrong = const . AnswerError
-  (letrec ((start #{lam}))
-    (start halt))
-|]
 
-p :: Program
+single :: (E -> CmdCont) -> ExpCont
-p = [cps|
+single k = \case
-  (λ (ktail)
+  [x] -> k x
-    (continue ktail 123))
+  _ -> wrong "wrong number of return values"
-|]
 
-e1 :: Exp
+send :: E -> ExpCont -> CmdCont
-e1 = [cps|
+send e k = k [e]
-  (continue $halt 123)
+
-|]
+-- | 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) = _

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 }