What is the simplest way to determine which call to a superfunction has generated a Message?

Question

I have a complicated function which contains many calls to NIntegrate, NSolve, FindRoot and other superfunctions in many places. My function is organized in such a way that every call to a superfunction is assigned to unique Blocked variable. Sometimes these functions produce Messages but it is not obvious which call has generated the message. I wish to find a straighforward way to know which call has generated the message. It would be great to include this information in the Message itself but just printing this information before/after the Message would be sufficient.

I know that there is undocumented function Internal`HandlerBlock which seemingly can do such tasks but I do not know how to restrict it to handle only printed messages.

For example,

Internal`HandlerBlock[{"Message", 
  If[MatchQ[#, Hold[_, True]], Print[#]] &}, 
 NIntegrate[Cos[20000 x]/Sqrt[x], {x, 0, 1}]]

Produces many prints but only one of them corresponds to the actually printed one Message.

Answer 1

Following R.M's suggestion, and shamelessly lifting code from the Wizard’s fine answer there, you can use Stack[] and get the following:

SetAttributes[withTaggedMsg, HoldAll]
withTaggedMsg[] := 
 Function[, 
  Internal`InheritedBlock[{MessagePacket}, Unprotect[MessagePacket];
   MessagePacket[name__, BoxData[obj_, form_]] /; ! TrueQ[$tagMsg] := 
    Block[{$tagMsg = True}, 
     Identity@
      MessagePacket[name, 
       BoxData[RowBox[{ToBoxes@
           Style[Row[{"With stack", Stack[][[3 ;;]], Spacer[5]}, " "],
             Black], obj}], form]]];
   #], HoldAll]

Answer 2

Finding F'x's answer a bit hard to comprehend (mainly because I'm not used to working with BoxData nor MessagePacket, but also since I didn't understand why identity was necessary there, I produced the following, which also has the advantage of producing a more useful (imho) stack, i.e. with the parameters and user defined functions printed as well, and the part of the stack that comes from the observation removed. I should note though F'x's method can easily be adapted to do the same.

ClearAll[withStackTraces];
SetAttributes[withStackTraces, HoldFirst];
withStackTraces::Stack = "Stack is: `1`";

withStackTraces[code_] := Internal`InheritedBlock[{Message},
  Unprotect[Message];

  Module[{inside, temp}, 
   Message[x___] /; ! TrueQ[inside] := 
    Block[{inside = True}, temp = List[x][[1]];
     If[! temp === $Off[],
      Message[x];
      Internal`InheritedBlock[{$MessagePrePrint},
       Unset[$MessagePrePrint];
       Message[withStackTraces::Stack, 
        ToString[Stack[__][[4 ;; -11]], StandardForm]]]]]];

  StackComplete@code
  ]

I started out with printing the stack but it turns out that the same message gets called several times before actually getting printed (I'm guessing that by some catch and rethrow mechanism) and so I got multiple outputs. This way, there is only one extra message generated. Comparison of output for both methods: