[Git][ghc/ghc][master] Ensure unconstrained instance dictionaries get IPE info

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
69abb171 by Finley McIlwaine at 2023-10-06T14:06:28-07:00
Ensure unconstrained instance dictionaries get IPE info

In the `StgRhsCon` case of `GHC.Stg.Debug.collectStgRhs`, we were not coming up
with an initial source span based on the span of the binder, which was causing
instance dictionaries without dynamic superclass constraints to not have source
locations in their IPE info. Now they do.

Resolves #24005

- - - - -


4 changed files:

- compiler/GHC/Stg/Debug.hs
- + testsuite/tests/rts/ipe/T24005/all.T
- + testsuite/tests/rts/ipe/T24005/t24005.hs
- + testsuite/tests/rts/ipe/T24005/t24005.stdout


Changes:

=====================================
compiler/GHC/Stg/Debug.hs
=====================================
@@ -68,21 +68,25 @@ collectStgBind (StgRec pairs) = do
     return (StgRec es)
 
 collectStgRhs :: Id -> StgRhs -> M StgRhs
-collectStgRhs bndr (StgRhsClosure ext cc us bs e t) = do
-  let
-    name = idName bndr
-    -- If the name has a span, use that initially as the source position in-case
-    -- we don't get anything better.
-    with_span = case nameSrcSpan name of
-                  RealSrcSpan pos _ -> withSpan (pos, LexicalFastString $ occNameFS (getOccName name))
-                  _ -> id
-  e' <- with_span $ collectExpr e
-  recordInfo bndr e'
-  return $ StgRhsClosure ext cc us bs e' t
-collectStgRhs _bndr (StgRhsCon cc dc _mn ticks args typ) = do
-  n' <- numberDataCon dc ticks
-  return (StgRhsCon cc dc n' ticks args typ)
-
+collectStgRhs bndr rhs =
+    case rhs of
+      StgRhsClosure ext cc us bs e t -> do
+        e' <- with_span $ collectExpr e
+        recordInfo bndr e'
+        return $ StgRhsClosure ext cc us bs e' t
+      StgRhsCon cc dc _mn ticks args typ -> do
+        n' <- with_span $ numberDataCon dc ticks
+        return (StgRhsCon cc dc n' ticks args typ)
+  where
+    -- If the binder name has a span, use that initially as the source position
+    -- in case we don't get anything better
+    with_span :: M a -> M a
+    with_span =
+      let name = idName bndr in
+      case nameSrcSpan name of
+        RealSrcSpan pos _ ->
+          withSpan (pos, LexicalFastString $ occNameFS (getOccName name))
+        _ -> id
 
 recordInfo :: Id -> StgExpr -> M ()
 recordInfo bndr new_rhs = do


=====================================
testsuite/tests/rts/ipe/T24005/all.T
=====================================
@@ -0,0 +1 @@
+test('t24005', [ js_skip ], compile_and_run, ['-finfo-table-map -fdistinct-constructor-tables'])


=====================================
testsuite/tests/rts/ipe/T24005/t24005.hs
=====================================
@@ -0,0 +1,36 @@
+{-# LANGUAGE AllowAmbiguousTypes  #-}
+
+module Main where
+
+import GHC.InfoProv
+import Unsafe.Coerce
+
+-- Boilerplate to help us access the literal dictionaries
+
+data Dict c where
+    Dict :: forall c. c => Dict c
+
+data Box where
+    Box :: forall a. a -> Box
+
+mkBox :: forall a. a => Box
+mkBox = unsafeCoerce (Dict @a)
+
+-- Interesting bit
+
+data A = A
+data B a = B a
+
+-- Becomes a `StgRhsCon`, which used to not get IPE estimate based on Name
+instance Show A where
+  show = undefined
+
+-- Becomes a `StgRhsClosure`, which does get IPE estimate based on Name
+instance Show a => Show (B a) where
+  show = undefined
+
+main :: IO ()
+main = do
+    -- Should both result in InfoProvs with correct source locations
+    (\(Box d) -> print =<< whereFrom d) $ mkBox @(Show A)
+    (\(Box d) -> print =<< whereFrom d) $ mkBox @(Show (B A))


=====================================
testsuite/tests/rts/ipe/T24005/t24005.stdout
=====================================
@@ -0,0 +1,2 @@
+Just (InfoProv {ipName = "C:Show_Main_1_con_info", ipDesc = "1", ipTyDesc = "Show", ipLabel = "$fShowA", ipMod = "Main", ipSrcFile = "t24005.hs", ipSrcSpan = "25:10-15"})
+Just (InfoProv {ipName = "C:Show_Main_0_con_info", ipDesc = "1", ipTyDesc = "Show", ipLabel = "$fShowB", ipMod = "Main", ipSrcFile = "t24005.hs", ipSrcSpan = "29:10-29"})



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/69abb1714ade3059593297f3a5faec4c07d1f984

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/69abb1714ade3059593297f3a5faec4c07d1f984
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231007/978e1195/attachment-0001.html>