[Git][ghc/ghc][wip/con-info] 2 commits: Quality refactoring
Matthew Pickering
gitlab at gitlab.haskell.org
Wed Nov 18 10:01:25 UTC 2020
Matthew Pickering pushed to branch wip/con-info at Glasgow Haskell Compiler / GHC
Commits:
4f3e5fe9 by Matthew Pickering at 2020-11-18T09:53:19+00:00
Quality refactoring
- - - - -
8ce72ae0 by Matthew Pickering at 2020-11-18T09:59:24+00:00
Revert changes to CoreToStg
- - - - -
16 changed files:
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Stg/CSE.hs
- + compiler/GHC/Stg/Debug.hs
- compiler/GHC/Stg/DepAnal.hs
- compiler/GHC/Stg/FVs.hs
- compiler/GHC/Stg/Lift.hs
- compiler/GHC/Stg/Lift/Analysis.hs
- compiler/GHC/Stg/Lift/Monad.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Stg/Stats.hs
- compiler/GHC/Stg/Syntax.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/Bind.hs
- compiler/GHC/StgToCmm/Expr.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, DeriveFunctor, TupleSections #-}
+{-# LANGUAGE CPP, DeriveFunctor #-}
--
-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
@@ -22,6 +22,7 @@ import GHC.Core.Utils ( exprType, findDefault, isJoinBind
, exprIsTickedString_maybe )
import GHC.Core.Opt.Arity ( manifestArity )
import GHC.Stg.Syntax
+import GHC.Stg.Debug
import GHC.Core.Type
import GHC.Types.RepType
@@ -33,7 +34,7 @@ import GHC.Core.DataCon
import GHC.Types.CostCentre
import GHC.Types.Var.Env
import GHC.Unit.Module
-import GHC.Types.Name ( getName, getOccName, occNameString, nameSrcSpan, isExternalName, nameModule_maybe )
+import GHC.Types.Name ( isExternalName, nameModule_maybe )
import GHC.Types.Basic ( Arity )
import GHC.Builtin.Types ( unboxedUnitDataCon, unitDataConId )
import GHC.Types.Literal
@@ -48,16 +49,14 @@ import GHC.Driver.Ppr
import GHC.Types.ForeignCall
import GHC.Types.Demand ( isUsedOnce )
import GHC.Builtin.PrimOps ( PrimCall(..) )
+import GHC.Types.SrcLoc ( mkGeneralSrcSpan )
import GHC.Builtin.Names ( unsafeEqualityProofName )
-import GHC.Data.Maybe
+import Control.Monad (ap)
import Data.List.NonEmpty (nonEmpty, toList)
-import Control.Monad (when, ap)
+import Data.Maybe (fromMaybe)
+import Data.Tuple (swap)
import qualified Data.Set as Set
-import Control.Monad.Trans.RWS
-import GHC.Types.Unique.Map
-import GHC.Types.SrcLoc
-import Control.Applicative
-- Note [Live vs free]
-- ~~~~~~~~~~~~~~~~~~~
@@ -233,10 +232,15 @@ import Control.Applicative
coreToStg :: DynFlags -> Module -> ModLocation -> CoreProgram
-> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
coreToStg dflags this_mod ml pgm
- = (pgm', denv, final_ccs)
+ = (pgm'', denv, final_ccs)
where
- (_, denv, (local_ccs, local_cc_stacks), pgm')
- = coreTopBindsToStg dflags this_mod ml emptyVarEnv emptyInfoTableProvMap emptyCollectedCCs pgm
+ (_, (local_ccs, local_cc_stacks), pgm')
+ = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm
+
+ (!pgm'', !denv) =
+ if gopt Opt_InfoTableMap dflags
+ then collectDebugInformation dflags ml pgm'
+ else (pgm', emptyInfoTableProvMap)
prof = WayProf `Set.member` ways dflags
@@ -253,49 +257,45 @@ coreToStg dflags this_mod ml pgm
coreTopBindsToStg
:: DynFlags
-> Module
- -> ModLocation
-> IdEnv HowBound -- environment for the bindings
- -> InfoTableProvMap
-> CollectedCCs
-> CoreProgram
- -> (IdEnv HowBound, InfoTableProvMap,CollectedCCs, [StgTopBinding])
+ -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
-coreTopBindsToStg _ _ _ env denv ccs []
- = (env, denv, ccs, [])
-coreTopBindsToStg dflags this_mod ml env denv ccs (b:bs)
- = (env2, denv2, ccs2, b':bs')
+coreTopBindsToStg _ _ env ccs []
+ = (env, ccs, [])
+coreTopBindsToStg dflags this_mod env ccs (b:bs)
+ = (env2, ccs2, b':bs')
where
- (env1, denv1, ccs1, b' ) =
- coreTopBindToStg dflags this_mod ml env denv ccs b
- (env2, denv2, ccs2, bs') =
- coreTopBindsToStg dflags this_mod ml env1 denv1 ccs1 bs
+ (env1, ccs1, b' ) =
+ coreTopBindToStg dflags this_mod env ccs b
+ (env2, ccs2, bs') =
+ coreTopBindsToStg dflags this_mod env1 ccs1 bs
coreTopBindToStg
:: DynFlags
-> Module
- -> ModLocation
-> IdEnv HowBound
- -> InfoTableProvMap
-> CollectedCCs
-> CoreBind
- -> (IdEnv HowBound, InfoTableProvMap, CollectedCCs, StgTopBinding)
+ -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
-coreTopBindToStg _ _ _ env dcenv ccs (NonRec id e)
+coreTopBindToStg _ _ env ccs (NonRec id e)
| Just str <- exprIsTickedString_maybe e
-- top-level string literal
-- See Note [Core top-level string literals] in GHC.Core
= let
env' = extendVarEnv env id how_bound
how_bound = LetBound TopLet 0
- in (env', dcenv, ccs, StgTopStringLit id str)
+ in (env', ccs, StgTopStringLit id str)
-coreTopBindToStg dflags this_mod ml env dcenv ccs (NonRec id rhs)
+coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)
= let
env' = extendVarEnv env id how_bound
how_bound = LetBound TopLet $! manifestArity rhs
- ((stg_rhs, ccs'), denv) =
- initCts dflags ml env dcenv $
+ (stg_rhs, ccs') =
+ initCts dflags env $
coreToTopStgRhs dflags ccs this_mod (id,rhs)
bind = StgTopLifted $ StgNonRec id stg_rhs
@@ -304,9 +304,9 @@ coreTopBindToStg dflags this_mod ml env dcenv ccs (NonRec id rhs)
-- as well as 'id', but that led to a black hole
-- where printing the assertion error tripped the
-- assertion again!
- (env', denv, ccs', bind)
+ (env', ccs', bind)
-coreTopBindToStg dflags this_mod ml env dcenv ccs (Rec pairs)
+coreTopBindToStg dflags this_mod env ccs (Rec pairs)
= ASSERT( not (null pairs) )
let
binders = map fst pairs
@@ -316,18 +316,14 @@ coreTopBindToStg dflags this_mod ml env dcenv ccs (Rec pairs)
env' = extendVarEnvList env extra_env'
-- generate StgTopBindings and CAF cost centres created for CAFs
- ((ccs', stg_rhss), dcenv')
- = initCts dflags ml env' dcenv $ do
- mapAccumLM (\ccs rhs -> do
- (rhs', ccs') <-
- coreToTopStgRhs dflags ccs this_mod rhs
- return (ccs', rhs'))
- ccs
- pairs
-
+ (ccs', stg_rhss)
+ = initCts dflags env' $
+ mapAccumLM (\ccs rhs -> swap <$> coreToTopStgRhs dflags ccs this_mod rhs)
+ ccs
+ pairs
bind = StgTopLifted $ StgRec (zip binders stg_rhss)
in
- (env', dcenv', ccs', bind)
+ (env', ccs', bind)
coreToTopStgRhs
:: DynFlags
@@ -344,14 +340,6 @@ coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
stg_arity =
stgRhsArity stg_rhs
- ; modLoc <- ctsModLocation
- ; let
- thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc
- best_span = quickSourcePos thisFile new_rhs
- ; case stg_rhs of
- StgRhsClosure {} ->
- recordStgIdPosition bndr best_span (((, occNameString (getOccName bndr))) <$> (srcSpanToRealSrcSpan (nameSrcSpan (getName bndr))))
- _ -> return ()
; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
ccs') }
where
@@ -422,12 +410,12 @@ coreToStgExpr expr@(Lam _ _)
return result_expr
coreToStgExpr (Tick tick expr)
- = do let k = case tick of
- HpcTick{} -> id
- ProfNote{} -> id
- SourceNote ss fp -> withSpan (ss, fp)
- Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
- expr2 <- k (coreToStgExpr expr)
+ = do case tick of
+ HpcTick{} -> return ()
+ ProfNote{} -> return ()
+ SourceNote{} -> return ()
+ Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
+ expr2 <- coreToStgExpr expr
return (StgTick tick expr2)
coreToStgExpr (Cast expr _)
@@ -552,32 +540,30 @@ coreToStgApp f args ticks = do
saturated = f_arity <= n_val_args
res_ty = exprType (mkApps (Var f) args)
- app <- case idDetails f of
+ app = case idDetails f of
DataConWorkId dc
- | saturated -> do
- u <- incDc dc
- return $ StgConApp dc u args' --(Just u) args'
- (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty)))
+ | saturated -> StgConApp dc Nothing args'
+ (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty)))
-- Some primitive operator that might be implemented as a library call.
-- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps
-- we require that primop applications be saturated.
PrimOpId op -> ASSERT( saturated )
- return $ StgOpApp (StgPrimOp op) args' res_ty
+ StgOpApp (StgPrimOp op) args' res_ty
-- A call to some primitive Cmm function.
FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)
PrimCallConv _))
-> ASSERT( saturated )
- return $ StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
+ StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
-- A regular foreign call.
FCallId call -> ASSERT( saturated )
- return $ StgOpApp (StgFCallOp call (idType f)) args' res_ty
+ StgOpApp (StgFCallOp call (idType f)) args' res_ty
TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args')
- _other -> return $ StgApp f args'
- let
+ _other -> StgApp f args'
+
tapp = foldr StgTick app (ticks ++ ticks')
-- Forcing these fixes a leak in the code generator, noticed while
@@ -613,7 +599,7 @@ coreToStgArgs (arg : args) = do -- Non-type argument
(aticks, arg'') = stripStgTicksTop tickishFloatable arg'
stg_arg = case arg'' of
StgApp v [] -> StgVarArg v
- StgConApp con _n [] _ -> StgVarArg (dataConWorkId con)
+ StgConApp con _ [] _ -> StgVarArg (dataConWorkId con)
StgLit lit -> StgLitArg lit
_ -> pprPanic "coreToStgArgs" (ppr arg)
@@ -695,23 +681,7 @@ coreToStgRhs :: (Id,CoreExpr)
coreToStgRhs (bndr, rhs) = do
new_rhs <- coreToStgExpr rhs
- modLoc <- ctsModLocation
- let
- thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc
- best_span = quickSourcePos thisFile new_rhs
- let new_stg_rhs = (mkStgRhs bndr new_rhs)
- case new_stg_rhs of
- StgRhsClosure {} ->
- recordStgIdPosition bndr best_span (((, occNameString (getOccName bndr))) <$> (srcSpanToRealSrcSpan (nameSrcSpan (getName bndr))))
- _ -> return ()
- return new_stg_rhs
-
-
-quickSourcePos :: FastString -> StgExpr -> Maybe (RealSrcSpan, String)
-quickSourcePos cur_mod (StgTick (SourceNote ss m) e)
- | srcSpanFile ss == cur_mod = Just (ss, m)
- | otherwise = quickSourcePos cur_mod e
-quickSourcePos _ _ = Nothing
+ return (mkStgRhs bndr new_rhs)
-- Generate a top-level RHS. Any new cost centres generated for CAFs will be
-- appended to `CollectedCCs` argument.
@@ -727,13 +697,13 @@ mkTopStgRhs dflags this_mod ccs bndr rhs
(toList bndrs) body
, ccs )
- | StgConApp con n args _ <- unticked_rhs
+ | StgConApp con mn args _ <- unticked_rhs
, -- Dynamic StgConApps are updatable
not (isDllConApp dflags this_mod con args)
= -- CorePrep does this right, but just to make sure
ASSERT2( not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)
, ppr bndr $$ ppr con $$ ppr args)
- ( StgRhsCon dontCareCCS con n args, ccs )
+ ( StgRhsCon dontCareCCS con mn ticks args, ccs )
-- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
| gopt Opt_AutoSccsOnIndividualCafs dflags
@@ -749,7 +719,7 @@ mkTopStgRhs dflags this_mod ccs bndr rhs
, ccs )
where
- unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs
+ (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
| otherwise = Updatable
@@ -783,15 +753,15 @@ mkStgRhs bndr rhs
ReEntrant -- ignored for LNE
[] rhs
- | StgConApp con mu args _ <- unticked_rhs
- = StgRhsCon currentCCS con mu args
+ | StgConApp con mn args _ <- unticked_rhs
+ = StgRhsCon currentCCS con mn ticks args
| otherwise
= StgRhsClosure noExtFieldSilent
currentCCS
upd_flag [] rhs
where
- unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs
+ (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
| otherwise = Updatable
@@ -857,9 +827,8 @@ isPAP env _ = False
newtype CtsM a = CtsM
{ unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs
- -> ModLocation
-> IdEnv HowBound
- -> RWS (Maybe (RealSrcSpan, String)) () InfoTableProvMap a
+ -> a
}
deriving (Functor)
@@ -895,10 +864,8 @@ data LetInfo
-- The std monad functions:
-initCts :: DynFlags -> ModLocation -> IdEnv HowBound -> InfoTableProvMap -> CtsM a -> (a, InfoTableProvMap)
-initCts dflags ml env u m =
- let (a, d, ()) = runRWS (unCtsM m dflags ml env) Nothing u
- in (a, d)
+initCts :: DynFlags -> IdEnv HowBound -> CtsM a -> a
+initCts dflags env m = unCtsM m dflags env
@@ -906,14 +873,11 @@ initCts dflags ml env u m =
{-# INLINE returnCts #-}
returnCts :: a -> CtsM a
-returnCts e = CtsM $ \_ _ _ -> return e
+returnCts e = CtsM $ \_ _ -> e
thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b
-thenCts m k = CtsM $ \dflags ml env
- -> do
- a <- (unCtsM m dflags ml env)
- unCtsM (k a) dflags ml env
-
+thenCts m k = CtsM $ \dflags env
+ -> unCtsM (k (unCtsM m dflags env)) dflags env
instance Applicative CtsM where
pure = returnCts
@@ -923,49 +887,23 @@ instance Monad CtsM where
(>>=) = thenCts
instance HasDynFlags CtsM where
- getDynFlags = CtsM $ \dflags _ _ -> return dflags
+ getDynFlags = CtsM $ \dflags _ -> dflags
-- Functions specific to this monad:
extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts ids_w_howbound expr
- = CtsM $ \dflags ml env
- -> unCtsM expr dflags ml (extendVarEnvList env ids_w_howbound)
+ = CtsM $ \dflags env
+ -> unCtsM expr dflags (extendVarEnvList env ids_w_howbound)
lookupVarCts :: Id -> CtsM HowBound
-lookupVarCts v = CtsM $ \_ _ env -> return $ lookupBinding env v
+lookupVarCts v = CtsM $ \_ env -> lookupBinding env v
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding env v = case lookupVarEnv env v of
Just xx -> xx
Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
-incDc :: DataCon -> CtsM (Maybe Int)
-incDc dc | isUnboxedTupleDataCon dc = return Nothing
-incDc dc | isUnboxedSumDataCon dc = return Nothing
-incDc dc = CtsM $ \dflags _ _ -> if not (gopt Opt_DistinctConstructorTables dflags) then return Nothing else do
- env <- get
- cc <- ask
- let dcMap' = alterUniqMap (maybe (Just [(0, cc)]) (\xs@((k, _):_) -> Just ((k + 1, cc) : xs))) (provDC env) dc
- put (env { provDC = dcMap' })
- let r = lookupUniqMap dcMap' dc
- return (fst . head <$> r)
-
-recordStgIdPosition :: Id -> Maybe (RealSrcSpan, String) -> Maybe (RealSrcSpan, String) -> CtsM ()
-recordStgIdPosition id best_span ss = CtsM $ \dflags _ _ -> when (gopt Opt_InfoTableMap dflags) $ do
- cc <- ask
- let tyString = showPpr dflags (idType id)
- --pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr ss)
- case best_span <|> ss <|> cc of
- Nothing -> return ()
- Just (rss, d) -> modify (\env -> env { provClosure = addToUniqMap (provClosure env) (idName id) (tyString, rss, d)})
-
-withSpan :: (RealSrcSpan, String) -> CtsM a -> CtsM a
-withSpan s (CtsM act) = CtsM (\a b c -> local (const $ Just s) (act a b c))
-
-ctsModLocation :: CtsM ModLocation
-ctsModLocation = CtsM (\_ ml _ -> return ml)
-
getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
getAllCAFsCC this_mod =
let
=====================================
compiler/GHC/Stg/CSE.hs
=====================================
@@ -290,8 +290,8 @@ stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs
stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body)
= let body' = stgCseExpr (initEnv in_scope) body
in StgRhsClosure ext ccs upd args body'
-stgCseTopLvlRhs _ (StgRhsCon ccs dataCon mu args)
- = StgRhsCon ccs dataCon mu args
+stgCseTopLvlRhs _ (StgRhsCon ccs dataCon mu ticks args)
+ = StgRhsCon ccs dataCon mu ticks args
------------------------------
-- The actual AST traversal --
@@ -395,7 +395,7 @@ stgCsePairs env0 ((b,e):pairs)
-- The RHS of a binding.
-- If it is a constructor application, either short-cut it or extend the environment
stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv)
-stgCseRhs env bndr (StgRhsCon ccs dataCon mu args)
+stgCseRhs env bndr (StgRhsCon ccs dataCon mu ticks args)
| Just other_bndr <- envLookup dataCon args' env
, not (isWeakLoopBreaker (idOccInfo bndr)) -- See Note [Care with loop breakers]
= let env' = addSubst bndr other_bndr env
@@ -403,7 +403,7 @@ stgCseRhs env bndr (StgRhsCon ccs dataCon mu args)
| otherwise
= let env' = addDataCon bndr dataCon args' env
-- see note [Case 1: CSEing allocated closures]
- pair = (bndr, StgRhsCon ccs dataCon mu args')
+ pair = (bndr, StgRhsCon ccs dataCon mu ticks args')
in (Just pair, env')
where args' = substArgs env args
=====================================
compiler/GHC/Stg/Debug.hs
=====================================
@@ -0,0 +1,137 @@
+{-# LANGUAGE TupleSections #-}
+-- This module contains functions which implement
+-- the -finfo-table-map and -fdistinct-constructor-tables flags
+module GHC.Stg.Debug(collectDebugInformation) where
+
+
+import GHC.Prelude
+
+import GHC.Core
+import GHC.Stg.Syntax
+
+import GHC.Types.Id
+import GHC.Core.DataCon
+import GHC.Types.CostCentre
+import GHC.Unit.Module
+import GHC.Types.Name ( getName, getOccName, occNameString, nameSrcSpan)
+import GHC.Data.FastString
+import GHC.Driver.Session
+import GHC.Driver.Ppr
+
+import Control.Monad (when)
+import Control.Monad.Trans.RWS
+import GHC.Types.Unique.Map
+import GHC.Types.SrcLoc
+import Control.Applicative
+import GHC.Utils.Outputable
+
+data R = R { rDynFlags :: DynFlags, rModLocation :: ModLocation, rSpan :: Maybe (RealSrcSpan, String) }
+
+type M a = RWS R () InfoTableProvMap a
+
+withSpan :: (RealSrcSpan, String) -> M a -> M a
+withSpan s act = local (\r -> r { rSpan = Just s }) act
+
+collectDebugInformation :: DynFlags -> ModLocation -> [StgTopBinding] -> ([StgTopBinding], InfoTableProvMap)
+collectDebugInformation dflags ml bs = case runRWS (mapM collectTop bs) (R dflags ml Nothing) emptyInfoTableProvMap of
+ (bs', m, _) -> (bs', m)
+
+collectTop :: StgTopBinding -> M StgTopBinding
+collectTop (StgTopLifted t) = StgTopLifted <$> collectStgBind t
+collectTop tb = return tb
+
+collectStgBind :: StgBinding -> M StgBinding
+collectStgBind (StgNonRec bndr rhs) = do
+ rhs' <- collectStgRhs bndr rhs
+ return (StgNonRec bndr rhs')
+collectStgBind (StgRec pairs) = do
+ es <- mapM (\(b, e) -> (b,) <$> collectStgRhs b e) pairs
+ return (StgRec es)
+
+collectStgRhs :: Id -> StgRhs -> M StgRhs
+collectStgRhs bndr (StgRhsClosure ext cc us bs e)= do
+ e' <- collectExpr e
+ recordInfo bndr e'
+ return $ StgRhsClosure ext cc us bs e'
+collectStgRhs _bndr (StgRhsCon cc dc _n ticks args) = do
+ n' <- incDc dc ticks
+ return (StgRhsCon cc dc n' ticks args)
+
+
+recordInfo :: Id -> StgExpr -> M ()
+recordInfo bndr new_rhs = do
+ modLoc <- asks rModLocation
+ let
+ thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc
+ best_span = quickSourcePos thisFile new_rhs
+ recordStgIdPosition bndr best_span (((, occNameString (getOccName bndr))) <$> (srcSpanToRealSrcSpan (nameSrcSpan (getName bndr))))
+
+collectExpr :: StgExpr -> M StgExpr
+collectExpr = go
+ where
+ go (StgApp occ as) = return $ StgApp occ as
+ go (StgLit lit) = return $ StgLit lit
+ go (StgConApp dc _n as tys) = do
+ n' <- incDc dc []
+ return (StgConApp dc n' as tys)
+ go (StgOpApp op as ty) = return (StgOpApp op as ty)
+ go (StgLam bs e) = StgLam bs <$> collectExpr e
+ go (StgCase scrut bndr ty alts) =
+ StgCase <$> collectExpr scrut <*> pure bndr <*> pure ty <*> mapM collectAlts alts
+ go (StgLet ext bind body) = do
+ bind' <- collectStgBind bind
+ body' <- go body
+ return (StgLet ext bind' body')
+ go (StgLetNoEscape ext bind body) = do
+ bind' <- collectStgBind bind
+ body' <- go body
+ return (StgLetNoEscape ext bind' body')
+
+ go (StgTick tick e) = do
+ let k = case tick of
+ SourceNote ss fp -> withSpan (ss, fp)
+ _ -> id
+ e' <- k (go e)
+ return (StgTick tick e')
+
+collectAlts :: StgAlt -> M StgAlt
+collectAlts (ac, bs, e) = (ac, bs, ) <$> collectExpr e
+
+
+--runM dflags ml act = runRWS act (dflags, ml)
+
+
+quickSourcePos :: FastString -> StgExpr -> Maybe (RealSrcSpan, String)
+quickSourcePos cur_mod (StgTick (SourceNote ss m) e)
+ | srcSpanFile ss == cur_mod = Just (ss, m)
+ | otherwise = quickSourcePos cur_mod e
+quickSourcePos _ _ = Nothing
+
+incDc :: DataCon -> [Tickish Id] -> M (Maybe Int)
+incDc dc _ | isUnboxedTupleDataCon dc = return Nothing
+incDc dc _ | isUnboxedSumDataCon dc = return Nothing
+incDc dc ts = do
+ dflags <- asks rDynFlags
+ if not (gopt Opt_DistinctConstructorTables dflags) then return Nothing else do
+ env <- get
+ mcc <- asks rSpan
+ let best_span = selectTick ts <|> mcc
+ let dcMap' = alterUniqMap (maybe (Just [(0, best_span)]) (\xs@((k, _):_) -> Just ((k + 1, best_span) : xs))) (provDC env) dc
+ put (env { provDC = dcMap' })
+ let r = lookupUniqMap dcMap' dc
+ return (fst . head <$> r)
+
+selectTick :: [Tickish Id] -> Maybe (RealSrcSpan, String)
+selectTick [] = Nothing
+selectTick (SourceNote rss d : ts ) = selectTick ts <|> Just (rss, d)
+
+recordStgIdPosition :: Id -> Maybe (RealSrcSpan, String) -> Maybe (RealSrcSpan, String) -> M ()
+recordStgIdPosition id best_span ss = do
+ dflags <- asks rDynFlags
+ when (gopt Opt_InfoTableMap dflags) $ do
+ let tyString = showPpr dflags (idType id)
+ cc <- asks rSpan
+ pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr best_span $$ ppr ss)
+ case best_span <|> cc <|> ss of
+ Nothing -> return ()
+ Just (rss, d) -> modify (\env -> env { provClosure = addToUniqMap (provClosure env) (idName id) (tyString, rss, d)})
=====================================
compiler/GHC/Stg/DepAnal.hs
=====================================
@@ -62,7 +62,7 @@ annTopBindingsDeps this_mod bs = zip bs (map top_bind bs)
rhs bounds (StgRhsClosure _ _ _ as e) =
expr (extendVarSetList bounds as) e
- rhs bounds (StgRhsCon _ _ _ as) =
+ rhs bounds (StgRhsCon _ _ _ _ as) =
args bounds as
var :: BVs -> Var -> FVs
=====================================
compiler/GHC/Stg/FVs.hs
=====================================
@@ -159,7 +159,7 @@ rhs env (StgRhsClosure _ ccs uf bndrs body)
-- See Note [Tracking local binders]
(body', body_fvs) = expr (addLocals bndrs env) body
fvs = delDVarSetList body_fvs bndrs
-rhs env (StgRhsCon ccs dc mu as) = (StgRhsCon ccs dc mu as, args env as)
+rhs env (StgRhsCon ccs dc mu ts as) = (StgRhsCon ccs dc mu ts as, args env as)
alt :: Env -> StgAlt -> (CgStgAlt, DIdSet)
alt env (con, bndrs, e) = ((con, bndrs, e'), fvs)
=====================================
compiler/GHC/Stg/Lift.hs
=====================================
@@ -199,9 +199,9 @@ liftRhs
-- as lambda binders, discarding all free vars.
-> LlStgRhs
-> LiftM OutStgRhs
-liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn args)
+liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn ts args)
= ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ pprStgRhs panicStgPprOpts rhs)
- StgRhsCon ccs con mn <$> traverse liftArgs args
+ StgRhsCon ccs con mn ts <$> traverse liftArgs args
liftRhs Nothing (StgRhsClosure _ ccs upd infos body) =
-- This RHS wasn't lifted.
withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->
=====================================
compiler/GHC/Stg/Lift/Analysis.hs
=====================================
@@ -117,7 +117,7 @@ type instance XLet 'LiftLams = Skeleton
type instance XLetNoEscape 'LiftLams = Skeleton
freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet
-freeVarsOfRhs (StgRhsCon _ _ _ args) = mkDVarSet [ id | StgVarArg id <- args ]
+freeVarsOfRhs (StgRhsCon _ _ _ _ args) = mkDVarSet [ id | StgVarArg id <- args ]
freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs
-- | Captures details of the syntax tree relevant to the cost model, such as
@@ -326,8 +326,8 @@ tagSkeletonBinding is_lne body_skel body_arg_occs (StgRec pairs)
bndr' = BindsClosure bndr (bndr `elemVarSet` scope_occs)
tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs)
-tagSkeletonRhs _ (StgRhsCon ccs dc mn args)
- = (NilSk, mkArgOccs args, StgRhsCon ccs dc mn args)
+tagSkeletonRhs _ (StgRhsCon ccs dc mn ts args)
+ = (NilSk, mkArgOccs args, StgRhsCon ccs dc mn ts args)
tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body)
= (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body')
where
=====================================
compiler/GHC/Stg/Lift/Monad.hs
=====================================
@@ -194,9 +194,9 @@ removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass
removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body)
| isCurrentCCS ccs
= StgRhsClosure ext dontCareCCS upd bndrs body
-removeRhsCCCS (StgRhsCon ccs con mu args)
+removeRhsCCCS (StgRhsCon ccs con mu ts args)
| isCurrentCCS ccs
- = StgRhsCon dontCareCCS con mu args
+ = StgRhsCon dontCareCCS con mu ts args
removeRhsCCCS rhs = rhs
-- | The analysis monad consists of the following 'RWST' components:
=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -148,7 +148,7 @@ checkNoCurrentCCS rhs = do
StgRhsClosure _ ccs _ _ _
| isCurrentCCS ccs
-> addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ rhs')
- StgRhsCon ccs _ _ _
+ StgRhsCon ccs _ _ _ _
| isCurrentCCS ccs
-> addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ rhs')
_ -> return ()
@@ -163,7 +163,7 @@ lintStgRhs (StgRhsClosure _ _ _ binders expr)
addInScopeVars binders $
lintStgExpr expr
-lintStgRhs rhs@(StgRhsCon _ con _ args) = do
+lintStgRhs rhs@(StgRhsCon _ con _ _ args) = do
when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do
opts <- getStgPprOpts
addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
=====================================
compiler/GHC/Stg/Stats.hs
=====================================
@@ -125,7 +125,7 @@ statBinding top (StgRec pairs)
statRhs :: Bool -> (Id, StgRhs) -> StatEnv
-statRhs top (_, StgRhsCon _ _ _ _)
+statRhs top (_, StgRhsCon _ _ _ _ _)
= countOne (ConstructorBinds top)
statRhs top (_, StgRhsClosure _ _ u _ body)
=====================================
compiler/GHC/Stg/Syntax.hs
=====================================
@@ -437,6 +437,7 @@ important):
DataCon -- Constructor. Never an unboxed tuple or sum, as those
-- are not allocated.
(Maybe Int)
+ [Tickish Id]
[StgArg] -- Args
-- | Used as a data type index for the stgSyn AST
@@ -483,7 +484,7 @@ stgRhsArity :: StgRhs -> Int
stgRhsArity (StgRhsClosure _ _ _ bndrs _)
= ASSERT( all isId bndrs ) length bndrs
-- The arity never includes type parameters, but they should have gone by now
-stgRhsArity (StgRhsCon _ _ _ _) = 0
+stgRhsArity (StgRhsCon _ _ _ _ _) = 0
{-
************************************************************************
@@ -818,5 +819,5 @@ pprStgRhs opts rhs = case rhs of
])
4 (pprStgExpr opts body)
- StgRhsCon cc con mid args
- -> hcat [ ppr cc, space, ppr mid, ppr con, text "! ", brackets (sep (map pprStgArg args))]
+ StgRhsCon cc con mid ticks args
+ -> hcat [ ppr cc, space, ppr mid, ppr ticks, ppr con, text "! ", brackets (sep (map pprStgArg args))]
=====================================
compiler/GHC/Stg/Unarise.hs
=====================================
@@ -293,9 +293,9 @@ unariseRhs rho (StgRhsClosure ext ccs update_flag args expr)
expr' <- unariseExpr rho' expr
return (StgRhsClosure ext ccs update_flag args1 expr')
-unariseRhs rho (StgRhsCon ccs con mu args)
+unariseRhs rho (StgRhsCon ccs con mu ts args)
= ASSERT(not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
- return (StgRhsCon ccs con mu (unariseConArgs rho args))
+ return (StgRhsCon ccs con mu ts (unariseConArgs rho args))
--------------------------------------------------------------------------------
=====================================
compiler/GHC/StgToCmm.hs
=====================================
@@ -198,7 +198,7 @@ cgTopBinding dflags (StgTopStringLit id str) = do
cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
-- The Id is passed along for setting up a binding...
-cgTopRhs dflags _rec bndr (StgRhsCon _cc con mn args)
+cgTopRhs dflags _rec bndr (StgRhsCon _cc con mn _ts args)
= cgTopRhsCon dflags bndr con mn (assertNonVoidStgArgs args)
-- con args are always non-void,
-- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
=====================================
compiler/GHC/StgToCmm/Bind.hs
=====================================
@@ -205,7 +205,7 @@ cgRhs :: Id
-- (see above)
)
-cgRhs id (StgRhsCon cc con mn args)
+cgRhs id (StgRhsCon cc con mn _ts args)
= withNewTickyCounterCon (idName id) con $
buildDynCon id mn True cc con (assertNonVoidStgArgs args)
-- con args are always non-void,
=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -158,7 +158,7 @@ cgLetNoEscapeRhsBody
-> FCode (CgIdInfo, FCode ())
cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body)
= cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
-cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con mn args)
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con mn _ts args)
= cgLetNoEscapeClosure bndr local_cc cc []
(StgConApp con mn args (pprPanic "cgLetNoEscapeRhsBody" $
text "StgRhsCon doesn't have type args"))
=====================================
compiler/ghc.cabal.in
=====================================
@@ -511,6 +511,7 @@ Library
GHC.Settings.Constants
GHC.Settings.IO
GHC.Stg.CSE
+ GHC.Stg.Debug
GHC.Stg.DepAnal
GHC.Stg.FVs
GHC.Stg.Lift
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a6ef34bb20b9adda775954039a7c69a84535751e...8ce72ae05f126285579a6d228c44bd6dedbee71e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a6ef34bb20b9adda775954039a7c69a84535751e...8ce72ae05f126285579a6d228c44bd6dedbee71e
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/20201118/e579efbb/attachment-0001.html>
More information about the ghc-commits
mailing list