fusion-plugin 0.2.2 → 0.2.3
raw patch · 5 files changed
+130/−68 lines, 5 filesdep ~ghcnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ghc
API changes (from Hackage documentation)
Files
- CHANGELOG.md +5/−0
- README.md +9/−4
- fusion-plugin.cabal +5/−5
- src/Fusion/Plugin.hs +110/−56
- stack.yaml +1/−3
CHANGELOG.md view
@@ -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
README.md view
@@ -1,5 +1,9 @@ # fusion-plugin +[](https://hackage.haskell.org/package/fusion-plugin)+++ ## 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
fusion-plugin.cabal view
@@ -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- <https://hackage.haskell.org/package/streamly streamly> but it can+ <https://streamly.composewell.com streamly> 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
src/Fusion/Plugin.hs view
@@ -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"
stack.yaml view
@@ -1,5 +1,3 @@-resolver: lts-15.9+resolver: lts-17.14 packages: - '.'-extra-deps:- - fusion-plugin-types-0.1.0