diff --git a/gyehoek.cabal b/gyehoek.cabal index 25979b0..c0f3264 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -121,6 +121,7 @@ library , typed-process , unordered-containers , vector + , tardis hs-source-dirs: src default-language: GHC2024 diff --git a/src/Gyehoek/CPS/Contify.hs b/src/Gyehoek/CPS/Contify.hs index c924ff8..5563158 100644 --- a/src/Gyehoek/CPS/Contify.hs +++ b/src/Gyehoek/CPS/Contify.hs @@ -1,6 +1,103 @@ module Gyehoek.CPS.Contify - ( + ( contifyProgram ) where +import Control.Monad.Tardis +import Gyehoek.CPS.Syntax import Gyehoek.Prelude +import qualified Data.HashSet as HS +import Control.Lens.Unsound (adjoin) + +-- | ain't no way... +type T es = TardisT (HashSet Name) (HashSet Name) (Eff es) + +runT :: T es a -> Eff es a +runT = (`evalTardisT` (mempty,mempty)) + +-- | inline function if it hasn't been used in the past, and won't +-- be used in the future. +tryInline :: Name -> Kappa -> T es Kexp +tryInline kname kap = do + modifyBackwards (HS.insert kname) + p <- getsPast (HS.member kname) + modifyForwards (HS.insert kname) + q <- getsFuture (HS.member kname) + pure $ if p || q + then KexpVar kname + else KexpKappa kap + +getKap :: HashMap Name Abs -> Name -> Maybe Kappa +getKap g kname = g ^? ix kname . #AbsKappa + +contify :: HashMap Name Abs -> Exp -> T es Exp +contify g = \case + ExpApply f xs (KexpVar kname) | Just kap <- getKap g kname + -> ExpApply f xs <$> tryInline kname kap + ExpPrim p (KexpVar kname) | Just kap <- getKap g kname + -> ExpPrim p <$> tryInline kname kap + e -> pure e + +contifyProgram :: HoistedProgram -> Eff es HoistedProgram +contifyProgram p = do + let g = p.bindings + runT $ + traverseOf + (adjoin + (#bindings . each . body) + (#body . body)) + (contify g) + p + + + +type BidirectionalState = Tardis (HashSet Text) (HashSet Text) + +runBidirectionalState = (`evalTardis` (mempty,mempty)) + +markAsUsed :: Hashable a => a -> HashSet a -> HashSet a +markAsUsed = HS.insert + +isMarkedAsUsed :: Hashable a => a -> HashSet a -> Bool +isMarkedAsUsed = HS.member + +-- | our bidirectional state monad. updates can be sent forwards or +-- backwards. +runBidirectionalState :: BidirectionalState a -> a + +data InlineResult + -- | represents the successful inlining of a function. + = Inlined Text + -- | represents a function that couldn't be inlined. + | NotInlined Text + deriving (Show) + + +-- | try inlining two functions, `x` and `y`. each is used exactly +-- once, so both should be successfully inlined. +-- +-- >>> runBidirectionalState example1 +-- ( Inlined "x" +-- , Inlined "y" +-- ) +example1 :: BidirectionalState (InlineResult, InlineResult) +example1 = do + x <- tryInline "x" + y <- tryInline "y" + pure (x,y) + +-- | try inlining two functions, `x` and `y`. `x` is used twice, so +-- can't be inlined. but `y` is used once, and thus ought to be +-- inlined. +-- +-- >>> runBidirectionalState example2 +-- ( NotInlined "x" +-- , Inlined "y" +-- , NotInlined "x" +-- ) +example2 :: BidirectionalState (InlineResult, InlineResult, InlineResult) +example2 = do + x <- tryInline "x" + y <- tryInline "y" + x' <- tryInline "x" + pure (x,y,x') diff --git a/src/Gyehoek/CPS/Syntax.hs b/src/Gyehoek/CPS/Syntax.hs index c5d434d..561290d 100644 --- a/src/Gyehoek/CPS/Syntax.hs +++ b/src/Gyehoek/CPS/Syntax.hs @@ -326,6 +326,15 @@ instance S.DatumIso Kexp where instance S.DatumIso Program where datumIso = S.with \prog -> S.datumIso @Lambda >>> prog +-- the printed representation is pretty dishonest in its current +-- state. consider the following hoisted program: +-- +-- (letrec ((k (κ () (continue start-ktail 123)))) +-- (λ (start-ktail) +-- (continue k))) +-- +-- here, `start-ktail` is bound in `k`, but the printed representation +-- fails to reflect that. instance S.DatumIso HoistedProgram where datumIso = S.with \prog -> S.letLike "letrec" diff --git a/src/Gyehoek/Driver.hs b/src/Gyehoek/Driver.hs index 8332686..e12955f 100644 --- a/src/Gyehoek/Driver.hs +++ b/src/Gyehoek/Driver.hs @@ -36,6 +36,7 @@ import Gyehoek.Prelude import Gyehoek.Jalmot import qualified Gyehoek.Sexp as S import Gyehoek.CPS.Hoist (hoistProgram) +import Gyehoek.CPS.Contify (contifyProgram) main :: IO () @@ -126,6 +127,9 @@ driver opts = do hoistedCps <- hoistProgram closedCps when opts.dumpHoisted do hPutStrLn FS.stdout =<< S.encodeWith S.datumIso hoistedCps + contifiedCps <- contifyProgram hoistedCps + when opts.dumpContified do + hPutStrLn FS.stdout =<< S.encodeWith S.datumIso contifiedCps 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 c66cda5..eb15c2a 100644 --- a/src/Gyehoek/Options.hs +++ b/src/Gyehoek/Options.hs @@ -30,6 +30,7 @@ data Options = MkOptions , dumpParsed :: Bool , dumpStackified :: Bool , dumpHoisted :: Bool + , dumpContified :: Bool , traceStackified :: Bool , runtime :: Maybe Runtime , inspectWasm :: Bool @@ -63,6 +64,7 @@ parser = do dumpStackified <- switch (long "dump-stackified") dumpParsed <- switch (long "dump-parsed") dumpHoisted <- switch (long "dump-hoisted") + dumpContified <- switch (long "dump-contified") traceStackified <- switch (long "trace-stackified") inspectWasm <- switch $ long "inspect-wasm" <> short 'p' runtime <- option runtimeReader . fold $