[Temporary hack, not for master] DmdAnal: Remember by “Many” things are many

I change the type
	data Count = One | Many
into
	data Count = One | Many [String]
and use these list of strings (always sorted and nub'ed) to track the
various reasons why something is called many times.

15 files changed, 195 insertions, 137 deletions

diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs
index 4ae6812434..58a32093ac 100644
--- a/compiler/basicTypes/Demand.hs
+++ b/compiler/basicTypes/Demand.hs
@@ -13,7 +13,7 @@ module Demand (
         Demand, CleanDemand, getStrDmd, getUseDmd,
         mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd,
         toCleanDmd,
-        absDmd, topDmd, botDmd, seqDmd,
+        absDmd, topDmd, boringTopDmd, botDmd, seqDmd,
         lubDmd, bothDmd,
         lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd,
         catchArgDmd,
@@ -50,7 +50,7 @@ module Demand (
         argOneShots, argsOneShots, saturatedByOneShots,
         trimToType, TypeShape(..),
 
-        useCount, isUsedOnce, reuseEnv,
+        useCount, isUsedOnce, isBoringDemand, reuseEnv,
         killUsageDemand, killUsageSig, zapUsageDemand, zapUsageEnvSig,
         zapUsedOnceDemand, zapUsedOnceSig,
         strictifyDictDmd
@@ -59,6 +59,8 @@ module Demand (
 
 #include "HsVersions.h"
 
+import Data.List (nub, sort)
+
 import DynFlags
 import Outputable
 import Var ( Var )
@@ -357,15 +359,25 @@ data Use u
   | Use Count u     -- May be used with some cardinality
   deriving ( Eq, Show )
 
+-- Lets be lazy here and use strings, instead of a proper data type
+type ManyReasons = [String]
+
+normManyReasons :: ManyReasons -> ManyReasons
+normManyReasons = nub . sort
+
+lubManyReasons :: ManyReasons -> ManyReasons -> ManyReasons
+lubManyReasons mr1 mr2 = normManyReasons $ mr1 ++ mr2
+
 -- Abstract counting of usages
-data Count = One | Many
+-- Bool argument: True <=> Many for a good reason
+data Count = One | Many ManyReasons
   deriving ( Eq, Show )
 
 -- Pretty-printing
 instance Outputable ArgUse where
-  ppr Abs           = char 'A'
-  ppr (Use Many a)   = ppr a
-  ppr (Use One  a)   = char '1' <> char '*' <> ppr a
+  ppr Abs              = char 'A'
+  ppr (Use (Many _) a) = ppr a
+  ppr (Use One  a)     = char '1' <> char '*' <> ppr a
 
 instance Outputable UseDmd where
   ppr Used           = char 'U'
@@ -375,11 +387,11 @@ instance Outputable UseDmd where
 
 instance Outputable Count where
   ppr One  = char '1'
-  ppr Many = text ""
+  ppr (Many _) = text ""
 
 useBot, useTop :: ArgUse
 useBot     = Abs
-useTop     = Use Many Used
+useTop     = Use (Many ["top"]) Used
 
 mkUCall :: Count -> UseDmd -> UseDmd
 --mkUCall c Used = Used c
@@ -391,8 +403,9 @@ mkUProd ux
   | otherwise          = UProd ux
 
 lubCount :: Count -> Count -> Count
-lubCount _ Many = Many
-lubCount Many _ = Many
+lubCount (Many r1) (Many r2) = Many (r1 `lubManyReasons` r2)
+lubCount _ (Many r) = Many r
+lubCount (Many r) _ = Many r
 lubCount x _    = x
 
 lubArgUse :: ArgUse -> ArgUse -> ArgUse
@@ -420,30 +433,35 @@ lubUse Used _                      = Used  -- Note [Used should win]
 --  cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain).
 --  Also,  x `bothUse` x /= x (for anything but Abs).
 
-bothArgUse :: ArgUse -> ArgUse -> ArgUse
-bothArgUse Abs x                   = x
-bothArgUse x Abs                   = x
-bothArgUse (Use _ a1) (Use _ a2)   = Use Many (bothUse a1 a2)
+bothCount :: String -> Count -> Count -> Count
+bothCount r One One = Many [r]
+bothCount r One (Many mr) = Many  (mr `lubManyReasons` [r])
+bothCount r (Many mr) One = Many  (mr `lubManyReasons` [r])
+bothCount r (Many mr1) (Many mr2) = Many  (mr1 `lubManyReasons` mr2 `lubManyReasons` [r])
 
+bothArgUse :: String -> ArgUse -> ArgUse -> ArgUse
+bothArgUse _ Abs x                    = x
+bothArgUse _ x Abs                    = x
+bothArgUse r (Use c1 a1) (Use c2 a2)  = Use (bothCount r c1 c2) (bothUse r a1 a2)
 
-bothUse :: UseDmd -> UseDmd -> UseDmd
-bothUse UHead       u               = u
-bothUse (UCall c u) UHead           = UCall c u
+bothUse :: String -> UseDmd -> UseDmd -> UseDmd
+bothUse _ UHead       u               = u
+bothUse _ (UCall c u) UHead           = UCall c u
 
 -- Exciting special treatment of inner demand for call demands:
 --    use `lubUse` instead of `bothUse`!
-bothUse (UCall _ u1) (UCall _ u2)   = UCall Many (u1 `lubUse` u2)
+bothUse r (UCall _ u1) (UCall _ u2)   = UCall (Many [r]) (u1 `lubUse` u2)
 
-bothUse (UCall {}) _                = Used
-bothUse (UProd ux) UHead            = UProd ux
-bothUse (UProd ux1) (UProd ux2)
-      | length ux1 == length ux2    = UProd $ zipWith bothArgUse ux1 ux2
+bothUse _ (UCall {}) _                = Used
+bothUse _ (UProd ux) UHead            = UProd ux
+bothUse r (UProd ux1) (UProd ux2)
+      | length ux1 == length ux2    = UProd $ zipWith (bothArgUse r) ux1 ux2
       | otherwise                   = Used
-bothUse (UProd {}) (UCall {})       = Used
+bothUse _ (UProd {}) (UCall {})       = Used
 -- bothUse (UProd {}) Used             = Used  -- Note [Used should win]
-bothUse Used (UProd ux)             = UProd (map (`bothArgUse` useTop) ux)
-bothUse (UProd ux) Used             = UProd (map (`bothArgUse` useTop) ux)
-bothUse Used _                      = Used  -- Note [Used should win]
+bothUse r Used (UProd ux)             = UProd (map (\x -> bothArgUse r x useTop) ux)
+bothUse r (UProd ux) Used             = UProd (map (\x -> bothArgUse r x useTop) ux)
+bothUse _ Used _                      = Used  -- Note [Used should win]
 
 peelUseCall :: UseDmd -> Maybe (Count, UseDmd)
 peelUseCall (UCall c u)   = Just (c,u)
@@ -456,7 +474,7 @@ addCaseBndrDmd :: Demand    -- On the case binder
 addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds
   = case mu of
      Abs     -> alt_dmds
-     Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us)
+     Use _ u -> zipWith (bothDmd "caseBndr") alt_dmds (mkJointDmds ss us)
              where
                 Just ss = splitArgStrProdDmd arity ms  -- Guaranteed not to be a call
                 Just us = splitUseProdDmd      arity u   -- Ditto
@@ -542,20 +560,24 @@ Compare with: (C) making Used win for both, but UProd win for lub
 
 -- If a demand is used multiple times (i.e. reused), than any use-once
 -- mentioned there, that is not protected by a UCall, can happen many times.
-markReusedDmd :: ArgUse -> ArgUse
-markReusedDmd Abs         = Abs
-markReusedDmd (Use _ a)   = Use Many (markReused a)
+markReusedDmd :: ManyReasons -> ArgUse -> ArgUse
+markReusedDmd _ Abs         = Abs
+markReusedDmd r (Use c a)   = Use (addReason r c) (markReused r a)
 
-markReused :: UseDmd -> UseDmd
-markReused (UCall _ u)      = UCall Many u   -- No need to recurse here
-markReused (UProd ux)       = UProd (map markReusedDmd ux)
-markReused u                = u
+addReason :: ManyReasons -> Count -> Count
+addReason r One = Many r
+addReason r (Many mr) = Many (mr `lubManyReasons` r)
+
+markReused :: ManyReasons -> UseDmd -> UseDmd
+markReused r (UCall c u)      = UCall (addReason r c) u   -- No need to recurse here
+markReused r (UProd ux)       = UProd (map (markReusedDmd r) ux)
+markReused _ u                = u
 
 isUsedMU :: ArgUse -> Bool
 -- True <=> markReusedDmd d = d
 isUsedMU Abs          = True
 isUsedMU (Use One _)  = False
-isUsedMU (Use Many u) = isUsedU u
+isUsedMU (Use (Many _) u) = isUsedU u
 
 isUsedU :: UseDmd -> Bool
 -- True <=> markReused d = d
@@ -563,7 +585,7 @@ isUsedU Used           = True
 isUsedU UHead          = True
 isUsedU (UProd us)     = all isUsedMU us
 isUsedU (UCall One _)  = False
-isUsedU (UCall Many _) = True  -- No need to recurse
+isUsedU (UCall (Many _) _) = True  -- No need to recurse
 
 -- Squashing usage demand demands
 seqUseDmd :: UseDmd -> ()
@@ -581,7 +603,7 @@ seqArgUse _          = ()
 
 -- Splitting polymorphic Maybe-Used demands
 splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse]
-splitUseProdDmd n Used        = Just (replicate n useTop)
+splitUseProdDmd n Used        = Just (replicate n (Use (Many ["splitUse"]) Used))
 splitUseProdDmd n UHead       = Just (replicate n Abs)
 splitUseProdDmd n (UProd ds)  = ASSERT2( ds `lengthIs` n, text "splitUseProdDmd" $$ ppr n $$ ppr ds )
                                 Just ds
@@ -590,9 +612,8 @@ splitUseProdDmd _ (UCall _ _) = Nothing
       -- and we don't then want to crash the compiler (Trac #9208)
 
 useCount :: Use u -> Count
-useCount Abs         = One
-useCount (Use One _) = One
-useCount _           = Many
+useCount Abs       = One
+useCount (Use c _) = c
 
 
 {-
@@ -641,18 +662,19 @@ type CleanDemand = JointDmd StrDmd UseDmd
 
 bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand
 bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2})
-  = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 }
+  = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse'` a2 }
+  where bothUse' = bothUse "bothCleanDmd"
 
 mkHeadStrict :: CleanDemand -> CleanDemand
 mkHeadStrict cd = cd { sd = HeadStr }
 
 mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand
 mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str VanStr s, ud = Use One a }
-mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str VanStr s, ud = Use Many a }
+mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str VanStr s, ud = Use (Many ["mkManyUsedDmd"]) a }
 
 evalDmd :: Demand
 -- Evaluated strictly, and used arbitrarily deeply
-evalDmd = JD { sd = Str VanStr HeadStr, ud = useTop }
+evalDmd = JD { sd = Str VanStr HeadStr, ud = Use (Many ["evalDmd"]) Used }
 
 mkProdDmd :: [Demand] -> CleanDemand
 mkProdDmd dx
@@ -673,7 +695,7 @@ cleanEvalDmd :: CleanDemand
 cleanEvalDmd = JD { sd = HeadStr, ud = Used }
 
 cleanEvalProdDmd :: Arity -> CleanDemand
-cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) }
+cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n (Use (Many ["cleanEval"]) Used)) }
 
 
 {-
@@ -691,15 +713,16 @@ lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})
  = JD { sd = s1 `lubArgStr` s2
       , ud = a1 `lubArgUse` a2 }
 
-bothDmd :: Demand -> Demand -> Demand
-bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})
+bothDmd :: String -> Demand -> Demand -> Demand
+bothDmd r (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})
  = JD { sd = s1 `bothArgStr` s2
-      , ud = a1 `bothArgUse` a2 }
+      , ud = a1 `bothArgUse'` a2 }
+  where bothArgUse' = bothArgUse r
 
 lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, catchArgDmd :: Demand
 
 strictApply1Dmd = JD { sd = Str VanStr (SCall HeadStr)
-                     , ud = Use Many (UCall One Used) }
+                     , ud = Use (Many ["strictApply1Dmd"]) (UCall One Used) }
 
 -- First argument of catch#:
 --    uses its arg once, applies it once
@@ -720,7 +743,10 @@ absDmd :: Demand
 absDmd = JD { sd = Lazy, ud = Abs }
 
 topDmd :: Demand
-topDmd = JD { sd = Lazy, ud = useTop }
+topDmd = JD { sd = Lazy, ud = Use (Many ["topDmd"]) Used }
+
+boringTopDmd :: String -> Demand
+boringTopDmd r = JD { sd = Lazy, ud =  Use (Many [r]) Used }
 
 botDmd :: Demand
 botDmd = JD { sd = strBot, ud = useBot }
@@ -734,8 +760,8 @@ oneifyDmd jd                            = jd
 
 isTopDmd :: Demand -> Bool
 -- Used to suppress pretty-printing of an uninformative demand
-isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True
-isTopDmd _                                    = False
+isTopDmd (JD {sd = Lazy, ud = Use (Many _) Used}) = True
+isTopDmd _                                        = False
 
 isAbsDmd :: Demand -> Bool
 isAbsDmd (JD {ud = Abs}) = True   -- The strictness part can be HyperStr
@@ -748,7 +774,12 @@ isSeqDmd _                                                = False
 isUsedOnce :: Demand -> Bool
 isUsedOnce (JD { ud = a }) = case useCount a of
                                One  -> True
-                               Many -> False
+                               Many _ -> False
+
+isBoringDemand :: Demand -> ManyReasons
+isBoringDemand (JD { ud = a }) = case useCount a of
+                               One  -> []
+                               Many b -> b
 
 -- More utility functions for strictness
 seqDemand :: Demand -> ()
@@ -1027,7 +1058,7 @@ resTypeArgDmd :: Termination r -> Demand
 --      TopRes === (Top -> TopRes) === ...
 -- This function makes that concrete
 -- Also see Note [defaultDmd vs. resTypeArgDmd]
-resTypeArgDmd (Dunno _) = topDmd
+resTypeArgDmd (Dunno _) = boringTopDmd "unsat"
 resTypeArgDmd _         = botDmd   -- Diverges or ThrowsExn
 
 {-
@@ -1240,9 +1271,10 @@ bothDmdType (DmdType fv1 ds1 r1) (fv2, t2)
     -- See Note [Asymmetry of 'both' for DmdType and DmdResult]
     -- 'both' takes the argument/result info from its *first* arg,
     -- using its second arg just for its free-var info.
-  = DmdType (plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2))
+  = DmdType (plusVarEnv_CD bothDmd' fv1 (defaultDmd r1) fv2 (defaultDmd t2))
             ds1
             (r1 `bothDmdResult` t2)
+  where bothDmd' = bothDmd "bothDmdType"
 
 instance Outputable DmdType where
   ppr (DmdType fv ds res)
@@ -1395,9 +1427,9 @@ postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env
   -- We only processed the thing at all to analyse the body
   -- See Note [Always analyse in virgin pass]
 
-reuseEnv :: DmdEnv -> DmdEnv
-reuseEnv = mapVarEnv (postProcessDmd
-                        (JD { sd = Str VanStr (), ud = Use Many () }))
+reuseEnv :: String -> DmdEnv -> DmdEnv
+reuseEnv r = mapVarEnv (postProcessDmd
+                        (JD { sd = Str VanStr (), ud = Use (Many [r]) () }))
 
 postProcessUnsat :: DmdShell -> DmdType -> DmdType
 postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty)
@@ -1414,9 +1446,9 @@ postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a})
            Str ExnStr _ -> markExnStr s
            Str VanStr _ -> s
     a' = case us of
-           Abs        -> Abs
-           Use Many _ -> markReusedDmd a
-           Use One  _ -> a
+           Abs            -> Abs
+           Use (Many r) _ -> markReusedDmd r a
+           Use One  _     -> a
 
 markExnStr :: ArgStr -> ArgStr
 markExnStr (Str VanStr s) = Str ExnStr s
@@ -1436,8 +1468,8 @@ peelCallDmd (JD {sd = s, ud = u})
                  HyperStr -> (HyperStr, Str VanStr ())
                  _        -> (HeadStr,  Lazy)
     (u', us) = case u of
-                 UCall c u' -> (u',   Use c    ())
-                 _          -> (Used, Use Many ())
+                 UCall c u' -> (u',   Use c            ())
+                 _          -> (Used, Use (Many ["peel"]) ())
        -- The _ cases for usage includes UHead which seems a bit wrong
        -- because the body isn't used at all!
        -- c.f. the Abs case in toCleanDmd
@@ -1458,7 +1490,7 @@ peelManyCalls n (JD { sd = str, ud = abs })
     go_abs :: Int -> UseDmd -> Use ()      -- Many <=> unsaturated, or at least
     go_abs 0 _              = Use One ()   --          one UCall Many in the demand
     go_abs n (UCall One d') = go_abs (n-1) d'
-    go_abs _ _              = Use Many ()
+    go_abs _ _              = Use (Many ["peel"]) ()
 
 {-
 Note [Demands from unsaturated function calls]
@@ -1810,8 +1842,8 @@ argOneShots one_shot_info (JD { ud = usg })
       Use _ arg_usg -> go arg_usg
       _             -> []
   where
-    go (UCall One  u) = one_shot_info : go u
-    go (UCall Many u) = NoOneShotInfo : go u
+    go (UCall One      u) = one_shot_info : go u
+    go (UCall (Many _) u) = NoOneShotInfo : go u
     go _              = []
 
 {- Note [Computing one-shot info, and ProbOneShot]
@@ -1926,15 +1958,15 @@ kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u}
 
 zap_musg :: KillFlags -> ArgUse -> ArgUse
 zap_musg kfs Abs
-  | kf_abs kfs = useTop
+  | kf_abs kfs = Use (Many ["zap"]) Used
   | otherwise  = Abs
 zap_musg kfs (Use c u)
-  | kf_used_once kfs = Use Many (zap_usg kfs u)
-  | otherwise        = Use c    (zap_usg kfs u)
+  | kf_used_once kfs = Use (Many ["zap"]) (zap_usg kfs u)
+  | otherwise        = Use c              (zap_usg kfs u)
 
 zap_usg :: KillFlags -> UseDmd -> UseDmd
 zap_usg kfs (UCall c u)
-    | kf_called_once kfs = UCall Many (zap_usg kfs u)
+    | kf_called_once kfs = UCall (Many ["zap"]) (zap_usg kfs u)
     | otherwise          = UCall c    (zap_usg kfs u)
 zap_usg kfs (UProd us)   = UProd (map (zap_musg kfs) us)
 zap_usg _   u            = u
@@ -1950,7 +1982,7 @@ strictifyDictDmd ty dmd = case getUseDmd dmd of
     Just (tycon, _arg_tys, _data_con, inst_con_arg_tys)
       <- splitDataProductType_maybe ty,
     not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary
-    -> seqDmd `bothDmd` -- main idea: ensure it's strict
+    -> bothDmd "strictify" seqDmd $
        case splitProdDmd_maybe dmd of
          -- superclass cycles should not be a problem, since the demand we are
          -- consuming would also have to be infinite in order for us to diverge
@@ -2034,12 +2066,12 @@ instance Binary ArgStr where
 
 instance Binary Count where
     put_ bh One  = do putByte bh 0
-    put_ bh Many = do putByte bh 1
+    put_ bh (Many _) = do putByte bh 1
 
     get  bh = do h <- getByte bh
                  case h of
                    0 -> return One
-                   _ -> return Many
+                   _ -> return (Many ["iface"])
 
 instance Binary ArgUse where
     put_ bh Abs          = do
diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs
index 97d4186d4f..1f99f4a714 100644
--- a/compiler/basicTypes/IdInfo.hs
+++ b/compiler/basicTypes/IdInfo.hs
@@ -270,7 +270,7 @@ vanillaIdInfo
             oneShotInfo         = NoOneShotInfo,
             inlinePragInfo      = defaultInlinePragma,
             occInfo             = NoOccInfo,
-            demandInfo          = topDmd,
+            demandInfo          = boringTopDmd "vanilla",
             strictnessInfo      = nopSig,
             callArityInfo     = unknownArity
            }
@@ -453,7 +453,7 @@ zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})
   | is_safe_occ occ && is_safe_dmd demand
   = Nothing
   | otherwise
-  = Just (info {occInfo = safe_occ, demandInfo = topDmd})
+  = Just (info {occInfo = safe_occ, demandInfo = boringTopDmd "zap"})
   where
         -- The "unsafe" occ info is the ones that say I'm not in a lambda
         -- because that might not be true for an unsaturated lambda
@@ -468,7 +468,7 @@ zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand})
 
 -- | Remove all demand info on the 'IdInfo'
 zapDemandInfo :: IdInfo -> Maybe IdInfo
-zapDemandInfo info = Just (info {demandInfo = topDmd})
+zapDemandInfo info = Just (info {demandInfo = boringTopDmd "zap"})
 
 -- | Remove usage (but not strictness) info on the 'IdInfo'
 zapUsageInfo :: IdInfo -> Maybe IdInfo
diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index e146c66c47..d277b8bd9f 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -381,7 +381,7 @@ mkDataConWorkId wkr_name data_con
                 `setUnfoldingInfo`   evaldUnfolding  -- Record that it's evaluated,
                                                      -- even if arity = 0
 
-    wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con)
+    wkr_sig = mkClosedStrictSig (replicate wkr_arity (boringTopDmd "dcon")) (dataConCPR data_con)
         --      Note [Data-con worker strictness]
         -- Notice that we do *not* say the worker is strict
         -- even if the data constructor is declared strict
@@ -493,7 +493,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
              wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
              wrap_arg_dmds = map mk_dmd arg_ibangs
              mk_dmd str | isBanged str = evalDmd
-                        | otherwise           = topDmd
+                        | otherwise    = boringTopDmd "dcon"
                  -- The Cpr info can be important inside INLINE rhss, where the
                  -- wrapper constructor isn't inlined.
                  -- And the argument strictness can be important too; we
@@ -971,7 +971,7 @@ mkFCallId dflags uniq fcall ty
 
     (bndrs, _) = tcSplitPiTys ty
     arity      = count isAnonTyBinder bndrs
-    strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes
+    strict_sig = mkClosedStrictSig (replicate arity (boringTopDmd "foreign")) topRes
     -- the call does not claim to be strict in its arguments, since they
     -- may be lifted (foreign import prim) and the called code doesn't
     -- necessarily force them. See Trac #11076.
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 8672273e90..492190bb82 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -291,7 +291,7 @@ mkRhsClosure    dflags bndr _cc _bi
     -- will evaluate to.
     --
     -- srt is discarded; it must be empty
-    let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
+    let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag) (isBoring upd_flag)
     in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]
 
 ---------- Note [Ap thunks] ------------------
@@ -411,7 +411,10 @@ cgRhsStdThunk bndr lf_info payload
        }
  where
  gen_code reg  -- AHA!  A STANDARD-FORM THUNK
-  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $
+  = withNewTickyCounterStdThunk
+        (lfUpdatable lf_info)
+        (lfBoring lf_info)
+        (idName bndr) $
     do
   {     -- LAY OUT THE OBJECT
     mod_name <- getModuleName
@@ -488,6 +491,7 @@ closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details _entry_ctr_o
   = withNewTickyCounterThunk
         (isStaticClosure cl_info)
         (closureUpdReqd cl_info)
+        (closureBoring cl_info)
         (closureName cl_info) $
     emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
       \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 7aa90ae28a..7d2842254e 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -24,7 +24,7 @@ module StgCmmClosure (
         mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
         mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
         lfDynTag,
-        maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable,
+        maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable, lfBoring,
 
         -- * Used by other modules
         CgLoc(..), SelfLoopInfo, CallMethod(..),
@@ -45,7 +45,7 @@ module StgCmmClosure (
 
         -- ** Predicates
         -- These are really just functions on LambdaFormInfo
-        closureUpdReqd, closureSingleEntry,
+        closureUpdReqd, closureBoring, closureSingleEntry,
         closureReEntrant, closureFunInfo,
         isToplevClosure,
 
@@ -157,6 +157,7 @@ data LambdaFormInfo
         TopLevelFlag
         !Bool           -- True <=> no free vars
         !Bool           -- True <=> updatable (i.e., *not* single-entry)
+        [String]        -- [] <=> boring
         StandardFormInfo
         !Bool           -- True <=> *might* be a function type
 
@@ -241,6 +242,7 @@ mkLFThunk thunk_ty top fvs upd_flag
   = ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )
     LFThunk top (null fvs)
             (isUpdatable upd_flag)
+            (isBoring upd_flag)
             NonStandardThunk
             (might_be_a_function thunk_ty)
 
@@ -261,15 +263,15 @@ mkConLFInfo :: DataCon -> LambdaFormInfo
 mkConLFInfo con = LFCon con
 
 -------------
-mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
-mkSelectorLFInfo id offset updatable
-  = LFThunk NotTopLevel False updatable (SelectorThunk offset)
+mkSelectorLFInfo :: Id -> Int -> Bool -> [String] -> LambdaFormInfo
+mkSelectorLFInfo id offset updatable boring
+  = LFThunk NotTopLevel False updatable boring (SelectorThunk offset)
         (might_be_a_function (idType id))
 
 -------------
 mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
 mkApLFInfo id upd_flag arity
-  = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
+  = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (isBoring upd_flag) (ApThunk arity)
         (might_be_a_function (idType id))
 
 -------------
@@ -366,7 +368,7 @@ lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
 lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd
 lfClosureType (LFCon con)                    = Constr (dataConTagZ con)
                                                     (dataConIdentity con)
-lfClosureType (LFThunk _ _ _ is_sel _)       = thunkClosureType is_sel
+lfClosureType (LFThunk _ _ _ _ is_sel _)     = thunkClosureType is_sel
 lfClosureType _                              = panic "lfClosureType"
 
 thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
@@ -394,7 +396,7 @@ nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _)
         -- non-inherited (i.e. non-top-level) function.
         -- The isNotTopLevel test above ensures this is ok.
 
-nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _)
+nodeMustPointToIt dflags (LFThunk top no_fvs updatable _boring NonStandardThunk _)
   =  not no_fvs            -- Self parameter
   || isNotTopLevel top     -- Note [GC recovery]
   || updatable             -- Need to push update frame
@@ -537,7 +539,7 @@ getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info
     -- n_args=0 because it'd be ill-typed to apply a saturated
     --          constructor application to anything
 
-getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)
+getCallMethod dflags name id (LFThunk _ _ updatable _ std_form_info is_fun)
               n_args _v_args _cg_loc _self_loop_info
   | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)
   = SlowCall    -- We cannot just enter it [in eval/apply, the entry code
@@ -768,7 +770,7 @@ blackHoleOnEntry cl_info
   = case closureLFInfo cl_info of
       LFReEntrant {}            -> False
       LFLetNoEscape             -> False
-      LFThunk _ _no_fvs upd _ _ -> upd   -- See Note [Black-holing non-updatable thunks]
+      LFThunk _ _no_fvs upd _ _ _ -> upd   -- See Note [Black-holing non-updatable thunks]
       _other -> panic "blackHoleOnEntry"
 
 {- Note [Black-holing non-updatable thunks]
@@ -844,12 +846,19 @@ isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
 closureUpdReqd :: ClosureInfo -> Bool
 closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
 
+closureBoring :: ClosureInfo -> [String]
+closureBoring ClosureInfo{ closureLFInfo = lf_info } = lfBoring lf_info
+
 lfUpdatable :: LambdaFormInfo -> Bool
-lfUpdatable (LFThunk _ _ upd _ _)  = upd
+lfUpdatable (LFThunk _ _ upd _ _ _)  = upd
 lfUpdatable _ = False
 
+lfBoring :: LambdaFormInfo -> [String]
+lfBoring (LFThunk _ _ _ bor _ _)  = bor
+lfBoring _ = []
+
 closureSingleEntry :: ClosureInfo -> Bool
-closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
+closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _ _}) = not upd
 closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True
 closureSingleEntry _ = False
 
@@ -872,7 +881,7 @@ isToplevClosure :: ClosureInfo -> Bool
 isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
   = case lf_info of
       LFReEntrant TopLevel _ _ _ _ -> True
-      LFThunk TopLevel _ _ _ _     -> True
+      LFThunk TopLevel _ _ _ _ _   -> True
       _other                       -> False
 
 --------------------------------------
@@ -893,10 +902,10 @@ closureLocalEntryLabel dflags
 mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel
 mkClosureInfoTableLabel id lf_info
   = case lf_info of
-        LFThunk _ _ upd_flag (SelectorThunk offset) _
+        LFThunk _ _ upd_flag _ (SelectorThunk offset) _
                       -> mkSelectorInfoLabel upd_flag offset
 
-        LFThunk _ _ upd_flag (ApThunk arity) _
+        LFThunk _ _ upd_flag _ (ApThunk arity) _
                       -> mkApInfoTableLabel upd_flag arity
 
         LFThunk{}     -> std_mk_lbl name cafs
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index 020d76900a..3d3ea4a4ec 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -151,6 +151,7 @@ data TickyClosureType
     | TickyCon
     | TickyThunk
         Bool -- True <-> updateable
+        [String] -- Why updateable?
         Bool -- True <-> standard thunk (AP or selector), has no entry counter
     | TickyLNE
 
@@ -165,25 +166,27 @@ withNewTickyCounterLNE nm args code = do
 withNewTickyCounterThunk
   :: Bool -- ^ static
   -> Bool -- ^ updateable
+  -> [String] -- ^ manyReasons
   -> Name
   -> FCode a
   -> FCode a
-withNewTickyCounterThunk isStatic isUpdatable name code = do
+withNewTickyCounterThunk isStatic isUpdatable isBoring name code = do
     b <- tickyDynThunkIsOn
     if isStatic || not b -- ignore static thunks
       then code
-      else withNewTickyCounter (TickyThunk isUpdatable False) name [] code
+      else withNewTickyCounter (TickyThunk isUpdatable isBoring False) name [] code
 
 withNewTickyCounterStdThunk
   :: Bool -- ^ updateable
+  -> [String] -- ^ manyReasons
   -> Name
   -> FCode a
   -> FCode a
-withNewTickyCounterStdThunk isUpdatable name code = do
+withNewTickyCounterStdThunk isUpdatable isBoring name code = do
     b <- tickyDynThunkIsOn
     if not b
       then code
-      else withNewTickyCounter (TickyThunk isUpdatable True) name [] code
+      else withNewTickyCounter (TickyThunk isUpdatable isBoring True) name [] code
 
 withNewTickyCounterCon
   :: Name
@@ -219,10 +222,14 @@ emitTickyCounter cloType name args
                 let n = ppr name
                     ext = case cloType of
                               TickyFun single_entry -> parens $ hcat $ punctuate comma $
-                                  [text "fun"] ++ [text "se"|single_entry]
+                                  [text "fun"] ++
+                                  [text "se"|single_entry]
                               TickyCon -> parens (text "con")
-                              TickyThunk upd std -> parens $ hcat $ punctuate comma $
-                                  [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std]
+                              TickyThunk upd mr std -> parens $ hcat $ punctuate comma $
+                                  [text "thk"] ++
+                                  [text "se"|not upd] ++
+                                  (if null mr then [] else [ parens $ hcat $ punctuate comma $ map text mr]) ++
+                                  [text "std"|std]
                               TickyLNE | isInternalName name -> parens (text "LNE")
                                        | otherwise -> panic "emitTickyCounter: how is this an external LNE?"
                     p = case hasHaskellName parent of
diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs
index ef87656a0e..ca2001f117 100644
--- a/compiler/coreSyn/CoreArity.hs
+++ b/compiler/coreSyn/CoreArity.hs
@@ -141,7 +141,7 @@ exprBotStrictness_maybe e
         Just ar -> Just (ar, sig ar)
   where
     env    = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False }
-    sig ar = mkClosedStrictSig (replicate ar topDmd) exnRes
+    sig ar = mkClosedStrictSig (replicate ar (boringTopDmd "exprBotStrictness")) exnRes
                   -- For this purpose we can be very simple
                   -- exnRes is a bit less aggressive than botRes
 
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 320a98992c..700de62b01 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -392,7 +392,7 @@ cpeBind top_lvl env (NonRec bndr rhs)
 cpeBind top_lvl env (Rec pairs)
   = do { let (bndrs,rhss) = unzip pairs
        ; (env', bndrs1) <- cpCloneBndrs env (map fst pairs)
-       ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') bndrs1 rhss
+       ; stuff <- zipWithM (cpePair top_lvl Recursive (boringTopDmd "cpe") False env') bndrs1 rhss
 
        ; let (floats_s, bndrs2, rhss2) = unzip3 stuff
              all_pairs = foldrOL add_float (bndrs2 `zip` rhss2)
@@ -424,7 +424,7 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
                else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
                                -- Note [Silly extra arguments]
                     (do { v <- newVar (idType bndr)
-                        ; let float = mkFloat topDmd False v rhs2
+                        ; let float = mkFloat (boringTopDmd "cpe") False v rhs2
                         ; return ( addFloat floats2 float
                                  , cpeEtaExpand arity (Var v)) })
 
@@ -713,9 +713,9 @@ cpeApp env expr
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
            ; let (ss1, ss_rest)  -- See Note [lazyId magic] in MkId
                     = case (ss, isLazyExpr arg) of
-                        (_   : ss_rest, True)  -> (topDmd, ss_rest)
+                        (_   : ss_rest, True)  -> ((boringTopDmd "cpe"), ss_rest)
                         (ss1 : ss_rest, False) -> (ss1,    ss_rest)
-                        ([],            _)     -> (topDmd, [])
+                        ([],            _)     -> ((boringTopDmd "cpe"), [])
                  (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
                                     splitFunTy_maybe fun_ty
 
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index bfeb7852c6..55d66081f2 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -61,7 +61,7 @@ defaults
    can_fail         = False   -- See Note Note [PrimOp can_fail and has_side_effects] in PrimOp
    commutable       = False
    code_size        = { primOpCodeSizeDefault }
-   strictness       = { \ arity -> mkClosedStrictSig (replicate arity topDmd) topRes }
+   strictness       = { \ arity -> mkClosedStrictSig (replicate arity (boringTopDmd "primop")) topRes }
    fixity           = Nothing
    llvm_only        = False
    vector           = []
@@ -1963,7 +1963,7 @@ primop  CatchOp "catch#" GenPrimOp
    with
    strictness  = { \ _arity -> mkClosedStrictSig [ catchArgDmd
                                                  , lazyApply2Dmd
-                                                 , topDmd] topRes }
+                                                 , (boringTopDmd "primop")] topRes }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True
@@ -1972,7 +1972,7 @@ primop  RaiseOp "raise#" GenPrimOp
    b -> o
       -- NB: the type variable "o" is "a", but with OpenKind
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [topDmd] exnRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [(boringTopDmd "primop")] exnRes }
       -- NB: result is ThrowsExn
    out_of_line = True
    has_side_effects = True
@@ -1994,7 +1994,7 @@ primop  RaiseOp "raise#" GenPrimOp
 primop  RaiseIOOp "raiseIO#" GenPrimOp
    a -> State# RealWorld -> (# State# RealWorld, b #)
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [topDmd, topDmd] exnRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [(boringTopDmd "primop"), (boringTopDmd "primop")] exnRes }
    out_of_line = True
    has_side_effects = True
 
@@ -2002,7 +2002,7 @@ primop  MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp
         (State# RealWorld -> (# State# RealWorld, a #))
      -> (State# RealWorld -> (# State# RealWorld, a #))
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,(boringTopDmd "primop")] topRes }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True
@@ -2011,7 +2011,7 @@ primop  MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp
         (State# RealWorld -> (# State# RealWorld, a #))
      -> (State# RealWorld -> (# State# RealWorld, a #))
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,(boringTopDmd "primop")] topRes }
    out_of_line = True
    has_side_effects = True
 
@@ -2019,7 +2019,7 @@ primop  UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp
         (State# RealWorld -> (# State# RealWorld, a #))
      -> (State# RealWorld -> (# State# RealWorld, a #))
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,(boringTopDmd "primop")] topRes }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True
@@ -2040,7 +2040,7 @@ primop  AtomicallyOp "atomically#" GenPrimOp
       (State# RealWorld -> (# State# RealWorld, a #) )
    -> State# RealWorld -> (# State# RealWorld, a #)
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,(boringTopDmd "primop")] topRes }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True
@@ -2058,7 +2058,7 @@ primop  AtomicallyOp "atomically#" GenPrimOp
 primop  RetryOp "retry#" GenPrimOp
    State# RealWorld -> (# State# RealWorld, a #)
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [topDmd] botRes }
+   strictness  = { \ _arity -> mkClosedStrictSig [(boringTopDmd "primop")] botRes }
    out_of_line = True
    has_side_effects = True
 
@@ -2069,7 +2069,7 @@ primop  CatchRetryOp "catchRetry#" GenPrimOp
    with
    strictness  = { \ _arity -> mkClosedStrictSig [ catchArgDmd
                                                  , lazyApply1Dmd
-                                                 , topDmd ] topRes }
+                                                 , (boringTopDmd "primop") ] topRes }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True
@@ -2081,7 +2081,7 @@ primop  CatchSTMOp "catchSTM#" GenPrimOp
    with
    strictness  = { \ _arity -> mkClosedStrictSig [ catchArgDmd
                                                  , lazyApply2Dmd
-                                                 , topDmd ] topRes }
+                                                 , (boringTopDmd "primop") ] topRes }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True
@@ -2945,7 +2945,7 @@ primop PrefetchAddrOp3 "prefetchAddr3#" GenPrimOp
 
 primop PrefetchValueOp3 "prefetchValue3#" GenPrimOp
    a -> State# s -> State# s
-   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes }
+   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, (boringTopDmd "primop")] topRes }
         has_side_effects =  True
 ----
 
@@ -2963,7 +2963,7 @@ primop PrefetchAddrOp2 "prefetchAddr2#" GenPrimOp
 
 primop PrefetchValueOp2 "prefetchValue2#" GenPrimOp
    a ->  State# s -> State# s
-   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes }
+   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, (boringTopDmd "primop")] topRes }
         has_side_effects =  True
 ----
 
@@ -2981,7 +2981,7 @@ primop PrefetchAddrOp1 "prefetchAddr1#" GenPrimOp
 
 primop PrefetchValueOp1 "prefetchValue1#" GenPrimOp
    a -> State# s -> State# s
-   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes }
+   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, (boringTopDmd "primop")] topRes }
         has_side_effects =  True
 ----
 
@@ -2999,7 +2999,7 @@ primop PrefetchAddrOp0 "prefetchAddr0#" GenPrimOp
 
 primop PrefetchValueOp0 "prefetchValue0#" GenPrimOp
    a -> State# s -> State# s
-   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes }
+   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, (boringTopDmd "primop")] topRes }
         has_side_effects =  True
 
 ------------------------------------------------------------------------
diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs
index 2c72266ad6..0dc87fb40a 100644
--- a/compiler/simplStg/StgStats.hs
+++ b/compiler/simplStg/StgStats.hs
@@ -133,7 +133,7 @@ statRhs top (_, StgRhsClosure _ _ fv u _ body)
     countOne (
       case u of
         ReEntrant   -> ReEntrantBinds   top
-        Updatable   -> UpdatableBinds   top
+        Updatable _ -> UpdatableBinds   top
         SingleEntry -> SingleEntryBinds top
     )
 
diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs
index 00c68535f3..6edd930c1f 100644
--- a/compiler/specialise/SpecConstr.hs
+++ b/compiler/specialise/SpecConstr.hs
@@ -1698,7 +1698,7 @@ calcSpecStrictness fn qvars pats
     go env _      _                = env
 
     go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv
-    go_one env d   (Var v) = extendVarEnv_C bothDmd env v d
+    go_one env d   (Var v) = extendVarEnv_C (bothDmd "spec") env v d
     go_one env d e
            | Just ds <- splitProdDmd_maybe d  -- NB: d does not have to be strict
            , (Var _, args) <- collectArgs e = go env ds args
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index 273cbdb9c1..4ab1b88fd0 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -41,7 +41,7 @@ import FastString
 import Util
 import DynFlags
 import ForeignCall
-import Demand           ( isUsedOnce )
+import Demand           ( isUsedOnce, isBoringDemand )
 import PrimOp           ( PrimCall(..) )
 
 import Data.Maybe    (isJust)
@@ -780,7 +780,7 @@ mkStgRhs' con_updateable rhs_fvs bndr binder_info rhs
     (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
 
     upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
-             | otherwise                      = Updatable
+             | otherwise                      = Updatable (isBoringDemand (idDemandInfo bndr))
 
   {-
     SDM: disabled.  Eval/Apply can't handle functions with arity zero very
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index f3a02c83aa..e65afe30ff 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -18,7 +18,7 @@ module StgSyn (
         GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
         GenStgAlt, AltType(..),
 
-        UpdateFlag(..), isUpdatable,
+        UpdateFlag(..), isUpdatable, isBoring,
 
         StgBinderInfo,
         noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly,
@@ -575,18 +575,24 @@ closure will only be entered once, and so need not be updated but may
 safely be blackholed.
 -}
 
-data UpdateFlag = ReEntrant | Updatable | SingleEntry
+-- Bool: True <=> Boring
+data UpdateFlag = ReEntrant | Updatable [String] | SingleEntry
 
 instance Outputable UpdateFlag where
     ppr u = char $ case u of
                        ReEntrant   -> 'r'
-                       Updatable   -> 'u'
+                       Updatable _ -> 'u'
                        SingleEntry -> 's'
 
 isUpdatable :: UpdateFlag -> Bool
 isUpdatable ReEntrant   = False
 isUpdatable SingleEntry = False
-isUpdatable Updatable   = True
+isUpdatable (Updatable _)  = True
+
+isBoring :: UpdateFlag -> [String]
+isBoring ReEntrant   = []
+isBoring SingleEntry = []
+isBoring (Updatable b)  = b
 
 {-
 ************************************************************************
diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs
index 53144fff10..36fa450939 100644
--- a/compiler/stranal/DmdAnal.hs
+++ b/compiler/stranal/DmdAnal.hs
@@ -510,7 +510,7 @@ dmdFix top_lvl env orig_pairs
           = ((env', lazy_fv'), (id', rhs'))
           where
             (sig, lazy_fv1, id', rhs') = dmdAnalRhs top_lvl (Just bndrs) env id rhs
-            lazy_fv'                   = plusVarEnv_C bothDmd lazy_fv lazy_fv1
+            lazy_fv'                   = plusVarEnv_C (bothDmd "fix") lazy_fv lazy_fv1
             env'                       = extendAnalEnv top_lvl env id sig
 
     same_sig sigs sigs' var = lookup sigs var == lookup sigs' var
@@ -528,7 +528,7 @@ dmdAnalRhs :: TopLevelFlag
 dmdAnalRhs top_lvl rec_flag env id rhs
   | Just fn <- unpackTrivial rhs   -- See Note [Demand analysis for trivial right-hand sides]
   , let fn_str = getStrictness env fn
-        fn_fv | isLocalId fn = unitVarEnv fn topDmd
+        fn_fv | isLocalId fn = unitVarEnv fn (boringTopDmd "fn_fv")
               | otherwise    = emptyDmdEnv
         -- Note [Remember to demand the function itself]
         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -560,7 +560,7 @@ dmdAnalRhs top_lvl rec_flag env id rhs
     -- See Note [Lazy and unleashable free variables]
     -- See Note [Aggregated demand for cardinality]
     rhs_fv1 = case rec_flag of
-                Just bs -> reuseEnv (delVarEnvList rhs_fv bs)
+                Just bs -> reuseEnv "fix" (delVarEnvList rhs_fv bs)
                 Nothing -> rhs_fv
 
     (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1
@@ -641,12 +641,12 @@ unitDmdType :: DmdEnv -> DmdType
 unitDmdType dmd_env = DmdType dmd_env [] topRes
 
 coercionDmdEnv :: Coercion -> DmdEnv
-coercionDmdEnv co = mapVarEnv (const topDmd) (coVarsOfCo co)
+coercionDmdEnv co = mapVarEnv (const (boringTopDmd "coercion")) (coVarsOfCo co)
                     -- The VarSet from coVarsOfCo is really a VarEnv Var
 
 addVarDmd :: DmdType -> Var -> Demand -> DmdType
 addVarDmd (DmdType fv ds res) var dmd
-  = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res
+  = DmdType (extendVarEnv_C (bothDmd "dmdTransformFix") fv var dmd) ds res
 
 addLazyFVs :: DmdType -> DmdEnv -> DmdType
 addLazyFVs dmd_ty lazy_fvs
@@ -1057,7 +1057,7 @@ addDataConStrictness con ds
   where
     strs = dataConRepStrictness con
     add dmd str | isMarkedStrict str
-                , not (isAbsDmd dmd) = dmd `bothDmd` seqDmd
+                , not (isAbsDmd dmd) = bothDmd "strdatacon" dmd seqDmd
                 | otherwise          = dmd
 
 findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand])
diff --git a/compiler/stranal/WorkWrap.hs b/compiler/stranal/WorkWrap.hs
index 80d966b392..f22128ce85 100644
--- a/compiler/stranal/WorkWrap.hs
+++ b/compiler/stranal/WorkWrap.hs
@@ -405,7 +405,7 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs
             -- See Note [Demand on the Worker]
             single_call = saturatedByOneShots arity (demandInfo fn_info)
             worker_demand | single_call = mkWorkerDemand work_arity
-                          | otherwise   = topDmd
+                          | otherwise   = boringTopDmd "worker"
 
                                 -- arity is consistent with the demand type goes through