[Git][ghc/ghc][wip/con-info] Also store closure labels
Matthew Pickering
gitlab at gitlab.haskell.org
Fri May 29 16:47:40 UTC 2020
Matthew Pickering pushed to branch wip/con-info at Glasgow Haskell Compiler / GHC
Commits:
d28a579a by Matthew Pickering at 2020-05-29T17:46:48+01:00
Also store closure labels
- - - - -
8 changed files:
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Hooks.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Utils.hs
- compiler/GHC/Types/CostCentre.hs
- compiler/GHC/Types/SrcLoc.hs
Changes:
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, DeriveFunctor #-}
+{-# LANGUAGE CPP, DeriveFunctor, TupleSections #-}
--
-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
@@ -33,7 +33,7 @@ import GHC.Core.DataCon
import GHC.Types.CostCentre
import GHC.Types.Var.Env
import GHC.Unit.Module
-import GHC.Types.Name ( isExternalName, nameModule_maybe )
+import GHC.Types.Name ( getName, getOccName, occNameString, nameSrcSpan, isExternalName, nameModule_maybe )
import GHC.Types.Basic ( Arity )
import GHC.Builtin.Types ( unboxedUnitDataCon, unitDataConId )
import GHC.Types.Literal
@@ -48,6 +48,7 @@ import GHC.Types.Demand ( isUsedOnce )
import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId )
import GHC.Types.SrcLoc ( mkGeneralSrcSpan )
import GHC.Builtin.Names ( unsafeEqualityProofName )
+import GHC.Data.Maybe
import Data.List.NonEmpty (nonEmpty, toList)
import Data.Maybe (fromMaybe)
@@ -229,12 +230,12 @@ import GHC.Types.SrcLoc
coreToStg :: DynFlags -> Module -> CoreProgram
- -> ([StgTopBinding], DCMap, CollectedCCs)
+ -> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
coreToStg dflags this_mod pgm
= (pgm', denv, final_ccs)
where
(_, denv, (local_ccs, local_cc_stacks), pgm')
- = coreTopBindsToStg dflags this_mod emptyVarEnv emptyUniqMap emptyCollectedCCs pgm
+ = coreTopBindsToStg dflags this_mod emptyVarEnv emptyInfoTableProvMap emptyCollectedCCs pgm
prof = WayProf `Set.member` ways dflags
@@ -252,10 +253,10 @@ coreTopBindsToStg
:: DynFlags
-> Module
-> IdEnv HowBound -- environment for the bindings
- -> DCMap
+ -> InfoTableProvMap
-> CollectedCCs
-> CoreProgram
- -> (IdEnv HowBound, DCMap,CollectedCCs, [StgTopBinding])
+ -> (IdEnv HowBound, InfoTableProvMap,CollectedCCs, [StgTopBinding])
coreTopBindsToStg _ _ env denv ccs []
= (env, denv, ccs, [])
@@ -271,10 +272,10 @@ coreTopBindToStg
:: DynFlags
-> Module
-> IdEnv HowBound
- -> DCMap
+ -> InfoTableProvMap
-> CollectedCCs
-> CoreBind
- -> (IdEnv HowBound, DCMap, CollectedCCs, StgTopBinding)
+ -> (IdEnv HowBound, InfoTableProvMap, CollectedCCs, StgTopBinding)
coreTopBindToStg _ _ env dcenv ccs (NonRec id e)
| Just str <- exprIsTickedString_maybe e
@@ -339,7 +340,9 @@ coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
mkTopStgRhs dflags this_mod ccs bndr new_rhs
stg_arity =
stgRhsArity stg_rhs
-
+ ; case stg_rhs of
+ StgRhsClosure {} -> recordStgIdPosition bndr (((, occNameString (getOccName bndr))) <$> (srcSpanToRealSrcSpan (nameSrcSpan (getName bndr))))
+ _ -> return ()
; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
ccs') }
where
@@ -686,13 +689,16 @@ coreToStgRhs :: (Id,CoreExpr)
coreToStgRhs (bndr, rhs) = do
new_rhs <- coreToStgExpr rhs
+ recordStgIdPosition bndr (quickSourcePos rhs)
return (mkStgRhs bndr new_rhs)
+quickSourcePos (Tick (SourceNote ss m) _) = Just (ss, m)
+quickSourcePos _ = Nothing
+
-- Generate a top-level RHS. Any new cost centres generated for CAFs will be
-- appended to `CollectedCCs` argument.
mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
-> Id -> StgExpr -> (StgRhs, CollectedCCs)
-
mkTopStgRhs dflags this_mod ccs bndr rhs
| StgLam bndrs body <- rhs
= -- StgLam can't have empty arguments, so not CAF
@@ -833,7 +839,7 @@ isPAP env _ = False
newtype CtsM a = CtsM
{ unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs
-> IdEnv HowBound
- -> RWS (Maybe (RealSrcSpan, String)) () DCMap a
+ -> RWS (Maybe (RealSrcSpan, String)) () InfoTableProvMap a
}
deriving (Functor)
@@ -869,7 +875,7 @@ data LetInfo
-- The std monad functions:
-initCts :: DynFlags -> IdEnv HowBound -> DCMap -> CtsM a -> (a, DCMap)
+initCts :: DynFlags -> IdEnv HowBound -> InfoTableProvMap -> CtsM a -> (a, InfoTableProvMap)
initCts dflags env u m =
let (a, d, ()) = runRWS (unCtsM m dflags env) Nothing u
in (a, d)
@@ -918,11 +924,19 @@ incDc :: DataCon -> CtsM Int
incDc dc = CtsM $ \_ _ -> do
env <- get
cc <- ask
- let env' = alterUniqMap (maybe (Just [(0, cc)]) (\xs@((k, _):_) -> Just ((k + 1, cc) : xs))) env dc
- put env'
- let Just r = lookupUniqMap env' dc
+ let dcMap' = alterUniqMap (maybe (Just [(0, cc)]) (\xs@((k, _):_) -> Just ((k + 1, cc) : xs))) (provDC env) dc
+ put (env { provDC = dcMap' })
+ let Just r = lookupUniqMap dcMap' dc
return (fst (head r))
+recordStgIdPosition :: Id -> Maybe (RealSrcSpan, String) -> CtsM ()
+recordStgIdPosition id ss = CtsM $ \_ _ -> do
+ cc <- ask
+ pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr ss)
+ case firstJust ss cc of
+ Nothing -> return ()
+ Just r -> modify (\env -> env { provClosure = addToUniqMap (provClosure env) id r})
+
withSpan :: (RealSrcSpan, String) -> CtsM a -> CtsM a
withSpan s (CtsM act) = CtsM (\a b -> local (const $ Just s) (act a b))
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -321,8 +321,8 @@ profilingInitCode dflags this_mod (local_CCs, singleton_CCSs)
-- | Generate code to initialise info pointer origin
-ipInitCode :: DynFlags -> Module -> DCMap -> SDoc
-ipInitCode dflags this_mod dcmap
+ipInitCode :: DynFlags -> Module -> InfoTableProvMap -> SDoc
+ipInitCode dflags this_mod (InfoTableProvMap dcmap closure_map)
= pprTraceIt "codeOutput" $ if not (gopt Opt_SccProfilingOn dflags)
then empty
else vcat
@@ -336,7 +336,9 @@ ipInitCode dflags this_mod dcmap
])
]
where
- ents = convertDCMap this_mod dcmap
+ dc_ents = convertDCMap this_mod dcmap
+ closure_ents = convertClosureMap this_mod closure_map
+ ents = closure_ents ++ dc_ents
emit_ipe_decl ipe =
text "extern InfoProvEnt" <+> ipe_lbl <> text "[];"
where ipe_lbl = ppr (mkIPELabel ipe)
=====================================
compiler/GHC/Driver/Hooks.hs
=====================================
@@ -110,7 +110,7 @@ data Hooks = Hooks
, getValueSafelyHook :: Maybe (HscEnv -> Name -> Type
-> IO (Maybe HValue))
, createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle)
- , stgToCmmHook :: Maybe (DynFlags -> Module -> DCMap -> [TyCon] -> CollectedCCs
+ , stgToCmmHook :: Maybe (DynFlags -> Module -> InfoTableProvMap -> [TyCon] -> CollectedCCs
-> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ())
, cmmToRawCmmHook :: forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -1542,7 +1542,7 @@ This reduces residency towards the end of the CodeGen phase significantly
(5-10%).
-}
-doCodeGen :: HscEnv -> Module -> DCMap -> [TyCon]
+doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]
-> CollectedCCs
-> [StgTopBinding]
-> HpcInfo
@@ -1591,7 +1591,7 @@ doCodeGen hsc_env this_mod denv data_tycons
myCoreToStg :: DynFlags -> Module -> CoreProgram
-> IO ( [StgTopBinding] -- output program
- , DCMap
+ , InfoTableProvMap
, CollectedCCs ) -- CAF cost centre info (declared and used)
myCoreToStg dflags this_mod prepd_binds = do
let (stg_binds, denv, cost_centre_info)
=====================================
compiler/GHC/StgToCmm.hs
=====================================
@@ -64,7 +64,7 @@ import Data.Maybe
codeGen :: DynFlags
-> Module
- -> DCMap
+ -> InfoTableProvMap
-> [TyCon]
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [CgStgTopBinding] -- Bindings to convert
@@ -72,7 +72,7 @@ codeGen :: DynFlags
-> Stream IO CmmGroup () -- Output as a stream, so codegen can
-- be interleaved with output
-codeGen dflags this_mod dcmap@(UniqMap denv) data_tycons
+codeGen dflags this_mod (InfoTableProvMap (dcmap@(UniqMap denv)) _) data_tycons
cost_centre_info stg_binds hpc_info
= do { -- cg: run the code generator, and yield the resulting CmmGroup
-- Using an IORef to store the state is a bit crude, but otherwise
=====================================
compiler/GHC/StgToCmm/Utils.hs
=====================================
@@ -45,7 +45,7 @@ module GHC.StgToCmm.Utils (
emitUpdRemSetPush,
emitUpdRemSetPushThunk,
- convertDCMap
+ convertDCMap, convertClosureMap
) where
#include "HsVersions.h"
@@ -91,6 +91,7 @@ import GHC.Types.Unique.Map
import GHC.Types.Unique.FM
import Data.Maybe
import GHC.Core.DataCon
+import GHC.Types.Id
-------------------------------------------------------------------------
@@ -632,11 +633,15 @@ emitUpdRemSetPushThunk ptr = do
False
+convertClosureMap :: Module -> ClosureMap -> [InfoTableEnt]
+convertClosureMap this_mod (UniqMap denv) =
+ map (\(bndr, (ss, l)) -> InfoTableEnt (mkClosureTableLabel (idName bndr) (idCafInfo bndr)) (this_mod, ss, l)) (nonDetEltsUFM denv)
+
convertDCMap :: Module -> DCMap -> [InfoTableEnt]
convertDCMap this_mod (UniqMap denv) =
- concatMap (\(dc, ns) -> mapMaybe (\(k, mss) ->
+ concatMap (\(dc, ns) -> mapMaybe (\(k, mss) ->
case mss of
Nothing -> Nothing
- Just (ss, l) -> Just $
- InfoTableEnt (mkConInfoTableLabel (dataConName dc) (Just (this_mod, k)))
+ Just (ss, l) -> Just $
+ InfoTableEnt (mkConInfoTableLabel (dataConName dc) (Just (this_mod, k)))
(this_mod, ss, l)) ns) (nonDetEltsUFM denv)
\ No newline at end of file
=====================================
compiler/GHC/Types/CostCentre.hs
=====================================
@@ -2,7 +2,7 @@
module GHC.Types.CostCentre (
CostCentre(..), CcName, CCFlavour(..),
-- All abstract except to friend: ParseIface.y
- DCMap,
+ DCMap, ClosureMap, InfoTableProvMap(..), emptyInfoTableProvMap,
CostCentreStack,
CollectedCCs, emptyCollectedCCs, collectCC,
currentCCS, dontCareCCS,
@@ -189,6 +189,13 @@ data CostCentreStack
type DCMap = UniqMap DataCon [(Int, Maybe (RealSrcSpan, String))]
+type ClosureMap = UniqMap Id (RealSrcSpan, String)
+
+data InfoTableProvMap = InfoTableProvMap
+ { provDC :: DCMap
+ , provClosure :: ClosureMap }
+
+emptyInfoTableProvMap = InfoTableProvMap emptyUniqMap emptyUniqMap
-- synonym for triple which describes the cost centre info in the generated
-- code for a module.
@@ -209,6 +216,7 @@ currentCCS = CurrentCCS
dontCareCCS = DontCareCCS
-----------------------------------------------------------------------------
+
-- Predicates on Cost-Centre Stacks
isCurrentCCS :: CostCentreStack -> Bool
=====================================
compiler/GHC/Types/SrcLoc.hs
=====================================
@@ -53,6 +53,7 @@ module GHC.Types.SrcLoc (
srcSpanStart, srcSpanEnd,
realSrcSpanStart, realSrcSpanEnd,
srcSpanFileName_maybe,
+ srcSpanToRealSrcSpan,
pprUserRealSpan,
-- ** Unsafely deconstructing SrcSpan
@@ -511,6 +512,10 @@ srcSpanFileName_maybe :: SrcSpan -> Maybe FastString
srcSpanFileName_maybe (RealSrcSpan s _) = Just (srcSpanFile s)
srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing
+srcSpanToRealSrcSpan :: SrcSpan -> Maybe RealSrcSpan
+srcSpanToRealSrcSpan (RealSrcSpan ss _) = Just ss
+srcSpanToRealSrcSpan _ = Nothing
+
{-
************************************************************************
* *
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d28a579ab4daf2a587477940565f2cf684db0262
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d28a579ab4daf2a587477940565f2cf684db0262
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/20200529/051b3bda/attachment-0001.html>
More information about the ghc-commits
mailing list