gyehoek.cabal

@@ -121,6 +121,7 @@ library
     , typed-process
     , unordered-containers
     , vector
+    , tardis
 
   hs-source-dirs:   src
   default-language: GHC2024

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')

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"

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)

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 $