diff options
| -rw-r--r-- | compiler/GHC/Stg/Debug.hs | 30 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Utils.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Types/IPE.hs | 4 |
3 files changed, 17 insertions, 22 deletions
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 |