superfuck

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'} (κ (#{r_l}) #{m}))
-        (prim #{p'} #{k_l}))
     |]
+    -- 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

@@ -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 ()
@@ -18,150 +22,231 @@ import Control.Monad.Cont qualified as Cont
 import Gyehoek.Sexp qualified as S
 import GHC.Generics (Generically(..))
 import Gyehoek.Sexp ((:-)(..))
+import Data.List (nub, mapAccumR)
+import Data.HashSet.Lens (setOf)
+import Data.IntMap.Strict (IntMap)
+import Data.IntMap.Strict qualified as IM
+import Data.Monoid
 
 
-data Env = MkEnv
+newtype Loc = MkLoc { getLoc :: Int }
-  { store :: HashMap Name Obj
+  deriving stock (Generic, Data)
-  }
+  deriving newtype (Show, Eq, Ord, Enum)
-  deriving stock (Show, Generic, Data, Eq)
-  deriving (Semigroup, Monoid)
-    via Generically Env
 
-emptyEnv = MkEnv
+data Store = MkStore
-  { store = mempty
+  { nextLoc :: Loc
+  , heap :: IntMap E
+  }
+  deriving stock (Show, Generic, Data)
+
+emptyStore :: Store
+emptyStore = MkStore
+  { nextLoc = 0
+  , heap = mempty
   }
 
-
+newtype Env = MkEnv { getEnv :: HashMap Name Loc }
+  deriving stock (Show, Generic, Data)
+  deriving newtype (Semigroup, Monoid)
 
-data Obj
+emptyEnv :: Env
-  = ObjImm Imm
+emptyEnv = mempty
-  | ObjHob Hob
-  deriving stock (Show, Generic, Data, Eq)
 
--- | a heap object.
+type instance Index Env = Name
-data Hob
+type instance IxValue Env = Loc
-  = 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
+instance Ixed Env where ix j = #getEnv . ix j
-  datumIso = S.match
+instance At Env where at j = #getEnv . at j
-    $ S.With (S.datumIso @Imm >>>)
-    $ S.With (S.datumIso @Hob >>>)
-    $ S.End
 
-instance S.DatumIso Hob where
+update :: Loc -> E -> Store -> Store
-  datumIso = S.match
+update (MkLoc loc) v = #heap %~ IM.alter f loc
-    $ S.With (closure >>>)
+  where
-    $ S.With (conspair >>>)
+    f (Just _) = Just v
-    $ S.End
+    f Nothing = error "segfault lol"
-    where
+
-      conspair = S.dottedList (S.el S.datumIso) S.datumIso
+updates :: Foldable f => f (Loc, E) -> Store -> Store
-      -- closures can be printed, but not parsed.
+updates = alaf Endo foldMap (uncurry update)
-      closure :: S.G (S.Datum :- t) (Env :- Abs :- t)
+
-      closure = S.Flip $ S.PartialIso
+fetch :: Loc -> Store -> E
-        (\(_:-_:-t) -> S.Unreadable [i|\#<procedure>|] :- t)
+fetch (MkLoc loc) st = st ^?! #heap . ix loc
-        (const . Left $ mempty)
+
+new :: Store -> (Store, Loc)
+new st = (st & #nextLoc %~ succ, st.nextLoc)
+
+new' :: E -> Store -> (Store, Loc)
+new' e st = (update l e st', l)
+  where
+    (st',l) = new st
+
+news' :: Traversable t => t E -> Store -> (Store, Loc)
+news' es st = mapAccumR _ st es
+  where
+    (st',l) = new st
+
+var :: HasCallStack => Env -> Name -> Loc
+var g x = g ^?! ix x
+
+type CmdCont = Store -> Answer
+type ExpCont = List E -> CmdCont
+
+data Answer
+  = AnswerValues Store (List E)
+  | AnswerError Text
+  deriving (Show, Generic, Data)
+
+data Mutability
+  = Mut
+  | NoMut
+  deriving (Show, Generic, Data, Eq)
+
+wrong :: Text -> CmdCont
+wrong = const . AnswerError
+
+single :: (E -> CmdCont) -> ExpCont
+single k = \case
+  [x] -> k x
+  _ -> wrong "wrong number of return values"
+
+send :: E -> ExpCont -> CmdCont
+send e k = k [e]
+
+-- | Continue with the value located at a given 'Loc'.
+hold :: Loc -> ExpCont -> CmdCont
+hold loc k st = send (fetch loc st) k st
+
+tievals :: Traversable t => t E -> (t Loc -> CmdCont) -> CmdCont
+tievals es f st0 = f ls stn
+  where
+    (stn,ls) = mapAccumR (flip new') st0 es
+
+bind :: Name -> Loc -> Env
+bind k = MkEnv . H.singleton k
+
+extends :: Foldable f => f (Name, Loc) -> Env -> Env
+extends xs g = g <> foldMap (uncurry bind) xs
 
 
 
-err :: Jalmot :> es => Text -> Eff es a
+-- | The denotation of an expressed value.
-err = throwError . VMError
+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 Procedure
+  deriving stock (Show, Generic, Data)
 
-eval1 :: Jalmot :> es => Env -> Exp -> Eff es Obj
+type Procedure = List E -> DynPoints -> ExpCont -> CmdCont
-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)
+eGrammar :: Store -> S.DatumGrammar E
-pure1 = pure . (:[])
+eGrammar st = S.partialOsi (const . Left $ mempty) go
-
-eval
-  :: Jalmot :> es
-  => Env -> Exp
-  -> Eff es (List Obj)
-
-eval g (ExpLetRec bs e) = eval g' e
   where
-    g' = g <> foldMap
+    gofetch x = go $ fetch x st
-      (\(f,ab) -> mempty & #store . at f ?~
+    go = \case
-        ObjHob (HobClosure ab g'))
+      ESymbol s -> S.Symbol s
-      bs
+      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 _
 
-eval g (Halt rs) = traverse (evalVal g) rs
+data DynPoints = MkDynPoints
+  deriving (Generic, Data)
 
-eval g (ExpContinue k xs) =
+
-  case k of
-    ValVar x -> continueWith g (KexpVar x) xs
 
-eval g (ExpApply f xs ktail) = do
+-- 뻘짓이어라
-  f' <- evalVal g f
+telescope
-  xs' <- traverse (evalVal g) xs
+  :: Traversable t
-  ktail' <- evalKexp g ktail
+  => (a -> (b -> r) -> r)
-  case f' of
+  -> t a -> (t b -> r) -> r
-    ObjHob (HobClosure {code,env}) -> eval env' e
+telescope f = Cont.runCont . traverse (Cont.cont . f)
-      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
+procedure :: Env -> Procedure -> (E -> CmdCont) -> CmdCont
-  PrimSub x y -> arith2 (-) x y
+procedure = _
-  PrimDiv x y -> arith2 div x y
+
+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 = evalAbs g (AbsKappa kap) k
+
+evalAbs :: Env -> Abs -> ExpCont -> CmdCont
+evalAbs g (MkAbs formals mtail e) k st = send ab k st'
   where
-    arith2 f (ObjImm (ImmInt x)) (ObjImm (ImmInt y)) =
+    (st',l) = new' EUnspecified st
-      pure1 . ObjImm . ImmInt $ f x y
+    ab = EProcedure l \args dps k' ->
+      tievals args \argLocs ->
+        let argEnv = zip (formals ++ foldMap (:[]) mtail) argLocs
+            g' = g <> foldMap (uncurry bind) argEnv
+        in eval g' dps e k'
 
-eval g e = err [i|unimplemented exp: #{S.encodeOrShow' @Text S.datumIso e}|]
+eval :: Env -> DynPoints -> Exp -> ExpCont -> CmdCont
 
-continueWith :: Jalmot :> es => Env -> Kexp -> List Val -> Eff es (List Obj)
+eval g dps (ExpLetRec bs e) k = \st0 ->
-continueWith g kexp xs = do
+  let
-  xs' <- traverse (evalVal g) xs
+    rhss = bs ^.. each . _2
-  evalKexp g kexp >>= \case
+    (st',ls) = mapAccumR (\st _ -> new st) st0 bs
-    ObjImm (ImmLabel "halt") -> traverse (evalVal g) xs
+    g' = g & extends (zip (bs ^.. each . _1) ls)
-    ObjHob (HobClosure {code,env}) -> eval env' e
+    f :: List E -> CmdCont
-      where
+    f = \rhss' -> eval g' dps e k . updates (zip ls rhss')
-        MkAbs bxs bktail e = code
+  in telescope (\ab -> evalAbs g' ab . single) rhss f st'
-        env' = env & #store <>~ H.fromList (zip bxs xs')
 
-evalKexp :: Jalmot :> es => Env -> Kexp -> Eff es Obj
+eval g dps (ExpJump f xs ktail) k =
-evalKexp g = \case
+  telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
-  KexpVar x -> var g x
+    telescope (\ke -> evalKexp g ke . single) (ktail ^.. each) \ktail' ->
-  KexpKappa kap -> pure . ObjHob $ HobClosure (AbsKappa kap) g
+      case f' of
+        EProcedure _loc fp -> fp xs' dps k
+        _ -> wrong "bad procedure"
 
-evalVal
+eval g dps (ExpContinue f xs) k =
-  :: Jalmot :> es
+  telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
-  => Env -> Val
+    case f' of
-  -> Eff es Obj
+      EProcedure _loc fp -> fp xs' dps k
-evalVal g (ValImm imm) = pure $ ObjImm imm
+      _ -> wrong "bad procedure"
-evalVal g (ValVar x) = var g x
 
-var :: Jalmot :> es => Env -> Name -> Eff es Obj
+eval g dps (ExpApply f xs ktail) k =
-var _ "halt" = pure . ObjImm . ImmLabel $ "halt"
+  telescope (evalVal1 g) (f:|xs) \(f':|xs') ->
-var g x = case g ^. #store . at x of
+    evalKexp g ktail . single $ \ktail' ->
-  Just o -> pure o
+      case f' of
-  Nothing -> err [i|unbound var #{x}|]
+        EProcedure _loc fp -> fp (xs' ++ [ktail']) dps k
+        _ -> wrong "bad procedure"
 
-evalExp :: Jalmot :> es => Exp -> Eff es (List Obj)
+
-evalExp e = eval emptyEnv e
 
-evalProgram :: Jalmot :> es => Program -> Eff es (List Obj)
+prim_halt :: Procedure
-evalProgram (MkProgram lam) = evalExp [cps|
+prim_halt xs _dps _k st = AnswerValues st xs
-  (letrec ((start #{lam}))
-    (start halt))
-|]
 
-p :: Program
+setup :: (Env -> CmdCont) -> CmdCont
-p = [cps|
+setup k = tievals (defs ^.. each) _
-  (λ (ktail)
+  where
-    (continue ktail 123))
+    defs :: HashMap Name E
-|]
+    defs =
+      [ ("halt", EProcedure _ prim_halt)
+      ]
 
-e1 :: Exp
+evalExp :: Jalmot :> es => Exp -> Eff es _
-e1 = [cps|
+evalExp e = _
-  (continue $halt 123)
+
-|]
+evalProgram :: Jalmot :> es => Program -> Eff es (List E)
+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 }

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 :: (FilePath -> IO Text) -> FilePath -> TestTree
-cpsCase test =
+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
                    , "" ))