diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,9 +1,5 @@ # 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 @@ -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 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.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 diff --git a/src/Fusion/Plugin.hs b/src/Fusion/Plugin.hs --- a/src/Fusion/Plugin.hs +++ b/src/Fusion/Plugin.hs @@ -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