...
 
Commits (79)
......@@ -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
......
......@@ -178,7 +178,7 @@ module GHC (
isRecordSelector,
isPrimOpId, isFCallId, isClassOpId_maybe,
isDataConWorkId, idDataCon,
isBottomingId, isDictonaryId,
isDeadEndId, isDictonaryId,
recordSelectorTyCon,
-- ** Type constructors
......@@ -597,8 +597,7 @@ checkBrokenTablesNextToCode' dflags
setSessionDynFlags :: GhcMonad m => DynFlags -> m [UnitId]
setSessionDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
dflags'' <- liftIO $ interpretPackageEnv dflags'
(dflags''', preload) <- liftIO $ initPackages dflags''
(dflags''', preload) <- liftIO $ initPackages dflags'
-- Interpreter
interp <- if gopt Opt_ExternalInterpreter dflags
......@@ -715,7 +714,11 @@ getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))
parseDynamicFlags :: MonadIO m =>
DynFlags -> [Located String]
-> m (DynFlags, [Located String], [Warn])
parseDynamicFlags = parseDynamicFlagsCmdLine
parseDynamicFlags dflags cmdline = do
(dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline
dflags2 <- liftIO $ interpretPackageEnv dflags1
return (dflags2, leftovers, warns)
-- | Checks the set of new DynFlags for possibly erroneous option
-- combinations when invoking 'setSessionDynFlags' and friends, and if
......
......@@ -511,7 +511,7 @@ genericTyConNames = [
pRELUDE :: Module
pRELUDE = mkBaseModule_ pRELUDE_NAME
gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
gHC_PRIM, gHC_PRIM_PANIC, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM,
gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,
gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_INTEGER_TYPE, gHC_NATURAL,
......@@ -527,6 +527,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE :: Module
gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values
gHC_PRIM_PANIC = mkPrimModule (fsLit "GHC.Prim.Panic")
gHC_TYPES = mkPrimModule (fsLit "GHC.Types")
gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic")
gHC_CSTRING = mkPrimModule (fsLit "GHC.CString")
......
......@@ -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,
......@@ -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))
......
......@@ -399,9 +399,23 @@ funTyConName = mkPrimTyConName (fsLit "->") funTyConKey funTyCon
-- | The @(->)@ type constructor.
--
-- @
-- (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep).
-- TYPE rep1 -> TYPE rep2 -> *
-- (->) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.
-- TYPE rep1 -> TYPE rep2 -> Type
-- @
--
-- The runtime representations quantification is left inferred. This
-- means they cannot be specified with @-XTypeApplications@.
--
-- This is a deliberate choice to allow future extensions to the
-- function arrow. To allow visible application a type synonym can be
-- defined:
--
-- @
-- type Arr :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep).
-- TYPE rep1 -> TYPE rep2 -> Type
-- type Arr = (->)
-- @
--
funTyCon :: TyCon
funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm
where
......
......@@ -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 }
......@@ -2567,14 +2567,17 @@ section "Exceptions"
------------------------------------------------------------------------
-- Note [Strictness for mask/unmask/catch]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Consider this example, which comes from GHC.IO.Handle.Internals:
-- wantReadableHandle3 f ma b st
-- = case ... of
-- DEFAULT -> case ma of MVar a -> ...
-- 0# -> maskAsynchExceptions# (\st -> case ma of MVar a -> ...)
-- 0# -> maskAsyncExceptions# (\st -> case ma of MVar a -> ...)
-- The outer case just decides whether to mask exceptions, but we don't want
-- thereby to hide the strictness in 'ma'! Hence the use of strictApply1Dmd.
-- thereby to hide the strictness in 'ma'! Hence the use of strictApply1Dmd
-- in mask and unmask. But catch really is lazy in its first argument, see
-- #11555. So for IO actions 'ma' we often use a wrapper around it that is
-- head-strict in 'ma': GHC.IO.catchException.
primop CatchOp "catch#" GenPrimOp
(State# RealWorld -> (# State# RealWorld, a #) )
......@@ -2593,13 +2596,16 @@ primop RaiseOp "raise#" GenPrimOp
b -> o
-- NB: the type variable "o" is "a", but with OpenKind
with
-- In contrast to 'raiseIO#', which throws a *precise* exception,
-- exceptions thrown by 'raise#' are considered *imprecise*.
-- See Note [Precise vs imprecise exceptions] in GHC.Types.Demand.
-- Hence, it has 'botDiv', not 'exnDiv'.
-- For the same reasons, 'raise#' is marked as "can_fail" (which 'raiseIO#'
-- is not), but not as "has_side_effects" (which 'raiseIO#' is).
-- See Note [PrimOp can_fail and has_side_effects] in PrimOp.hs.
strictness = { \ _arity -> mkClosedStrictSig [topDmd] botDiv }
out_of_line = True
has_side_effects = True
-- raise# certainly throws a Haskell exception and hence has_side_effects
-- It doesn't actually make much difference because the fact that it
-- returns bottom independently ensures that we are careful not to discard
-- it. But still, it's better to say the Right Thing.
can_fail = True
-- Note [Arithmetic exception primops]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -2648,8 +2654,8 @@ primop RaiseIOOp "raiseIO#" GenPrimOp
a -> State# RealWorld -> (# State# RealWorld, b #)
with
-- See Note [Precise exceptions and strictness analysis] in Demand.hs
-- for why we give it topDiv
-- strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd] topDiv }
-- for why this is the *only* primop that has 'exnDiv'
strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd] exnDiv }
out_of_line = True
has_side_effects = True
......
......@@ -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
......@@ -1170,11 +1169,11 @@ instance Outputable CLabel where
pprCLabel :: DynFlags -> CLabel -> SDoc
pprCLabel dflags = \case
(LocalBlockLabel u) -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u
(LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
(AsmTempLabel u)
| not (platformUnregisterised platform)
-> tempLabelPrefixOrUnderscore <> pprUniqueAlways u
-> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
(AsmTempDerivedLabel l suf)
| useNCG
......@@ -1232,8 +1231,8 @@ pprCLabel dflags = \case
pprCLbl :: DynFlags -> CLabel -> SDoc
pprCLbl dflags = \case
(StringLitLabel u) -> pprUniqueAlways u <> text "_str"
(SRTLabel u) -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt"
(LargeBitmapLabel u) -> tempLabelPrefixOrUnderscore
(SRTLabel u) -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u <> pp_cSEP <> text "srt"
(LargeBitmapLabel u) -> tempLabelPrefixOrUnderscore platform
<> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"
-- Some bitmaps for tuple constructors have a numeric tag (e.g. '7')
-- until that gets resolved we'll just force them to start
......@@ -1243,7 +1242,7 @@ pprCLbl dflags = \case
(CmmLabel _ str CmmData) -> ftext str
(CmmLabel _ str CmmPrimCall) -> ftext str
(LocalBlockLabel u) -> tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u
(LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u
(RtsLabel (RtsApFast str)) -> ftext str <> text "_fast"
......@@ -1291,7 +1290,7 @@ pprCLbl dflags = \case
(ForeignLabel str _ _ _) -> ftext str
(IdLabel name _cafs flavor) -> internalNamePrefix name <> ppr name <> ppIdFlavor flavor
(IdLabel name _cafs flavor) -> internalNamePrefix platform name <> ppr name <> ppIdFlavor flavor
(CC_Label cc) -> ppr cc
(CCS_Label ccs) -> ppr ccs
......@@ -1302,6 +1301,8 @@ pprCLbl dflags = \case
(DynamicLinkerLabel {}) -> panic "pprCLbl DynamicLinkerLabel"
(PicBaseLabel {}) -> panic "pprCLbl PicBaseLabel"
(DeadStripPreventer {}) -> panic "pprCLbl DeadStripPreventer"
where
platform = targetPlatform dflags
ppIdFlavor :: IdLabelInfo -> SDoc
ppIdFlavor x = pp_cSEP <> text
......@@ -1332,21 +1333,20 @@ instance Outputable ForeignLabelSource where
ForeignLabelInThisPackage -> parens $ text "this package"
ForeignLabelInExternalPackage -> parens $ text "external package"
internalNamePrefix :: Name -> SDoc
internalNamePrefix name = getPprStyle $ \ sty ->
internalNamePrefix :: Platform -> Name -> SDoc
internalNamePrefix platform name = getPprStyle $ \ sty ->
if asmStyle sty && isRandomGenerated then
sdocWithDynFlags $ \dflags ->
ptext (asmTempLabelPrefix (targetPlatform dflags))
ptext (asmTempLabelPrefix platform)
else
empty
where
isRandomGenerated = not $ isExternalName name
tempLabelPrefixOrUnderscore :: SDoc
tempLabelPrefixOrUnderscore = sdocWithDynFlags $ \dflags ->
tempLabelPrefixOrUnderscore :: Platform -> SDoc
tempLabelPrefixOrUnderscore platform =
getPprStyle $ \ sty ->
if asmStyle sty then
ptext (asmTempLabelPrefix (targetPlatform dflags))
ptext (asmTempLabelPrefix platform)
else
char '_'
......
......@@ -459,7 +459,7 @@ type CAFSet = Set CAFLabel
type CAFEnv = LabelMap CAFSet
mkCAFLabel :: CLabel -> CAFLabel
mkCAFLabel lbl = CAFLabel $! toClosureLbl lbl
mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)
-- This is a label that we can put in an SRT. It *must* be a closure label,
-- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.
......@@ -736,10 +736,11 @@ getStaticFuns decls =
type SRTMap = Map CAFLabel (Maybe SRTEntry)
-- | Given SRTMap of a module returns the set of non-CAFFY names in the module.
-- Any Names not in the set are CAFFY.
srtMapNonCAFs :: SRTMap -> NameSet
srtMapNonCAFs srtMap = mkNameSet (mapMaybe get_name (Map.toList srtMap))
-- | Given 'SRTMap' of a module, returns the set of non-CAFFY names in the
-- module. Any 'Name's not in the set are CAFFY.
srtMapNonCAFs :: SRTMap -> NonCaffySet
srtMapNonCAFs srtMap =
NonCaffySet $ mkNameSet (mapMaybe get_name (Map.toList srtMap))
where
get_name (CAFLabel l, Nothing) = hasHaskellName l
get_name (_l, Just _srt_entry) = Nothing
......
......@@ -69,6 +69,7 @@ cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]
MO_SF_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to)
MO_SS_Conv from to -> CmmLit (CmmInt (narrowS from x) to)
MO_UU_Conv from to -> CmmLit (CmmInt (narrowU from x) to)
MO_XX_Conv from to -> CmmLit (CmmInt (narrowS from x) to)
_ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op
......@@ -76,6 +77,7 @@ cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]
-- Eliminate conversion NOPs
cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
cmmMachOpFoldM _ (MO_XX_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
-- Eliminate nested conversions where possible
cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]]
......
......@@ -46,9 +46,6 @@ module GHC.Cmm.Utils(
baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,
currentTSOExpr, currentNurseryExpr, cccsExpr,
-- Statics
blankWord,
-- Tagging
cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,
cmmConstrTag1,
......@@ -380,9 +377,6 @@ cmmNegate platform = \case
-> CmmLit (CmmInt (-n) rep)
e -> CmmMachOp (MO_S_Neg (cmmExprWidth platform e)) [e]
blankWord :: Platform -> CmmStatic
blankWord platform = CmmUninitialised (platformWordSizeInBytes platform)
cmmToWord :: Platform -> CmmExpr -> CmmExpr
cmmToWord platform e
| w == word = e
......
......@@ -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
......
......@@ -2,8 +2,6 @@ module GHC.CmmToAsm.PPC.Cond (
Cond(..),
condNegate,
condUnsigned,
condToSigned,
condToUnsigned,
)
where
......@@ -47,17 +45,3 @@ condUnsigned LU = True
condUnsigned GEU = True
condUnsigned LEU = True
condUnsigned _ = False
condToSigned :: Cond -> Cond
condToSigned GU = GTT
condToSigned LU = LTT
condToSigned GEU = GE
condToSigned LEU = LE
condToSigned x = x
condToUnsigned :: Cond -> Cond
condToUnsigned GTT = GU
condToUnsigned LTT = LU
condToUnsigned GE = GEU
condToUnsigned LE = LEU
condToUnsigned x = x
......@@ -554,8 +554,9 @@ delAssoc :: (Uniquable a)
delAssoc a m
| Just aSet <- lookupUFM m a
, m1 <- delFromUFM m a
= nonDetFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet
-- It's OK to use nonDetFoldUFM here because deletion is commutative
= nonDetStrictFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet
-- It's OK to use a non-deterministic fold here because deletion is
-- commutative
| otherwise = m
......
{-# 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)