+import GHC.Types.Name         ( getOccName, getSrcSpan, mkSystemNameAt )

+import GHC.Types.Name.Occurrence ( occNameFS, mkVarOccFS )

+                             -- Keep bndr's srcspan so that diagnostics can

+                             -- still point at the original definition

+                             mkLocalId (mkSystemNameAt uniq (mkVarOccFS str) (getSrcSpan bndr))

+                                       (idMult bndr) poly_ty

+import GHC.Core.TyCo.Compare ( eqType )

+import GHC.Core.TyCo.Ppr ( pprSigmaType )

+import GHC.Core.TyCo.Tidy ( tidyTopType )

+import GHC.Types.Literal ( Literal, litIsLifted )

+import GHC.Types.SrcLoc ( isGoodSrcSpan )

+import Data.List ( sortBy, partition, dropWhileEnd, mapAccumL, nub, nubBy, unzip4 )

+       ; mapM_ (diagnostic (WarningWithFlag Opt_WarnSpecConstrReboxing) . rebox_msg)

+               (aggregateRebox rebox_ws)

+    -- One warning per specialised function (all its patterns listed),

+    -- then warnings that would render identically merged too; see

+    -- Note [Reboxing warning]

+    aggregateRebox :: SpecConstrWarnings -> SpecConstrWarnings

+    aggregateRebox = mergeBy same_render . mergeBy same_fn

+      where

+        mergeBy eq ws

+          = [ SpecReboxed fn ty parent recur (nubBy same_pat (concat patss)) (nub (concat callerss))

+            | w@(SpecReboxed fn ty parent recur _ _) <- nubBy eq ws

+            , let (patss, callerss) = unzip [ (pats, callers)

+                                            | w'@(SpecReboxed _ _ _ _ pats callers) <- ws

+                                            , eq w w' ] ]

+

+        -- Also compare the parents: the fn Name alone is ambiguous

+        -- between top-level bindings; see Note [Reboxing warning]

+        same_fn (SpecReboxed fn1 _ p1 _ _ _) (SpecReboxed fn2 _ p2 _ _ _)

+          = fn1 == fn2 && p1 == p2

+        same_fn _ _ = False

+

+        -- Merge warnings that would render identically: same occurrence

+        -- name, type, parent, displayed location, recursivity, and

+        -- patterns. The reader could not tell them apart, so printing

+        -- both is noise; see Note [Reboxing warning].  Callers are

+        -- aggregated, not compared.

+        same_render (SpecReboxed fn1 ty1 p1 r1 pats1 _) (SpecReboxed fn2 ty2 p2 r2 pats2 _)

+          = getOccName fn1 == getOccName fn2 && p1 == p2

+            && nameSrcSpan (rebox_loc_name fn1 p1) == nameSrcSpan (rebox_loc_name fn2 p2)

+            && ty1 `eqType` ty2

+            && r1 `same_recur` r2

+            && equalLength pats1 pats2

+            && and (zipWith same_pat (sortBy cmpReboxedPat pats1)

+                                     (sortBy cmpReboxedPat pats2))

+        same_render _ _ = False

+

+        same_pat p1 p2 = cmpReboxedPat p1 p2 == EQ

+

+        -- Recursivity as displayed: siblings compare by occurrence name,

+        -- so span-less copies of one mutual group still merge

+        same_recur ReboxSelfRec        ReboxSelfRec        = True

+        same_recur (ReboxNonRec j1)    (ReboxNonRec j2)    = j1 == j2

+        same_recur (ReboxMutualRec s1) (ReboxMutualRec s2)

+          = map getOccName (sortBy stableNameCmp s1)

+            == map getOccName (sortBy stableNameCmp s2)

+        same_recur _ _ = False

+

+    -- The definition site shown in a reboxing warning: the fn's own when

+    -- known, otherwise the parent's (e.g. for simplifier-made join points)

+    rebox_loc_name :: Name -> Maybe Name -> Name

+    rebox_loc_name fn (Just parent)

+      | not (isGoodSrcSpan (nameSrcSpan fn)) = parent

+    rebox_loc_name fn _ = fn

+

+    rebox_msg :: SpecConstrWarning -> SDoc

+    rebox_msg w@(SpecFailForcedArgCount {}) = pprPanic "rebox_msg" (ppr w)

+    rebox_msg (SpecReboxed fn ty mb_parent recur pats callers)

+      = vcat [ hang (text "SpecConstr specialised") 2

+                    (quotes (ppr fn <+> dcolon <+> pp_ty))

+             , nest 2 $ vcat $ catMaybes

+                 [ Just (fact "source:" pp_source)

+                 , Just (fact "recursivity:" pp_recur)

+                 , fact "called from:" <$> pp_callers

+                 , Just (fact pats_label pp_pats) ]

+             , pp_trailer

+             , text "See -Wspec-constr-reboxing in the users guide for possible remedies." ]

+      where

+        -- Aligned label column; $$ overlaps, so a multi-line value keeps

+        -- its lines aligned under the first

+        fact l v = text l $$ nest 23 v

+

+        -- Truncate only pathologically large types

+        pp_ty = sdocWithContext $ \ctx ->

+                  case splitAt 10000 (showSDocOneLine ctx pp_tidy) of

+                    (_, [])        -> pp_tidy

+                    (prefix, _)    -> text prefix <> text "..."

+          where pp_tidy = pprSigmaType (tidyTopType ty)

+                -- pprSigmaType: suppress the printed forall

+

+        -- A name with no source span reached this module in an interface

+        -- unfolding: iface files record no spans for local binders

+        pp_source = case (mb_parent, isGoodSrcSpan (nameSrcSpan loc_name)) of

+          (Nothing, True)  -> pp_loc

+          (Just p,  True)  -> quotes (ppr p) <+> text "at" <+> pp_loc

+          (Just p,  False) -> quotes (ppr p) <> comma <+> pp_no_loc

+          (Nothing, False) -> pp_no_loc

+          where

+            loc_name  = rebox_loc_name fn mb_parent

+            pp_loc    = ppr (nameSrcLoc loc_name)

+            pp_no_loc = text "inlined from another module (no source location)"

+

+        pp_recur = case recur of

+          ReboxSelfRec        -> text "self-recursive"

+          ReboxNonRec True    -> text "non-recursive (a join point)"

+          ReboxNonRec False   -> text "non-recursive"

+          ReboxMutualRec sibs

+            -> text "mutually recursive with"

+               <+> pprWithCommas (quotes . ppr) named <> pp_rest

+            where

+              (named, rest) = splitAt 3 (sortBy stableNameCmp sibs)

+              pp_rest = case length rest of

+                0 -> empty

+                1 -> text " and 1 other"

+                n -> text " and" <+> int n <+> text "others"

+

+        pp_callers = case sortBy stableNameCmp callers of

+          [] -> Nothing

+          cs -> Just (pprWithCommas (quotes . ppr) cs)

+

+        pats_label = case pats of

+          [_] -> "call pattern:"

+          _   -> "call patterns:"

+

+        pp_pats = vcat (map pp_pat (sortBy cmpReboxedPat pats))

+

+        pp_pat (ReboxedPat shapes cons)

+          = hang (hang (ppr fn) 2 (fsep (map pprPatShape shapes))) 2

+                 (text "-- reboxes" <+>

+                  pprWithCommas pp_con (sortBy stableNameCmp cons))

+

+        -- Qualify imported constructors: they identify the package to

+        -- follow up with when the function itself has no location

+        pp_con con

+          | Just m <- nameModule_maybe con, m /= mg_module guts

+          = quotes (ppr m <> dot <> ppr con)

+          | otherwise = quotes (ppr con)

+

+        all_cons = nub [ con | ReboxedPat _ cons <- pats, con <- cons ]

+

+        pp_trailer = fsep $ map text $ words $ case all_cons of

+          [_] -> "This constructor argument is also used boxed, so the specialisation may increase allocation and defeat pointer-equality-based sharing."

+          _   -> "These constructor arguments are also used boxed, so the specialisations may increase allocation and defeat pointer-equality-based sharing."

+                   sc_annotations :: UniqFM Name SpecConstrAnnotation,

+

+                   sc_top_fn    :: Maybe Name

+                        -- The top-level binder whose RHS we are inside,

+                        -- used to attribute warnings about local functions

+                        -- See Note [Reboxing warning]

+                       sc_annotations = anns,

+                       sc_top_fn      = Nothing }) }

+-- Keeps the outermost binder; see Note [Reboxing warning]

+setTopFn :: ScEnv -> OutId -> ScEnv

+setTopFn env@(SCE { sc_top_fn = Nothing }) bndr = env { sc_top_fn = Just (idName bndr) }

+setTopFn env _ = env

+

+data Call    = Call OutId [CoreArg] ValueEnv (Maybe Name)

+        -- and the enclosing top-level binder of the call site

+        -- (sc_top_fn, for reboxing warnings)

+  ppr (Call fn args _ _) = ppr fn <+> fsep (map pprParendExpr args)

+* One warning per function, listing each call pattern the function was

+  specialised for — the constructor skeletons of the call's arguments,

+  e.g. `go (_ : _) (BMap _) -- reboxes ‘BMap’` — alongside that

+  pattern's reboxed constructors.  The shapes show where in the

+  argument each reboxed constructor sits, and picture what SpecConstr

+  did: it made a copy of

+  the function for calls of exactly that shape.  The warning also shows

+  the function's type: names like `go1` say nothing, and for span-less

+  functions (last bullet below) the type is the main identifying clue.

+

+  "Per function" means per (parent, function) *pair*: the function's

+  Name alone is ambiguous, because distinct top-level bindings can bind

+  distinct locals that share a unique.  That happens when several

+  bindings inline one stable unfolding (e.g. a class's default-method

+  template): each copy keeps the template's uniques, and the simplifier

+  only freshens a binder on an in-scope clash, which cannot arise

+  between sibling top-level RHSs.

+

+  Warnings that would render identically — same name, type, parent,

+  definition site, recursivity, and patterns — are merged too: the

+  reader could not tell them apart, so printing both is noise.  For

+  located functions the merged warnings are simplifier-made copies of one

+  binding, addressed by a single source-level remedy; span-less loops

+  inlined from other modules can in principle merge across different

+  origins, but sharing name and type they are almost certainly copies of

+  one function.

+

+* The warning classifies how the specialised function recurses

+  ("recursivity"), taken from the binding SpecConstr saw: a Rec group of

+  one is self-recursive (the occurrence analyser demotes non-recursive

+  singletons to NonRec), a larger group is mutually recursive and the

+  siblings are named, and a nested NonRec binding — typically a join

+  point, see Note [Specialising local let bindings] — is non-recursive.

+  This reflects the post-optimisation program, whose shape can differ

+  from the source's.

+

+* Nullary constructors are exempt: "reboxing" a nullary constructor just

+  references its shared static closure, so it costs no allocation and even

+  preserves pointer identity.  Such patterns are common (Nil, [], Nothing,

+  ...) and warning about them would be pure noise.

+

+* Warnings about local functions (join points, local workers) name the

+  enclosing top-level binder too: locals often have meaningless names,

+  and any remedy is applied at the enclosing function anyway.

+  sc_top_fn tracks that binder, set when entering a top-level RHS (or a

+  specialised copy of one) and kept unchanged below that.  The location

+  shown is the local's own definition site, so same-named locals can be

+  told apart; only when that is missing (e.g. for simplifier-made join

+  points) does the warning fall back to the parent's location.

+

+* The warning lists the top-level binders containing the specialised

+  calls ("called from"); each Call records the sc_top_fn of its call

+  site for this purpose.  Self-calls of a top-level loop are dropped as

+  uninformative (in callToPat); a *local* loop's self-calls record its

+  parent, indistinguishable from the parent's entry call, so the parent

+  appears among the callers.

+

+* A function with no source span and no parent reached this module in an

+  interface unfolding: iface files record no spans for local binders, and

+  such loops typically float to top level in the consuming module.  The

+  warning says "inlined from another module" instead of showing an

+  unhelpful span.  Imported constructors are shown qualified — with the

+  function anonymous, they are what identifies the package to report the

+  reboxing to.  For such a warning the call sites ("called from") are the

+  only located code to point at: following the inlining from one of them

+  identifies the reboxed loop.

+

+  = do { (rhs_usage, rhs', ws_rhs)   <- scExpr (setTopFn env bndr) rhs

+        ; (rhs_usgs, rhss', rhs_ws) <- mapAndUnzip3M (\(b,r) -> scExpr (setTopFn env b) r)

+                                                     (bndrs' `zip` rhss)

+        Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env) (sc_top_fn env)]

+              (body_env, arg_bndrs') = extendBndrsWith RecArg (setTopFn env bndr) arg_bndrs

+  = specialise env recur body_calls rhs_info (initSpecInfo rhs_info)

+  where

+    recur = ReboxNonRec (isJoinId (ri_fn rhs_info))

+    -- A Rec group of one is genuinely self-recursive: the occurrence

+    -- analyser demotes non-recursive singletons to NonRec

+    recur ri = case rhs_infos of

+      [_] -> ReboxSelfRec

+      _   -> ReboxMutualRec [ idName (ri_fn ri') | ri' <- rhs_infos

+                            , ri_fn ri' /= ri_fn ri ]

+

+        do  { specs_w_usg <- zipWithM (\ri si -> specialise env (recur ri) seed_calls ri si)

+                                      rhs_infos spec_infos

+   -> ReboxRecursivity            -- How the function recurses, for warnings

+specialise env recur bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs

+                                    , ri_lam_body = body, ri_arg_occs = arg_occs })

+              rebox_ws = [ SpecReboxed (idName fn) (idType fn) (sc_top_fn env)

+                                       recur [ReboxedPat (patShapes p) (cp_rebox p)]

+                                       (cp_callers p)

+        ; let spec_env = setTopFn (decreaseSpecCount env n_pats) fn

+                -- setTopFn: attribute warnings from re-analysing the

+                -- specialised copies of a top-level fn's body to fn

+                  , cp_rebox :: [Name]          -- Constructors matched by this pattern whose box

+                  , cp_callers :: [Name] }      -- Enclosing top-level binders of the calls this

+                                                -- pattern came from; see Note [Reboxing warning]

+  ppr (CP { cp_qvars = qvars, cp_args = args, cp_strict_args = strict, cp_rebox = rebox

+          , cp_callers = callers })

+                               , text "cp_rebox = " <> ppr rebox

+                               , text "cp_callers = " <> ppr callers ])

+

+-- | One call pattern as displayed by the reboxing warning: the shapes of

+-- the pattern's arguments, and the reboxed constructors among them.

+-- See Note [Reboxing warning]

+data ReboxedPat = ReboxedPat [PatShape] [Name]

+

+-- | The constructor skeleton of one call-pattern argument, as displayed

+-- by the reboxing warning

+data PatShape = ShapeWild

+              | ShapeLit Literal

+              | ShapeCon DataCon [PatShape]

+

+-- | The displayed shapes of a pattern's value arguments

+patShapes :: CallPat -> [PatShape]

+patShapes (CP { cp_args = args }) = mapMaybe arg_shape args

+  where

+    arg_shape (Type {})     = Nothing

+    arg_shape (Coercion {}) = Nothing

+    arg_shape (Cast e _)    = arg_shape e

+    arg_shape (Tick _ e)    = arg_shape e

+    arg_shape (Lit l)       = Just (ShapeLit l)

+    arg_shape e

+      | (Var f, f_args) <- collectArgs e

+      , Just dc <- isDataConWorkId_maybe f

+      = Just (ShapeCon dc (mapMaybe arg_shape f_args))

+      | otherwise

+      = Just ShapeWild

+

+-- | Stable comparison, used both to merge identically-rendering warnings

+-- and to order a warning's patterns deterministically

+cmpReboxedPat :: ReboxedPat -> ReboxedPat -> Ordering

+cmpReboxedPat (ReboxedPat ss1 cs1) (ReboxedPat ss2 cs2)

+  = cmpListBy cmpShape ss1 ss2

+    `mappend` cmpListBy stableNameCmp (sortBy stableNameCmp cs1)

+                                      (sortBy stableNameCmp cs2)

+

+cmpShape :: PatShape -> PatShape -> Ordering

+cmpShape ShapeWild        ShapeWild        = EQ

+cmpShape ShapeWild        _                = LT

+cmpShape _                ShapeWild        = GT

+cmpShape (ShapeLit l1)    (ShapeLit l2)    = compare l1 l2

+cmpShape (ShapeLit _)     _                = LT

+cmpShape _                (ShapeLit _)     = GT

+cmpShape (ShapeCon c1 a1) (ShapeCon c2 a2)

+  = stableNameCmp (dataConName c1) (dataConName c2)

+    `mappend` cmpListBy cmpShape a1 a2

+

+cmpListBy :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering

+cmpListBy _   []       []       = EQ

+cmpListBy _   []       _        = LT

+cmpListBy _   _        []       = GT

+cmpListBy cmp (x1:xs1) (x2:xs2) = cmp x1 x2 `mappend` cmpListBy cmp xs1 xs2

+

+-- Constructors are shown by bare occurrence name: shapes illustrate,

+-- while the warning's "reboxes" list identifies (with qualification)

+pprPatShape :: PatShape -> SDoc

+pprPatShape = go (10 :: Int)   -- Depth cap against pathological patterns

+  where

+    go _ ShapeWild        = underscore

+    go _ (ShapeLit l)     = ppr l

+    go _ (ShapeCon dc []) = ppr (getOccName dc)

+    go 0 (ShapeCon {})    = text "..."

+    go d (ShapeCon dc args)

+      | isTupleDataCon dc

+      = parens (pprWithCommas (go d') args)

+      | isUnboxedTupleDataCon dc

+      = text "(#" <+> pprWithCommas (go d') args <+> text "#)"

+      | dataConIsInfix dc, [a1, a2] <- args

+      = parens (go d' a1 <+> pprInfixOcc (getOccName dc) <+> go d' a2)

+      | otherwise

+      = parens (pprPrefixOcc (getOccName dc) <+> sep (map (go d') args))

+      where d' = d - 1

+

+-- | How the function that SpecConstr specialised recurses, as bound in

+-- the post-optimisation program.  See Note [Reboxing warning]

+data ReboxRecursivity

+  = ReboxSelfRec

+  | ReboxMutualRec [Name]  -- The sibling binders of its Rec group

+  | ReboxNonRec Bool       -- True <=> a join point

+                , spec_rebox_fun_ty :: Type      -- Its type: often the only clue

+                                                 -- to a span-less function's identity

+                , spec_rebox_parent :: Maybe Name -- Its enclosing top-level

+                                                  -- binder, if fn is local

+                , spec_rebox_recur :: ReboxRecursivity

+                , spec_rebox_pats :: [ReboxedPat] -- The patterns that rebox

+                , spec_rebox_callers :: [Name] } -- Top-level binders containing

+                                                 -- the specialised calls

+  ppr (SpecReboxed fn _ty mb_parent _recur pats _callers)

+    = ppr fn <+> parens (pprWithCommas ppr dcs) <+> pp_defn

+    where

+      dcs = [ dc | ReboxedPat _ cons <- pats, dc <- cons ]

+      -- A local fn often has no useful location; point at its

+      -- enclosing top-level binder instead

+      pp_defn = case mb_parent of

+        Just parent -> text "in" <+> ppr parent <> comma <+> pprDefinedAt parent

+        Nothing     -> pprDefinedAt fn

+callToPat env bndr_occs call@(Call fn args con_env mb_caller)

+                                    , cp_rebox = concat rebox_cons

+                                      -- Self-recursive calls are no clue

+                                      -- to the function's identity

+                                    , cp_callers = [ c | Just c <- [mb_caller]

+                                                       , c /= idName fn ] }

+             -- rebox_here: see Note [Reboxing warning]; nullary

+             -- constructors rebox for free, so don't warn about them

+             rebox_here   = [ dataConName dc

+                            | box_use == BoxOther, dataConRepArity dc > 0 ]

+    The warning shows the specialised function's type, which is often the

+    clearest clue to its identity when its name carries no meaning,

+    followed by a block of labelled facts: ``source:`` — the function's

+    definition site (for a local function, also the enclosing top-level

+    binding); ``recursivity:`` — whether the function is self-recursive,

+    mutually recursive (naming the other functions of its recursive

+    group), or non-recursive (for example a join point), as bound in the

+    optimised program, whose shape can differ from the source's;

+    ``called from:`` — the top-level bindings containing the specialised

+    calls; ``call patterns:`` — the calls the function was specialised

+    for, shown as the constructor skeletons of their arguments, each

+    alongside the constructors that the specialisation reboxes (for

+    example ``go (_ : _) (Bin _ _ _) -- reboxes ‘Bin’``). One warning is emitted per

+    specialised function, and warnings that would read identically are

+    merged into one. Specialisations on nullary constructors are not

+    reported, since "reboxing" a nullary constructor simply references

+    its shared static closure.

+

+    A ``source:`` reading ``inlined from another module (no source

+    location)`` concerns a function that reached the module being compiled

+    through another module's unfolding; interface files record no source

+    locations for local functions. Such reboxing cannot be addressed in

+    the module being compiled — consider reporting it against the package

+    defining the inlined code. Constructors imported from other modules

+    are shown qualified with their defining module as a hint to where that

+    is. For such a warning the ``called from:`` sites are the only located

+    code — following the inlining from one of them identifies the reboxed

+    code.

+

+    SpecConstr specialised

+      ‘$wgo :: LC

+               -> GHC.Internal.Prim.Int#

+               -> GHC.Internal.Prim.Int#

+               -> GHC.Internal.Prim.Int#’

+      source:                T27628.hs:17:1

+      recursivity:           self-recursive

+      called from:           ‘f’

+      call pattern:          $wgo (LC _ _) -- reboxes ‘LC’

+    This constructor argument is also used boxed, so the specialisation

+    may increase allocation and defeat pointer-equality-based sharing.

+    See -Wspec-constr-reboxing in the users guide for possible remedies.

+    SpecConstr specialised ‘merge :: T -> T -> T’

+      source:                T27628b.hs:10:1

+      recursivity:           self-recursive

+      called from:           ‘f’

+      call pattern:          merge (Bin _ _ _) -- reboxes ‘Bin’

+    This constructor argument is also used boxed, so the specialisation

+    may increase allocation and defeat pointer-equality-based sharing.

+    See -Wspec-constr-reboxing in the users guide for possible remedies.

+-- Like T27628b, but the specialisation pattern is the *nullary*

+-- constructor Tip (the call passes Tip; the box is also returned).

+-- Reboxing a nullary constructor is free (it is a shared static

+-- closure), so no warning should be emitted.

+module T27628e where

+

+data T = Tip | Bin Int T T

+

+merge :: T -> T -> T

+merge Tip t2 = t2

+merge t1@(Bin k l r) t2 =

+  case t2 of

+    Tip         -> t1

+    Bin _ l2 r2 -> Bin k (merge l l2) (merge r r2)

+

+g :: T -> T

+g t = merge t Tip

+-- Like T27628b, but the specialised function is a *local* worker.

+-- The warning should attribute it to the enclosing top-level binder f.

+-- (merge captures n so that it is not floated to the top level.)

+module T27628f where

+

+data T = Tip | Bin Int T T

+

+f :: Int -> T -> T

+f n t0 = merge (Bin n Tip Tip) t0

+  where

+    merge :: T -> T -> T

+    merge Tip _ = Tip

+    merge t1@(Bin k l r) t2 =

+      case t2 of

+        Tip         -> t1

+        Bin _ l2 r2 -> Bin (k + n) (merge l l2) (merge r r2)

+T27628f.hs: warning: [-Wspec-constr-reboxing]

+    SpecConstr specialised ‘merge :: T -> T -> T’

+      source:                ‘f’ at T27628f.hs:12:5

+      recursivity:           self-recursive

+      called from:           ‘f’

+      call pattern:          merge (Bin _ _ _) -- reboxes ‘Bin’

+    This constructor argument is also used boxed, so the specialisation

+    may increase allocation and defeat pointer-equality-based sharing.

+    See -Wspec-constr-reboxing in the users guide for possible remedies.

+

+module T27628g where