ughhh evaluate cps

golden/exec/lit-int/source.scm

@@ -0,0 +1 @@
+123

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
+  { store :: HashMap Name Obj
-  , labels :: HashMap Name (Env, Abs)
   }
-  deriving (Show, Generic)
+  deriving stock (Show, Generic, Data, Eq)
+  deriving (Semigroup, Monoid)
+    via Generically Env
 
-eval :: Env -> Exp -> List Obj
+emptyEnv = MkEnv
-eval = _
+  { store = mempty
+  }
 
-evalExp :: Exp -> List Obj
+
-evalExp = _
 
-evalProgram :: Program -> List Obj
+data Obj
-evalProgram (MkProgram lam) = eval emptyEnv [cps|
+  = 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)
+|]

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))
+pattern MkAbs xs ktail body <- (view _MkAbs -> (xs,ktail,body))
-  where MkAbs xs ktail body = review _Abs' (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
 

src/Gyehoek/Driver.hs

@@ -138,10 +138,9 @@ driver opts = do
          >>> T.unwords
          >>> hPutStrLn FS.stdout)
   when (rt_is #CPS) do
-    closedCps
+    CPS.evalProgram closedCps
-      & CPS.evalProgram
+      >>= S.encodeDataWith S.dataIso
-      & S.encodeDataWith S.dataIso
+      >>= hPutStrLn FS.stdout
-      & hPutStrLn FS.stdout
   -- dumpOrRun opts.inspectWasm (rt_is #Wasm)
   --   (lowerProgram cps)
   --   inspectWasm