cli, cps interpreter, stack vm, closure-conversion, fixes, tests, LOL

.dir-locals.el

@@ -4,4 +4,6 @@
                  (haskell-mode-buffer-apply-command "cabal-fmt"))
                (add-hook 'before-save-hook #'apply-cabal-fmt-h nil t)
                (add-to-list 'haskell-font-lock-quasi-quote-modes
-                            '("cps" . scheme-mode)))))))
+                            '("cps" . scheme-mode))
+               (add-to-list 'haskell-font-lock-quasi-quote-modes
+                            '("scm" . scheme-mode)))))))

doc/closure-conversion.org

@@ -2,8 +2,59 @@
 
 the closure-conversion phase makes closed-over variables explicit by addition of the primitive ~make-closure~, taking a code pointer (in the CPS language, bare lambda) and the environment.
 
+nice testable properties of closure-converted code:
+- code pointers only appear in function position
+- no function has free variables
+
+multiple ~env-ref~ calls could probably be replaced with a primitive that loads the entire environment at once, returning multiple variables.
+
 * scratchpad
 
+** example
+
+#+caption: scheme source
+#+begin_src scheme
+  (letrec ((curried-add (λ (n)
+                          (λ (m)
+                            (+ n m)))))
+    ((curried-add 3) 4))
+#+end_src
+
+#+caption: cps
+#+begin_src scheme
+  (letrec ((curried-add
+            (λ (n ktail0)
+              (letrec ((curried-add-in
+                        (λ (m ktail1)
+                          (prim (+ n m)
+                                (κ (x0) (continue ktail1 x0))))))
+                (continue ktail0 curried-add-in)))))
+    (letrec ((k0 (κ (adder) (adder 4 halt))))
+      (curried-add 3 k0)))
+#+end_src
+
+#+caption: closure-converted
+#+begin_src scheme
+  (letrec ((curried-add
+            (λ (n ktail0)
+              (letrec ((curried-add-in-code
+                        (λ (env m ktail1)
+                          (prim (env-ref 0 env)
+                                (κ (n)
+                                   (prim (+ n m)
+                                         (κ (x0) (continue ktail1 x0))))))))
+                (prim (make-closure curried-add-in-code n)
+                      (κ (curried-add-in)
+                         (continue ktail0 curried-add-in)))))))
+    (letrec ((k0 (κ (adder-closure)
+                    (prim (closure-code adder-closure)
+                          (κ (adder)
+                             (adder adder-closure 4 halt))))))
+      (curried-add 3 k0)))
+#+end_src
+
+** wasm
+
 #+begin_src scheme
 (letrec ((make-adder
         (lambda (n)

golden/adder/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 9

golden/callcc-nested1/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 456

golden/let-fn/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 16

golden/letrec-fn/exec

@@ -0,0 +1,2 @@
+ret > ExitSuccess
+out > 16

golden/letrec-fn/source.scm

@@ -0,0 +1,2 @@
+(letrec ((square (λ (x) (* x x))))
+  (square 4))

gyehoek.cabal

@@ -54,6 +54,7 @@ library
   exposed-modules:
     Gyehoek.CPS.Close
     Gyehoek.CPS.Convert
+    Gyehoek.CPS.Eval
     Gyehoek.CPS.Lower
     Gyehoek.CPS.Stackify
     Gyehoek.CPS.Syntax
@@ -83,6 +84,7 @@ library
     , megaparsec
     , mtl
     , optparse-applicative
+    , ordered-containers
     , pretty-simple
     , prettyprinter
     , process
@@ -105,9 +107,11 @@ test-suite test
   hs-source-dirs:   test
   main-is:          Main.hs
   other-modules:
+    Gyehoek.Test.CPS.Eval
     Gyehoek.Test.CPS.Stackify
     Gyehoek.Test.CPS.Syntax
     Gyehoek.Test.Golden
+    Gyehoek.Test.Scheme.Syntax
     Gyehoek.Test.Sexp
     Gyehoek.Test.Stack.VM
 

src/Gyehoek/CPS/Close.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedLists #-}
 module Gyehoek.CPS.Close
   ( closeProgram
   ) where
@@ -9,6 +10,12 @@ import Control.Monad ((>=>))
 import Control.Lens
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.HashSet as HS
+import qualified Data.Set.Ordered as O
+import Data.Set.Ordered (OSet)
+import Gyehoek.GenSym
+import Data.String.Interpolate (i)
+import Debug.Pretty.Simple
+import Data.HashSet (HashSet)
 
 
 cataM
@@ -16,14 +23,77 @@ cataM
   => (Base t a -> m a) -> t -> m a
 cataM f = cata (sequenceA >=> f)
 
-close :: Exp -> Exp
-close = cata \case
-  ExpLetRecF {bindersF,bodyF} -> ExpLetRec binders bodyF
-    where
-      binders = bindersF & (each . _2 . _AbsLambda' . _3) %~ \e -> _
-  e -> embed e
+close :: GenSym :> es => Exp -> Eff es Exp
 
-        -- let frees = freeWithBound' (HS.fromList $ ktail : bs) e'
+close = transformM \case
 
-closeProgram :: Program -> Eff es Program
-closeProgram (MkProgram e) = pure . MkProgram . close $ e
+  ExpLetRec [(f, AbsLambda lam@(MkLambda bs kb m))] e -> do
+    f_code <- gensym' @Name $ f ^. _Wrapped'. to (<> "-code")
+    -- it would probably be most sane to generate a symbol for `env`,
+    -- but we're reusing the lambda binding for the sake of recursive
+    -- reverences.
+    -- env <- gensym' @Name "env"
+    let frees = freeWithBound' [f] lam
+    let m' = ifoldr
+             (\n x q -> [cps|(prim (env-ref #{f} #{n})
+                                (κ (#{x}) #{q}))|])
+             m frees
+    pure [cps|
+      (letrec ((#{f_code} (λ (#{f} ##{bs} #{kb})
+                            #{m'})))
+        (prim (make-closure ($ #{f_code}) ##{frees})
+          (κ (#{f}) #{e})))
+    |]
+
+  ExpApply f xs ktail -> do
+    code <- gensym' @Name "code"
+    pure [cps|
+      (prim (env-code #{f})
+        (κ (#{code})
+          (#{code} #{f} ##{xs} #{ktail})))
+    |]
+
+  e -> pure e
+
+  e -> error [i|unimplemented case: #{e}|]
+
+  -- lam@(ExpLambdaF bs m) -> do
+  --   env <- gensym' @Name "env"
+  --   let upvalBinds = free' (embed lam)
+  --         & itraversed %@~ \i x -> (x, [cps|(env-ref #{env} #{i})|])
+  --   let upvals = upvalBinds ^.. each . _1
+  --   pure [cps|
+  --     (make-closure (λ (#{env} ##{bs})
+  --                     (let #{upvalBinds}
+  --                       #{m}))
+  --                   ##{upvals})
+  --    |]
+  -- ExpApplyF f xs ->
+  --   pure [scm|
+  --     (apply-closure #{f} ##{xs})
+  --   |]
+
+closeProgram :: GenSym :> es => Program -> Eff es Program
+closeProgram = traverseOf #body close
+
+curriedadd :: Program
+curriedadd = [cps|
+  (letrec ((curried-add
+            (λ (n ktail1)
+              (letrec ((curried-add-in
+                        (λ (m ktail2)
+                          (prim (+ n m)
+                                (κ (x0) (continue ktail2 x0))))))
+                (continue ktail1 curried-add-in)))))
+    (letrec ((k0 (κ (adder) (adder 4 halt))))
+      (curried-add 5 k0)))
+|]
+
+square :: Program
+square = [cps|
+(letrec ((lambda-body0 (λ (x lambda-tail1)
+                (prim (* x x) (κ (r2) (continue lambda-tail1 r2))))))
+  (letrec
+    ((r3 (κ (x4) (continue halt x4))))
+    (lambda-body0 5 r3)))
+|]

src/Gyehoek/CPS/Convert.hs

@@ -18,6 +18,7 @@ import Data.String.Interpolate (i)
 import Data.Functor (unzip)
 import Data.List (List)
 import Prelude hiding (unzip)
+import Debug.Pretty.Simple (pTraceShowMForceColor)
 
 
 -- 뻘짓이어라
@@ -64,7 +65,7 @@ convert (Scm.ExpPrim p) k =
     ExpPrim p' . MkKappa [r] <$> k (ValVar r)
 
 convert (Scm.ExpLambda xs e) k = do
-  f <- gensym' "λ-body"
+  f <- gensym' "lambda-body"
   lam <- convertLambda xs e
   ke <- k $ ValVar f
   pure [cps|
@@ -92,7 +93,7 @@ convert (Scm.ExpLet bs e) k =
   let rhss = bs ^.. each . _2
   in telescope (convert @es) rhss \rhss' -> do
     e' <- convert e k
-    kbody <- gensym' @Name "letrec-body"
+    kbody <- gensym' @Name "let-body"
     let bs' = bs ^.. each . _1
     pure [cps|
       (letrec ((#{kbody} (κ #{bs'} #{e'})))

src/Gyehoek/CPS/Eval.hs

@@ -0,0 +1,107 @@
+{-# LANGUAGE ViewPatterns #-}
+module Gyehoek.CPS.Eval
+  ( evalProgram
+  , module Gyehoek.CPS.Syntax
+  ) where
+
+import Gyehoek.CPS.Syntax
+import Data.String.Interpolate (i)
+import Data.HashMap.Strict (HashMap)
+import Control.Lens
+import Data.Maybe (fromMaybe)
+import Data.Generics.Labels ()
+import GHC.Generics (Generic)
+import Data.List (List)
+import Text.Show.Functions ()
+import qualified Data.HashMap.Strict as H
+import Debug.Pretty.Simple (pTraceShowId)
+import qualified Data.Text as T
+
+
+data Code
+  = CodeKap (List Obj -> List Obj)
+  | CodeLam (List Obj -> Name -> List Obj)
+  deriving (Show, Generic)
+
+data Env = MkEnv
+  { vars :: HashMap Name Obj
+  , labels :: HashMap Name (Env, Abs)
+  }
+  deriving (Show, Generic)
+
+eval :: Env -> Exp -> List Obj
+
+eval g (Halt xs) = evalVal g <$> xs
+
+eval g (ExpContinue k xs) =
+  case g ^. #labels . at k of
+    Just (h, AbsKappa' bs m) -> eval h' m
+      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
+    _ -> error [i|not a kappa: #{k}|]
+
+eval g (ExpApply ((^?! #ValVar) -> f) xs ktail) =
+  case g ^?! #labels . at f of
+    Just (h,AbsLambda' bs kb m) -> eval h' m
+      where h' = h & #vars <>~ envOfBinds bs (evalVal g <$> xs)
+                   & #labels . at kb .~ (g ^. #labels . at ktail)
+    Nothing -> error [i|undefined label: #{f}|]
+
+eval g (ExpLetRec [(b, ab)] e) = eval g' e
+  where g' = g & #labels . at b ?~ (g,ab)
+
+eval g (ExpPrim p (MkKappa bs e)) = case evalVal g <$> p of
+  PrimAdd x y -> arithBinop (+) x y
+  PrimMul x y -> arithBinop (*) x y
+  PrimSub x y -> arithBinop (-) x y
+  PrimDiv x y -> arithBinop div x y
+  _ -> error [i|unhandled prim: #{p}|]
+  where
+    ret rs = eval
+        (g & #vars <>~ envOfBinds bs rs)
+        e
+    arithBinop f (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
+      ret [ObjImm . ImmInt $ f x y]
+    arithBinop _ x y = error [i|bad arith: #{x}, #{y}|]
+
+eval _ e = error [i|unimplemented case: #{e}|]
+
+envOfBinds bs xs = foldMap (uncurry H.singleton) (zip bs xs)
+
+evalVal :: Env -> Val -> Obj
+evalVal g = \case
+  ValVar x -> fromMaybe (error [i|unbound: #{x}|]) $ g ^?! #vars . at x
+  ValImm x -> ObjImm x
+  ValLit l -> ObjImm $ case l of
+    LitInt n -> ImmInt n
+    LitBool b -> ImmBool b
+
+emptyEnv :: Env
+emptyEnv = MkEnv
+  { vars = mempty
+  , labels = H.singleton "halt" $
+    ( emptyEnv
+    , AbsKappa' ["h0"] $ Halt [ValVar "h0"]
+    )
+  }
+
+evalProgram :: Program -> List Obj
+evalProgram (MkProgram e) = eval emptyEnv e
+
+curriedadd :: Program
+curriedadd = [cps|
+(letrec ((curried-add
+          (λ (n ktail1)
+            (letrec ((curried-add-in
+                      (λ (m ktail2)
+                        (prim (+ n m)
+                              (κ (x0) (continue ktail2 x0))))))
+              (continue ktail1 curried-add-in)))))
+  (letrec ((k0 (κ (adder) (adder 4 halt))))
+    (curried-add 5 k0)))
+|]
+
+idfn = [cps|
+        (letrec ((id (λ (x ktail)
+                       (continue ktail x))))
+          (id 456 halt))
+      |] :: Program

src/Gyehoek/CPS/Stackify.hs

@@ -8,6 +8,7 @@ module Gyehoek.CPS.Stackify
 import Gyehoek.CPS.Syntax
 import Gyehoek.Stack.Syntax qualified as Stk
 import Data.Sequence (Seq)
+import Data.Sequence qualified as Seq
 import Effectful
 import Gyehoek.GenSym
 import Effectful.Writer.Static.Shared
@@ -18,7 +19,7 @@ import GHC.Generics (Generic)
 import Data.Foldable
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as H
-import Data.List (List)
+import Data.List (List, elemIndex)
 import GHC.Exts (IsList(fromList))
 
 
@@ -48,12 +49,10 @@ stackify g (ExpLetRec [(f, kap@(AbsKappa' xs m))] e) = do
 
 stackify g (ExpLetRec [(f, AbsLambda' xs k m)] e) = do
   let vs = (k:xs) <&> \x -> (x, Stk.ValReg x)
-  lam_body <- gensym' "lambda-body"
   m' <- stackify (g & #bound .~ H.fromList vs
-                    & #bound . at f ?~ Stk.ValLabel lam_body
                     & #contStack %~ (k:)) m
-  tell [Stk.MkBlock lam_body xs . toList $ m']
-  stackify (g & #bound . at f ?~ Stk.ValLabel lam_body) e
+  tell [Stk.MkBlock f xs . toList $ m']
+  stackify g e
 
 stackify g (ExpIf c t f) = do
   t' <- stackify g t
@@ -70,16 +69,21 @@ stackify g (ExpApply f xs ktail) = do
     ls = fold $ (k ^? #ValImm . #ImmLabel)
       >>= \klbl -> g ^. #liveness . at klbl
 
--- this probably won't work for call/cc, for cps-converted code it'll
--- be fine i think. notice how, instead of calling `var g k`, we just
--- assume it's the return continuation on top of the stack.
-stackify g (ExpContinue k xs) = do
-  ktail <- gensym' $ k ^. _Wrapped'
-  pure $
-    fromList [ Stk.PopCont "_" | _ <- takeWhile (/= k) g.contStack ]
-    <> [ Stk.PopCont ktail
-       , Stk.Call (Stk.ValReg ktail) (stackifyVal g <$> xs)
-       ]
+stackify g (ExpContinue k xs) =
+  -- return continuations require popping the stack. how do we know
+  -- when a continuation is a return continuation? is this a correct
+  -- test?
+  case elemIndex k g.contStack of
+    Nothing -> pure [ Stk.Call (Stk.ValLabel k) xs' ]
+    Just j -> do
+      ktail <- gensym' $ k ^. _Wrapped'
+      pure $
+       Seq.replicate j (Stk.PopCont "_")
+       <> [ Stk.PopCont ktail
+          , Stk.Call (Stk.ValReg ktail) (stackifyVal g <$> xs)
+          ]
+
+  where xs' = stackifyVal g <$> xs
 
 stackify g (ExpPrim p (MkKappa [x] e)) = do
   e' <- stackify (g & #bound . at x ?~ Stk.ValReg x) e
@@ -91,6 +95,7 @@ stackifyVal :: Env -> Val -> Stk.Val
 stackifyVal g = \case
   ValLit (LitInt n) -> Stk.ValImm (ImmInt n)
   ValLit (LitBool b) -> Stk.ValImm (ImmBool b)
+  ValImm imm -> Stk.ValImm imm
   ValVar v -> var g v
   v -> error [i|unimplemented val: #{v}|]
 

src/Gyehoek/CPS/Syntax.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE DeriveAnyClass #-}
 module Gyehoek.CPS.Syntax
   ( Val(..)
   , Kappa(..)
@@ -14,6 +15,9 @@ module Gyehoek.CPS.Syntax
   , Prim(..)
   , Program(..)
   , Lit(..)
+  , Imm(..)
+  , Obj(..)
+  , Hob(..)
   , pattern Void
   , pattern Halt
   , pattern Halt1
@@ -34,6 +38,8 @@ module Gyehoek.CPS.Syntax
   , Free(..)
   , Vars(..)
   , Subst(..)
+  , pattern ValLabel
+  , labelName -- don't like that this is part of the api
   )
   where
 
@@ -61,14 +67,41 @@ import Data.Monoid (Endo)
 import Data.Containers.ListUtils (nubOrd)
 import Data.Functor.Foldable.TH
 import Data.Functor.Foldable (Recursive(..), Corecursive (..))
+import Control.DeepSeq (NFData)
+import qualified Gyehoek.Sexp as GS
+import qualified Language.Sexp.Located as SL
+import Data.Data.Lens (uniplate)
 
 -- Data types
 
 data Val
-  = ValVar Name
+  = ValImm Imm
   | ValLit Lit
+  | ValVar Name
   deriving (Show, Generic, Data, Eq)
 
+pattern ValLabel :: Name -> Val
+pattern ValLabel x = ValImm (ImmLabel x)
+
+data Imm
+  = ImmInt Int
+  | ImmBool Bool
+  | ImmLabel Name
+  deriving stock (Show, Generic, Data, Eq)
+  deriving anyclass (NFData)
+
+data Obj
+  = ObjImm Imm
+  | ObjHob Hob
+  deriving stock (Show, Generic, Data, Eq)
+  deriving anyclass (NFData)
+
+-- | a heap object.
+data Hob
+  = HobClosure { label :: Name, env :: List Obj }
+  deriving stock (Show, Generic, Data, Eq)
+  deriving anyclass (NFData)
+
 data Kappa = MkKappa { binders :: List Name, body :: Exp }
   deriving (Show, Generic, Data, Eq)
 
@@ -88,7 +121,7 @@ pattern AbsLambda' xs e ktail = AbsLambda (MkLambda xs e ktail)
 
 data Exp
   = ExpPrim (Prim Val) Kappa
-  | ExpLetRec { binders :: NonEmpty (Name, Abs), body :: Exp }
+  | ExpLetRec { binders :: List (Name, Abs), body :: Exp }
   | ExpContinue Name (List Val)
   | ExpIf Val Exp Exp
   | ExpApply
@@ -139,15 +172,57 @@ _AbsLambda' = prism'
   (\case AbsLambda' bs ktail e -> Just (bs,ktail,e)
          _ -> Nothing)
 
+instance Plated Exp where
+  plate = uniplate
+  -- plate k = \case
+  --   ExpPrim p kap -> ExpPrim p <$> body k kap
+  --   ExpLetRec bs e -> ExpLetRec <$> (each . _2 . body) k bs <*> k e
+  --   ExpContinue c xs -> pure $ ExpContinue c xs
+  --   ExpIf c t f -> ExpIf c <$> k t <*> k f
+  --   ExpApply f xs ktail -> pure $ ExpApply f xs ktail
+
 
 -- SexpIso instances
 
 instance S.SexpIso Val where
   sexpIso = match
-    $ With (\var -> var . S.sexpIso)
     $ With (\lit -> lit . S.sexpIso)
+    $ With (\imm -> imm . S.sexpIso)
+    $ With (\var -> var . S.sexpIso)
     $ End
 
+instance S.SexpIso Obj where
+  sexpIso = match
+    $ With (\imm -> imm . S.sexpIso)
+    $ With (\hob -> hob . S.sexpIso)
+    $ End
+
+instance S.SexpIso Imm where
+  sexpIso = match
+    $ With (. S.int)
+    $ With (. GS.schemeBool)
+    $ With (. labelName)
+    $ End
+
+labelName :: S.SexpGrammar Name
+labelName = S.coproduct
+  [ S.sexpIso @Name >>> Gyehoek.Sexp.prismIso
+        (S.expected "label")
+        (prefixed @Name "$")
+  , S.list $ S.el (S.sym "$") >>> S.el (S.sexpIso @Name)
+  ]
+
+instance S.SexpIso Hob where
+  sexpIso = match
+    $ With (. closure)
+    $ End
+    where
+      -- closures can be printed, but not parsed.
+      closure :: S.Grammar S.Position (Sexp :- t) (List Obj :- Name :- t)
+      closure = IG.Flip $ IG.PartialIso
+        (\(env:-code:-t) -> SL.Modified SL.Hash [GS.sx|(#{code} ##{env})|] :- t)
+        (const . Left $ mempty)
+
 instance S.SexpIso Lambda where
   sexpIso = match
     $ With (. lambda)
@@ -359,8 +434,3 @@ instance Scoped Exp where
 
 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/Driver.hs

@@ -19,7 +19,7 @@ import System.IO (Handle)
 import System.IO qualified as IO
 import Gyehoek.CPS.Convert
 import Gyehoek.CPS.Lower
-import Gyehoek.CPS.Syntax qualified as Cps
+import Gyehoek.CPS.Eval qualified as CPS
 import Control.Monad
 import Text.Pretty.Simple (pShowNoColor)
 import System.Process.Typed
@@ -33,8 +33,11 @@ import Text.Pretty.Simple (pShow)
 import Gyehoek.Stack.VM (eval, writeObj, Obj)
 import qualified Data.Text as T
 import Data.List (List)
-import Gyehoek.Stack.Syntax (encodeProgram)
+import Gyehoek.Stack.Syntax qualified as Stk
 import Effectful.Exception
+import Gyehoek.CPS.Close (closeProgram)
+import Control.Lens.Extras (is)
+import Control.Arrow ((>>>))
 
 
 main :: IO ()
@@ -98,6 +101,18 @@ inspectWasm wat = do
       IO.hFlush (getStdin pager)
       IO.hClose (getStdin pager)
 
+dumpOrRun
+  :: Monad m
+  => Bool -> Bool
+  -> m a
+  -> (a -> m ()) -> (a -> m ())
+  -> m ()
+dumpOrRun dump run acquire do_dump do_run =
+  when (dump || run) do
+    x <- acquire
+    when dump (do_dump x)
+    when run (do_run x)
+
 driver
   :: (GenSym :> es, FileSystem :> es, IOE :> es)
   => Options -> Eff es ()
@@ -108,32 +123,40 @@ driver opts = do
   cps <- convertProgram scm
   when opts.dumpCPS do
     hPutStrLn FS.stdout $ Sexp.encodePretty cps ^?! _Right
-  stk <- stackifyProgram cps
-  if opts.dumpStackified then do
-    hPutStrLn FS.stdout . encodeProgram $ stk
-  else if opts.stackify then do
-    eval stk & fmap writeObj
-             & T.unwords
-             & hPutStrLn FS.stdout
-  else do
-    wat <- lowerProgram cps
-    withFile opts.output FS.WriteMode \h ->
-      hPutStrLn h wat
-    when opts.inspectWasm do
-      inspectWasm wat
+  closedCps <- closeProgram cps
+  when opts.dumpClosed do
+    hPutStrLn FS.stdout $ Sexp.encodePretty closedCps ^?! _Right
+  let rt_is p = is (_Just . p) opts.runtime
+  dumpOrRun opts.dumpStackified (rt_is #Stackify)
+    (stackifyProgram closedCps)
+    (hPutStrLn FS.stdout . Stk.encodeProgram)
+    (eval >>> fmap writeObj      
+         >>> T.unwords          
+         >>> hPutStrLn FS.stdout)
+  dumpOrRun False (rt_is #CPS)
+    (pure closedCps)
+    (const $ pure ())
+    (CPS.evalProgram >>> fmap writeObj      
+         >>> T.unwords          
+         >>> hPutStrLn FS.stdout)
+  dumpOrRun opts.inspectWasm (rt_is #Wasm)
+    (lowerProgram cps)
+    inspectWasm
+    (\wat -> withFile opts.output FS.WriteMode \h -> hPutStrLn h wat)
 
 parse_e2e :: FilePath -> IO Scm.Program
 parse_e2e = runEff . runFileSystem . readScm
 
-convert_e2e :: FilePath -> IO Cps.Program
-convert_e2e = runEff . runFileSystem . runGenSym . (convertProgram <=< readScm)
+convert_e2e :: FilePath -> IO CPS.Program
+convert_e2e = runEff . runFileSystem . runGenSym
+  . (closeProgram <=< convertProgram <=< readScm)
 
 lower_e2e :: FilePath -> IO Text
 lower_e2e =
   runEff . runFileSystem . runGenSym
-  . (lowerProgram <=< convertProgram <=< readScm)
+  . (lowerProgram <=< closeProgram <=< convertProgram <=< readScm)
 
 eval_e2e :: FilePath -> IO (List Obj)
 eval_e2e fp = runEff . runFileSystem . runGenSym $ do
-  stk <- stackifyProgram <=< convertProgram <=< readScm $ fp
+  stk <- stackifyProgram <=< closeProgram <=< convertProgram <=< readScm $ fp
   pure . eval $ stk

src/Gyehoek/Options.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE NoFieldSelectors #-}
 module Gyehoek.Options
   ( Options(..)
+  , Runtime(..)
   , parser
   )
   where
@@ -12,13 +13,18 @@ import System.FilePath
 import qualified Data.HashSet as HS
 import Control.Lens hiding (argument)
 import GHC.Generics (Generic)
+import Data.Foldable
 
 
+data Runtime = Stackify | Wasm | CPS
+  deriving (Show, Generic)
+
 data Options = MkOptions
-  { dumpCPS :: Bool
+  { dumpClosed :: Bool
+  , dumpCPS :: Bool
   , dumpParsed :: Bool
   , dumpStackified :: Bool
-  , stackify :: Bool
+  , runtime :: Maybe Runtime
   , inspectWasm :: Bool
   , output :: FilePath
   , sourceFile :: FilePath
@@ -48,18 +54,32 @@ parseOutput = strOption
     <> value "-"
     )
 
+parseRuntime = option rdr . fold $
+  [ long "runtime"
+  , short 'R'
+  , value Nothing
+  ]
+  where
+    rdr = maybeReader \case
+      "stackify" -> Just (Just Stackify)
+      "wasm" -> Just (Just Wasm)
+      "cps" -> Just (Just CPS)
+      "none" -> Just Nothing
+      _ -> Nothing
+
+parseDumpClosed = switch (long "dump-closed")
 parseDumpCPS = switch (long "dump-cps")
 parseDumpStackified = switch (long "dump-stackified")
-parseStackify = switch (long "stackify")
 parseDumpParsed = switch (long "dump-parsed")
 parseInspectWasm = switch $ long "inspect-wasm" <> short 'p'
 
 parser :: Parser Options
 parser = MkOptions
-  <$> parseDumpCPS
+  <$> parseDumpClosed
+  <*> parseDumpCPS
   <*> parseDumpParsed
   <*> parseDumpStackified
-  <*> parseStackify
+  <*> parseRuntime
   <*> parseInspectWasm
   <*> parseOutput
   <*> argument str (metavar "FILE")

src/Gyehoek/Scheme/Syntax.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -15,6 +16,7 @@ module Gyehoek.Scheme.Syntax
   , Lit(..)
   , Def(..)
   , Exp(..)
+  , ExpF(..)
   , Sexp(..)
   , Program(..)
   , CommandOrDef(..)
@@ -26,11 +28,15 @@ module Gyehoek.Scheme.Syntax
   , scm
   , readExp
   , readProgram
+  , free'
+  , freeWithBound'
+  , freeO
+  , encodeProgram
   )
   where
 
 import Data.Text (Text)
-import Data.List (List)
+import Data.List (List, intersperse)
 import Language.SexpGrammar
   ( SexpIso(..), list, el, rest, sym, symbol )
 import Language.SexpGrammar qualified as Sexp
@@ -51,13 +57,15 @@ import Data.Functor.Foldable.TH (makeBaseFunctor)
 import Data.Functor.Foldable hiding (fold)
 import Data.HashSet (HashSet)
 import qualified Data.HashSet as HS
-import Data.Foldable (fold)
+import Data.Foldable (fold, toList)
 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
 import Control.DeepSeq (NFData)
+import qualified Data.Set.Ordered as O
+import Data.Sequence (Seq)
 
 
 newtype Name = MkName { inner :: Text }
@@ -87,6 +95,7 @@ data Prim e
   | PrimNewline
   | PrimMakeClosure { code :: e, env :: List e }
   | PrimEnvRef e Int
+  | PrimEnvCode e
   | PrimCallCC e
   deriving stock (Show, Generic, Functor, Foldable, Traversable, Data, Eq)
   deriving anyclass (NFData)
@@ -112,8 +121,8 @@ data Def
   deriving anyclass (NFData)
 
 data Exp
-  = ExpLet (NonEmpty (Name, Exp)) Exp
-  | ExpLetRec (NonEmpty (Name, Exp)) Exp
+  = ExpLet (List (Name, Exp)) Exp
+  | ExpLetRec (List (Name, Exp)) Exp
   | ExpPrim (Prim Exp)
   | ExpBegin (List Exp)
   | ExpIf Exp Exp Exp
@@ -180,6 +189,7 @@ primSexpIso namefn a = match
     $ With (. nullop "newline")
     $ With (. ht1' "make-closure")
     $ With (. GS.headTagged2 (namefn "env-ref") a Sexp.int)
+    $ With (. ht1 "env-code")
     $ With (. ht1 "call/cc")
     $ End
     where
@@ -253,6 +263,35 @@ instance SexpIso CommandOrDef where
 scm :: QuasiQuoter
 scm = GS.makeSx [|| GS.fromSexp @Exp ||]
 
+freeWithBound' :: Foldable f => f Name -> Exp -> List Name
+freeWithBound' bound = filter (`elem` bound) . free'
+
+freeO :: Exp -> O.OSet Name
+freeO = O.unbiased . cata \case
+  ExpVarF x -> O.Bias @O.L $ O.singleton x
+  ExpLetF bs e ->
+    foldOf (each . _2) bs
+    <> (e & coerced %~ deleteFromO (bs ^.. each . _1))
+  ExpLetRecF bs e ->
+    (foldOf (each . _2) bs & coerced %~ deleteFromO binds)
+    <> (e & coerced %~ deleteFromO binds)
+    where binds = bs ^.. each . _1
+  ExpLambdaF bs e -> e & coerced %~ deleteFromO bs
+  e -> fold e
+
+free' :: Exp -> List Name
+free' = toList @O.OSet . O.unbiased . cata \case
+  ExpVarF x -> O.Bias @O.L $ O.singleton x
+  ExpLetF bs e ->
+    foldOf (each . _2) bs
+    <> (e & coerced %~ deleteFromO (bs ^.. each . _1))
+  ExpLetRecF bs e ->
+    (foldOf (each . _2) bs & coerced %~ deleteFromO binds)
+    <> (e & coerced %~ deleteFromO binds)
+    where binds = bs ^.. each . _1
+  ExpLambdaF bs e -> e & coerced %~ deleteFromO bs
+  e -> fold e
+
 free :: Exp -> HashSet Name
 free = cata \case
   ExpVarF x -> HS.singleton x
@@ -260,6 +299,9 @@ free = cata \case
   ExpLambdaF binders vs -> deleteFrom binders vs
   e -> fold e
 
+deleteFromO :: (Foldable f, Ord a) => f a -> O.OSet a -> O.OSet a
+deleteFromO = flip $ foldr O.delete
+
 deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
 deleteFrom = flip $ foldr HS.delete
 
@@ -292,3 +334,9 @@ readProgram fp = runFileSystem $
 
 readExp :: IOE :> es => FilePath -> Eff es Exp
 readExp fp = readProgram fp <&> (^?! #commandsAndDefs . _head . #Command)
+
+encodeProgram :: Program -> Text
+encodeProgram p = p.commandsAndDefs
+  & fmap ((^?! _Right) . GS.encodePretty)
+  & intersperse "\n\n"
+  & mconcat

src/Gyehoek/Sexp.hs

@@ -170,12 +170,12 @@ let_
   :: Text
   -> (forall t. Grammar Position (Sexp :- t) (a :- t))
   -> (forall t. Grammar Position (Sexp :- t) (b :- t))
-  -> Grammar Position (Sexp :- (NonEmpty (a, b) :- t1)) t2
+  -> Grammar Position (Sexp :- (List (a, b) :- t1)) t2
   -> Grammar Position (Sexp :- t1) t2
 let_ kw name rhs e = list (el (sym kw) >>> el bindings >>> el e)
   where
     -- bindings :: Grammar Position (Sexp :- _) (List (_, _) :- _)
-    bindings = nonempty binding
+    bindings = list $ rest binding
     binding :: Grammar Position (Sexp :- t) ((_, _) :- t)
     binding = list (el name >>> el rhs) >>> pair
 
@@ -304,6 +304,7 @@ instance Each Sexp Sexp Sexp Sexp where
   each k (SL.ParenList xs)              = SL.ParenList <$> traverse k xs
   each k (SL.BracketList xs)            = SL.BracketList <$> traverse k xs
   each k (SL.BraceList xs)              = SL.BraceList <$> traverse k xs
+  -- each k (SL.Modified m e)   = SL.Modified m <$> each k e
   each _ e@(SL.Atom _; SL.Modified _ _) = pure e
 
 stripLocation :: Sexp -> Sexp
@@ -348,10 +349,6 @@ unquoteSplicingRecursive xs = [| mconcat $(spans) |]
           _ (UnquoteSplicing _) -> False
           _ _                   -> True
       & fmap \case
-        -- [e@(Unquote _)] ->
-        --   case unquote e of
-        --     Just x -> [| [$(x)] |]
-        --     Nothing -> error "unreachable"
         [UnquoteSplicing x] ->
           [| spliceSexp $(varE (mkName (T.unpack x))) |]
         es -> listE $ unquoteRecursive <$> es

src/Gyehoek/Stack/Syntax.hs

@@ -10,6 +10,7 @@ module Gyehoek.Stack.Syntax
   , Lit(..)
   , Obj(..)
   , Imm(..)
+  , Hob(..)
   , Prim(..)
   , Name
   , pattern ValLabel
@@ -34,6 +35,7 @@ import Gyehoek.Scheme.Syntax (Name(..), Lit(..), Prim(..))
 import GHC.Exts (IsList(..))
 import Data.List (intersperse)
 import Control.DeepSeq (NFData)
+import Gyehoek.CPS.Syntax (Imm(..), Obj(..), Hob(..), labelName)
 
 
 newtype Program = MkProgram
@@ -79,18 +81,6 @@ data Val
 pattern ValLabel :: Name -> Val
 pattern ValLabel x = ValImm (ImmLabel x)
 
-data Imm
-  = ImmInt Int
-  | ImmBool Bool
-  | ImmLabel Name
-  deriving stock (Show, Generic, Data, Eq)
-  deriving anyclass (NFData)
-
-data Obj
-  = ObjImm Imm
-  deriving stock (Show, Generic, Data, Eq)
-  deriving anyclass (NFData)
-
 
 --- sexp work
 
@@ -118,13 +108,6 @@ instance SexpIso Val where
     $ With (S.sexpIso >>>)
     $ End
 
-instance SexpIso Imm where
-  sexpIso = match
-    $ With (S.sexpIso @Int >>>)
-    $ With (Gyehoek.Sexp.schemeBool >>>)
-    $ With (labelName >>>)
-    $ End
-
 instance SexpIso Block where
   sexpIso = with (block >>>)
     where
@@ -143,8 +126,3 @@ regName :: S.SexpGrammar Name
 regName = S.sexpIso @Name >>> Gyehoek.Sexp.prismIso
   (S.expected "register")
   (prefixed @Name "%")
-
-labelName :: S.SexpGrammar Name
-labelName = S.sexpIso @Name >>> Gyehoek.Sexp.prismIso
-        (S.expected "label")
-        (prefixed @Name "$")

src/Gyehoek/Stack/VM.hs

@@ -57,6 +57,18 @@ stepI e vm (Prim r p) = case evalVal e vm <$> p of
   PrimMul x y -> arith_binop (*) x y
   PrimSub x y -> arith_binop (-) x y
   PrimDiv x y -> arith_binop div x y
+  PrimMakeClosure f env ->
+    case f of
+      ObjImm (ImmLabel l) -> ret . ObjHob $ HobClosure l env
+      _ -> error [i|expected label, got #{f}|]
+  PrimEnvCode env ->
+    case env of
+      ObjHob (HobClosure l _) -> ret . ObjImm . ImmLabel $ l
+      _ -> error [i|expected closure, got #{env}|]
+  PrimEnvRef env n ->
+    case env of
+      ObjHob (HobClosure _ xs) -> ret $ xs ^?! ix n
+      _ -> error [i|expected closure, got #{env}|]
   x -> error [i|unimplemented prim: #{p}|]
   where
     ret v = vm & #registers . at r ?~ v
@@ -69,8 +81,8 @@ stepI e vm (Pop r) = case vm ^. #stack of
   (x:xs) -> vm & #registers . at r ?~ x
                & #stack .~ xs
 
-stepI e vm (PopCont r) = case vm ^. #kstack of
-  [] -> error "empty stack"
+stepI e vm ins@(PopCont r) = case vm ^. #kstack of
+  [] -> error [i|empty cont stack: #{ins}|]
   (x:xs) -> vm & #registers . at r ?~ ObjImm (ImmLabel x)
                & #kstack .~ xs
 
@@ -141,3 +153,5 @@ writeObj (ObjImm im) = case im of
   ImmBool True -> "#t"
   ImmBool False -> "#f"
   ImmLabel l -> "#<procedure>"
+writeObj (ObjHob h) = case h of
+  HobClosure code env -> "#<procedure>"

test/Gyehoek/Test/CPS/Eval.hs

@@ -0,0 +1,56 @@
+module Gyehoek.Test.CPS.Eval (root) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import Language.SexpGrammar ()
+import Gyehoek.CPS.Syntax (cps, Obj(..), Hob(..), Imm(..))
+import Gyehoek.CPS.Eval qualified as Sut
+import Data.List (List)
+
+
+root :: IO TestTree
+root = pure . testGroup "cps interpreter" $
+  [ prim
+  , testCase "halt with constant" do
+      evalsTo [ObjImm (ImmInt 123)] [cps|
+        (continue halt 123)
+      |]
+  , testCase "identity cont" do
+      evalsTo [ObjImm (ImmInt 154)] [cps|
+        (letrec ((id (κ (x)
+                       (continue halt x))))
+          (continue id 154))
+      |]
+  , testCase "identity function" do
+      evalsTo [ObjImm (ImmInt 456)] [cps|
+        (letrec ((id (λ (x ktail)
+                       (continue ktail x))))
+          (id 456 halt))
+      |]
+  , testCase "square" do
+      evalsTo [ObjImm (ImmInt 81)] [cps|
+        (letrec ((square (λ (x ktail)
+                           (prim (* x x)
+                             (κ (r) (continue ktail r))))))
+          (square 9 halt))
+      |]
+  ]
+
+evalsTo :: HasCallStack => List Obj -> Sut.Program -> Assertion
+evalsTo rs p = Sut.evalProgram p @?= rs
+
+prim = testGroup "primitives"
+  [ testGroup "arith"
+    [ testCase "basic 1" do
+        evalsTo [ObjImm (ImmInt 20)] [cps|
+          (prim (* 4 5)
+            (κ (x) (continue halt x)))
+          |]
+    , testCase "basic 2" do
+        evalsTo [ObjImm (ImmInt 35)] [cps|
+          (prim (* 2 16)
+            (κ (x) (prim (+ x 3)
+                      (κ (r) (continue halt r)))))
+          |]
+    ]
+  ]

test/Gyehoek/Test/Golden.hs

@@ -25,10 +25,11 @@ brokenWasmTests =
 
 brokenStackifyTests :: List String
 brokenStackifyTests =
-  [ "adder"
-  , "let-fn"
-  , "callcc-nested1" -- requires closure-conversion
-  ]
+  []
+  -- [ "adder"
+  -- , "let-fn"
+  -- , "callcc-nested1" -- requires closure-conversion
+  -- ]
 
 root :: IO TestTree
 root = do

test/Gyehoek/Test/Scheme/Syntax.hs

@@ -0,0 +1,27 @@
+module Gyehoek.Test.Scheme.Syntax (root) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import Language.SexpGrammar ()
+import Gyehoek.Scheme.Syntax (scm)
+import Gyehoek.Scheme.Syntax qualified as Sut
+
+
+root :: IO TestTree
+root = pure . testGroup "scheme syntax" $
+  [ freeTree
+  ]
+
+freeTree :: TestTree
+freeTree = testGroup "free"
+  [ testCase "lambda" do
+    Sut.free' [scm|
+      (lambda (x y z k) (f x b a))
+    |] @=? ["f","b","a"]
+  , testCase "exp" do
+    Sut.free' [scm|
+      (letrec ((x (lambda (r) (f a y)))
+               (y (lambda (r b) (f b x))))
+        (g x y z))
+    |] @=? ["f","a","g","z"]
+  ]

test/Main.hs

@@ -5,8 +5,10 @@ import Test.Tasty.Silver.Interactive (defaultMain)
 import qualified Gyehoek.Test.Golden
 import qualified Gyehoek.Test.Sexp
 import qualified Gyehoek.Test.CPS.Syntax
+import qualified Gyehoek.Test.Scheme.Syntax
 import qualified Gyehoek.Test.Stack.VM
 import qualified Gyehoek.Test.CPS.Stackify
+import qualified Gyehoek.Test.CPS.Eval
 
 
 main :: IO ()
@@ -17,7 +19,9 @@ root = testGroup "test" <$> sequenceA
   [ Gyehoek.Test.Golden.root
   , Gyehoek.Test.Sexp.root
   , Gyehoek.Test.CPS.Syntax.root
+  , Gyehoek.Test.Scheme.Syntax.root
   , Gyehoek.Test.Stack.VM.root
   , Gyehoek.Test.CPS.Stackify.root
+  , Gyehoek.Test.CPS.Eval.root
   ]