+    , alterLookupWithKey

+-- | \(O(\min(n,W))\). The expression (@'alterLookupWithKey' f k map@) alters

+-- the value @x@ at @k@, or absence thereof, and returns the result of the

+-- alteration. 'alterLookupWithKey' can be used to insert, delete, or update a

+-- value in a 'Word64Map'.

+--

+-- Note that the behavior of this function differs from 'updateLookupWithKey',

+-- and instead matches the behavior of 'Data.Map.updateLookupWithKey'.

+alterLookupWithKey :: (Maybe a -> Maybe a) -> Key -> Word64Map a -> (Maybe a, Word64Map a)

+alterLookupWithKey f !k t@(Bin p m l r)

+  | nomatch k p m =

+      case f Nothing of

+        Nothing -> (Nothing, t)

+        Just x -> (Just x, link k (Tip k x) p t)

+  | zero k m =

+      let !(res, l') = alterLookupWithKey f k l

+      in (res, binCheckLeft p m l' r)

+  | otherwise =

+      let !(res, r') = alterLookupWithKey f k r

+      in (res, binCheckRight p m l r')

+alterLookupWithKey f k t@(Tip ky y)

+  | k==ky =

+      case f (Just y) of

+        Just x -> (Just x, Tip ky x)

+        Nothing -> (Nothing, Nil)

+  | otherwise =

+      case f Nothing of

+        Just x -> (Just x, link k (Tip k x) ky t)

+        Nothing -> (Nothing, Tip ky y)

+alterLookupWithKey f k Nil =

+  case f Nothing of

+    Just x -> (Just x, Tip k x)

+    Nothing -> (Nothing, Nil)

+

+    , alterLookupWithKey

+  , stgDebug_distinctConstructorTables = distinctConstructorTables dflags

+import GHC.Stg.Debug.Types (StgDebugDctConfig(..))

+import qualified Data.Set as Set

+  cfgWeights            :: Weights,

+

+  -- | Configuration specifying which constructor names we should create

+  -- distinct info tables for

+  distinctConstructorTables :: StgDebugDctConfig

+        cfgWeights    = defaultWeights,

+

+        distinctConstructorTables = None

+import GHC.Stg.Debug.Types

+  , make_ord_flag defGhcFlag "fdistinct-constructor-tables"

+      (OptPrefix setDistinctConstructorTables)

+  , make_ord_flag defGhcFlag "fno-distinct-constructor-tables"

+      (OptPrefix unSetDistinctConstructorTables)

+setDistinctConstructorTables :: String -> DynP ()

+setDistinctConstructorTables arg = do

+  let cs = parseDistinctConstructorTablesArg arg

+  upd $ \d ->

+    d { distinctConstructorTables =

+        (distinctConstructorTables d) `dctConfigPlus` cs

+      }

+

+unSetDistinctConstructorTables :: String -> DynP ()

+unSetDistinctConstructorTables arg = do

+  let cs = parseDistinctConstructorTablesArg arg

+  upd $ \d ->

+    d { distinctConstructorTables =

+        (distinctConstructorTables d) `dctConfigMinus` cs

+      }

+

+-- | Parse a string of comma-separated constructor names into a 'Set' of

+-- 'String's with one entry per constructor.

+parseDistinctConstructorTablesArg :: String -> Set.Set String

+parseDistinctConstructorTablesArg =

+      -- Ensure we insert the last constructor name built by the fold, if not

+      -- empty

+      uncurry insertNonEmpty

+    . foldr go ("", Set.empty)

+  where

+    go :: Char -> (String, Set.Set String) -> (String, Set.Set String)

+    go ',' (cur, acc) = ("", Set.insert cur acc)

+    go c   (cur, acc) = (c : cur, acc)

+

+    insertNonEmpty :: String -> Set.Set String -> Set.Set String

+    insertNonEmpty "" = id

+    insertNonEmpty cs = Set.insert cs

+

+   , IfaceCodeGen(..)

+   , IfaceDistinctConstructorConfig(..)

+import qualified Data.Set as Set

+import GHC.Stg.Debug.Types

+        , ifaceCodeGen :: IfaceCodeGen

+       , nest 2 $ ppr a11

+             ]

+

+data IfaceCodeGen = IfaceCodeGen

+  { ifaceCodeGenFlags :: [IfaceGeneralFlag]

+  , ifaceCodeGenDistinctConstructorTables :: IfaceDistinctConstructorConfig

+  }

+

+instance NFData IfaceCodeGen where

+  rnf (IfaceCodeGen flags distinctCnstrTables) =

+    rnf flags `seq` rnf distinctCnstrTables

+

+instance Binary IfaceCodeGen where

+  put_ bh (IfaceCodeGen flags distinctCnstrTables) = do

+    put_ bh flags

+    put_ bh distinctCnstrTables

+

+  get bh =

+    IfaceCodeGen <$> get bh <*> get bh

+

+instance Outputable IfaceCodeGen where

+  ppr (IfaceCodeGen flags distinctCnstrTables) =

+    vcat

+      [ text "flags:"

+      , nest 2 $ ppr flags

+      , text "distinct constructor tables:"

+      , nest 2 $ ppr distinctCnstrTables

+      ]

+

+newtype IfaceDistinctConstructorConfig = IfaceDistinctConstructorConfig StgDebugDctConfig

+

+instance NFData IfaceDistinctConstructorConfig where

+  rnf (IfaceDistinctConstructorConfig cnf) = case cnf of

+    All -> ()

+    (Only v) -> rnf v

+    (AllExcept v) -> rnf v

+    None -> ()

+

+instance Outputable IfaceDistinctConstructorConfig where

+  ppr (IfaceDistinctConstructorConfig cnf) = case cnf of

+    All -> text "all"

+    (Only v) -> text "only" <+> brackets (hcat $ fmap text $ Set.toList v)

+    (AllExcept v) -> text "all except" <+> brackets (hcat $ fmap text $ Set.toList v)

+    None -> text "none"

+

+instance Binary IfaceDistinctConstructorConfig where

+  put_ bh (IfaceDistinctConstructorConfig cnf) = case cnf of

+    All -> putByte bh 0

+    (Only cs) -> do

+      putByte bh 1

+      put_ bh cs

+    (AllExcept cs) -> do

+      putByte bh 2

+      put_ bh cs

+    None -> putByte bh 3

+

+  get bh = do

+    h <- getByte bh

+    IfaceDistinctConstructorConfig <$>

+      case h of

+        0 -> pure All

+        1 -> Only <$> get bh

+        2 -> AllExcept <$> get bh

+        _ -> pure None

+        codegen = IfaceCodeGen

+          { ifaceCodeGenFlags = mapMaybe (\f -> (if f `gopt` dflags then Just (IfaceGeneralFlag f) else Nothing)) (EnumSet.toList codeGenFlags)

+          , ifaceCodeGenDistinctConstructorTables = IfaceDistinctConstructorConfig distinctConstructorTables

+          }

+        f = IfaceDynFlags

+          { ifaceMainIs = mainis

+          , ifaceSafeMode = safeHs

+          , ifaceLang = lang

+          , ifaceExts = exts

+          , ifaceCppOptions = cpp

+          , ifaceJsOptions = js

+          , ifaceCmmOptions = cmm

+          , ifacePaths = paths

+          , ifaceProf = prof

+          , ifaceTicky = ticky

+          , ifaceCodeGen = codegen

+          , ifaceFatIface = fat_iface

+          , ifaceDebugLevel = debugLevel

+          , ifaceCallerCCFilters = callerCcFilters

+          }

+{-# LANGUAGE RecordWildCards #-}

+{-# LANGUAGE TupleSections   #-}

+  , StgDebugDctConfig(..)

+  , dctConfigPlus

+  , dctConfigMinus

+import GHC.Types.Name   ( getName, getOccName, occNameFS, nameSrcSpan, occName, occNameString)

+import GHC.Stg.Debug.Types

+import qualified Data.Set as Set

+-- | If @-fdistinct-constructor-tables@ is enabled, each occurrence of a data

+-- constructor will be given its own info table

+  if shouldMakeDistinctTable opts dc then do

+    -- -fdistinct-constructor-tables is enabled and we do want to make distinct

+    -- tables for this constructor. Add an entry to the data constructor map for

+    -- this occurrence of the data constructor with a unique number and a src

+    -- span

+    let

+      -- Guess a src span for this occurrence using source note ticks and the

+      -- current span in the environment

+      !mbest_span = selectTick ts <|> (\(SpanWithLabel rss l) -> (rss, l)) <$> mcc

+

+      -- Add the occurrence to the data constructor map of the InfoTableProvMap,

+      -- noting the unique number assigned for this occurence

+      (!r, !dcMap') =

+        alterUDFM_L

+          ( maybe

+              (Just (dc, (0, mbest_span) :| [] ))

+              ( \(_dc, xs@((k, _):|_)) ->

+                  Just $! (dc, (k + 1, mbest_span) `NE.cons` xs)

+              )

+          )

+          (provDC env)

+          dc

+  else do

+    -- -fdistinct-constructor-tables is not enabled, or we do not want to make

+    -- distinct tables for this specific constructor

+    return NoNumber

+selectTick :: [StgTickish] -> Maybe (RealSrcSpan, LexicalFastString)

+selectTick = foldl' go Nothing

+  where

+    go :: Maybe (RealSrcSpan, LexicalFastString) -> StgTickish -> Maybe (RealSrcSpan, LexicalFastString)

+    go _   (SourceNote rss d) = Just (rss, d)

+    go acc _                  = acc

+

+-- | Descide whether a distinct info table should be made for a usage of a data

+-- constructor. We only want to do this if -fdistinct-constructor-tables was

+-- given and this constructor name was given, or no constructor names were

+-- given.

+shouldMakeDistinctTable :: StgDebugOpts -> DataCon -> Bool

+shouldMakeDistinctTable StgDebugOpts{..} dc =

+  case stgDebug_distinctConstructorTables of

+    All -> True

+    Only these -> Set.member dcStr these

+    AllExcept these -> Set.notMember dcStr these

+    None -> False

+  where

+    dcStr = occNameString . occName $ dataConName dc

+module GHC.Stg.Debug.Types where

+

+import GHC.Prelude

+

+import GHC.Data.FastString

+import GHC.Types.SrcLoc

+

+import Data.Set (Set)

+import qualified Data.Set as Set

+

+data SpanWithLabel = SpanWithLabel RealSrcSpan LexicalFastString

+

+data StgDebugOpts = StgDebugOpts

+  { stgDebug_infoTableMap              :: !Bool

+  , stgDebug_distinctConstructorTables :: !StgDebugDctConfig

+  }

+

+-- | Configuration describing which constructors should be given distinct info

+-- tables for each usage.

+data StgDebugDctConfig =

+    -- | Create distinct constructor tables for each usage of any data

+    -- constructor.

+    --

+    -- This is the behavior if just @-fdistinct-constructor-tables@ is supplied.

+    All

+

+    -- | Create distinct constructor tables for each usage of only these data

+    -- constructors.

+    --

+    -- This is the behavior if @-fdistinct-constructor-tables=C1,...,CN@ is

+    -- supplied.

+  | Only !(Set String)

+

+    -- | Create distinct constructor tables for each usage of any data

+    -- constructor except these ones.

+    --

+    -- This is the behavior if @-fdistinct-constructor-tables@ and

+    -- @-fno-distinct-constructor-tables=C1,...,CN@ is given.

+  | AllExcept !(Set String)

+

+    -- | Do not create distinct constructor tables for any data constructor.

+    --

+    -- This is the behavior if no @-fdistinct-constructor-tables@ is given (or

+    -- @-fno-distinct-constructor-tables@ is given).

+  | None

+

+-- | Given a distinct constructor tables configuration and a set of constructor

+-- names that we want to generate distinct info tables for, create a new

+-- configuration which includes those constructors.

+--

+-- If the given set is empty, that means the user has entered

+-- @-fdistinct-constructor-tables@ with no constructor names specified, and

+-- therefore we consider that an 'All' configuration.

+dctConfigPlus :: StgDebugDctConfig -> Set String -> StgDebugDctConfig

+dctConfigPlus cfg cs

+    | Set.null cs = All

+    | otherwise =

+        case cfg of

+          All -> All

+          Only cs' -> Only $ Set.union cs' cs

+          AllExcept cs' -> AllExcept $ Set.difference cs' cs

+          None -> Only cs

+

+-- | Given a distinct constructor tables configuration and a set of constructor

+-- names that we /do not/ want to generate distinct info tables for, create a

+-- new configuration which excludes those constructors.

+--

+-- If the given set is empty, that means the user has entered

+-- @-fno-distinct-constructor-tables@ with no constructor names specified, and

+-- therefore we consider that a 'None' configuration.

+dctConfigMinus :: StgDebugDctConfig -> Set String -> StgDebugDctConfig

+dctConfigMinus cfg cs

+    | Set.null cs = None

+    | otherwise =

+        case cfg of

+          All -> AllExcept cs

+          Only cs' -> Only $ Set.difference cs' cs

+          AllExcept cs' -> AllExcept $ Set.union cs' cs

+          None -> None

+

+        alterUDFM_L,

+-- | The expression (@'alterUDFM' f map k@) alters value x at k, or absence

+-- thereof. 'alterUDFM' can be used to insert, delete, or update a value in

+--

+-- 'alterUDFM' is non-strict in @k@.

+  => (Maybe elt -> Maybe elt)  -- ^ How to adjust the element

+  -> UniqDFM key elt           -- ^ Old 'UniqDFM'

+  -> key                       -- ^ @key@ of the element to adjust

+  -> UniqDFM key elt           -- ^ New element at @key@ and modified 'UniqDFM'

+-- | The expression (@'alterUDFM_L' f map k@) alters value @x@ at @k@, or absence

+-- thereof and returns the new element at @k@ if there is any.

+-- 'alterUDFM_L' can be used to insert, delete, or update a value in

+-- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are

+-- more efficient.

+--

+-- Note, 'alterUDFM_L' is strict in @k@.

+alterUDFM_L

+  :: forall key elt . Uniquable key

+  => (Maybe elt -> Maybe elt)      -- ^ How to adjust the element

+  -> UniqDFM key elt               -- ^ Old 'UniqDFM'

+  -> key                           -- ^ @key@ of the element to adjust

+  -> (Maybe elt, UniqDFM key elt)  -- ^ New element at @key@ and modified 'UniqDFM'

+alterUDFM_L f (UDFM m i) k =

+  let

+    -- Force the key Word64 as the thunk is almost never worth it.

+    !key = getKey $ getUnique k

+    (mElt, udfm) = M.alterF (dupe . alterf) key m

+  in

+    (mElt, UDFM udfm (i + 1))

+  where

+  dupe :: Maybe (TaggedVal elt) -> (Maybe elt, Maybe (TaggedVal elt))

+  dupe mt = (fmap taggedFst mt, mt)

+  alterf :: Maybe (TaggedVal elt) -> (Maybe (TaggedVal elt))

+  alterf Nothing = inject $ f Nothing

+  alterf (Just (TaggedVal v _)) = inject $ f (Just v)

+  inject Nothing = Nothing

+  inject (Just v) = Just $ TaggedVal v i

+

+        adjustUFM, alterUFM, alterUFM_L, alterUFM_Directly,

+alterUFM_L

+  :: Uniquable key

+  => (Maybe elt -> Maybe elt)    -- ^ How to adjust

+  -> UniqFM key elt              -- ^ old

+  -> key                         -- ^ new

+  -> (Maybe elt, UniqFM key elt) -- ^ result

+alterUFM_L f (UFM m) k =

+  let (r, m') = (M.alterLookupWithKey f (getKey $ getUnique k) m)

+  in (r, UFM m')

+

+    alterUniqMap_L,

+alterUniqMap_L :: Uniquable k

+             => (Maybe a -> Maybe a)

+             -> UniqMap k a

+             -> k

+             -> (Maybe a, UniqMap k a)

+alterUniqMap_L f (UniqMap m) k =

+  let (r, m') = alterUFM_L (fmap (k,) . f . fmap snd) m k

+  in (snd <$> r, UniqMap m')

+

+        GHC.Stg.Debug.Types

+    should also use :ghc-flag:`-fdistinct-constructor-tables

+    <-fdistinct-constructor-tables=⟨cs⟩>`.

+.. ghc-flag:: -fdistinct-constructor-tables=⟨cs⟩

+    :since: 9.16

+

+    The entries in the info table map resulting from this flag may significantly

+    increase the size of executables. However, generating distinct info tables

+    for *every* usage of *every* data constructor often results in more

+    information than necessary. Instead, we would like to generate these

+    distinct tables for some specific constructors. To do this, the names of the

+    constructors we are interested in may be supplied to this flag in a

+    comma-separated list. If no constructor names are supplied (i.e. just

+    ``-fdistinct-constructor-tables`` is given) then fresh info tables will be

+    generated for every usage of every constructor.

+

+    For example, to only generate distinct info tables for the ``Just`` and

+    ``Right`` constructors, use ``-fdistinct-constructor-tables=Just,Right``.

+

+.. ghc-flag:: -fno-distinct-constructor-tables=⟨cs⟩

+    :shortdesc: Avoid generating a fresh info table for each usage of a data

+                constructor.

+    :type: dynamic

+    :category: debugging

+

+    :since: 9.16

+

+    Use this flag to refine the set of data constructors for which distinct info

+    tables are generated (as specified by

+    :ghc-flag:`-fdistinct-constructor-tables

+    <-fdistinct-constructor-tables=⟨cs⟩>`).

+    If no constructor names are given

+    (i.e. just ``-fno-distinct-constructor-tables`` is given) then no distinct

+    info tables will be generated for any usages of any data constructors.

+

+    For example, to generate distinct constructor tables for all data

+    constructors except those named ``MyConstr``, pass both

+    ``-fdistinct-constructor-tables`` and

+    ``-fno-distinct-constructor-tables=MyConstr``.

+GHC.Stg.Debug.Types

+GHC.Stg.Debug.Types

+module Main where

+

+import GHC.InfoProv

+import qualified X

+

+main = do

+    printIp =<< whereFrom cafA1

+    printIp =<< whereFrom cafA2

+    printIp =<< whereFrom cafB1

+    printIp =<< whereFrom cafB2

+    printIp =<< whereFrom cafC1

+    printIp =<< whereFrom cafC2

+    printIp =<< whereFrom (ACon ())

+    printIp =<< whereFrom cafXA

+    printIp =<< whereFrom X.cafXA1

+    printIp =<< whereFrom X.cafXA2

+    printIp =<< whereFrom (X.ACon ())

+    printIp =<< whereFrom (BCon cafA1)

+    printIp =<< whereFrom (CCon (cafA1, BCon (ACon ())))

+  where

+    -- Get rid of the src file path since it makes test output difficult to diff

+    -- on Windows

+    printIp = print . stripIpSrc

+    stripIpSrc (Just ip) = ip { ipSrcFile = "" }

+

+data A = ACon ()

+data B = BCon A

+data C = CCon (A, B)

+

+cafA1 = ACon ()

+cafA2 = ACon ()

+cafB1 = BCon cafA1

+cafB2 = BCon cafA2

+cafC1 = CCon (cafA1, cafB1)

+cafC2 = CCon (cafA2, cafB2)

+

+cafXA = X.ACon ()

+TOP=../../../..

+include $(TOP)/mk/boilerplate.mk

+include $(TOP)/mk/test.mk

+

+# This test runs ghc with various combinations of

+# -f{no-}distinct-constructor-tables for different constructors and checks that

+# whereFrom finds (or fails to find) their provenance appropriately.

+

+distinct_tables01:

+	@$$TEST_HC $$TEST_HC_OPTS -v0 -finfo-table-map -fdistinct-constructor-tables=ACon Main.hs && ./Main

+

+distinct_tables02:

+	@$$TEST_HC $$TEST_HC_OPTS -v0 -finfo-table-map -fdistinct-constructor-tables=BCon Main.hs && ./Main

+

+distinct_tables03:

+	@$$TEST_HC $$TEST_HC_OPTS -v0 -finfo-table-map -fdistinct-constructor-tables=CCon Main.hs && ./Main

+

+distinct_tables04:

+	@$$TEST_HC $$TEST_HC_OPTS -v0 -finfo-table-map -fdistinct-constructor-tables=ACon,BCon Main.hs && ./Main