...
 
Commits (81)
......@@ -2,7 +2,7 @@ variables:
GIT_SSL_NO_VERIFY: "1"
# Commit of ghc/ci-images repository from which to pull Docker images
DOCKER_REV: 3f731f5d37a156e7ebe10cd32656946083baaf4a
DOCKER_REV: 6223fe0b5942f4fa35bdec92c74566cf195bfb42
# Sequential version number capturing the versions of all tools fetched by
# .gitlab/ci.sh.
......
......@@ -26,6 +26,9 @@ LT_CYAN="1;36"
WHITE="1;37"
LT_GRAY="0;37"
export LANG=C.UTF-8
export LC_ALL=C.UTF-8
# GitLab Pipelines log section delimiters
# https://gitlab.com/gitlab-org/gitlab-foss/issues/14664
start_section() {
......
Thank you for your contribution to GHC!
**Please read the checklist below to make sure your contribution fulfills these
expectations. Also please answer the following question in your MR description:**
**Where is the key part of this patch? That is, what should reviewers look at first?**
Please take a few moments to verify that your commits fulfill the following:
* [ ] are either individually buildable or squashed
......@@ -10,7 +15,7 @@ Please take a few moments to verify that your commits fulfill the following:
likely should add a [Note][notes] and cross-reference it from the relevant
places.
* [ ] add a [testcase to the testsuite](https://gitlab.haskell.org/ghc/ghc/wikis/building/running-tests/adding).
* [ ] if your MR affects library interfaces (e.g. changes `base`) please add
* [ ] if your MR affects library interfaces (e.g. changes `base`) or affects whether GHC will accept user-written code, please add
the ~"user facing" label.
* [ ] updates the users guide if applicable
* [ ] mentions new features in the release notes for the next release
......
......@@ -594,10 +594,10 @@ checkBrokenTablesNextToCode' dflags
-- flags. If you are not doing linking or doing static linking, you
-- can ignore the list of packages returned.
--
setSessionDynFlags :: GhcMonad m => DynFlags -> m [UnitId]
setSessionDynFlags :: GhcMonad m => DynFlags -> m ()
setSessionDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
(dflags''', preload) <- liftIO $ initPackages dflags'
dflags''' <- liftIO $ initUnits dflags'
-- Interpreter
interp <- if gopt Opt_ExternalInterpreter dflags
......@@ -637,12 +637,14 @@ setSessionDynFlags dflags = do
-- already one set up
}
invalidateModSummaryCache
return preload
-- | Sets the program 'DynFlags'. Note: this invalidates the internal
-- cached module graph, causing more work to be done the next time
-- 'load' is called.
setProgramDynFlags :: GhcMonad m => DynFlags -> m [UnitId]
--
-- Returns a boolean indicating if preload units have changed and need to be
-- reloaded.
setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool
setProgramDynFlags dflags = setProgramDynFlags_ True dflags
-- | Set the action taken when the compiler produces a message. This
......@@ -654,17 +656,17 @@ setLogAction action = do
void $ setProgramDynFlags_ False $
dflags' { log_action = action }
setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [UnitId]
setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool
setProgramDynFlags_ invalidate_needed dflags = do
dflags' <- checkNewDynFlags dflags
dflags_prev <- getProgramDynFlags
(dflags'', preload) <-
if (packageFlagsChanged dflags_prev dflags')
then liftIO $ initPackages dflags'
else return (dflags', [])
let changed = packageFlagsChanged dflags_prev dflags'
dflags'' <- if changed
then liftIO $ initUnits dflags'
else return dflags'
modifySession $ \h -> h{ hsc_dflags = dflags'' }
when invalidate_needed $ invalidateModSummaryCache
return preload
return changed
-- When changing the DynFlags, we want the changes to apply to future
......@@ -699,7 +701,7 @@ getProgramDynFlags = getSessionDynFlags
-- | Set the 'DynFlags' used to evaluate interactive expressions.
-- Note: this cannot be used for changes to packages. Use
-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the
-- 'pkgState' into the interactive @DynFlags@.
-- 'unitState' into the interactive @DynFlags@.
setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
......@@ -1355,7 +1357,7 @@ packageDbModules :: GhcMonad m =>
-> m [Module]
packageDbModules only_exposed = do
dflags <- getSessionDynFlags
let pkgs = eltsUFM (unitInfoMap (pkgState dflags))
let pkgs = eltsUFM (unitInfoMap (unitState dflags))
return $
[ mkModule pid modname
| p <- pkgs
......@@ -1489,7 +1491,7 @@ findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
let
dflags = hsc_dflags hsc_env
this_pkg = thisPackage dflags
this_pkg = homeUnit dflags
--
case maybe_pkg of
Just pkg | fsToUnit pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
......@@ -1679,7 +1681,7 @@ interpretPackageEnv dflags = do
namedEnvPath :: String -> MaybeT IO FilePath
namedEnvPath name = do
appdir <- versionedAppDir dflags
appdir <- versionedAppDir (programName dflags) (targetPlatform dflags)
return $ appdir </> "environments" </> name
probeEnvName :: String -> MaybeT IO FilePath
......@@ -1716,7 +1718,7 @@ interpretPackageEnv dflags = do
-- e.g. .ghc.environment.x86_64-linux-7.6.3
localEnvFileName :: FilePath
localEnvFileName = ".ghc.environment" <.> versionedFilePath dflags
localEnvFileName = ".ghc.environment" <.> versionedFilePath (targetPlatform dflags)
-- Search for an env file, starting in the current dir and looking upwards.
-- Fail if we get to the users home dir or the filesystem root. That is,
......
......@@ -144,7 +144,7 @@ When GHC reads the package data base, it (internally only) pretends it has UnitI
`integer-wired-in` instead of the actual UnitId (which includes the version
number); just like for `base` and other packages, as described in
Note [Wired-in units] in GHC.Unit.Module. This is done in
GHC.Unit.State.findWiredInPackages.
GHC.Unit.State.findWiredInUnits.
-}
{-# LANGUAGE CPP #-}
......@@ -618,7 +618,7 @@ rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation
mkInteractiveModule :: Int -> Module
-- (mkInteractiveMoudule 9) makes module 'interactive:M9'
mkInteractiveModule n = mkModule interactiveUnitId (mkModuleName ("Ghci" ++ show n))
mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ show n))
pRELUDE_NAME, mAIN_NAME :: ModuleName
pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude")
......@@ -629,28 +629,28 @@ dATA_ARRAY_PARALLEL_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel")
dATA_ARRAY_PARALLEL_PRIM_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel.Prim")
mkPrimModule :: FastString -> Module
mkPrimModule m = mkModule primUnitId (mkModuleNameFS m)
mkPrimModule m = mkModule primUnit (mkModuleNameFS m)
mkIntegerModule :: FastString -> Module
mkIntegerModule m = mkModule integerUnitId (mkModuleNameFS m)
mkIntegerModule m = mkModule integerUnit (mkModuleNameFS m)
mkBaseModule :: FastString -> Module
mkBaseModule m = mkModule baseUnitId (mkModuleNameFS m)
mkBaseModule m = mkBaseModule_ (mkModuleNameFS m)
mkBaseModule_ :: ModuleName -> Module
mkBaseModule_ m = mkModule baseUnitId m
mkBaseModule_ m = mkModule baseUnit m
mkThisGhcModule :: FastString -> Module
mkThisGhcModule m = mkModule thisGhcUnitId (mkModuleNameFS m)
mkThisGhcModule m = mkThisGhcModule_ (mkModuleNameFS m)
mkThisGhcModule_ :: ModuleName -> Module
mkThisGhcModule_ m = mkModule thisGhcUnitId m
mkThisGhcModule_ m = mkModule thisGhcUnit m
mkMainModule :: FastString -> Module
mkMainModule m = mkModule mainUnitId (mkModuleNameFS m)
mkMainModule m = mkModule mainUnit (mkModuleNameFS m)
mkMainModule_ :: ModuleName -> Module
mkMainModule_ m = mkModule mainUnitId m
mkMainModule_ m = mkModule mainUnit m
{-
************************************************************************
......
......@@ -105,6 +105,9 @@ templateHaskellNames = [
numTyLitName, strTyLitName,
-- TyVarBndr
plainTVName, kindedTVName,
plainInvisTVName, kindedInvisTVName,
-- Specificity
specifiedSpecName, inferredSpecName,
-- Role
nominalRName, representationalRName, phantomRName, inferRName,
-- Kind
......@@ -152,7 +155,7 @@ templateHaskellNames = [
expQTyConName, fieldExpTyConName, predTyConName,
stmtTyConName, decsTyConName, conTyConName, bangTypeTyConName,
varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName,
typeTyConName, tyVarBndrTyConName, clauseTyConName,
typeTyConName, tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, clauseTyConName,
patQTyConName, funDepTyConName, decsQTyConName,
ruleBndrTyConName, tySynEqnTyConName,
roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName,
......@@ -167,7 +170,7 @@ thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal")
qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
mkTHModule :: FastString -> Module
mkTHModule m = mkModule thUnitId (mkModuleNameFS m)
mkTHModule m = mkModule thUnit (mkModuleNameFS m)
libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name
libFun = mk_known_key_name varName thLib
......@@ -471,6 +474,15 @@ plainTVName, kindedTVName :: Name
plainTVName = libFun (fsLit "plainTV") plainTVIdKey
kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
plainInvisTVName, kindedInvisTVName :: Name
plainInvisTVName = libFun (fsLit "plainInvisTV") plainInvisTVIdKey
kindedInvisTVName = libFun (fsLit "kindedInvisTV") kindedInvisTVIdKey
-- data Specificity = ...
specifiedSpecName, inferredSpecName :: Name
specifiedSpecName = libFun (fsLit "specifiedSpec") specifiedSpecKey
inferredSpecName = libFun (fsLit "inferredSpec") inferredSpecKey
-- data Role = ...
nominalRName, representationalRName, phantomRName, inferRName :: Name
nominalRName = libFun (fsLit "nominalR") nominalRIdKey
......@@ -546,7 +558,8 @@ patQTyConName, expQTyConName, stmtTyConName,
conTyConName, bangTypeTyConName,
varBangTypeTyConName, typeQTyConName,
decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName,
derivClauseTyConName, kindTyConName, tyVarBndrTyConName,
derivClauseTyConName, kindTyConName,
tyVarBndrUnitTyConName, tyVarBndrSpecTyConName,
derivStrategyTyConName :: Name
-- These are only used for the types of top-level splices
expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
......@@ -564,7 +577,8 @@ tySynEqnTyConName = thTc (fsLit "TySynEqn") tySynEqnTyConKey
roleTyConName = libTc (fsLit "Role") roleTyConKey
derivClauseTyConName = thTc (fsLit "DerivClause") derivClauseTyConKey
kindTyConName = thTc (fsLit "Kind") kindTyConKey
tyVarBndrTyConName = thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
tyVarBndrUnitTyConName = libTc (fsLit "TyVarBndrUnit") tyVarBndrUnitTyConKey
tyVarBndrSpecTyConName = libTc (fsLit "TyVarBndrSpec") tyVarBndrSpecTyConKey
derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey
-- quasiquoting
......@@ -628,7 +642,8 @@ quoteClassKey = mkPreludeClassUnique 201
expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
patTyConKey,
stmtTyConKey, conTyConKey, typeQTyConKey, typeTyConKey,
tyVarBndrTyConKey, decTyConKey, bangTypeTyConKey, varBangTypeTyConKey,
tyVarBndrUnitTyConKey, tyVarBndrSpecTyConKey,
decTyConKey, bangTypeTyConKey, varBangTypeTyConKey,
fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
funDepTyConKey, predTyConKey,
predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey,
......@@ -655,7 +670,8 @@ patQTyConKey = mkPreludeTyConUnique 219
funDepTyConKey = mkPreludeTyConUnique 222
predTyConKey = mkPreludeTyConUnique 223
predQTyConKey = mkPreludeTyConUnique 224
tyVarBndrTyConKey = mkPreludeTyConUnique 225
tyVarBndrUnitTyConKey = mkPreludeTyConUnique 225
tyVarBndrSpecTyConKey = mkPreludeTyConUnique 237
decsQTyConKey = mkPreludeTyConUnique 226
ruleBndrTyConKey = mkPreludeTyConUnique 227
tySynEqnTyConKey = mkPreludeTyConUnique 228
......@@ -985,6 +1001,10 @@ plainTVIdKey, kindedTVIdKey :: Unique
plainTVIdKey = mkPreludeMiscIdUnique 413
kindedTVIdKey = mkPreludeMiscIdUnique 414
plainInvisTVIdKey, kindedInvisTVIdKey :: Unique
plainInvisTVIdKey = mkPreludeMiscIdUnique 482
kindedInvisTVIdKey = mkPreludeMiscIdUnique 483
-- data Role = ...
nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique
nominalRIdKey = mkPreludeMiscIdUnique 415
......@@ -1060,6 +1080,11 @@ anyclassStrategyIdKey = mkPreludeDataConUnique 495
newtypeStrategyIdKey = mkPreludeDataConUnique 496
viaStrategyIdKey = mkPreludeDataConUnique 497
-- data Specificity = ...
specifiedSpecKey, inferredSpecKey :: Unique
specifiedSpecKey = mkPreludeMiscIdUnique 498
inferredSpecKey = mkPreludeMiscIdUnique 499
{-
************************************************************************
* *
......
......@@ -586,7 +586,7 @@ pcDataConWithFixity' declared_infix dc_name wrk_key rri
(map (const no_bang) arg_tys)
[] -- No labelled fields
tyvars ex_tyvars
(mkTyCoVarBinders Specified user_tyvars)
(mkTyVarBinders SpecifiedSpec user_tyvars)
[] -- No equality spec
[] -- No theta
arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))
......
......@@ -1254,7 +1254,7 @@ primop ShrinkSmallMutableArrayOp_Char "shrinkSmallMutableArray#" GenPrimOp
SmallMutableArray# s a -> Int# -> State# s -> State# s
{Shrink mutable array to new specified size, in
the specified state thread. The new size argument must be less than or
equal to the current size as reported by {\tt sizeofSmallMutableArray\#}.}
equal to the current size as reported by {\tt getSizeofSmallMutableArray\#}.}
with out_of_line = True
has_side_effects = True
......@@ -1279,8 +1279,8 @@ primop SizeofSmallArrayOp "sizeofSmallArray#" GenPrimOp
primop SizeofSmallMutableArrayOp "sizeofSmallMutableArray#" GenPrimOp
SmallMutableArray# s a -> Int#
{Return the number of elements in the array. Note that this is deprecated
as it is unsafe in the presence of resize operations on the
same byte array.}
as it is unsafe in the presence of shrink and resize operations on the
same small mutable array.}
with deprecated_msg = { Use 'getSizeofSmallMutableArray#' instead }
primop GetSizeofSmallMutableArrayOp "getSizeofSmallMutableArray#" GenPrimOp
......@@ -1451,7 +1451,7 @@ primop ShrinkMutableByteArrayOp_Char "shrinkMutableByteArray#" GenPrimOp
MutableByteArray# s -> Int# -> State# s -> State# s
{Shrink mutable byte array to new specified size (in bytes), in
the specified state thread. The new size argument must be less than or
equal to the current size as reported by {\tt sizeofMutableByteArray\#}.}
equal to the current size as reported by {\tt getSizeofMutableByteArray\#}.}
with out_of_line = True
has_side_effects = True
......@@ -1484,7 +1484,7 @@ primop SizeofByteArrayOp "sizeofByteArray#" GenPrimOp
primop SizeofMutableByteArrayOp "sizeofMutableByteArray#" GenPrimOp
MutableByteArray# s -> Int#
{Return the size of the array in bytes. Note that this is deprecated as it is
unsafe in the presence of resize operations on the same byte
unsafe in the presence of shrink and resize operations on the same mutable byte
array.}
with deprecated_msg = { Use 'getSizeofMutableByteArray#' instead }
......
......@@ -169,7 +169,7 @@ nameToCLabel n suffix = mkFastString label
occPart = encodeZ (occNameFS (nameOccName n))
label = concat
[ if pkgKey == mainUnitId then "" else packagePart ++ "_"
[ if pkgKey == mainUnit then "" else packagePart ++ "_"
, modulePart
, '_':occPart
, '_':suffix
......
......@@ -12,7 +12,7 @@ module GHC.Cmm (
CmmBlock, RawCmmDecl,
Section(..), SectionType(..),
GenCmmStatics(..), type CmmStatics, type RawCmmStatics, CmmStatic(..),
isSecConstant,
SectionProtection(..), sectionProtection,
-- ** Blocks containing lists
GenBasicBlock(..), blockId,
......@@ -185,17 +185,33 @@ data SectionType
| OtherSection String
deriving (Show)
-- | Should a data in this section be considered constant
isSecConstant :: Section -> Bool
isSecConstant (Section t _) = case t of
Text -> True
ReadOnlyData -> True
RelocatableReadOnlyData -> True
ReadOnlyData16 -> True
CString -> True
Data -> False
UninitialisedData -> False
(OtherSection _) -> False
data SectionProtection
= ReadWriteSection
| ReadOnlySection
| WriteProtectedSection -- See Note [Relocatable Read-Only Data]
deriving (Eq)
-- | Should a data in this section be considered constant at runtime
sectionProtection :: Section -> SectionProtection
sectionProtection (Section t _) = case t of
Text -> ReadOnlySection
ReadOnlyData -> ReadOnlySection
RelocatableReadOnlyData -> WriteProtectedSection
ReadOnlyData16 -> ReadOnlySection
CString -> ReadOnlySection
Data -> ReadWriteSection
UninitialisedData -> ReadWriteSection
(OtherSection _) -> ReadWriteSection
{-
Note [Relocatable Read-Only Data]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Relocatable data are only read-only after relocation at the start of the
program. They should be writable from the source code until then. Failure to
do so would end up in segfaults at execution when using linkers that do not
enforce writability of those sections, such as the gold linker.
-}
data Section = Section SectionType CLabel
......
......@@ -119,7 +119,6 @@ import GHC.Prelude
import GHC.Types.Id.Info
import GHC.Types.Basic
import {-# SOURCE #-} GHC.Cmm.BlockId (BlockId, mkBlockId)
import GHC.Unit.State
import GHC.Unit
import GHC.Types.Name
import GHC.Types.Unique
......@@ -187,7 +186,7 @@ data CLabel
-- | A label from a .cmm file that is not associated with a .hs level Id.
| CmmLabel
Unit -- what package the label belongs to.
UnitId -- what package the label belongs to.
FastString -- identifier giving the prefix of the label
CmmLabelInfo -- encodes the suffix of the label
......@@ -553,7 +552,7 @@ mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo
-----
mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
mkCmmCodeLabel, mkCmmDataLabel, mkCmmClosureLabel
:: Unit -> FastString -> CLabel
:: UnitId -> FastString -> CLabel
mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo
mkCmmEntryLabel pkg str = CmmLabel pkg str CmmEntry
......@@ -584,7 +583,7 @@ mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off)
-- A call to some primitive hand written Cmm code
mkPrimCallLabel :: PrimCall -> CLabel
mkPrimCallLabel (PrimCall str pkg)
= CmmLabel pkg str CmmPrimCall
= CmmLabel (toUnitId pkg) str CmmPrimCall
-- Constructing ForeignLabels
......@@ -1033,7 +1032,7 @@ labelDynamic config this_mod lbl =
case lbl of
-- is the RTS in a DLL or not?
RtsLabel _ ->
externalDynamicRefs && (this_pkg /= rtsUnitId)
externalDynamicRefs && (this_pkg /= rtsUnit)
IdLabel n _ _ ->
externalDynamicRefs && isDynLinkName platform this_mod n
......@@ -1041,7 +1040,7 @@ labelDynamic config this_mod lbl =
-- When compiling in the "dyn" way, each package is to be linked into
-- its own shared library.
CmmLabel pkg _ _
| os == OSMinGW32 -> externalDynamicRefs && (this_pkg /= pkg)
| os == OSMinGW32 -> externalDynamicRefs && (toUnitId this_pkg /= pkg)
| otherwise -> externalDynamicRefs
LocalBlockLabel _ -> False
......
......@@ -377,7 +377,7 @@ cmmtop :: { CmmParse () }
| cmmdata { $1 }
| decl { $1 }
| 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
{% liftP . withThisPackage $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
do lits <- sequence $6;
staticClosure pkg $3 $5 (map getLit lits) }
......@@ -398,7 +398,7 @@ cmmdata :: { CmmParse () }
data_label :: { CmmParse CLabel }
: NAME ':'
{% liftP . withThisPackage $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
return (mkCmmDataLabel pkg $1) }
statics :: { [CmmParse [CmmStatic]] }
......@@ -455,14 +455,14 @@ maybe_body :: { CmmParse () }
info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
: NAME
{% liftP . withThisPackage $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
do newFunctionName $1 pkg
return (mkCmmCodeLabel pkg $1, Nothing, []) }
| 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, closure type, description, type
{% liftP . withThisPackage $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
do dflags <- getDynFlags
let prof = profilingInfo dflags $11 $13
rep = mkRTSRep (fromIntegral $9) $
......@@ -478,7 +478,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type
{% liftP . withThisPackage $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
do dflags <- getDynFlags
let prof = profilingInfo dflags $11 $13
ty = Fun 0 (ArgSpec (fromIntegral $15))
......@@ -496,7 +496,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, tag, closure type, description, type
{% liftP . withThisPackage $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
do dflags <- getDynFlags
let prof = profilingInfo dflags $13 $15
ty = Constr (fromIntegral $9) -- Tag
......@@ -515,7 +515,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
-- selector, closure type, description, type
{% liftP . withThisPackage $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
do dflags <- getDynFlags
let prof = profilingInfo dflags $9 $11
ty = ThunkSelector (fromIntegral $5)
......@@ -529,7 +529,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ')'
-- closure type (no live regs)
{% liftP . withThisPackage $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
do let prof = NoProfilingInfo
rep = mkRTSRep (fromIntegral $5) $ mkStackRep []
return (mkCmmRetLabel pkg $3,
......@@ -540,7 +540,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
-- closure type, live regs
{% liftP . withThisPackage $ \pkg ->
{% liftP . withHomeUnitId $ \pkg ->
do dflags <- getDynFlags
let platform = targetPlatform dflags
live <- sequence $7
......@@ -583,9 +583,9 @@ importName
| 'CLOSURE' NAME
{ ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }
-- A label imported with an explicit packageId.
-- A label imported with an explicit UnitId.
| STRING NAME
{ ($2, mkCmmCodeLabel (fsToUnit (mkFastString $1)) $2) }
{ ($2, mkCmmCodeLabel (UnitId (mkFastString $1)) $2) }
names :: { [FastString] }
......@@ -1163,7 +1163,7 @@ profilingInfo dflags desc_str ty_str
then NoProfilingInfo
else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)
staticClosure :: Unit -> FastString -> FastString -> [CmmLit] -> CmmParse ()
staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
staticClosure pkg cl_label info payload
= do dflags <- getDynFlags
let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
......
......@@ -728,7 +728,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
let optimizedCFG :: Maybe CFG
optimizedCFG =
optimizeCFG (cfgWeightInfo dflags) cmm <$!> postShortCFG
optimizeCFG (gopt Opt_CmmStaticPred dflags) (cfgWeightInfo dflags) cmm <$!> postShortCFG
maybeDumpCfg dflags optimizedCFG "CFG Weights - Final" proc_name
......
......@@ -240,7 +240,44 @@ import Control.Monad (foldM)
Assuming that Lwork is large the chance that the "call" ends up
in the same cache line is also fairly small.
-}
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
~~~ Note [Layout relevant edge weights]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The input to the chain based code layout algorithm is a CFG
with edges annotated with their frequency. The frequency
of traversal corresponds quite well to the cost of not placing
the connected blocks next to each other.
However even if having the same frequency certain edges are
inherently more or less relevant to code layout.
In particular:
* Edges which cross an info table are less relevant than others.
If we place the blocks across this edge next to each other
they are still separated by the info table which negates
much of the benefit. It makes it less likely both blocks
will share a cache line reducing the benefits from locality.
But it also prevents us from eliminating jump instructions.
* Conditional branches and switches are slightly less relevant.
We can completely remove unconditional jumps by placing them
next to each other. This is not true for conditional branch edges.
We apply a small modifier to them to ensure edges for which we can
eliminate the overhead completely are considered first. See also #18053.
* Edges constituted by a call are ignored.
Considering these hardly helped with performance and ignoring
them helps quite a bit to improve compiler performance.
So we perform a preprocessing step where we apply a multiplicator
to these kinds of edges.
-}
-- | Look at X number of blocks in two chains to determine
......@@ -636,35 +673,35 @@ sequenceChain :: forall a i. (Instruction i, Outputable i)
-> [GenBasicBlock i] -- ^ Blocks placed in sequence.
sequenceChain _info _weights [] = []
sequenceChain _info _weights [x] = [x]
sequenceChain info weights' blocks@((BasicBlock entry _):_) =
let weights :: CFG
weights = --pprTrace "cfg'" (pprEdgeWeights cfg')
cfg'
where
(_, globalEdgeWeights) = {-# SCC mkGlobalWeights #-} mkGlobalWeights entry weights'
cfg' = {-# SCC rewriteEdges #-}
mapFoldlWithKey
(\cfg from m ->
mapFoldlWithKey
(\cfg to w -> setEdgeWeight cfg (EdgeWeight w) from to )
cfg m )
weights'
globalEdgeWeights
directEdges :: [CfgEdge]
sequenceChain info weights blocks@((BasicBlock entry _):_) =
let directEdges :: [CfgEdge]
directEdges = sortBy (flip compare) $ catMaybes . map relevantWeight $ (infoEdgeList weights)
where
-- Apply modifiers to turn edge frequencies into useable weights
-- for computing code layout.
-- See also Note [Layout relevant edge weights]
relevantWeight :: CfgEdge -> Maybe CfgEdge
relevantWeight edge@(CfgEdge from to edgeInfo)
| (EdgeInfo CmmSource { trans_cmmNode = CmmCall {} } _) <- edgeInfo
-- Ignore edges across calls
-- Ignore edges across calls.
= Nothing
| mapMember to info
, w <- edgeWeight edgeInfo
-- The payoff is small if we jump over an info table
-- The payoff is quite small if we jump over an info table
= Just (CfgEdge from to edgeInfo { edgeWeight = w/8 })
| (EdgeInfo CmmSource { trans_cmmNode = exitNode } _) <- edgeInfo
, cantEliminate exitNode
, w <- edgeWeight edgeInfo
-- A small penalty to edge types which
-- we can't optimize away by layout.
-- w * 0.96875 == w - w/32
= Just (CfgEdge from to edgeInfo { edgeWeight = w * 0.96875 })
| otherwise
= Just edge
where
cantEliminate CmmCondBranch {} = True
cantEliminate CmmSwitch {} = True
cantEliminate _ = False
blockMap :: LabelMap (GenBasicBlock i)
blockMap
......
......@@ -670,11 +670,21 @@ findBackEdges root cfg =
typedEdges =
classifyEdges root getSuccs edges :: [((BlockId,BlockId),EdgeType)]
optimizeCFG :: D.CfgWeights -> RawCmmDecl -> CFG -> CFG
optimizeCFG _ (CmmData {}) cfg = cfg
optimizeCFG weights (CmmProc info _lab _live graph) cfg =
{-# SCC optimizeCFG #-}
optimizeCFG :: Bool -> D.CfgWeights -> RawCmmDecl -> CFG -> CFG
optimizeCFG _ _ (CmmData {}) cfg = cfg
optimizeCFG doStaticPred weights proc@(CmmProc _info _lab _live graph) cfg =
(if doStaticPred then staticPredCfg (g_entry graph) else id) $
optHsPatterns weights proc $ cfg
-- | Modify branch weights based on educated guess on
-- patterns GHC tends to produce and how they affect
-- performance.
--
-- Most importantly we penalize jumps across info tables.
optHsPatterns :: D.CfgWeights -> RawCmmDecl -> CFG -> CFG
optHsPatterns _ (CmmData {}) cfg = cfg
optHsPatterns weights (CmmProc info _lab _live graph) cfg =
{-# SCC optHsPatterns #-}
-- pprTrace "Initial:" (pprEdgeWeights cfg) $
-- pprTrace "Initial:" (ppr $ mkGlobalWeights (g_entry graph) cfg) $
......@@ -749,6 +759,21 @@ optimizeCFG weights (CmmProc info _lab _live graph) cfg =
| CmmSource { trans_cmmNode = CmmCondBranch {} } <- source = True
| otherwise = False
-- | Convert block-local branch weights to global weights.
staticPredCfg :: BlockId -> CFG -> CFG
staticPredCfg entry cfg = cfg'
where
(_, globalEdgeWeights) = {-# SCC mkGlobalWeights #-}
mkGlobalWeights entry cfg
cfg' = {-# SCC rewriteEdges #-}
mapFoldlWithKey
(\cfg from m ->
mapFoldlWithKey
(\cfg to w -> setEdgeWeight cfg (EdgeWeight w) from to )
cfg m )
cfg
globalEdgeWeights
-- | Determine loop membership of blocks based on SCC analysis
-- This is faster but only gives yes/no answers.
loopMembers :: HasDebugCallStack => CFG -> LabelMap Bool
......@@ -922,6 +947,10 @@ revPostorderFrom cfg root =
-- reverse post order. Which is required for diamond control flow to work probably.
--
-- We also apply a few prediction heuristics (based on the same paper)
--
-- The returned result represents frequences.
-- For blocks it's the expected number of executions and
-- for edges is the number of traversals.
{-# NOINLINE mkGlobalWeights #-}
{-# SCC mkGlobalWeights #-}
......
......@@ -37,7 +37,10 @@ import GHC.CmmToAsm.Config
-- (for allocation purposes, anyway).
--
data RegUsage
= RU [Reg] [Reg]
= RU {
reads :: [Reg],
writes :: [Reg]
}
-- | No regs read or written to.
noUsage :: RegUsage
......
......@@ -149,7 +149,7 @@ mkNatM_State us delta dflags this_mod
initConfig :: DynFlags -> NCGConfig
initConfig dflags = NCGConfig
{ ncgPlatform = targetPlatform dflags
, ncgUnitId = thisPackage dflags
, ncgUnitId = homeUnit dflags
, ncgProcAlignment = cmmProcAlignment dflags
, ncgDebugLevel = debugLevel dflags
, ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
......
{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}
{-# LANGUAGE ConstraintKinds #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
......@@ -137,6 +138,7 @@ import GHC.Platform
import Data.Maybe
import Data.List
import Control.Monad
import Control.Applicative
-- -----------------------------------------------------------------------------
-- Top level of the register allocator
......@@ -229,8 +231,13 @@ linearRegAlloc config entry_ids block_live sccs
go f = linearRegAlloc' config f entry_ids block_live sccs
platform = ncgPlatform config
-- | Constraints on the instruction instances used by the
-- linear allocator.
type OutputableRegConstraint freeRegs instr =
(FR freeRegs, Outputable freeRegs, Outputable instr, Instruction instr)
linearRegAlloc'
:: (FR freeRegs, Outputable instr, Instruction instr)
:: OutputableRegConstraint freeRegs instr
=> NCGConfig
-> freeRegs
-> [BlockId] -- ^ entry points
......@@ -246,7 +253,7 @@ linearRegAlloc' config initFreeRegs entry_ids block_live sccs
return (blocks, stats, getStackUse stack)
linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr)
linearRA_SCCs :: OutputableRegConstraint freeRegs instr
=> [BlockId]
-> BlockMap RegSet
-> [NatBasicBlock instr]
......@@ -281,7 +288,7 @@ linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs)
more sanity checking to guard against this eventuality.
-}
process :: (FR freeRegs, Instruction instr, Outputable instr)
process :: OutputableRegConstraint freeRegs instr
=> [BlockId]
-> BlockMap RegSet
-> [GenBasicBlock (LiveInstr instr)]
......@@ -325,15 +332,18 @@ process entry_ids block_live (b@(BasicBlock id _) : blocks)
-- | Do register allocation on this basic block
--
processBlock
:: (FR freeRegs, Outputable instr, Instruction instr)
:: OutputableRegConstraint freeRegs instr
=> BlockMap RegSet -- ^ live regs on entry to each basic block
-> LiveBasicBlock instr -- ^ block to do register allocation on
-> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated
processBlock block_live (BasicBlock id instrs)
= do initBlock id block_live
= do -- pprTraceM "processBlock" $ text "" $$ ppr (BasicBlock id instrs)
initBlock id block_live
(instrs', fixups)
<- linearRA block_live [] [] id instrs
-- pprTraceM "blockResult" $ ppr (instrs', fixups)
return $ BasicBlock id instrs' : fixups
......@@ -369,7 +379,7 @@ initBlock id block_live
-- | Do allocation for a sequence of instructions.
linearRA
:: (FR freeRegs, Outputable instr, Instruction instr)
:: OutputableRegConstraint freeRegs instr
=> BlockMap RegSet -- ^ map of what vregs are live on entry to each block.
-> [instr] -- ^ accumulator for instructions already processed.
-> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code.
......@@ -396,7 +406,7 @@ linearRA block_live accInstr accFixups id (instr:instrs)
-- | Do allocation for a single instruction.
raInsn
:: (FR freeRegs, Outputable instr, Instruction instr)
:: OutputableRegConstraint freeRegs instr
=> BlockMap RegSet -- ^ map of what vregs are love on entry to each block.
-> [instr] -- ^ accumulator for instructions already processed.
-> BlockId -- ^ the id of the current block, for debugging
......@@ -476,7 +486,7 @@ isInReg src assig | Just (InReg _) <- lookupUFM assig src = True
| otherwise = False
genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr)
genRaInsn :: OutputableRegConstraint freeRegs instr
=> BlockMap RegSet
-> [instr]
-> BlockId
......@@ -486,6 +496,7 @@ genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr)
-> RegM freeRegs ([instr], [NatBasicBlock instr])
genRaInsn block_live new_instrs block_id instr r_dying w_dying = do
-- pprTraceM "genRaInsn" $ ppr (block_id, instr)
platform <- getPlatform
case regUsageOfInstr platform instr of { RU read written ->
do
......@@ -525,6 +536,8 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = do
(fixup_blocks, adjusted_instr)
<- joinToTargets block_live block_id instr
-- when (not $ null fixup_blocks) $ pprTraceM "genRA:FixBlocks" $ ppr fixup_blocks
-- Debugging - show places where the reg alloc inserted
-- assignment fixup blocks.
-- when (not $ null fixup_blocks) $
......@@ -737,7 +750,7 @@ data SpillLoc = ReadMem StackSlot -- reading from register only in memory
-- the list of free registers and free stack slots.
allocateRegsAndSpill
:: (FR freeRegs, Outputable instr, Instruction instr)
:: forall freeRegs instr. (FR freeRegs, Outputable instr, Instruction instr)
=> Bool -- True <=> reading (load up spilled regs)
-> [VirtualReg] -- don't push these out
-> [instr] -- spill insns
......@@ -749,7 +762,8 @@ allocateRegsAndSpill _ _ spills alloc []
= return (spills, reverse alloc)
allocateRegsAndSpill reading keep spills alloc (r:rs)
= do assig <- getAssigR
= do assig <- getAssigR :: RegM freeRegs (RegMap Loc)
-- pprTraceM "allocateRegsAndSpill:assig" (ppr (r:rs) $$ ppr assig)
let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig
case lookupUFM assig r of
-- case (1a): already in a register
......@@ -779,6 +793,26 @@ allocateRegsAndSpill reading keep spills alloc (r:rs)
| otherwise -> doSpill WriteNew
-- | Given a virtual reg find a preferred real register.
-- The preferred register is simply the first one the variable
-- was assigned to (if any). This way when we allocate for a loop
-- variables are likely to end up in the same registers at the
-- end and start of the loop, avoiding redundant reg-reg moves.
-- Note: I tried returning a list of past assignments, but that
-- turned out to barely matter but added a few tenths of
-- a percent to compile time.
findPrefRealReg :: forall freeRegs u. Uniquable u
=> u -> RegM freeRegs (Maybe RealReg)
findPrefRealReg vreg = do
bassig <- getBlockAssigR :: RegM freeRegs (BlockMap (freeRegs,RegMap Loc))
return $ foldr (findVirtRegAssig) Nothing bassig
where
findVirtRegAssig :: (freeRegs,RegMap Loc) -> Maybe RealReg -> Maybe RealReg
findVirtRegAssig assig z =
z <|> case lookupUFM (snd assig) vreg of
Just (InReg real_reg) -> Just real_reg
Just (InBoth real_reg _) -> Just real_reg
_ -> z
-- reading is redundant with reason, but we keep it around because it's
-- convenient and it maintains the recursive structure of the allocator. -- EZY
......@@ -795,18 +829,26 @@ allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr)
allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
= do platform <- getPlatform
freeRegs <- getFreeRegsR
let freeRegs_thisClass = frGetFreeRegs platform (classOfVirtualReg r) freeRegs
let freeRegs_thisClass = frGetFreeRegs platform (classOfVirtualReg r) freeRegs :: [RealReg]
case freeRegs_thisClass of
-- Can we put the variable into a register it already was?
pref_reg <- findPrefRealReg r
case freeRegs_thisClass of
-- case (2): we have a free register
(my_reg : _) ->
do spills' <- loadTemp r spill_loc my_reg spills
(first_free : _) ->
do let final_reg
| Just reg <- pref_reg
, reg `elem` freeRegs_thisClass
= reg
| otherwise
= first_free
spills' <- loadTemp r spill_loc final_reg spills
setAssigR (addToUFM assig r $! newLocation spill_loc my_reg)
setFreeRegsR $ frAllocateReg platform my_reg freeRegs
setAssigR (addToUFM assig r $! newLocation spill_loc final_reg)
setFreeRegsR $ frAllocateReg platform final_reg freeRegs
allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs
allocateRegsAndSpill reading keep spills' (final_reg : alloc) rs
-- case (3): we need to push something out to free up a register
......@@ -814,7 +856,8 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
do let inRegOrBoth (InReg _) = True
inRegOrBoth (InBoth _ _) = True
inRegOrBoth _ = False
let candidates' =
let candidates' :: UniqFM Loc
candidates' =
flip delListFromUFM keep $
filterUFM inRegOrBoth $
assig
......
......@@ -30,6 +30,7 @@ import GHC.Types.Unique.FM
import GHC.Types.Unique.Supply
import GHC.Cmm.BlockId
data ReadingOrWriting = Reading | Writing deriving (Eq,Ord)
-- | Used to store the register assignment on entry to a basic block.
-- We use this to handle join points, where multiple branch instructions
......@@ -138,6 +139,8 @@ data RA_State freeRegs
, ra_config :: !NCGConfig
-- | (from,fixup,to) : We inserted fixup code between from and to
, ra_fixups :: [(BlockId,BlockId,BlockId)] }
, ra_fixups :: [(BlockId,BlockId,BlockId)]
}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Free regs map for PowerPC
module GHC.CmmToAsm.Reg.Linear.PPC where
......@@ -27,6 +29,9 @@ import Data.Bits
data FreeRegs = FreeRegs !Word32 !Word32
deriving( Show ) -- The Show is used in an ASSERT
instance Outputable FreeRegs where
ppr = text . show
noFreeRegs :: FreeRegs
noFreeRegs = FreeRegs 0 0
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Free regs map for SPARC
module GHC.CmmToAsm.Reg.Linear.SPARC where
......@@ -38,6 +39,9 @@ data FreeRegs
instance Show FreeRegs where
show = showFreeRegs
instance Outputable FreeRegs where
ppr = text . showFreeRegs
-- | A reg map where no regs are free to be allocated.
noFreeRegs :: FreeRegs
noFreeRegs = FreeRegs 0 0 0
......
{-# LANGUAGE CPP, PatternSynonyms, DeriveFunctor #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if !defined(GHC_LOADED_INTO_GHCI)
{-# LANGUAGE UnboxedTuples #-}
......
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Free regs map for i386
module GHC.CmmToAsm.Reg.Linear.X86 where
......@@ -9,12 +10,13 @@ import GHC.Platform.Reg.Class
import GHC.Platform.Reg
import GHC.Utils.Panic
import GHC.Platform
import GHC.Utils.Outputable
import Data.Word
import Data.Bits
newtype FreeRegs = FreeRegs Word32
deriving Show
deriving (Show,Outputable)
noFreeRegs :: FreeRegs
noFreeRegs = FreeRegs 0
......
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Free regs map for x86_64
module GHC.CmmToAsm.Reg.Linear.X86_64 where
......@@ -9,12 +10,13 @@ import GHC.Platform.Reg.Class
import GHC.Platform.Reg
import GHC.Utils.Panic
import GHC.Platform
import GHC.Utils.Outputable
import Data.Word
import Data.Bits
newtype FreeRegs = FreeRegs Word64
deriving Show
deriving (Show,Outputable)
noFreeRegs :: FreeRegs
noFreeRegs = FreeRegs 0
......
......@@ -129,6 +129,10 @@ pprTop dflags = \case
pprDataExterns platform lits $$
pprWordArray dflags (isSecConstant section) lbl lits
where
isSecConstant section = case sectionProtection section of
ReadOnlySection -> True
WriteProtectedSection -> True
_ -> False
platform = targetPlatform dflags
-- --------------------------------------------------------------------------
......
......@@ -83,7 +83,8 @@ genLlvmData (sec, CmmStaticsRaw lbl xs) = do
Section CString _ -> if (platformArch platform == ArchS390X)
then Just 2 else Just 1
_ -> Nothing