fusion-plugin 0.2.1 → 0.2.2
raw patch · 5 files changed
+470/−104 lines, 5 filesdep ~timePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: time
API changes (from Hackage documentation)
+ Fusion.Plugin: instance GHC.Show.Show Fusion.Plugin.ReportMode
Files
- CHANGELOG.md +8/−0
- LICENSE +171/−24
- README.md +10/−9
- fusion-plugin.cabal +4/−4
- src/Fusion/Plugin.hs +277/−67
CHANGELOG.md view
@@ -1,3 +1,11 @@+## 0.2.2++### Enhancements++- Plugin now forces inline on binders that return a type annotated with Fuse.+- `Fusion.Plugin` now accepts new command line arguments to control the+ verbosity of the plugin's reporting phase. Refer to `README.md` for usage.+ ## 0.2.1 ### Enhancements
LICENSE view
@@ -1,30 +1,177 @@-Copyright (c) 2019, Composewell Technologies -All rights reserved.+ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/ -Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION - * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.+ 1. Definitions. - * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.+ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document. - * Neither the name of Composewell Technologies nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.+ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS
README.md view
@@ -1,9 +1,5 @@ # fusion-plugin -[](https://hackage.haskell.org/package/fusion-plugin)--- ## Motivation The goal of stream fusion is to eliminate constructors of@@ -47,12 +43,17 @@ general. To use this plugin, add this package to your `build-depends`-and pass the following to your ghc-options: `ghc-options: -O2--fplugin=Fusion.Plugin`+and pass the following to your ghc-options:+`ghc-options: -O2 -fplugin=Fusion.Plugin` -To dump core after each core to core transformation, pass the argument-`-fplugin-opt=Fusion.Plugin:dump-core`. Output from each-transformation is then printed in a different file.+### Plugin options++`-fplugin-opt=Fusion.Plugin:dump-core`: dump core after each+core-to-core transformation. Output from each transformation is printed+in a different file.++`-fplugin-opt=Fusion.Plugin:verbose=1`: report unfused functions. Verbosity+levels `2`, `3`, `4` can be used for more verbose output. ## See also
fusion-plugin.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: fusion-plugin-version: 0.2.1+version: 0.2.2 synopsis: GHC plugin to make stream fusion more predictable. description: This plugin provides the programmer with a way to annotate certain@@ -18,9 +18,9 @@ be used in general. homepage: https://github.com/composewell/fusion-plugin bug-reports: https://github.com/composewell/fusion-plugin/issues-license: BSD-3-Clause+license: Apache-2.0 license-file: LICENSE-tested-with: GHC==8.6.3, GHC==8.8.1+tested-with: GHC==8.6.3, GHC==8.8.1, GHC==8.10.3 author: Pranay Sashank maintainer: pranaysashank@composewell.com copyright: (c) 2019 Composewell Technologies@@ -41,7 +41,7 @@ , filepath >= 1.4 && < 1.5 , ghc >= 7.10.3 && <= 8.11 , syb >= 0.7 && < 0.8- , time >= 1.5 && < 1.10+ , time >= 1.5 && < 1.12 , transformers >= 0.4 && < 0.6 , fusion-plugin-types >= 0.1 && < 0.2
src/Fusion/Plugin.hs view
@@ -1,9 +1,8 @@ -- | -- Module : Fusion.Plugin -- Copyright : (c) 2019 Composewell Technologies------ License : BSD-3-Clause--- Maintainer : pranaysashank@composewell.com+-- License : Apache-2.0+-- Maintainer : streamly@composewell.com -- Stability : experimental -- Portability : GHC --@@ -49,11 +48,13 @@ ) where +#if MIN_VERSION_ghc(8,6,0) -- Explicit/qualified imports import Control.Monad (mzero, when, unless) 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) import Data.IORef (readIORef, writeIORef)@@ -68,6 +69,7 @@ import qualified Data.List as DL import qualified Data.Set as Set+#endif -- Implicit imports import GhcPlugins@@ -130,16 +132,26 @@ data Options = Options { optionsDumpCore :: Bool+ , optionsVerbosityLevel :: ReportMode } deriving Show defaultOptions :: Options-defaultOptions = Options False+defaultOptions = Options+ { optionsDumpCore = False+ , optionsVerbosityLevel = ReportSilent+ } setDumpCore :: Monad m => Bool -> StateT ([CommandLineOption], Options) m () setDumpCore val = do (args, opts) <- get put (args, opts { optionsDumpCore = val }) +setVerbosityLevel :: Monad m+ => ReportMode -> StateT ([CommandLineOption], Options) m ()+setVerbosityLevel val = do+ (args, opts) <- get+ put (args, opts { optionsVerbosityLevel = val })+ -- Like the shell "shift" to shift the command line arguments shift :: StateT ([String], Options) (MaybeT IO) (Maybe String) shift = do@@ -162,8 +174,14 @@ parseOpt opt = case opt of "dump-core" -> setDumpCore True+ "verbose=1" -> setVerbosityLevel ReportWarn+ "verbose=2" -> setVerbosityLevel ReportVerbose+ "verbose=3" -> setVerbosityLevel ReportVerbose1+ "verbose=4" -> setVerbosityLevel ReportVerbose2 str -> do- liftIO $ putStrLn $ "Unrecognized option - \"" ++ str ++ "\""+ liftIO+ $ putStrLn+ $ "fusion-plugin: Unrecognized option - \"" ++ str ++ "\"" mzero parseLoop = do@@ -197,6 +215,7 @@ in lazySetIdInfo n info' --TODO: Replace self-recursive definitions with a loop breaker.+-- | Set inline on specific binders inside a given bind. setInlineOnBndrs :: [CoreBndr] -> CoreBind -> CoreBind setInlineOnBndrs bndrs = everywhere $ mkT go where@@ -205,6 +224,11 @@ NonRec (setAlwaysInlineOnBndr b) expr go x = x +hasInlineBinder :: CoreBndr -> Bool+hasInlineBinder bndr =+ let inl = inlinePragInfo $ idInfo bndr+ in isInlinePragma inl && isActiveIn 0 (inlinePragmaActivation inl)+ ------------------------------------------------------------------------------- -- Inspect case alternatives for interesting constructor matches -------------------------------------------------------------------------------@@ -221,6 +245,13 @@ altsContainsAnn anns ((DEFAULT, _, _):alts) = altsContainsAnn anns alts altsContainsAnn _ _ = Nothing +needInlineCaseAlt+ :: CoreBind -> UniqFM [Fuse] -> [Alt CoreBndr] -> Maybe (Alt CoreBndr)+needInlineCaseAlt parent anns bndr =+ case altsContainsAnn anns bndr of+ Just alt | not (hasInlineBinder $ getNonRecBinder parent) -> Just alt+ _ -> Nothing+ ------------------------------------------------------------------------------- -- Determine if a let binder contains a case match on an annotated type -------------------------------------------------------------------------------@@ -228,19 +259,26 @@ -- XXX Can check the call site and return only those that would enable -- case-of-known constructor to kick in. Or is that not relevant? ----- | Returns the Bndrs, that are either of the form:+-- | Discover binders that start with a pattern match on constructors that are+-- annotated with Fuse. For example, for the following code: --+-- @ -- joinrec { $w$g0 x y z = case y of predicateAlt -> ... } -> returns [$w$go] -- join { $j1_sGH1 x y z = case y of predicateAlt -> ... } -> returns [$j1_sGH1]+-- @ --+-- It will return @$w$go@ and @$j1_sGH1@ if they are matching on fusible+-- constructors.+-- -- Returns all the binds in the hierarchy from the parent to the bind--- containing the case alternative as well as the case alternative scrutinizing--- the annotated type.+-- containing the case alternative. Along with the binders it also returns the+-- case alternative scrutinizing the annotated type for better errors with+-- context. letBndrsThatAreCases- :: ([Alt CoreBndr] -> Maybe (Alt CoreBndr))+ :: UniqFM [Fuse] -> CoreBind -> [([CoreBind], Alt CoreBndr)]-letBndrsThatAreCases f bind = goLet [] bind+letBndrsThatAreCases anns bind = goLet [] bind where -- The first argument is current binder and its parent chain. We add a new -- element to this path when we enter a let statement.@@ -258,7 +296,7 @@ -- let bindings. go parents True (Case _ _ _ alts) = let binders = alts >>= (\(_, _, expr1) -> go parents False expr1)- in case f alts of+ in case needInlineCaseAlt (head parents) anns alts of Just x -> (parents, x) : binders Nothing -> binders @@ -270,9 +308,13 @@ -- Enter a new let binding inside the current expression and traverse the -- let expression as well. go parents _ (Let bndr expr1) = goLet parents bndr+ -- If the binding starts with a "let" expression we ignore the case matches+ -- in its expression. Can inlining such lets be useful in some cases? ++ go parents False expr1 - -- Traverse these to discover new let bindings+ -- Traverse these to discover new let bindings. We ignore any case matches+ -- directly in the application expr. There should not be any harm in+ -- chasing expr1 with True here? go parents _ (App expr1 expr2) = go parents False expr1 ++ go parents False expr2 go parents x (Lam _ expr1) = go parents x expr1@@ -286,30 +328,86 @@ go _ _ (Coercion _) = [] goLet :: [CoreBind] -> CoreBind -> [([CoreBind], Alt CoreBndr)]- -- Here we pass the second argument to "go" as "True" i.e. we are no+ -- Here we pass the second argument to "go" as "True" i.e. we are now -- looking to match the case alternatives for annotated constructors. goLet parents bndr@(NonRec _ expr1) = go (bndr : parents) True expr1 goLet parents (Rec bs) = bs >>= (\(b, expr1) -> goLet parents $ NonRec b expr1) -containsAnns- :: ([Alt CoreBndr] -> Maybe (Alt CoreBndr))- -> CoreBind- -> [([CoreBind], Alt CoreBndr)]-containsAnns f bind =+needInlineConstr :: CoreBind -> UniqFM [Fuse] -> DataCon -> Bool+needInlineConstr parent anns dcon =+ case lookupUFM anns (getUnique $ dataConTyCon dcon) of+ Just _ | not (hasInlineBinder $ getNonRecBinder parent) -> True+ _ -> False++-- XXX Currently this function and containsAnns are equivalent. So containsAnns+-- can be used in place of this. But we may want to restrict this to certain+-- cases and keep containsAnns unrestricted so it is kept separate for now.+--+-- | Discover binders whose return type is a fusible constructor and the+-- constructor is directly used in the binder definition rather than through an+-- identifier.+--+constructingBinders :: UniqFM [Fuse] -> CoreBind -> [([CoreBind], DataCon)]+constructingBinders anns bind = goLet [] bind+ where -- The first argument is current binder and its parent chain. We add a new -- element to this path when we enter a let statement.+ --+ go :: [CoreBind] -> CoreExpr -> [([CoreBind], DataCon)]++ -- Enter a new let binding inside the current expression and traverse the+ -- let expression as well.+ go parents (Let bndr expr1) = goLet parents bndr ++ go parents expr1++ -- Traverse these to discover new let bindings+ go parents (Case _ _ _ alts) =+ alts >>= (\(_, _, 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++ -- Check if the Var is a data constructor of interest+ go parents (Var i) =+ let needInline = needInlineConstr (head parents) anns+ in case idDetails i of+ DataConWorkId dcon | needInline dcon -> [(parents, dcon)]+ _ -> []++ go _ (Lit _) = []+ go _ (Tick _ _) = []+ go _ (Type _) = []+ go _ (Coercion _) = []++ goLet :: [CoreBind] -> CoreBind -> [([CoreBind], DataCon)]+ goLet parents bndr@(NonRec _ expr1) = go (bndr : parents) expr1+ goLet parents (Rec bs) =+ bs >>= (\(b, expr1) -> goLet parents $ NonRec b expr1)++data Context = CaseAlt (Alt CoreBndr) | Constr DataCon++-- letBndrsThatAreCases restricts itself to only case matches right on+-- entry to a let. This one looks for case matches anywhere.+--+-- | Report whether data constructors of interest are case matched or returned+-- anywhere in the binders, not just case match on entry or construction on+-- return.+--+containsAnns :: UniqFM [Fuse] -> 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. goLet [] bind where- go :: [CoreBind] -> CoreExpr -> [([CoreBind], Alt CoreBndr)]+ go :: [CoreBind] -> CoreExpr -> [([CoreBind], Context)] -- Match and record the case alternative if it contains a constructor -- annotated with "Fuse" and traverse the Alt expressions to discover more -- let bindings. go parents (Case _ _ _ alts) = let binders = alts >>= (\(_, _, expr1) -> go parents expr1)- in case f alts of- Just x -> (parents, x) : binders+ in case altsContainsAnn anns alts of+ Just x -> (parents, CaseAlt x) : binders Nothing -> binders -- Enter a new let binding inside the current expression and traverse the@@ -321,14 +419,22 @@ go parents (Lam _ expr1) = go parents expr1 go parents (Cast expr1 _) = go parents expr1 + -- Check if the Var is a data constructor of interest+ go parents (Var i) =+ case idDetails i of+ DataConWorkId dcon ->+ case lookupUFM anns (getUnique $ dataConTyCon dcon) of+ Just _ -> [(parents, Constr dcon)]+ Nothing -> []+ _ -> []+ -- There are no let bindings in these.- go _ (Var _) = [] go _ (Lit _) = [] go _ (Tick _ _) = [] go _ (Type _) = [] go _ (Coercion _) = [] - goLet :: [CoreBind] -> CoreBind -> [([CoreBind], Alt CoreBndr)]+ goLet :: [CoreBind] -> CoreBind -> [([CoreBind], Context)] goLet parents bndr@(NonRec _ expr1) = go (bndr : parents) expr1 goLet parents (Rec bs) = bs >>= (\(b, expr1) -> goLet parents $ NonRec b expr1)@@ -337,7 +443,13 @@ -- Core-to-core pass to mark interesting binders to be always inlined ------------------------------------------------------------------------------- -data ReportMode = ReportSilent | ReportWarn | ReportVerbose | ReportVerbose2+data ReportMode =+ ReportSilent+ | ReportWarn+ | ReportVerbose+ | ReportVerbose1+ | ReportVerbose2+ deriving (Show) getNonRecBinder :: CoreBind -> CoreBndr getNonRecBinder (NonRec b _) = b@@ -357,39 +469,67 @@ then bndrName else bndrName ++ "_" ++ suffix +listPath :: DynFlags -> [CoreBind] -> [Char]+listPath dflags binds =+ DL.intercalate "/"+ $ reverse+ $ map (addMissingUnique dflags)+ $ map getNonRecBinder binds++showDetailsCaseMatch+ :: DynFlags+ -> ReportMode+ -> ([CoreBind], Alt CoreBndr)+ -> String+showDetailsCaseMatch dflags reportMode (binds, c@(con,_,_)) =+ listPath dflags binds ++ ": " +++ case reportMode of+ ReportVerbose -> showSDoc dflags (ppr con)+ ReportVerbose1 -> showSDoc dflags (ppr c)+ ReportVerbose2 -> showSDoc dflags (ppr $ head binds)+ _ -> error "transformBind: unreachable"++showDetailsConstr+ :: DynFlags+ -> ReportMode+ -> ([CoreBind], DataCon)+ -> String+showDetailsConstr dflags reportMode (binds, con) =+ listPath dflags binds ++ ": " +++ case reportMode of+ ReportVerbose -> showSDoc dflags (ppr con)+ ReportVerbose1 -> showSDoc dflags (ppr con)+ ReportVerbose2 -> showSDoc dflags (ppr $ head binds)+ _ -> error "transformBind: unreachable"+ showInfo :: CoreBndr -> DynFlags -> ReportMode -> Bool+ -> String -> [CoreBndr]- -> [([CoreBind], Alt CoreBndr)]+ -> [([CoreBind], a)]+ -> (DynFlags -> ReportMode -> ([CoreBind], a) -> String) -> CoreM ()-showInfo parent dflags reportMode failIt uniqBinders annotated =+showInfo parent dflags reportMode failIt+ tag uniqBinders annotated showDetails = when (uniqBinders /= []) $ do- let showDetails (binds, c@(con,_,_)) =- let path = DL.intercalate "/"- $ reverse- $ map (addMissingUnique dflags)- $ map getNonRecBinder binds- in path ++ ": " ++- case reportMode of- ReportWarn -> showSDoc dflags (ppr con)- ReportVerbose -> showSDoc dflags (ppr c)- ReportVerbose2 ->- showSDoc dflags (ppr $ head binds)- _ -> error "transformBind: unreachable" let msg = "In " ++ addMissingUnique dflags parent ++ " binders " ++ show (map (addMissingUnique dflags) (uniqBinders))- ++ " scrutinize data types annotated with "+ ++ " " ++ tag+ ++ " data types annotated with " ++ showSDoc dflags (ppr Fuse) case reportMode of ReportSilent -> return ()+ ReportWarn -> return () _ -> do putMsgS msg- putMsgS $ DL.unlines $ map showDetails annotated+ putMsgS $ DL.unlines+ $ DL.nub+ $ map (showDetails dflags reportMode) annotated when failIt $ error "failing" markInline :: ReportMode -> Bool -> Bool -> ModGuts -> CoreM ModGuts@@ -403,22 +543,46 @@ where transformBind :: DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM CoreBind transformBind dflags anns bind@(NonRec b _) = do- let annotated = letBndrsThatAreCases (altsContainsAnn anns) bind- let uniqBinders = DL.nub (map (getNonRecBinder. head . fst) annotated)+ let patternMatches = letBndrsThatAreCases anns bind+ let uniqPat = DL.nub (map (getNonRecBinder. head . fst) patternMatches) - when (uniqBinders /= []) $- showInfo b dflags reportMode failIt uniqBinders annotated+ let constrs = constructingBinders anns bind+ let uniqConstr = DL.nub (map (getNonRecBinder. head . fst) constrs) - let bind' =- if transform- then setInlineOnBndrs uniqBinders bind+ -- TBD: For ReportWarn level prepare a single consolidated list of+ -- paths with one entry for each binder and giving one example of what+ -- it scrutinizes and/or constructs, for example:+ --+ -- \$sconcat_s8wu/step5_s8M4: Scrutinizes ConcatOuter, Constructs Yield+ --+ case reportMode of+ ReportSilent -> return ()+ ReportWarn -> do+ let allBinds = map fst patternMatches ++ map fst constrs+ when (not $ null allBinds) $ do+ putMsgS "INLINE required on:"+ putMsgS $ DL.unlines $ DL.nub $ map (listPath dflags) allBinds+ _ -> do+ showInfo b dflags reportMode failIt "SCRUTINIZE"+ uniqPat patternMatches showDetailsCaseMatch+ showInfo b dflags reportMode failIt "CONSTRUCT"+ uniqConstr constrs showDetailsConstr++ let bind' = do+ let allBinders = uniqPat ++ uniqConstr+ if transform && (not $ null allBinders)+ then setInlineOnBndrs allBinders bind else bind return bind' - transformBind _ _ bndr =- -- This is probably wrong, but we don't need it for now.- --mapM_ (\(b, expr) -> transformBind dflags anns (NonRec b expr)) bs- return bndr+ transformBind dflags anns (Rec bs) = do+ fmap Rec (mapM transformAsNonRec bs)+ where+ transformAsNonRec (b, expr) = do+ r <- transformBind dflags anns (NonRec b expr)+ case r of+ NonRec b1 expr1 -> return (b1, expr1)+ _ -> error "Bug: expecting NonRec binder" -- | Core pass to mark functions scrutinizing constructors marked with Fuse fusionMarkInline :: ReportMode -> Bool -> Bool -> CoreToDo@@ -447,25 +611,57 @@ -- Report unfused constructors ------------------------------------------------------------------------------- -fusionReport :: ReportMode -> ModGuts -> CoreM ModGuts-fusionReport reportMode guts = do- putMsgS $ "fusion-plugin: Checking presence of annotated types..."+fusionReport :: String -> ReportMode -> ModGuts -> CoreM ModGuts+fusionReport msg reportMode guts = do+ putMsgS $ "fusion-plugin: " ++ msg ++ "..." dflags <- getDynFlags anns <- getAnnotations deserializeWithData guts- if (anyUFM (any (== Fuse)) anns)- then bindsOnlyPass (mapM (transformBind dflags anns)) guts- else return guts+ when (anyUFM (any (== Fuse)) anns) $+ mapM_ (transformBind dflags anns) $ mg_binds guts+ return guts where- transformBind :: DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM CoreBind+ transformBind :: DynFlags -> UniqFM [Fuse] -> CoreBind -> CoreM () transformBind dflags anns bind@(NonRec b _) = do- let annotated = containsAnns (altsContainsAnn anns) bind- uniqBinders = DL.nub (map (getNonRecBinder . head . fst) annotated)- when (uniqBinders /= []) $- showInfo b dflags reportMode False uniqBinders annotated- return bind+ let results = containsAnns anns bind - transformBind _ _ bndr = return bndr+ let getAlts x =+ case x of+ (bs, CaseAlt alt) -> Just (bs, alt)+ _ -> Nothing+ let patternMatches = mapMaybe getAlts results+ let uniqBinders = DL.nub (map (getNonRecBinder . head . fst)+ patternMatches) + -- let constrs = constructingBinders anns bind+ let getConstrs x =+ case x of+ (bs, Constr con) -> Just (bs, con)+ _ -> Nothing+ let constrs = mapMaybe getConstrs results+ let uniqConstr = DL.nub (map (getNonRecBinder. head . fst) constrs)++ -- TBD: For ReportWarn level prepare a single consolidated list of+ -- paths with one entry for each binder and giving one example of what+ -- it scrutinizes and/or constructs, for example:+ --+ -- \$sconcat_s8wu/step5_s8M4: Scrutinizes ConcatOuter, Constructs Yield+ --+ case reportMode of+ ReportSilent -> return ()+ ReportWarn -> do+ let allBinds = map fst patternMatches ++ map fst constrs+ when (not $ null allBinds) $ do+ putMsgS "Unfused bindings:"+ putMsgS $ DL.unlines $ DL.nub $ map (listPath dflags) allBinds+ _ -> do+ showInfo b dflags reportMode False "SCRUTINIZE"+ uniqBinders patternMatches showDetailsCaseMatch+ showInfo b dflags reportMode False "CONSTRUCT"+ uniqConstr constrs showDetailsConstr++ transformBind dflags anns (Rec bs) =+ mapM_ (\(b, expr) -> transformBind dflags anns (NonRec b expr)) bs+ ------------------------------------------------------------------------------- -- Dump core passes -------------------------------------------------------------------------------@@ -628,7 +824,8 @@ -- Install our plugin core pass ------------------------------------------------------------------------------- --- Inserts the given list of 'CoreToDo' after the simplifier phase 0.+-- | Inserts the given list of 'CoreToDo' after the simplifier phase 0.+-- A final 'CoreToDo' (for reporting) passed is executed after all the phases. insertAfterSimplPhase0 :: [CoreToDo] -> [CoreToDo] -> CoreToDo -> [CoreToDo] insertAfterSimplPhase0 origTodos ourTodos report =@@ -664,8 +861,16 @@ , fusionSimplify dflags , fusionMarkInline ReportSilent False True , fusionSimplify dflags+ , fusionMarkInline ReportSilent False True+ , fusionSimplify 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) ]- (CoreDoPluginPass "Check fusion" (fusionReport ReportWarn))+ (let msg = "Check unfused (final)"+ report = fusionReport msg (optionsVerbosityLevel options)+ in CoreDoPluginPass msg report) #else install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] install _ todos = do@@ -674,7 +879,12 @@ #endif plugin :: Plugin-plugin = defaultPlugin {installCoreToDos = install}+plugin = defaultPlugin+ { installCoreToDos = install+#if MIN_VERSION_ghc(8,6,0)+ , pluginRecompile = purePlugin+#endif+ } -- Orphan instance for 'Fuse' instance Outputable Fuse where