...
 
Commits (32)
  • Sebastian Graf's avatar
    Much simpler language for PmCheck · 30f5ac07
    Sebastian Graf authored
    Simon realised that the simple language composed of let bindings, bang
    patterns and flat constructor patterns is enough to capture the
    semantics of the source pattern language that are important for
    pattern-match checking. Well, given that the Oracle is smart enough to
    connect the dots in this less informationally dense form, which it is
    now.
    
    So we transform `translatePat` to return a list of `PmGrd`s relative to
    an incoming match variable. `pmCheck` then trivially translates each of
    the `PmGrd`s into constraints that the oracle understands.
    
    Since we pass in the match variable, we incidentally fix #15884
    (coverage checks for view patterns) through an interaction with !1746.
    30f5ac07
  • Stefan Schulze Frielinghaus's avatar
    Hadrian: Take care of assembler source files · 166e1c2a
    Stefan Schulze Frielinghaus authored
    Fixes #17286.
    166e1c2a
  • John Ericson's avatar
    Simplify Configure in a few ways · c2290596
    John Ericson authored
     - No need to distinguish between gcc-llvm and clang. First of all,
       gcc-llvm is quite old and surely unmaintained by now. Second of all,
       none of the code actually care about that distinction!
    
       Now, it does make sense to consider C multiple frontends for LLVMs in
       the form of clang vs clang-cl (same clang, yes, but tweaked
       interface). But this is better handled in terms of "gccish vs
       mvscish" and "is LLVM", yielding 4 combinations. Therefore, I don't
       think it is useful saving the existing code for that.
    
     - Get the remaining CC_LLVM_BACKEND, and also TABLES_NEXT_TO_CODE in
       mk/config.h the normal way, rather than hacking it post-hoc. No point
       keeping these special cases around for now reason.
    
     - Get rid of hand-rolled `die` function and just use `AC_MSG_ERROR`.
    
     - Abstract check + flag override for unregisterised and tables next to
       code.
    
    Oh, and as part of the above I also renamed/combined some variables
    where it felt appropriate.
    
     - GccIsClang -> CcLlvmBackend. This is for `AC_SUBST`, like the other
     Camal case ones. It was never about gcc-llvm, or Apple's renamed clang,
     to be clear.
    
     - llvm_CC_FLAVOR -> CC_LLVM_BACKEND. This is for `AC_DEFINE`, like the
     other all-caps snake case ones. llvm_CC_FLAVOR was just silly
     indirection *and* an odd name to boot.
    c2290596
  • Vladislav Zavialov's avatar
    Escape stats file command (#13676) · f1ce3535
    Vladislav Zavialov authored
    f1ce3535
  • Vladislav Zavialov's avatar
    Skip T13767 on Darwin · cd1a8808
    Vladislav Zavialov authored
    The CI job fails with:
    
    	+++ rts/T13676.run/T13676.run.stderr.normalised	2019-10-09 12:27:56.000000000 -0700
    	@@ -0,0 +1,4 @@
    	+dyld: Library not loaded: @rpath/libHShaskeline-0.7.5.0-ghc8.9.0.20191009.dylib
    	+  Referenced from: /Users/builder/builds/ewzE5N2p/0/ghc/ghc/inplace/lib/bin/ghc
    	+  Reason: image not found
    	+*** Exception: readCreateProcess: '/Users/builder/builds/ewzE5N2p/0/ghc/ghc/inplace/lib/bin/ghc' '-B/Users/builder/builds/ewzE5N2p/0/ghc/ghc/inplace/lib' '-e' ''/''$'/'' == '/''/x0024'/''' +RTS '-tT13676.t'  (exit -6): failed
    
    Unable to reproduce locally.
    cd1a8808
  • Ryan Scott's avatar
    Use newDFunName for both manual and derived instances (#17339) · 0a338264
    Ryan Scott authored
    Issue #17339 was caused by using a slightly different version of
    `newDFunName` for derived instances that, confusingly enough, did not
    take all arguments to the class into account when generating the
    `DFun` name. I cannot think of any good reason for doing this, so
    this patch uses `newDFunName` uniformly for both derived instances
    and manually written instances alike.
    
    Fixes #17339.
    0a338264
  • Simon Peyton Jones's avatar
    Fix validity checking for inferred types · c50e4c92
    Simon Peyton Jones authored
    GHC is suposed to uphold the principle that an /inferred/ type
    for a let-binding should obey the rules for that module.  E.g.
    we should only accept an inferred higher rank type if we have
    RankNTypes on.
    
    But we were failing to check this: TcValidity.checkValidType
    allowed arbitrary rank for inferred types.
    
    This patch fixes the bug.  It might in principle cause some breakage,
    but if so that's good: the user should add RankNTypes and/or a
    manual signature.  (And almost every package has explicit user
    signatures for all top-level things anyway.)  Let's see.
    
    Fixes #17213.
    
    Metric Decrease:
        T10370
    c50e4c92
  • Simon Peyton Jones's avatar
    Do not add a 'solved dict' for quantified constraints · 226d86d2
    Simon Peyton Jones authored
    GHC has a wonderful-but-delicate mechanism for building recursive
    dictionaries by adding a goal to the "solved dictionaries" before
    solving the sub-goals.  See Note [Solved dictionaries] in TcSMonad
    
    Ticket #17267 showed that if you use this mechanism for local
    /quantified/ constraints you can get a loop -- or even unsafe
    coerce.   This patch fixes the bug.
    
    Specifically
    
    * Make TcSMonad.addSolvedDict be conditional on using a
      /top level/ instance, not a quantified one.
    
    * Moreover, we /also/ don't want to add a solved dict
      for equalities (a~b).
    
    * Add lots more comments to Note [Solved dictionaries]
      to explain the above cryptic stuff.
    
    * Extend InstanceWhat to identify those strange built-in
      equality instances.
    
    A couple of other things along the way
    
    * Delete the unused Type.isIPPred_maybe.
    
    * Stop making addSolvedDict conditional on not being an
      impolicit parameter.  This comes from way back. But
      it's irrelevant now because IP dicts are never solved
      via an instance.
    226d86d2
  • Alex D's avatar
    5ab1a28d
  • Andreas Klebinger's avatar
    Fix #17334 where NCG did not properly update the CFG. · c1bd07cd
    Andreas Klebinger authored
    Statements can change the basic block in which instructions
    are placed during instruction selection.
    
    We have to keep track of this switch of the current basic block
    as we need this information in order to properly update the CFG.
    
    This commit implements this change and fixes #17334.
    
    We do so by having stmtToInstr return the new block id
    if a statement changed the basic block.
    c1bd07cd
  • Takenobu Tani's avatar
    users-guide: Add GHCi's ::<builtin-command> form · 1eda9f28
    Takenobu Tani authored
    This commit explicitly adds description about double colon command
    of GHCi.
    
    [skip ci]
    1eda9f28
  • Takenobu Tani's avatar
    27145351
  • Ryan Scott's avatar
    Add docs/users_guide/.log to .gitignore · 78463fc5
    Ryan Scott authored
    When the users guide fails to build (as in #17346), a
    `docs/users_guide/.log` file will be generated with contents that
    look something like this:
    
    ```
    WARNING: unknown config value 'latex_paper_size' in override, ignoring
    /home/rgscott/Software/ghc5/docs/users_guide/ghci.rst:3410: WARNING: u'ghc-flag' reference target not found: -pgmo ?option?
    /home/rgscott/Software/ghc5/docs/users_guide/ghci.rst:3410: WARNING: u'ghc-flag' reference target not found: -pgmo ?port?
    
    Encoding error:
    'ascii' codec can't encode character u'\u27e8' in position 132: ordinal not in range(128)
    The full traceback has been saved in /tmp/sphinx-err-rDF2LX.log, if you want to report the issue to the developers.
    ```
    
    This definitely should not be checked in to version control, so let's
    add this to `.gitignore`.
    78463fc5
  • Ryan Scott's avatar
    Mention changes from #16980, #17213 in 8.10.1 release notes · 4aba72d6
    Ryan Scott authored
    The fixes for these issues both have user-facing consequences, so it
    would be good to mention them in the release notes for GHC 8.10.1.
    
    While I'm in town, also mention `UnboxedSums` in the release notes
    entry related to `-fobject-code`.
    4aba72d6
  • Ben Gamari's avatar
    gitlab-ci: Move hadrian-ghc-in-ghci job first · 0ca044fd
    Ben Gamari authored
    This is a very cheap job and can catch a number of "easy" failure modes
    (e.g. missing imports in the compiler). Let's run it first.
    0ca044fd
  • Ryan Scott's avatar
    Refactor some cruft in TcDerivInfer.inferConstraints · a2d3594c
    Ryan Scott authored
    The latest installment in my quest to clean up the code in
    `TcDeriv*`. This time, my sights are set on
    `TcDerivInfer.inferConstraints`, which infers the context for derived
    instances. This function is a wee bit awkward at the moment:
    
    * It's not terribly obvious from a quick glance, but
      `inferConstraints` is only ever invoked when using the `stock` or
      `anyclass` deriving strategies, as the code for inferring the
      context for `newtype`- or `via`-derived instances is located
      separately in `mk_coerce_based_eqn`. But there's no good reason
      for things to be this way, so I moved this code from
      `mk_coerce_based_eqn` to `inferConstraints` so that everything
      related to inferring instance contexts is located in one place.
    * In this process, I discovered that the Haddocks for the auxiliary
      function `inferConstraintsDataConArgs` are completely wrong. It
      claims that it handles both `stock` and `newtype` deriving, but
      this is completely wrong, as discussed above—it only handles
      `stock`. To rectify this, I renamed this function to
      `inferConstraintsStock` to reflect its actual purpose and created
      a new `inferConstraintsCoerceBased` function to specifically
      handle `newtype` (and `via`) deriving.
    
    Doing this revealed some opportunities for further simplification:
    
    * Removing the context-inference–related code from
      `mk_coerce_based_eqn` made me realize that the overall structure
      of the function is basically identical to `mk_originative_eqn`.
      In fact, I was easily able to combine the two functions into a
      single `mk_eqn_from_mechanism` function.
    
      As part of this merger, I now invoke
      `atf_coerce_based_error_checks` from `doDerivInstErrorChecks1`.
    * I discovered that GHC defined this function:
    
      ```hs
      typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind
      ```
    
      No fewer than four times in different modules. I consolidated all
      of these definitions in a single location in `TysWiredIn`.
    a2d3594c
  • Ryan Scott's avatar
    Don't skip validity checks for built-in classes (#17355) · 426b0ddc
    Ryan Scott authored
    Issue #17355 occurred because the control flow for
    `TcValidity.check_valid_inst_head` was structured in such a way that
    whenever it checked a special, built-in class (like `Generic` or
    `HasField`), it would skip the most important check of all:
    `checkValidTypePats`, which rejects nonsense like this:
    
    ```hs
    instance Generic (forall a. a)
    ```
    
    This fixes the issue by carving out `checkValidTypePats` from
    `check_valid_inst_head` so that `checkValidTypePats` is always
    invoked. `check_valid_inst_head` has also been renamed to
    `check_special_inst_head` to reflect its new purpose of _only_
    checking for instances headed by special classes.
    
    Fixes #17355.
    426b0ddc
  • Alp Mestanogullari's avatar
    a55b8a65
  • Ben Gamari's avatar
    hadrian: Add support for bindist compressors other than Xz · 9c11f817
    Ben Gamari authored
    Fixes #17351.
    9c11f817
  • Andreas Klebinger's avatar
    Add loop level analysis to the NCG backend. · 535a88e1
    Andreas Klebinger authored
    For backends maintaining the CFG during codegen
    we can now find loops and their nesting level.
    
    This is based on the Cmm CFG and dominator analysis.
    
    As a result we can estimate edge frequencies a lot better
    for methods, resulting in far better code layout.
    
    Speedup on nofib: ~1.5%
    Increase in compile times: ~1.9%
    
    To make this feasible this commit adds:
    * Dominator analysis based on the Lengauer-Tarjan Algorithm.
    * An algorithm estimating global edge frequences from branch
    probabilities - In CFG.hs
    
    A few static branch prediction heuristics:
    
    * Expect to take the backedge in loops.
    * Expect to take the branch NOT exiting a loop.
    * Expect integer vs constant comparisons to be false.
    
    We also treat heap/stack checks special for branch prediction
    to avoid them being treated as loops.
    535a88e1
  • Adithya Kumar's avatar
  • Takenobu Tani's avatar
    testsuite: Add test for #8305 · 19641957
    Takenobu Tani authored
    This is a test for the current algorithm of GHCi command name resolution.
    
    I add this test in preparation for updating GHCi command name resolution.
    
    For the current algorithm, see https://downloads.haskell.org/ghc/latest/docs/html/users_guide/ghci.html#the-ghci-files
    19641957
  • Sebastian Graf's avatar
    Infer rho-types instead of sigma-types in guard BindStmts and TransStmts · 6ede3554
    Sebastian Graf authored
    In #17343 we saw that we didn't handle the pattern guard `!_ <-
    undefined` correctly: The `undefined` was never evaluated. Indeed,
    elaboration failed to insert the invisible type aruments to `undefined`.
    So `undefined` was trivially a normal-form and in turn never entered.
    
    The problem is that we used to infer a sigma-type for the RHS of the
    guard, the leading qualifiers of which will never be useful in a pattern
    match situation. Hence we infer a rho-type now.
    
    Fixes #17343.
    6ede3554
  • John Ericson's avatar
    Delete ghctags cabal file · 798037a1
    John Ericson authored
    It came back to life in 381c3ae3 by
    mistake.
    798037a1
  • Richard Eisenberg's avatar
    Break up TcRnTypes, among other modules. · 51fad9e6
    Richard Eisenberg authored
    This introduces three new modules:
    
     - basicTypes/Predicate.hs describes predicates, moving
       this logic out of Type. Predicates don't really exist
       in Core, and so don't belong in Type.
    
     - typecheck/TcOrigin.hs describes the origin of constraints
       and types. It was easy to remove from other modules and
       can often be imported instead of other, scarier modules.
    
     - typecheck/Constraint.hs describes constraints as used in
       the solver. It is taken from TcRnTypes.
    
    No work other than module splitting is in this patch.
    
    This is the first step toward homogeneous equality, which will
    rely more strongly on predicates. And homogeneous equality is the
    next step toward a dependently typed core language.
    51fad9e6
  • Ben Gamari's avatar
    hadrian: Introduce enableDebugInfo flavour transformer · 11d4fc50
    Ben Gamari authored
    Also refactor things a bit to eliminate repetition.
    11d4fc50
  • Ryan Scott's avatar
    Make Coverage.TM a newtype · deb96399
    Ryan Scott authored
    deb96399
  • Brian Wignall's avatar
    42ebc3f6
  • Ben Gamari's avatar
    testsuite: Ensure that makefile tests get run · b15a7fb8
    Ben Gamari authored
    Previously `makefile_test` and `run_command` tests could easily end up
    in a situation where they wouldn't be run if the user used the
    `only_ways` modifier. The reason is to build the set of a ways to run
    the test in we first start with a candidate set determined by the test
    type (e.g. `makefile_test`, `compile_run`, etc.) and then filter that
    set with the constraints given by the test's modifiers.
    
    `makefile_test` and `run_command` tests' candidate sets were simply
    `{normal}`, and consequently most uses of `only_ways` would result in
    the test being never run.
    
    To avoid this we rather use all ways as the candidate sets for these
    test types. This may result in a few more testcases than we would like
    (given that some `run_command` tests are insensitive to way) but this
    can be fixed by adding modifiers and we would much rather run too many
    tests than too few.
    
    This fixes #16042 and a number of other tests afflicted by the same issue.
    However, there were a few cases that required special attention:
    
     * `T14028` is currently failing and is therefore marked as broken due
       to #17300
    
     * `T-signals-child` is fragile in the `threaded1` and `threaded2` ways
       (tracked in #17307)
    b15a7fb8
  • Richard Eisenberg's avatar
    4efdda90
  • Ben Gamari's avatar
    testsuite: Assert that testsuite ways are known · c4c9904b
    Ben Gamari authored
    This ensures that all testsuite way names given to `omit_ways`,
    `only_ways`, etc. are known ways.
    c4c9904b
  • Ömer Sinan Ağacan's avatar
    rts/BlockAlloc: Allow aligned allocation requests · 921e4e36
    Ömer Sinan Ağacan authored
    This implements support for block group allocations which are aligned to
    an integral number of blocks.
    
    This will be used by the nonmoving garbage collector, which uses the
    block allocator to allocate the segments which back its heap. These
    segments are a fixed number of blocks in size, with each segment being
    aligned to the segment size boundary. This allows us to easily find the
    segment metadata stored at the beginning of the segment.
    921e4e36
......@@ -107,6 +107,7 @@ _darcs/
/distrib/ghc.iss
/docs/man
/docs/index.html
/docs/users_guide/.log
/docs/users_guide/users_guide
/docs/users_guide/ghc.1
/docs/users_guide/flags.pyc
......@@ -227,7 +228,7 @@ ghc.nix/
.gdbinit
# Tooling - direnv
.envrc
.envrc
# Tooling - vscode
.vscode
......@@ -18,13 +18,14 @@ before_script:
- "git fetch https://gitlab.haskell.org/ghc/ghc-performance-notes.git refs/notes/perf:refs/notes/perf || true"
stages:
- lint # Source linting
- build # A quick smoke-test to weed out broken commits
- full-build # Build all the things
- cleanup # See Note [Cleanup after the shell executor]
- packaging # Source distribution, etc.
- testing # head.hackage correctness and compiler performance testing
- deploy # push documentation
- lint # Source linting
- quick-build # A very quick smoke-test to weed out broken commits
- build # A quick smoke-test to weed out broken commits
- full-build # Build all the things
- cleanup # See Note [Cleanup after the shell executor]
- packaging # Source distribution, etc.
- testing # head.hackage correctness and compiler performance testing
- deploy # push documentation
# N.B.Don't run on wip/ branches, instead on run on merge requests.
.only-default: &only-default
......@@ -229,7 +230,7 @@ validate-x86_64-linux-deb9-hadrian:
hadrian-ghc-in-ghci:
<<: *only-default
stage: build
stage: quick-build
image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
before_script:
# workaround for docker permissions
......@@ -237,6 +238,8 @@ hadrian-ghc-in-ghci:
- git submodule sync --recursive
- git submodule update --init --recursive
- git checkout .gitmodules
variables:
GHC_FLAGS: -Werror
tags:
- x86_64-linux
script:
......
......@@ -842,6 +842,48 @@ AC_DEFUN([FP_CHECK_SIZEOF_AND_ALIGNMENT],
FP_CHECK_ALIGNMENT([$1])
])# FP_CHECK_SIZEOF_AND_ALIGNMENT
# FP_DEFAULT_CHOICE_OVERRIDE_CHECK(
# flag, name, anti name, var name, help string,
# [var true val], [var false val], [flag true val])
# ---------------------------------------------------
# Helper for when there is a automatic detection and an explicit flag for the
# user to override disable a feature, but not override enable a feature.
#
# $1 = flag of feature
# $2 = name of feature
# $3 = name of anti feature
# $4 = name of variable
# $5 = help string
# $6 = when true
# $7 = when false
# $8 = default explicit case (yes/no). Used for handle "backwards" legacy
# options where enabling makes fewer assumptions than disabling.
AC_DEFUN(
[FP_DEFAULT_CHOICE_OVERRIDE_CHECK],
[AC_ARG_ENABLE(
[$1],
[AC_HELP_STRING(
[--enable-$1],
[$5])],
[AS_IF(
[test x"$enableval" = x"m4_default([$8],yes)"],
[AS_CASE(
[x"$$4Default"],
[x"m4_default([$6],YES)"],
[AC_MSG_NOTICE([user chose $2 matching default for platform])],
[x"m4_default([$7],NO)"],
[AC_MSG_ERROR([user chose $2 overriding only supported option for platform])],
[AC_MSG_ERROR([invalid default])])
$4=m4_default([$6],YES)],
[AS_CASE(
[x"$$4Default"],
[x"m4_default([$6],YES)"],
[AC_MSG_NOTICE([user chose $3 overriding for platform])],
[x"m4_default([$7],NO)"],
[AC_MSG_NOTICE([user chose $3 matching default for platform])],
[AC_MSG_ERROR([invalid default])])
$4=m4_default([$7],NO)])],
[$4="$$4Default"])])
# FP_LEADING_UNDERSCORE
# ---------------------
......@@ -1293,30 +1335,19 @@ AC_SUBST(GccLT46)
dnl Check to see if the C compiler is clang or llvm-gcc
dnl
GccIsClang=NO
AC_DEFUN([FP_CC_LLVM_BACKEND],
[AC_REQUIRE([AC_PROG_CC])
AC_MSG_CHECKING([whether C compiler is clang])
AC_MSG_CHECKING([whether C compiler has an LLVM back end])
$CC -x c /dev/null -dM -E > conftest.txt 2>&1
if grep "__clang__" conftest.txt >/dev/null 2>&1; then
AC_SUBST([CC_CLANG_BACKEND], [1])
AC_SUBST([CC_LLVM_BACKEND], [1])
GccIsClang=YES
if grep "__llvm__" conftest.txt >/dev/null 2>&1; then
AC_DEFINE([CC_LLVM_BACKEND], [1], [Define (to 1) if C compiler has an LLVM back end])
CcLlvmBackend=YES
AC_MSG_RESULT([yes])
else
CcLlvmBackend=NO
AC_MSG_RESULT([no])
AC_MSG_CHECKING([whether C compiler has an LLVM back end])
if grep "__llvm__" conftest.txt >/dev/null 2>&1; then
AC_SUBST([CC_CLANG_BACKEND], [0])
AC_SUBST([CC_LLVM_BACKEND], [1])
AC_MSG_RESULT([yes])
else
AC_SUBST([CC_CLANG_BACKEND], [0])
AC_SUBST([CC_LLVM_BACKEND], [0])
AC_MSG_RESULT([no])
fi
fi
AC_SUBST(GccIsClang)
AC_SUBST(CcLlvmBackend)
rm -f conftest.txt
])
......
This diff is collapsed.
......@@ -93,7 +93,7 @@ tracePm herald doc = do
-- | Generate a fresh `Id` of a given type
mkPmId :: Type -> DsM Id
mkPmId ty = getUniqueM >>= \unique ->
let occname = mkVarOccFS $ fsLit "$pm"
let occname = mkVarOccFS $ fsLit "pm"
name = mkInternalName unique occname noSrcSpan
in return (mkLocalId name ty)
......@@ -1576,8 +1576,8 @@ addVarCoreCt delta x e = runMaybeT (execStateT (core_expr x e) delta)
= do { arg_ids <- traverse bind_expr args
; data_con_app x dc arg_ids }
-- See Note [Detecting pattern synonym applications in expressions]
| Var y <- e, not (isDataConWorkId x)
-- We don't consider (unsaturated!) DataCons as flexible variables
| Var y <- e, Nothing <- isDataConId_maybe x
-- We don't consider DataCons flexible variables
= modifyT (\delta -> addVarVarCt delta (x, y))
| otherwise
-- Any other expression. Try to find other uses of a semantically
......@@ -1635,9 +1635,9 @@ Compared to the situation where P and Q are DataCons, the lack of generativity
means we could never flag Q as redundant.
(also see Note [Undecidable Equality for PmAltCons] in PmTypes.)
On the other hand, if we fail to recognise the pattern synonym, we flag the
pattern match as incomplete. That wouldn't happen if had knowledge about the
scrutinee, in which case the oracle basically knows "If it's a P, then its field
is 15".
pattern match as inexhaustive. That wouldn't happen if we had knowledge about
the scrutinee, in which case the oracle basically knows "If it's a P, then its
field is 15".
This is a pretty narrow use case and I don't think we should to try to fix it
until a user complains energetically.
......
......@@ -131,8 +131,8 @@ import DynFlags
-- Turgid imports for showTypeCategory
import PrelNames
import TcType
import Type
import TyCon
import Predicate
import Data.Maybe
import qualified Data.Char
......
......@@ -1368,12 +1368,7 @@ cvtTypeKind ty_str ty
TupleT n
| Just normals <- m_normals
, normals `lengthIs` n -- Saturated
-> if n==1 then return (head normals) -- Singleton tuples treated
-- like nothing (ie just parens)
else returnL (HsTupleTy noExtField
HsBoxedOrConstraintTuple normals)
| n == 1
-> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
-> returnL (HsTupleTy noExtField HsBoxedOrConstraintTuple normals)
| otherwise
-> mk_apps
(HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))
......@@ -1491,8 +1486,6 @@ cvtTypeKind ty_str ty
-- Promoted data constructor; hence cName
PromotedTupleT n
| n == 1
-> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
| Just normals <- m_normals
, normals `lengthIs` n -- Saturated
-> returnL (HsExplicitTupleTy noExtField normals)
......
......@@ -106,7 +106,9 @@ module BasicTypes(
IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit,
SpliceExplicitFlag(..)
SpliceExplicitFlag(..),
TypeOrKind(..), isTypeLevel, isKindLevel
) where
import GhcPrelude
......@@ -1644,3 +1646,25 @@ data SpliceExplicitFlag
= ExplicitSplice | -- ^ <=> $(f x y)
ImplicitSplice -- ^ <=> f x y, i.e. a naked top level expression
deriving Data
{- *********************************************************************
* *
Types vs Kinds
* *
********************************************************************* -}
-- | Flag to see whether we're type-checking terms or kind-checking types
data TypeOrKind = TypeLevel | KindLevel
deriving Eq
instance Outputable TypeOrKind where
ppr TypeLevel = text "TypeLevel"
ppr KindLevel = text "KindLevel"
isTypeLevel :: TypeOrKind -> Bool
isTypeLevel TypeLevel = True
isTypeLevel KindLevel = False
isKindLevel :: TypeOrKind -> Bool
isKindLevel TypeLevel = False
isKindLevel KindLevel = True
......@@ -73,6 +73,7 @@ import FieldLabel
import Class
import Name
import PrelNames
import Predicate
import Var
import VarSet( emptyVarSet )
import Outputable
......
......@@ -73,9 +73,6 @@ module Id (
isConLikeId, isBottomingId, idIsFrom,
hasNoBinding,
-- ** Evidence variables
DictId, isDictId, isEvVar,
-- ** Join variables
JoinId, isJoinId, isJoinId_maybe, idJoinArity,
asJoinId, asJoinId_maybe, zapJoinId,
......@@ -129,7 +126,7 @@ import IdInfo
import BasicTypes
-- Imported and re-exported
import Var( Id, CoVar, DictId, JoinId,
import Var( Id, CoVar, JoinId,
InId, InVar,
OutId, OutVar,
idInfo, idDetails, setIdDetails, globaliseId, varType,
......@@ -584,20 +581,6 @@ isDeadBinder :: Id -> Bool
isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)
| otherwise = False -- TyVars count as not dead
{-
************************************************************************
* *
Evidence variables
* *
************************************************************************
-}
isEvVar :: Var -> Bool
isEvVar var = isEvVarType (varType var)
isDictId :: Id -> Bool
isDictId id = isDictTy (idType id)
{-
************************************************************************
* *
......
{-
Describes predicates as they are considered by the solver.
-}
module Predicate (
Pred(..), classifyPredType,
isPredTy, isEvVarType,
-- Equality predicates
EqRel(..), eqRelRole,
isEqPrimPred, isEqPred,
getEqPredTys, getEqPredTys_maybe, getEqPredRole,
predTypeEqRel,
mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,
mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,
-- Class predicates
mkClassPred, isDictTy,
isClassPred, isEqPredClass, isCTupleClass,
getClassPredTys, getClassPredTys_maybe,
-- Implicit parameters
isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, hasIPPred,
-- Evidence variables
DictId, isEvVar, isDictId
) where
import GhcPrelude
import Type
import Class
import TyCon
import Var
import Coercion
import PrelNames
import FastString
import Outputable
import Util
import Control.Monad ( guard )
-- | A predicate in the solver. The solver tries to prove Wanted predicates
-- from Given ones.
data Pred
= ClassPred Class [Type]
| EqPred EqRel Type Type
| IrredPred PredType
| ForAllPred [TyCoVarBinder] [PredType] PredType
-- ForAllPred: see Note [Quantified constraints] in TcCanonical
-- NB: There is no TuplePred case
-- Tuple predicates like (Eq a, Ord b) are just treated
-- as ClassPred, as if we had a tuple class with two superclasses
-- class (c1, c2) => (%,%) c1 c2
classifyPredType :: PredType -> Pred
classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of
Just (tc, [_, _, ty1, ty2])
| tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2
| tc `hasKey` eqPrimTyConKey -> EqPred NomEq ty1 ty2
Just (tc, tys)
| Just clas <- tyConClass_maybe tc
-> ClassPred clas tys
_ | (tvs, rho) <- splitForAllVarBndrs ev_ty
, (theta, pred) <- splitFunTys rho
, not (null tvs && null theta)
-> ForAllPred tvs theta pred
| otherwise
-> IrredPred ev_ty
-- --------------------- Dictionary types ---------------------------------
mkClassPred :: Class -> [Type] -> PredType
mkClassPred clas tys = mkTyConApp (classTyCon clas) tys
isDictTy :: Type -> Bool
isDictTy = isClassPred
getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type])
getClassPredTys ty = case getClassPredTys_maybe ty of
Just (clas, tys) -> (clas, tys)
Nothing -> pprPanic "getClassPredTys" (ppr ty)
getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
getClassPredTys_maybe ty = case splitTyConApp_maybe ty of
Just (tc, tys) | Just clas <- tyConClass_maybe tc -> Just (clas, tys)
_ -> Nothing
-- --------------------- Equality predicates ---------------------------------
-- | A choice of equality relation. This is separate from the type 'Role'
-- because 'Phantom' does not define a (non-trivial) equality relation.
data EqRel = NomEq | ReprEq
deriving (Eq, Ord)
instance Outputable EqRel where
ppr NomEq = text "nominal equality"
ppr ReprEq = text "representational equality"
eqRelRole :: EqRel -> Role
eqRelRole NomEq = Nominal
eqRelRole ReprEq = Representational
getEqPredTys :: PredType -> (Type, Type)
getEqPredTys ty
= case splitTyConApp_maybe ty of
Just (tc, [_, _, ty1, ty2])
| tc `hasKey` eqPrimTyConKey
|| tc `hasKey` eqReprPrimTyConKey
-> (ty1, ty2)
_ -> pprPanic "getEqPredTys" (ppr ty)
getEqPredTys_maybe :: PredType -> Maybe (Role, Type, Type)
getEqPredTys_maybe ty
= case splitTyConApp_maybe ty of
Just (tc, [_, _, ty1, ty2])
| tc `hasKey` eqPrimTyConKey -> Just (Nominal, ty1, ty2)
| tc `hasKey` eqReprPrimTyConKey -> Just (Representational, ty1, ty2)
_ -> Nothing
getEqPredRole :: PredType -> Role
getEqPredRole ty = eqRelRole (predTypeEqRel ty)
-- | Get the equality relation relevant for a pred type.
predTypeEqRel :: PredType -> EqRel
predTypeEqRel ty
| Just (tc, _) <- splitTyConApp_maybe ty
, tc `hasKey` eqReprPrimTyConKey
= ReprEq
| otherwise
= NomEq
{-------------------------------------------
Predicates on PredType
--------------------------------------------}
{-
Note [Evidence for quantified constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The superclass mechanism in TcCanonical.makeSuperClasses risks
taking a quantified constraint like
(forall a. C a => a ~ b)
and generate superclass evidence
(forall a. C a => a ~# b)
This is a funny thing: neither isPredTy nor isCoVarType are true
of it. So we are careful not to generate it in the first place:
see Note [Equality superclasses in quantified constraints]
in TcCanonical.
-}
isEvVarType :: Type -> Bool
-- True of (a) predicates, of kind Constraint, such as (Eq a), and (a ~ b)
-- (b) coercion types, such as (t1 ~# t2) or (t1 ~R# t2)
-- See Note [Types for coercions, predicates, and evidence] in TyCoRep
-- See Note [Evidence for quantified constraints]
isEvVarType ty = isCoVarType ty || isPredTy ty
isEqPredClass :: Class -> Bool
-- True of (~) and (~~)
isEqPredClass cls = cls `hasKey` eqTyConKey
|| cls `hasKey` heqTyConKey
isClassPred, isEqPred, isEqPrimPred, isIPPred :: PredType -> Bool
isClassPred ty = case tyConAppTyCon_maybe ty of
Just tyCon | isClassTyCon tyCon -> True
_ -> False
isEqPred ty -- True of (a ~ b) and (a ~~ b)
-- ToDo: should we check saturation?
| Just tc <- tyConAppTyCon_maybe ty
, Just cls <- tyConClass_maybe tc
= isEqPredClass cls
| otherwise
= False
isEqPrimPred ty = isCoVarType ty
-- True of (a ~# b) (a ~R# b)
isIPPred ty = case tyConAppTyCon_maybe ty of
Just tc -> isIPTyCon tc
_ -> False
isIPTyCon :: TyCon -> Bool
isIPTyCon tc = tc `hasKey` ipClassKey
-- Class and its corresponding TyCon have the same Unique
isIPClass :: Class -> Bool
isIPClass cls = cls `hasKey` ipClassKey
isCTupleClass :: Class -> Bool
isCTupleClass cls = isTupleTyCon (classTyCon cls)
isIPPred_maybe :: Type -> Maybe (FastString, Type)
isIPPred_maybe ty =
do (tc,[t1,t2]) <- splitTyConApp_maybe ty
guard (isIPTyCon tc)
x <- isStrLitTy t1
return (x,t2)
hasIPPred :: PredType -> Bool
hasIPPred pred
= case classifyPredType pred of
ClassPred cls tys
| isIPClass cls -> True
| isCTupleClass cls -> any hasIPPred tys
_other -> False
{-
************************************************************************
* *
Evidence variables
* *
************************************************************************
-}
isEvVar :: Var -> Bool
isEvVar var = isEvVarType (varType var)
isDictId :: Id -> Bool
isDictId id = isDictTy (varType id)
......@@ -6,8 +6,6 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fprof-auto-top #-}
--
-- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones,
-- and Norman Ramsey
......@@ -108,6 +106,7 @@ analyzeCmm
-> FactBase f
-> FactBase f
analyzeCmm dir lattice transfer cmmGraph initFact =
{-# SCC analyzeCmm #-}
let entry = g_entry cmmGraph
hooplGraph = g_graph cmmGraph
blockMap =
......@@ -169,7 +168,7 @@ rewriteCmm
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
rewriteCmm dir lattice rwFun cmmGraph initFact = do
rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do
let entry = g_entry cmmGraph
hooplGraph = g_graph cmmGraph
blockMap1 =
......
......@@ -30,6 +30,7 @@ import VarEnv
import Id
import Type
import TyCon ( initRecTc, checkRecTc )
import Predicate ( isDictTy )
import Coercion
import BasicTypes
import Unique
......@@ -517,7 +518,7 @@ mk_cheap_fn dflags cheap_app
= \e mb_ty -> exprIsCheapX cheap_app e
|| case mb_ty of
Nothing -> False
Just ty -> isDictLikeTy ty
Just ty -> isDictTy ty
----------------------
......@@ -624,9 +625,6 @@ The (foo DInt) is floated out, and makes ineffective a RULE
One could go further and make exprIsCheap reply True to any
dictionary-typed expression, but that's more work.
See Note [Dictionary-like types] in TcType.hs for why we use
isDictLikeTy here rather than isDictTy
Note [Eta expanding thunks]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
We don't eta-expand
......
......@@ -77,6 +77,7 @@ import Id
import IdInfo
import PrelNames( absentErrorIdKey )
import Type
import Predicate
import TyCoRep( TyCoBinder(..), TyBinder )
import Coercion
import TyCon
......
......@@ -1071,7 +1071,7 @@ noFVs = emptyOccEnv
-- to filter additions to the latter. This gives us complete control
-- over what free variables we track.
data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
deriving (Functor)
-- a combination of a state monad (TickTransState) and a writer
-- monad (FreeVars).
......
......@@ -327,7 +327,7 @@ dsProcExpr pat (dL->L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
fail_expr <- mkFailExpr ProcExpr env_stk_ty
var <- selectSimpleMatchVarL pat
match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr
let pat_ty = hsLPatType pat
let pat_ty = hsPatType pat
let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty
(Lam var match_code)
core_cmd
......@@ -868,7 +868,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do
-- but that's likely to be defined in terms of first.
dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do
let pat_ty = hsLPatType pat
let pat_ty = hsPatType pat
(core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
let pat_vars = mkVarSet (collectPatBinders pat)
let
......
......@@ -41,6 +41,7 @@ import CoreArity ( etaExpand )
import CoreUnfold
import CoreFVs
import Digraph
import Predicate
import PrelNames
import TyCon
......
module DsBinds where
import DsMonad ( DsM )
import CoreSyn ( CoreExpr )
import TcEvidence (HsWrapper)
dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
......@@ -930,7 +930,7 @@ dsDo stmts
(pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
do_arg (XApplicativeArg nec) = noExtCon nec
arg_tys = map hsLPatType pats
arg_tys = map hsPatType pats
; rhss' <- sequence rhss
......
......@@ -279,7 +279,7 @@ deBindComp pat core_list1 quals core_list2 = do
let u3_ty@u1_ty = exprType core_list1 -- two names, same thing
-- u1_ty is a [alpha] type, and u2_ty = alpha
let u2_ty = hsLPatType pat
let u2_ty = hsPatType pat
let res_ty = exprType core_list2
h_ty = u1_ty `mkVisFunTy` res_ty
......@@ -373,7 +373,7 @@ dfBindComp :: Id -> Id -- 'c' and 'n'
-> DsM CoreExpr
dfBindComp c_id n_id (pat, core_list1) quals = do
-- find the required type
let x_ty = hsLPatType pat
let x_ty = hsPatType pat
let b_ty = idType n_id
-- create some new local id's
......
......@@ -672,7 +672,7 @@ mkSelectorBinds ticks pat val_expr
= return (v, [(v, val_expr)])
| is_flat_prod_lpat pat' -- Special case (B)
= do { let pat_ty = hsLPatType pat'
= do { let pat_ty = hsPatType pat'
; val_var <- newSysLocalDsNoLP pat_ty
; let mk_bind tick bndr_var
......@@ -758,7 +758,7 @@ mkLHsPatTup lpats = cL (getLoc (head lpats)) $
mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
-- A vanilla tuple pattern simply gets its type from its sub-patterns
mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
mkVanillaTuplePat pats box = TuplePat (map hsPatType pats) pats box
-- The Big equivalents for the source tuple expressions
mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
......
......@@ -214,6 +214,7 @@ Library
Hooks
Id
IdInfo
Predicate
Lexeme
Literal
Llvm
......@@ -505,6 +506,8 @@ Library
TcRnExports
TcRnMonad
TcRnTypes
Constraint
TcOrigin
TcRules
TcSimplify
TcHoleErrors
......@@ -593,6 +596,7 @@ Library
Instruction
BlockLayout
CFG
Dominators
Format
Reg
RegClass
......
......@@ -10,6 +10,7 @@
-- | Binary interface file support.
module BinIface (
-- * Public API for interface file serialisation
writeBinIface,
readBinIface,
getSymtabName,
......@@ -17,7 +18,16 @@ module BinIface (
CheckHiWay(..),
TraceBinIFaceReading(..),
getWithUserData,
putWithUserData
putWithUserData,
-- * Internal serialisation functions
getSymbolTable,
putName,
putDictionary,
putFastString,
putSymbolTable,
BinSymbolTable(..),
BinDictionary(..)
) where
......
......@@ -311,6 +311,7 @@ import GhcMonad
import TcRnMonad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import LoadIface ( loadSysInterface )
import TcRnTypes
import Predicate
import Packages
import NameSet
import RdrName
......
......@@ -63,6 +63,9 @@ import TyCon
import Type hiding( typeKind )
import RepType
import TcType
import Constraint
import TcOrigin
import Predicate
import Var
import Id
import Name hiding ( varName )
......
......@@ -558,12 +558,11 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
(cmmTopCodeGen ncgImpl)
fileIds dbgMap opt_cmm cmmCfg
dumpIfSet_dyn dflags
Opt_D_dump_asm_native "Native code"
(vcat $ map (pprNatCmmDecl ncgImpl) native)
dumpIfSet_dyn dflags
when (not $ null nativeCfgWeights) $ dumpIfSet_dyn dflags
Opt_D_dump_cfg_weights "CFG Weights"
(pprEdgeWeights nativeCfgWeights)
......@@ -679,19 +678,20 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats)
let cfgWithFixupBlks =
addNodesBetween nativeCfgWeights cfgRegAllocUpdates
(\cfg -> addNodesBetween cfg cfgRegAllocUpdates) <$> livenessCfg
-- Insert stack update blocks
let postRegCFG =
foldl' (\m (from,to) -> addImmediateSuccessor from to m )
cfgWithFixupBlks stack_updt_blks
pure (foldl' (\m (from,to) -> addImmediateSuccessor from to m ))
<*> cfgWithFixupBlks
<*> pure stack_updt_blks
---- generate jump tables
let tabled =
{-# SCC "generateJumpTables" #-}
generateJumpTables ncgImpl alloced
dumpIfSet_dyn dflags
when (not $ null nativeCfgWeights) $ dumpIfSet_dyn dflags
Opt_D_dump_cfg_weights "CFG Update information"
( text "stack:" <+> ppr stack_updt_blks $$
text "linearAlloc:" <+> ppr cfgRegAllocUpdates )
......@@ -701,12 +701,14 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
{-# SCC "shortcutBranches" #-}
shortcutBranches dflags ncgImpl tabled postRegCFG
let optimizedCFG =
optimizeCFG (cfgWeightInfo dflags) cmm postShortCFG
let optimizedCFG :: Maybe CFG
optimizedCFG =
optimizeCFG (cfgWeightInfo dflags) cmm <$!> postShortCFG
dumpIfSet_dyn dflags
Opt_D_dump_cfg_weights "CFG Final Weights"
( pprEdgeWeights optimizedCFG )
maybe (return ()) (\cfg->
dumpIfSet_dyn dflags Opt_D_dump_cfg_weights "CFG Final Weights"
( pprEdgeWeights cfg ))
optimizedCFG
--TODO: Partially check validity of the cfg.
let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks
......@@ -716,7 +718,8 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
(gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do
let blocks = concatMap getBlks shorted
let labels = setFromList $ fmap blockId blocks :: LabelSet
return $! seq (sanityCheckCfg optimizedCFG labels $
let cfg = fromJust optimizedCFG
return $! seq (sanityCheckCfg cfg labels $
text "cfg not in lockstep") ()
---- sequence blocks
......@@ -734,7 +737,9 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
{-# SCC "invertCondBranches" #-}
map invert sequenced
where
invertConds = (invertCondBranches ncgImpl) optimizedCFG
invertConds :: LabelMap CmmStatics -> [NatBasicBlock instr]
-> [NatBasicBlock instr]
invertConds = invertCondBranches ncgImpl optimizedCFG
invert top@CmmData {} = top
invert (CmmProc info lbl live (ListGraph blocks)) =
CmmProc info lbl live (ListGraph $ invertConds info blocks)
......@@ -884,13 +889,13 @@ shortcutBranches
:: forall statics instr jumpDest. (Outputable jumpDest) => DynFlags
-> NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr]
-> CFG
-> ([NatCmmDecl statics instr],CFG)
-> Maybe CFG
-> ([NatCmmDecl statics instr],Maybe CFG)
shortcutBranches dflags ncgImpl tops weights
| gopt Opt_AsmShortcutting dflags
= ( map (apply_mapping ncgImpl mapping) tops'
, shortcutWeightMap weights mappingBid )
, shortcutWeightMap mappingBid <$!> weights )
| otherwise
= (tops, weights)
where
......
This diff is collapsed.
This diff is collapsed.
......@@ -88,7 +88,7 @@ data NcgImpl statics instr jumpDest = NcgImpl {
-- the block's 'UnwindPoint's
-- See Note [What is this unwinding business?] in Debug
-- and Note [Unwinding information in the NCG] in this module.
invertCondBranches :: CFG -> LabelMap CmmStatics -> [NatBasicBlock instr]
invertCondBranches :: Maybe CFG -> LabelMap CmmStatics -> [NatBasicBlock instr]
-> [NatBasicBlock instr]
-- ^ Turn the sequence of `jcc l1; jmp l2` into `jncc l2; <block_l1>`
-- when possible.
......
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ScopedTypeVariables, GADTs, BangPatterns #-}
module RegAlloc.Graph.SpillCost (
SpillCostRecord,
plusSpillCostRecord,
......@@ -23,6 +23,7 @@ import Reg
import GraphBase
import Hoopl.Collections (mapLookup)
import Hoopl.Label
import Cmm
import UniqFM
import UniqSet
......@@ -49,9 +50,6 @@ type SpillCostRecord
type SpillCostInfo
= UniqFM SpillCostRecord
-- | Block membership in a loop
type LoopMember = Bool
type SpillCostState = State (UniqFM SpillCostRecord) ()
-- | An empty map of spill costs.
......@@ -88,45 +86,49 @@ slurpSpillCostInfo platform cfg cmm
where
countCmm CmmData{} = return ()
countCmm (CmmProc info _ _ sccs)
= mapM_ (countBlock info)
= mapM_ (countBlock info freqMap)
$ flattenSCCs sccs
where
LiveInfo _ entries _ _ = info
freqMap = (fst . mkGlobalWeights (head entries)) <$> cfg
-- Lookup the regs that are live on entry to this block in
-- the info table from the CmmProc.
countBlock info (BasicBlock blockId instrs)
countBlock info freqMap (BasicBlock blockId instrs)
| LiveInfo _ _ blockLive _ <- info
, Just rsLiveEntry <- mapLookup blockId blockLive
, rsLiveEntry_virt <- takeVirtuals rsLiveEntry
= countLIs (loopMember blockId) rsLiveEntry_virt instrs
= countLIs (ceiling $ blockFreq freqMap blockId) rsLiveEntry_virt instrs
| otherwise
= error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block"
countLIs :: LoopMember -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState
countLIs :: Int -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState
countLIs _ _ []
= return ()
-- Skip over comment and delta pseudo instrs.
countLIs inLoop rsLive (LiveInstr instr Nothing : lis)
countLIs scale rsLive (LiveInstr instr Nothing : lis)
| isMetaInstr instr
= countLIs inLoop rsLive lis
= countLIs scale rsLive lis
| otherwise
= pprPanic "RegSpillCost.slurpSpillCostInfo"
$ text "no liveness information on instruction " <> ppr instr
countLIs inLoop rsLiveEntry (LiveInstr instr (Just live) : lis)
countLIs scale rsLiveEntry (LiveInstr instr (Just live) : lis)
= do
-- Increment the lifetime counts for regs live on entry to this instr.
mapM_ (incLifetime (loopCount inLoop)) $ nonDetEltsUniqSet rsLiveEntry
mapM_ incLifetime $ nonDetEltsUniqSet rsLiveEntry
-- This is non-deterministic but we do not
-- currently support deterministic code-generation.
-- See Note [Unique Determinism and code generation]
-- Increment counts for what regs were read/written from.
let (RU read written) = regUsageOfInstr platform instr
mapM_ (incUses (loopCount inLoop)) $ catMaybes $ map takeVirtualReg $ nub read
mapM_ (incDefs (loopCount inLoop)) $ catMaybes $ map takeVirtualReg $ nub written
mapM_ (incUses scale) $ catMaybes $ map takeVirtualReg $ nub read
mapM_ (incDefs scale) $ catMaybes $ map takeVirtualReg $ nub written
-- Compute liveness for entry to next instruction.
let liveDieRead_virt = takeVirtuals (liveDieRead live)
......@@ -140,21 +142,18 @@ slurpSpillCostInfo platform cfg cmm
= (rsLiveAcross `unionUniqSets` liveBorn_virt)
`minusUniqSet` liveDieWrite_virt
countLIs inLoop rsLiveNext lis
countLIs scale rsLiveNext lis
loopCount inLoop
| inLoop = 10
| otherwise = 1
incDefs count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, count, 0, 0)
incUses count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, count, 0)
incLifetime count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, count)
incLifetime reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, 1)
loopBlocks = CFG.loopMembers <$> cfg
loopMember bid
| Just isMember <- join (mapLookup bid <$> loopBlocks)
= isMember
blockFreq :: Maybe (LabelMap Double) -> Label -> Double
blockFreq freqs bid
| Just freq <- join (mapLookup bid <$> freqs)
= max 1.0 (10000 * freq)
| otherwise
= False
= 1.0 -- Only if no cfg given
-- | Take all the virtual registers from this set.
takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg
......@@ -215,31 +214,39 @@ chooseSpill info graph
-- Without live range splitting, its's better to spill from the outside
-- in so set the cost of very long live ranges to zero
--
{-
spillCost_chaitin
:: SpillCostInfo
-> Graph Reg RegClass Reg
-> Reg
-> Float
spillCost_chaitin info graph reg
-- Spilling a live range that only lives for 1 instruction
-- isn't going to help us at all - and we definitely want to avoid
-- trying to re-spill previously inserted spill code.
| lifetime <= 1 = 1/0
-- It's unlikely that we'll find a reg for a live range this long
-- better to spill it straight up and not risk trying to keep it around
-- and have to go through the build/color cycle again.
| lifetime > allocatableRegsInClass (regClass reg) * 10
= 0
-- spillCost_chaitin
-- :: SpillCostInfo
-- -> Graph VirtualReg RegClass RealReg
-- -> VirtualReg
-- -> Float
-- spillCost_chaitin info graph reg
-- -- Spilling a live range that only lives for 1 instruction
-- -- isn't going to help us at all - and we definitely want to avoid
-- -- trying to re-spill previously inserted spill code.
-- | lifetime <= 1 = 1/0
-- -- It's unlikely that we'll find a reg for a live range this long
-- -- better to spill it straight up and not risk trying to keep it around
-- -- and have to go through the build/color cycle again.
-- -- To facility this we scale down the spill cost of long ranges.
-- -- This makes sure long ranges are still spilled first.
-- -- But this way spill cost remains relevant for long live
-- -- ranges.
-- | lifetime >= 128
-- = (spillCost / conflicts) / 10.0
-- -- Otherwise revert to chaitin's regular cost function.
-- | otherwise = (spillCost / conflicts)
-- where
-- !spillCost = fromIntegral (uses + defs) :: Float
-- conflicts = fromIntegral (nodeDegree classOfVirtualReg graph reg)
-- (_, defs, uses, lifetime)
-- = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg
-- Otherwise revert to chaitin's regular cost function.
| otherwise = fromIntegral (uses + defs)
/ fromIntegral (nodeDegree graph reg)
where (_, defs, uses, lifetime)
= fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg
-}
-- Just spill the longest live range.
spillCost_length
......
This diff is collapsed.
......@@ -81,6 +81,7 @@ module TysPrim(
eqPrimTyCon, -- ty1 ~# ty2
eqReprPrimTyCon, -- ty1 ~R# ty2 (at role Representational)
eqPhantPrimTyCon, -- ty1 ~P# ty2 (at role Phantom)
equalityTyCon,
-- * SIMD
#include "primop-vector-tys-exports.hs-incl"
......@@ -919,6 +920,12 @@ eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles
res_kind = unboxedTupleKind []
roles = [Nominal, Nominal, Phantom, Phantom]
-- | Given a Role, what TyCon is the type of equality predicates at that role?
equalityTyCon :: Role -> TyCon
equalityTyCon Nominal = eqPrimTyCon
equalityTyCon Representational = eqReprPrimTyCon
equalityTyCon Phantom = eqPhantPrimTyCon
{- *********************************************************************
* *
The primitive array types
......
......@@ -92,7 +92,8 @@ module TysWiredIn (
-- * Kinds
typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind,
isLiftedTypeKindTyConName, liftedTypeKind, constraintKind,
isLiftedTypeKindTyConName, liftedTypeKind,
typeToTypeKind, constraintKind,
liftedTypeKindTyCon, constraintKindTyCon, constraintKindTyConName,
liftedTypeKindTyConName,
......@@ -612,8 +613,9 @@ typeSymbolKind = mkTyConTy typeSymbolKindCon
constraintKindTyCon :: TyCon
constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] []
liftedTypeKind, constraintKind :: Kind
liftedTypeKind, typeToTypeKind, constraintKind :: Kind
liftedTypeKind = tYPE liftedRepTy
typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind
constraintKind = mkTyConApp constraintKindTyCon []
{-
......
......@@ -49,7 +49,7 @@ import NameSet
import RdrName ( RdrName, rdrNameOcc )
import SrcLoc
import ListSetOps ( findDupsEq )
import BasicTypes ( RecFlag(..) )
import BasicTypes ( RecFlag(..), TypeOrKind(..) )
import Digraph ( SCC(..) )
import Bag
import Util
......
......@@ -52,7 +52,7 @@ import NameEnv
import Avail
import Outputable
import Bag
import BasicTypes ( pprRuleName )
import BasicTypes ( pprRuleName, TypeOrKind(..) )
import FastString
import SrcLoc
import DynFlags
......
......@@ -57,8 +57,9 @@ import FieldLabel
import Util
import ListSetOps ( deleteBys )
import BasicTypes ( compareFixity, funTyFixity, negateFixity,
Fixity(..), FixityDirection(..), LexicalFixity(..) )
import BasicTypes ( compareFixity, funTyFixity, negateFixity
, Fixity(..), FixityDirection(..), LexicalFixity(..)
, TypeOrKind(..) )
import Outputable
import FastString
import Maybes
......
......@@ -16,6 +16,7 @@ import GhcPrelude
import Id
import TcType hiding( substTy )
import Type hiding( substTy, extendTvSubstList )
import Predicate
import Module( Module, HasModule(..) )
import Coercion( Coercion )
import CoreMonad
......
......@@ -30,6 +30,7 @@ import Literal ( absentLiteralOf, rubbishLit )
import VarEnv ( mkInScopeSet )
import VarSet ( VarSet )
import Type
import Predicate ( isClassPred )
import RepType ( isVoidTy, typePrimRep )
import Coercion
import FamInstEnv
......
......@@ -3,7 +3,7 @@
module ClsInst (
matchGlobalInst,
ClsInstResult(..),
InstanceWhat(..), safeOverlap,
InstanceWhat(..), safeOverlap, instanceReturnsDictCon,
AssocInstInfo(..), isNotAssociated
) where
......@@ -17,6 +17,7 @@ import TcType
import TcTypeable
import TcMType
import TcEvidence
import Predicate
import RnEnv( addUsedGRE )
import RdrName( lookupGRE_FieldLabel )
import InstEnv
......@@ -31,7 +32,7 @@ import Id
import Type
import MkCore ( mkStringExprFS, mkNaturalExpr )
import Name ( Name )
import Name ( Name, pprDefinedAt )
import VarEnv ( VarEnv )
import DataCon
import TyCon
......@@ -91,6 +92,8 @@ data ClsInstResult
data InstanceWhat
= BuiltinInstance
| BuiltinEqInstance -- A built-in "equality instance"; see the
-- TcSMonad Note [Solved dictionaries]
| LocalInstance
| TopLevInstance { iw_dfun_id :: DFunId
, iw_safe_over :: SafeOverlapping }
......@@ -103,15 +106,24 @@ instance Outputable ClsInstResult where
= text "OneInst" <+> vcat [ppr ev, ppr what]
instance Outputable InstanceWhat where
ppr BuiltinInstance = text "built-in instance"
ppr LocalInstance = text "locally-quantified instance"
ppr (TopLevInstance { iw_safe_over = so })
= text "top-level instance" <+> (text $ if so then "[safe]" else "[unsafe]")
ppr BuiltinInstance = text "a built-in instance"
ppr BuiltinEqInstance = text "a built-in equality instance"
ppr LocalInstance = text "a locally-quantified instance"
ppr (TopLevInstance { iw_dfun_id = dfun })
= hang (text "instance" <+> pprSigmaType (idType dfun))
2 (text "--" <+> pprDefinedAt (idName dfun))
safeOverlap :: InstanceWhat -> Bool
safeOverlap (TopLevInstance { iw_safe_over = so }) = so
safeOverlap _ = True
instanceReturnsDictCon :: InstanceWhat -> Bool
-- See Note [Solved dictionaries] in TcSMonad
instanceReturnsDictCon (TopLevInstance {}) = True
instanceReturnsDictCon BuiltinInstance = True
instanceReturnsDictCon BuiltinEqInstance = False
instanceReturnsDictCon LocalInstance = False
matchGlobalInst :: DynFlags
-> Bool -- True <=> caller is the short-cut solver
-- See Note [Shortcut solving: overlap]
......@@ -561,14 +573,14 @@ matchHeteroEquality :: [Type] -> TcM ClsInstResult
matchHeteroEquality args
= return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon args ]
, cir_mk_ev = evDataConApp heqDataCon args
, cir_what = BuiltinInstance })
, cir_what = BuiltinEqInstance })
matchHomoEquality :: [Type] -> TcM ClsInstResult
-- Solves (t1 ~ t2)
matchHomoEquality args@[k,t1,t2]
= return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon [k,k,t1,t2] ]
, cir_mk_ev = evDataConApp eqDataCon args
, cir_what = BuiltinInstance })
, cir_what = BuiltinEqInstance })
matchHomoEquality args = pprPanic "matchHomoEquality" (ppr args)
-- See also Note [The equality types story] in TysPrim
......@@ -576,7 +588,7 @@ matchCoercible :: [Type] -> TcM ClsInstResult
matchCoercible args@[k, t1, t2]
= return (OneInst { cir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ]
, cir_mk_ev = evDataConApp coercibleDataCon args
, cir_what = BuiltinInstance })
, cir_what = BuiltinEqInstance })
where
args' = [k, k, t1, t2]
matchCoercible args = pprPanic "matchLiftedCoercible" (ppr args)
......
This diff is collapsed.
......@@ -24,6 +24,7 @@ import GhcPrelude
import Name
import Var
import Class
import Predicate
import Type
import TcType( transSuperClasses )
import CoAxiom( TypeEqn )
......
<
......@@ -42,6 +42,9 @@ import FastString
import GHC.Hs
import TcHsSyn
import TcRnMonad
import Constraint
import Predicate
import TcOrigin
import TcEnv
import TcEvidence
import InstEnv
......@@ -66,6 +69,7 @@ import SrcLoc
import DynFlags
import Util
import Outputable
import BasicTypes ( TypeOrKind(..) )
import qualified GHC.LanguageExtensions as LangExt