...
 
Commits (39)
  • Ryan Scott's avatar
    Remove duplicate Note [When to print foralls] in GHC.Core.TyCo.Ppr · 5bcf8606
    Ryan Scott authored
    There are two different Notes named `[When to print foralls]`. The
    most up-to-date one is in `GHC.Iface.Type`, but there is a second
    one in `GHC.Core.TyCo.Ppr`. The latter is less up-to-date, as it was
    written before GHC switched over to using ifaces to pretty-print
    types. I decided to just remove the latter and replace it with a
    reference to the former.
    
    [ci skip]
    5bcf8606
  • Fumiaki Kinoshita's avatar
    base: Add Generic instances to various datatypes under GHC.* · 55f0e783
    Fumiaki Kinoshita authored
    * GHC.Fingerprint.Types: Fingerprint
    * GHC.RTS.Flags: GiveGCStats, GCFlags, ConcFlags, DebugFlags, CCFlags, DoHeapProfile, ProfFlags, DoTrace, TraceFlags, TickyFlags, ParFlags and RTSFlags
    * GHC.Stats: RTSStats and GCStats
    * GHC.ByteOrder: ByteOrder
    * GHC.Unicode: GeneralCategory
    * GHC.Stack.Types: SrcLoc
    
    Metric Increase:
        haddock.base
    55f0e783
  • Gert-Jan Bottu's avatar
    Explicit Specificity · a9311cd5
    Gert-Jan Bottu authored
    Implementation for Ticket #16393.
    Explicit specificity allows users to manually create inferred type variables,
    by marking them with braces.
    This way, the user determines which variables can be instantiated through
    visible type application.
    
    The additional syntax is included in the parser, allowing users to write
    braces in type variable binders (type signatures, data constructors etc).
    This information is passed along through the renamer and verified in the
    type checker.
    The AST for type variable binders, data constructors, pattern synonyms,
    partial signatures and Template Haskell has been updated to include the
    specificity of type variables.
    
    Minor notes:
    - Bumps haddock submodule
    - Disables pattern match checking in GHC.Iface.Type with GHC 8.8
    a9311cd5
  • Ben Price's avatar
    Lint should say when it is checking a rule · 24e61aad
    Ben Price authored
    It is rather confusing that when lint finds an error in a rule attached
    to a binder, it reports the error as in the RHS, not the rule:
      ...
      In the RHS of foo
    
    We add a clarifying line:
      ...
      In the RHS of foo
      In a rule attached to foo
    
    The implication that the rule lives inside the RHS is a bit odd, but
    this niggle is already present for unfoldings, whose pattern we are
    following.
    24e61aad
  • Ben Gamari's avatar
    nonmoving: Optimise the write barrier · 78c6523c
    Ben Gamari authored
    78c6523c
  • Andreas Klebinger's avatar
    Refactor linear reg alloc to remember past assignments. · 13f6c9d0
    Andreas Klebinger authored
    When assigning registers we now first try registers we
    assigned to in the past, instead of picking the "first"
    one.
    
    This is in extremely helpful when dealing with loops for
    which variables are dead for part of the loop.
    
    This is important for patterns like this:
    
            foo = arg1
        loop:
            use(foo)
            ...
            foo = getVal()
            goto loop;
    
    There we:
    * assign foo to the register of arg1.
    * use foo, it's dead after this use as it's overwritten after.
    * do other things.
    * look for a register to put foo in.
    
    If we pick an arbitrary one it might differ from the register the
    start of the loop expect's foo to be in.
    To fix this we simply look for past register assignments for
    the given variable. If we find one and the register is free we
    use that register.
    
    This reduces the need for fixup blocks which match the register
    assignment between blocks. In the example above between the end
    and the head of the loop.
    
    This patch also moves branch weight estimation ahead of register
    allocation and adds a flag to control it (cmm-static-pred).
    * It means the linear allocator is more likely to assign the hotter
      code paths first.
    * If it assign these first we are:
      + Less likely to spill on the hot path.
      + Less likely to introduce fixup blocks on the hot path.
    
    These two measure combined are surprisingly effective. Based on nofib
    we get in the mean:
    
    * -0.9% instructions executed
    * -0.1% reads/writes
    * -0.2% code size.
    * -0.1% compiler allocations.
    * -0.9% compile time.
    * -0.8% runtime.
    
    Most of the benefits are simply a result of removing redundant moves
    and spills.
    
    Reduced compiler allocations likely are the result of less code being
    generated. (The added lookup is mostly non-allocating).
    13f6c9d0
  • Andreas Klebinger's avatar
    NCG: Codelayout: Distinguish conditional and other branches. · edc2cc58
    Andreas Klebinger authored
    In #18053 we ended up with a suboptimal code layout because
    the code layout algorithm didn't distinguish between conditional
    and unconditional control flow.
    
    We can completely eliminate unconditional control flow instructions
    by placing blocks next to each other, not so much for conditionals.
    
    In terms of implementation we simply give conditional branches less
    weight before computing the layout.
    
    Fixes #18053
    edc2cc58
  • Gleb Popov's avatar
    gitlab-ci: Set locale to C.UTF-8. · b7a6b2f4
    Gleb Popov authored
    b7a6b2f4
  • Stefan Holdermans's avatar
    Allow spaces in GHCi :script file names · a8c27cf6
    Stefan Holdermans authored
    This patch updates the user interface of GHCi so that file names passed
    to the ':script' command may contain spaces escaped with a backslash.
    
    For example:
    
      :script foo\ bar.script
    
    The implementation uses a modified version of 'words' that does not
    break on escaped spaces.
    
    Fixes #18027.
    a8c27cf6
  • Stefan Holdermans's avatar
    Add extra tests for GHCi :script syntax checks · 82663959
    Stefan Holdermans authored
    The syntax for GHCi's ":script" command allows for only a single file
    name to be passed as an argument. This patch adds a test for the cases
    in which a file name is missing or multiple file names are passed.
    
    Related to #T18027.
    82663959
  • Stefan Holdermans's avatar
    Allow GHCi :script file names in double quotes · a0b79e1b
    Stefan Holdermans authored
    This patch updates the user interface of GHCi so that file names passed
    to the ':script' command can be wrapped in double quotes.
    
    For example:
    
      :script "foo bar.script"
    
    The implementation uses a modified version of 'words' that treats
    character sequences enclosed in double quotes as single words.
    
    Fixes #18027.
    a0b79e1b
  • Stefan Holdermans's avatar
    Update documentation for GHCi :script · cf566330
    Stefan Holdermans authored
    This patch adds the fixes that allow for file names containing spaces to
    be passed to GHCi's ':script' command to the release notes for 8.12 and
    expands the user-guide documentation for ':script' by mentioning how
    such file names can be passed.
    
    Related to #18027.
    cf566330
  • Tuan Le's avatar
  • John Ericson's avatar
    Use `Checker` for `tc_pat` · 964d3ea2
    John Ericson authored
    964d3ea2
  • John Ericson's avatar
    Use `Checker` for `tc_lpat` and `tc_lpats` · b797aa42
    John Ericson authored
    b797aa42
  • John Ericson's avatar
    More judiciously panic in `ts_pat` · 5108e84a
    John Ericson authored
    5108e84a
  • John Ericson's avatar
    510e0451
  • John Ericson's avatar
    Tiny cleaup eta-reduce away a function argument · cb4231db
    John Ericson authored
    In GHC, not in the code being compiled!
    cb4231db
  • John Ericson's avatar
    6890c38d
  • Vilem-Benjamin Liepelt's avatar
    Fix spelling mistakes and typos · 3451584f
    Vilem-Benjamin Liepelt authored
    3451584f
  • Vilem-Benjamin Liepelt's avatar
    Add INLINABLE pragmas to Enum list producers · b552e531
    Vilem-Benjamin Liepelt authored
    The INLINABLE pragmas ensure that we export stable (unoptimised) unfoldings in
    the interface file so we can do list fusion at usage sites.
    
    Related tickets: #15185, #8763, #18178.
    b552e531
  • Vilem-Benjamin Liepelt's avatar
    Piggyback on Enum Word methods for Word64 · e7480063
    Vilem-Benjamin Liepelt authored
    If we are on a 64 bit platform, we can use the efficient Enum Word
    methods for the Enum Word64 instance.
    e7480063
  • Vilem-Benjamin Liepelt's avatar
  • Richard Eisenberg's avatar
    MR template should ask for key part · 2b363ebb
    Richard Eisenberg authored
    2b363ebb
  • Sebastian Graf's avatar
    Make `Int`'s `mod` and `rem` strict in their first arguments · a95bbd0b
    Sebastian Graf authored
    They used to be strict until 4d2ac2d4 (9 years ago).
    
    It's obviously better to be strict for performance reasons.
    It also blocks #18067.
    
    NoFib results:
    
    ```
    --------------------------------------------------------------------------------
            Program         Allocs    Instrs
    --------------------------------------------------------------------------------
            integer          -1.1%     +0.4%
       wheel-sieve2         +21.2%    +20.7%
    --------------------------------------------------------------------------------
                Min          -1.1%     -0.0%
                Max         +21.2%    +20.7%
     Geometric Mean          +0.2%     +0.2%
    ```
    
    The regression in `wheel-sieve2` is due to reboxing that likely will go
    away with the resolution of #18067. See !3282 for details.
    
    Fixes #18187.
    a95bbd0b
  • Galen Huntington's avatar
    d3d055b8
  • Alexey Kuleshevich's avatar
    Fix wording in primops documentation to reflect the correct reasoning: · 1b508a9e
    Alexey Kuleshevich authored
    * Besides resizing functions, shrinking ones also mutate the
      size of a mutable array and because of those two `sizeofMutabeByteArray`
      and `sizeofSmallMutableArray` are now deprecated
    * Change reference in documentation to the newer functions `getSizeof*`
      instead of `sizeof*` for shrinking functions
    * Fix incorrect mention of "byte" instead of "small"
    1b508a9e
  • Andreas Klebinger's avatar
    Don't variable-length encode magic iface constant. · 4ca0c8a1
    Andreas Klebinger authored
    We changed to use variable length encodings for many types by default,
    including Word32. This makes sense for numbers but not when Word32 is
    meant to represent four bytes.
    
    I added a FixedLengthEncoding newtype to Binary who's instances
    interpret their argument as a collection of bytes instead of a number.
    
    We then use this when writing/reading magic numbers to the iface file.
    
    I also took the libery to remove the dummy iface field.
    
    This fixes #18180.
    4ca0c8a1
  • Krzysztof Gogolewski's avatar
    Add a regression test for #11506 · a1275081
    Krzysztof Gogolewski authored
    The testcase works now.
    See explanation in ghc/ghc#11506 (comment 273202)
    a1275081
  • Krzysztof Gogolewski's avatar
    Sort deterministically metric output · 8a816e5f
    Krzysztof Gogolewski authored
    Previously, we sorted according to the test name and way,
    but the metrics (max_bytes_used/peak_megabytes_allocated etc.)
    were appearing in nondeterministic order.
    8a816e5f
  • Sylvain Henry's avatar
    Move isDynLinkName into GHC.Types.Name · 566cc73f
    Sylvain Henry authored
    It doesn't belong into GHC.Unit.State
    566cc73f
  • Adam Sandberg Eriksson's avatar
    docs: fix formatting and add some links · d830bbc9
    Adam Sandberg Eriksson authored
    [skip ci]
    d830bbc9
  • Andrew Martin's avatar
    Implement cstringLength# and FinalPtr · 49301ad6
    Andrew Martin authored
    This function and its accompanying rule resolve issue #5218.
    A future PR to the bytestring library will make the internal
    Data.ByteString.Internal.unsafePackAddress compute string length
    with cstringLength#. This will improve the status quo because it is
    eligible for constant folding.
    
    Additionally, introduce a new data constructor to ForeignPtrContents
    named FinalPtr. This additional data constructor, when used in the
    IsString instance for ByteString, leads to more Core-to-Core
    optimization opportunities, fewer runtime allocations, and smaller
    binaries.
    
    Also, this commit re-exports all the functions from GHC.CString
    (including cstringLength#) in GHC.Exts. It also adds a new test
    driver. This test driver is used to perform substring matches on Core
    that is dumped after all the simplifier passes. In this commit, it is
    used to check that constant folding of cstringLength# works.
    49301ad6
  • Ben Gamari's avatar
    simplCore: Ignore ticks in rule templates · dcd6bdcc
    Ben Gamari authored
    This fixes #17619, where a tick snuck in to the template of a rule,
    resulting in a panic during rule matching. The tick in question was
    introduced via post-inlining, as discussed in `Note [Simplifying
    rules]`. The solution we decided upon was to simply ignore ticks in the
    rule template, as discussed in `Note [Tick annotations in RULE
    matching]`.
    
    Fixes #18162.
    Fixes #17619.
    dcd6bdcc
  • John Ericson's avatar
    Fix #18145 and also avoid needless work with implicit vars · 82cb8913
    John Ericson authored
     - `forAllOrNothing` now is monadic, so we can trace whether we bind
       an explicit `forall` or not.
    
     - #18145 arose because the free vars calculation was needlessly
       complex. It is now greatly simplified.
    
     - Replaced some other implicit var code with `filterFreeVarsToBind`.
    Co-authored-by: Ryan Scott's avatarRyan Scott <ryan.gl.scott@gmail.com>
    82cb8913
  • Ben Gamari's avatar
    Bump process submodule · a60dc835
    Ben Gamari authored
    Fixes #17926.
    a60dc835
  • Ben Gamari's avatar
    users-guide: Clarify meaning of -haddock flag · 856adf54
    Ben Gamari authored
    Fixes #18206.
    856adf54
  • Ben Gamari's avatar
    git: Add ignored commits file · 7ae57afd
    Ben Gamari authored
    This can be used to tell git to ignore bulk renaming commits like the
    recently-finished module hierarchy refactoring. Configured with,
    
        git config blame.ignoreRevsFile .git-ignore-revs
    7ae57afd
  • Sebastian Graf's avatar
    Make WorkWrap.Lib.isWorkerSmallEnough aware of the old arity · 75a13c38
    Sebastian Graf authored
    We should allow a wrapper with up to 82 parameters when the original
    function had 82 parameters to begin with.
    
    I verified that this made no difference on NoFib, but then again
    it doesn't use huge records...
    
    Fixes #18122.
    75a13c38
# Configure git to ignore commits listed in this file with:
#
# git config blame.ignoreRevsFile .git-ignore-revs
# Module Hierarchy Renamings
af332442123878c1b61d236dce46418efcbe8750
255418da5d264fb2758bc70925adb2094f34adc3
1941ef4f050c0dfcb68229641fcbbde3a10f1072
528df8ecb4e2f9c78b1ae4ab7ff8230644e9b643
18a346a4b5a02b8c62e8eedb91b35c2d8e754b96
817f93eac4d13f680e8e3e7a25eb403b1864f82e
1b1067d14b656bbbfa7c47f156ec2700c9751549
240f5bf6f53515535be5bf3ef7632aa69ae21e3e
1500f0898e85316c7c97a2f759d83278a072ab0e
3ca52151881451ce5b3a7740d003e811b586140d
cf739945b8b28ff463dc44925348f20b3c1f22cb
da7f74797e8c322006eba385c9cbdce346dd1d43
6e2d9ee25bce06ae51d2f1cf8df4f7422106a383
d491a6795d507eabe35d8aec63c534d29f2d305b
99a9f51bf8207c79241fc0b685fadeb222a61292
eb6082358cdb5f271a8e4c74044a12f97352c52f
5119296440e6846c553c72b8a93afc5ecfa576f0
447864a94a1679b5b079e08bb7208a0005381cef
......@@ -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
......
......@@ -349,6 +349,7 @@ basicKnownKeyNames
-- Strings and lists
unpackCStringName,
unpackCStringFoldrName, unpackCStringUtf8Name,
cstringLengthName,
-- Overloaded lists
isListClassName,
......@@ -1014,10 +1015,11 @@ modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey
-- Base strings Strings
unpackCStringName, unpackCStringFoldrName,
unpackCStringUtf8Name, eqStringName :: Name
unpackCStringUtf8Name, eqStringName, cstringLengthName :: Name
unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey
unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey
unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey
cstringLengthName = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey
eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey
-- The 'inline' function
......@@ -2097,7 +2099,7 @@ wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey,
unpackCStringUtf8IdKey, unpackCStringAppendIdKey,
unpackCStringFoldrIdKey, unpackCStringIdKey,
typeErrorIdKey, divIntIdKey, modIntIdKey,
absentSumFieldErrorIdKey :: Unique
absentSumFieldErrorIdKey, cstringLengthIdKey :: Unique
wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders]
absentErrorIdKey = mkPreludeMiscIdUnique 1
......@@ -2124,6 +2126,7 @@ voidPrimIdKey = mkPreludeMiscIdUnique 21
typeErrorIdKey = mkPreludeMiscIdUnique 22
divIntIdKey = mkPreludeMiscIdUnique 23
modIntIdKey = mkPreludeMiscIdUnique 24
cstringLengthIdKey = mkPreludeMiscIdUnique 25
concatIdKey, filterIdKey, zipIdKey,
bindIOIdKey, returnIOIdKey, newStablePtrIdKey,
......
......@@ -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))
......
......@@ -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 }
......
......@@ -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
......
......@@ -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
......
{-# 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
const = if isSecConstant sec then Constant else Global
const = if sectionProtection sec == ReadOnlySection
then Constant else Global
varDef = LMGlobalVar label tyAlias link lmsec align const
globDef = LMGlobal varDef struct
......
......@@ -2284,7 +2284,7 @@ coercionRKind co
go_forall subst (ForAllCo tv1 k_co co)
-- See Note [Nested ForAllCos]
| isTyVar tv1
= mkInvForAllTy tv2 (go_forall subst' co)
= mkInfForAllTy tv2 (go_forall subst' co)
where
k2 = coercionRKind k_co
tv2 = setTyVarKind tv1 (substTy subst k2)
......
......@@ -119,7 +119,7 @@ conLikeInstOrigArgTys (PatSynCon pat_syn) tys =
-- followed by the existentially quantified type variables. For data
-- constructors, the situation is slightly more complicated—see
-- @Note [DataCon user type variable binders]@ in "GHC.Core.DataCon".
conLikeUserTyVarBinders :: ConLike -> [TyVarBinder]
conLikeUserTyVarBinders :: ConLike -> [InvisTVBinder]
conLikeUserTyVarBinders (RealDataCon data_con) =
dataConUserTyVarBinders data_con
conLikeUserTyVarBinders (PatSynCon pat_syn) =
......
......@@ -371,7 +371,7 @@ data DataCon
-- of tyvars (*not* covars) of dcExTyCoVars unioned with the
-- set of dcUnivTyVars whose tyvars do not appear in dcEqSpec
-- See Note [DataCon user type variable binders]
dcUserTyVarBinders :: [TyVarBinder],
dcUserTyVarBinders :: [InvisTVBinder],
dcEqSpec :: [EqSpec], -- Equalities derived from the result type,
-- _as written by the programmer_.
......@@ -939,10 +939,10 @@ mkDataCon :: Name
-- if it is a record, otherwise empty
-> [TyVar] -- ^ Universals.
-> [TyCoVar] -- ^ Existentials.
-> [TyVarBinder] -- ^ User-written 'TyVarBinder's.
-- These must be Inferred/Specified.
-- See @Note [TyVarBinders in DataCons]@
-> [EqSpec] -- ^ GADT equalities
-> [InvisTVBinder] -- ^ User-written 'TyVarBinder's.
-- These must be Inferred/Specified.
-- See @Note [TyVarBinders in DataCons]@
-> [EqSpec] -- ^ GADT equalities
-> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper
-> [KnotTied Type] -- ^ Original argument types
-> KnotTied Type -- ^ Original result type
......@@ -1006,13 +1006,13 @@ mkDataCon name declared_infix prom_info
NoDataConRep -> dataConUserType con
-- If the DataCon has a wrapper, then the worker's type is never seen
-- by the user. The visibilities we pick do not matter here.
DCR{} -> mkInvForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $
DCR{} -> mkInfForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $
mkVisFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
-- See Note [Promoted data constructors] in GHC.Core.TyCon
prom_tv_bndrs = [ mkNamedTyConBinder vis tv
| Bndr tv vis <- user_tvbs ]
prom_tv_bndrs = [ mkNamedTyConBinder (Invisible spec) tv
| Bndr tv spec <- user_tvbs ]
fresh_names = freshNames (map getName user_tvbs)
-- fresh_names: make sure that the "anonymous" tyvars don't
......@@ -1102,9 +1102,9 @@ dataConUserTyVars :: DataCon -> [TyVar]
dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs
-- See Note [DataCon user type variable binders]
-- | 'TyCoVarBinder's for the type variables of the constructor, in the order the
-- | 'InvisTVBinder's for the type variables of the constructor, in the order the
-- user wrote them
dataConUserTyVarBinders :: DataCon -> [TyVarBinder]
dataConUserTyVarBinders :: DataCon -> [InvisTVBinder]
dataConUserTyVarBinders = dcUserTyVarBinders
-- | Equalities derived from the result type of the data constructor, as written
......@@ -1327,7 +1327,7 @@ dataConUserType :: DataCon -> Type
dataConUserType (MkData { dcUserTyVarBinders = user_tvbs,
dcOtherTheta = theta, dcOrigArgTys = arg_tys,
dcOrigResTy = res_ty })
= mkForAllTys user_tvbs $
= mkInvisForAllTys user_tvbs $
mkInvisFunTys theta $
mkVisFunTys arg_tys $
res_ty
......
module GHC.Core.DataCon where
import GHC.Prelude
import GHC.Types.Var( TyVar, TyCoVar, TyVarBinder )
import GHC.Types.Var( TyVar, TyCoVar, InvisTVBinder )
import GHC.Types.Name( Name, NamedThing )
import {-# SOURCE #-} GHC.Core.TyCon( TyCon )
import GHC.Types.FieldLabel ( FieldLabel )
......@@ -18,7 +18,7 @@ dataConName :: DataCon -> Name
dataConTyCon :: DataCon -> TyCon
dataConExTyCoVars :: DataCon -> [TyCoVar]
dataConUserTyVars :: DataCon -> [TyVar]
dataConUserTyVarBinders :: DataCon -> [TyVarBinder]
dataConUserTyVarBinders :: DataCon -> [InvisTVBinder]
dataConSourceArity :: DataCon -> Arity
dataConFieldLabels :: DataCon -> [FieldLabel]
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
......
......@@ -659,7 +659,7 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty
ppr binder)
_ -> return ()
; mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)
; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)
; addLoc (UnfoldingOf binder) $
lintIdUnfolding binder binder_ty (idUnfolding binder) }
......@@ -2293,6 +2293,7 @@ data LintLocInfo
= RhsOf Id -- The variable bound
| OccOf Id -- Occurrence of id
| LambdaBodyOf Id -- The lambda-binder
| RuleOf Id -- Rules attached to a binder
| UnfoldingOf Id -- Unfolding of a binder
| BodyOfLetRec [Id] -- One of the binders
| CaseAlt CoreAlt -- Case alternative
......@@ -2511,6 +2512,9 @@ dumpLoc (OccOf v)
dumpLoc (LambdaBodyOf b)
= (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b)
dumpLoc (RuleOf b)
= (getSrcLoc b, text "In a rule attached to" <+> pp_binder b)
dumpLoc (UnfoldingOf b)
= (getSrcLoc b, text "In the unfolding of" <+> pp_binder b)
......
......@@ -66,6 +66,7 @@ import qualified Data.ByteString as BS
import Data.Int
import Data.Ratio
import Data.Word
import Data.Maybe (fromMaybe)
{-
Note [Constant folding]
......@@ -1257,6 +1258,8 @@ builtinRules
ru_nargs = 4, ru_try = match_append_lit },
BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
ru_nargs = 2, ru_try = match_eq_string },
BuiltinRule { ru_name = fsLit "CStringLength", ru_fn = cstringLengthName,
ru_nargs = 1, ru_try = match_cstring_length },
BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,
......@@ -1477,6 +1480,30 @@ match_eq_string _ id_unf _
match_eq_string _ _ _ _ = Nothing
-----------------------------------------------------------------------
-- Illustration of this rule:
--
-- cstringLength# "foobar"# --> 6
-- cstringLength# "fizz\NULzz"# --> 4
--
-- Nota bene: Addr# literals are suffixed by a NUL byte when they are
-- compiled to read-only data sections. That's why cstringLength# is
-- well defined on Addr# literals that do not explicitly have an embedded
-- NUL byte.
--
-- See GHC issue #5218, MR 2165, and bytestring PR 191. This is particularly
-- helpful when using OverloadedStrings to create a ByteString since the
-- function computing the length of such ByteStrings can often be constant
-- folded.
match_cstring_length :: RuleFun
match_cstring_length env id_unf _ [lit1]
| Just (LitString str) <- exprIsLiteral_maybe id_unf lit1
-- If elemIndex returns Just, it has the index of the first embedded NUL
-- in the string. If no NUL bytes are present (the common case) then use
-- full length of the byte string.
= let len = fromMaybe (BS.length str) (BS.elemIndex 0 str)
in Just (Lit (mkLitInt (roPlatform env) (fromIntegral len)))
match_cstring_length _ _ _ _ = Nothing
---------------------------------------------------
-- The rule is this:
......
......@@ -830,6 +830,21 @@ Ticks into the LHS, which makes matching trickier. #10665, #10745.
Doing this to either side confounds tools like HERMIT, which seek to reason
about and apply the RULES as originally written. See #10829.
There is, however, one case where we are pretty much /forced/ to transform the
LHS of a rule: postInlineUnconditionally. For instance, in the case of
let f = g @Int in f
We very much want to inline f into the body of the let. However, to do so (and
be able to safely drop f's binding) we must inline into all occurrences of f,
including those in the LHS of rules.
This can cause somewhat surprising results; for instance, in #18162 we found
that a rule template contained ticks in its arguments, because
postInlineUnconditionally substituted in a trivial expression that contains
ticks. See Note [Tick annotations in RULE matching] in GHC.Core.Rules for
details.
Note [No eta expansion in stable unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have a stable unfolding
......@@ -1251,6 +1266,10 @@ it's best to inline it anyway. We often get a=E; b=a from desugaring,
with both a and b marked NOINLINE. But that seems incompatible with
our new view that inlining is like a RULE, so I'm sticking to the 'active'
story for now.
NB: unconditional inlining of this sort can introduce ticks in places that
may seem surprising; for instance, the LHS of rules. See Note [Simplfying
rules] for details.
-}
postInlineUnconditionally
......@@ -1802,7 +1821,7 @@ abstractFloats dflags top_lvl main_tvs floats body
mk_poly1 tvs_here var
= do { uniq <- getUniqueM
; let poly_name = setNameUnique (idName var) uniq -- Keep same name
poly_ty = mkInvForAllTys tvs_here (idType var) -- But new type of course
poly_ty = mkInfForAllTys tvs_here (idType var) -- But new type of course
poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in GHC.Types.Id
mkLocalId poly_name poly_ty
; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }
......
......@@ -1947,7 +1947,7 @@ callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
-- Remove ones that have too many worker variables
small_pats = filterOut too_big non_dups
too_big (vars,_) = not (isWorkerSmallEnough (sc_dflags env) vars)
too_big (vars,args) = not (isWorkerSmallEnough (sc_dflags env) (valArgCount args) vars)
-- We are about to construct w/w pair in 'spec_one'.
-- Omit specialisation leading to high arity workers.
-- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils
......@@ -2101,12 +2101,12 @@ argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
argToPat env in_scope val_env (Tick _ arg) arg_occ
= argToPat env in_scope val_env arg arg_occ
-- Note [Notes in call patterns]
-- Note [Tick annotations in call patterns]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Ignore Notes. In particular, we want to ignore any InlineMe notes
-- Perhaps we should not ignore profiling notes, but I'm going to
-- ride roughshod over them all for now.
--- See Note [Notes in RULE matching] in GHC.Core.Rules
--- See Note [Tick annotations in RULE matching] in GHC.Core.Rules
argToPat env in_scope val_env (Let _ arg) arg_occ
= argToPat env in_scope val_env arg arg_occ
......
......@@ -162,7 +162,7 @@ mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info
wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var
worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args
; if isWorkerSmallEnough dflags work_args
; if isWorkerSmallEnough dflags (length demands) work_args
&& not (too_many_args_for_join_point wrap_args)
&& ((useful1 && not only_one_void_argument) || useful2)
then return (Just (worker_args_dmds, length work_call_args,
......@@ -203,10 +203,13 @@ mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info
= False
-- See Note [Limit w/w arity]
isWorkerSmallEnough :: DynFlags -> [Var] -> Bool
isWorkerSmallEnough dflags vars = count isId vars <= maxWorkerArgs dflags
isWorkerSmallEnough :: DynFlags -> Int -> [Var] -> Bool
isWorkerSmallEnough dflags old_n_args vars
= count isId vars <= max old_n_args (maxWorkerArgs dflags)
-- We count only Free variables (isId) to skip Type, Kind
-- variables which have no runtime representation.
-- Also if the function took 82 arguments before (old_n_args), it's fine if
-- it takes <= 82 arguments afterwards.
{-
Note [Always do CPR w/w]
......@@ -227,7 +230,8 @@ Guard against high worker arity as it generates a lot of stack traffic.
A simplified example is #11565#comment:6
Current strategy is very simple: don't perform w/w transformation at all
if the result produces a wrapper with arity higher than -fmax-worker-args=.
if the result produces a wrapper with arity higher than -fmax-worker-args
and the number arguments before w/w.
It is a bit all or nothing, consider
......
......@@ -15,7 +15,8 @@ module GHC.Core.PatSyn (
patSynName, patSynArity, patSynIsInfix,
patSynArgs,
patSynMatcher, patSynBuilder,
patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, patSynSig,
patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders,
patSynSig, patSynSigBndr,
patSynInstArgTys, patSynInstResTy, patSynFieldLabels,
patSynFieldType,
......@@ -67,13 +68,13 @@ data PatSyn
-- psArgs
-- Universally-quantified type variables
psUnivTyVars :: [TyVarBinder],
psUnivTyVars :: [InvisTVBinder],
-- Required dictionaries (may mention psUnivTyVars)
psReqTheta :: ThetaType,
-- Existentially-quantified type vars
psExTyVars :: [TyVarBinder],
psExTyVars :: [InvisTVBinder],
-- Provided dictionaries (may mention psUnivTyVars or psExTyVars)
psProvTheta :: ThetaType,
......@@ -354,10 +355,10 @@ instance Data.Data PatSyn where
-- | Build a new pattern synonym
mkPatSyn :: Name
-> Bool -- ^ Is the pattern synonym declared infix?
-> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type
-- variables and required dicts
-> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type
-- variables and provided dicts
-> ([InvisTVBinder], ThetaType) -- ^ Universially-quantified type
-- variables and required dicts
-> ([InvisTVBinder], ThetaType) -- ^ Existentially-quantified type
-- variables and provided dicts
-> [Type] -- ^ Original arguments
-> Type -- ^ Original result type
-> (Id, Bool) -- ^ Name of matcher
......@@ -411,20 +412,24 @@ patSynFieldType ps label
Just (_, ty) -> ty
Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label)
patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder]
patSynUnivTyVarBinders :: PatSyn -> [InvisTVBinder]
patSynUnivTyVarBinders = psUnivTyVars
patSynExTyVars :: PatSyn -> [TyVar]
patSynExTyVars ps = binderVars (psExTyVars ps)
patSynExTyVarBinders :: PatSyn -> [TyVarBinder]
patSynExTyVarBinders :: PatSyn -> [InvisTVBinder]
patSynExTyVarBinders = psExTyVars
patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type)
patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
patSynSigBndr :: PatSyn -> ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Type], Type)
patSynSigBndr (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
, psProvTheta = prov, psReqTheta = req
, psArgs = arg_tys, psResultTy = res_ty })
= (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty)
= (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty)
patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type)
patSynSig ps = let (u_tvs, req, e_tvs, prov, arg_tys, res_ty) = patSynSigBndr ps
in (binderVars u_tvs, req, binderVars e_tvs, prov, arg_tys, res_ty)
patSynMatcher :: PatSyn -> (Id,Bool)
patSynMatcher = psMatcher
......@@ -473,12 +478,12 @@ pprPatSynType :: PatSyn -> SDoc
pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta
, psExTyVars = ex_tvs, psProvTheta = prov_theta
, psArgs = orig_args, psResultTy = orig_res_ty })
= sep [ pprForAll univ_tvs
= sep [ pprForAll $ tyVarSpecToBinders univ_tvs
, pprThetaArrowTy req_theta
, ppWhen insert_empty_ctxt $ parens empty <+> darrow
, pprType sigma_ty ]
where
sigma_ty = mkForAllTys ex_tvs $
sigma_ty = mkInvisForAllTys ex_tvs $
mkInvisFunTys prov_theta $
mkVisFunTys orig_args orig_res_ty
insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs)