diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 9b5e629..e6eb7e1 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -98,6 +98,7 @@ jobs: CABAL_OPTIONS: >- CABAL_REINIT_CONFIG=y CABAL_CHECK_RELAX=y + CABAL_PROJECT=cabal.project MATRIX_OPTIONS: ${{ matrix.pack_options }} diff --git a/.packcheck.ignore b/.packcheck.ignore index 88b5a26..a8c8827 100644 --- a/.packcheck.ignore +++ b/.packcheck.ignore @@ -2,6 +2,7 @@ .github/workflows/haskell.yml .gitignore appveyor.yml +cabal.project cabal.project.ghc-head flake.lock flake.nix diff --git a/CHANGELOG.md b/CHANGELOG.md index 4b31040..cc0bab6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +## Unreleased + +* Add the following annotations: + * `FuseTypes`: mark types fusible within a specific binding. + * `NoFuseTypes`: disable `Fuse` annotation within a specific binding. + * `InspectTypes`: Forbid or permit existence of given types within a + binding. + * `InspectTypeClasses`: Forbid or permit existence of given type + classes within a binding. + * `MaxCoreSize`: report the size of the optimized Core of a binding. + * `DumpCore`: write the core of a specific binding to a file. + ## 0.2.8 * Support ghc-9.14, adapt to HPT rule creation API change diff --git a/README.md b/README.md index 64ec102..7396661 100644 --- a/README.md +++ b/README.md @@ -40,14 +40,185 @@ through the relevant bindings and if one of these types are found inside a binding then that binding is marked to be inlined irrespective of the size. -## Using the plugin - This plugin was primarily motivated by [streamly](https://github.com/composewell/streamly) but it can be used in general. -To use this plugin, add this package to your `build-depends` -and pass the following to your ghc-options: +## Using the plugin + +There are two different stages where the plugin functionality is used, (1) when +writing code for fusion we annotate data types or bindings using annotations +imported from the `fusion-plugin-types` packages, (2) when compiling the code +we use the `fusion-plugin` package as a compiler plugin to make those +annotations work towards fusing the code better. + +## Annotations to Enable Fusion + +See the `fusion-plugin-types` package for detailed reference on available +annotations. + +### Enabling Fusion of a Data Type + +Library authors annotate the data types used in the intermediate states of +stream pipelines using the `Fuse` annotation. All the functions where these +data types appear are liable to be force inlined by the plugin to make the +types fuse. + +### Enabling Fusion within a Function + +`Fuse` marks a type as fusible everywhere it is used. Sometimes a type should +drive fusion only inside one particular function and must not force inlining +wherever else it happens to be used. For that, annotate the *binding* (not the +type) with `FuseTypes` from `Fusion.Plugin.Types`. The listed types then behave +exactly as if they carried a `Fuse` annotation, but only while inlining inside +that one binding: + +```haskell +{-# LANGUAGE TemplateHaskellQuotes #-} + +import Fusion.Plugin.Types (FuseTypes(..)) + +{-# ANN myFunction (FuseTypes [''Step, ''MyMaybe]) #-} +myFunction :: ... +``` + +Type references are TH `Name`s (`''Step`), so a typo or a stale reference to a +renamed type is a compile error rather than a silently-ignored annotation. +Using `''Foo` requires `{-# LANGUAGE TemplateHaskellQuotes #-}` (or the heavier +`TemplateHaskell`) in the annotated module. + +### Disabling Fusion within a Function + +`NoFuseTypes` is the inverse of `Fuse`/`FuseTypes`. Sometimes a type should +drive fusion in general (via a module-wide `Fuse` annotation) but must *not* +force inlining inside one particular function. Annotate that *binding* with +`NoFuseTypes` from `Fusion.Plugin.Types`: the listed types then behave as if +they carried no `Fuse` annotation, disabling the forced inlining they would +otherwise drive, but only while inlining inside that one binding. Fusion of +those types everywhere else in the module is unaffected: + +```haskell +{-# LANGUAGE TemplateHaskellQuotes #-} + +import Fusion.Plugin.Types (NoFuseTypes(..)) + +{-# ANN myFunction (NoFuseTypes [''Step, ''MyMaybe]) #-} +myFunction :: ... +``` + +## Annotations to Verify Fusion + +### Inspecting Types within a Function + +To verify elimination of certain types within a function annotate the +function with `InspectTypes`. If a violation is found the plugin will complain +providing details of the violation. When `werror` plugin options is used it +will fail the compilation on violation. + +```haskell +{-# LANGUAGE TemplateHaskellQuotes #-} + +import Fusion.Plugin.Types (InspectTypes(..)) +``` + +Complain if any `Fuse` annotated type is found in the function. +```haskell +{-# ANN function1 (ForbidFused [] []) #-} +function1 :: ... +``` + +Also forbid `Maybe` as well even though it isn't Fuse-annotated. +```haskell +{-# ANN function1a (ForbidFused [''Maybe] []) #-} +function1a :: ... +``` + +Disallow `Maybe`, but explicitly allow `Step` even though it is Fuse-annotated +we allow it to be present in this binding. +```haskell +{-# ANN function1b (ForbidFused [''Maybe] [''Step]) #-} +function1b :: ... +``` + +Disallow the specified types and allow the rest, irrespective of `Fuse` +annotation. +```haskell +{-# ANN function2 (ForbidTypes [''Step]) #-} +function2 :: ... +``` + +Allow only the specified types and disallow all others. +```haskell +{-# ANN function3 (PermitTypes [''Int, ''IO]) #-} +function3 :: ... +``` + +To show all boxed types used within a function: +```haskell +{-# ANN function4 (PermitTypes []) #-} +function4 :: ... +``` + +### Inspecting type class dictionaries + +To check the presence or absence of type classes in the Core of a binding, +annotate it with `InspectTypeClasses`. A type class appears in Core as a +dictionary argument; a class that survives to Core usually means a dictionary +that failed to specialize away. + +```haskell +{-# LANGUAGE TemplateHaskellQuotes #-} + +import Fusion.Plugin.Types (InspectTypeClasses(..)) +``` + +'Num' should not appear in the core. +```haskell +{-# ANN function1 (ForbidTypeClasses [''Num]) #-} +function1 :: ... +``` + +'Ord' and 'Eq' can appear but no other type class can be present. +```haskell +{-# ANN function2 (PermitTypeClasses [''Ord, ''Eq]) #-} +function2 :: ... +``` + +### Inspecting Core Size of a Function + +Sometimes the Core blows up due to aggressive inlining and SpecConstr +optimizations. To guard against or detect such issues we can use the +`MaxCoreSize` as a core size ratchet for a function. + +```haskell +import Fusion.Plugin.Types (MaxCoreSize(..)) + +{-# ANN myFunction (MaxCoreSize 1000) #-} +myFunction :: ... +``` + +This prints a line such as: +``` +fusion-plugin: myFunction: core size (1361 terms) exceeds the specified size (1000 terms). +``` + +### Generating Core of a Function + +Use `DumpCore` annotation to write the final simplified core of a function to a +file under `fusion-plugin-output` directory: +```haskell +{-# ANN myFunction DumpCore #-} +myFunction :: ... +``` + +You can examine the core to find the reported violations. + +### Compilation + +To make the fusion annotations do the actual work you need to compile +your code with the fusion-plugin added to GHC during compilation. To do +that add this package to the `build-depends` in the cabal file of the +package to be compiled and use the following ghc options: `ghc-options: -O2 -fplugin=Fusion.Plugin` ### Plugin options @@ -61,6 +232,9 @@ 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. +`-fplugin-opt=Fusion.Plugin:werror`: treat annotation-check violations as +errors instead of warnings. + ## See also If you are a library author looking to annotate the types, you need to diff --git a/appveyor.yml b/appveyor.yml index c6c92b7..ef57702 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -42,7 +42,7 @@ environment: # cabal options # ------------------------------------------------------------------------ CABAL_CHECK_RELAX: "y" - #CABAL_PROJECT: "cabal.project" + CABAL_PROJECT: "cabal.project" # ------------------------------------------------------------------------ # Location of packcheck.sh (the shell script invoked to perform CI tests ). diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..95ab064 --- /dev/null +++ b/cabal.project @@ -0,0 +1,6 @@ +packages: fusion-plugin.cabal + +source-repository-package + type: git + location: https://github.com/composewell/fusion-plugin-types.git + tag: d4fa57623450ba4a43f08ebd7cfbfc2745035375 diff --git a/fusion-plugin.cabal b/fusion-plugin.cabal index 296e924..9278877 100644 --- a/fusion-plugin.cabal +++ b/fusion-plugin.cabal @@ -4,14 +4,17 @@ name: fusion-plugin version: 0.2.8 synopsis: GHC plugin to make stream fusion more predictable. description: - This plugin provides the programmer with a way to annotate certain - types using a 'Fuse' pragma from the + This GHC plugin provides the programmer with a way to annotate types + and functions using various annotations from the - package. The programmer would annotate the types that are to be - eliminated by fusion. During the simplifier phase the plugin goes - through the relevant bindings and if one of these types are found - inside a binding then that binding is marked to be inlined - irrespective of the size. + package, via GHC's @ANN@ pragma. The annotations are used during + compilation to eliminate intermediate constructors by automatically + enforcing inlining within GHC where fusion is needed. The plugin also + provides annotations to verify and report that specific types are + actually eliminated from the function in the final generated Core. It + also provides debugging mechanisms to dump the Core for a specific + function or report if the Core size blows up due to aggressive + optimizations. . This plugin was primarily motivated by but it can @@ -49,16 +52,17 @@ source-repository head library exposed-modules: Fusion.Plugin - build-depends: base >= 4.0 && < 5 - , containers >= 0.5.6.2 && < 0.9 - , directory >= 1.2.2.0 && < 1.4 - , filepath >= 1.4 && < 1.6 - , ghc >= 7.10.3 && < 9.15 - , syb >= 0.7 && < 0.8 - , time >= 1.5 && < 1.16 - , transformers >= 0.4 && < 0.7 + build-depends: base >= 4.0 && < 5 + , containers >= 0.5.6.2 && < 0.9 + , directory >= 1.2.2.0 && < 1.4 + , filepath >= 1.4 && < 1.6 + , ghc >= 7.10.3 && < 9.15 + , syb >= 0.7 && < 0.8 + , template-haskell >= 2.16 && < 2.25 + , time >= 1.5 && < 1.16 + , transformers >= 0.4 && < 0.7 - , fusion-plugin-types >= 0.1 && < 0.2 + , fusion-plugin-types >= 0.1.1 && < 0.2 hs-source-dirs: src ghc-options: -Wall if impl(ghc >= 8.0) diff --git a/src/Fusion/Plugin.hs b/src/Fusion/Plugin.hs index c0400ec..832f791 100644 --- a/src/Fusion/Plugin.hs +++ b/src/Fusion/Plugin.hs @@ -54,11 +54,18 @@ where import Control.Monad (mzero, when) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.State (StateT, evalStateT, get, put) -import Data.Maybe (mapMaybe) +import Data.Char (isDigit) +import Data.Data (Data) +import Data.Maybe (catMaybes, isJust, mapMaybe) +import Data.Word (Word8) import Data.Generics.Schemes (everywhere) import Data.Generics.Aliases (mkT) import Debug.Trace (trace) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) import qualified Data.List as DL +import qualified Data.Map.Strict as Map +import qualified Language.Haskell.TH.Syntax as TH -- Imports for specific compiler versions #if MIN_VERSION_ghc(9,6,0) @@ -117,8 +124,20 @@ import qualified GHC.Plugins as GhcPlugins import GhcPlugins #endif --- Imports from this package -import Fusion.Plugin.Types (Fuse(..)) +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +import GHC.Utils.Panic (throwGhcExceptionIO, GhcException(ProgramError)) +#elif !MIN_VERSION_ghc(9,0,0) +import Panic (throwGhcExceptionIO, GhcException(ProgramError)) +#endif + +-- Core size reporting +#if MIN_VERSION_ghc(9,0,0) +import GHC.Core.Stats (exprStats, CoreStats(cs_tm)) +#else +import CoreStats (exprStats, CoreStats(cs_tm)) +#endif + +import Fusion.Plugin.Types -- $using -- @@ -126,6 +145,11 @@ import Fusion.Plugin.Types (Fuse(..)) -- [streamly](https://github.com/composewell/streamly) but it can be used in -- general. -- +-- You need to annotate your code to enable fusion or to report details about +-- fused types in a function. See the documentation of the +-- `fusion-plugin-types` package for available annotations. Also see the +-- `README` in this package for a guide to use the annotations and this plugin. +-- -- To use this plugin, add this package to your @build-depends@ -- and pass the following to your ghc-options: -- @@ -133,7 +157,20 @@ import Fusion.Plugin.Types (Fuse(..)) -- ghc-options: -O2 -fplugin=Fusion.Plugin -- @ -- --- The following currently works only for GHC versions less than 9.0. +-- GHC option to treat annotation-check violations as errors instead of +-- warnings: +-- +-- @ +-- ghc-options: -fplugin-opt=Fusion.Plugin:werror +-- @ +-- +-- GHC option to show more details about the checks and violations: +-- +-- @ +-- ghc-options: -fplugin-opt=Fusion.Plugin:verbose=1 +-- @ +-- +-- Verbosity levels @2@, @3@, @4@ can be used for more verbose output. -- -- To dump the core after each core to core transformation, pass the -- following to your ghc-options: @@ -142,6 +179,8 @@ import Fusion.Plugin.Types (Fuse(..)) -- ghc-options: -O2 -fplugin=Fusion.Plugin -fplugin-opt=Fusion.Plugin:dump-core -- @ -- Output from each transformation is then printed in a different file. +-- +-- Note: @dump-core@ does not work for GHC-9.0.x, 9.6.x and 9.8.x. -- $impl -- @@ -214,17 +253,19 @@ data ReportMode = | ReportVerbose | ReportVerbose1 | ReportVerbose2 - deriving (Show) + deriving (Eq, Show) data Options = Options { optionsDumpCore :: Bool , optionsVerbosityLevel :: ReportMode + , optionsWError :: Bool } deriving Show defaultOptions :: Options defaultOptions = Options { optionsDumpCore = False , optionsVerbosityLevel = ReportSilent + , optionsWError = False } setDumpCore :: Monad m => Bool -> StateT ([CommandLineOption], Options) m () @@ -232,6 +273,11 @@ setDumpCore val = do (args, opts) <- get put (args, opts { optionsDumpCore = val }) +setWError :: Monad m => Bool -> StateT ([CommandLineOption], Options) m () +setWError val = do + (args, opts) <- get + put (args, opts { optionsWError = val }) + setVerbosityLevel :: Monad m => ReportMode -> StateT ([CommandLineOption], Options) m () setVerbosityLevel val = do @@ -260,6 +306,7 @@ parseOptions args = do parseOpt opt = case opt of "dump-core" -> setDumpCore True + "werror" -> setWError True "verbose=1" -> setVerbosityLevel ReportWarn "verbose=2" -> setVerbosityLevel ReportVerbose "verbose=3" -> setVerbosityLevel ReportVerbose1 @@ -328,10 +375,20 @@ setInlineOnBndrs dflags bndrs = everywhere $ mkT go #else #define IS_ACTIVE isActiveIn 0 #define UNIQ_FM UniqFM [Fuse] -#define GET_NAME getUnique +#define GET_NAME getName #define FMAP_SND #endif +-- Keyed by 'OccName' string rather than by 'Name'/'Unique'. A top-level Id's +-- Unique -- and even its 'NameSort' -- is not guaranteed to survive the +-- Core-to-core passes while OccName stays the same. +#define INSPECT_FM Map.Map String InspectTypes +#define INSPECT_CLASSES_FM Map.Map String InspectTypeClasses +#define FUSE_TYPES_FM Map.Map String FuseTypes +#define NO_FUSE_TYPES_FM Map.Map String NoFuseTypes +#define MAX_CORE_SIZE_FM Map.Map String MaxCoreSize +#define DUMP_CORE_FM Map.Map String DumpCore + hasInlineBinder :: CoreBndr -> Bool hasInlineBinder bndr = let inl = inlinePragInfo $ idInfo bndr @@ -347,22 +404,22 @@ hasInlineBinder bndr = #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 +-- Checks whether a case alternative contains a type for which the given +-- predicate is true. Only checks the first typed element in the list, so -- only pass alternatives from one case expression. altsContainsAnn :: - DynFlags -> UNIQ_FM -> [Alt CoreBndr] -> Maybe (Alt CoreBndr) + DynFlags -> (Name -> Bool) -> [Alt CoreBndr] -> Maybe (Alt CoreBndr) altsContainsAnn _ _ [] = Nothing altsContainsAnn _ _ ((ALT_CONSTR(DEFAULT,_,_)):[]) = debug 2 "Case trivial default" Nothing -altsContainsAnn dflags anns (bndr@(ALT_CONSTR(DataAlt dcon,_,_)):_) = +altsContainsAnn dflags isInteresting (bndr@(ALT_CONSTR(DataAlt dcon,_,_)):_) = let name = GET_NAME $ dataConTyCon dcon mesg = "Case DataAlt type " ++ showWithUnique dflags name - in case lookupUFM anns name of - Nothing -> debug 2 (mesg ++ " not annotated") Nothing - Just _ -> debug 2 (mesg ++ " annotated") (Just bndr) -altsContainsAnn dflags anns ((ALT_CONSTR(DEFAULT,_,_)):alts) = - altsContainsAnn dflags anns alts + in if isInteresting name + then debug 2 (mesg ++ " annotated") (Just bndr) + else debug 2 (mesg ++ " not annotated") Nothing +altsContainsAnn dflags isInteresting ((ALT_CONSTR(DEFAULT,_,_)):alts) = + altsContainsAnn dflags isInteresting alts altsContainsAnn _ _ ((ALT_CONSTR(LitAlt _,_,_)):_) = debug 2 "Case LitAlt" Nothing @@ -382,7 +439,7 @@ needInlineCaseAlt dflags parents anns bndr = then debug 2 (mesg ++ " not inlined") - $ case altsContainsAnn dflags anns bndr of + $ case altsContainsAnn dflags (isJust . lookupUFM anns) bndr of Just alt -> Just alt _ -> Nothing else debug 2 (mesg ++ " already inlined") Nothing @@ -529,8 +586,9 @@ data Context = CaseAlt (Alt CoreBndr) | Constr Id -- anywhere in the binders, not just case match on entry or construction on -- return. -- -containsAnns :: DynFlags -> UNIQ_FM -> CoreBind -> [([CoreBind], Context)] -containsAnns dflags anns bind = +containsAnns + :: DynFlags -> (Name -> Bool) -> CoreBind -> [([CoreBind], Context)] +containsAnns dflags isInteresting 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 @@ -542,7 +600,7 @@ containsAnns dflags anns bind = -- let bindings. go parents (Case _ _ _ alts) = let binders = alts >>= (\(ALT_CONSTR(_,_,expr1)) -> go parents expr1) - in case altsContainsAnn dflags anns alts of + in case altsContainsAnn dflags isInteresting alts of Just x -> (parents, CaseAlt x) : binders Nothing -> binders @@ -558,11 +616,9 @@ containsAnns dflags anns bind = -- Check if the Var is of the type of a data constructor of interest go parents (Var i) = case tyConAppTyConPicky_maybe (varType i) of - Just tycon -> - case lookupUFM anns (GET_NAME tycon) of - Just _ -> [(parents, Constr i)] - Nothing -> [] - Nothing -> [] + Just tycon | isInteresting (GET_NAME tycon) -> + [(parents, Constr i)] + _ -> [] -- There are no let bindings in these. go _ (Lit _) = [] @@ -575,6 +631,129 @@ containsAnns dflags anns bind = goLet parents (Rec bs) = bs >>= (\(b, expr1) -> goLet parents $ NonRec b expr1) +contextTyConName :: Context -> Maybe Name +contextTyConName (CaseAlt (ALT_CONSTR(DataAlt dcon,_,_))) = + Just (GET_NAME $ dataConTyCon dcon) +contextTyConName (CaseAlt _) = Nothing +contextTyConName (Constr con) = + GET_NAME <$> tyConAppTyConPicky_maybe (varType con) + +-- | Like 'contextTyConName' but yields the fully-qualified @Module.Type@ name +-- (via 'qualifiedTyConName') used in reports rather than the raw 'Name'. +contextQualifiedName :: Context -> Maybe String +contextQualifiedName (CaseAlt (ALT_CONSTR(DataAlt dcon,_,_))) = + Just (qualifiedTyConName (dataConTyCon dcon)) +contextQualifiedName (CaseAlt _) = Nothing +contextQualifiedName (Constr con) = + qualifiedTyConName <$> tyConAppTyConPicky_maybe (varType con) + +-- | Drop any hit whose TyCon 'Name' is in the given exclusion list. +filterExcluded + :: [Name] -> [([CoreBind], Context)] -> [([CoreBind], Context)] +filterExcluded excl = + filter (\(_, ctx) -> maybe True (`notElem` excl) (contextTyConName ctx)) + +-- | True for TyCons whose values GHC never heap-allocates: unboxed +-- primitives (e.g. 'Int#', 'State#'), unboxed tuples/sums, and true +-- enumeration types (every data constructor nullary, e.g. '()', 'Bool') +-- which are compiled as statically shared singletons. +isNonAllocatingTyCon :: TyCon -> Bool +isNonAllocatingTyCon tycon = + isPrimTyCon tycon + || isUnboxedTupleTyCon tycon + || isUnboxedSumTyCon tycon + || isEnumerationTyCon tycon + +-- | False for hits that can never represent leftover boxing: a case match +-- or construction of a non-allocating type (see 'isNonAllocatingTyCon'), or +-- a bare reference to something of function type (e.g. a primop like +-- \"+#\", or a specialized worker) which is not a data construction at +-- all. Applied unconditionally, regardless of which types the active +-- 'InspectTypes' predicate flags as \"interesting\" -- these are never useful +-- signal for a boxing/fusion report. +isAllocating :: Context -> Bool +isAllocating (CaseAlt (ALT_CONSTR(DataAlt dcon,_,_))) = + not (isNonAllocatingTyCon (dataConTyCon dcon)) +isAllocating (CaseAlt _) = True +isAllocating (Constr con) = + not (isFunTy (varType con)) + && maybe True (not . isNonAllocatingTyCon) + (tyConAppTyConPicky_maybe (varType con)) + +-- | Drop hits that can never represent leftover boxing (see 'isAllocating'). +filterNonAllocating + :: [([CoreBind], Context)] -> [([CoreBind], Context)] +filterNonAllocating = filter (isAllocating . snd) + +-- | Like GHC 'getAnnotations' but keyed by 'OccName' string instead of by +-- 'Name' (i.e. by 'Unique'). 'getAnnotations' folds annotations into a +-- 'NameEnv', and it stores only an 'Int' key internally. We read 'mg_anns' +-- directly: it is populated once from the module's '{-# ANN #-}' pragmas +-- (before any Core-to-core pass runs) and it is never rewritten by any +-- 'CoreToDo', so the 'Name's inside it are exactly as resolved by the renamer, +-- unaffected by any later binder cloning/renaming. +-- +-- At most one annotation of this type is permitted per binding: a binding +-- carrying more than one is a compile error (the @annName@ argument names the +-- annotation type in that message). +getAnnotationsByStableName + :: Data a => String -> ([Word8] -> a) -> ModGuts -> CoreM (Map.Map String a) +getAnnotationsByStableName annName deserialize guts = + Map.traverseWithKey single + (Map.fromListWith (++) (mapMaybe annPair (mg_anns guts))) + + where + + annPair (Annotation (NamedTarget name) payload) = + (\v -> (getOccString name, [v])) <$> fromSerialized deserialize payload + annPair _ = Nothing + + single _ [v] = return v + single name _ = + error $ "fusion-plugin: the binding '" ++ name + ++ "' has more than one " ++ annName + ++ " annotation; at most one " ++ annName + ++ " annotation is allowed per binding." + +-- | Resolve a list of Template Haskell 'TH.Name's to GHC 'Name's. +resolveTHNames :: [TH.Name] -> CoreM [Name] +resolveTHNames = fmap catMaybes . mapM thNameToGhcName + +-- | If the given top level binder carries a 'FuseTypes' annotation, return the +-- module-wide 'Fuse' annotation map augmented with an entry for each of the +-- named types, so that they are treated exactly like 'Fuse'-annotated types +-- while inlining inside this binding -- and nowhere else. Returns the map +-- unchanged if the binder is not annotated. +augmentFuseTypes :: UNIQ_FM -> FUSE_TYPES_FM -> CoreBndr -> CoreM (UNIQ_FM) +augmentFuseTypes anns fuseTypesAnns b = + case Map.lookup (getOccString (GET_NAME b)) fuseTypesAnns of + Nothing -> return anns + Just (FuseTypes ns) -> do + names <- resolveTHNames ns + return $ plusUFM anns (listToUFM (map (\n -> (n, [Fuse])) names)) + +removeFuseTypes :: UNIQ_FM -> NO_FUSE_TYPES_FM -> CoreBndr -> CoreM (UNIQ_FM) +removeFuseTypes anns noFuseTypesAnns b = + case Map.lookup (getOccString (GET_NAME b)) noFuseTypesAnns of + Nothing -> return anns + Just (NoFuseTypes ns) -> do + names <- resolveTHNames ns + return $ delListFromUFM anns names + +-- | Build the "isInteresting" predicate and the exclusion list for a given +-- 'InspectTypes' directive. +inspectPredicate :: UNIQ_FM -> InspectTypes -> CoreM (Name -> Bool, [Name]) +inspectPredicate _ (ForbidTypes thNames) = do + names <- resolveTHNames thNames + return (\n -> n `elem` names, []) +inspectPredicate anns (ForbidFused thForbid thAllow) = do + forbidden <- resolveTHNames thForbid + allowed <- resolveTHNames thAllow + return (\n -> isJust (lookupUFM anns n) || n `elem` forbidden, allowed) +inspectPredicate _ (PermitTypes thAllow) = do + allowed <- resolveTHNames thAllow + return (const True, allowed) + ------------------------------------------------------------------------------- -- Core-to-core pass to mark interesting binders to be always inlined ------------------------------------------------------------------------------- @@ -591,12 +770,30 @@ showDetailsCaseMatch -> ([CoreBind], Alt CoreBndr) -> String showDetailsCaseMatch dflags reportMode (binds, c@(ALT_CONSTR(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" + let vstr = + case reportMode of + ReportVerbose -> showSDoc dflags (ppr con) + ReportVerbose1 -> showSDoc dflags (ppr c) + ReportVerbose2 -> showSDoc dflags (ppr $ head binds) + _ -> error "transformBind: unreachable" + tstr = + case con of + DataAlt dcon -> + " :: " ++ qualifiedTyConName (dataConTyCon dcon) + _ -> "" + in listPath dflags binds ++ ": " ++ vstr ++ tstr + +-- | Show a 'TyCon' fully qualified as @Module.Name@ so that types with the +-- same unqualified name defined in different modules (e.g. several @Step@ +-- types) can be told apart in a report. Wired-in types with no defining +-- module are shown by their bare name. +qualifiedTyConName :: TyCon -> String +qualifiedTyConName tc = + let name = getName tc + in case nameModule_maybe name of + Just m -> + moduleNameString (moduleName m) ++ "." ++ getOccString name + Nothing -> getOccString name showDetailsConstr :: DynFlags @@ -614,24 +811,41 @@ showDetailsConstr dflags reportMode (binds, con) = tstr = case t of Nothing -> " :: Not a Type Constructor" - Just x -> " :: " ++ showSDoc dflags (ppr x) + Just x -> " :: " ++ qualifiedTyConName x in listPath dflags binds ++ ": " ++ vstr ++ tstr -- Orphan instance for 'Fuse' instance Outputable Fuse where ppr _ = text "Fuse" +-- Orphan instance for 'InspectTypes', used only to print a banner naming the +-- directive that triggered a focused report; TH 'TH.Name's are shown via +-- their derived 'Show' instance rather than GHC's 'Outputable' (which has +-- no instance for 'TH.Name'). +instance Outputable InspectTypes where + ppr (ForbidTypes names) = text "ForbidTypes" <+> text (show names) + ppr (ForbidFused f a) = + text "ForbidFused" <+> text (show f) <+> text (show a) + ppr (PermitTypes names) = text "PermitTypes" <+> text (show names) + +-- Orphan instance for 'InspectTypeClasses', used only to print a banner naming +-- the directive that triggered a focused report. +instance Outputable InspectTypeClasses where + ppr (ForbidTypeClasses names) = + text "ForbidTypeClasses" <+> text (show names) + ppr (PermitTypeClasses names) = + text "PermitTypeClasses" <+> text (show names) + showInfo :: CoreBndr -> DynFlags -> ReportMode - -> Bool -> String -> [CoreBndr] -> [([CoreBind], a)] -> (DynFlags -> ReportMode -> ([CoreBind], a) -> String) -> CoreM () -showInfo parent dflags reportMode failIt +showInfo parent dflags reportMode tag uniqBinders annotated showDetails = when (uniqBinders /= []) $ do let mesg = "In " @@ -649,23 +863,277 @@ showInfo parent dflags reportMode failIt putMsgS $ DL.unlines $ DL.nub $ map (showDetails dflags reportMode) annotated - when failIt $ error "failing" -markInline :: Int -> ReportMode -> Bool -> Bool -> ModGuts -> CoreM ModGuts -markInline pass reportMode failIt transform guts = do +-- | If the given top level bind's own binder carries an 'InspectTypes' +-- annotation, print a report of interesting types case-matched or +-- constructed anywhere in its RHS, per the annotation's rules. No-op if +-- the binder is not annotated, or if the binding has no offending types. +-- +-- The output honours the module-wide verbosity: at the default (or +-- @verbose=1@) a single terse @found forbidden types@ line is printed; at +-- @verbose=2@ and above the full "Inspecting ..." banner plus per-hit +-- @SCRUTINIZE@/@CONSTRUCT@ breakdown is printed. +-- Returns 0 on no violations and 1 otherwise. +reportInspected + :: DynFlags -> ReportMode -> UNIQ_FM -> INSPECT_FM -> CoreBind -> CoreM Int +reportInspected dflags reportMode anns inspectAnns bind@(NonRec b _) = + case Map.lookup (getOccString (GET_NAME b)) inspectAnns of + Nothing -> return 0 + Just ispec -> go ispec + + where + + go ispec = do + (isInteresting, exclusion) <- inspectPredicate anns ispec + let results = filterNonAllocating + $ filterExcluded exclusion (containsAnns dflags isInteresting bind) + if null results + then return 0 + else do + case reportMode of + ReportSilent -> terse results + ReportWarn -> terse results + _ -> detailed ispec results + return 1 + + terse results = + let names = DL.nub (mapMaybe (contextQualifiedName . snd) results) + in putMsgS $ "fusion-plugin: " + ++ getOccString (GET_NAME b) + ++ ": found forbidden types [" + ++ DL.intercalate ", " names ++ "]" + + detailed ispec results = do + putMsgS $ "fusion-plugin: " + ++ showWithUnique dflags b + ++ ": inspecting (" ++ showSDoc dflags (ppr ispec) ++ ")..." + let getAlts x = + case x of + (bs, CaseAlt alt) -> Just (bs, alt) + _ -> Nothing + patternMatches = mapMaybe getAlts results + uniqBinders = + DL.nub (map (getNonRecBinder . head . fst) patternMatches) + + getConstrs x = + case x of + (bs, Constr con) -> Just (bs, con) + _ -> Nothing + constrs = mapMaybe getConstrs results + uniqConstr = DL.nub (map (getNonRecBinder . head . fst) constrs) + + showInfo b dflags reportMode "SCRUTINIZE" + uniqBinders patternMatches showDetailsCaseMatch + showInfo b dflags reportMode "CONSTRUCT" + uniqConstr constrs showDetailsConstr +reportInspected _ _ _ _ (Rec _) = + error "reportInspected: expecting only NonRec binders" + +------------------------------------------------------------------------------- +-- Inspect the presence/absence of type classes in a binding's Core +------------------------------------------------------------------------------- + +-- | Collect the class 'TyCon's appearing anywhere in the Core of a binding. A +-- type class manifests in Core as a dictionary; its type has the class 'TyCon' +-- at the head (see 'isClassTyCon'). We gather the 'TyCon's mentioned by the +-- type of every 'Var', binder, case scrutinee and 'Type' node in the RHS and +-- keep those that are classes. +classTyConsInBind :: CoreBind -> [TyCon] +classTyConsInBind bind = + nonDetEltsUniqSet (goBind bind) + + where + + fromType t = filterUniqSet isClassTyCon (tyConsOfType t) + + go (Var i) = fromType (varType i) + go (Lit _) = emptyUniqSet + go (App e1 e2) = go e1 `unionUniqSets` go e2 + go (Lam b e) = fromType (varType b) `unionUniqSets` go e + go (Let b e) = goBind b `unionUniqSets` go e + go (Case e b t alts) = + go e + `unionUniqSets` fromType (varType b) + `unionUniqSets` fromType t + `unionUniqSets` unionManyUniqSets (map goAlt alts) + go (Cast e _) = go e + go (Tick _ e) = go e + go (Type t) = fromType t + go (Coercion _) = emptyUniqSet + + goAlt (ALT_CONSTR(_,bs,e)) = + unionManyUniqSets (map (fromType . varType) bs) `unionUniqSets` go e + + goBind (NonRec b e) = fromType (varType b) `unionUniqSets` go e + goBind (Rec bs) = + unionManyUniqSets + (map (\(b, e) -> fromType (varType b) `unionUniqSets` go e) bs) + +-- | Build the "isInteresting" predicate over class 'Name's for a given +-- 'InspectTypeClasses' directive. +inspectClassPredicate :: InspectTypeClasses -> CoreM (Name -> Bool) +inspectClassPredicate (ForbidTypeClasses thNames) = do + names <- resolveTHNames thNames + return (\n -> n `elem` names) +inspectClassPredicate (PermitTypeClasses thAllow) = do + allowed <- resolveTHNames thAllow + return (\n -> n `notElem` allowed) + +-- | If the given top level bind's own binder carries an 'InspectTypeClasses' +-- annotation, print a report of the type classes present in its Core that the +-- directive flags as forbidden. No-op if the binder is not annotated, or if no +-- offending class is present. +-- Returns 0 on no violations and 1 otherwise. +reportInspectedClasses + :: DynFlags + -> ReportMode + -> INSPECT_CLASSES_FM + -> CoreBind + -> CoreM Int +reportInspectedClasses dflags reportMode classAnns bind@(NonRec b _) = + case Map.lookup (getOccString (GET_NAME b)) classAnns of + Nothing -> return 0 + Just ispec -> go ispec + + where + + go ispec = do + isInteresting <- inspectClassPredicate ispec + let hits = filter (isInteresting . getName) (classTyConsInBind bind) + if null hits + then return 0 + else do + case reportMode of + ReportSilent -> report ispec hits + ReportWarn -> report ispec hits + _ -> do + putMsgS $ "fusion-plugin: " + ++ showWithUnique dflags b + ++ ": inspecting (" ++ showSDoc dflags (ppr ispec) ++ ")..." + report ispec hits + return 1 + + report _ hits = + let names = DL.nub (map qualifiedTyConName hits) + in putMsgS $ "fusion-plugin: " + ++ getOccString (GET_NAME b) + ++ ": found forbidden type classes [" + ++ DL.intercalate ", " names ++ "]" +reportInspectedClasses _ _ _ (Rec _) = + error "reportInspectedClasses: expecting only NonRec binders" + +-- Returns 0 on no violations and 1 otherwise. +reportCoreSize + :: DynFlags -> ReportMode -> MAX_CORE_SIZE_FM -> CoreBind -> CoreM Int +reportCoreSize dflags reportMode sizeAnns (NonRec b rhs) = + case Map.lookup (getOccString (GET_NAME b)) sizeAnns of + Nothing -> return 0 + Just ann -> go ann + where + stats = exprStats rhs + terms = cs_tm stats + + go (MaxCoreSize maxSize) = do + case reportMode of + ReportSilent -> return () + ReportWarn -> return () + _ -> + putMsgS $ "fusion-plugin: " + ++ showWithUnique dflags b + ++ ": core size " + ++ showSDoc dflags (ppr stats) + if terms > maxSize + then do + putMsgS $ "fusion-plugin: " + ++ showWithUnique dflags b + ++ ": core size (" ++ show terms + ++ " terms) exceeds the specified size (" + ++ show maxSize ++ " terms)." + return 1 + else return 0 +reportCoreSize _ _ _ (Rec _) = + error "reportCoreSize: expecting only NonRec binders" + +-- | Split a string on @\'-\'@ characters. +splitOnDash :: String -> [String] +splitOnDash s = + case break (== '-') s of + (a, []) -> [a] + (a, _ : rest) -> a : splitOnDash rest + +-- | Recover the bare package name from a unit-id string. During a build the +-- unit id of the package being compiled looks like @my-pkg-0.2.8-inplace@ (or +-- with a hash instead of @inplace@); we strip the trailing version and any +-- component suffix, leaving just @my-pkg@. If no version-like component is +-- found the string is returned unchanged. +packageNameFromUnitId :: String -> String +packageNameFromUnitId uid = + case break isVersion (splitOnDash uid) of + (before, _ : _) | not (null before) -> DL.intercalate "-" before + _ -> uid + where + isVersion x = not (null x) && all (\c -> isDigit c || c == '.') x + +-- | The bare package name of the module currently being compiled. +modulePackageName :: Module -> String +modulePackageName = + packageNameFromUnitId +#if MIN_VERSION_ghc(9,0,0) + . unitString . moduleUnit +#else + . unitIdString . moduleUnitId +#endif + +-- | If the given top level bind's own binder carries a 'DumpCore' annotation, +-- write the Core of that binding to a file under the @fusion-plugin-output@ +-- directory. No-op if the binder is not annotated. +reportDumpCore :: + DynFlags -> String -> String -> DUMP_CORE_FM -> CoreBind -> CoreM () +reportDumpCore dflags pkgName modName dumpAnns bind@(NonRec b _) = + case Map.lookup (getOccString (GET_NAME b)) dumpAnns of + Nothing -> return () + Just _ -> do + let dir = "fusion-plugin-output" pkgName + fileName = + modName ++ "." ++ getOccString (GET_NAME b) ++ ".dump-simpl" + path = dir fileName + liftIO $ do + createDirectoryIfMissing True dir + writeFile path (showSDoc dflags (ppr bind) ++ "\n") + putMsgS $ "fusion-plugin: " + ++ showWithUnique dflags b ++ ": dumped core to " ++ path +reportDumpCore _ _ _ _ (Rec _) = + error "reportDumpCore: expecting only NonRec binders" + +markInline :: Int -> ReportMode -> Bool -> ModGuts -> CoreM ModGuts +markInline pass reportMode transform guts = do putMsgS $ "fusion-plugin: Checking bindings to inline..." dflags <- getDynFlags anns <- FMAP_SND getAnnotations deserializeWithData guts - if (anyUFM (any (== Fuse)) anns) + fuseTypesAnns <- + getAnnotationsByStableName "FuseTypes" deserializeWithData guts + noFuseTypesAnns <- + getAnnotationsByStableName "NoFuseTypes" deserializeWithData guts + if (anyUFM (any (== Fuse)) anns || not (Map.null fuseTypesAnns)) then do - r <- bindsOnlyPass (mapM (transformBind dflags anns)) guts + r <- bindsOnlyPass + (mapM + (transformBind dflags anns fuseTypesAnns noFuseTypesAnns)) + guts if dbgLevel > 0 then dumpCore 0 (text ("Fusion-plugin-" ++ show pass)) r else return r else return guts where -- transformBind :: DynFlags -> UniqFM Unique [Fuse] -> CoreBind -> CoreM CoreBind - transformBind dflags anns bind@(NonRec b _) = do + transformBind dflags anns0 fuseTypesAnns noFuseTypesAnns bind@(NonRec b _) = do + -- Types named in a 'FuseTypes' annotation on this binding act as if + -- they were 'Fuse'-annotated, but only while inlining inside it. + -- Types named in a 'NoFuseTypes' annotation are stripped of their + -- 'Fuse' status locally, overriding the above and any module-wide + -- 'Fuse' annotation for this binding only. + anns1 <- augmentFuseTypes anns0 fuseTypesAnns b + anns <- removeFuseTypes anns1 noFuseTypesAnns b let patternMatches = letBndrsThatAreCases dflags anns bind let uniqPat = DL.nub (map (getNonRecBinder. head . fst) patternMatches) @@ -686,9 +1154,9 @@ markInline pass reportMode failIt transform guts = do putMsgS "INLINE required on:" putMsgS $ DL.unlines $ DL.nub $ map (listPath dflags) allBinds _ -> do - showInfo b dflags reportMode failIt "SCRUTINIZE" + showInfo b dflags reportMode "SCRUTINIZE" uniqPat patternMatches showDetailsCaseMatch - showInfo b dflags reportMode failIt "CONSTRUCT" + showInfo b dflags reportMode "CONSTRUCT" uniqConstr constrs showDetailsConstr let bind' = do @@ -698,19 +1166,20 @@ markInline pass reportMode failIt transform guts = do else bind return bind' - transformBind dflags anns (Rec bs) = do + transformBind dflags anns fuseTypesAnns noFuseTypesAnns (Rec bs) = do fmap Rec (mapM transformAsNonRec bs) where transformAsNonRec (b, expr) = do - r <- transformBind dflags anns (NonRec b expr) + r <- transformBind dflags anns fuseTypesAnns noFuseTypesAnns + (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 :: Int -> ReportMode -> Bool -> Bool -> CoreToDo -fusionMarkInline pass opt failIt transform = - CoreDoPluginPass "Mark for inlining" (markInline pass opt failIt transform) +fusionMarkInline :: Int -> ReportMode -> Bool -> CoreToDo +fusionMarkInline pass opt transform = + CoreDoPluginPass "Mark for inlining" (markInline pass opt transform) ------------------------------------------------------------------------------- -- Simplification pass after marking inline @@ -760,61 +1229,172 @@ fusionSimplify _hsc_env dflags = -- Report unfused constructors ------------------------------------------------------------------------------- -fusionReport :: String -> ReportMode -> ModGuts -> CoreM ModGuts -fusionReport mesg reportMode guts = do +-- | The set of top level binders that are reachable from an exported +-- binder, and therefore guaranteed to survive into the final program. +-- +-- This plugin's final check runs as the very last 'CoreToDo', but GHC's +-- "CoreTidy" runs even after that, it changes the Core and there is no way to +-- run a hook after that in the plugin. We approximate CoreTidy's reachability +-- analysis here so we can skip unreachable bindings, seeding it from the same +-- 'isExportedId' flag CoreTidy itself relies on. +-- +liveTopLevelBinders :: ModGuts -> VarSet +liveTopLevelBinders guts = go initial initial + + where + + flattenBind (NonRec b e) = [(b, e)] + flattenBind (Rec bs) = bs + + topBinds = mg_binds guts >>= flattenBind + topBndrSet = mkVarSet (map fst topBinds) + + adjacency :: VarEnv VarSet + adjacency = mkVarEnv + [ (b, intersectVarSet topBndrSet (exprFreeVars rhs)) + | (b, rhs) <- topBinds + ] + + initial = mkVarSet (filter isExportedId (map fst topBinds)) + + go frontier visited + | isEmptyVarSet frontier = visited + | otherwise = + let next = unionVarSets + $ mapMaybe (lookupVarEnv adjacency) + $ nonDetEltsUniqSet frontier + newVisited = unionVarSet visited next + newFrontier = next `minusVarSet` visited + in go newFrontier newVisited + +-- | @runInspect@ controls whether the per-binding 'InspectTypes' annotations are +-- also processed. When @werror@ is set, the build is failed (after all +-- annotation violations in the module have been reported) if any +-- annotation-check violation ('InspectTypes', 'InspectTypeClasses' or +-- 'MaxCoreSize') was found. +fusionReport :: String -> ReportMode -> Bool -> Bool -> ModGuts -> CoreM ModGuts +fusionReport mesg reportMode runInspect werror guts = do + inspectAnns <- + if runInspect + then getAnnotationsByStableName "InspectTypes" deserializeWithData guts + else return Map.empty + sizeAnns <- + if runInspect + then getAnnotationsByStableName "MaxCoreSize" deserializeWithData guts + else return Map.empty + dumpAnns <- + if runInspect + then getAnnotationsByStableName "DumpCore" deserializeWithData guts + else return Map.empty + classAnns <- + if runInspect + then getAnnotationsByStableName + "InspectTypeClasses" deserializeWithData guts + else return Map.empty + let anyInspect = runInspect && not (Map.null inspectAnns) + anyInspectClasses = runInspect && not (Map.null classAnns) + anyMaxCoreSize = runInspect && not (Map.null sizeAnns) + anyDumpCore = runInspect && not (Map.null dumpAnns) + anyReport = + anyInspect || anyInspectClasses || anyMaxCoreSize || anyDumpCore case reportMode of - ReportSilent -> return guts + ReportSilent | not anyReport -> return guts _ -> do - putMsgS $ "fusion-plugin: " ++ mesg ++ "..." + when (reportMode /= ReportSilent) $ + putMsgS $ "fusion-plugin: " ++ mesg ++ "..." dflags <- getDynFlags anns <- FMAP_SND getAnnotations deserializeWithData guts - when (anyUFM (any (== Fuse)) anns) $ - mapM_ (transformBind dflags anns) $ mg_binds guts + let liveBndrs = liveTopLevelBinders guts + let pkgName = modulePackageName (mg_module guts) + let modName = moduleNameString (moduleName (mg_module guts)) + violations <- + if anyUFM (any (== Fuse)) anns || anyReport + then fmap sum + $ mapM + (transformBind + dflags anns inspectAnns classAnns sizeAnns + dumpAnns pkgName modName liveBndrs) + $ mg_binds guts + else return 0 + when (werror && violations > 0) $ do + putMsgS $ "fusion-plugin: " ++ show violations + ++ " annotation violation(s) reported in " ++ modName + ++ "; failing the build (werror)." + liftIO $ throwGhcExceptionIO + (ProgramError + "fusion-plugin: annotation violations found (werror)") return guts where - transformBind :: DynFlags -> UNIQ_FM -> CoreBind -> CoreM () - transformBind dflags anns bind@(NonRec b _) = do - let results = containsAnns dflags anns bind - - 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 + -- Returns the number of annotation-check violations reported for this + -- binding (the module-wide unfused report below is not counted). + transformBind + :: DynFlags -> UNIQ_FM -> INSPECT_FM -> INSPECT_CLASSES_FM + -> MAX_CORE_SIZE_FM -> DUMP_CORE_FM + -> String -> String -> VarSet + -> CoreBind -> CoreM Int + transformBind dflags anns inspectAnns classAnns sizeAnns dumpAnns + pkgName modName liveBndrs bind@(NonRec b _) = do + n1 <- if runInspect + then reportInspected dflags reportMode anns inspectAnns bind + else return 0 + n2 <- if runInspect + then reportInspectedClasses dflags reportMode classAnns bind + else return 0 + n3 <- if runInspect + then reportCoreSize dflags reportMode sizeAnns bind + else return 0 + when runInspect $ reportDumpCore dflags pkgName modName dumpAnns bind + when (b `elemVarSet` liveBndrs) $ do + let results = filterNonAllocating + $ containsAnns dflags (isJust . lookupUFM anns) bind + + 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 "SCRUTINIZE" + uniqBinders patternMatches showDetailsCaseMatch + showInfo b dflags reportMode "CONSTRUCT" + uniqConstr constrs showDetailsConstr + return (n1 + n2 + n3) + + transformBind dflags anns inspectAnns classAnns sizeAnns dumpAnns + pkgName modName liveBndrs (Rec bs) = + fmap sum + $ mapM + (\(b, expr) -> + transformBind + dflags anns inspectAnns classAnns sizeAnns dumpAnns + pkgName modName liveBndrs (NonRec b expr)) + bs ------------------------------------------------------------------------------- -- Dump core passes @@ -1129,19 +1709,23 @@ install args todos = do else id) $ insertAfterSimplPhase0 todos - [ fusionMarkInline 1 ReportSilent False True + [ fusionMarkInline 1 ReportSilent True , simplify - , fusionMarkInline 2 ReportSilent False True + , fusionMarkInline 2 ReportSilent True , simplify - , fusionMarkInline 3 ReportSilent False True + , fusionMarkInline 3 ReportSilent True , simplify -- This lets us know what was left unfused after all the inlining -- and case-of-case transformations. , let mesg = "Check unfused (post inlining)" - in CoreDoPluginPass mesg (fusionReport mesg ReportSilent) + in CoreDoPluginPass mesg + (fusionReport mesg ReportSilent False False) ] (let mesg = "Check unfused (final)" - report = fusionReport mesg (optionsVerbosityLevel options) + report = + fusionReport + mesg (optionsVerbosityLevel options) True + (optionsWError options) in CoreDoPluginPass mesg report) #else install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] diff --git a/stack.yaml b/stack.yaml index 9c73980..5a1cb74 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,6 @@ resolver: lts-24.36 packages: - '.' +extra-deps: + - git: https://github.com/composewell/fusion-plugin-types.git + commit: d4fa57623450ba4a43f08ebd7cfbfc2745035375