From 0aa1bde6898db09ca4abd80e9b049f3fd2c1404f Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sun, 19 Jul 2026 13:59:24 +0530 Subject: [PATCH 1/7] Exempt unboxed types in pattern matches as well --- src/Fusion/Plugin/Inspect.hs | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/src/Fusion/Plugin/Inspect.hs b/src/Fusion/Plugin/Inspect.hs index e41aa25..fbca998 100644 --- a/src/Fusion/Plugin/Inspect.hs +++ b/src/Fusion/Plugin/Inspect.hs @@ -299,8 +299,6 @@ 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 @@ -341,7 +339,6 @@ normPatternMatches anns d = do , niPermit = permit , niForbidLabel = "forbidden pattern matches" , niBanner = banner - , niHeapFilter = False } -- | Normalize an 'InspectAllocations' directive. All of its constructors act @@ -382,7 +379,6 @@ normAllocations anns d = do , niPermit = permit , niForbidLabel = "forbidden allocations" , niBanner = banner - , niHeapFilter = True } -- | If the given top level bind's own binder carries an 'InspectPatternMatches' @@ -416,11 +412,8 @@ reportInspected dflags reportMode anns pmAnns allocAnns allBinds (NonRec b _) let isInteresting = niInteresting ni exclusion = niExclusion ni inPosition = niPosition ni - heapFilter = if niHeapFilter ni - then keepHeapAllocatedOnly - else id let allHits = filter (inPosition . snd) - $ heapFilter + $ keepHeapAllocatedOnly $ concatMap (\(v, e) -> containsAnns dflags isInteresting (NonRec v e)) From 92a9ec5caa84f763dcf2ddc1d0ae62cee9c4f416 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sun, 19 Jul 2026 15:11:08 +0530 Subject: [PATCH 2/7] Remove Forbid/PermitFused anns, add forbid-fused option --- README.md | 33 +++++++---------------- src/Fusion/Plugin.hs | 17 ++++++++++++ src/Fusion/Plugin/Common.hs | 1 + src/Fusion/Plugin/Inspect.hs | 52 ++++++++++++++---------------------- 4 files changed, 48 insertions(+), 55 deletions(-) diff --git a/README.md b/README.md index b55e500..2a67989 100644 --- a/README.md +++ b/README.md @@ -141,31 +141,10 @@ each has an analogous `...PatternMatches` counterpart. import Fusion.Plugin.Types (InspectAllocations(..), InspectPatternMatches(..)) ``` -### Using `Fuse` Annotated as Baseline - -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 :: ... -``` - ### 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 allocations and pattern matches, attach one annotation of each type to the binding. ```haskell {-# ANN function (ForbidAllocations [''Step]) #-} @@ -173,6 +152,14 @@ annotation of each type to the binding. function2 :: ... ``` +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 +`ForbidAllocations []` forbids exactly the `Fuse` annotated types. +``` +ghc-options: -fplugin-opt=Fusion.Plugin:forbid-fused +``` + Report the listed types only where they are allocated: ```haskell {-# ANN function (ForbidAllocations [''Step]) #-} diff --git a/src/Fusion/Plugin.hs b/src/Fusion/Plugin.hs index ea2b2ed..9b79a8b 100644 --- a/src/Fusion/Plugin.hs +++ b/src/Fusion/Plugin.hs @@ -141,6 +141,16 @@ 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.ForbidAllocations') additionally forbid all +-- 'Fusion.Plugin.Types.Fuse' annotated types, using them as a baseline. The +-- types named in the annotation are then forbidden on top of the fused types: +-- +-- @ +-- ghc-options: -fplugin-opt=Fusion.Plugin:forbid-fused +-- @ +-- -- To dump the core after each core to core transformation, pass the -- following to your ghc-options: -- @@ -230,6 +240,7 @@ defaultOptions = Options , optionsVerbosityLevel = ReportSilent , optionsWError = False , optionsCsvAppend = False + , optionsForbidFused = False } setDumpCore :: Monad m => Bool -> StateT ([CommandLineOption], Options) m () @@ -264,6 +275,11 @@ 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 }) + setVerbosityLevel :: Monad m => ReportMode -> StateT ([CommandLineOption], Options) m () setVerbosityLevel val = do @@ -295,6 +311,7 @@ parseOptions args = "dump-core-if-violated" -> setDumpCoreIfViolated True "werror" -> setWError True "csv-append" -> setCsvAppend True + "forbid-fused" -> setForbidFused 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..7436e12 100644 --- a/src/Fusion/Plugin/Common.hs +++ b/src/Fusion/Plugin/Common.hs @@ -182,6 +182,7 @@ data Options = Options , optionsVerbosityLevel :: ReportMode , optionsWError :: Bool , optionsCsvAppend :: Bool + , optionsForbidFused :: 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 fbca998..8a26840 100644 --- a/src/Fusion/Plugin/Inspect.hs +++ b/src/Fusion/Plugin/Inspect.hs @@ -251,6 +251,10 @@ keepHeapAllocatedOnly :: [([CoreBind], Context)] -> [([CoreBind], Context)] keepHeapAllocatedOnly = filter (isHeapAllocated . 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 -- 'Right' is a constructor-less scrutiny (a default-only\/literal @case@) whose @@ -303,27 +307,18 @@ data NormInspect = NormInspect -- | 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 +normPatternMatches + :: Bool -> UNIQ_FM -> InspectPatternMatches -> CoreM NormInspect +normPatternMatches forbidFused anns d = do (interesting, excl, permit, banner) <- case d of ForbidPatternMatches thNames -> do names <- resolveTHNames thNames return - ( \n -> n `elem` names + ( forbidding forbidFused anns 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 @@ -343,27 +338,17 @@ normPatternMatches anns d = do -- | Normalize an 'InspectAllocations' directive. All of its constructors act -- on the constructing (allocating) position. -normAllocations :: UNIQ_FM -> InspectAllocations -> CoreM NormInspect -normAllocations anns d = do +normAllocations :: Bool -> UNIQ_FM -> InspectAllocations -> CoreM NormInspect +normAllocations forbidFused anns d = do (interesting, excl, permit, banner) <- case d of ForbidAllocations thNames -> do names <- resolveTHNames thNames return - ( \n -> n `elem` names + ( forbidding forbidFused anns names , [] , Nothing , "ForbidAllocations " ++ 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 allowed <- resolveTHNames thAllow return @@ -393,16 +378,18 @@ 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 -> UNIQ_FM + -> INSPECT_PM_FM -> INSPECT_ALLOC_FM -> [(CoreBndr, CoreExpr)] -> CoreBind -> CoreM Int -reportInspected dflags reportMode anns pmAnns allocAnns allBinds (NonRec b _) +reportInspected + dflags reportMode forbidFused anns pmAnns allocAnns 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) + (\d -> normAllocations forbidFused anns d >>= go) (lookupBinderAnn b allocAnns) return (n1 + n2) @@ -479,7 +466,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" ------------------------------------------------------------------------------- @@ -838,7 +825,8 @@ fusionReport mesg reportMode runInspect opts guts = do dumpAnns = iaDumps iAnns n1 <- if runInspect then reportInspected - dflags reportMode anns pmAnns allocAnns allBinds bind + dflags reportMode (optionsForbidFused opts) + anns pmAnns allocAnns allBinds bind else return 0 n2 <- if runInspect then reportInspectedClasses From ffcc8fa8072dd8cbc0e2cd832c4066276355038c Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sun, 19 Jul 2026 15:27:38 +0530 Subject: [PATCH 3/7] Replace "Allocations" in anns to "Constructions" --- README.md | 32 ++++++++++----------- cabal.project | 2 +- src/Fusion/Plugin.hs | 9 +++--- src/Fusion/Plugin/Inspect.hs | 54 +++++++++++++++++++----------------- 4 files changed, 50 insertions(+), 47 deletions(-) diff --git a/README.md b/README.md index 2a67989..f699ad0 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,22 +132,22 @@ 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(..)) ``` ### Forbidding Only Selected Types Disallow only the specified types and allow the rest, irrespective of the -`Fuse` annotation. To check both allocations and pattern matches, attach one +`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 :: ... ``` @@ -155,14 +155,14 @@ function2 :: ... 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 -`ForbidAllocations []` forbids exactly the `Fuse` annotated types. +`ForbidConstructions []` forbids exactly the `Fuse` annotated types. ``` ghc-options: -fplugin-opt=Fusion.Plugin:forbid-fused ``` -Report the listed types only where they are allocated: +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: @@ -173,23 +173,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: @@ -289,7 +289,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 @@ -328,7 +328,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..046025f 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: 5a7d049b69437dc8d505931820cbdd8ab56193fa diff --git a/src/Fusion/Plugin.hs b/src/Fusion/Plugin.hs index 9b79a8b..ae4792f 100644 --- a/src/Fusion/Plugin.hs +++ b/src/Fusion/Plugin.hs @@ -143,7 +143,7 @@ import Fusion.Plugin.Inspect -- -- GHC option to make every @Forbid...@ annotation -- ('Fusion.Plugin.Types.ForbidPatternMatches', --- 'Fusion.Plugin.Types.ForbidAllocations') additionally forbid all +-- 'Fusion.Plugin.Types.ForbidConstructions') additionally forbid all -- 'Fusion.Plugin.Types.Fuse' annotated types, using them as a baseline. The -- types named in the annotation are then forbidden on top of the fused types: -- @@ -162,8 +162,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 @@ -185,7 +186,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: -- -- @ diff --git a/src/Fusion/Plugin/Inspect.hs b/src/Fusion/Plugin/Inspect.hs index 8a26840..59fe572 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 @@ -280,11 +280,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. @@ -336,38 +336,39 @@ normPatternMatches forbidFused anns d = do , niBanner = banner } --- | Normalize an 'InspectAllocations' directive. All of its constructors act +-- | Normalize an 'InspectConstructions' directive. All of its constructors act -- on the constructing (allocating) position. -normAllocations :: Bool -> UNIQ_FM -> InspectAllocations -> CoreM NormInspect -normAllocations forbidFused anns d = do +normConstructions + :: Bool -> UNIQ_FM -> InspectConstructions -> CoreM NormInspect +normConstructions forbidFused anns d = do (interesting, excl, permit, banner) <- case d of - ForbidAllocations thNames -> do + ForbidConstructions thNames -> do names <- resolveTHNames thNames return ( forbidding forbidFused anns names , [] , Nothing - , "ForbidAllocations " ++ show thNames + , "ForbidConstructions " ++ show thNames ) - PermitAllocations thAllow -> do + PermitConstructions thAllow -> do allowed <- resolveTHNames thAllow return ( const True , allowed - , Just ("PermitAllocations", thAllow) - , "PermitAllocations " ++ show thAllow + , Just ("PermitConstructions", thAllow) + , "PermitConstructions " ++ show thAllow ) return NormInspect { niInteresting = interesting , niExclusion = excl , niPosition = isConstruction , niPermit = permit - , niForbidLabel = "forbidden allocations" + , niForbidLabel = "forbidden constructions" , niBanner = banner } -- | 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. @@ -379,18 +380,19 @@ normAllocations forbidFused anns d = do -- Returns the number of directives (0, 1 or 2) that reported a violation. reportInspected :: DynFlags -> ReportMode -> Bool -> UNIQ_FM - -> INSPECT_PM_FM -> INSPECT_ALLOC_FM + -> INSPECT_PM_FM -> INSPECT_CONSTR_FM -> [(CoreBndr, CoreExpr)] -> CoreBind -> CoreM Int reportInspected - dflags reportMode forbidFused anns pmAnns allocAnns allBinds (NonRec b _) + dflags reportMode forbidFused anns pmAnns constrAnns allBinds + (NonRec b _) | subsumedBySameName allBinds b = return 0 | otherwise = do n1 <- maybe (return 0) (\d -> normPatternMatches forbidFused anns d >>= go) (lookupBinderAnn b pmAnns) n2 <- maybe (return 0) - (\d -> normAllocations forbidFused anns d >>= go) - (lookupBinderAnn b allocAnns) + (\d -> normConstructions forbidFused anns d >>= go) + (lookupBinderAnn b constrAnns) return (n1 + n2) where @@ -699,7 +701,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 @@ -717,7 +719,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 -> @@ -740,7 +742,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 @@ -751,19 +753,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) @@ -819,14 +821,14 @@ 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 (optionsForbidFused opts) - anns pmAnns allocAnns allBinds bind + anns pmAnns constrAnns allBinds bind else return 0 n2 <- if runInspect then reportInspectedClasses @@ -837,7 +839,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) From 88a4de34c25beb9130a034eac5c2e1d7664ca01b Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sun, 19 Jul 2026 15:52:48 +0530 Subject: [PATCH 4/7] Add inspect-unboxed option to include unboxed types --- README.md | 15 +++++++++++++++ src/Fusion/Plugin.hs | 18 ++++++++++++++++++ src/Fusion/Plugin/Common.hs | 1 + src/Fusion/Plugin/Inspect.hs | 12 +++++++----- 4 files changed, 41 insertions(+), 5 deletions(-) diff --git a/README.md b/README.md index f699ad0..9e6d924 100644 --- a/README.md +++ b/README.md @@ -201,6 +201,21 @@ 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 the inspection annotations ignore unboxed and other +non-heap-allocated types (e.g. `Int#`, unboxed tuples, enumeration types like +`Bool`), since these never represent a boxing failure. Pass the +`inspect-unboxed` plugin option to include them in the inspection instead: + +``` +ghc-options: -fplugin-opt=Fusion.Plugin:inspect-unboxed +``` + +With this option a `Forbid...` annotation reports unboxed occurrences too, and +an unboxed type must be listed explicitly in a `Permit...` annotation to be +allowed, exactly like a boxed type. + ### Inspecting type class dictionaries To check the presence or absence of type classes in the Core of a binding, diff --git a/src/Fusion/Plugin.hs b/src/Fusion/Plugin.hs index ae4792f..de7a840 100644 --- a/src/Fusion/Plugin.hs +++ b/src/Fusion/Plugin.hs @@ -151,6 +151,16 @@ import Fusion.Plugin.Inspect -- ghc-options: -fplugin-opt=Fusion.Plugin:forbid-fused -- @ -- +-- By default the inspection annotations ignore unboxed and other +-- non-heap-allocated types (e.g. @Int#@, unboxed tuples, enumerations), since +-- these never represent a boxing failure. GHC option to instead include them +-- in the inspection: with this on, an unboxed type must be listed explicitly +-- in a @Permit...@ annotation to be allowed, exactly like a boxed type: +-- +-- @ +-- 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: -- @@ -242,6 +252,7 @@ defaultOptions = Options , optionsWError = False , optionsCsvAppend = False , optionsForbidFused = False + , optionsInspectUnboxed = False } setDumpCore :: Monad m => Bool -> StateT ([CommandLineOption], Options) m () @@ -281,6 +292,12 @@ 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 @@ -313,6 +330,7 @@ parseOptions args = "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 7436e12..95a86a4 100644 --- a/src/Fusion/Plugin/Common.hs +++ b/src/Fusion/Plugin/Common.hs @@ -183,6 +183,7 @@ data Options = Options , 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 59fe572..b14fb6e 100644 --- a/src/Fusion/Plugin/Inspect.hs +++ b/src/Fusion/Plugin/Inspect.hs @@ -379,12 +379,12 @@ normConstructions forbidFused anns d = do -- @SCRUTINIZE@/@CONSTRUCT@ breakdown is printed. -- Returns the number of directives (0, 1 or 2) that reported a violation. reportInspected - :: DynFlags -> ReportMode -> Bool -> UNIQ_FM + :: DynFlags -> ReportMode -> Bool -> Bool -> UNIQ_FM -> INSPECT_PM_FM -> INSPECT_CONSTR_FM -> [(CoreBndr, CoreExpr)] -> CoreBind -> CoreM Int reportInspected - dflags reportMode forbidFused anns pmAnns constrAnns allBinds - (NonRec b _) + dflags reportMode forbidFused inspectUnboxed anns pmAnns constrAnns + allBinds (NonRec b _) | subsumedBySameName allBinds b = return 0 | otherwise = do n1 <- maybe (return 0) @@ -401,8 +401,9 @@ reportInspected let isInteresting = niInteresting ni exclusion = niExclusion ni inPosition = niPosition ni + let heapFilter = if inspectUnboxed then id else keepHeapAllocatedOnly let allHits = filter (inPosition . snd) - $ keepHeapAllocatedOnly + $ heapFilter $ concatMap (\(v, e) -> containsAnns dflags isInteresting (NonRec v e)) @@ -468,7 +469,7 @@ reportInspected uniqBinders patternMatches showDetailsScrutinize showInfo b dflags reportMode "CONSTRUCT" uniqConstr constrs showDetailsConstr -reportInspected _ _ _ _ _ _ _ (Rec _) = +reportInspected _ _ _ _ _ _ _ _ (Rec _) = error "reportInspected: expecting only NonRec binders" ------------------------------------------------------------------------------- @@ -828,6 +829,7 @@ fusionReport mesg reportMode runInspect opts guts = do n1 <- if runInspect then reportInspected dflags reportMode (optionsForbidFused opts) + (optionsInspectUnboxed opts) anns pmAnns constrAnns allBinds bind else return 0 n2 <- if runInspect From a55a9b4a14df0f80511cd41ca7fd2e0d9c7109ca Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sun, 19 Jul 2026 19:40:26 +0530 Subject: [PATCH 5/7] Forbid/permit all listed, implicitly permit unboxed only --- README.md | 26 +++++++++---- src/Fusion/Plugin.hs | 15 ++++---- src/Fusion/Plugin/Inspect.hs | 73 ++++++++++++++++++++++-------------- 3 files changed, 69 insertions(+), 45 deletions(-) diff --git a/README.md b/README.md index 9e6d924..55587fd 100644 --- a/README.md +++ b/README.md @@ -141,6 +141,18 @@ each has an analogous `...PatternMatches` counterpart. import Fusion.Plugin.Types (InspectConstructions(..), InspectPatternMatches(..)) ``` +The whole system reduces to four simple rules: + +* 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 only the specified types and allow the rest, irrespective of the @@ -203,19 +215,17 @@ the list. ### Including Unboxed Types in the Inspection -By default the inspection annotations ignore unboxed and other -non-heap-allocated types (e.g. `Int#`, unboxed tuples, enumeration types like -`Bool`), since these never represent a boxing failure. Pass the -`inspect-unboxed` plugin option to include them in the inspection instead: +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 ``` -With this option a `Forbid...` annotation reports unboxed occurrences too, and -an unboxed type must be listed explicitly in a `Permit...` annotation to be -allowed, exactly like a boxed type. - ### Inspecting type class dictionaries To check the presence or absence of type classes in the Core of a binding, diff --git a/src/Fusion/Plugin.hs b/src/Fusion/Plugin.hs index de7a840..6f6e06d 100644 --- a/src/Fusion/Plugin.hs +++ b/src/Fusion/Plugin.hs @@ -143,19 +143,18 @@ import Fusion.Plugin.Inspect -- -- GHC option to make every @Forbid...@ annotation -- ('Fusion.Plugin.Types.ForbidPatternMatches', --- 'Fusion.Plugin.Types.ForbidConstructions') additionally forbid all --- 'Fusion.Plugin.Types.Fuse' annotated types, using them as a baseline. The --- types named in the annotation are then forbidden on top of the fused types: +-- '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 the inspection annotations ignore unboxed and other --- non-heap-allocated types (e.g. @Int#@, unboxed tuples, enumerations), since --- these never represent a boxing failure. GHC option to instead include them --- in the inspection: with this on, an unboxed type must be listed explicitly --- in a @Permit...@ annotation to be allowed, exactly like a boxed type: +-- 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 diff --git a/src/Fusion/Plugin/Inspect.hs b/src/Fusion/Plugin/Inspect.hs index b14fb6e..c924079 100644 --- a/src/Fusion/Plugin/Inspect.hs +++ b/src/Fusion/Plugin/Inspect.hs @@ -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,16 @@ 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 = @@ -294,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]) @@ -310,12 +315,13 @@ data NormInspect = NormInspect normPatternMatches :: Bool -> UNIQ_FM -> InspectPatternMatches -> CoreM NormInspect normPatternMatches forbidFused anns d = do - (interesting, excl, permit, banner) <- case d of + (interesting, excl, explicit, permit, banner) <- case d of ForbidPatternMatches thNames -> do names <- resolveTHNames thNames return ( forbidding forbidFused anns names , [] + , names , Nothing , "ForbidPatternMatches " ++ show thNames ) @@ -324,12 +330,14 @@ normPatternMatches forbidFused anns d = do 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" @@ -341,12 +349,13 @@ normPatternMatches forbidFused anns d = do normConstructions :: Bool -> UNIQ_FM -> InspectConstructions -> CoreM NormInspect normConstructions forbidFused anns d = do - (interesting, excl, permit, banner) <- case d of + (interesting, excl, explicit, permit, banner) <- case d of ForbidConstructions thNames -> do names <- resolveTHNames thNames return ( forbidding forbidFused anns names , [] + , names , Nothing , "ForbidConstructions " ++ show thNames ) @@ -355,12 +364,14 @@ normConstructions forbidFused anns d = do return ( const True , allowed + , allowed , Just ("PermitConstructions", thAllow) , "PermitConstructions " ++ show thAllow ) return NormInspect { niInteresting = interesting , niExclusion = excl + , niExplicit = explicit , niPosition = isConstruction , niPermit = permit , niForbidLabel = "forbidden constructions" @@ -400,10 +411,14 @@ reportInspected go ni = do let isInteresting = niInteresting ni exclusion = niExclusion ni + explicit = niExplicit ni inPosition = niPosition ni - let heapFilter = if inspectUnboxed then id else keepHeapAllocatedOnly + 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)) @@ -857,7 +872,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 = From e706a470dd9939f623b3043d2b663325d9836a4f Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sun, 19 Jul 2026 15:39:31 +0530 Subject: [PATCH 6/7] Update fusion-plugin-types commit tag --- cabal.project | 2 +- stack.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 046025f..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: 5a7d049b69437dc8d505931820cbdd8ab56193fa + tag: a74c4a229303b3df25d06853d80408c55b3e45e7 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 From 2ec7138a2e2ce3e6cea6e7641fcdf42aa34c8c6c Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sun, 19 Jul 2026 21:20:47 +0530 Subject: [PATCH 7/7] Fix stale entries message for unboxed types --- src/Fusion/Plugin/Inspect.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Fusion/Plugin/Inspect.hs b/src/Fusion/Plugin/Inspect.hs index c924079..91e1151 100644 --- a/src/Fusion/Plugin/Inspect.hs +++ b/src/Fusion/Plugin/Inspect.hs @@ -443,7 +443,8 @@ reportInspected 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: "