diff --git a/gyehoek.cabal b/gyehoek.cabal index 4d50143..25979b0 100644 --- a/gyehoek.cabal +++ b/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 diff --git a/src/Gyehoek/CPS/Contify.hs b/src/Gyehoek/CPS/Contify.hs new file mode 100644 index 0000000..c924ff8 --- /dev/null +++ b/src/Gyehoek/CPS/Contify.hs @@ -0,0 +1,6 @@ +module Gyehoek.CPS.Contify + ( + ) where + +import Gyehoek.Prelude + diff --git a/src/Gyehoek/CPS/Hoist.hs b/src/Gyehoek/CPS/Hoist.hs new file mode 100644 index 0000000..0031132 --- /dev/null +++ b/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} diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index 011814c..c5d434d 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/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 diff --git a/src/Gyehoek/Driver.hs b/src/Gyehoek/Driver.hs index 65497cb..8332686 100644 --- a/src/Gyehoek/Driver.hs +++ b/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) diff --git a/src/Gyehoek/Options.hs b/src/Gyehoek/Options.hs index 4ecf008..c66cda5 100644 --- a/src/Gyehoek/Options.hs +++ b/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 $