wip: abstract stack/continuation machine

src/Gyehoek/CPS/Convert.hs

@@ -2,6 +2,7 @@
 {- HLINT ignore "Use camelCase" -}
 module Gyehoek.CPS.Convert
   ( convertProgram
+  , convertExp
   ) where
 
 import Gyehoek.CPS.Syntax
@@ -79,7 +80,6 @@ convert (Scm.ExpLet bs e) k =
         (continue #{kbody} ##{rhss'}))
     |]
 
-
 convert _ k = _
 
 convertProgram :: forall es. (GenSym :> es) => Scm.Program -> Eff es Program
@@ -88,3 +88,6 @@ convertProgram p =
     pure . Halt1 $ case NE.nonEmpty exps of
       Nothing -> ValLit Void
       Just es -> NE.last es
+
+convertExp :: forall es. (GenSym :> es) => Scm.Exp -> Eff es Exp
+convertExp e = convert e (pure . Halt1)

src/Gyehoek/CPS/Syntax.hs

@@ -309,32 +309,53 @@ instance Vars Exp where
 
 
 data Scope
-  = Bind (List Name) Scope
-  | Use (List Name) Scope
-  | Leaf
+  = Bind (List Name) (List Scope)
+  | Use (List Name) (List Scope)
   deriving (Show, Eq)
 
 makeBaseFunctor ''Scope
 
-class Subst a where
-  substWith :: (Name -> Val) -> a -> a
-
-instance Subst Exp where
-  substWith sub = cata \e ->
-    _
-
 class Scoped a where
   scope :: a -> Scope
 
 instance Scoped Kappa where
   scope (MkKappa bs e) =
-    Bind bs (scope e)
+    Bind bs [scope e]
+
+instance Scoped Lambda where
+  scope (MkLambda bs k e) = Bind (bs ++ [k]) [scope e]
+
+instance Scoped Abs where
+  scope = \case
+    AbsKappa k -> scope k
+    AbsLambda l -> scope l
 
 instance Scoped Val where
   scope = \case
-    ValVar x -> Use [x] Leaf
-    _ -> Leaf
+    ValVar x -> Use [x] []
+    _ -> Use [] []
 
 instance Scoped Exp where
   scope = \case
-    ExpApply f xs k = _
+    ExpApply f xs k ->
+      Use (((f:xs) ^.. each . _ValVar) ++ [k]) []
+    ExpLetRec bs e ->
+      Bind (bs ^.. each . _1) $
+        (bs ^.. each . _2 . to scope)
+        ++ [scope e]
+    ExpPrim p k ->
+      Use (p ^.. each . _ValVar) [scope k]
+    ExpContinue k xs ->
+      Use (k : (xs ^.. each . _ValVar)) []
+    ExpIf c t f ->
+      Use (c ^.. _ValVar) [ scope t, scope f ]
+
+
+
+class Subst a where
+  substWith :: (Name -> Maybe Val) -> a -> a
+
+instance Subst Exp where
+  substWith f = go HS.empty where
+    go bound e = case scope e of
+      Use xs ss -> _

src/Gyehoek/Scheme/Syntax.hs

@@ -23,6 +23,8 @@ module Gyehoek.Scheme.Syntax
   , subst
   , getName
   , scm
+  , readExp
+  , readProgram
   )
   where
 
@@ -33,6 +35,7 @@ import Language.SexpGrammar
 import Language.SexpGrammar qualified as Sexp
 import Language.Sexp.Located qualified as S
 import Language.SexpGrammar.Generic
+import Effectful
 import GHC.Generics
 import Prelude hiding ((.), id)
 import Control.Category
@@ -49,6 +52,10 @@ import Data.HashSet (HashSet)
 import qualified Data.HashSet as HS
 import Data.Foldable (fold)
 import Language.Haskell.TH.Quote (QuasiQuoter)
+import Effectful.FileSystem (runFileSystem)
+import qualified Effectful.FileSystem.IO as FS
+import qualified Data.Text.Encoding as T
+import qualified Effectful.FileSystem.IO.ByteString as FB
 
 
 newtype Name = MkName { inner :: Text }
@@ -72,7 +79,8 @@ data Prim e
   | PrimWrite e
   | PrimZeroP e
   | PrimNewline
-  | PrimMakeClosure { code :: e, upvals :: List e }
+  | PrimMakeClosure { code :: e, env :: List e }
+  | PriEnvRef e Int
   deriving (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
 
 instance Each (Prim e) (Prim e') e e'
@@ -157,6 +165,7 @@ primSexpIso namefn a = match
     $ With (. unop "zero?")
     $ With (. nullop "newline")
     $ With (. mkclosure)
+    $ With (. envref)
     $ End
     where
       idn s = el (sym (namefn s))
@@ -164,6 +173,7 @@ primSexpIso namefn a = match
       unop s = list $ idn s >>> el a
       binop s = list $ idn s >>> el a >>> el a
       mkclosure = list $ idn "make-closure" >>> el a >>> rest a
+      envref = list $ idn "env-ref" >>> el a >>> el Sexp.int
 
 instance SexpIso a => SexpIso (Prim a) where
   -- sexpIso = primSexpIso ("prim:"<>) sexpIso
@@ -259,3 +269,22 @@ subst f = \e -> cata go e mempty where
   go (ExpLetF _ _) _ = error "todo lol"
   go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
   go e bound = embed $ fmap ($ bound) e
+
+
+
+fileName :: FilePath -> FilePath
+fileName "-" = "<interactive>"
+fileName e = e
+
+hGetContents :: FS.FileSystem :> es => FS.Handle -> Eff es Text
+hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
+
+readProgram :: IOE :> es => FilePath -> Eff es Program
+readProgram fp = runFileSystem $
+  FS.withFile fp FS.ReadMode $ \h ->
+    Gyehoek.Sexp.parseSexps @CommandOrDef (fileName fp) <$> hGetContents h
+     >>= either error (pure . MkProgram)
+
+readExp :: IOE :> es => FilePath -> Eff es Program
+readExp fp = readProgram fp <&>
+  (^?! (#commandsAndDefs . _head . _Comm))

src/Gyehoek/Sexp.hs

@@ -38,10 +38,12 @@ module Gyehoek.Sexp
   , makeSx'
   , toSexp
   , fromSexp
+  , fromSexp'
   , stripLocation
   , format
   , equivalent
   , encodeOrShow
+  , readSxs
   )
   where
 
@@ -87,6 +89,10 @@ import qualified Data.Vector as V
 import qualified Data.Vector.Strict
 import Data.Function (on)
 import Data.String (IsString (fromString))
+import Effectful
+import qualified Effectful.FileSystem.IO as FS
+import qualified Effectful.FileSystem.IO.ByteString as FB
+import qualified Data.Text.Encoding as T
 
 
 sexp :: SexpIso a => Iso' a Text
@@ -120,6 +126,10 @@ parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
 parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8
   where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp sexpIso)
 
+parseSexpsWith :: SexpGrammar a -> FilePath -> Text -> Either String (List a)
+parseSexpsWith g f = marshal . SL.parseSexps f . view lazy . encodeUtf8
+  where marshal = join . traverseOf (_Right . each) (Sexp.fromSexp g)
+
 parseSexp :: SexpIso a => FilePath -> Text -> Either String a
 parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8
   where marshal = join . traverseOf _Right (Sexp.fromSexp sexpIso)
@@ -140,6 +150,24 @@ parseSexpWithPos g pos =
   marshal . SL.parseSexpWithPos pos . view lazy . encodeUtf8
   where marshal = join . traverseOf _Right (Sexp.fromSexp g)
 
+fileName :: FilePath -> FilePath
+fileName "-" = "<interactive>"
+fileName e = e
+
+hGetContents :: FS.FileSystem :> es => FS.Handle -> Eff es Text
+hGetContents h = T.decodeUtf8 <$> FB.hGetContents h
+
+readSxs
+  :: IOE :> es
+  => SexpGrammar a
+  -> FilePath -> Eff es (List a)
+readSxs g fp = FS.runFileSystem $
+  FS.withFile fp FS.ReadMode $ \h ->
+    parseSexpsWith g (fileName fp) <$> hGetContents h
+     >>= either error pure
+
+
+
 nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
 nonEmptyGrammar = IGB.Iso
   (\((x:|xs) :- t) -> reverse xs :- x :- t)

src/Gyehoek/Stack/Syntax.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module Gyehoek.Stack.Syntax
+  ( Program(..)
+  , Block(..)
+  , Instr(..)
+  , Val(..)
+  , Lit(..)
+  , Obj(..)
+  , Imm(..)
+  , Prim(..)
+  , Name
+  ) where
+
+import Control.Lens
+import Data.List (List)
+import GHC.Generics (Generic)
+import Data.HashMap.Strict (HashMap)
+import Language.SexpGrammar (SexpIso, (>>>), (:-))
+import Language.SexpGrammar qualified as S
+import Language.SexpGrammar.Generic
+import Data.Coerce (coerce)
+import Data.Text (Text)
+import qualified Gyehoek.Sexp
+import Language.Haskell.TH.Quote (QuasiQuoter)
+import Data.Data (Data)
+import qualified Data.HashMap.Strict as H
+import Effectful
+import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..))
+
+
+newtype Program = MkProgram
+  { blocks :: List Block
+  }
+  deriving stock (Show, Generic, Data)
+
+data Block = MkBlock
+  { label :: Name
+  , params :: List Name
+  , code :: List Instr
+  }
+  deriving stock (Show, Generic, Data)
+
+instance Each Block Block Instr Instr where
+  each = #code . each
+
+data Instr
+  = Pop Name
+  | Push Val
+  | PopCont Name
+  | PushCont Name
+  | Prim Name (Prim Val)
+  | CallLabel Name (List Val)
+  | CallReg Name (List Val)
+  deriving stock (Show, Generic, Data)
+
+data Val
+  = ValLabel Name
+  | ValReg Name
+  | ValImm Imm
+  deriving stock (Show, Generic, Data, Eq)
+
+data Imm
+  = ImmInt Int
+  | ImmBool Bool
+  deriving stock (Show, Generic, Data, Eq)
+
+data Obj
+  = ObjImm Imm
+  | ObjLabel Name
+  deriving (Show, Generic, Data, Eq)

src/Gyehoek/Stack/VM.hs

@@ -0,0 +1,110 @@
+module Gyehoek.Stack.VM
+  ( VM(..)
+  , Env(..)
+  , eval
+  ) where
+
+import Gyehoek.Stack.Syntax
+import Data.List (List)
+import GHC.Generics (Generic)
+import Control.Lens
+import Data.HashMap.Strict (HashMap)
+import Data.Text (Text)
+import qualified Data.HashMap.Strict as H
+import Data.String.Interpolate (i)
+import Gyehoek.Scheme.Syntax (Sexp(..))
+
+
+data VM = MkVM
+  { stack :: List Obj
+  , kstack :: List Name
+  , code :: List Instr
+  , registers :: HashMap Name Obj
+  , stdout :: Text
+  , result :: Maybe (List Obj)
+  }
+  deriving (Show, Generic)
+
+data Env = MkEnv
+  { blocks :: HashMap Name Block
+  }
+  deriving (Show, Generic)
+
+step :: Env -> VM -> VM
+step e vm = case vm ^. #code of
+  c:cs -> stepI e (vm & #code .~ cs) c
+  _ -> error "halt never called"
+
+stepI :: Env -> VM -> Instr -> VM
+
+stepI e vm (Push v) = vm & #stack %~ (evalVal e vm v :)
+
+stepI e vm (PushCont k) = vm & #kstack %~ (k:)
+
+stepI e vm (Prim r p) = case evalVal e vm <$> p of
+  PrimAdd x y -> arith_binop (+) x y
+  PrimMul x y -> arith_binop (*) x y
+  PrimSub x y -> arith_binop (-) x y
+  PrimDiv x y -> arith_binop div x y
+  x -> error [i|unimplemented prim: #{p}|]
+  where
+    arith_binop op (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
+      vm & #registers . at r ?~ ObjImm (ImmInt (op x y))
+    arith_binop _ x y = error [i|bad arith: #{x}, #{y}|]
+
+stepI e vm (Pop r) = case vm ^. #stack of
+  [] -> error "empty stack"
+  (x:xs) -> vm & #registers . at r ?~ x
+               & #stack .~ xs
+
+stepI e vm (PopCont r) = case vm ^. #kstack of
+  [] -> error "empty stack"
+  (x:xs) -> vm & #registers . at r ?~ ObjLabel x
+               & #kstack .~ xs
+
+stepI e vm (CallReg r xs) = stepI e vm (CallLabel l xs)
+  where l = vm ^?! #registers . at r . _Just . #ObjLabel
+
+stepI e vm (CallLabel "halt" xs) = vm & #result ?~ fmap (evalVal e vm) xs
+
+stepI e vm (CallLabel l xs) =
+  vm & #code .~ b.code
+     & #registers .~ fmap (evalVal e vm) (H.fromList $ b.params `zip` xs)
+  where
+    b = case e ^. #blocks . at l of
+      Just x -> x
+      Nothing -> error [i|undefined label: #{l}|]
+
+stepI e vm _ = _
+
+evalVal :: Env -> VM -> Val -> Obj
+evalVal e vm = \case
+  ValImm imm -> ObjImm imm
+  ValReg r -> case vm ^. #registers . at r of
+    Just x -> x
+    Nothing -> error [i|undefined register: #{r}|]
+
+initialVM :: VM
+initialVM = MkVM
+  { stack = []
+  , kstack = ["halt"]
+  , code = [CallLabel "main" []]
+  , registers = mempty
+  , stdout = ""
+  , result = Nothing
+  }
+
+initialEnv :: Program -> Env
+initialEnv (MkProgram bs) = MkEnv
+  { blocks = bs & foldMap \b -> H.singleton b.label b
+  }
+
+loop :: (a -> Either b a) -> a -> b
+loop f a = case f a of
+  Right a' -> loop f a'
+  Left b -> b
+
+eval :: Program -> List Obj
+eval p = initialVM & loop \vm -> case vm ^. #result of
+  Nothing -> Right $ step (initialEnv p) vm
+  Just rs -> Left rs