From 831ebff167cceb1c8c22ef50da2fc6f38714a8ee Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 22 Jul 2026 03:10:17 +0530 Subject: [PATCH 1/4] Note the differences between inspection and fusion --- src/Fusion/Plugin/Fuse.hs | 96 +++++++++++++++++++++++++++++++++------ 1 file changed, 83 insertions(+), 13 deletions(-) diff --git a/src/Fusion/Plugin/Fuse.hs b/src/Fusion/Plugin/Fuse.hs index 967c658..3e86ff7 100644 --- a/src/Fusion/Plugin/Fuse.hs +++ b/src/Fusion/Plugin/Fuse.hs @@ -176,7 +176,7 @@ needInlineCaseAlt dflags parents anns bndr = -- XXX Can check the call site and return only those that would enable -- case-of-known constructor to kick in. Or is that not relevant? --- + -- | Discover binders that start with a pattern match on constructors that are -- annotated with Fuse. For example, for the following code: -- @@ -198,6 +198,37 @@ needInlineCaseAlt dflags parents anns bndr = -- inline. The caller ('transformBind') is responsible for deduplicating the -- 'Left' paths by binder before warning, since the same @NOINLINE@'d binder -- can contain more than one matching case. +-- +-- NOTE [Force-inlining vs inspection divergences] +-- +-- This traversal (and 'constructingBinders' below) drives /force-inlining/: +-- it finds local binders to mark INLINE so that fusion fires. The inspection +-- traversal 'containsAnns' (in Fusion.Plugin.Inspect) walks the same Core to +-- /report/ residual matches and constructions. The two deliberately differ; +-- every difference below is a place where force-inlining skips (or narrows) +-- something that inspection checks. +-- +-- 1. Case scrutinee. We never descend into a case scrutinee (the '_' in the +-- 'Case' patterns below), only into its alternatives. Force-inlining acts +-- only on matches reachable on entry to a local binder, and in any case +-- cannot force-inline something defined in another module. Inspection DOES +-- descend into the scrutinee: a match buried there -- e.g. the stream +-- stepper lambda passed to an un-inlined imported combinator like +-- 'foldBreak', which ends up in the scrutinee of the outer +-- result-unpacking @case (# _, _ #)@ -- is still reported so the user can +-- add an INLINE pragma in that other module. +-- +-- 2. Entry position only. We record a case-alt match only in "entry" +-- position -- the 'True' flag argument to 'go' -- i.e. when the binder's +-- body begins (modulo lambdas) with the case. Descending through +-- App/Let/Cast or into a nested case resets the flag to 'False'. +-- Inspection has no such flag; it reports matches anywhere in the binder. +-- +-- 3. Default-only / literal cases. 'needInlineCaseAlt' -> 'altsContainsAnn' +-- recognizes an interesting type only through a matched data constructor, +-- so a default-only case such as @case s of _ -> ...@ (e.g. @s :: SPEC@) +-- is never a force-inline target. Inspection falls back to the case +-- binder's type (its 'scrutHit') and reports these too. letBndrsThatAreCases :: DynFlags -> UNIQ_FM @@ -219,7 +250,9 @@ letBndrsThatAreCases dflags anns bind = goLet [] bind -- Match and record the case alternative if it contains a constructor -- annotated with "Fuse" and traverse the Alt expressions to discover more - -- let bindings. + -- let bindings. The scrutinee ('_') is intentionally not traversed -- + -- inspection does traverse it; see NOTE [Force-inlining vs inspection + -- divergences] item 1. go parents True (Case _ _ _ alts) = let result = alts >>= (\(ALT_CONSTR(_,_,expr1)) -> go parents False expr1) in case needInlineCaseAlt dflags parents anns alts of @@ -270,17 +303,45 @@ needInlineTyCon parent anns tycon = Just _ | not (hasInlineBinder parentBndr) -> InlineNeeded () _ -> InlineNotNeeded --- XXX Currently this function and containsAnns are equivalent. So containsAnns --- can be used in place of this. But we may want to restrict this to certain --- cases and keep containsAnns unrestricted so it is kept separate for now. --- --- | Discover binders whose return type is a fusible constructor and the --- constructor is directly used in the binder definition rather than through an --- identifier. +-- | Discover binders that either construct a fusible type or hold a reference +-- to a fusible-typed value (a consumer, e.g. a join point) -- both are force- +-- inline targets so that case-of-case can eliminate the value. See item 5 of +-- the NOTE below for why references are included. -- -- See 'letBndrsThatAreCases' for the meaning of the 'Either' result: 'Left' -- is a binder blocked from force-inlining by a user @NOINLINE@ pragma, -- 'Right' is an actual hit to force inline. +-- +-- This is the construction-side counterpart of 'containsAnns' in +-- Fusion.Plugin.Inspect, but it is NOT equivalent to it. Beyond the shared +-- scrutinee skip (item 1 of NOTE [Force-inlining vs inspection divergences]), +-- the construction detection itself differs: +-- +-- 4. Applied constructors. The App-spine data-constructor check below is +-- commented out (force-inlining an applied constructor such as @Yield x y@ +-- can bloat code without a proven benefit), so here only bare 'Var' nodes +-- are considered. Inspection's 'dataConHit' DOES fire on the head of an +-- App spine, so it reports applied constructors. +-- +-- 5. Bare 'Var' predicate. We deliberately treat a 'Var' as a fusion trigger +-- whenever its type is headed by a fusible 'TyCon' ('tyConAppTyConPicky_maybe' +-- on its 'varType'), which fires not only for a nullary constructor but also +-- for an ordinary reference to a value of that type. This is intentional and +-- load-bearing: force-inlining must reach binders that merely /consume/ a +-- fusible constructor -- e.g. a join point holding such a value -- because +-- inlining the consumer is what lets case-of-case eliminate it. This was +-- added in commit c9871cb ("Inline joins that consume fusible constructors") +-- for the WordCount example from the streamly-examples repository; the +-- committed Core that motivates it is in @design/join-constr-app.hs@ (see +-- @design/README.md@ item 1), where the join point @$j_sm2u@ must be +-- inlined so case-of-case can eliminate @SeqParseL@/@SeqParseR@. Do NOT +-- tighten this to actual constructors. +-- Inspection instead restricts its 'dataConHit' to real data-constructor +-- 'Id's ('isDataConId_maybe'): its job is to report /allocations/, and a +-- plain reference allocates nothing (a bare 'Var' at a boxed type points at +-- a box built elsewhere) -- reporting it was a false positive, fixed in +-- commit 3ed86ee ("Fix a false positive allocation reporting"). So the two +-- sides diverge on purpose, for opposite and individually-correct reasons. constructingBinders :: UNIQ_FM -> CoreBind -> [Either ([CoreBind], TyCon) ([CoreBind], Id)] constructingBinders anns bind = goLet [] bind @@ -295,17 +356,23 @@ constructingBinders anns bind = goLet [] bind -- let expression as well. go parents (Let bndr expr1) = goLet parents bndr ++ go parents expr1 - -- Traverse these to discover new let bindings + -- Traverse the alternatives to discover new let bindings. The scrutinee + -- ('_') is intentionally not traversed -- inspection does traverse it; see + -- NOTE [Force-inlining vs inspection divergences] item 1. go parents (Case _ _ _ alts) = alts >>= (\(ALT_CONSTR(_,_,expr1)) -> go parents expr1) -- If the head of the application spine is a data constructor, record a hit -- for its type -- this recognizes a constructor applied to its fields -- (e.g. `Yield x y`), which checking a bare 'Var' node's own type cannot: -- the unapplied constructor 'Id' has a function type, not the constructed - -- type, so that check only fires for nullary constructors. + -- type, so the 'Var' check misses applied constructors. (The 'Var' check + -- still fires for nullary constructors and, by design, for any reference to + -- a fusible-typed value -- see item 5 above.) -- -- XXX Inlining these cases can bloat the code, need to prove the benefit - -- before enabling this. + -- before enabling this. While disabled, applied constructors are not + -- force-inline targets, whereas inspection reports them; see NOTE + -- [Force-inlining vs inspection divergences] item 4. {- go parents e@(App _ _) = let (fun, args) = collectArgs e @@ -325,7 +392,10 @@ constructingBinders anns bind = goLet [] bind go parents (Lam _ expr1) = go parents expr1 go parents (Cast expr1 _) = go parents expr1 - -- Check if the Var is a data constructor of interest + -- Fire when the Var's type is headed by a fusible constructor -- covering + -- both nullary constructors and (deliberately) references to fusible-typed + -- values, so consumers get inlined too. Broader than inspection on purpose; + -- see NOTE [Force-inlining vs inspection divergences] item 5. go parents (Var i) = let needInline = needInlineTyCon (head parents) anns in case tyConAppTyConPicky_maybe (varType i) of From 57dcb3236f27574f514bc5b5dfeed75640864ced Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 22 Jul 2026 03:12:11 +0530 Subject: [PATCH 2/4] Inspect the expression in the case scrutinee as well --- src/Fusion/Plugin/Inspect.hs | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/src/Fusion/Plugin/Inspect.hs b/src/Fusion/Plugin/Inspect.hs index aca0820..0544714 100644 --- a/src/Fusion/Plugin/Inspect.hs +++ b/src/Fusion/Plugin/Inspect.hs @@ -87,8 +87,10 @@ import Fusion.Plugin.Common -- 3. 'Constr' is a construction or bare boxed use. data Context = CaseAlt (Alt CoreBndr) | CaseScrut CoreBndr | Constr Id --- letBndrsThatAreCases restricts itself to only case matches right on --- entry to a let. This one looks for case matches anywhere. +-- Inspection detects everything detectable: it looks for interesting types +-- everywhere in a binding, in every subexpression including case scrutinees. +-- (Force-inlining is deliberately narrower; those choices are documented in +-- Fusion.Plugin.Fuse) -- -- | Report whether data constructors of interest are case matched or returned -- anywhere in the binders, not just case match on entry or construction on @@ -128,10 +130,16 @@ containsAnns dflags isInteresting bind = go :: [CoreBind] -> CoreExpr -> [([CoreBind], Context)] -- Match and record the case alternative if it contains a constructor - -- annotated with "Fuse" and traverse the Alt expressions to discover more - -- let bindings. - go parents (Case _ caseBndr _ alts) = - let binders = alts >>= (\(ALT_CONSTR(_,_,expr1)) -> go parents expr1) + -- annotated with "Fuse", and traverse both the scrutinee and the Alt + -- expressions to discover more hits and let bindings. Traversing the + -- scrutinee ('scrut') matters for matches buried there -- e.g. a stream + -- stepper lambda passed to an un-inlined imported combinator (such as + -- 'foldBreak'), which lands in the scrutinee of the outer result-unpacking + -- @case (# _, _ #)@. + go parents (Case scrut caseBndr _ alts) = + let binders = + go parents scrut + ++ (alts >>= (\(ALT_CONSTR(_,_,expr1)) -> go parents expr1)) hit = case altsContainsAnn dflags isInteresting alts of Just x -> [(parents, CaseAlt x)] From d3038d9bbc1261aeda582fec937d2209f2846d77 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 22 Jul 2026 03:12:39 +0530 Subject: [PATCH 3/4] Inspect the expression in a Tick --- src/Fusion/Plugin/Inspect.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Fusion/Plugin/Inspect.hs b/src/Fusion/Plugin/Inspect.hs index 0544714..8dc82af 100644 --- a/src/Fusion/Plugin/Inspect.hs +++ b/src/Fusion/Plugin/Inspect.hs @@ -165,9 +165,13 @@ containsAnns dflags isInteresting bind = go parents (Lam _ expr1) = go parents expr1 go parents (Cast expr1 _) = go parents expr1 - -- There are no let bindings in these. + -- A 'Tick' (cost-centre, HPC, or debug/source note, present under -prof, + -- -fhpc, or -g) wraps a sub-expression, which may itself contain matches or + -- constructions, so descend into it. + go parents (Tick _ expr1) = go parents expr1 + + -- These carry no sub-expression to traverse. go _ (Lit _) = [] - go _ (Tick _ _) = [] go _ (Type _) = [] go _ (Coercion _) = [] From 807bdc572e1ad26334e7ebd575f04db439733831 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Wed, 22 Jul 2026 03:46:25 +0530 Subject: [PATCH 4/4] Warn about consumed vars involving fusible types --- src/Fusion/Plugin/Inspect.hs | 87 ++++++++++++++++++++++++++++++++---- 1 file changed, 78 insertions(+), 9 deletions(-) diff --git a/src/Fusion/Plugin/Inspect.hs b/src/Fusion/Plugin/Inspect.hs index 8dc82af..fbc73b6 100644 --- a/src/Fusion/Plugin/Inspect.hs +++ b/src/Fusion/Plugin/Inspect.hs @@ -389,6 +389,46 @@ normConstructions forbidFused anns d = do , niBanner = banner } +-- | Collect the fusible ('Fuse'-annotated) 'TyCon's that occur as the type of +-- a bare 'Var' /reference/ -- not a data constructor -- anywhere in the Core +-- of an expression. These are consumers of a fusible value: force-inlining +-- deliberately targets the enclosing binder so that case-of-case can eliminate +-- the value (see 'constructingBinders' item 5 in Fusion.Plugin.Fuse). A bare +-- Var reference is not an allocation, so 'containsAnns' does not record it as +-- a 'Constr' hit and it is not verified through 'PermitConstructions'; it is +-- only reported as an advisory note (see 'warnConsumedFusible'). Actual +-- constructors (nullary or applied) are excluded here -- those are already +-- reported as constructions. +-- +consumedFusibleTyCons :: UNIQ_FM -> CoreExpr -> [TyCon] +consumedFusibleTyCons fuseAnns e0 = + nonDetEltsUniqSet (go e0) + + where + + fusibleRef i + | Nothing <- isDataConId_maybe i + , Just tc <- tyConAppTyConPicky_maybe (varType i) + , isJust (lookupUFM fuseAnns (getName tc)) = unitUniqSet tc + | otherwise = emptyUniqSet + + go (Var i) = fusibleRef i + go (Lit _) = emptyUniqSet + go (App e1 e2) = go e1 `unionUniqSets` go e2 + go (Lam _ e) = go e + go (Let b e) = goBind b `unionUniqSets` go e + go (Case scrut _ _ alts) = + go scrut + `unionUniqSets` + unionManyUniqSets (map (\(ALT_CONSTR(_,_,e)) -> go e) alts) + go (Cast e _) = go e + go (Tick _ e) = go e + go (Type _) = emptyUniqSet + go (Coercion _) = emptyUniqSet + + goBind (NonRec _ e) = go e + goBind (Rec bs) = unionManyUniqSets (map (go . snd) bs) + -- | If the given top level bind's own binder carries an 'InspectPatternMatches' -- and/or an 'InspectConstructions' annotation, print a report of interesting -- types case-matched or constructed anywhere in its RHS, per the annotation's @@ -399,23 +439,33 @@ normConstructions forbidFused anns d = do -- @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 the number of directives (0, 1 or 2) that reported a violation. +-- Returns the number of directives (0, 1 or 2) that reported a violation, and +-- a flag that is 'True' when the (non-violation) consumed-fusible advisory +-- fired -- so the caller can dump the Core for it without counting it as a +-- violation. reportInspected :: DynFlags -> ReportMode -> Bool -> Bool -> UNIQ_FM -> INSPECT_PM_FM -> INSPECT_CONSTR_FM - -> [(CoreBndr, CoreExpr)] -> CoreBind -> CoreM Int + -> [(CoreBndr, CoreExpr)] -> CoreBind -> CoreM (Int, Bool) reportInspected dflags reportMode forbidFused inspectUnboxed anns pmAnns constrAnns allBinds (NonRec b _) - | subsumedBySameName allBinds b = return 0 + | subsumedBySameName allBinds b = return (0, False) | otherwise = do n1 <- maybe (return 0) (\d -> normPatternMatches forbidFused anns d >>= go) (lookupBinderAnn b pmAnns) - n2 <- maybe (return 0) - (\d -> normConstructions forbidFused anns d >>= go) + (n2, advised) <- maybe (return (0, False)) + (\d -> do + ni <- normConstructions forbidFused anns d + r <- go ni + -- Advisory only: references to fusible values that fusion + -- would try to inline away. Not counted as a violation, but + -- the returned flag lets the caller dump the Core for it. + adv <- warnConsumedFusible ni + return (r, adv)) (lookupBinderAnn b constrAnns) - return (n1 + n2) + return (n1 + n2, advised) where @@ -465,6 +515,24 @@ reportInspected ++ DL.intercalate ", " (map qualifiedName stale) ++ "]" + -- Returns 'True' if any consumed-but-not-constructed fusible type was + -- reported, so the caller can dump the Core even though this is not a + -- violation. + warnConsumedFusible ni = do + let excluded = niExclusion ni + tycons = DL.nub + $ concatMap (consumedFusibleTyCons anns . snd) + (binderClosure allBinds b) + reported = filter ((`notElem` excluded) . getName) tycons + unless (null reported) $ + putMsgS $ "fusion-plugin: " + ++ binderDisplayName b + ++ ": note: fusible type(s) consumed as var references," + ++ " not constructed:" + ++ " [" ++ DL.intercalate ", " (map qualifiedTyConName reported) + ++ "]" + return (not (null reported)) + terse ni results = let names = DL.nub (mapMaybe (contextQualifiedName . snd) results) in putMsgS $ "fusion-plugin: " @@ -853,12 +921,12 @@ fusionReport mesg reportMode runInspect opts guts = do classAnns = iaClasses iAnns sizeAnns = iaSizes iAnns dumpAnns = iaDumps iAnns - n1 <- if runInspect + (n1, advised) <- if runInspect then reportInspected dflags reportMode (optionsForbidFused opts) (optionsInspectUnboxed opts) anns pmAnns constrAnns allBinds bind - else return 0 + else return (0, False) n2 <- if runInspect then reportInspectedClasses dflags reportMode classAnns allBinds bind @@ -880,7 +948,8 @@ fusionReport mesg reportMode runInspect opts guts = do | hasDumpAnn = True | otherwise = (optionsDumpCoreIfAnnotated opts && hasViolationAnn) - || (optionsDumpCoreIfViolated opts && n1 + n2 + n3 > 0) + || (optionsDumpCoreIfViolated opts + && (n1 + n2 + n3 > 0 || advised)) when (shouldDump && notSubsumed) $ dumpBindCore dflags pkgName modName allBinds b when (b `elemVarSet` liveBndrs) $ do