Cover a few additional cases in inspection

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

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)]
@@ -157,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 _) = []
 
@@ -377,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
@@ -387,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
 
@@ -453,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: "
@@ -841,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
@@ -868,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