golden/exec/cons-2/source.scm

@@ -0,0 +1,2 @@
+(let ((p (cons 123 456)))
+  (cons (cdr p) (car p)))

src/Gyehoek/CPS/Close.hs

@@ -31,7 +31,6 @@ close1 = \case
             (each . _2)
             (freeWithBound' boundNames')
           & nub
-    pTraceShowM frees
     env_cont_l <- gensym' @Name "env-cont"
     e_l <- gensym' @Name "letrec-body-cont"
     bs' <- for bs \(f,ab) -> do

src/Gyehoek/CPS/Convert.hs

@@ -49,12 +49,15 @@ convert (Scm.ExpLit l) k = k . one . ValImm $ case l of
 convert (Scm.ExpPrim p) k =
   telescope (convert1 @es) p \p' -> do
     r_l <- gensym' "r"
-    k_l <- gensym' @Name "prim-k"
+    -- k_l <- gensym' @Name "prim-k"
     m <- k [ValVar r_l]
     pure [cps|
-      (letrec ((#{k_l} (κ (#{r_l}) #{m})))
-        (prim #{p'} #{k_l}))
+      (prim #{p'} (κ (#{r_l}) #{m}))
     |]
+    -- pure [cps|
+    --   (letrec ((#{k_l} (κ (#{r_l}) #{m})))
+    --     (prim #{p'} #{k_l}))
+    -- |]
 
 convert (Scm.ExpLambda xs e) k = do
   f <- gensym' "lambda-body"

src/Gyehoek/CPS/Eval.hs

@@ -18,6 +18,8 @@ import Control.Monad.Cont qualified as Cont
 import Gyehoek.Sexp qualified as S
 import GHC.Generics (Generically(..))
 import Gyehoek.Sexp ((:-)(..))
+import Data.List (nub)
+import Data.HashSet.Lens (setOf)
 
 
 data Env = MkEnv
@@ -40,7 +42,7 @@ data Obj
 
 -- | a heap object.
 data Hob
-  = HobClosure { code :: Abs, env :: Env}
+  = HobClosure { code :: Abs, env :: List Obj }
   -- should a continuation have a label, or an Obj?
   | HobPair Obj Obj
   deriving stock (Show, Generic, Data, Eq)
@@ -59,7 +61,7 @@ instance S.DatumIso Hob where
     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.G (S.Datum :- t) (List Obj :- Abs :- t)
       closure = S.Flip $ S.PartialIso
         (\(_:-_:-t) -> S.Unreadable [i|\#<procedure>|] :- t)
         (const . Left $ mempty)
@@ -82,18 +84,23 @@ eval
   => 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 (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) xs
+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
@@ -112,21 +119,29 @@ eval g (ExpPrim p k) = traverse (evalVal g) p >>= \case
   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 . (:[])
     arith2 f (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
-      pure1 . ObjImm . ImmInt $ f x y
+      ret1 . ObjImm . ImmInt $ f x y
 
 eval g e = err [i|unimplemented exp: #{S.encodeOrShow' @Text S.datumIso e}|]
 
-continueWith :: Jalmot :> es => Env -> Kexp -> List Val -> Eff es (List Obj)
-continueWith g kexp xs = do
-  xs' <- traverse (evalVal g) xs
+continueWith :: Jalmot :> es => Env -> Kexp -> List Obj -> Eff es (List Obj)
+continueWith g kexp xs =
   evalKexp g kexp >>= \case
-    ObjImm (ImmLabel "halt") -> traverse (evalVal g) xs
+    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')
+        env' = env & #store <>~ H.fromList (zip bxs xs)
 
 evalKexp :: Jalmot :> es => Env -> Kexp -> Eff es Obj
 evalKexp g = \case

src/Gyehoek/Driver.hs

@@ -1,5 +1,5 @@
 module Gyehoek.Driver
-  (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e, eval_cps_e2e)
+  (main, lower_e2e, convert_e2e, parse_e2e, readScm, eval_e2e, eval_cps_e2e, eval_cps2_e2e)
   where
 
 import Gyehoek.Options
@@ -123,10 +123,10 @@ driver opts = do
      S.writeDatum cps
   closedCps <- closeProgram cps
   when opts.dumpClosed do
-    S.writeData closedCps
+    S.writeDatum closedCps
   hoistedCps <- hoistProgram closedCps
   when opts.dumpHoisted do
-    S.writeData hoistedCps
+    S.writeDatum hoistedCps
   -- contifiedCps <- contifyProgram hoistedCps
   -- when opts.dumpContified do
   --   hPutStrLn FS.stdout =<< S.encodeWith S.datumIso contifiedCps
@@ -137,6 +137,9 @@ driver opts = do
     (eval >=> fmap writeObj
          >>> T.unwords
          >>> hPutStrLn FS.stdout)
+  when (rt_is #HigherOrderCPS) do
+    CPS.evalProgram cps
+      >>= S.writeData
   when (rt_is #CPS) do
     CPS.evalProgram closedCps
       >>= S.writeData
@@ -166,6 +169,14 @@ eval_e2e fp = runJalmotIO . runFileSystem . runGenSym $ do
 
 eval_cps_e2e :: FilePath -> IO Text
 eval_cps_e2e fp = runJalmotIO . runFileSystem . runGenSym $
+  readScm fp
+   >>= convertProgram
+   >>= closeProgram
+   >>= CPS.evalProgram
+   >>= pure . S.encodeOrShowData' S.dataIso
+
+eval_cps2_e2e :: FilePath -> IO Text
+eval_cps2_e2e fp = runJalmotIO . runFileSystem . runGenSym $
   readScm fp
    >>= convertProgram
    -- >>= closeProgram

src/Gyehoek/Options.hs

@@ -13,7 +13,7 @@ import Data.Foldable
 import Gyehoek.Prelude hiding (argument)
 
 
-data Runtime = Stackify | Wasm | CPS
+data Runtime = Stackify | Wasm | CPS | HigherOrderCPS
   deriving (Show, Generic, Eq)
 
 data Language
@@ -55,6 +55,7 @@ runtimeReader = maybeReader \case
   "stackify" -> Just (Just Stackify)
   "wasm" -> Just (Just Wasm)
   "cps" -> Just (Just CPS)
+  ("cps2";"higher-order-cps") -> Just (Just CPS)
   "none" -> Just Nothing
   _ -> Nothing
 
@@ -75,9 +76,9 @@ parser = do
   runtime <- option runtimeReader . fold $
     [ long "runtime"
     , short 'R'
-    , value (Just CPS)
+    , value (Just HigherOrderCPS)
     , completeWith runtimeValues
-    , showDefaultWith $ const "cps"
+    , showDefaultWith $ const "higher-order-cps"
     , metavar "RUNTIME"
     ]
   sourceLanguage <- option languageReader . fold $

src/Gyehoek/Sexp/Grammar.hs

@@ -132,7 +132,7 @@ encodeOrShow' g x = fromString $
 
 encodeOrShow :: (IsString s, Show a) => DatumGrammar a -> a -> s
 encodeOrShow g x = fromString $
-  case runPureEff . runJalmot . encodeWith' g $ x of
+  case runPureEff . runJalmot . encodeWith g $ x of
     Left _ -> show x
     Right t -> T.unpack t
 

test/Gyehoek/Test/CPS/Eval.hs

@@ -56,12 +56,15 @@ test_eval :: IO TestTree
 test_eval = do
   cs <- listDirectory "golden/exec"
       <&> fmap ("golden/exec" </>)
-  pure $ testGroup "cps interpreter" $ cpsCase <$> cs
+  pure $ testGroup "cps interpreter"
+    [ testGroup "higher-order" $ cpsCase Driver.eval_cps2_e2e <$> cs
+    , testGroup "first-order" $ cpsCase Driver.eval_cps_e2e <$> cs
+    ]
 
 maybeBroken name broken = applyWhen (name `elem` broken) expectFail
 
-cpsCase :: FilePath -> TestTree
-cpsCase test =
+cpsCase :: (FilePath -> IO Text) -> FilePath -> TestTree
+cpsCase f test =
   maybeBroken testName brokenEvalTests $
     goldenVsAction testName resultFile action printProcResult
   where
@@ -69,7 +72,7 @@ cpsCase test =
     resultFile = test </> "exec"
     sourceFile = test </> "source.scm"
     action = catch @SomeException
-      (do r <- Driver.eval_cps_e2e sourceFile
+      (do r <- f sourceFile
           pure $!! ( ExitSuccess
                    , r
                    , "" ))