diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## 0.2.3 + +* Enhancement: Support ghc-9.0.1 +* Note: `dump-core` command line flag does not work for ghc-9.0.1 + ## 0.2.2 ### Enhancements diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,9 @@ # fusion-plugin +[![Hackage](https://img.shields.io/hackage/v/fusion-plugin.svg?style=flat)](https://hackage.haskell.org/package/fusion-plugin) +![](https://github.com/composewell/fusion-plugin/workflows/Haskell%20CI/badge.svg) + + ## Motivation The goal of stream fusion is to eliminate constructors of @@ -48,6 +52,8 @@ ### Plugin options +Note: dump-core does not work for GHC-9.0.1 and above + `-fplugin-opt=Fusion.Plugin:dump-core`: dump core after each core-to-core transformation. Output from each transformation is printed in a different file. @@ -64,11 +70,10 @@ ## Contributing -All contributions are welcome! The code is available under BSD-3 +All contributions are welcome! The code is available under Apache-2.0 license [on github](https://github.com/composewell/fusion-plugin). In -case you have any questions or suggestions please contact [Pranay -Sashank](mailto:pranaysashank@composewell.com), the author and -maintainer of this plugin. +case you have any questions or suggestions please contact [the +maintainers](mailto:streamly@composewell.com). We would be happy to see this work getting integrated with GHC as a fix for [GHC ticket #17075](https://gitlab.haskell.org/ghc/ghc/issues/17075), any help diff --git a/fusion-plugin.cabal b/fusion-plugin.cabal --- a/fusion-plugin.cabal +++ b/fusion-plugin.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: fusion-plugin -version: 0.2.2 +version: 0.2.3 synopsis: GHC plugin to make stream fusion more predictable. description: This plugin provides the programmer with a way to annotate certain @@ -14,15 +14,15 @@ irrespective of the size. . This plugin was primarily motivated by - but it can + but it can be used in general. homepage: https://github.com/composewell/fusion-plugin bug-reports: https://github.com/composewell/fusion-plugin/issues license: Apache-2.0 license-file: LICENSE -tested-with: GHC==8.6.3, GHC==8.8.1, GHC==8.10.3 +tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.4, GHC==9.0.1 author: Pranay Sashank -maintainer: pranaysashank@composewell.com +maintainer: streamly@composewell.com copyright: (c) 2019 Composewell Technologies category: Development extra-source-files: CHANGELOG.md @@ -39,7 +39,7 @@ , containers >= 0.5.6.2 && < 0.7 , directory >= 1.2.2.0 && < 1.4 , filepath >= 1.4 && < 1.5 - , ghc >= 7.10.3 && <= 8.11 + , ghc >= 7.10.3 && < 9.3 , syb >= 0.7 && < 0.8 , time >= 1.5 && < 1.12 , transformers >= 0.4 && < 0.6 diff --git a/src/Fusion/Plugin.hs b/src/Fusion/Plugin.hs --- a/src/Fusion/Plugin.hs +++ b/src/Fusion/Plugin.hs @@ -50,29 +50,39 @@ #if MIN_VERSION_ghc(8,6,0) -- Explicit/qualified imports -import Control.Monad (mzero, when, unless) +import Control.Monad (mzero, when) import Control.Monad.Trans.Maybe import Control.Monad.Trans.State -import Data.Char (isSpace) import Data.Maybe (mapMaybe) import Data.Generics.Schemes (everywhere) import Data.Generics.Aliases (mkT) + +#if MIN_VERSION_ghc(9,0,0) +-- import GHC.Utils.Error (Severity(..)) +-- import GHC.Core.Ppr (pprCoreBindingsWithSize, pprRules) +#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 import qualified Data.List as DL -import qualified Data.Set as Set #endif -- Implicit imports +#if MIN_VERSION_ghc(9,0,0) +import GHC.Plugins +#else import GhcPlugins +#endif -- Imports from this package import Fusion.Plugin.Types (Fuse(..)) @@ -90,6 +100,8 @@ -- ghc-options: -O2 -fplugin=Fusion.Plugin -- @ -- +-- The following currently works only for GHC versions less than 9.0. +-- -- To dump the core after each core to core transformation, pass the -- following to your ghc-options: -- @@ -130,6 +142,14 @@ -- Commandline parsing lifted from streamly/benchmark/Chart.hs ------------------------------------------------------------------------------- +data ReportMode = + ReportSilent + | ReportWarn + | ReportVerbose + | ReportVerbose1 + | ReportVerbose2 + deriving (Show) + data Options = Options { optionsDumpCore :: Bool , optionsVerbosityLevel :: ReportMode @@ -141,10 +161,12 @@ , optionsVerbosityLevel = ReportSilent } +#if !MIN_VERSION_ghc(9,0,0) setDumpCore :: Monad m => Bool -> StateT ([CommandLineOption], Options) m () setDumpCore val = do (args, opts) <- get put (args, opts { optionsDumpCore = val }) +#endif setVerbosityLevel :: Monad m => ReportMode -> StateT ([CommandLineOption], Options) m () @@ -173,7 +195,9 @@ parseOpt opt = case opt of +#if !MIN_VERSION_ghc(9,0,0) "dump-core" -> setDumpCore True +#endif "verbose=1" -> setVerbosityLevel ReportWarn "verbose=2" -> setVerbosityLevel ReportVerbose "verbose=3" -> setVerbosityLevel ReportVerbose1 @@ -224,29 +248,51 @@ NonRec (setAlwaysInlineOnBndr b) expr go x = x +#if MIN_VERSION_ghc(9,0,0) +#define IS_ACTIVE isActive (Phase 0) +#define UNIQ_FM UniqFM Name [Fuse] +#define GET_NAME getName +#define FMAP_SND fmap snd $ +#else +#define IS_ACTIVE isActiveIn 0 +#define UNIQ_FM UniqFM [Fuse] +#define GET_NAME getUnique +#define FMAP_SND +#endif + hasInlineBinder :: CoreBndr -> Bool hasInlineBinder bndr = let inl = inlinePragInfo $ idInfo bndr - in isInlinePragma inl && isActiveIn 0 (inlinePragmaActivation inl) + in isInlinePragma inl && IS_ACTIVE (inlinePragmaActivation inl) ------------------------------------------------------------------------------- -- Inspect case alternatives for interesting constructor matches ------------------------------------------------------------------------------- +#if MIN_VERSION_ghc(9,3,0) +#define ALT_CONSTR(x,y,z) Alt (x) y z +#else +#define ALT_CONSTR(x,y,z) (x, y, z) +#endif + -- Checks whether a case alternative contains a type with the -- annotation. Only checks the first typed element in the list, so -- only pass alternatives from one case expression. -altsContainsAnn :: UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr) +altsContainsAnn :: UNIQ_FM -> [Alt CoreBndr] -> Maybe (Alt CoreBndr) altsContainsAnn _ [] = Nothing -altsContainsAnn anns (bndr@(DataAlt dcon, _, _):_) = - case lookupUFM anns (getUnique $ dataConTyCon dcon) of +altsContainsAnn anns (bndr@(ALT_CONSTR(DataAlt dcon,_,_)):_) = + case lookupUFM anns (GET_NAME $ dataConTyCon dcon) of Nothing -> Nothing Just _ -> Just bndr -altsContainsAnn anns ((DEFAULT, _, _):alts) = altsContainsAnn anns alts +altsContainsAnn anns ((ALT_CONSTR(DEFAULT,_,_)):alts) = altsContainsAnn anns alts altsContainsAnn _ _ = Nothing +getNonRecBinder :: CoreBind -> CoreBndr +getNonRecBinder (NonRec b _) = b +getNonRecBinder (Rec _) = error "markInline: expecting only nonrec binders" + needInlineCaseAlt - :: CoreBind -> UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr) + :: CoreBind -> UNIQ_FM -> [Alt CoreBndr] -> Maybe (Alt CoreBndr) needInlineCaseAlt parent anns bndr = case altsContainsAnn anns bndr of Just alt | not (hasInlineBinder $ getNonRecBinder parent) -> Just alt @@ -275,7 +321,7 @@ -- case alternative scrutinizing the annotated type for better errors with -- context. letBndrsThatAreCases - :: UniqFM [Fuse] + :: UNIQ_FM -> CoreBind -> [([CoreBind], Alt CoreBndr)] letBndrsThatAreCases anns bind = goLet [] bind @@ -295,7 +341,7 @@ -- annotated with "Fuse" and traverse the Alt expressions to discover more -- let bindings. go parents True (Case _ _ _ alts) = - let binders = alts >>= (\(_, _, expr1) -> go parents False expr1) + let binders = alts >>= (\(ALT_CONSTR(_,_,expr1)) -> go parents False expr1) in case needInlineCaseAlt (head parents) anns alts of Just x -> (parents, x) : binders Nothing -> binders @@ -303,7 +349,7 @@ -- Only traverse the Alt expressions of the case to discover new let -- bindings. Do not match for annotated constructors in the Alts. go parents False (Case _ _ _ alts) = - alts >>= (\(_, _, expr1) -> go parents False expr1) + alts >>= (\(ALT_CONSTR(_,_,expr1)) -> go parents False expr1) -- Enter a new let binding inside the current expression and traverse the -- let expression as well. @@ -334,9 +380,9 @@ goLet parents (Rec bs) = bs >>= (\(b, expr1) -> goLet parents $ NonRec b expr1) -needInlineConstr :: CoreBind -> UniqFM [Fuse] -> DataCon -> Bool +needInlineConstr :: CoreBind -> UNIQ_FM -> DataCon -> Bool needInlineConstr parent anns dcon = - case lookupUFM anns (getUnique $ dataConTyCon dcon) of + case lookupUFM anns (GET_NAME $ dataConTyCon dcon) of Just _ | not (hasInlineBinder $ getNonRecBinder parent) -> True _ -> False @@ -348,7 +394,7 @@ -- constructor is directly used in the binder definition rather than through an -- identifier. -- -constructingBinders :: UniqFM [Fuse] -> CoreBind -> [([CoreBind], DataCon)] +constructingBinders :: UNIQ_FM -> CoreBind -> [([CoreBind], DataCon)] constructingBinders anns bind = goLet [] bind where -- The first argument is current binder and its parent chain. We add a new @@ -362,7 +408,7 @@ -- Traverse these to discover new let bindings go parents (Case _ _ _ alts) = - alts >>= (\(_, _, expr1) -> go parents expr1) + alts >>= (\(ALT_CONSTR(_,_,expr1)) -> go parents expr1) go parents (App expr1 expr2) = go parents expr1 ++ go parents expr2 go parents (Lam _ expr1) = go parents expr1 go parents (Cast expr1 _) = go parents expr1 @@ -393,7 +439,7 @@ -- anywhere in the binders, not just case match on entry or construction on -- return. -- -containsAnns :: UniqFM [Fuse] -> CoreBind -> [([CoreBind], Context)] +containsAnns :: UNIQ_FM -> CoreBind -> [([CoreBind], Context)] containsAnns anns bind = -- The first argument is current binder and its parent chain. We add a new -- element to this path when we enter a let statement. @@ -405,7 +451,7 @@ -- annotated with "Fuse" and traverse the Alt expressions to discover more -- let bindings. go parents (Case _ _ _ alts) = - let binders = alts >>= (\(_, _, expr1) -> go parents expr1) + let binders = alts >>= (\(ALT_CONSTR(_,_,expr1)) -> go parents expr1) in case altsContainsAnn anns alts of Just x -> (parents, CaseAlt x) : binders Nothing -> binders @@ -423,7 +469,7 @@ go parents (Var i) = case idDetails i of DataConWorkId dcon -> - case lookupUFM anns (getUnique $ dataConTyCon dcon) of + case lookupUFM anns (GET_NAME $ dataConTyCon dcon) of Just _ -> [(parents, Constr dcon)] Nothing -> [] _ -> [] @@ -443,18 +489,6 @@ -- Core-to-core pass to mark interesting binders to be always inlined ------------------------------------------------------------------------------- -data ReportMode = - ReportSilent - | ReportWarn - | ReportVerbose - | ReportVerbose1 - | ReportVerbose2 - deriving (Show) - -getNonRecBinder :: CoreBind -> CoreBndr -getNonRecBinder (NonRec b _) = b -getNonRecBinder (Rec _) = error "markInline: expecting only nonrec binders" - -- XXX we can possibly have a FUSE_DEBUG annotation to print verbose -- messages only for a given type. -- @@ -481,7 +515,7 @@ -> ReportMode -> ([CoreBind], Alt CoreBndr) -> String -showDetailsCaseMatch dflags reportMode (binds, c@(con,_,_)) = +showDetailsCaseMatch dflags reportMode (binds, c@(ALT_CONSTR(con,_,_))) = listPath dflags binds ++ ": " ++ case reportMode of ReportVerbose -> showSDoc dflags (ppr con) @@ -502,6 +536,10 @@ ReportVerbose2 -> showSDoc dflags (ppr $ head binds) _ -> error "transformBind: unreachable" +-- Orphan instance for 'Fuse' +instance Outputable Fuse where + ppr _ = text "Fuse" + showInfo :: CoreBndr -> DynFlags @@ -515,7 +553,7 @@ showInfo parent dflags reportMode failIt tag uniqBinders annotated showDetails = when (uniqBinders /= []) $ do - let msg = "In " + let mesg = "In " ++ addMissingUnique dflags parent ++ " binders " ++ show (map (addMissingUnique dflags) (uniqBinders)) @@ -526,7 +564,7 @@ ReportSilent -> return () ReportWarn -> return () _ -> do - putMsgS msg + putMsgS mesg putMsgS $ DL.unlines $ DL.nub $ map (showDetails dflags reportMode) annotated @@ -536,12 +574,12 @@ markInline reportMode failIt transform guts = do putMsgS $ "fusion-plugin: Checking bindings to inline..." dflags <- getDynFlags - anns <- getAnnotations deserializeWithData guts + anns <- FMAP_SND getAnnotations deserializeWithData guts if (anyUFM (any (== Fuse)) anns) then bindsOnlyPass (mapM (transformBind dflags anns)) guts else return guts where - transformBind :: DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM CoreBind + -- transformBind :: DynFlags -> UniqFM Unique [Fuse] -> CoreBind -> CoreM CoreBind transformBind dflags anns bind@(NonRec b _) = do let patternMatches = letBndrsThatAreCases anns bind let uniqPat = DL.nub (map (getNonRecBinder. head . fst) patternMatches) @@ -593,8 +631,8 @@ -- Simplification pass after marking inline ------------------------------------------------------------------------------- -fusionSimplify :: DynFlags -> CoreToDo -fusionSimplify dflags = +fusionSimplify :: HscEnv -> DynFlags -> CoreToDo +fusionSimplify _hsc_env dflags = CoreDoSimplify (maxSimplIterations dflags) SimplMode @@ -605,22 +643,31 @@ , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags , sm_inline = True , sm_case_case = True +#if MIN_VERSION_ghc(9,3,0) + , sm_uf_opts = unfoldingOpts dflags + , sm_pre_inline = gopt Opt_SimplPreInlining dflags + , sm_logger = logger +#endif } +#if MIN_VERSION_ghc(9,3,0) + where logger = hsc_logger _hsc_env +#endif + ------------------------------------------------------------------------------- -- Report unfused constructors ------------------------------------------------------------------------------- fusionReport :: String -> ReportMode -> ModGuts -> CoreM ModGuts -fusionReport msg reportMode guts = do - putMsgS $ "fusion-plugin: " ++ msg ++ "..." +fusionReport mesg reportMode guts = do + putMsgS $ "fusion-plugin: " ++ mesg ++ "..." dflags <- getDynFlags - anns <- getAnnotations deserializeWithData guts + anns <- FMAP_SND getAnnotations deserializeWithData guts when (anyUFM (any (== Fuse)) anns) $ mapM_ (transformBind dflags anns) $ mg_binds guts return guts where - transformBind :: DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM () + transformBind :: DynFlags -> UNIQ_FM -> CoreBind -> CoreM () transformBind dflags anns bind@(NonRec b _) = do let results = containsAnns anns bind @@ -666,6 +713,7 @@ -- Dump core passes ------------------------------------------------------------------------------- +#if !MIN_VERSION_ghc(9,0,0) chooseDumpFile :: DynFlags -> FilePath -> Maybe FilePath chooseDumpFile dflags suffix | Just prefix <- getPrefix @@ -691,6 +739,7 @@ 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 @@ -819,6 +868,7 @@ go counter (todo:rest) = todo : dumpCorePass counter (text "After " GhcPlugins.<> ppr todo) : go (counter + 1) rest +#endif ------------------------------------------------------------------------------- -- Install our plugin core pass @@ -844,6 +894,7 @@ install args todos = do options <- liftIO $ parseOptions args dflags <- getDynFlags + hscEnv <- getHscEnv -- We run our plugin once the simplifier finishes phase 0, -- followed by a gentle simplifier which inlines and case-cases -- twice. @@ -854,23 +905,30 @@ -- -- TODO do not run simplify if we did not do anything in markInline phase. return $ - (if optionsDumpCore options then _insertDumpCore else id) $ + (if optionsDumpCore options + then +#if !MIN_VERSION_ghc(9,0,0) + _insertDumpCore +#else + id +#endif + else id) $ insertAfterSimplPhase0 todos [ fusionMarkInline ReportSilent False True - , fusionSimplify dflags + , fusionSimplify hscEnv dflags , fusionMarkInline ReportSilent False True - , fusionSimplify dflags + , fusionSimplify hscEnv dflags , fusionMarkInline ReportSilent False True - , fusionSimplify dflags + , fusionSimplify hscEnv dflags -- This lets us know what was left unfused after all the inlining -- and case-of-case transformations. - , let msg = "Check unfused (post inlining)" - in CoreDoPluginPass msg (fusionReport msg ReportSilent) + , let mesg = "Check unfused (post inlining)" + in CoreDoPluginPass mesg (fusionReport mesg ReportSilent) ] - (let msg = "Check unfused (final)" - report = fusionReport msg (optionsVerbosityLevel options) - in CoreDoPluginPass msg report) + (let mesg = "Check unfused (final)" + report = fusionReport mesg (optionsVerbosityLevel options) + in CoreDoPluginPass mesg report) #else install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] install _ todos = do @@ -885,7 +943,3 @@ , pluginRecompile = purePlugin #endif } - --- Orphan instance for 'Fuse' -instance Outputable Fuse where - ppr _ = text "Fuse" diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,5 +1,3 @@ -resolver: lts-15.9 +resolver: lts-17.14 packages: - '.' -extra-deps: - - fusion-plugin-types-0.1.0