From f943edb0c40d20e1330450c3e148b8d0c877eded Mon Sep 17 00:00:00 2001
From: Matthew Pickering <matthewtpickering@gmail.com>
Date: Fri, 5 Feb 2021 17:38:33 +0000
Subject: IPE: Give all constructor and function tables locations

During testing it was observed that quite a few info tables were not
being given locations (due to not being assigned source locations,
because they were not enclosed by a source note). We can at least give
the module name and type for such closures even if no more accurate
source information.

Especially for constructors this helps find them in the STG dumps.
---
 compiler/GHC/Stg/Debug.hs      | 30 ++++++++++++------------------
 compiler/GHC/StgToCmm/Utils.hs |  5 +++--
 compiler/GHC/Types/IPE.hs      |  4 ++--
 3 files changed, 17 insertions(+), 22 deletions(-)

(limited to 'compiler/GHC')

diff --git a/compiler/GHC/Stg/Debug.hs b/compiler/GHC/Stg/Debug.hs
index 823334e2aa..0fea7a0d72 100644
--- a/compiler/GHC/Stg/Debug.hs
+++ b/compiler/GHC/Stg/Debug.hs
@@ -133,10 +133,8 @@ recordStgIdPosition id best_span ss = do
     cc <- asks rSpan
     --Useful for debugging why a certain Id gets given a certain span
     --pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr best_span $$ ppr ss)
-    case best_span <|> cc <|> ss of
-      Nothing -> return ()
-      Just (SpanWithLabel rss d) ->
-        lift $ modify (\env -> env { provClosure = addToUniqMap (provClosure env) (idName id) (idType id, rss, d)})
+    let mbspan = (\(SpanWithLabel rss d) -> (rss, d)) <$> (best_span <|> cc <|> ss)
+    lift $ modify (\env -> env { provClosure = addToUniqMap (provClosure env) (idName id) (idType id, mbspan) })
 
 numberDataCon :: DataCon -> [Tickish Id] -> M ConstructorNumber
 -- Unboxed tuples and sums do not allocate so they
@@ -146,20 +144,16 @@ numberDataCon dc _ | isUnboxedSumDataCon dc = return NoNumber
 numberDataCon dc ts = do
   dflags <- asks rDynFlags
   if not (gopt Opt_DistinctConstructorTables dflags) then return NoNumber else do
-          env <- lift get
-          mcc <- asks rSpan
-          let mbest_span = selectTick ts <|> mcc
-          case mbest_span of
-            Nothing -> return NoNumber
-            Just (SpanWithLabel rss l) -> do
-              let best_span = (rss, l)
-              let dcMap' = alterUniqMap (maybe (Just ((0, best_span) :| [] ))
-                                  (\xs@((k, _):|_) -> Just ((k + 1, best_span) `NE.cons` xs))) (provDC env) dc
-              lift $ put (env { provDC = dcMap' })
-              let r = lookupUniqMap dcMap' dc
-              return $ case r of
-                Nothing -> NoNumber
-                Just res -> Numbered (fst (NE.head res))
+    env <- lift get
+    mcc <- asks rSpan
+    let mbest_span = (\(SpanWithLabel rss l) -> (rss, l)) <$> (selectTick ts <|> mcc)
+    let dcMap' = alterUniqMap (maybe (Just ((0, mbest_span) :| [] ))
+                        (\xs@((k, _):|_) -> Just ((k + 1, mbest_span) `NE.cons` xs))) (provDC env) dc
+    lift $ put (env { provDC = dcMap' })
+    let r = lookupUniqMap dcMap' dc
+    return $ case r of
+      Nothing -> NoNumber
+      Just res -> Numbered (fst (NE.head res))
 
 selectTick :: [Tickish Id] -> Maybe SpanWithLabel
 selectTick [] = Nothing
diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs
index 8472711753..86d8a8d842 100644
--- a/compiler/GHC/StgToCmm/Utils.hs
+++ b/compiler/GHC/StgToCmm/Utils.hs
@@ -96,6 +96,7 @@ import qualified Data.List.NonEmpty as NE
 import GHC.Core.DataCon
 import GHC.Types.Unique.FM
 import GHC.Data.Maybe
+import Control.Monad
 
 -------------------------------------------------------------------------
 --
@@ -662,7 +663,7 @@ convertInfoProvMap dflags defns this_mod (InfoTableProvMap (UniqMap dcenv) denv)
 
         lookupClosureMap :: Maybe InfoProvEnt
         lookupClosureMap = case hasHaskellName cl >>= lookupUniqMap denv of
-                                Just (ty, ss, l) -> Just (InfoProvEnt cl cn (tyString ty) this_mod (Just (ss, l)))
+                                Just (ty, mbspan) -> Just (InfoProvEnt cl cn (tyString ty) this_mod mbspan)
                                 Nothing -> Nothing
 
         lookupDataConMap = do
@@ -670,7 +671,7 @@ convertInfoProvMap dflags defns this_mod (InfoTableProvMap (UniqMap dcenv) denv)
             -- This is a bit grimy, relies on the DataCon and Name having the same Unique, which they do
             (dc, ns) <- (hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique)
             -- Lookup is linear but lists will be small (< 100)
-            return $ InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (lookup n (NE.toList ns))
+            return $ InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns))
 
         -- This catches things like prim closure types and anything else which doesn't have a
         -- source location
diff --git a/compiler/GHC/Types/IPE.hs b/compiler/GHC/Types/IPE.hs
index 2f4f0b35b4..c69aeb004a 100644
--- a/compiler/GHC/Types/IPE.hs
+++ b/compiler/GHC/Types/IPE.hs
@@ -14,7 +14,7 @@ import Data.List.NonEmpty
 -- | A map from a 'Name' to the best approximate source position that
 -- name arose from.
 type ClosureMap = UniqMap Name  -- The binding
-                          (Type, RealSrcSpan, String)
+                          (Type, Maybe (RealSrcSpan, String))
                           -- The best approximate source position.
                           -- (rendered type, source position, source note
                           -- label)
@@ -26,7 +26,7 @@ type ClosureMap = UniqMap Name  -- The binding
 -- the constructor was used at, if possible and a string which names
 -- the source location. This is the same information as is the payload
 -- for the 'GHC.Core.SourceNote' constructor.
-type DCMap = UniqMap DataCon (NonEmpty (Int, (RealSrcSpan, String)))
+type DCMap = UniqMap DataCon (NonEmpty (Int, Maybe (RealSrcSpan, String)))
 
 data InfoTableProvMap = InfoTableProvMap
                           { provDC :: DCMap
-- 
cgit v1.2.1