...
 
Commits (32)
  • 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 #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
  • wz1000's avatar
    Add info about typeclass evidence to .hie files · 52eca563
    wz1000 authored
    See `testsuite/tests/hiefile/should_run/HieQueries.hs` and
    `testsuite/tests/hiefile/should_run/HieQueries.stdout` for an example of this
    
    We add two new fields, `EvidenceVarBind` and `EvidenceVarUse` to the
    `ContextInfo` associated with an Identifier. These are associated with the
    appropriate identifiers for the evidence variables collected when we come across
    `HsWrappers`, `TcEvBinds` and `IPBinds` while traversing the AST.
    
    Instance dictionary and superclass selector dictionaries from `tcg_insts` and
    classes defined in `tcg_tcs` are also recorded in the AST as originating from
    their definition span
    
    This allows us to save a complete picture of the evidence constructed by the
    constraint solver, and will let us report this to the user, enabling features
    like going to the instance definition from the invocation of a class method(or
    any other method taking a constraint) and finding all usages of a particular
    instance.
    
    Additionally,
    
    - Mark NodeInfo with an origin so we can differentiate between bindings
      origininating in the source vs those in ghc
    - Along with typeclass evidence info, also include information on Implicit
      Parameters
    - Add a few utility functions to HieUtils in order to query the new info
    
    Updates haddock submodule
    52eca563
......@@ -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
......
......@@ -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)
......
......@@ -1802,7 +1802,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)) }
......
......@@ -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)
......@@ -171,7 +171,8 @@ pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType
pprForAll :: [TyCoVarBinder] -> SDoc
pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs)
-- | Print a user-level forall; see Note [When to print foralls] in this module.
-- | Print a user-level forall; see @Note [When to print foralls]@ in
-- "GHC.Iface.Type".
pprUserForAll :: [TyCoVarBinder] -> SDoc
pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr
......@@ -253,24 +254,6 @@ debug_ppr_ty prec ty@(ForAllTy {})
= ([], ty)
{-
Note [When to print foralls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Mostly we want to print top-level foralls when (and only when) the user specifies
-fprint-explicit-foralls. But when kind polymorphism is at work, that suppresses
too much information; see #9018.
So I'm trying out this rule: print explicit foralls if
a) User specifies -fprint-explicit-foralls, or
b) Any of the quantified type variables has a kind
that mentions a kind variable
This catches common situations, such as a type siguature
f :: m a
which means
f :: forall k. forall (m :: k->*) (a :: k). m a
We really want to see both the "forall k" and the kind signatures
on m and a. The latter comes from pprTCvBndr.
Note [Infix type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
With TypeOperators you can say
......@@ -300,7 +283,7 @@ pprDataConWithArgs :: DataCon -> SDoc
pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc]
where
(_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc
user_bndrs = dataConUserTyVarBinders dc
user_bndrs = tyVarSpecToBinders $ dataConUserTyVarBinders dc
forAllDoc = pprUserForAll user_bndrs
thetaDoc = pprThetaArrowTy theta
argsDoc = hsep (fmap pprParendType arg_tys)
......
......@@ -47,7 +47,7 @@ module GHC.Core.TyCo.Rep (
mkTyConTy, mkTyVarTy, mkTyVarTys,
mkTyCoVarTy, mkTyCoVarTys,
mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys,
mkForAllTy, mkForAllTys,
mkForAllTy, mkForAllTys, mkInvisForAllTys,
mkPiTy, mkPiTys,
-- * Functions over binders
......@@ -687,8 +687,10 @@ data TyCoBinder
instance Outputable TyCoBinder where
ppr (Anon af ty) = ppr af <+> ppr ty
ppr (Named (Bndr v Required)) = ppr v
ppr (Named (Bndr v Specified)) = char '@' <> ppr v
ppr (Named (Bndr v Inferred)) = braces (ppr v)
-- See Note [Explicit Case Statement for Specificity]
ppr (Named (Bndr v (Invisible spec))) = case spec of
SpecifiedSpec -> char '@' <> ppr v
InferredSpec -> braces (ppr v)
-- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder'
......@@ -802,16 +804,22 @@ This table summarises the visibility rules:
f3 :: forall a. a -> a; f3 x = x
So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified
* Inferred. Function defn, with signature (explicit forall), marked as inferred:
f4 :: forall {a}. a -> a; f4 x = x
So f4 gets the type f4 :: forall {a}. a -> a, with 'a' Inferred
It's Inferred because the user marked it as such, even though it does appear
in the user-written signature for f4
* Inferred/Specified. Function signature with inferred kind polymorphism.
f4 :: a b -> Int
So 'f4' gets the type f4 :: forall {k} (a:k->*) (b:k). a b -> Int
f5 :: a b -> Int
So 'f5' gets the type f5 :: forall {k} (a:k->*) (b:k). a b -> Int
Here 'k' is Inferred (it's not mentioned in the type),
but 'a' and 'b' are Specified.
* Specified. Function signature with explicit kind polymorphism
f5 :: a (b :: k) -> Int
f6 :: a (b :: k) -> Int
This time 'k' is Specified, because it is mentioned explicitly,
so we get f5 :: forall (k:*) (a:k->*) (b:k). a b -> Int
so we get f6 :: forall (k:*) (a:k->*) (b:k). a b -> Int
* Similarly pattern synonyms:
Inferred - from inferred types (e.g. no pattern type signature)
......@@ -995,6 +1003,10 @@ mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty
mkForAllTys :: [TyCoVarBinder] -> Type -> Type
mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
-- | Wraps foralls over the type using the provided 'InvisTVBinder's from left to right
mkInvisForAllTys :: [InvisTVBinder] -> Type -> Type
mkInvisForAllTys tyvars ty = foldr ForAllTy ty $ tyVarSpecToBinders tyvars
mkPiTy:: TyCoBinder -> Type -> Type
mkPiTy (Anon af ty1) ty2 = FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 }
mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty
......
......@@ -100,7 +100,7 @@ module GHC.Core.TyCon(
newTyConDataCon_maybe,
algTcFields,
tyConRuntimeRepInfo,
tyConBinders, tyConResKind, tyConTyVarBinders,
tyConBinders, tyConResKind, tyConInvisTVBinders,
tcTyConScopedTyVars, tcTyConIsPoly,
mkTyConTagMap,
......@@ -492,19 +492,19 @@ mkTyConKind bndrs res_kind = foldr mk res_kind bndrs
mk (Bndr tv (AnonTCB af)) k = mkFunTy af (varType tv) k
mk (Bndr tv (NamedTCB vis)) k = mkForAllTy tv vis k
tyConTyVarBinders :: [TyConBinder] -- From the TyCon
-> [TyVarBinder] -- Suitable for the foralls of a term function
tyConInvisTVBinders :: [TyConBinder] -- From the TyCon
-> [InvisTVBinder] -- Suitable for the foralls of a term function
-- See Note [Building TyVarBinders from TyConBinders]
tyConTyVarBinders tc_bndrs
tyConInvisTVBinders tc_bndrs
= map mk_binder tc_bndrs
where
mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv
where
vis = case tc_vis of
AnonTCB VisArg -> Specified
AnonTCB InvisArg -> Inferred -- See Note [AnonTCB InvisArg]
NamedTCB Required -> Specified
NamedTCB vis -> vis
AnonTCB VisArg -> SpecifiedSpec
AnonTCB InvisArg -> InferredSpec -- See Note [AnonTCB InvisArg]
NamedTCB Required -> SpecifiedSpec
NamedTCB (Invisible vis) -> vis
-- Returns only tyvars, as covars are always inferred
tyConVisibleTyVars :: TyCon -> [TyVar]
......@@ -655,8 +655,10 @@ instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where
ppr_bi (AnonTCB VisArg) = text "anon-vis"
ppr_bi (AnonTCB InvisArg) = text "anon-invis"
ppr_bi (NamedTCB Required) = text "req"
ppr_bi (NamedTCB Specified) = text "spec"
ppr_bi (NamedTCB Inferred) = text "inf"
-- See Note [Explicit Case Statement for Specificity]
ppr_bi (NamedTCB (Invisible spec)) = case spec of
SpecifiedSpec -> text "spec"
InferredSpec -> text "inf"
instance Binary TyConBndrVis where
put_ bh (AnonTCB af) = do { putByte bh 0; put_ bh af }
......
......@@ -3,7 +3,7 @@
--
-- Type - public interface
{-# LANGUAGE CPP, FlexibleContexts #-}
{-# LANGUAGE CPP, FlexibleContexts, PatternSynonyms #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
......@@ -16,6 +16,7 @@ module GHC.Core.Type (
-- $representation_types
TyThing(..), Type, ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..),
Specificity(..),
KindOrType, PredType, ThetaType,
Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder,
KnotTied,
......@@ -39,10 +40,10 @@ module GHC.Core.Type (
splitListTyConApp_maybe,
repSplitTyConApp_maybe,
mkForAllTy, mkForAllTys, mkTyCoInvForAllTys,
mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys,
mkSpecForAllTy, mkSpecForAllTys,
mkVisForAllTys, mkTyCoInvForAllTy,
mkInvForAllTy, mkInvForAllTys,
mkInfForAllTy, mkInfForAllTys,
splitForAllTys, splitForAllTysSameVis,
splitForAllVarBndrs,
splitForAllTy_maybe, splitForAllTy,
......@@ -92,6 +93,7 @@ module GHC.Core.Type (
sameVis,
mkTyCoVarBinder, mkTyCoVarBinders,
mkTyVarBinders,
tyVarSpecToBinders,
mkAnonBinder,
isAnonTyCoBinder,
binderVar, binderVars, binderType, binderArgFlag,
......@@ -1476,8 +1478,8 @@ mkTyCoInvForAllTy tv ty
= ForAllTy (Bndr tv Inferred) ty
-- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar
mkInvForAllTy :: TyVar -> Type -> Type
mkInvForAllTy tv ty = ASSERT( isTyVar tv )
mkInfForAllTy :: TyVar -> Type -> Type
mkInfForAllTy tv ty = ASSERT( isTyVar tv )
ForAllTy (Bndr tv Inferred) ty
-- | Like 'mkForAllTys', but assumes all variables are dependent and
......@@ -1486,8 +1488,8 @@ mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type
mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs
-- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar
mkInvForAllTys :: [TyVar] -> Type -> Type
mkInvForAllTys tvs ty = foldr mkInvForAllTy ty tvs
mkInfForAllTys :: [TyVar] -> Type -> Type
mkInfForAllTys tvs ty = foldr mkInfForAllTy ty tvs
-- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified',
-- a common case
......@@ -1600,12 +1602,13 @@ splitForAllTys ty = split ty ty []
-- @'sameVis' argf supplied_argf@ is 'True', where @argf@ is the visibility
-- of the @ForAllTy@'s binder and @supplied_argf@ is the visibility provided
-- as an argument to this function.
splitForAllTysSameVis :: ArgFlag -> Type -> ([TyCoVar], Type)
-- Furthermore, each returned tyvar is annotated with its argf.
splitForAllTysSameVis :: ArgFlag -> Type -> ([TyCoVarBinder], Type)
splitForAllTysSameVis supplied_argf ty = split ty ty []
where
split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs
split _ (ForAllTy (Bndr tv argf) ty) tvs
| argf `sameVis` supplied_argf = split ty ty (tv:tvs)
| argf `sameVis` supplied_argf = split ty ty ((Bndr tv argf):tvs)
split orig_ty _ tvs = (reverse tvs, orig_ty)
-- | Like splitForAllTys, but split only for tyvars.
......@@ -3021,10 +3024,22 @@ tyConAppNeedsKindSig spec_inj_pos tc n_args
_ -> emptyFV
source_of_injectivity Required = True
source_of_injectivity Specified = spec_inj_pos
source_of_injectivity Inferred = False
-- See Note [Explicit Case Statement for Specificity]
source_of_injectivity (Invisible spec) = case spec of
SpecifiedSpec -> spec_inj_pos