diff --git a/README.md b/README.md index b55e500..55587fd 100644 --- a/README.md +++ b/README.md @@ -124,7 +124,7 @@ function :: ... ### Inspecting Boxed Types within a Function To verify elimination of certain types within a function annotate -the function with `InspectAllocations` (types constructed/allocated) +the function with `InspectConstructions` (types constructed/allocated) and/or `InspectPatternMatches` (types scrutinized in a `case`). If a violation is found the plugin will complain providing details of the violation. When the `werror` plugin option is used it will fail the @@ -132,50 +132,49 @@ compilation on violation. The two annotation types are independent, so a single binding may carry one of each to inspect both the constructing and the scrutinizing -position at once. All the examples below use the allocation variant; +position at once. All the examples below use the construction variant; each has an analogous `...PatternMatches` counterpart. ```haskell {-# LANGUAGE TemplateHaskellQuotes #-} -import Fusion.Plugin.Types (InspectAllocations(..), InspectPatternMatches(..)) +import Fusion.Plugin.Types (InspectConstructions(..), InspectPatternMatches(..)) ``` -### Using `Fuse` Annotated as Baseline +The whole system reduces to four simple rules: -Complain if any `Fuse` annotated type is allocated in the function. -```haskell -{-# ANN function (ForbidFusedAllocations [] []) #-} -function1 :: ... -``` - -Also forbid `Maybe` as well even though it isn't Fuse-annotated. -```haskell -{-# ANN function (ForbidFusedAllocations [''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 function (ForbidFusedAllocations [''Maybe] [''Step]) #-} -function1b :: ... -``` +* A type explicitly listed in a `Forbid...` annotation is **always reported** + (forbidden). +* A type explicitly listed in a `Permit...` annotation is **always allowed** + (permitted), never reported. +* The `forbid-fused` plugin option **adds all `Fuse` annotated types to the + forbidden set**. +* By default unboxed types are implicitly in the permitted list. The + `inspect-unboxed` plugin option means **unboxed types are no longer + implicitly permitted**. ### Forbidding Only Selected Types -Disallow the specified types and allow the rest, irrespective of `Fuse` -annotation. To check both allocations and pattern matches, attach one +Disallow only the specified types and allow the rest, irrespective of the +`Fuse` annotation. To check both constructions and pattern matches, attach one annotation of each type to the binding. ```haskell -{-# ANN function (ForbidAllocations [''Step]) #-} +{-# ANN function (ForbidConstructions [''Step]) #-} {-# ANN function (ForbidPatternMatches [''Step]) #-} function2 :: ... ``` -Report the listed types only where they are allocated: +Additionally pass the `forbid-fused` plugin option to forbid all `Fuse` +annotated types too, using them as a baseline; the types named in the +annotation are then forbidden on top of them. With this option +`ForbidConstructions []` forbids exactly the `Fuse` annotated types. +``` +ghc-options: -fplugin-opt=Fusion.Plugin:forbid-fused +``` + +Report the listed types only where they are constructed: ```haskell -{-# ANN function (ForbidAllocations [''Step]) #-} +{-# ANN function (ForbidConstructions [''Step]) #-} ``` Report the listed types only where they are pattern-matched: @@ -186,23 +185,23 @@ Report the listed types only where they are pattern-matched: ### Permitting Only Selected Types Allow only the specified types and disallow all others. To check both -allocations and pattern matches, attach one annotation of each type to the +constructions and pattern matches, attach one annotation of each type to the binding. ```haskell -{-# ANN function (PermitAllocations [''Int, ''IO]) #-} +{-# ANN function (PermitConstructions [''Int, ''IO]) #-} {-# ANN function (PermitPatternMatches [''Int, ''IO]) #-} function3 :: ... ``` -To report every allocated type used within a function: +To report every constructed type used within a function: ```haskell -{-# ANN function (PermitAllocations []) #-} +{-# ANN function (PermitConstructions []) #-} function4 :: ... ``` -Report every allocated type except the listed ones: +Report every constructed type except the listed ones: ```haskell -{-# ANN function (PermitAllocations [''Int, ''IO]) #-} +{-# ANN function (PermitConstructions [''Int, ''IO]) #-} ``` Report every pattern-matched type except the listed ones: @@ -214,6 +213,19 @@ If any of the types in the permitted list is not actually found in the binding, a warning is emitted so that stale entries can be removed from the list. +### Including Unboxed Types in the Inspection + +By default unboxed types (e.g. `Int#`, unboxed tuples and sums) are +implicitly considered in the `Permit...` list. + +When `inspect-unboxed` plugin option is used, unboxed types are no longer +implicitly permitted, you will have to mention them explicitly in the permitted +list to allow them, forbidden list is not affected by this option. + +``` +ghc-options: -fplugin-opt=Fusion.Plugin:inspect-unboxed +``` + ### Inspecting type class dictionaries To check the presence or absence of type classes in the Core of a binding, @@ -302,7 +314,7 @@ violation. ### Detecting code bloat To record the core size of every binding that carries a violation-causing -annotation (`InspectPatternMatches`, `InspectAllocations`, `InspectTypeClasses` +annotation (`InspectPatternMatches`, `InspectConstructions`, `InspectTypeClasses` or `MaxCoreSize`) to a file, pass the `dump-core-sizes` option: ``` ghc-options: -fplugin-opt=Fusion.Plugin:dump-core-sizes @@ -341,7 +353,7 @@ otherwise. Each pass adds a `.dump-simpl` suffix, e.g. `dump-core-if-annotated` option dumps the core of every binding that carries a violation-causing annotation (`InspectPatternMatches`, -`InspectAllocations`, `InspectTypeClasses` or `MaxCoreSize`), without adding a +`InspectConstructions`, `InspectTypeClasses` or `MaxCoreSize`), without adding a `DumpCore` annotation to each one: ``` ghc-options: -fplugin-opt=Fusion.Plugin:dump-core-if-annotated diff --git a/cabal.project b/cabal.project index 4dd58eb..c07cdf7 100644 --- a/cabal.project +++ b/cabal.project @@ -6,4 +6,4 @@ package fusion-plugin source-repository-package type: git location: https://github.com/composewell/fusion-plugin-types.git - tag: 1f21d07917b62e1b9a5327f930bd31168441d505 + tag: a74c4a229303b3df25d06853d80408c55b3e45e7 diff --git a/src/Fusion/Plugin.hs b/src/Fusion/Plugin.hs index ea2b2ed..6f6e06d 100644 --- a/src/Fusion/Plugin.hs +++ b/src/Fusion/Plugin.hs @@ -141,6 +141,25 @@ import Fusion.Plugin.Inspect -- -- Verbosity levels @2@, @3@, @4@ can be used for more verbose output. -- +-- GHC option to make every @Forbid...@ annotation +-- ('Fusion.Plugin.Types.ForbidPatternMatches', +-- 'Fusion.Plugin.Types.ForbidConstructions') to implicitly forbid all +-- 'Fusion.Plugin.Types.Fuse' annotated types. +-- This does not affect the @Permit...@ annotations: +-- +-- @ +-- ghc-options: -fplugin-opt=Fusion.Plugin:forbid-fused +-- @ +-- +-- By default unboxed types (e.g. @Int#@, unboxed tuples and sums) are +-- implicitly in the permitted list. When `inspect-fused` plugin option is +-- enabled they are no longer implicitly permitted, they will now have to be +-- explictly mentioned in the permitted list to allow them. +-- +-- @ +-- ghc-options: -fplugin-opt=Fusion.Plugin:inspect-unboxed +-- @ +-- -- To dump the core after each core to core transformation, pass the -- following to your ghc-options: -- @@ -152,8 +171,9 @@ import Fusion.Plugin.Inspect -- Note: @dump-core@ does not work for GHC-9.0.x. -- -- To record the optimized core size of every binding that carries a --- violation-causing annotation ('InspectPatternMatches', 'InspectAllocations', --- 'InspectTypeClasses' or 'MaxCoreSize') to a CSV file, pass the following: +-- violation-causing annotation ('InspectPatternMatches', +-- 'InspectConstructions', 'InspectTypeClasses' or 'MaxCoreSize') to a CSV +-- file, pass the following: -- -- @ -- ghc-options: -fplugin-opt=Fusion.Plugin:dump-core-sizes @@ -175,7 +195,7 @@ import Fusion.Plugin.Inspect -- @ -- -- To dump the Core of every binding that carries a violation-causing --- annotation ('InspectPatternMatches', 'InspectAllocations', +-- annotation ('InspectPatternMatches', 'InspectConstructions', -- 'InspectTypeClasses' or 'MaxCoreSize'), pass the following: -- -- @ @@ -230,6 +250,8 @@ defaultOptions = Options , optionsVerbosityLevel = ReportSilent , optionsWError = False , optionsCsvAppend = False + , optionsForbidFused = False + , optionsInspectUnboxed = False } setDumpCore :: Monad m => Bool -> StateT ([CommandLineOption], Options) m () @@ -264,6 +286,17 @@ setCsvAppend val = do (args, opts) <- get put (args, opts { optionsCsvAppend = val }) +setForbidFused :: Monad m => Bool -> StateT ([CommandLineOption], Options) m () +setForbidFused val = do + (args, opts) <- get + put (args, opts { optionsForbidFused = val }) + +setInspectUnboxed + :: Monad m => Bool -> StateT ([CommandLineOption], Options) m () +setInspectUnboxed val = do + (args, opts) <- get + put (args, opts { optionsInspectUnboxed = val }) + setVerbosityLevel :: Monad m => ReportMode -> StateT ([CommandLineOption], Options) m () setVerbosityLevel val = do @@ -295,6 +328,8 @@ parseOptions args = "dump-core-if-violated" -> setDumpCoreIfViolated True "werror" -> setWError True "csv-append" -> setCsvAppend True + "forbid-fused" -> setForbidFused True + "inspect-unboxed" -> setInspectUnboxed True "verbose=1" -> setVerbosityLevel ReportWarn "verbose=2" -> setVerbosityLevel ReportVerbose "verbose=3" -> setVerbosityLevel ReportVerbose1 diff --git a/src/Fusion/Plugin/Common.hs b/src/Fusion/Plugin/Common.hs index 1b2c3d1..95a86a4 100644 --- a/src/Fusion/Plugin/Common.hs +++ b/src/Fusion/Plugin/Common.hs @@ -182,6 +182,8 @@ data Options = Options , optionsVerbosityLevel :: ReportMode , optionsWError :: Bool , optionsCsvAppend :: Bool + , optionsForbidFused :: Bool + , optionsInspectUnboxed :: Bool } deriving Show -- Checks whether a case alternative contains a type for which the given diff --git a/src/Fusion/Plugin/Inspect.hs b/src/Fusion/Plugin/Inspect.hs index e41aa25..91e1151 100644 --- a/src/Fusion/Plugin/Inspect.hs +++ b/src/Fusion/Plugin/Inspect.hs @@ -69,7 +69,7 @@ import Fusion.Plugin.Common -- Unique -- and even its 'NameSort' -- is not guaranteed to survive the -- Core-to-core passes while OccName stays the same. #define INSPECT_PM_FM Map.Map String InspectPatternMatches -#define INSPECT_ALLOC_FM Map.Map String InspectAllocations +#define INSPECT_CONSTR_FM Map.Map String InspectConstructions #define INSPECT_CLASSES_FM Map.Map String InspectTypeClasses #define MAX_CORE_SIZE_FM Map.Map String MaxCoreSize #define DUMP_CORE_FM Map.Map String DumpCore @@ -195,7 +195,7 @@ filterExcluded excl = -- | True when the type occurs in a scrutinizing (pattern-match, i.e. @case@) -- position -- a value being deconstructed. Note this is a /use/ of the value, --- not an allocation: the box was allocated elsewhere (see 'isHeapAllocated'). +-- not an allocation: the box was allocated elsewhere (see 'isBoxedHit'). isPatternMatch :: Context -> Bool isPatternMatch (CaseAlt _) = True isPatternMatch (CaseScrut _) = True @@ -208,31 +208,33 @@ isConstruction (Constr _) = True isConstruction (CaseAlt _) = False isConstruction (CaseScrut _) = False --- | 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. -isNotHeapAllocatedTyCon :: TyCon -> Bool -isNotHeapAllocatedTyCon tycon = +-- | True for unboxed TyCons: unboxed primitives (e.g. 'Int#', 'State#'), +-- unboxed tuples and unboxed sums. +-- +-- Note enumeration types (e.g. '()', 'Bool', 'SPEC') are /not/ included here. +-- Even though GHC allocates their values as global staic closures rather than +-- on the heap, they are still boxed -- deconstructing or using one goes +-- through a pointer indirection. +isUnboxedTyCon :: TyCon -> Bool +isUnboxedTyCon tycon = isPrimTyCon tycon || isUnboxedTupleTyCon tycon || isUnboxedSumTyCon tycon - || isEnumerationTyCon tycon --- | False for the cases that can never represent boxing: a case match or --- construction of a non-allocating type (see 'isNotHeapAllocatedTyCon'), 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. +-- | False for hits that can never represent boxing: a case match or +-- construction of an unboxed type (see 'isUnboxedTyCon'), 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. -- -- This covers all usage including case scrutiny as well as construction. -isHeapAllocated :: Context -> Bool -isHeapAllocated (CaseAlt (ALT_CONSTR(DataAlt dcon,_,_))) = - not (isNotHeapAllocatedTyCon (dataConTyCon dcon)) -isHeapAllocated (CaseAlt _) = True -isHeapAllocated (CaseScrut bndr) = - maybe True (not . isNotHeapAllocatedTyCon) +isBoxedHit :: Context -> Bool +isBoxedHit (CaseAlt (ALT_CONSTR(DataAlt dcon,_,_))) = + not (isUnboxedTyCon (dataConTyCon dcon)) +isBoxedHit (CaseAlt _) = True +isBoxedHit (CaseScrut bndr) = + maybe True (not . isUnboxedTyCon) (tyConAppTyConPicky_maybe (varType bndr)) -isHeapAllocated (Constr con) = +isBoxedHit (Constr con) = case isDataConId_maybe con of -- A genuine data-constructor 'Id' is never itself the "bare -- reference to something of function type" this guards against @@ -240,16 +242,20 @@ isHeapAllocated (Constr con) = -- exclusion below does not apply here -- it would wrongly drop -- every non-nullary constructor (e.g. @(:)@), whose own type is a -- function over its fields. - Just dcon -> not (isNotHeapAllocatedTyCon (dataConTyCon dcon)) + Just dcon -> not (isUnboxedTyCon (dataConTyCon dcon)) Nothing -> not (isFunTy (varType con)) - && maybe True (not . isNotHeapAllocatedTyCon) + && maybe True (not . isUnboxedTyCon) (tyConAppTyConPicky_maybe (varType con)) --- | Drop the cases that can never represent boxing (see 'isHeapAllocated'). -keepHeapAllocatedOnly +-- | Drop the hits that can never represent boxing (see 'isBoxedHit'). +keepBoxedOnly :: [([CoreBind], Context)] -> [([CoreBind], Context)] -keepHeapAllocatedOnly = filter (isHeapAllocated . snd) +keepBoxedOnly = filter (isBoxedHit . snd) + +forbidding :: Bool -> UNIQ_FM -> [Name] -> Name -> Bool +forbidding forbidFused anns names n = + n `elem` names || (forbidFused && isJust (lookupUFM anns n)) -- | Show a scrutinizing hit for the detailed report. A 'Left' is a scrutiny -- that matched a data constructor (delegated to 'showDetailsCaseMatch'); a @@ -276,11 +282,11 @@ showDetailsScrutinize dflags reportMode (binds, Right bndr) = in listPath dflags binds ++ ": " ++ vstr ++ tstr ------------------------------------------------------------------------------- --- Inspect pattern matches and allocations +-- Inspect pattern matches and constructions ------------------------------------------------------------------------------- -- | The position-normalized form of an inspection directive. Both --- 'InspectPatternMatches' and 'InspectAllocations' are reduced to this common +-- 'InspectPatternMatches' and 'InspectConstructions' are reduced to this common -- shape so that the reporting machinery need not know which one it came from; -- the two differ only in the position filter, the report labels, and the -- banner text captured here. @@ -290,6 +296,9 @@ data NormInspect = NormInspect -- about. , niExclusion :: [Name] -- ^ Names to exclude from the reported hits (the allow list). + , niExplicit :: [Name] + -- ^ Types the directive names explicitly (the forbid list for a "forbid" + -- directive, the allow list for a "permit" one). , niPosition :: Context -> Bool -- ^ Position filter: keep only scrutinizing or only constructing hits. , niPermit :: Maybe (String, [TH.Name]) @@ -299,94 +308,78 @@ data NormInspect = NormInspect -- ^ Label used in the terse "found ..." report line. , niBanner :: String -- ^ The directive rendered for the detailed report banner. - , niHeapFilter :: Bool - -- ^ Whether to drop non-heap-allocated hits in allocation matches. } -- | Normalize an 'InspectPatternMatches' directive. All of its constructors -- act on the scrutinizing (pattern-match) position. -normPatternMatches :: UNIQ_FM -> InspectPatternMatches -> CoreM NormInspect -normPatternMatches anns d = do - (interesting, excl, permit, banner) <- case d of +normPatternMatches + :: Bool -> UNIQ_FM -> InspectPatternMatches -> CoreM NormInspect +normPatternMatches forbidFused anns d = do + (interesting, excl, explicit, permit, banner) <- case d of ForbidPatternMatches thNames -> do names <- resolveTHNames thNames return - ( \n -> n `elem` names + ( forbidding forbidFused anns names , [] + , names , Nothing , "ForbidPatternMatches " ++ show thNames ) - ForbidFusedPatternMatches thForbid thAllow -> do - forbidden <- resolveTHNames thForbid - allowed <- resolveTHNames thAllow - return - ( \n -> isJust (lookupUFM anns n) || n `elem` forbidden - , allowed - , Nothing - , "ForbidFusedPatternMatches " - ++ show thForbid ++ " " ++ show thAllow - ) PermitPatternMatches thAllow -> do allowed <- resolveTHNames thAllow return ( const True , allowed + , allowed , Just ("PermitPatternMatches", thAllow) , "PermitPatternMatches " ++ show thAllow ) return NormInspect { niInteresting = interesting , niExclusion = excl + , niExplicit = explicit , niPosition = isPatternMatch , niPermit = permit , niForbidLabel = "forbidden pattern matches" , niBanner = banner - , niHeapFilter = False } --- | Normalize an 'InspectAllocations' directive. All of its constructors act +-- | Normalize an 'InspectConstructions' directive. All of its constructors act -- on the constructing (allocating) position. -normAllocations :: UNIQ_FM -> InspectAllocations -> CoreM NormInspect -normAllocations anns d = do - (interesting, excl, permit, banner) <- case d of - ForbidAllocations thNames -> do +normConstructions + :: Bool -> UNIQ_FM -> InspectConstructions -> CoreM NormInspect +normConstructions forbidFused anns d = do + (interesting, excl, explicit, permit, banner) <- case d of + ForbidConstructions thNames -> do names <- resolveTHNames thNames return - ( \n -> n `elem` names + ( forbidding forbidFused anns names , [] + , names , Nothing - , "ForbidAllocations " ++ show thNames + , "ForbidConstructions " ++ show thNames ) - ForbidFusedAllocations thForbid thAllow -> do - forbidden <- resolveTHNames thForbid - allowed <- resolveTHNames thAllow - return - ( \n -> isJust (lookupUFM anns n) || n `elem` forbidden - , allowed - , Nothing - , "ForbidFusedAllocations " - ++ show thForbid ++ " " ++ show thAllow - ) - PermitAllocations thAllow -> do + PermitConstructions thAllow -> do allowed <- resolveTHNames thAllow return ( const True , allowed - , Just ("PermitAllocations", thAllow) - , "PermitAllocations " ++ show thAllow + , allowed + , Just ("PermitConstructions", thAllow) + , "PermitConstructions " ++ show thAllow ) return NormInspect { niInteresting = interesting , niExclusion = excl + , niExplicit = explicit , niPosition = isConstruction , niPermit = permit - , niForbidLabel = "forbidden allocations" + , niForbidLabel = "forbidden constructions" , niBanner = banner - , niHeapFilter = True } -- | If the given top level bind's own binder carries an 'InspectPatternMatches' --- and/or an 'InspectAllocations' annotation, print a report of interesting +-- and/or an 'InspectConstructions' annotation, print a report of interesting -- types case-matched or constructed anywhere in its RHS, per the annotation's -- rules. A binding may carry one of each; both are processed. No-op if the -- binder is not annotated, or if the binding has no offending types. @@ -397,17 +390,20 @@ normAllocations anns d = do -- @SCRUTINIZE@/@CONSTRUCT@ breakdown is printed. -- Returns the number of directives (0, 1 or 2) that reported a violation. reportInspected - :: DynFlags -> ReportMode -> UNIQ_FM -> INSPECT_PM_FM -> INSPECT_ALLOC_FM + :: DynFlags -> ReportMode -> Bool -> Bool -> UNIQ_FM + -> INSPECT_PM_FM -> INSPECT_CONSTR_FM -> [(CoreBndr, CoreExpr)] -> CoreBind -> CoreM Int -reportInspected dflags reportMode anns pmAnns allocAnns allBinds (NonRec b _) +reportInspected + dflags reportMode forbidFused inspectUnboxed anns pmAnns constrAnns + allBinds (NonRec b _) | subsumedBySameName allBinds b = return 0 | otherwise = do n1 <- maybe (return 0) - (\d -> normPatternMatches anns d >>= go) + (\d -> normPatternMatches forbidFused anns d >>= go) (lookupBinderAnn b pmAnns) n2 <- maybe (return 0) - (\d -> normAllocations anns d >>= go) - (lookupBinderAnn b allocAnns) + (\d -> normConstructions forbidFused anns d >>= go) + (lookupBinderAnn b constrAnns) return (n1 + n2) where @@ -415,12 +411,14 @@ reportInspected dflags reportMode anns pmAnns allocAnns allBinds (NonRec b _) go ni = do let isInteresting = niInteresting ni exclusion = niExclusion ni + explicit = niExplicit ni inPosition = niPosition ni - heapFilter = if niHeapFilter ni - then keepHeapAllocatedOnly - else id + keep (_, ctx) = + inspectUnboxed + || isBoxedHit ctx + || maybe False (`elem` explicit) (contextTyConName ctx) let allHits = filter (inPosition . snd) - $ heapFilter + $ filter keep $ concatMap (\(v, e) -> containsAnns dflags isInteresting (NonRec v e)) @@ -445,7 +443,8 @@ reportInspected dflags reportMode anns pmAnns allocAnns allBinds (NonRec b _) Nothing -> return () Just (label, thAllow) -> do allowed <- resolveTHNames thAllow - let present = mapMaybe (contextTyConName . snd) allHits + let hits = if inspectUnboxed then allHits else keepBoxedOnly allHits + present = mapMaybe (contextTyConName . snd) hits stale = filter (`notElem` present) allowed unless (null stale) $ putMsgS $ "fusion-plugin: " @@ -486,7 +485,7 @@ reportInspected dflags reportMode anns pmAnns allocAnns allBinds (NonRec b _) uniqBinders patternMatches showDetailsScrutinize showInfo b dflags reportMode "CONSTRUCT" uniqConstr constrs showDetailsConstr -reportInspected _ _ _ _ _ _ (Rec _) = +reportInspected _ _ _ _ _ _ _ _ (Rec _) = error "reportInspected: expecting only NonRec binders" ------------------------------------------------------------------------------- @@ -719,7 +718,7 @@ liveTopLevelBinders guts = go initial initial data InspectAnns = InspectAnns { iaPatternMatches :: INSPECT_PM_FM - , iaAllocations :: INSPECT_ALLOC_FM + , iaConstructions :: INSPECT_CONSTR_FM , iaClasses :: INSPECT_CLASSES_FM , iaSizes :: MAX_CORE_SIZE_FM , iaDumps :: DUMP_CORE_FM @@ -737,7 +736,7 @@ failOnUnmatchedAnns dflags pkgName modName allTopBinds allBinds anns = do unmatched = filter (`notElem` candidateKeys) $ DL.nub ( Map.keys (iaPatternMatches anns) - ++ Map.keys (iaAllocations anns) ++ Map.keys (iaClasses anns) + ++ Map.keys (iaConstructions anns) ++ Map.keys (iaClasses anns) ++ Map.keys (iaSizes anns) ++ Map.keys (iaDumps anns) ) mapM_ (\k -> @@ -760,7 +759,7 @@ failOnUnmatchedAnns dflags pkgName modName allTopBinds allBinds anns = do -- | @runInspect@ controls whether the per-binding inspection 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 ('InspectPatternMatches', 'InspectAllocations', +-- annotation-check violation ('InspectPatternMatches', 'InspectConstructions', -- 'InspectTypeClasses' or 'MaxCoreSize') was found. fusionReport :: String -> ReportMode -> Bool -> Options @@ -771,19 +770,19 @@ fusionReport mesg reportMode runInspect opts guts = do then getAnnotationsByStableName name deserializeWithData guts else return Map.empty pmAnns <- getAnns "InspectPatternMatches" - allocAnns <- getAnns "InspectAllocations" + constrAnns <- getAnns "InspectConstructions" sizeAnns <- getAnns "MaxCoreSize" dumpAnns <- getAnns "DumpCore" classAnns <- getAnns "InspectTypeClasses" let inspectAnns = InspectAnns { iaPatternMatches = pmAnns - , iaAllocations = allocAnns + , iaConstructions = constrAnns , iaClasses = classAnns , iaSizes = sizeAnns , iaDumps = dumpAnns } let anyInspect = - runInspect && (not (Map.null pmAnns) || not (Map.null allocAnns)) + runInspect && (not (Map.null pmAnns) || not (Map.null constrAnns)) anyInspectClasses = runInspect && not (Map.null classAnns) anyMaxCoreSize = runInspect && not (Map.null sizeAnns) anyDumpCore = runInspect && not (Map.null dumpAnns) @@ -839,13 +838,15 @@ fusionReport mesg reportMode runInspect opts guts = do transformBind dflags anns iAnns pkgName modName liveBndrs allBinds bind@(NonRec b _) = do let pmAnns = iaPatternMatches iAnns - allocAnns = iaAllocations iAnns + constrAnns = iaConstructions iAnns classAnns = iaClasses iAnns sizeAnns = iaSizes iAnns dumpAnns = iaDumps iAnns n1 <- if runInspect then reportInspected - dflags reportMode anns pmAnns allocAnns allBinds bind + dflags reportMode (optionsForbidFused opts) + (optionsInspectUnboxed opts) + anns pmAnns constrAnns allBinds bind else return 0 n2 <- if runInspect then reportInspectedClasses @@ -856,7 +857,7 @@ fusionReport mesg reportMode runInspect opts guts = do else return 0 let hasViolationAnn = isJust (lookupBinderAnn b pmAnns) - || isJust (lookupBinderAnn b allocAnns) + || isJust (lookupBinderAnn b constrAnns) || isJust (lookupBinderAnn b classAnns) || isJust (lookupBinderAnn b sizeAnns) hasDumpAnn = isJust (lookupBinderAnn b dumpAnns) @@ -872,7 +873,7 @@ fusionReport mesg reportMode runInspect opts guts = do when (shouldDump && notSubsumed) $ dumpBindCore dflags pkgName modName allBinds b when (b `elemVarSet` liveBndrs) $ do - let results = keepHeapAllocatedOnly + let results = keepBoxedOnly $ containsAnns dflags (isJust . lookupUFM anns) bind let getAlts x = diff --git a/stack.yaml b/stack.yaml index ca3bd54..2b58171 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,4 +3,4 @@ packages: - '.' extra-deps: - git: https://github.com/composewell/fusion-plugin-types.git - commit: 1f21d07917b62e1b9a5327f930bd31168441d505 + commit: a74c4a229303b3df25d06853d80408c55b3e45e7