From 0aa9fadc50adec315e871ba2fa12bf2cc715eb50 Mon Sep 17 00:00:00 2001 From: pranaysashank Date: Sat, 27 Aug 2022 18:16:50 +0530 Subject: [PATCH] Some change to reduce cpp usage in the Main file. - Made separate modules for each ghc version in the hopes that maintaining them would become easier than the many nested if, else we have in cpp right now. --- fusion-plugin.cabal | 25 ++++ src/Fusion/Plugin.hs | 281 +---------------------------------- src/Fusion/Plugin/Ghc.hs | 47 ++++++ src/Fusion/Plugin/Ghc860.hs | 200 +++++++++++++++++++++++++ src/Fusion/Plugin/Ghc900.hs | 49 ++++++ src/Fusion/Plugin/Ghc920.hs | 133 +++++++++++++++++ src/Fusion/Plugin/Ghc922.hs | 133 +++++++++++++++++ src/Fusion/Plugin/Ghc930.hs | 137 +++++++++++++++++ src/Fusion/Plugin/Ghc940.hs | 138 +++++++++++++++++ src/Fusion/Plugin/GhcHead.hs | 147 ++++++++++++++++++ 10 files changed, 1017 insertions(+), 273 deletions(-) create mode 100644 src/Fusion/Plugin/Ghc.hs create mode 100644 src/Fusion/Plugin/Ghc860.hs create mode 100644 src/Fusion/Plugin/Ghc900.hs create mode 100644 src/Fusion/Plugin/Ghc920.hs create mode 100644 src/Fusion/Plugin/Ghc922.hs create mode 100644 src/Fusion/Plugin/Ghc930.hs create mode 100644 src/Fusion/Plugin/Ghc940.hs create mode 100644 src/Fusion/Plugin/GhcHead.hs diff --git a/fusion-plugin.cabal b/fusion-plugin.cabal index 8720f31..8371a31 100644 --- a/fusion-plugin.cabal +++ b/fusion-plugin.cabal @@ -43,6 +43,31 @@ source-repository head library exposed-modules: Fusion.Plugin + other-modules: + Fusion.Plugin.Ghc + if impl(ghc >= 9.5.0) + other-modules: + Fusion.Plugin.GhcHead + elif impl(ghc >= 9.4.0) + other-modules: + Fusion.Plugin.Ghc940 + elif impl(ghc >= 9.3.0) + other-modules: + Fusion.Plugin.Ghc930 + elif impl(ghc >= 9.2.2) + other-modules: + Fusion.Plugin.Ghc922 + elif impl(ghc >= 9.2.0) + other-modules: + Fusion.Plugin.Ghc920 + elif impl(ghc >= 9.0.0) + other-modules: + Fusion.Plugin.Ghc900 + else + if impl(ghc >= 8.6.0) + other-modules: + Fusion.Plugin.Ghc860 + build-depends: base >= 4.0 && < 5.0 , containers >= 0.5.6.2 && < 0.7 , directory >= 1.2.2.0 && < 1.4 diff --git a/src/Fusion/Plugin.hs b/src/Fusion/Plugin.hs index deff174..d118787 100644 --- a/src/Fusion/Plugin.hs +++ b/src/Fusion/Plugin.hs @@ -58,36 +58,6 @@ import Data.Generics.Schemes (everywhere) import Data.Generics.Aliases (mkT) import Debug.Trace (trace) import qualified Data.List as DL - --- Imports for specific compiler versions -#if MIN_VERSION_ghc(9,2,0) -import Data.Char (isSpace) -import Text.Printf (printf) -import GHC.Core.Ppr (pprCoreBindingsWithSize, pprRules) -import GHC.Types.Name.Ppr (mkPrintUnqualified) -import GHC.Utils.Logger (Logger) -#endif - --- dump-core option related imports -#if MIN_VERSION_ghc(9,3,0) -import GHC.Utils.Logger (putDumpFile, logFlags, LogFlags(..)) -#elif MIN_VERSION_ghc(9,2,0) -import GHC.Utils.Logger (putDumpMsg) -#elif MIN_VERSION_ghc(9,0,0) --- dump core option not supported -#else -import Control.Monad (unless) -import Data.Char (isSpace) -import Data.IORef (readIORef, writeIORef) -import Data.Time (getCurrentTime) -import System.Directory (createDirectoryIfMissing) -import System.FilePath ((), takeDirectory) -import System.IO (Handle, IOMode(..), withFile, hSetEncoding, utf8) -import Text.Printf (printf) -import ErrUtils (mkDumpDoc, Severity(..)) -import PprCore (pprCoreBindingsWithSize, pprRules) -import qualified Data.Set as Set -#endif #endif -- Implicit imports @@ -100,6 +70,7 @@ import GhcPlugins -- Imports from this package import Fusion.Plugin.Types (Fuse(..)) +import qualified Fusion.Plugin.Ghc -- $using -- @@ -684,34 +655,7 @@ fusionMarkInline pass opt failIt transform = ------------------------------------------------------------------------------- fusionSimplify :: HscEnv -> DynFlags -> CoreToDo -fusionSimplify _hsc_env dflags = - let mode = - SimplMode - { sm_phase = InitialPhase - , sm_names = ["Fusion Plugin Inlining"] - , sm_dflags = dflags - , sm_rules = gopt Opt_EnableRewriteRules dflags - , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags - , sm_inline = True - , sm_case_case = True -#if MIN_VERSION_ghc(9,2,0) - , sm_uf_opts = unfoldingOpts dflags - , sm_pre_inline = gopt Opt_SimplPreInlining dflags - , sm_logger = hsc_logger _hsc_env -#endif -#if MIN_VERSION_ghc(9,2,2) - , sm_cast_swizzle = True -#endif -#if MIN_VERSION_ghc(9,5,0) - , sm_float_enable = floatEnable dflags -#endif - } - in CoreDoSimplify -#if MIN_VERSION_ghc(9,5,0) - (CoreDoSimplifyOpts (maxSimplIterations dflags) mode) -#else - (maxSimplIterations dflags) mode -#endif +fusionSimplify = Fusion.Plugin.Ghc.coreToDo ------------------------------------------------------------------------------- -- Report unfused constructors @@ -772,209 +716,12 @@ fusionReport mesg reportMode guts = do -- Dump core passes ------------------------------------------------------------------------------- --- Only for GHC versions before 9.0.0 -#if !MIN_VERSION_ghc(9,0,0) -chooseDumpFile :: DynFlags -> FilePath -> Maybe FilePath -chooseDumpFile dflags suffix - | Just prefix <- getPrefix - - = Just $ setDir (prefix ++ suffix) - - | otherwise - - = Nothing - - where getPrefix - -- dump file location is being forced - -- by the --ddump-file-prefix flag. - | Just prefix <- dumpPrefixForce dflags - = Just prefix - -- dump file location chosen by DriverPipeline.runPipeline - | Just prefix <- dumpPrefix dflags - = Just prefix - -- we haven't got a place to put a dump file. - | otherwise - = Nothing - setDir f = case dumpDir dflags of - Just d -> d f - Nothing -> f - --- Copied from GHC.Utils.Logger -withDumpFileHandle :: DynFlags -> FilePath -> (Maybe Handle -> IO ()) -> IO () -withDumpFileHandle dflags suffix action = do - let mFile = chooseDumpFile dflags suffix - case mFile of - Just fileName -> do - let gdref = generatedDumps dflags - gd <- readIORef gdref - let append = Set.member fileName gd - mode = if append then AppendMode else WriteMode - unless append $ - writeIORef gdref (Set.insert fileName gd) - createDirectoryIfMissing True (takeDirectory fileName) - withFile fileName mode $ \handle -> do - -- We do not want the dump file to be affected by - -- environment variables, but instead to always use - -- UTF8. See: - -- https://gitlab.haskell.org/ghc/ghc/issues/10762 - hSetEncoding handle utf8 - action (Just handle) - Nothing -> action Nothing - -dumpSDocWithStyle :: PprStyle -> DynFlags -> FilePath -> String -> SDoc -> IO () -dumpSDocWithStyle sty dflags suffix hdr doc = - withDumpFileHandle dflags suffix writeDump - where - -- write dump to file - writeDump (Just handle) = do - doc' <- if null hdr - then return doc - else do t <- getCurrentTime - let timeStamp = if (gopt Opt_SuppressTimestamps dflags) - then empty - else text (show t) - let d = timeStamp - $$ blankLine - $$ doc - return $ mkDumpDoc hdr d - defaultLogActionHPrintDoc dflags handle doc' sty - - -- write the dump to stdout - writeDump Nothing = do - let (doc', severity) - | null hdr = (doc, SevOutput) - | otherwise = (mkDumpDoc hdr doc, SevDump) - putLogMsg dflags NoReason severity noSrcSpan sty doc' - -dumpSDoc :: DynFlags -> PrintUnqualified -> FilePath -> String -> SDoc -> IO () -dumpSDoc dflags print_unqual - = dumpSDocWithStyle dump_style dflags - where dump_style = mkDumpStyle dflags print_unqual -#endif - --- dump core not supported on 9.0.0, 9.0.0 does not export Logger -#if __GLASGOW_HASKELL__!=900 --- Only for GHC versions >= 9.2.0 -#if MIN_VERSION_ghc(9,2,0) -dumpPassResult :: - Logger - -> DynFlags - -> PrintUnqualified - -> SDoc -- Header - -> SDoc -- Extra info to appear after header - -> CoreProgram -> [CoreRule] - -> IO () -dumpPassResult logger dflags unqual hdr extra_info binds rules = do -#if MIN_VERSION_ghc(9,3,0) - let flags = logFlags logger - let getDumpAction = putDumpFile -#else - let flags = dflags - let getDumpAction = putDumpMsg -#endif - (getDumpAction logger) - flags dump_style Opt_D_dump_simpl title undefined dump_doc - - where - - title = showSDoc dflags hdr - - dump_style = mkDumpStyle unqual - -#else - -dumpPassResult :: DynFlags - -> PrintUnqualified - -> FilePath - -> SDoc -- Header - -> SDoc -- Extra info to appear after header - -> CoreProgram -> [CoreRule] - -> IO () -dumpPassResult dflags unqual suffix hdr extra_info binds rules = do - dumpSDoc dflags unqual suffix (showSDoc dflags hdr) dump_doc - - where - -#endif - dump_doc = vcat [ nest 2 extra_info - , blankLine - , pprCoreBindingsWithSize binds - , ppUnless (null rules) pp_rules ] - pp_rules = vcat [ blankLine - , text "------ Local rules for imported ids --------" - , pprRules rules ] - -filterOutLast :: (a -> Bool) -> [a] -> [a] -filterOutLast _ [] = [] -filterOutLast p [x] - | p x = [] - | otherwise = [x] -filterOutLast p (x:xs) = x : filterOutLast p xs - -dumpResult -#if MIN_VERSION_ghc(9,2,0) - :: Logger - -> DynFlags -#else - :: DynFlags -#endif - -> PrintUnqualified - -> Int - -> SDoc - -> CoreProgram - -> [CoreRule] - -> IO () -#if MIN_VERSION_ghc(9,2,0) -dumpResult logger dflags print_unqual counter todo binds rules = - dumpPassResult logger1 dflags print_unqual hdr (text "") binds rules -#else -dumpResult dflags print_unqual counter todo binds rules = - dumpPassResult - dflags print_unqual (_suffix ++ "dump-simpl") hdr (text "") binds rules -#endif - - where - - hdr = text "[" - GhcPlugins.<> int counter - GhcPlugins.<> text "] " - GhcPlugins.<> todo - - _suffix = printf "%02d" counter ++ "-" - ++ (map (\x -> if isSpace x then '-' else x) - $ filterOutLast isSpace - $ takeWhile (/= '(') - $ showSDoc dflags todo) - ++ "." - -#if MIN_VERSION_ghc(9,4,0) - prefix = log_dump_prefix (logFlags logger) ++ _suffix - logger1 = logger {logFlags = (logFlags logger) {log_dump_prefix = prefix}} -#elif MIN_VERSION_ghc(9,2,0) - logger1 = logger -#endif -#endif - dumpCore :: Int -> SDoc -> ModGuts -> CoreM ModGuts dumpCore counter title guts = do dflags <- getDynFlags putMsgS $ "fusion-plugin: dumping core " ++ show counter ++ " " ++ showSDoc dflags title - -#if MIN_VERSION_ghc(9,2,0) - hscEnv <- getHscEnv - let logger = hsc_logger hscEnv - let print_unqual = - mkPrintUnqualified (hsc_unit_env hscEnv) (mg_rdr_env guts) - liftIO $ dumpResult logger dflags print_unqual counter - title (mg_binds guts) (mg_rules guts) -#elif MIN_VERSION_ghc(9,0,0) - putMsgS $ "fusion-plugin: dump-core not supported on GHC 9.0 " -#else - let print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts) - liftIO $ dumpResult dflags print_unqual counter - title (mg_binds guts) (mg_rules guts) -#endif + Fusion.Plugin.Ghc.dumpCore counter title guts return guts dumpCorePass :: Int -> SDoc -> CoreToDo @@ -1002,19 +749,10 @@ insertAfterSimplPhase0 origTodos ourTodos report = where go False [] = error "Simplifier phase 0/\"main\" not found" go True [] = [] -#if MIN_VERSION_ghc(9,5,0) - go _ (todo@(CoreDoSimplify (CoreDoSimplifyOpts _ SimplMode - { sm_phase = Phase 0 - , sm_names = ["main"] - })):todos) -#else - go _ (todo@(CoreDoSimplify _ SimplMode - { sm_phase = Phase 0 - , sm_names = ["main"] - }):todos) -#endif - = todo : ourTodos ++ go True todos - go found (todo:todos) = todo : go found todos + go found (todo:todos) = + if Fusion.Plugin.Ghc.isPhase0MainTodo todo + then todo : ourTodos ++ go True todos + else todo : go found todos install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] install args todos = do @@ -1058,9 +796,6 @@ install _ todos = do #endif plugin :: Plugin -plugin = defaultPlugin +plugin = Fusion.Plugin.Ghc.defaultPurePlugin { installCoreToDos = install -#if MIN_VERSION_ghc(8,6,0) - , pluginRecompile = purePlugin -#endif } diff --git a/src/Fusion/Plugin/Ghc.hs b/src/Fusion/Plugin/Ghc.hs new file mode 100644 index 0000000..6b6150f --- /dev/null +++ b/src/Fusion/Plugin/Ghc.hs @@ -0,0 +1,47 @@ +-- | +-- Module : Fusion.Plugin.Ghc +-- Copyright : (c) 2022 Composewell Technologies +-- +-- License : Apache-2.0 +-- Maintainer : ps@pranaysashank.com +-- Stability : experimental +-- Portability : GHC + +{-# LANGUAGE CPP #-} + +#if MIN_VERSION_ghc(8,6,0) +module Fusion.Plugin.Ghc + ( coreToDo + , dumpCore + , isPhase0MainTodo + , defaultPurePlugin + ) +where + +#if MIN_VERSION_ghc(9,5,0) +import Fusion.Plugin.GhcHead +#elif MIN_VERSION_ghc(9,4,0) +import Fusion.Plugin.Ghc940 +#elif MIN_VERSION_ghc(9,3,0) +import Fusion.Plugin.Ghc930 +#elif MIN_VERSION_ghc(9,2,2) +import Fusion.Plugin.Ghc922 +#elif MIN_VERSION_ghc(9,2,0) +import Fusion.Plugin.Ghc920 +#elif MIN_VERSION_ghc(9,0,0) +import Fusion.Plugin.Ghc900 +#elif MIN_VERSION_ghc(8,6,0) +import Fusion.Plugin.Ghc860 +#endif +#else +module Fusion.Plugin.Ghc + ( defaultPurePlugin + ) +where + +import GhcPlugins + +defaultPurePlugin :: Plugin +defaultPurePlugin = defaultPlugin + +#endif diff --git a/src/Fusion/Plugin/Ghc860.hs b/src/Fusion/Plugin/Ghc860.hs new file mode 100644 index 0000000..49e522e --- /dev/null +++ b/src/Fusion/Plugin/Ghc860.hs @@ -0,0 +1,200 @@ +-- | +-- Module : Fusion.Plugin.Ghc860 +-- Copyright : (c) 2019 Composewell Technologies +-- License : Apache-2.0 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- + +module Fusion.Plugin.Ghc860 + ( coreToDo + , dumpCore + , isPhase0MainTodo + , defaultPurePlugin + ) +where + +import Control.Monad (unless) +import Data.Char (isSpace) +import Data.IORef (readIORef, writeIORef) +import Data.Time (getCurrentTime) +import System.Directory (createDirectoryIfMissing) +import System.FilePath ((), takeDirectory) +import System.IO (Handle, IOMode(..), withFile, hSetEncoding, utf8) +import Text.Printf (printf) +import ErrUtils (mkDumpDoc, Severity(..)) +import PprCore (pprCoreBindingsWithSize, pprRules) +import qualified Data.Set as Set + +-- Implicit imports +import GhcPlugins + +------------------------------------------------------------------------------- +-- Simplification pass after marking inline +------------------------------------------------------------------------------- + +coreToDo :: HscEnv -> DynFlags -> CoreToDo +coreToDo _hsc_env dflags = + let mode = + SimplMode + { sm_phase = InitialPhase + , sm_names = ["Fusion Plugin Inlining"] + , sm_dflags = dflags + , sm_rules = gopt Opt_EnableRewriteRules dflags + , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags + , sm_inline = True + , sm_case_case = True + } + in CoreDoSimplify + (maxSimplIterations dflags) mode + +chooseDumpFile :: DynFlags -> FilePath -> Maybe FilePath +chooseDumpFile dflags suffix + | Just prefix <- getPrefix + + = Just $ setDir (prefix ++ suffix) + + | otherwise + + = Nothing + + where getPrefix + -- dump file location is being forced + -- by the --ddump-file-prefix flag. + | Just prefix <- dumpPrefixForce dflags + = Just prefix + -- dump file location chosen by DriverPipeline.runPipeline + | Just prefix <- dumpPrefix dflags + = Just prefix + -- we haven't got a place to put a dump file. + | otherwise + = Nothing + setDir f = case dumpDir dflags of + Just d -> d f + Nothing -> f + +-- Copied from GHC.Utils.Logger +withDumpFileHandle :: DynFlags -> FilePath -> (Maybe Handle -> IO ()) -> IO () +withDumpFileHandle dflags suffix action = do + let mFile = chooseDumpFile dflags suffix + case mFile of + Just fileName -> do + let gdref = generatedDumps dflags + gd <- readIORef gdref + let append = Set.member fileName gd + mode = if append then AppendMode else WriteMode + unless append $ + writeIORef gdref (Set.insert fileName gd) + createDirectoryIfMissing True (takeDirectory fileName) + withFile fileName mode $ \handle -> do + -- We do not want the dump file to be affected by + -- environment variables, but instead to always use + -- UTF8. See: + -- https://gitlab.haskell.org/ghc/ghc/issues/10762 + hSetEncoding handle utf8 + action (Just handle) + Nothing -> action Nothing + +dumpSDocWithStyle :: PprStyle -> DynFlags -> FilePath -> String -> SDoc -> IO () +dumpSDocWithStyle sty dflags suffix hdr doc = + withDumpFileHandle dflags suffix writeDump + where + -- write dump to file + writeDump (Just handle) = do + doc' <- if null hdr + then return doc + else do t <- getCurrentTime + let timeStamp = if (gopt Opt_SuppressTimestamps dflags) + then empty + else text (show t) + let d = timeStamp + $$ blankLine + $$ doc + return $ mkDumpDoc hdr d + defaultLogActionHPrintDoc dflags handle doc' sty + + -- write the dump to stdout + writeDump Nothing = do + let (doc', severity) + | null hdr = (doc, SevOutput) + | otherwise = (mkDumpDoc hdr doc, SevDump) + putLogMsg dflags NoReason severity noSrcSpan sty doc' + +dumpSDoc :: DynFlags -> PrintUnqualified -> FilePath -> String -> SDoc -> IO () +dumpSDoc dflags print_unqual + = dumpSDocWithStyle dump_style dflags + where dump_style = mkDumpStyle dflags print_unqual + +dumpPassResult :: DynFlags + -> PrintUnqualified + -> FilePath + -> SDoc -- Header + -> SDoc -- Extra info to appear after header + -> CoreProgram -> [CoreRule] + -> IO () +dumpPassResult dflags unqual suffix hdr extra_info binds rules = do + dumpSDoc dflags unqual suffix (showSDoc dflags hdr) dump_doc + + where + + dump_doc = vcat [ nest 2 extra_info + , blankLine + , pprCoreBindingsWithSize binds + , ppUnless (null rules) pp_rules ] + pp_rules = vcat [ blankLine + , text "------ Local rules for imported ids --------" + , pprRules rules ] + +filterOutLast :: (a -> Bool) -> [a] -> [a] +filterOutLast _ [] = [] +filterOutLast p [x] + | p x = [] + | otherwise = [x] +filterOutLast p (x:xs) = x : filterOutLast p xs + + +dumpResult + :: DynFlags + -> PrintUnqualified + -> Int + -> SDoc + -> CoreProgram + -> [CoreRule] + -> IO () +dumpResult dflags print_unqual counter todo binds rules = + dumpPassResult + dflags print_unqual (_suffix ++ "dump-simpl") hdr (text "") binds rules + + where + + hdr = text "[" + GhcPlugins.<> int counter + GhcPlugins.<> text "] " + GhcPlugins.<> todo + + _suffix = printf "%02d" counter ++ "-" + ++ (map (\x -> if isSpace x then '-' else x) + $ filterOutLast isSpace + $ takeWhile (/= '(') + $ showSDoc dflags todo) + ++ "." + +dumpCore :: Int -> SDoc -> ModGuts -> CoreM () +dumpCore counter title guts = do + dflags <- getDynFlags + let print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts) + liftIO $ dumpResult dflags print_unqual counter + title (mg_binds guts) (mg_rules guts) + +isPhase0MainTodo :: CoreToDo -> Bool +isPhase0MainTodo (CoreDoSimplify _ SimplMode + { sm_phase = Phase 0 + , sm_names = ["main"] + }) = True +isPhase0MainTodo _ = False + +defaultPurePlugin :: Plugin +defaultPurePlugin = defaultPlugin + { pluginRecompile = purePlugin + } diff --git a/src/Fusion/Plugin/Ghc900.hs b/src/Fusion/Plugin/Ghc900.hs new file mode 100644 index 0000000..488980e --- /dev/null +++ b/src/Fusion/Plugin/Ghc900.hs @@ -0,0 +1,49 @@ +-- | +-- Module : Fusion.Plugin.Ghc900 +-- Copyright : (c) 2019 Composewell Technologies +-- License : Apache-2.0 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- + +module Fusion.Plugin.Ghc900 + ( coreToDo + , dumpCore + , isPhase0MainTodo + , defaultPurePlugin + ) +where + +import GHC.Plugins + +coreToDo :: HscEnv -> DynFlags -> CoreToDo +coreToDo _hsc_env dflags = + let mode = + SimplMode + { sm_phase = InitialPhase + , sm_names = ["Fusion Plugin Inlining"] + , sm_dflags = dflags + , sm_rules = gopt Opt_EnableRewriteRules dflags + , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags + , sm_inline = True + , sm_case_case = True + } + in CoreDoSimplify + (maxSimplIterations dflags) mode + +dumpCore :: Int -> SDoc -> ModGuts -> CoreM () +dumpCore _ _ _ = do + putMsgS $ "fusion-plugin: dump-core not supported on GHC 9.0 " + +isPhase0MainTodo :: CoreToDo -> Bool +isPhase0MainTodo (CoreDoSimplify _ SimplMode + { sm_phase = Phase 0 + , sm_names = ["main"] + }) = True +isPhase0MainTodo _ = False + +defaultPurePlugin :: Plugin +defaultPurePlugin = defaultPlugin + { pluginRecompile = purePlugin + } diff --git a/src/Fusion/Plugin/Ghc920.hs b/src/Fusion/Plugin/Ghc920.hs new file mode 100644 index 0000000..75b73bf --- /dev/null +++ b/src/Fusion/Plugin/Ghc920.hs @@ -0,0 +1,133 @@ +-- | +-- Module : Fusion.Plugin.Ghc920 +-- Copyright : (c) 2019 Composewell Technologies +-- License : Apache-2.0 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- + +module Fusion.Plugin.Ghc920 + ( coreToDo + , dumpCore + , isPhase0MainTodo + , defaultPurePlugin + ) +where + +import Data.Char (isSpace) +import Text.Printf (printf) +import GHC.Core.Ppr (pprCoreBindingsWithSize, pprRules) +import GHC.Types.Name.Ppr (mkPrintUnqualified) +import GHC.Utils.Logger (Logger) +import GHC.Utils.Logger (putDumpMsg) + +-- Implicit imports + +import GHC.Plugins +import qualified GHC.Plugins as GhcPlugins + +coreToDo :: HscEnv -> DynFlags -> CoreToDo +coreToDo _hsc_env dflags = + let mode = + SimplMode + { sm_phase = InitialPhase + , sm_names = ["Fusion Plugin Inlining"] + , sm_dflags = dflags + , sm_rules = gopt Opt_EnableRewriteRules dflags + , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags + , sm_inline = True + , sm_case_case = True + , sm_uf_opts = unfoldingOpts dflags + , sm_pre_inline = gopt Opt_SimplPreInlining dflags + , sm_logger = hsc_logger _hsc_env + } + in CoreDoSimplify + (maxSimplIterations dflags) mode + +------------------------------------------------------------------------------- +-- Dump core passes +------------------------------------------------------------------------------- + +dumpPassResult :: + Logger + -> DynFlags + -> PrintUnqualified + -> SDoc -- Header + -> SDoc -- Extra info to appear after header + -> CoreProgram -> [CoreRule] + -> IO () +dumpPassResult logger dflags unqual hdr extra_info binds rules = do + let flags = dflags + let getDumpAction = putDumpMsg + (getDumpAction logger) + flags dump_style Opt_D_dump_simpl title undefined dump_doc + where + + title = showSDoc dflags hdr + + dump_style = mkDumpStyle unqual + + dump_doc = vcat [ nest 2 extra_info + , blankLine + , pprCoreBindingsWithSize binds + , ppUnless (null rules) pp_rules ] + pp_rules = vcat [ blankLine + , text "------ Local rules for imported ids --------" + , pprRules rules ] + +filterOutLast :: (a -> Bool) -> [a] -> [a] +filterOutLast _ [] = [] +filterOutLast p [x] + | p x = [] + | otherwise = [x] +filterOutLast p (x:xs) = x : filterOutLast p xs + +dumpResult + :: Logger + -> DynFlags + -> PrintUnqualified + -> Int + -> SDoc + -> CoreProgram + -> [CoreRule] + -> IO () +dumpResult logger dflags print_unqual counter todo binds rules = + dumpPassResult logger1 dflags print_unqual hdr (text "") binds rules + where + + hdr = text "[" + GhcPlugins.<> int counter + GhcPlugins.<> text "] " + GhcPlugins.<> todo + + _suffix = printf "%02d" counter ++ "-" + ++ (map (\x -> if isSpace x then '-' else x) + $ filterOutLast isSpace + $ takeWhile (/= '(') + $ showSDoc dflags todo) + ++ "." + + logger1 = logger + +dumpCore :: Int -> SDoc -> ModGuts -> CoreM () +dumpCore counter title guts = do + dflags <- getDynFlags + hscEnv <- getHscEnv + let logger = hsc_logger hscEnv + let print_unqual = + mkPrintUnqualified (hsc_unit_env hscEnv) (mg_rdr_env guts) + liftIO $ dumpResult logger dflags print_unqual counter + title (mg_binds guts) (mg_rules guts) + +isPhase0MainTodo :: CoreToDo -> Bool +isPhase0MainTodo (CoreDoSimplify _ SimplMode + { sm_phase = Phase 0 + , sm_names = ["main"] + }) = True +isPhase0MainTodo = False + +defaultPurePlugin :: Plugin +defaultPurePlugin = defaultPlugin + { pluginRecompile = purePlugin + } diff --git a/src/Fusion/Plugin/Ghc922.hs b/src/Fusion/Plugin/Ghc922.hs new file mode 100644 index 0000000..dbb85bc --- /dev/null +++ b/src/Fusion/Plugin/Ghc922.hs @@ -0,0 +1,133 @@ +-- | +-- Module : Fusion.Plugin.Ghc922 +-- Copyright : (c) 2019 Composewell Technologies +-- License : Apache-2.0 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- + +module Fusion.Plugin.Ghc922 + ( coreToDo + , dumpCore + , isPhase0MainTodo + , defaultPurePlugin + ) +where + +import Data.Char (isSpace) +import Text.Printf (printf) +import GHC.Core.Ppr (pprCoreBindingsWithSize, pprRules) +import GHC.Types.Name.Ppr (mkPrintUnqualified) +import GHC.Utils.Logger (Logger) +import GHC.Utils.Logger (putDumpMsg) + +import GHC.Plugins +import qualified GHC.Plugins as GhcPlugins + +coreToDo :: HscEnv -> DynFlags -> CoreToDo +coreToDo _hsc_env dflags = + let mode = + SimplMode + { sm_phase = InitialPhase + , sm_names = ["Fusion Plugin Inlining"] + , sm_dflags = dflags + , sm_rules = gopt Opt_EnableRewriteRules dflags + , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags + , sm_inline = True + , sm_case_case = True + + , sm_uf_opts = unfoldingOpts dflags + , sm_pre_inline = gopt Opt_SimplPreInlining dflags + , sm_logger = hsc_logger _hsc_env + , sm_cast_swizzle = True + } + in CoreDoSimplify + (maxSimplIterations dflags) mode + +dumpPassResult :: + Logger + -> DynFlags + -> PrintUnqualified + -> SDoc -- Header + -> SDoc -- Extra info to appear after header + -> CoreProgram -> [CoreRule] + -> IO () +dumpPassResult logger dflags unqual hdr extra_info binds rules = do + let flags = dflags + let getDumpAction = putDumpMsg + (getDumpAction logger) + flags dump_style Opt_D_dump_simpl title undefined dump_doc + + where + + title = showSDoc dflags hdr + + dump_style = mkDumpStyle unqual + + dump_doc = vcat [ nest 2 extra_info + , blankLine + , pprCoreBindingsWithSize binds + , ppUnless (null rules) pp_rules ] + pp_rules = vcat [ blankLine + , text "------ Local rules for imported ids --------" + , pprRules rules ] + +filterOutLast :: (a -> Bool) -> [a] -> [a] +filterOutLast _ [] = [] +filterOutLast p [x] + | p x = [] + | otherwise = [x] +filterOutLast p (x:xs) = x : filterOutLast p xs + +dumpResult + :: Logger + -> DynFlags + -> PrintUnqualified + -> Int + -> SDoc + -> CoreProgram + -> [CoreRule] + -> IO () +dumpResult logger dflags print_unqual counter todo binds rules = + dumpPassResult logger1 dflags print_unqual hdr (text "") binds rules + + where + + hdr = text "[" + GhcPlugins.<> int counter + GhcPlugins.<> text "] " + GhcPlugins.<> todo + + _suffix = printf "%02d" counter ++ "-" + ++ (map (\x -> if isSpace x then '-' else x) + $ filterOutLast isSpace + $ takeWhile (/= '(') + $ showSDoc dflags todo) + ++ "." + + logger1 = logger + + +dumpCore :: Int -> SDoc -> ModGuts -> CoreM () +dumpCore counter title guts = do + dflags <- getDynFlags + hscEnv <- getHscEnv + let logger = hsc_logger hscEnv + let print_unqual = + mkPrintUnqualified (hsc_unit_env hscEnv) (mg_rdr_env guts) + liftIO $ dumpResult logger dflags print_unqual counter + title (mg_binds guts) (mg_rules guts) + + +isPhase0MainTodo :: CoreToDo -> Bool +isPhase0MainTodo (CoreDoSimplify _ SimplMode + { sm_phase = Phase 0 + , sm_names = ["main"] + }) = True +isPhase0MainTodo _ = False + +defaultPurePlugin :: Plugin +defaultPurePlugin = defaultPlugin + { pluginRecompile = purePlugin + } diff --git a/src/Fusion/Plugin/Ghc930.hs b/src/Fusion/Plugin/Ghc930.hs new file mode 100644 index 0000000..44a8e76 --- /dev/null +++ b/src/Fusion/Plugin/Ghc930.hs @@ -0,0 +1,137 @@ +-- | +-- Module : Fusion.Plugin.Ghc930 +-- Copyright : (c) 2019 Composewell Technologies +-- License : Apache-2.0 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- + +module Fusion.Plugin.Ghc930 + ( coreToDo + , dumpCore + , isPhase0MainTodo + , defaultPurePlugin + ) +where + +-- Imports for specific compiler versions +import Data.Char (isSpace) +import Text.Printf (printf) +import GHC.Core.Ppr (pprCoreBindingsWithSize, pprRules) +import GHC.Types.Name.Ppr (mkPrintUnqualified) +import GHC.Utils.Logger (Logger) +import GHC.Utils.Logger (putDumpFile, logFlags, LogFlags(..)) + +-- Implicit imports + +import GHC.Plugins +import qualified GHC.Plugins as GhcPlugins + +coreToDo :: HscEnv -> DynFlags -> CoreToDo +coreToDo _hsc_env dflags = + let mode = + SimplMode + { sm_phase = InitialPhase + , sm_names = ["Fusion Plugin Inlining"] + , sm_dflags = dflags + , sm_rules = gopt Opt_EnableRewriteRules dflags + , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags + , sm_inline = True + , sm_case_case = True + , sm_uf_opts = unfoldingOpts dflags + , sm_pre_inline = gopt Opt_SimplPreInlining dflags + , sm_logger = hsc_logger _hsc_env + , sm_cast_swizzle = True + } + in CoreDoSimplify + (maxSimplIterations dflags) mode + +------------------------------------------------------------------------------- +-- Dump core passes +------------------------------------------------------------------------------- + +dumpPassResult :: + Logger + -> DynFlags + -> PrintUnqualified + -> SDoc -- Header + -> SDoc -- Extra info to appear after header + -> CoreProgram -> [CoreRule] + -> IO () +dumpPassResult logger dflags unqual hdr extra_info binds rules = do + let flags = logFlags logger + let getDumpAction = putDumpFile + (getDumpAction logger) + flags dump_style Opt_D_dump_simpl title undefined dump_doc + + where + + title = showSDoc dflags hdr + + dump_style = mkDumpStyle unqual + + dump_doc = vcat [ nest 2 extra_info + , blankLine + , pprCoreBindingsWithSize binds + , ppUnless (null rules) pp_rules ] + pp_rules = vcat [ blankLine + , text "------ Local rules for imported ids --------" + , pprRules rules ] + +filterOutLast :: (a -> Bool) -> [a] -> [a] +filterOutLast _ [] = [] +filterOutLast p [x] + | p x = [] + | otherwise = [x] +filterOutLast p (x:xs) = x : filterOutLast p xs + +dumpResult + :: Logger + -> DynFlags + -> PrintUnqualified + -> Int + -> SDoc + -> CoreProgram + -> [CoreRule] + -> IO () +dumpResult logger dflags print_unqual counter todo binds rules = + dumpPassResult logger1 dflags print_unqual hdr (text "") binds rules + + where + + hdr = text "[" + GhcPlugins.<> int counter + GhcPlugins.<> text "] " + GhcPlugins.<> todo + + _suffix = printf "%02d" counter ++ "-" + ++ (map (\x -> if isSpace x then '-' else x) + $ filterOutLast isSpace + $ takeWhile (/= '(') + $ showSDoc dflags todo) + ++ "." + + logger1 = logger + +dumpCore :: Int -> SDoc -> ModGuts -> CoreM () +dumpCore counter title guts = do + dflags <- getDynFlags + hscEnv <- getHscEnv + let logger = hsc_logger hscEnv + let print_unqual = + mkPrintUnqualified (hsc_unit_env hscEnv) (mg_rdr_env guts) + liftIO $ dumpResult logger dflags print_unqual counter + title (mg_binds guts) (mg_rules guts) + +isPhase0MainTodo :: CoreToDo :: Bool +isPhase0MainTodo (CoreDoSimplify _ SimplMode + { sm_phase = Phase 0 + , sm_names = ["main"] + }) = True +isPhase0MainTodo _ = False + +defaultPurePlugin :: Plugin +defaultPurePlugin = defaultPlugin + { pluginRecompile = purePlugin + } diff --git a/src/Fusion/Plugin/Ghc940.hs b/src/Fusion/Plugin/Ghc940.hs new file mode 100644 index 0000000..af4094e --- /dev/null +++ b/src/Fusion/Plugin/Ghc940.hs @@ -0,0 +1,138 @@ +-- | +-- Module : Fusion.Plugin.Ghc940 +-- Copyright : (c) 2019 Composewell Technologies +-- License : Apache-2.0 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- + +module Fusion.Plugin.Ghc940 + ( coreToDo + , dumpCore + , isPhase0MainTodo + , defaultPurePlugin + ) +where + +import Data.Char (isSpace) +import Text.Printf (printf) +import GHC.Core.Ppr (pprCoreBindingsWithSize, pprRules) +import GHC.Types.Name.Ppr (mkPrintUnqualified) +import GHC.Utils.Logger (Logger) +import GHC.Utils.Logger (putDumpFile, logFlags, LogFlags(..)) + +-- Implicit imports + +import GHC.Plugins +import qualified GHC.Plugins as GhcPlugins + +coreToDo :: HscEnv -> DynFlags -> CoreToDo +coreToDo _hsc_env dflags = + let mode = + SimplMode + { sm_phase = InitialPhase + , sm_names = ["Fusion Plugin Inlining"] + , sm_dflags = dflags + , sm_rules = gopt Opt_EnableRewriteRules dflags + , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags + , sm_inline = True + , sm_case_case = True + , sm_uf_opts = unfoldingOpts dflags + , sm_pre_inline = gopt Opt_SimplPreInlining dflags + , sm_logger = hsc_logger _hsc_env + , sm_cast_swizzle = True + } + in CoreDoSimplify + (maxSimplIterations dflags) mode + +------------------------------------------------------------------------------- +-- Dump core passes +------------------------------------------------------------------------------- + +dumpPassResult :: + Logger + -> DynFlags + -> PrintUnqualified + -> SDoc -- Header + -> SDoc -- Extra info to appear after header + -> CoreProgram -> [CoreRule] + -> IO () +dumpPassResult logger dflags unqual hdr extra_info binds rules = do + let flags = logFlags logger + let getDumpAction = putDumpFile + (getDumpAction logger) + flags dump_style Opt_D_dump_simpl title undefined dump_doc + + where + + title = showSDoc dflags hdr + + dump_style = mkDumpStyle unqual + + dump_doc = vcat [ nest 2 extra_info + , blankLine + , pprCoreBindingsWithSize binds + , ppUnless (null rules) pp_rules ] + pp_rules = vcat [ blankLine + , text "------ Local rules for imported ids --------" + , pprRules rules ] + +filterOutLast :: (a -> Bool) -> [a] -> [a] +filterOutLast _ [] = [] +filterOutLast p [x] + | p x = [] + | otherwise = [x] +filterOutLast p (x:xs) = x : filterOutLast p xs + +dumpResult + :: Logger + -> DynFlags + -> PrintUnqualified + -> Int + -> SDoc + -> CoreProgram + -> [CoreRule] + -> IO () +dumpResult logger dflags print_unqual counter todo binds rules = + dumpPassResult logger1 dflags print_unqual hdr (text "") binds rules + + where + + hdr = text "[" + GhcPlugins.<> int counter + GhcPlugins.<> text "] " + GhcPlugins.<> todo + + _suffix = printf "%02d" counter ++ "-" + ++ (map (\x -> if isSpace x then '-' else x) + $ filterOutLast isSpace + $ takeWhile (/= '(') + $ showSDoc dflags todo) + ++ "." + + prefix = log_dump_prefix (logFlags logger) ++ _suffix + + logger1 = logger {logFlags = (logFlags logger) {log_dump_prefix = prefix}} + +dumpCore :: Int -> SDoc -> ModGuts -> CoreM () +dumpCore counter title guts = do + dflags <- getDynFlags + hscEnv <- getHscEnv + let logger = hsc_logger hscEnv + let print_unqual = + mkPrintUnqualified (hsc_unit_env hscEnv) (mg_rdr_env guts) + liftIO $ dumpResult logger dflags print_unqual counter + title (mg_binds guts) (mg_rules guts) + +isPhase0MainTodo :: CoreToDo -> Bool +isPhase0MainTodo (CoreDoSimplify _ SimplMode + { sm_phase = Phase 0 + , sm_names = ["main"] + }) = True +isPhase0MainTodo _ = False + +defaultPurePlugin :: Plugin +defaultPurePlugin = defaultPlugin + { pluginRecompile = purePlugin + } diff --git a/src/Fusion/Plugin/GhcHead.hs b/src/Fusion/Plugin/GhcHead.hs new file mode 100644 index 0000000..282ef20 --- /dev/null +++ b/src/Fusion/Plugin/GhcHead.hs @@ -0,0 +1,147 @@ +-- | +-- Module : Fusion.Plugin.GhcHead +-- Copyright : (c) 2019 Composewell Technologies +-- License : Apache-2.0 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- + +module Fusion.Plugin.GhcHead + ( coreToDo + , dumpCore + , isPhase0MainTodo + , defaultPurePlugin + ) +where + +-- Imports for specific compiler versions + +import Data.Char (isSpace) +import Text.Printf (printf) +import GHC.Core.Ppr (pprCoreBindingsWithSize, pprRules) +import GHC.Types.Name.Ppr (mkPrintUnqualified) +import GHC.Utils.Logger (Logger) + +import GHC.Utils.Logger (putDumpFile, logFlags, LogFlags(..)) + +-- Implicit imports + +import GHC.Plugins +import qualified GHC.Plugins as GhcPlugins + +-- Imports from this package +import Fusion.Plugin.Types (Fuse(..)) + +coreToDo :: HscEnv -> DynFlags -> CoreToDo +coreToDo _hsc_env dflags = + let mode = + SimplMode + { sm_phase = InitialPhase + , sm_names = ["Fusion Plugin Inlining"] + , sm_dflags = dflags + , sm_rules = gopt Opt_EnableRewriteRules dflags + , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags + , sm_inline = True + , sm_case_case = True + , sm_uf_opts = unfoldingOpts dflags + , sm_pre_inline = gopt Opt_SimplPreInlining dflags + , sm_logger = hsc_logger _hsc_env + , sm_cast_swizzle = True + , sm_float_enable = floatEnable dflags + } + in CoreDoSimplify + (CoreDoSimplifyOpts (maxSimplIterations dflags) mode) + +------------------------------------------------------------------------------- +-- Dump core passes +------------------------------------------------------------------------------- + +dumpPassResult :: + Logger + -> DynFlags + -> PrintUnqualified + -> SDoc -- Header + -> SDoc -- Extra info to appear after header + -> CoreProgram -> [CoreRule] + -> IO () +dumpPassResult logger dflags unqual hdr extra_info binds rules = do + let flags = logFlags logger + let getDumpAction = putDumpFile + (getDumpAction logger) + flags dump_style Opt_D_dump_simpl title undefined dump_doc + + where + + title = showSDoc dflags hdr + + dump_style = mkDumpStyle unqual + +# 906 "src/Fusion/Plugin.hs" + dump_doc = vcat [ nest 2 extra_info + , blankLine + , pprCoreBindingsWithSize binds + , ppUnless (null rules) pp_rules ] + pp_rules = vcat [ blankLine + , text "------ Local rules for imported ids --------" + , pprRules rules ] + +filterOutLast :: (a -> Bool) -> [a] -> [a] +filterOutLast _ [] = [] +filterOutLast p [x] + | p x = [] + | otherwise = [x] +filterOutLast p (x:xs) = x : filterOutLast p xs + +dumpResult + :: Logger + -> DynFlags + -> PrintUnqualified + -> Int + -> SDoc + -> CoreProgram + -> [CoreRule] + -> IO () +dumpResult logger dflags print_unqual counter todo binds rules = + dumpPassResult logger1 dflags print_unqual hdr (text "") binds rules + + where + + hdr = text "[" + GhcPlugins.<> int counter + GhcPlugins.<> text "] " + GhcPlugins.<> todo + + _suffix = printf "%02d" counter ++ "-" + ++ (map (\x -> if isSpace x then '-' else x) + $ filterOutLast isSpace + $ takeWhile (/= '(') + $ showSDoc dflags todo) + ++ "." + + + prefix = log_dump_prefix (logFlags logger) ++ _suffix + + logger1 = logger {logFlags = (logFlags logger) {log_dump_prefix = prefix}} + +dumpCore :: Int -> SDoc -> ModGuts -> CoreM () +dumpCore counter title guts = do + dflags <- getDynFlags + hscEnv <- getHscEnv + let logger = hsc_logger hscEnv + let print_unqual = + mkPrintUnqualified (hsc_unit_env hscEnv) (mg_rdr_env guts) + liftIO $ dumpResult logger dflags print_unqual counter + title (mg_binds guts) (mg_rules guts) + +isPhase0MainTodo :: CoreToDo -> Bool +isPhase0MainTodo (CoreDoSimplify (CoreDoSimplifyOpts _ SimplMode + { sm_phase = Phase 0 + , sm_names = ["main"] + })) = True +isPhase0MainTodo = False + +defaultPurePlugin :: Plugin +defaultPurePlugin = defaultPlugin + { pluginRecompile = purePlugin + }