hoist

gyehoek.cabal

@@ -58,14 +58,16 @@ library
   -- cabal-fmt: expand src
   exposed-modules:
     Gyehoek.CPS.Close
+    Gyehoek.CPS.Contify
     Gyehoek.CPS.Convert
     Gyehoek.CPS.Eval
+    Gyehoek.CPS.Hoist
     Gyehoek.CPS.Stackify
     Gyehoek.CPS.Syntax
     Gyehoek.Driver
-    Gyehoek.Language
     Gyehoek.GenSym
     Gyehoek.Jalmot
+    Gyehoek.Language
     Gyehoek.Lift1
     Gyehoek.Options
     Gyehoek.Prelude
@@ -100,6 +102,7 @@ library
     , hashable
     , invertible-grammar
     , lens
+    , lucid
     , megaparsec
     , mtl
     , optparse-applicative
@@ -107,6 +110,7 @@ library
     , pretty-simple
     , prettyprinter
     , prettyprinter-ansi-terminal
+    , prettyprinter-lucid
     , process
     , recursion-schemes
     , scientific
@@ -117,8 +121,6 @@ library
     , typed-process
     , unordered-containers
     , vector
-    , lucid
-    , prettyprinter-lucid
 
   hs-source-dirs:   src
   default-language: GHC2024
@@ -171,6 +173,7 @@ test-suite doctest
   build-depends:
     , base
     , gyehoek
+
   default-extensions: CPP
   main-is:            doctest.hs
 

src/Gyehoek/CPS/Contify.hs

@@ -0,0 +1,6 @@
+module Gyehoek.CPS.Contify
+  (
+  ) where
+
+import Gyehoek.Prelude
+

src/Gyehoek/CPS/Hoist.hs

@@ -0,0 +1,24 @@
+module Gyehoek.CPS.Hoist
+  ( hoistProgram
+  ) where
+
+import Gyehoek.CPS.Syntax
+import Gyehoek.Prelude
+import qualified Data.HashMap.Strict as H
+import Effectful.Writer.Static.Local
+import Data.Foldable
+
+
+type Hoist = Writer (HashMap Name Abs)
+
+hoist :: Hoist :> es => Exp -> Eff es Exp
+hoist = transformM \case
+  ExpLetRec bs m -> do
+    traverse_ (\(k,v) -> tell $ H.singleton k v) bs
+    pure m
+  e -> pure e
+
+hoistProgram :: Program -> Eff es HoistedProgram
+hoistProgram p = do
+  (body,bindings) <- runWriter $ traverseOf #body hoist p.body
+  pure $ MkHoistedProgram {body,bindings}

src/Gyehoek/CPS/Syntax.hs

@@ -15,6 +15,7 @@ module Gyehoek.CPS.Syntax
   , Name(..)
   , Prim(..)
   , Program(..)
+  , HoistedProgram(..)
   , Lit(..)
   , Imm(..)
   , Obj(..)
@@ -58,6 +59,7 @@ import qualified Data.InvertibleGrammar.Base as IG
 import Gyehoek.GenSym (Gen)
 import Data.String (IsString)
 import Control.Applicative
+import qualified Data.HashMap.Strict as H
 
 -- Data types
 
@@ -135,6 +137,7 @@ data Exp
 
 data Kexp
   = KexpVar Name
+  -- | Only to be used after contification.
   | KexpKappa Kappa
   deriving (Show, Generic, Data, Eq)
 
@@ -152,6 +155,22 @@ data Program = MkProgram
   }
   deriving (Show, Generic, Data)
 
+data HoistedProgram = MkHoistedProgram
+  { bindings :: HashMap Name Abs
+  , body :: Lambda
+  }
+  deriving stock (Show, Generic, Data)
+
+type instance Index HoistedProgram = Name
+type instance IxValue HoistedProgram = Abs
+
+instance Ixed HoistedProgram where ix j = #bindings . ix j
+
+instance At HoistedProgram where at j = #bindings . at j
+
+instance Each HoistedProgram HoistedProgram Abs Abs where
+  each = #bindings . each
+
 makePrisms ''Kappa
 makePrisms ''Exp
 makeFieldsId ''Exp
@@ -307,6 +326,13 @@ instance S.DatumIso Kexp where
 instance S.DatumIso Program where
   datumIso = S.with \prog -> S.datumIso @Lambda >>> prog
 
+instance S.DatumIso HoistedProgram where
+  datumIso = S.with \prog ->
+    S.letLike "letrec"
+      (S.datumIso @Name) (S.datumIso @Abs) (S.datumIso @Lambda)
+    >>> S.onTail (S.iso H.fromList H.toList)
+    >>> prog
+
 
 -- quasiquoters
 

src/Gyehoek/Driver.hs

@@ -35,6 +35,7 @@ import Control.Arrow ((>>>))
 import Gyehoek.Prelude
 import Gyehoek.Jalmot
 import qualified Gyehoek.Sexp as S
+import Gyehoek.CPS.Hoist (hoistProgram)
 
 
 main :: IO ()
@@ -122,6 +123,9 @@ driver opts = do
   closedCps <- closeProgram cps
   when opts.dumpClosed do
     hPutStrLn FS.stdout =<< S.encodeWith S.datumIso closedCps
+  hoistedCps <- hoistProgram closedCps
+  when opts.dumpHoisted do
+    hPutStrLn FS.stdout =<< S.encodeWith S.datumIso hoistedCps
   let rt_is p = is (_Just . p) opts.runtime
   dumpOrRun opts.dumpStackified (rt_is #Stackify)
     (stackifyProgram closedCps)

src/Gyehoek/Options.hs

@@ -29,6 +29,7 @@ data Options = MkOptions
   , dumpCPS :: Bool
   , dumpParsed :: Bool
   , dumpStackified :: Bool
+  , dumpHoisted :: Bool
   , traceStackified :: Bool
   , runtime :: Maybe Runtime
   , inspectWasm :: Bool
@@ -61,6 +62,7 @@ parser = do
   dumpCPS <- switch (long "dump-cps")
   dumpStackified <- switch (long "dump-stackified")
   dumpParsed <- switch (long "dump-parsed")
+  dumpHoisted <- switch (long "dump-hoisted")
   traceStackified <- switch (long "trace-stackified")
   inspectWasm <- switch $ long "inspect-wasm" <> short 'p'
   runtime <- option runtimeReader . fold $