Skip to content
Commits on Source (62)
  • Richard Eisenberg's avatar
    anyRewritableTyVar now looks in RuntimeReps · 5fa9cb82
    Richard Eisenberg authored and Marge Bot's avatar Marge Bot committed
    Previously, anyRewritableTyVar looked only at the arg and res
    of `arg -> res`, but their RuntimeReps are also subject to
    rewriting. Easy to fix.
    
    Test case: typecheck/should_compile/T17024
    
    Fixes #17024.
    5fa9cb82
  • Ben Price's avatar
    Clarify a Lint message · 5ba01d83
    Ben Price authored and Marge Bot's avatar Marge Bot committed
    When developing a plugin I had a shadowing problem, where I generated
    code
      app = \f{v r7B} x{v r7B} -> f{v r7B} x{v r7B}
    This is obviously wrong, since the occurrence of `f` to the right of the
    arrow refers to the `x` binder (they share a Unique). However, it is
    rather confusing when Lint reports
      Mismatch in type between binder and occurrence
      Var: x{v rB7}
    since it is printing the binder, rather than the occurrence.
    It is rather easy to read this as claiming there is something wrong with
    the `x` occurrence!
    
    We change the report to explicitly print both the binder and the
    occurrence variables.
    5ba01d83
  • Simon Peyton Jones's avatar
    Comments only · 7b2c827b
    Simon Peyton Jones authored and Marge Bot's avatar Marge Bot committed
    Clarify code added in #17852 and MR !2724
    7b2c827b
  • Krzysztof Gogolewski's avatar
    Misc cleanup · 3300eeac
    Krzysztof Gogolewski authored and Marge Bot's avatar Marge Bot committed
    - Remove Note [Existentials in shift_con_pat].
      The function shift_con_pat has been removed 15 years ago in 23f40f0e.
    - Remove kcLookupTcTyCon - it's the same as tcLookupTcTyCon
    - Remove ASSERT in tyConAppArgN. It's already done by getNth,
      and it's the only reason getNth exists.
    - Remove unused function nextRole
    3300eeac
  • Krzysztof Gogolewski's avatar
    Typos in comments [skip ci] · abf5736b
    Krzysztof Gogolewski authored
    abf5736b
  • Ben Gamari's avatar
    rts: Prefer darwin-specific getCurrentThreadCPUTime · bb586f89
    Ben Gamari authored and Marge Bot's avatar Marge Bot committed
    macOS Catalina now supports a non-POSIX-compliant version of clock_gettime
    which cannot use the clock_gettime codepath.
    
    Fixes #17906.
    bb586f89
  • Sylvain Henry's avatar
    Split GHC.Iface.Utils module · 20800b9a
    Sylvain Henry authored and Marge Bot's avatar Marge Bot committed
    * GHC.Iface.Recomp: recompilation avoidance stuff
    * GHC.Iface.Make: mkIface*
    
    Moved `writeIfaceFile` into GHC.Iface.Load alongside `readIface` and
    renamed it `writeIface` for consistency.
    20800b9a
  • Greg Steuck's avatar
    Fixed a minor typo in codegen.rst · 1daa2029
    Greg Steuck authored and Marge Bot's avatar Marge Bot committed
    1daa2029
  • Ryan Scott's avatar
    Re-quantify when generalising over rewrite rule types · 0bc23338
    Ryan Scott authored and Marge Bot's avatar Marge Bot committed
    Previously, `tcRules` would check for naughty quantification
    candidates (see `Note [Naughty quantification candidates]` in
    `TcMType`) when generalising over the type of a rewrite rule. This
    caused sensible-looking rewrite rules (like those in #17710) to be
    rejected. A more permissing (and easier-to-implement) approach is to
    do what is described in `Note [Generalising in tcTyFamInstEqnGuts]`
    in `TcTyClsDecls`: just re-quantify all the type variable binders,
    regardless of the order in which the user specified them. After all,
    the notion of type variable specificity has no real meaning in
    rewrite rules, since one cannot "visibly apply" a rewrite rule.
    I have written up this wisdom in
    `Note [Re-quantify type variables in rules]` in `TcRules`.
    
    As a result of this patch, compiling the `ExplicitForAllRules1` test
    case now generates one fewer warning than it used to. As far as I can
    tell, this is benign, since the thing that the disappearing warning
    talked about was also mentioned in an entirely separate warning.
    
    Fixes #17710.
    0bc23338
  • Ben Gamari's avatar
    testsuite: Mark ghci056 and ghcilink004 as fragile in unreg · 336eac7e
    Ben Gamari authored and Marge Bot's avatar Marge Bot committed
    As noted in #17018.
    
    Also fix fragile declaration of T13786, which only runs in the normal
    way.
    336eac7e
  • Simon Peyton Jones's avatar
    Deepen call stack for isIn · c61b9b02
    Simon Peyton Jones authored and Marge Bot's avatar Marge Bot committed
    I see quite a few warnings like:
    
      WARNING: file compiler/utils/Util.hs, line 593
        Over-long elem in unionLists
    
    But the call stack is uninformative.   Better to add HasDebugCallStack
    to isIn.  Ditto isn'tIn.
    c61b9b02
  • Ömer Sinan Ağacan's avatar
    Zero any slop after compaction in compacting GC · 3aa9b35f
    Ömer Sinan Ağacan authored and Marge Bot's avatar Marge Bot committed
    In copying GC, with the relevant debug flags enabled, we release the old
    blocks after a GC, and the block allocator zeroes the space before
    releasing a block. This effectively zeros the old heap.
    
    In compacting GC we reuse the blocks and previously we didn't zero the
    unused space in a compacting generation after compaction. With this
    patch we zero the slop between the free pointer and the end of the block
    when we're done with compaction and when switching to a new block
    (because the current block doesn't have enough space for the next object
    we're shifting).
    3aa9b35f
  • Sylvain Henry's avatar
    Refactor GHC.Driver.Session (Ways and Flags) · 8e6febce
    Sylvain Henry authored and Marge Bot's avatar Marge Bot committed
    * extract flags and ways into their own modules (with some renaming)
    
    * remove one SOURCE import of GHC.Driver.Session from GHC.Driver.Phases
    
    * when GHC uses dynamic linking (WayDyn), `interpWays` was only
      reporting WayDyn even if the host was profiled (WayProf).  Now it
      returns both as expected (might fix #16803).
    
    * `mkBuildTag :: [Way] -> String` wasn't reporting a canonical tag for
      differently ordered lists. Now we sort and nub the list to fix this.
    8e6febce
  • Sylvain Henry's avatar
    Refactor interpreterDynamic and interpreterProfiled · bc41e471
    Sylvain Henry authored and Marge Bot's avatar Marge Bot committed
    * `interpreterDynamic` and `interpreterProfiled` now take `Interp`
      parameters instead of DynFlags
    
    * slight refactoring of `ExternalInterp` so that we can read the iserv
      configuration (which is pure) without reading an MVar.
    bc41e471
  • Sylvain Henry's avatar
    Use a Set to represent Ways · a6989971
    Sylvain Henry authored and Marge Bot's avatar Marge Bot committed
    Should make `member` queries faster and avoid messing up with missing
    `nubSort`.
    
    Metric Increase:
        hie002
    a6989971
  • Ryan Scott's avatar
    Make DeriveFunctor-generated code require fewer beta reductions · cb93a1a4
    Ryan Scott authored and Marge Bot's avatar Marge Bot committed
    Issue #17880 demonstrates that `DeriveFunctor`-generated code is
    surprisingly fragile when rank-_n_ types are involved. The culprit is
    that `$fmap` (the algorithm used to generate `fmap` implementations)
    was too keen on applying arguments with rank-_n_ types to lambdas,
    which fail to typecheck more often than not.
    
    In this patch, I change `$fmap` (both the specification and the
    implementation) to produce code that avoids creating as many lambdas,
    avoiding problems when rank-_n_ field types arise.
    See the comments titled "Functor instances" in `TcGenFunctor` for a
    more detailed description. Not only does this fix #17880, but it also
    ensures that the code that `DeriveFunctor` generates will continue
    to work after simplified subsumption is implemented (see #17775).
    
    What is truly amazing is that #17880 is actually a regression
    (introduced in GHC 7.6.3) caused by commit
    49ca2a37, the fix #7436. Prior to
    that commit, the version of `$fmap` that was used was almost
    identical to the one used in this patch! Why did that commit change
    `$fmap` then? It was to avoid severe performance issues that would
    arise for recursive `fmap` implementations, such as in the example
    below:
    
    ```hs
    data List a = Nil | Cons a (List a) deriving Functor
    
    -- ===>
    
    instance Functor List where
      fmap f Nil = Nil
      fmap f (Cons x xs) = Cons (f x) (fmap (\y -> f y) xs)
    ```
    
    The fact that `\y -> f y` was eta expanded caused significant
    performance overheads. Commit
    49ca2a37 fixed this performance
    issue, but it went too far. As a result, this patch partially
    reverts 49ca2a37.
    
    To ensure that the performance issues pre-#7436 do not resurface,
    I have taken some precautionary measures:
    
    * I have added a special case to `$fmap` for situations where the
      last type variable in an application of some type occurs directly.
      If this special case fires, we avoid creating a lambda expression.
      This ensures that we generate
      `fmap f (Cons x xs) = Cons (f x) (fmap f xs)` in the derived
      `Functor List` instance above. For more details, see
      `Note [Avoid unnecessary eta expansion in derived fmap implementations]`
      in `TcGenFunctor`.
    * I have added a `T7436b` test case to ensure that the performance
      of this derived `Functor List`-style code does not regress.
    
    When implementing this, I discovered that `$replace`, the algorithm
    which generates implementations of `(<$)`, has a special case that is
    very similar to the `$fmap` special case described above. `$replace`
    marked this special case with a custom `Replacer` data type, which
    was a bit overkill. In order to use the same machinery for both
    `Functor` methods, I ripped out `Replacer` and instead implemented
    a simple way to detect the special case. See the updated commentary
    in `Note [Deriving <$]` for more details.
    cb93a1a4
  • Kirill Elagin's avatar
    pretty-printer: Properly parenthesise LastStmt · 1f9db3e7
    Kirill Elagin authored and Marge Bot's avatar Marge Bot committed
    After ApplicatveDo strips the last `return` during renaming, the pretty
    printer has to restore it. However, if the return was followed by `$`,
    the dollar was stripped too and not restored.
    
    For example, the last stamement in:
    
    ```
      foo = do
        x <- ...
        ...
        return $ f x
    ```
    
    would be printed as:
    
    ```
        return f x
    ```
    
    This commit preserved the dolar, so it becomes:
    
    ```
        return $ f x
    ```
    1f9db3e7
  • Kirill Elagin's avatar
    pretty-printer: Do not print ApplicativeDo join · 5cb93af7
    Kirill Elagin authored and Marge Bot's avatar Marge Bot committed
    * Do not print `join` in ApplictiveStmt, unless ppr-debug
    * Print parens around multiple parallel binds
    
    When ApplicativeDo is enabled, the renamer analyses the statements of a
    `do` block and in certain cases marks them as needing to be rewritten
    using `join`.
    
    For example, if you have:
    
    ```
    foo = do
      a <- e1
      b <- e2
      doSomething a b
    ```
    
    it will be desugared into:
    
    ```
    foo = join (doSomething <$> e1 <*> e2)
    ```
    
    After renaming but before desugaring the expression is stored
    essentially as:
    
    ```
    foo = do
      [will need join] (a <- e1 | b <- e2)
      [no return] doSomething a b
    ```
    
    Before this change, the pretty printer would print a call to `join`,
    even though it is not needed at this stage at all. The expression will be
    actually rewritten into one using join only at desugaring, at which
    point a literal call to join will be inserted.
    5cb93af7
  • Simon Peyton Jones's avatar
    Expose compulsory unfoldings always · 3a259092
    Simon Peyton Jones authored and Marge Bot's avatar Marge Bot committed
    The unsafeCoerce# patch requires that unsafeCoerce# has
    a compulsory unfolding that is always available.  So we have
    to be careful to expose compulsory unfoldings unconditionally
    and consistently.
    
    We didn't get this quite right: #17871.  This patch fixes
    it.  No real surprises here.
    
    See Note [Always expose compulsory unfoldings] in GHC.Iface.Tidy
    3a259092
  • Alp Mestanogullari's avatar
    hadrian: improve dependency tracking for the check-* programs · 6a65b8c2
    Alp Mestanogullari authored and Marge Bot's avatar Marge Bot committed
    The code in Rules.Register responsible for finding all the build artifacts
    that Cabal installs when registering a library (static/shared libs, .hi files,
    ...) was looking in the wrong place. This patch fixes that logic and makes sure
    we gather all those artifacts in a list to declare that the rule for a given
    `.conf` file, our proxy for "Hadrian, please install this package in the package
    db for this stage", also produces those artifacts under the said package
    database.
    
    We also were completely missing some logic to declare that the check-* programs
    have dependencies besides their source code, at least when testing an in-tree
    compiler.
    
    Finally, this patch also removes redundant packages from 'testsuitePackages',
    since they should already be covered by the stage<N>Packages lists from
    Settings.Default.
    
    With this patch, after a complete build and freezing stage 1, a change to
    `compiler/parser/Parser.y` results in rebuilding the ghc lib, reinstalling it,
    and rebuilding the few programs that depend on it, _including_ `check-ppr` and
    `check-api-annotations` (therefore fixing #17273).
    6a65b8c2
  • Sylvain Henry's avatar
    Rename isDllName · 44fad4a9
    Sylvain Henry authored and Marge Bot's avatar Marge Bot committed
    I wanted to fix the dangling comment in `isDllName` ("This is the cause
    of #", #8696 is already mentioned earlier). I took the opportunity to
    change the function name to better reflect what it does.
    44fad4a9
  • Paavo Parkkinen's avatar
    Update documentation for closureSize · 2f292db8
    Paavo Parkkinen authored and Marge Bot's avatar Marge Bot committed
    2f292db8
  • Ben Gamari's avatar
    gitlab-ci: Rework triggering of release builds · f124ff0d
    Ben Gamari authored and Marge Bot's avatar Marge Bot committed
    Use a push option instead of tagging.
    f124ff0d
  • Ben Gamari's avatar
    gitlab-ci: Distinguish integer-simple test envs · 7f25557a
    Ben Gamari authored
    Previously two integer-simple jobs declared the same test environment. One (the nightly job) was built in the perf way, the other in the validate way. Consequently they had appreciably different performance characteristics, causing in the nightly job to spuriously fail with performance changes.
    7f25557a
  • Simon Peyton Jones's avatar
    Fix Lint · c12a2ec5
    Simon Peyton Jones authored and Marge Bot's avatar Marge Bot committed
    Ticket #17590 pointed out a bug in the way the linter dealt with
    type lets, exposed by the new uniqAway story.
    
    The fix is described in Note [Linting type lets]. I ended up
    putting the in-scope Ids in a different env field, le_ids,
    rather than (as before) sneaking them into the TCvSubst.
    
    Surprisingly tiresome, but done.
    
    Metric Decrease:
        hie002
    c12a2ec5
  • Sylvain Henry's avatar
    Hadrian: fix absolute buildroot support (#17822) · b989845e
    Sylvain Henry authored and Marge Bot's avatar Marge Bot committed
    Shake's "**" wildcard doesn't match absolute root. We must use "//" instead.
    b989845e
  • Sylvain Henry's avatar
    Make: refactor GMP rules · 4f117135
    Sylvain Henry authored and Marge Bot's avatar Marge Bot committed
    Document and use simpler rules for the ghc-gmp.h header.
    4f117135
  • Sylvain Henry's avatar
    Use correct option name (-opti) (fix #17314) · 7432b327
    Sylvain Henry authored and Marge Bot's avatar Marge Bot committed
    s/pgmo/opti
    7432b327
  • Judah Jacobson's avatar
    Allow overriding LD_STAGE0 and AR_STAGE0 in the configure script. · 8f7dd571
    Judah Jacobson authored and Marge Bot's avatar Marge Bot committed
    Previously it was possible to override the stage0 C compiler via `CC_STAGE0`,
    but you couldn't override `ld` or `ar` in stage0.  This change allows overriding them
    by setting `LD_STAGE0` or `AR_STAGE0`, respectively.
    
    Our team uses this feature internally to take more control of our GHC build
    and make it run more hermetically.
    8f7dd571
  • Judah Jacobson's avatar
    Use AC_ARG_VAR for LD_STAGE0 and AR_STAGE0. · 7c3e39a9
    Judah Jacobson authored and Marge Bot's avatar Marge Bot committed
    7c3e39a9
  • Ben Gamari's avatar
    nonmoving: Don't traverse filled segment list in pause · 20d4d676
    Ben Gamari authored and Marge Bot's avatar Marge Bot committed
    The non-moving collector would previously walk the entire filled segment
    list during the preparatory pause. However, this is far more work than
    is strictly necessary. We can rather get away with merely collecting the
    allocators' filled segment list heads and process the lists themselves
    during the concurrent phase. This can significantly reduce the maximum
    gen1 GC pause time in programs with high rates of long-lived allocations.
    20d4d676
  • Ben Gamari's avatar
    nonmoving: Remove redundant bitmap clearing · fdfa2d01
    Ben Gamari authored and Marge Bot's avatar Marge Bot committed
    nonmovingSweep already clears the bitmap in the sweep loop. There is no
    reason to do so a second time.
    fdfa2d01
  • Simon Peyton Jones's avatar
    Simple refactor of cheapEqExpr · 2f8c7767
    Simon Peyton Jones authored and Marge Bot's avatar Marge Bot committed
    No change in functionality.  Just seems tidier (and signficantly more
    efficient) to deal with ticks directly than to call stripTicksTopE.
    2f8c7767
  • Simon Peyton Jones's avatar
    Improve CSE.combineAlts · 88f7a762
    Simon Peyton Jones authored and Marge Bot's avatar Marge Bot committed
    This patch improves the way that CSE combines identical
    alternatives.  See #17901.
    
    I'm still not happy about the duplication between CSE.combineAlts
    and GHC.Core.Utils.combineIdenticalAlts; see the Notes with those
    functions.  But this patch is a step forward.
    
    Metric Decrease:
        T12425
        T5642
    88f7a762
  • Ben Gamari's avatar
    gitlab-ci: Add integer-simple release build for Windows · 8b95ddd3
    Ben Gamari authored and Marge Bot's avatar Marge Bot committed
    Closes #16144.
    8b95ddd3
  • Simon Peyton Jones's avatar
    Wrap an implication around class-sig kind errors · e3c374cc
    Simon Peyton Jones authored and Marge Bot's avatar Marge Bot committed
    Ticket #17841 showed that we can get a kind error
    in a class signature, but lack an enclosing implication
    that binds its skolems.
    
    This patch
    
    * Adds the wrapping implication: the new call to
      checkTvConstraints in tcClassDecl1
    
    * Simplifies the API to checkTvConstraints, which
      was not otherwise called at all.
    
    * Simplifies TcErrors.report_unsolved by *not*
      initialising the TidyEnv from the typechecker lexical
      envt.  It's enough to do so from the free vars of the
      unsolved constraints; and we get silly renamings if
      we add variables twice: once from the lexical scope
      and once from the implication constraint.
    e3c374cc
  • Simon Peyton Jones's avatar
    Refactoring in TcSMonad · 73133a3b
    Simon Peyton Jones authored and Marge Bot's avatar Marge Bot committed
    This patch is just refactoring: no change in
    behaviour.
    
    I removed the rather complicated
        checkConstraintsTcS
        checkTvConstraintsTcS
    
    in favour of simpler functions
        emitImplicationTcS
        emitTvImplicationTcS
        pushLevelNoWorkList
    
    The last of these is a little strange, but overall
    it's much better I think.
    73133a3b
  • Ben Gamari's avatar
    base: Make `open` calls interruptible · 93c88c26
    Ben Gamari authored and Marge Bot's avatar Marge Bot committed
    As noted in #17912, `open` system calls were `safe` rather than
    `interruptible`. Consequently, the program could not be interrupted with
    SIGINT if stuck in a slow open operation. Fix this by marking
    `c_safe_open` as interruptible.
    93c88c26
  • Vladislav Zavialov's avatar
    Remove second tcLookupTcTyCon in tcDataDefn · bee4cdad
    Vladislav Zavialov authored and Marge Bot's avatar Marge Bot committed
    Before this patch, tcDataDefn used to call tcLookupTcTyCon twice in a row:
    	1. in bindTyClTyVars itself
    	2. in the continuation passed to it
    
    Now bindTyClTyVars passes the TcTyCon to the continuation, making
    the second lookup unnecessary.
    bee4cdad
  • cgibbard's avatar
    Enable stage1 build of haddock · 3f116d35
    cgibbard authored and Marge Bot's avatar Marge Bot committed
    The submodule has already been bumped to contain the fix.
    3f116d35
  • Ömer Sinan Ağacan's avatar
    rts: Fix printClosure when printing fwd ptrs · 49e9d739
    Ömer Sinan Ağacan authored and Marge Bot's avatar Marge Bot committed
    49e9d739
  • Krzysztof Gogolewski's avatar
    Remove unused field var_inline (#17915) · 1de3ab4a
    Krzysztof Gogolewski authored and Marge Bot's avatar Marge Bot committed
    1de3ab4a
  • Krzysztof Gogolewski's avatar
    Document restriction on SCC pragma syntax · d30aeb4b
    Krzysztof Gogolewski authored and Marge Bot's avatar Marge Bot committed
    Currently, the names of cost centres must be quoted or
    be lowercase identifiers.
    
    Fixes #17916.
    d30aeb4b
  • Brian Foley's avatar
    Remove some dead code · b4774598
    Brian Foley authored and Marge Bot's avatar Marge Bot committed
    From the notes.ghc.drop list found using weeder in #17713
    b4774598
  • vdukhovni's avatar
    Note platform-specific Foreign.C.Types in context · dd6ffe6b
    vdukhovni authored and Marge Bot's avatar Marge Bot committed
    Also fix the markup in the general note at the top of the module.  Haddock
    (usability trade-off), does not support multi-line emphasised text.
    dd6ffe6b
  • Sylvain Henry's avatar
    Refactor CmmToAsm (disentangle DynFlags) · 2e82465f
    Sylvain Henry authored and Marge Bot's avatar Marge Bot committed
    This patch disentangles a bit more DynFlags from the native code
    generator (CmmToAsm).
    
    In more details:
    
    - add a new NCGConfig datatype in GHC.CmmToAsm.Config which contains the
      configuration of a native code generation session
    - explicitly pass NCGConfig/Platform arguments when necessary
    - as a consequence `sdocWithPlatform` is gone and there are only a few
      `sdocWithDynFlags` left
    - remove the use of `unsafeGlobalDynFlags` from GHC.CmmToAsm.CFG
    - remove `sdocDebugLevel` (now we pass the debug level via NCGConfig)
    
    There are still some places where DynFlags is used, especially because
    of pretty-printing (CLabel), because of Cmm helpers (such as
    `cmmExprType`) and because of `Outputable` instance for the
    instructions. These are left for future refactoring as this patch is
    already big.
    2e82465f
  • Judah Jacobson's avatar
    Add a -no-haddock flag. · c35c545d
    Judah Jacobson authored and Marge Bot's avatar Marge Bot committed
    This flag undoes the effect of a previous "-haddock" flag.  Having both flags makes it easier
    for build systems to enable Haddock parsing in a set of global flags, but then disable it locally for
    specific targets (e.g., third-party packages whose comments don't pass the validation in the latest GHC).
    
    I added the flag to expected-undocumented-flags.txt since `-haddock` was alreadyin that list.
    c35c545d
  • Ömer Sinan Ağacan's avatar
    Fix global_link of TSOs for threads reachable via dead weaks · cfcc3c9a
    Ömer Sinan Ağacan authored and Marge Bot's avatar Marge Bot committed
    Fixes #17785
    
    Here's how the problem occurs:
    
    - In generation 0 we have a TSO that is finished (i.e. it has no more
      work to do or it is killed).
    
    - The TSO only becomes reachable after collectDeadWeakPtrs().
    
    - After collectDeadWeakPtrs() we switch to WeakDone phase where we don't
      move TSOs to different lists anymore (like the next gen's thread list
      or the resurrected_threads list).
    
    - So the TSO will never be moved to a generation's thread list, but it
      will be promoted to generation 1.
    
    - Generation 1 collected via mark-compact, and because the TSO is
      reachable it is marked, and its `global_link` field, which is bogus at
      this point (because the TSO is not in a list), will be threaded.
    
    - Chaos ensues.
    
    In other words, when these conditions hold:
    
    - A TSO is reachable only after collectDeadWeakPtrs()
    - It's finished (what_next is ThreadComplete or ThreadKilled)
    - It's retained by mark-compact collector (moving collector doesn't
      evacuate the global_list field)
    
    We end up doing random mutations on the heap because the TSO's
    global_list field is not valid, but it still looks like a heap pointer
    so we thread it during compacting GC.
    
    The fix is simple: when we traverse old_threads lists to resurrect
    unreachable threads the threads that won't be resurrected currently
    stays on the old_threads lists. Those threads will never be visited
    again by MarkWeak so we now reset the global_list fields. This way
    compacting GC does not thread pointers to nowhere.
    
    Testing
    -------
    
    The reproducer in #17785 is quite large and hard to build, because of
    the dependencies, so I'm not adding a regression test.
    
    In my testing the reproducer would take a less than 5 seconds to run,
    and once in every ~5 runs would fail with a segfault or an assertion
    error. In other cases it also fails with a test failure. Because the
    tests never fail with the bug fix, assuming the code is correct, this
    also means that this bug can sometimes lead to incorrect runtime
    results.
    
    After the fix I was able to run the reproducer repeatedly for about an
    hour, with no runtime crashes or test failures.
    
    To run the reproducer clone the git repo:
    
        $ git clone https://github.com/osa1/streamly --branch ghc-segfault
    
    Then clone primitive and atomic-primops from their git repos and point
    to the clones in cabal.project.local. The project should then be
    buildable using GHC HEAD. Run the executable `properties` with `+RTS -c
    -DZ`.
    
    In addition to the reproducer above I run the test suite using:
    
        $ make slowtest EXTRA_HC_OPTS="-debug -with-rtsopts=-DS \
            -with-rtsopts=-c +RTS -c -RTS" SKIPWAY='nonmoving nonmoving_thr'
    
    This enables compacting GC always in both GHC when building the test
    programs and when running the test programs, and also enables sanity
    checking when running the test programs. These set of flags are not
    compatible for all tests so there are some failures, but I got the same
    set of failures with this patch compared to GHC HEAD.
    cfcc3c9a
  • Xia Li-yao's avatar
    base: add strict IO functions: readFile', getContents', hGetContents' · 818b3c38
    Xia Li-yao authored and Marge Bot's avatar Marge Bot committed
    818b3c38
  • Sylvain Henry's avatar
    Modules: Core (#13009) · 18a346a4
    Sylvain Henry authored and Marge Bot's avatar Marge Bot committed
    Update submodule: haddock
    18a346a4
  • Ömer Sinan Ağacan's avatar
    Update sanity checking for TSOs: · 92327e3a
    Ömer Sinan Ağacan authored and Marge Bot's avatar Marge Bot committed
    - Remove an invalid assumption about GC checking what_next field. The GC
      doesn't care about what_next at all, if a TSO is reachable then all
      its pointers are followed (other than global_tso, which is only
      followed by compacting GC).
    
    - Remove checkSTACK in checkTSO: TSO stacks will be visited in
      checkHeapChain, or checkLargeObjects etc.
    
    - Add an assertion in checkTSO to check that the global_link field is
      sane.
    
    - Did some refactor to remove forward decls in checkGlobalTSOList and
      added braces around single-statement if statements.
    92327e3a
  • PHO's avatar
    Don't use non-portable operator "==" in configure.ac · e1aa4052
    PHO authored and Marge Bot's avatar Marge Bot committed
    The test operator "==" is a Bash extension and produces a wrong result
    if /bin/sh is not Bash.
    e1aa4052
  • MaxGabriel's avatar
    Document the units of -ddump-timings · 89f034dd
    MaxGabriel authored and Marge Bot's avatar Marge Bot committed
    Right now, in the output of -ddump-timings to a file, you can't tell what the units are:
    
    ```
    CodeGen [TemplateTestImports]: alloc=22454880 time=14.597
    ```
    
    I believe bytes/milliseconds are the correct units, but confirmation would be appreciated. I'm basing it off of this snippet from `withTiming'`:
    
    ```
    when (verbosity dflags >= 2 && prtimings == PrintTimings)
      $ liftIO $ logInfo dflags (defaultUserStyle dflags)
          (text "!!!" <+> what <> colon <+> text "finished in"
           <+> doublePrec 2 time
           <+> text "milliseconds"
           <> comma
           <+> text "allocated"
           <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
           <+> text "megabytes")
    ```
    
    which implies time is in milliseconds, and allocations in bytes (which divided by 1024 would be KB, and again would be MB)
    89f034dd
  • Simon Peyton Jones's avatar
    Implement mapTyCo like foldTyCo · beffa147
    Simon Peyton Jones authored and Marge Bot's avatar Marge Bot committed
    This patch makes mapType use the successful idiom described
    in TyCoRep
       Note [Specialising foldType]
    
    I have not yet changed any functions to use mapType, though there
    may be some suitable candidates.
    
    This patch should be a no-op in terms of functionality but,
    because it inlines the mapper itself, I'm hoping that there may
    be some modest perf improvements.
    
    Metric Decrease:
        T5631
        T5642
        T3064
        T9020
        T14683
        hie002
        haddock.Cabal
        haddock.base
        haddock.compiler
    beffa147
  • Ömer Sinan Ağacan's avatar
    Don't update ModDetails with CafInfos when opts are disabled · 5800ebfe
    Ömer Sinan Ağacan authored and Marge Bot's avatar Marge Bot committed
    This is consistent with the interface file behavior where we omit
    HsNoCafRefs annotations with -fomit-interface-pragmas (implied by -O0).
    
    ModDetails and ModIface are just different representations of the same
    thing, so they really need to be in sync. This patch does the right
    thing and does not need too much explanation, but here's an example of a
    problem not doing this causes in !2842:
    
        -- MyInteger.hs
        module MyInteger
          ( MyInteger (MyInteger)
          , ToMyInteger (toMyInteger)
          ) where
    
        newtype MyInteger = MyInteger Integer
    
        class ToMyInteger a where
          toMyInteger :: a -> MyInteger
    
        instance ToMyInteger Integer where
          toMyInteger = MyInteger {- . succ -}
    
        -- Main.hs
        module Main
          ( main
          ) where
    
        import MyInteger (MyInteger (MyInteger), toMyInteger)
    
        main :: IO ()
        main = do
          let (MyInteger i) = (id . toMyInteger) (41 :: Integer)
          print i
    
    If I build this with -O0, without this fix, we generate a ModDetails with
    accurate LFInfo for toMyInteger (MyInteger.$fToMyIntegerInteger) which says that
    it's a LFReEntrant with arity 1. This means in the use site (Main) we tag the
    value:
    
        R3 = MyInteger.$fToMyIntegerInteger_closure + 1;
        R2 = GHC.Base.id_closure;
        R1 = GHC.Base.._closure;
        Sp = Sp - 16;
        call stg_ap_ppp_fast(R4, R3, R2, R1) args: 24, res: 0, upd: 24;
    
    Now we change the definition by uncommenting the `succ` part and it becomes a thunk:
    
        MyInteger.$fToMyIntegerInteger [InlPrag=INLINE (sat-args=0)]
          :: MyInteger.ToMyInteger GHC.Integer.Type.Integer
        [GblId[DFunId(nt)]] =
            {} \u [] $ctoMyInteger_rEA;
    
    and its LFInfo is now LFThunk. This change in LFInfo makes a difference in the
    use site: we can no longer tag it.
    
    But becuase the interface fingerprint does not change (because ModIface does not
    change) we don't rebuild Main and tag the thunk.
    
    (1.2% increase in allocations when building T12545 on armv7 because we
    generate more code without CafInfos)
    
    Metric Increase:
        T12545
    5800ebfe
  • Paavo Parkkinen's avatar
    Add example for Data.Semigroup.diff · 5b632dad
    Paavo Parkkinen authored and Marge Bot's avatar Marge Bot committed
    5b632dad
  • Paavo Parkkinen's avatar
    Clean up · 4d85d68b
    Paavo Parkkinen authored and Marge Bot's avatar Marge Bot committed
    4d85d68b
  • Paavo Parkkinen's avatar
    Make example collapsible · 75168d07
    Paavo Parkkinen authored and Marge Bot's avatar Marge Bot committed
    75168d07
  • Richard Eisenberg's avatar
    Fix #17021 by checking more return kinds · 53ff2cd0
    Richard Eisenberg authored
    All the details are in new Note [Datatype return kinds] in
    TcTyClsDecls.
    
    Test case: typecheck/should_fail/T17021{,b}
               typecheck/should_compile/T17021a
    
    Updates haddock submodule
    53ff2cd0
  • Sylvain Henry's avatar
    Modules: Core operations (#13009) · 528df8ec
    Sylvain Henry authored and Marge Bot's avatar Marge Bot committed
    528df8ec
  • Richard Eisenberg's avatar
    Add release note about fix to #16502. · 4e8a71c1
    Richard Eisenberg authored and Marge Bot's avatar Marge Bot committed
    We thought we needed to update the manual, but the fix for #16502
    actually brings the implementation in line with the manual. So we
    just alert users of how to update their code.
    4e8a71c1
  • Simon Peyton Jones's avatar
    Re-engineer the binder-swap transformation · 50681bad
    Simon Peyton Jones authored
    The binder-swap transformation is implemented by the occurrence
    analyser -- see Note [Binder swap] in OccurAnal. However it had
    a very nasty corner in it, for the case where the case scrutinee
    was a GlobalId.  This led to trouble and hacks, and ultimately
    to #16296.
    
    This patch re-engineers how the occurrence analyser implements
    the binder-swap, by actually carrying out a substitution rather
    than by adding a let-binding.  It's all described in
    Note [The binder-swap substitution].
    
    I did a few other things along the way
    
    * Fix a bug in StgCse, which could allow a loop breaker to be CSE'd
      away.  See Note [Care with loop breakers] in StgCse.  I think it can
      only show up if occurrence analyser sets up bad loop breakers, but
      still.
    
    * Better commenting in SimplUtils.prepareAlts
    
    * A little refactoring in CoreUnfold; nothing significant
      e.g. rename CoreUnfold.mkTopUnfolding to mkFinalUnfolding
    
    * Renamed CoreSyn.isFragileUnfolding to hasCoreUnfolding
    
    * Move mkRuleInfo to CoreFVs
    50681bad
......@@ -51,7 +51,8 @@ stages:
when: always
expire_in: 1 year
only:
- tags
variables:
- $RELEASE == "yes"
############################################################
# Runner Tags
......@@ -616,7 +617,7 @@ validate-x86_64-linux-deb9-integer-simple:
variables:
BUILD_FLAVOUR: validate
INTEGER_LIBRARY: integer-simple
TEST_ENV: "x86_64-linux-deb9-integer-simple"
TEST_ENV: "x86_64-linux-deb9-integer-simple-validate"
BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-deb9-linux-integer-simple.tar.xz"
nightly-x86_64-linux-deb9-integer-simple:
......@@ -889,6 +890,13 @@ release-x86_64-windows:
extends: validate-x86_64-windows
variables:
BUILD_FLAVOUR: "perf"
#
release-x86_64-windows-integer-simple:
<<: *release
extends: validate-x86_64-windows
variables:
INTEGER_LIBRARY: integer-simple
BUILD_FLAVOUR: "perf"
.build-i386-windows-make:
......
......@@ -311,31 +311,33 @@ import GHC.Driver.Monad
import TcRnMonad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import GHC.Iface.Load ( loadSysInterface )
import TcRnTypes
import Predicate
import GHC.Core.Predicate
import GHC.Driver.Packages
import NameSet
import RdrName
import GHC.Hs
import Type hiding( typeKind )
import GHC.Core.Type hiding( typeKind )
import TcType
import Id
import TysPrim ( alphaTyVars )
import TyCon
import TyCoPpr ( pprForAll )
import Class
import DataCon
import GHC.Core.TyCon
import GHC.Core.TyCo.Ppr ( pprForAll )
import GHC.Core.Class
import GHC.Core.DataCon
import GHC.Core.FVs ( orphNamesOfFamInst )
import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts )
import GHC.Core.InstEnv
import Name hiding ( varName )
import Avail
import InstEnv
import FamInstEnv ( FamInst )
import SrcLoc
import GHC.Core
import GHC.Iface.Tidy
import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename )
import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename )
import GHC.Driver.Finder
import GHC.Driver.Types
import GHC.Driver.CmdLine
import GHC.Driver.Session hiding (WarnReason(..))
import GHC.Driver.Ways
import SysTools
import SysTools.BaseDir
import Annotations
......@@ -355,8 +357,6 @@ import Lexer
import ApiAnnotation
import qualified GHC.LanguageExtensions as LangExt
import NameEnv
import GHC.Core.FVs ( orphNamesOfFamInst )
import FamInstEnv ( famInstEnvElts )
import TcRnDriver
import Inst
import FamInst
......@@ -365,6 +365,7 @@ import FileCleanup
import Data.Foldable
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.Sequence as Seq
import Data.Maybe
import Data.Time
......@@ -542,10 +543,10 @@ checkBrokenTablesNextToCode dflags
checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool
checkBrokenTablesNextToCode' dflags
| not (isARM arch) = return False
| WayDyn `notElem` ways dflags = return False
| not (tablesNextToCode dflags) = return False
| otherwise = do
| not (isARM arch) = return False
| WayDyn `S.notMember` ways dflags = return False
| not (tablesNextToCode dflags) = return False
| otherwise = do
linkerInfo <- liftIO $ getLinkerInfo dflags
case linkerInfo of
GnuLD _ -> return True
......@@ -605,22 +606,24 @@ setSessionDynFlags dflags = do
let
prog = pgm_i dflags ++ flavour
flavour
| WayProf `elem` ways dflags = "-prof"
| WayDyn `elem` ways dflags = "-dyn"
| otherwise = ""
| WayProf `S.member` ways dflags = "-prof"
| WayDyn `S.member` ways dflags = "-dyn"
| otherwise = ""
msg = text "Starting " <> text prog
tr <- if verbosity dflags >= 3
then return (logInfo dflags (defaultDumpStyle dflags) msg)
else return (pure ())
let
conf = IServConfig
{ iservConfProgram = prog
, iservConfOpts = getOpts dflags opt_i
, iservConfHook = createIservProcessHook (hooks dflags)
, iservConfTrace = tr
{ iservConfProgram = prog
, iservConfOpts = getOpts dflags opt_i
, iservConfProfiled = gopt Opt_SccProfilingOn dflags
, iservConfDynamic = WayDyn `S.member` ways dflags
, iservConfHook = createIservProcessHook (hooks dflags)
, iservConfTrace = tr
}
s <- liftIO $ newMVar (IServPending conf)
return (Just (ExternalInterp (IServ s)))
s <- liftIO $ newMVar IServPending
return (Just (ExternalInterp conf (IServ s)))
else
#if defined(HAVE_INTERNAL_INTERPRETER)
return (Just InternalInterp)
......
......@@ -27,7 +27,7 @@ import GHC.Driver.Types
import Name
import NameSet
import Literal
import TyCon
import GHC.Core.TyCon
import FastString
import GHC.StgToCmm.Layout ( ArgRep(..) )
import GHC.Runtime.Heap.Layout
......
......@@ -17,8 +17,8 @@ import GHC.Driver.Session
import GHC.Driver.Types
import Name ( Name, getName )
import NameEnv
import DataCon ( DataCon, dataConRepArgTys, dataConIdentity )
import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
import GHC.Core.DataCon ( DataCon, dataConRepArgTys, dataConIdentity )
import GHC.Core.TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
import GHC.Types.RepType
import GHC.StgToCmm.Layout ( mkVirtConstrSizes )
import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) )
......
......@@ -25,7 +25,7 @@ import Unique
import Id
import GHC.Core
import Literal
import DataCon
import GHC.Core.DataCon
import VarSet
import PrimOp
import GHC.Runtime.Heap.Layout
......
......@@ -22,7 +22,7 @@ import NameEnv
import Outputable
import PrimOp
import SizedSeq
import Type
import GHC.Core.Type
import SrcLoc
import GHCi.BreakArray
import GHCi.RemoteTypes
......
......@@ -1029,7 +1029,7 @@ labelDynamic dflags this_mod lbl =
externalDynamicRefs && (this_pkg /= rtsUnitId)
IdLabel n _ _ ->
isDllName dflags this_mod n
isDynLinkName dflags this_mod n
-- When compiling in the "dyn" way, each package is to be linked into
-- its own shared library.
......@@ -1355,18 +1355,18 @@ instance Outputable ForeignLabelSource where
internalNamePrefix :: Name -> SDoc
internalNamePrefix name = getPprStyle $ \ sty ->
if asmStyle sty && isRandomGenerated then
sdocWithPlatform $ \platform ->
ptext (asmTempLabelPrefix platform)
sdocWithDynFlags $ \dflags ->
ptext (asmTempLabelPrefix (targetPlatform dflags))
else
empty
where
isRandomGenerated = not $ isExternalName name
tempLabelPrefixOrUnderscore :: SDoc
tempLabelPrefixOrUnderscore = sdocWithPlatform $ \platform ->
tempLabelPrefixOrUnderscore = sdocWithDynFlags $ \dflags ->
getPprStyle $ \ sty ->
if asmStyle sty then
ptext (asmTempLabelPrefix platform)
ptext (asmTempLabelPrefix (targetPlatform dflags))
else
char '_'
......
......@@ -66,13 +66,7 @@ data MaybeO ex t where
JustO :: t -> MaybeO O t
NothingO :: MaybeO C t
-- | Maybe type indexed by closed/open
data MaybeC ex t where
JustC :: t -> MaybeC C t
NothingC :: MaybeC O t
deriving instance Functor (MaybeO ex)
deriving instance Functor (MaybeC ex)
-- -----------------------------------------------------------------------------
-- The Block type
......
......@@ -873,17 +873,6 @@ section s = OtherSection s
mkString :: String -> CmmStatic
mkString s = CmmString (BS8.pack s)
-- |
-- Given an info table, decide what the entry convention for the proc
-- is. That is, for an INFO_TABLE_RET we want the return convention,
-- otherwise it is a NativeNodeCall.
--
infoConv :: Maybe CmmInfoTable -> Convention
infoConv Nothing = NativeNodeCall
infoConv (Just info)
| isStackRep (cit_rep info) = NativeReturn
| otherwise = NativeNodeCall
-- mkMachOp infers the type of the MachOp from the type of its first
-- argument. We assume that this is correct: for MachOps that don't have
-- symmetrical args (e.g. shift ops), the first arg determines the type of
......
......@@ -72,7 +72,7 @@ module GHC.Cmm.Utils(
import GhcPrelude
import TyCon ( PrimRep(..), PrimElemRep(..) )
import GHC.Core.TyCon ( PrimRep(..), PrimElemRep(..) )
import GHC.Types.RepType ( UnaryType, SlotTy (..), typePrimRep1 )
import GHC.Runtime.Heap.Layout
......
......@@ -69,6 +69,7 @@ import GHC.Platform.Reg
import GHC.CmmToAsm.Monad
import GHC.CmmToAsm.CFG
import GHC.CmmToAsm.Dwarf
import GHC.CmmToAsm.Config
import GHC.Cmm.DebugBlock
import GHC.Cmm.BlockId
......@@ -191,14 +192,15 @@ x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, RawCmmStatics)
X86.Instr.Instr X86.Instr.JumpDest
x86_64NcgImpl dflags
= NcgImpl {
cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags
ncgConfig = config
,cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr config
,getJumpDestBlockId = X86.Instr.getJumpDestBlockId
,canShortcut = X86.Instr.canShortcut
,shortcutStatics = X86.Instr.shortcutStatics
,shortcutJump = X86.Instr.shortcutJump
,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl
,maxSpillSlots = X86.Instr.maxSpillSlots dflags
,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl config
,maxSpillSlots = X86.Instr.maxSpillSlots config
,allocatableRegs = X86.Regs.allocatableRegs platform
,ncgAllocMoreStack = X86.Instr.allocMoreStack platform
,ncgExpandTop = id
......@@ -206,19 +208,22 @@ x86_64NcgImpl dflags
,extractUnwindPoints = X86.CodeGen.extractUnwindPoints
,invertCondBranches = X86.CodeGen.invertCondBranches
}
where platform = targetPlatform dflags
where
config = initConfig dflags
platform = ncgPlatform config
ppcNcgImpl :: DynFlags -> NcgImpl RawCmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest
ppcNcgImpl dflags
= NcgImpl {
cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags
ncgConfig = config
,cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr config
,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId
,canShortcut = PPC.RegInfo.canShortcut
,shortcutStatics = PPC.RegInfo.shortcutStatics
,shortcutJump = PPC.RegInfo.shortcutJump
,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl
,maxSpillSlots = PPC.Instr.maxSpillSlots dflags
,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl config
,maxSpillSlots = PPC.Instr.maxSpillSlots config
,allocatableRegs = PPC.Regs.allocatableRegs platform
,ncgAllocMoreStack = PPC.Instr.allocMoreStack platform
,ncgExpandTop = id
......@@ -226,19 +231,22 @@ ppcNcgImpl dflags
,extractUnwindPoints = const []
,invertCondBranches = \_ _ -> id
}
where platform = targetPlatform dflags
where
config = initConfig dflags
platform = ncgPlatform config
sparcNcgImpl :: DynFlags -> NcgImpl RawCmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest
sparcNcgImpl dflags
= NcgImpl {
cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen
ncgConfig = config
,cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags
,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId
,canShortcut = SPARC.ShortcutJump.canShortcut
,shortcutStatics = SPARC.ShortcutJump.shortcutStatics
,shortcutJump = SPARC.ShortcutJump.shortcutJump
,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl
,maxSpillSlots = SPARC.Instr.maxSpillSlots dflags
,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl config
,maxSpillSlots = SPARC.Instr.maxSpillSlots config
,allocatableRegs = SPARC.Regs.allocatableRegs
,ncgAllocMoreStack = noAllocMoreStack
,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop
......@@ -246,6 +254,8 @@ sparcNcgImpl dflags
,extractUnwindPoints = const []
,invertCondBranches = \_ _ -> id
}
where
config = initConfig dflags
--
-- Allocating more stack space for spilling is currently only
......@@ -538,7 +548,8 @@ cmmNativeGen
cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
= do
let platform = targetPlatform dflags
let config = ncgConfig ncgImpl
let platform = ncgPlatform config
let proc_name = case cmm of
(CmmProc _ entry_label _ _) -> ppr entry_label
......@@ -577,7 +588,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
-- tag instructions with register liveness information
-- also drops dead code. We don't keep the cfg in sync on
-- some backends, so don't use it there.
let livenessCfg = if (backendMaintainsCfg dflags)
let livenessCfg = if backendMaintainsCfg platform
then Just nativeCfgWeights
else Nothing
let (withLiveness, usLive) =
......@@ -607,7 +618,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
= {-# SCC "RegAlloc-color" #-}
initUs usLive
$ Color.regAlloc
dflags
config
alloc_regs
(mkUniqSet [0 .. maxSpillSlots ncgImpl])
(maxSpillSlots ncgImpl)
......@@ -655,7 +666,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
-- do linear register allocation
let reg_alloc proc = do
(alloced, maybe_more_stack, ra_stats) <-
Linear.regAlloc dflags proc
Linear.regAlloc config proc
case maybe_more_stack of
Nothing -> return ( alloced, ra_stats, [] )
Just amount -> do
......@@ -691,11 +702,11 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats)
let cfgWithFixupBlks =
(\cfg -> addNodesBetween cfg cfgRegAllocUpdates) <$> livenessCfg
(\cfg -> addNodesBetween dflags cfg cfgRegAllocUpdates) <$> livenessCfg
-- Insert stack update blocks
let postRegCFG =
pure (foldl' (\m (from,to) -> addImmediateSuccessor from to m ))
pure (foldl' (\m (from,to) -> addImmediateSuccessor dflags from to m ))
<*> cfgWithFixupBlks
<*> pure stack_updt_blks
......@@ -725,7 +736,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks
getBlks _ = []
when ( backendMaintainsCfg dflags &&
when ( backendMaintainsCfg platform &&
(gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do
let blocks = concatMap getBlks shorted
let labels = setFromList $ fmap blockId blocks :: LabelSet
......@@ -854,7 +865,7 @@ makeImportsDoc dflags imports
-- security. GHC generated code does not need an executable
-- stack so add the note in:
(if platformHasGnuNonexecStack platform
then text ".section .note.GNU-stack,\"\"," <> sectionType "progbits"
then text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits"
else Outputable.empty)
$$
-- And just because every other compiler does, let's stick in
......@@ -865,9 +876,8 @@ makeImportsDoc dflags imports
else Outputable.empty)
where
platform = targetPlatform dflags
arch = platformArch platform
os = platformOS platform
config = initConfig dflags
platform = ncgPlatform config
-- Generate "symbol stubs" for all external symbols that might
-- come from a dynamic library.
......@@ -877,10 +887,10 @@ makeImportsDoc dflags imports
-- (Hack) sometimes two Labels pretty-print the same, but have
-- different uniques; so we compare their text versions...
dyld_stubs imps
| needImportedSymbols dflags arch os
| needImportedSymbols config
= vcat $
(pprGotDeclaration dflags arch os :) $
map ( pprImportedSymbol dflags platform . fst . head) $
(pprGotDeclaration config :) $
map ( pprImportedSymbol dflags config . fst . head) $
groupBy (\(_,a) (_,b) -> a == b) $
sortBy (\(_,a) (_,b) -> compare a b) $
map doPpr $
......
......@@ -10,7 +10,7 @@
{-# LANGUAGE FlexibleContexts #-}
module GHC.CmmToAsm.BlockLayout
( sequenceTop )
( sequenceTop, backendMaintainsCfg)
where
#include "HsVersions.h"
......@@ -25,7 +25,8 @@ import GHC.Cmm
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Label
import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, backendMaintainsCfg)
import GHC.Platform
import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, targetPlatform)
import UniqFM
import Util
import Unique
......@@ -785,7 +786,7 @@ sequenceTop
sequenceTop _ _ _ top@(CmmData _ _) = top
sequenceTop dflags ncgImpl edgeWeights
(CmmProc info lbl live (ListGraph blocks))
| (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg dflags
| (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg (targetPlatform dflags)
--Use chain based algorithm
, Just cfg <- edgeWeights
= CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $
......@@ -799,7 +800,7 @@ sequenceTop dflags ncgImpl edgeWeights
sequenceBlocks cfg info blocks)
where
dontUseCfg = gopt Opt_WeightlessBlocklayout dflags ||
(not $ backendMaintainsCfg dflags)
(not $ backendMaintainsCfg (targetPlatform dflags))
-- The old algorithm:
-- It is very simple (and stupid): We make a graph out of
......@@ -893,3 +894,10 @@ lookupDeleteUFM :: Uniquable key => UniqFM elt -> key
lookupDeleteUFM m k = do -- Maybe monad
v <- lookupUFM m k
return (v, delFromUFM m k)
backendMaintainsCfg :: Platform -> Bool
backendMaintainsCfg platform = case platformArch platform of
-- ArchX86 -- Should work but not tested so disabled currently.
ArchX86_64 -> True
_otherwise -> False
......@@ -328,12 +328,12 @@ shortcutWeightMap cuts cfg =
-- \ \
-- -> C => -> C
--
addImmediateSuccessor :: BlockId -> BlockId -> CFG -> CFG
addImmediateSuccessor node follower cfg
addImmediateSuccessor :: D.DynFlags -> BlockId -> BlockId -> CFG -> CFG
addImmediateSuccessor dflags node follower cfg
= updateEdges . addWeightEdge node follower uncondWeight $ cfg
where
uncondWeight = fromIntegral . D.uncondWeight .
D.cfgWeightInfo $ D.unsafeGlobalDynFlags
D.cfgWeightInfo $ dflags
targets = getSuccessorEdges cfg node
successors = map fst targets :: [BlockId]
updateEdges = addNewSuccs . remOldSuccs
......@@ -508,13 +508,13 @@ mapWeights f cfg =
-- these cases.
-- We assign the old edge info to the edge A -> B and assign B -> C the
-- weight of an unconditional jump.
addNodesBetween :: CFG -> [(BlockId,BlockId,BlockId)] -> CFG
addNodesBetween m updates =
addNodesBetween :: D.DynFlags -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG
addNodesBetween dflags m updates =
foldl' updateWeight m .
weightUpdates $ updates
where
weight = fromIntegral . D.uncondWeight .
D.cfgWeightInfo $ D.unsafeGlobalDynFlags
D.cfgWeightInfo $ dflags
-- We might add two blocks for different jumps along a single
-- edge. So we end up with edges: A -> B -> C , A -> D -> C
-- in this case after applying the first update the weight for A -> C
......
-- | Native code generator configuration
module GHC.CmmToAsm.Config
( NCGConfig(..)
, ncgWordWidth
)
where
import GhcPrelude
import GHC.Platform
import GHC.Cmm.Type (Width(..))
-- | Native code generator configuration
data NCGConfig = NCGConfig
{ ncgPlatform :: !Platform -- ^ Target platform
, ncgProcAlignment :: !(Maybe Int) -- ^ Mandatory proc alignment
, ncgDebugLevel :: !Int -- ^ Debug level
, ncgExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries
, ncgPIC :: !Bool -- ^ Enable Position-Independent Code
, ncgSplitSections :: !Bool -- ^ Split sections
, ncgSpillPreallocSize :: !Int -- ^ Size in bytes of the pre-allocated spill space on the C stack
, ncgRegsIterative :: !Bool
, ncgAsmLinting :: !Bool -- ^ Perform ASM linting pass
, ncgDumpRegAllocStages :: !Bool
, ncgDumpAsmStats :: !Bool
, ncgDumpAsmConflicts :: !Bool
}
-- | Return Word size
ncgWordWidth :: NCGConfig -> Width
ncgWordWidth config = case platformWordSize (ncgPlatform config) of
PW4 -> W32
PW8 -> W64
......@@ -36,6 +36,7 @@ dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
-> IO (SDoc, UniqSupply)
dwarfGen _ _ us [] = return (empty, us)
dwarfGen df modLoc us blocks = do
let platform = targetPlatform df
-- Convert debug data structures to DWARF info records
-- We strip out block information when running with -g0 or -g1.
......@@ -64,33 +65,33 @@ dwarfGen df modLoc us blocks = do
haveSrc = any haveSrcIn procs
-- .debug_abbrev section: Declare the format we're using
let abbrevSct = pprAbbrevDecls haveSrc
let abbrevSct = pprAbbrevDecls platform haveSrc
-- .debug_info section: Information records on procedures and blocks
let -- unique to identify start and end compilation unit .debug_inf
(unitU, us') = takeUniqFromSupply us
infoSct = vcat [ ptext dwarfInfoLabel <> colon
, dwarfInfoSection
, compileUnitHeader unitU
, pprDwarfInfo haveSrc dwarfUnit
, dwarfInfoSection platform
, compileUnitHeader platform unitU
, pprDwarfInfo platform haveSrc dwarfUnit
, compileUnitFooter unitU
]
-- .debug_line section: Generated mainly by the assembler, but we
-- need to label it
let lineSct = dwarfLineSection $$
let lineSct = dwarfLineSection platform $$
ptext dwarfLineLabel <> colon
-- .debug_frame section: Information about the layout of the GHC stack
let (framesU, us'') = takeUniqFromSupply us'
frameSct = dwarfFrameSection $$
frameSct = dwarfFrameSection platform $$
ptext dwarfFrameLabel <> colon $$
pprDwarfFrame (debugFrame framesU procs)
pprDwarfFrame platform (debugFrame framesU procs)
-- .aranges section: Information about the bounds of compilation units
let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs
| otherwise = [DwarfARange lowLabel highLabel]
let aranges = dwarfARangesSection $$ pprDwarfARanges aranges' unitU
let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU
return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')
......@@ -106,17 +107,17 @@ mkDwarfARange proc = DwarfARange start end
-- | Header for a compilation unit, establishing global format
-- parameters
compileUnitHeader :: Unique -> SDoc
compileUnitHeader unitU = sdocWithPlatform $ \plat ->
compileUnitHeader :: Platform -> Unique -> SDoc
compileUnitHeader platform unitU =
let cuLabel = mkAsmTempLabel unitU -- sits right before initialLength field
length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel
<> text "-4" -- length of initialLength field
in vcat [ ppr cuLabel <> colon
, text "\t.long " <> length -- compilation unit size
, pprHalf 3 -- DWARF version
, sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)
, sectionOffset platform (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)
-- abbrevs offset
, text "\t.byte " <> ppr (platformWordSizeInBytes plat) -- word size
, text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size
]
-- | Compilation unit footer, mainly establishing size of debug sections
......@@ -176,7 +177,7 @@ parent, B.
-- | Generate DWARF info for a procedure debug block
procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
procToDwarf df prc
= DwarfSubprogram { dwChildren = map (blockToDwarf df) (dblBlocks prc)
= DwarfSubprogram { dwChildren = map blockToDwarf (dblBlocks prc)
, dwName = case dblSourceTick prc of
Just s@SourceNote{} -> sourceName s
_otherwise -> showSDocDump df $ ppr $ dblLabel prc
......@@ -195,10 +196,10 @@ procToDwarf df prc
goodParent _ = True
-- | Generate DWARF info for a block
blockToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
blockToDwarf df blk
= DwarfBlock { dwChildren = concatMap (tickToDwarf df) (dblTicks blk)
++ map (blockToDwarf df) (dblBlocks blk)
blockToDwarf :: DebugBlock -> DwarfInfo
blockToDwarf blk
= DwarfBlock { dwChildren = concatMap tickToDwarf (dblTicks blk)
++ map blockToDwarf (dblBlocks blk)
, dwLabel = dblCLabel blk
, dwMarker = marker
}
......@@ -207,9 +208,9 @@ blockToDwarf df blk
| Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk
| otherwise = Nothing -- block was optimized out
tickToDwarf :: DynFlags -> Tickish () -> [DwarfInfo]
tickToDwarf _ (SourceNote ss _) = [DwarfSrcNote ss]
tickToDwarf _ _ = []
tickToDwarf :: Tickish () -> [DwarfInfo]
tickToDwarf (SourceNote ss _) = [DwarfSrcNote ss]
tickToDwarf _ = []
-- | Generates the data for the debug frame section, which encodes the
-- desired stack unwind behaviour for the debugger
......
......@@ -144,20 +144,20 @@ dW_OP_call_frame_cfa = 0x9c
-- * Dwarf section declarations
dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection,
dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: SDoc
dwarfInfoSection = dwarfSection "info"
dwarfAbbrevSection = dwarfSection "abbrev"
dwarfLineSection = dwarfSection "line"
dwarfFrameSection = dwarfSection "frame"
dwarfGhcSection = dwarfSection "ghc"
dwarfARangesSection = dwarfSection "aranges"
dwarfSection :: String -> SDoc
dwarfSection name = sdocWithPlatform $ \plat ->
case platformOS plat of
dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: Platform -> SDoc
dwarfInfoSection platform = dwarfSection platform "info"
dwarfAbbrevSection platform = dwarfSection platform "abbrev"
dwarfLineSection platform = dwarfSection platform "line"
dwarfFrameSection platform = dwarfSection platform "frame"
dwarfGhcSection platform = dwarfSection platform "ghc"
dwarfARangesSection platform = dwarfSection platform "aranges"
dwarfSection :: Platform -> String -> SDoc
dwarfSection platform name =
case platformOS platform of
os | osElfTarget os
-> text "\t.section .debug_" <> text name <> text ",\"\","
<> sectionType "progbits"
<> sectionType platform "progbits"
| osMachOTarget os
-> text "\t.section __DWARF,__debug_" <> text name <> text ",regular,debug"
| otherwise
......
......@@ -90,8 +90,8 @@ pprAbbrev = pprLEBWord . fromIntegral . fromEnum
-- | Abbreviation declaration. This explains the binary encoding we
-- use for representing 'DwarfInfo'. Be aware that this must be updated
-- along with 'pprDwarfInfo'.
pprAbbrevDecls :: Bool -> SDoc
pprAbbrevDecls haveDebugLine =
pprAbbrevDecls :: Platform -> Bool -> SDoc
pprAbbrevDecls platform haveDebugLine =
let mkAbbrev abbr tag chld flds =
let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form
in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$
......@@ -106,7 +106,7 @@ pprAbbrevDecls haveDebugLine =
, (dW_AT_high_pc, dW_FORM_addr)
, (dW_AT_frame_base, dW_FORM_block1)
]
in dwarfAbbrevSection $$
in dwarfAbbrevSection platform $$
ptext dwarfAbbrevLabel <> colon $$
mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes
([(dW_AT_name, dW_FORM_string)
......@@ -142,8 +142,8 @@ pprAbbrevDecls haveDebugLine =
pprByte 0
-- | Generate assembly for DWARF data
pprDwarfInfo :: Bool -> DwarfInfo -> SDoc
pprDwarfInfo haveSrc d
pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc
pprDwarfInfo platform haveSrc d
= case d of
DwarfCompileUnit {} -> hasChildren
DwarfSubprogram {} -> hasChildren
......@@ -151,36 +151,36 @@ pprDwarfInfo haveSrc d
DwarfSrcNote {} -> noChildren
where
hasChildren =
pprDwarfInfoOpen haveSrc d $$
vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$
pprDwarfInfoOpen platform haveSrc d $$
vcat (map (pprDwarfInfo platform haveSrc) (dwChildren d)) $$
pprDwarfInfoClose
noChildren = pprDwarfInfoOpen haveSrc d
noChildren = pprDwarfInfoOpen platform haveSrc d
-- | Prints assembler data corresponding to DWARF info records. Note
-- that the binary format of this is parameterized in @abbrevDecls@ and
-- has to be kept in synch.
pprDwarfInfoOpen :: Bool -> DwarfInfo -> SDoc
pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lowLabel
pprDwarfInfoOpen :: Platform -> Bool -> DwarfInfo -> SDoc
pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowLabel
highLabel lineLbl) =
pprAbbrev DwAbbrCompileUnit
$$ pprString name
$$ pprString producer
$$ pprData4 dW_LANG_Haskell
$$ pprString compDir
$$ pprWord (ppr lowLabel)
$$ pprWord (ppr highLabel)
$$ pprWord platform (ppr lowLabel)
$$ pprWord platform (ppr highLabel)
$$ if haveSrc
then sectionOffset (ptext lineLbl) (ptext dwarfLineLabel)
then sectionOffset platform (ptext lineLbl) (ptext dwarfLineLabel)
else empty
pprDwarfInfoOpen _ (DwarfSubprogram _ name label
pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label
parent) = sdocWithDynFlags $ \df ->
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev abbrev
$$ pprString name
$$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))
$$ pprFlag (externallyVisibleCLabel label)
$$ pprWord (ppr label)
$$ pprWord (ppr $ mkAsmTempEndLabel label)
$$ pprWord platform (ppr label)
$$ pprWord platform (ppr $ mkAsmTempEndLabel label)
$$ pprByte 1
$$ pprByte dW_OP_call_frame_cfa
$$ parentValue
......@@ -188,18 +188,18 @@ pprDwarfInfoOpen _ (DwarfSubprogram _ name label
abbrev = case parent of Nothing -> DwAbbrSubprogram
Just _ -> DwAbbrSubprogramWithParent
parentValue = maybe empty pprParentDie parent
pprParentDie sym = sectionOffset (ppr sym) (ptext dwarfInfoLabel)
pprDwarfInfoOpen _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->
pprParentDie sym = sectionOffset platform (ppr sym) (ptext dwarfInfoLabel)
pprDwarfInfoOpen _ _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev DwAbbrBlockWithoutCode
$$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))
pprDwarfInfoOpen _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->
pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev DwAbbrBlock
$$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))
$$ pprWord (ppr marker)
$$ pprWord (ppr $ mkAsmTempEndLabel marker)
pprDwarfInfoOpen _ (DwarfSrcNote ss) =
$$ pprWord platform (ppr marker)
$$ pprWord platform (ppr $ mkAsmTempEndLabel marker)
pprDwarfInfoOpen _ _ (DwarfSrcNote ss) =
pprAbbrev DwAbbrGhcSrcNote
$$ pprString' (ftext $ srcSpanFile ss)
$$ pprData4 (fromIntegral $ srcSpanStartLine ss)
......@@ -222,9 +222,9 @@ data DwarfARange
-- | Print assembler directives corresponding to a DWARF @.debug_aranges@
-- address table entry.
pprDwarfARanges :: [DwarfARange] -> Unique -> SDoc
pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat ->
let wordSize = platformWordSizeInBytes plat
pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc
pprDwarfARanges platform arngs unitU =
let wordSize = platformWordSizeInBytes platform
paddingSize = 4 :: Int
-- header is 12 bytes long.
-- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform).
......@@ -234,19 +234,19 @@ pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat ->
initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize
in pprDwWord (ppr initialLength)
$$ pprHalf 2
$$ sectionOffset (ppr $ mkAsmTempLabel $ unitU)
(ptext dwarfInfoLabel)
$$ sectionOffset platform (ppr $ mkAsmTempLabel $ unitU)
(ptext dwarfInfoLabel)
$$ pprByte (fromIntegral wordSize)
$$ pprByte 0
$$ pad paddingSize
-- body
$$ vcat (map pprDwarfARange arngs)
$$ vcat (map (pprDwarfARange platform) arngs)
-- terminus
$$ pprWord (char '0')
$$ pprWord (char '0')
$$ pprWord platform (char '0')
$$ pprWord platform (char '0')
pprDwarfARange :: DwarfARange -> SDoc
pprDwarfARange arng = pprWord (ppr $ dwArngStartLabel arng) $$ pprWord length
pprDwarfARange :: Platform -> DwarfARange -> SDoc
pprDwarfARange platform arng = pprWord platform (ppr $ dwArngStartLabel arng) $$ pprWord platform length
where
length = ppr (dwArngEndLabel arng)
<> char '-' <> ppr (dwArngStartLabel arng)
......@@ -286,21 +286,20 @@ instance Outputable DwarfFrameBlock where
-- | Header for the @.debug_frame@ section. Here we emit the "Common
-- Information Entry" record that establishes general call frame
-- parameters and the default stack layout.
pprDwarfFrame :: DwarfFrame -> SDoc
pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
= sdocWithPlatform $ \plat ->
let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")
pprDwarfFrame :: Platform -> DwarfFrame -> SDoc
pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
= let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")
cieEndLabel = mkAsmTempEndLabel cieLabel
length = ppr cieEndLabel <> char '-' <> ppr cieStartLabel
spReg = dwarfGlobalRegNo plat Sp
retReg = dwarfReturnRegNo plat
wordSize = platformWordSizeInBytes plat
spReg = dwarfGlobalRegNo platform Sp
retReg = dwarfReturnRegNo platform
wordSize = platformWordSizeInBytes platform
pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc
pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw)
pprInit (g, uw) = pprSetUnwind platform g (Nothing, uw)
-- Preserve C stack pointer: This necessary to override that default
-- unwinding behavior of setting $sp = CFA.
preserveSp = case platformArch plat of
preserveSp = case platformArch platform of
ArchX86 -> pprByte dW_CFA_same_value $$ pprLEBWord 4
ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7
_ -> empty
......@@ -333,16 +332,16 @@ pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
, pprLEBWord (fromIntegral spReg)
, pprLEBWord 0
] $$
wordAlign $$
wordAlign platform $$
ppr cieEndLabel <> colon $$
-- Procedure unwind tables
vcat (map (pprFrameProc cieLabel cieInit) procs)
vcat (map (pprFrameProc platform cieLabel cieInit) procs)
-- | Writes a "Frame Description Entry" for a procedure. This consists
-- mainly of referencing the CIE and writing state machine
-- instructions to describe how the frame base (CFA) changes.
pprFrameProc :: CLabel -> UnwindTable -> DwarfFrameProc -> SDoc
pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
pprFrameProc :: Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> SDoc
pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
= let fdeLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde")
fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end")
procEnd = mkAsmTempEndLabel procLbl
......@@ -353,20 +352,20 @@ pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
, ppr fdeLabel <> colon
, pprData4' (ppr frameLbl <> char '-' <>
ptext dwarfFrameLabel) -- Reference to CIE
, pprWord (ppr procLbl <> ifInfo "-1") -- Code pointer
, pprWord (ppr procEnd <> char '-' <>
ppr procLbl <> ifInfo "+1") -- Block byte length
, pprWord platform (ppr procLbl <> ifInfo "-1") -- Code pointer
, pprWord platform (ppr procEnd <> char '-' <>
ppr procLbl <> ifInfo "+1") -- Block byte length
] $$
vcat (S.evalState (mapM pprFrameBlock blocks) initUw) $$
wordAlign $$
vcat (S.evalState (mapM (pprFrameBlock platform) blocks) initUw) $$
wordAlign platform $$
ppr fdeEndLabel <> colon
-- | Generates unwind information for a block. We only generate
-- instructions where unwind information actually changes. This small
-- optimisations saves a lot of space, as subsequent blocks often have
-- the same unwind information.
pprFrameBlock :: DwarfFrameBlock -> S.State UnwindTable SDoc
pprFrameBlock (DwarfFrameBlock hasInfo uws0) =
pprFrameBlock :: Platform -> DwarfFrameBlock -> S.State UnwindTable SDoc
pprFrameBlock platform (DwarfFrameBlock hasInfo uws0) =
vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0
where
pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable SDoc
......@@ -393,9 +392,8 @@ pprFrameBlock (DwarfFrameBlock hasInfo uws0) =
needsOffset = firstDecl && hasInfo
lblDoc = ppr lbl <>
if needsOffset then text "-1" else empty
doc = sdocWithPlatform $ \plat ->
pprByte dW_CFA_set_loc $$ pprWord lblDoc $$
vcat (map (uncurry $ pprSetUnwind plat) changed)
doc = pprByte dW_CFA_set_loc $$ pprWord platform lblDoc $$
vcat (map (uncurry $ pprSetUnwind platform) changed)
in (doc, uws)
-- Note [Info Offset]
......@@ -452,8 +450,8 @@ pprSetUnwind plat Sp (_, Just (UwReg s' o'))
else pprByte dW_CFA_def_cfa_sf $$
pprLEBRegNo plat s' $$
pprLEBInt o'
pprSetUnwind _ Sp (_, Just uw)
= pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr False uw
pprSetUnwind plat Sp (_, Just uw)
= pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr plat False uw
pprSetUnwind plat g (_, Just (UwDeref (UwReg Sp o)))
| o < 0 && ((-o) `mod` platformWordSizeInBytes plat) == 0 -- expected case
= pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$
......@@ -465,7 +463,7 @@ pprSetUnwind plat g (_, Just (UwDeref (UwReg Sp o)))
pprSetUnwind plat g (_, Just (UwDeref uw))
= pprByte dW_CFA_expression $$
pprLEBRegNo plat g $$
pprUnwindExpr True uw
pprUnwindExpr plat True uw
pprSetUnwind plat g (_, Just (UwReg g' 0))
| g == g'
= pprByte dW_CFA_same_value $$
......@@ -473,7 +471,7 @@ pprSetUnwind plat g (_, Just (UwReg g' 0))
pprSetUnwind plat g (_, Just uw)
= pprByte dW_CFA_val_expression $$
pprLEBRegNo plat g $$
pprUnwindExpr True uw
pprUnwindExpr plat True uw
-- | Print the register number of the given 'GlobalReg' as an unsigned LEB128
-- encoded number.
......@@ -483,20 +481,19 @@ pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat
-- | Generates a DWARF expression for the given unwind expression. If
-- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets
-- mentioned.
pprUnwindExpr :: Bool -> UnwindExpr -> SDoc
pprUnwindExpr spIsCFA expr
= sdocWithPlatform $ \plat ->
let pprE (UwConst i)
pprUnwindExpr :: Platform -> Bool -> UnwindExpr -> SDoc
pprUnwindExpr platform spIsCFA expr
= let pprE (UwConst i)
| i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i)
| otherwise = pprByte dW_OP_consts $$ pprLEBInt i -- lazy...
pprE (UwReg Sp i) | spIsCFA
= if i == 0
then pprByte dW_OP_call_frame_cfa
else pprE (UwPlus (UwReg Sp 0) (UwConst i))
pprE (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo plat g) $$
pprE (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo platform g) $$
pprLEBInt i
pprE (UwDeref u) = pprE u $$ pprByte dW_OP_deref
pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord (ppr l)
pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord platform (ppr l)
pprE (UwPlus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus
pprE (UwMinus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus
pprE (UwTimes u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul
......@@ -514,8 +511,8 @@ pprUndefUnwind plat g = pprByte dW_CFA_undefined $$
-- | Align assembly at (machine) word boundary
wordAlign :: SDoc
wordAlign = sdocWithPlatform $ \plat ->
wordAlign :: Platform -> SDoc
wordAlign plat =
text "\t.align " <> case platformOS plat of
OSDarwin -> case platformWordSize plat of
PW8 -> char '3'
......@@ -549,11 +546,11 @@ pprDwWord = pprData4'
-- | Assembly for a machine word of dynamic data. Depends on the
-- architecture we are currently generating code for.
pprWord :: SDoc -> SDoc
pprWord s = (<> s) . sdocWithPlatform $ \plat ->
pprWord :: Platform -> SDoc -> SDoc
pprWord plat s =
case platformWordSize plat of
PW4 -> text "\t.long "
PW8 -> text "\t.quad "
PW4 -> text "\t.long " <> s
PW8 -> text "\t.quad " <> s
-- | Prints a number in "little endian base 128" format. The idea is
-- to optimize for small numbers by stopping once all further bytes
......@@ -604,8 +601,8 @@ escapeChar c
-- us to just reference the target directly, and will figure out on
-- their own that we actually need an offset. Finally, Windows has
-- a special directive to refer to relative offsets. Fun.
sectionOffset :: SDoc -> SDoc -> SDoc
sectionOffset target section = sdocWithPlatform $ \plat ->
sectionOffset :: Platform -> SDoc -> SDoc -> SDoc
sectionOffset plat target section =
case platformOS plat of
OSDarwin -> pprDwWord (target <> char '-' <> section)
OSMinGW32 -> text "\t.secrel32 " <> target
......
......@@ -16,14 +16,15 @@ where
import GhcPrelude
import GHC.Platform
import GHC.Platform.Reg
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Label
import GHC.Driver.Session
import GHC.Cmm hiding (topInfoTable)
import GHC.Platform
import GHC.CmmToAsm.Config
-- | Holds a list of source and destination registers used by a
-- particular instruction.
......@@ -132,7 +133,7 @@ class Instruction instr where
-- | An instruction to spill a register into a spill slot.
mkSpillInstr
:: DynFlags
:: NCGConfig
-> Reg -- ^ the reg to spill
-> Int -- ^ the current stack delta
-> Int -- ^ spill slot to use
......@@ -141,7 +142,7 @@ class Instruction instr where
-- | An instruction to reload a register from a spill slot.
mkLoadInstr
:: DynFlags
:: NCGConfig
-> Reg -- ^ the reg to reload.
-> Int -- ^ the current stack delta
-> Int -- ^ the spill slot to use
......
......@@ -16,6 +16,7 @@ module GHC.CmmToAsm.Monad (
NatM, -- instance Monad
initNat,
initConfig,
addImportNat,
addNodeBetweenNat,
addImmediateSuccessorNat,
......@@ -23,6 +24,8 @@ module GHC.CmmToAsm.Monad (
getUniqueNat,
mapAccumLNat,
setDeltaNat,
getConfig,
getPlatform,
getDeltaNat,
getThisModuleNat,
getBlockIdNat,
......@@ -45,9 +48,11 @@ where
import GhcPrelude
import GHC.Platform
import GHC.Platform.Reg
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Reg.Target
import GHC.CmmToAsm.Config
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Collections
......@@ -69,6 +74,7 @@ import GHC.Cmm (RawCmmDecl, RawCmmStatics)
import GHC.CmmToAsm.CFG
data NcgImpl statics instr jumpDest = NcgImpl {
ncgConfig :: !NCGConfig,
cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
getJumpDestBlockId :: jumpDest -> Maybe BlockId,
......@@ -102,6 +108,7 @@ data NatM_State
natm_imports :: [(CLabel)],
natm_pic :: Maybe Reg,
natm_dflags :: DynFlags,
natm_config :: NCGConfig,
natm_this_module :: Module,
natm_modloc :: ModLocation,
natm_fileid :: DwarfFiles,
......@@ -130,6 +137,7 @@ mkNatM_State us delta dflags this_mod
, natm_imports = []
, natm_pic = Nothing
, natm_dflags = dflags
, natm_config = initConfig dflags
, natm_this_module = this_mod
, natm_modloc = loc
, natm_fileid = dwf
......@@ -137,6 +145,24 @@ mkNatM_State us delta dflags this_mod
, natm_cfg = cfg
}
-- | Initialize the native code generator configuration from the DynFlags
initConfig :: DynFlags -> NCGConfig
initConfig dflags = NCGConfig
{ ncgPlatform = targetPlatform dflags
, ncgProcAlignment = cmmProcAlignment dflags
, ncgDebugLevel = debugLevel dflags
, ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
, ncgPIC = positionIndependent dflags
, ncgSplitSections = gopt Opt_SplitSections dflags
, ncgSpillPreallocSize = rESERVED_C_STACK_BYTES dflags
, ncgRegsIterative = gopt Opt_RegsIterative dflags
, ncgAsmLinting = gopt Opt_DoAsmLinting dflags
, ncgDumpRegAllocStages = dopt Opt_D_dump_asm_regalloc_stages dflags
, ncgDumpAsmStats = dopt Opt_D_dump_asm_stats dflags
, ncgDumpAsmConflicts = dopt Opt_D_dump_asm_conflicts dflags
}
initNat :: NatM_State -> NatM a -> (a, NatM_State)
initNat init_st m
= case unNat m init_st of { (r,st) -> (r,st) }
......@@ -232,8 +258,9 @@ addNodeBetweenNat from between to
-- | Place `succ` after `block` and change any edges
-- block -> X to `succ` -> X
addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()
addImmediateSuccessorNat block succ
= updateCfgNat (addImmediateSuccessor block succ)
addImmediateSuccessorNat block succ = do
dflags <- getDynFlags
updateCfgNat (addImmediateSuccessor dflags block succ)
getBlockIdNat :: NatM BlockId
getBlockIdNat
......@@ -249,16 +276,16 @@ getNewLabelNat
getNewRegNat :: Format -> NatM Reg
getNewRegNat rep
= do u <- getUniqueNat
dflags <- getDynFlags
return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep)
platform <- getPlatform
return (RegVirtual $ targetMkVirtualReg platform u rep)
getNewRegPairNat :: Format -> NatM (Reg,Reg)
getNewRegPairNat rep
= do u <- getUniqueNat
dflags <- getDynFlags
let vLo = targetMkVirtualReg (targetPlatform dflags) u rep
let lo = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep
platform <- getPlatform
let vLo = targetMkVirtualReg platform u rep
let lo = RegVirtual $ targetMkVirtualReg platform u rep
let hi = RegVirtual $ getHiVirtualRegFromLo vLo
return (lo, hi)
......@@ -282,6 +309,14 @@ getModLoc :: NatM ModLocation
getModLoc
= NatM $ \ st -> (natm_modloc st, st)
-- | Get native code generator configuration
getConfig :: NatM NCGConfig
getConfig = NatM $ \st -> (natm_config st, st)
-- | Get target platform from native code generator configuration
getPlatform :: NatM Platform
getPlatform = ncgPlatform <$> getConfig
getFileId :: FastString -> NatM Int
getFileId f = NatM $ \st ->
case lookupUFM (natm_fileid st) f of
......
......@@ -57,6 +57,7 @@ import GHC.Platform
import GHC.CmmToAsm.Instr
import GHC.Platform.Reg
import GHC.CmmToAsm.Monad
import GHC.CmmToAsm.Config
import GHC.Cmm.Dataflow.Collections
......@@ -163,7 +164,7 @@ cmmMakePicReference dflags lbl
| OSAIX <- platformOS $ targetPlatform dflags
= CmmMachOp (MO_Add W32)
[ CmmReg (CmmGlobal PicBaseReg)
, CmmLit $ picRelative dflags
, CmmLit $ picRelative (wordWidth dflags)
(platformArch $ targetPlatform dflags)
(platformOS $ targetPlatform dflags)
lbl ]
......@@ -172,7 +173,7 @@ cmmMakePicReference dflags lbl
| ArchPPC_64 _ <- platformArch $ targetPlatform dflags
= CmmMachOp (MO_Add W32) -- code model medium
[ CmmReg (CmmGlobal PicBaseReg)
, CmmLit $ picRelative dflags
, CmmLit $ picRelative (wordWidth dflags)
(platformArch $ targetPlatform dflags)
(platformOS $ targetPlatform dflags)
lbl ]
......@@ -181,7 +182,7 @@ cmmMakePicReference dflags lbl
&& absoluteLabel lbl
= CmmMachOp (MO_Add (wordWidth dflags))
[ CmmReg (CmmGlobal PicBaseReg)
, CmmLit $ picRelative dflags
, CmmLit $ picRelative (wordWidth dflags)
(platformArch $ targetPlatform dflags)
(platformOS $ targetPlatform dflags)
lbl ]
......@@ -404,7 +405,7 @@ howToAccessLabel dflags _ _ _ _ _
-- | Says what we have to add to our 'PIC base register' in order to
-- get the address of a label.
picRelative :: DynFlags -> Arch -> OS -> CLabel -> CmmLit
picRelative :: Width -> Arch -> OS -> CLabel -> CmmLit
-- Darwin, but not x86_64:
-- The PIC base register points to the PIC base label at the beginning
......@@ -413,15 +414,15 @@ picRelative :: DynFlags -> Arch -> OS -> CLabel -> CmmLit
-- We have already made sure that all labels that are not from the current
-- module are accessed indirectly ('as' can't calculate differences between
-- undefined labels).
picRelative dflags arch OSDarwin lbl
picRelative width arch OSDarwin lbl
| arch /= ArchX86_64
= CmmLabelDiffOff lbl mkPicBaseLabel 0 (wordWidth dflags)
= CmmLabelDiffOff lbl mkPicBaseLabel 0 width
-- On AIX we use an indirect local TOC anchored by 'gotLabel'.
-- This way we use up only one global TOC entry per compilation-unit
-- (this is quite similar to GCC's @-mminimal-toc@ compilation mode)
picRelative dflags _ OSAIX lbl
= CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags)
picRelative width _ OSAIX lbl
= CmmLabelDiffOff lbl gotLabel 0 width
-- PowerPC Linux:
-- The PIC base register points to our fake GOT. Use a label difference
......@@ -429,9 +430,9 @@ picRelative dflags _ OSAIX lbl
-- We have made sure that *everything* is accessed indirectly, so this
-- is only used for offsets from the GOT to symbol pointers inside the
-- GOT.
picRelative dflags ArchPPC os lbl
picRelative width ArchPPC os lbl
| osElfTarget os
= CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags)
= CmmLabelDiffOff lbl gotLabel 0 width
-- Most Linux versions:
......@@ -453,14 +454,14 @@ picRelative _ arch os lbl
in result
picRelative _ _ _ _
= panic "PositionIndependentCode.picRelative undefined for this platform"
= panic "GHC.CmmToAsm.PIC.picRelative undefined for this platform"
--------------------------------------------------------------------------------
needImportedSymbols :: DynFlags -> Arch -> OS -> Bool
needImportedSymbols dflags arch os
needImportedSymbols :: NCGConfig -> Bool
needImportedSymbols config
| os == OSDarwin
, arch /= ArchX86_64
= True
......@@ -471,7 +472,7 @@ needImportedSymbols dflags arch os
-- PowerPC Linux: -fPIC or -dynamic
| osElfTarget os
, arch == ArchPPC
= positionIndependent dflags || gopt Opt_ExternalDynamicRefs dflags
= ncgPIC config || ncgExternalDynamicRefs config
-- PowerPC 64 Linux: always
| osElfTarget os
......@@ -481,11 +482,15 @@ needImportedSymbols dflags arch os
-- i386 (and others?): -dynamic but not -fPIC
| osElfTarget os
, arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
= gopt Opt_ExternalDynamicRefs dflags &&
not (positionIndependent dflags)
= ncgExternalDynamicRefs config &&
not (ncgPIC config)
| otherwise
= False
where
platform = ncgPlatform config
arch = platformArch platform
os = platformOS platform
-- gotLabel
-- The label used to refer to our "fake GOT" from
......@@ -499,13 +504,16 @@ gotLabel
--------------------------------------------------------------------------------
-- Emit GOT declaration
-- Output whatever needs to be output once per .s file.
--
-- We don't need to declare any offset tables.
-- However, for PIC on x86, we need a small helper function.
pprGotDeclaration :: DynFlags -> Arch -> OS -> SDoc
pprGotDeclaration dflags ArchX86 OSDarwin
| positionIndependent dflags
= vcat [
pprGotDeclaration :: NCGConfig -> SDoc
pprGotDeclaration config = case (arch,os) of
(ArchX86, OSDarwin)
| ncgPIC config
-> vcat [
text ".section __TEXT,__textcoal_nt,coalesced,no_toc",
text ".weak_definition ___i686.get_pc_thunk.ax",
text ".private_extern ___i686.get_pc_thunk.ax",
......@@ -513,48 +521,49 @@ pprGotDeclaration dflags ArchX86 OSDarwin
text "\tmovl (%esp), %eax",
text "\tret" ]
pprGotDeclaration _ _ OSDarwin
= empty
-- Emit XCOFF TOC section
pprGotDeclaration _ _ OSAIX
= vcat $ [ text ".toc"
, text ".tc ghc_toc_table[TC],.LCTOC1"
, text ".csect ghc_toc_table[RW]"
-- See Note [.LCTOC1 in PPC PIC code]
, text ".set .LCTOC1,$+0x8000"
]
-- PPC 64 ELF v1 needs a Table Of Contents (TOC)
pprGotDeclaration _ (ArchPPC_64 ELF_V1) _
= text ".section \".toc\",\"aw\""
-- In ELF v2 we also need to tell the assembler that we want ABI
-- version 2. This would normally be done at the top of the file
-- right after a file directive, but I could not figure out how
-- to do that.
pprGotDeclaration _ (ArchPPC_64 ELF_V2) _
= vcat [ text ".abiversion 2",
text ".section \".toc\",\"aw\""
]
(_, OSDarwin) -> empty
-- Emit GOT declaration
-- Output whatever needs to be output once per .s file.
pprGotDeclaration dflags arch os
-- Emit XCOFF TOC section
(_, OSAIX)
-> vcat $ [ text ".toc"
, text ".tc ghc_toc_table[TC],.LCTOC1"
, text ".csect ghc_toc_table[RW]"
-- See Note [.LCTOC1 in PPC PIC code]
, text ".set .LCTOC1,$+0x8000"
]
-- PPC 64 ELF v1 needs a Table Of Contents (TOC)
(ArchPPC_64 ELF_V1, _)
-> text ".section \".toc\",\"aw\""
-- In ELF v2 we also need to tell the assembler that we want ABI
-- version 2. This would normally be done at the top of the file
-- right after a file directive, but I could not figure out how
-- to do that.
(ArchPPC_64 ELF_V2, _)
-> vcat [ text ".abiversion 2",
text ".section \".toc\",\"aw\""
]
(arch, os)
| osElfTarget os
, arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
, not (positionIndependent dflags)
= empty
, not (ncgPIC config)
-> empty
| osElfTarget os
, arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
= vcat [
-> vcat [
-- See Note [.LCTOC1 in PPC PIC code]
text ".section \".got2\",\"aw\"",
text ".LCTOC1 = .+32768" ]
pprGotDeclaration _ _ _
= panic "pprGotDeclaration: no match"
_ -> panic "pprGotDeclaration: no match"
where
platform = ncgPlatform config
arch = platformArch platform
os = platformOS platform
--------------------------------------------------------------------------------
......@@ -563,43 +572,44 @@ pprGotDeclaration _ _ _
-- and one for non-PIC.
--
pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc
pprImportedSymbol dflags (Platform { platformMini = PlatformMini { platformMini_arch = ArchX86, platformMini_os = OSDarwin } }) importedLbl
pprImportedSymbol :: DynFlags -> NCGConfig -> CLabel -> SDoc
pprImportedSymbol dflags config importedLbl = case (arch,os) of
(ArchX86, OSDarwin)
| Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl
= case positionIndependent dflags of
False ->
vcat [
text ".symbol_stub",
text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),
text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
text "\tjmp *L" <> pprCLabel dflags lbl
<> text "$lazy_ptr",
text "L" <> pprCLabel dflags lbl
<> text "$stub_binder:",
text "\tpushl $L" <> pprCLabel dflags lbl
<> text "$lazy_ptr",
text "\tjmp dyld_stub_binding_helper"
]
True ->
vcat [
text ".section __TEXT,__picsymbolstub2,"
<> text "symbol_stubs,pure_instructions,25",
text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),
text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
text "\tcall ___i686.get_pc_thunk.ax",
text "1:",
text "\tmovl L" <> pprCLabel dflags lbl
<> text "$lazy_ptr-1b(%eax),%edx",
text "\tjmp *%edx",
text "L" <> pprCLabel dflags lbl
<> text "$stub_binder:",
text "\tlea L" <> pprCLabel dflags lbl
<> text "$lazy_ptr-1b(%eax),%eax",
text "\tpushl %eax",
text "\tjmp dyld_stub_binding_helper"
]
$+$ vcat [ text ".section __DATA, __la_sym_ptr"
<> (if positionIndependent dflags then int 2 else int 3)
-> if not pic
then
vcat [
text ".symbol_stub",
text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),
text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
text "\tjmp *L" <> pprCLabel dflags lbl
<> text "$lazy_ptr",
text "L" <> pprCLabel dflags lbl
<> text "$stub_binder:",
text "\tpushl $L" <> pprCLabel dflags lbl
<> text "$lazy_ptr",
text "\tjmp dyld_stub_binding_helper"
]
else
vcat [
text ".section __TEXT,__picsymbolstub2,"
<> text "symbol_stubs,pure_instructions,25",
text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),
text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
text "\tcall ___i686.get_pc_thunk.ax",
text "1:",
text "\tmovl L" <> pprCLabel dflags lbl
<> text "$lazy_ptr-1b(%eax),%edx",
text "\tjmp *%edx",
text "L" <> pprCLabel dflags lbl
<> text "$stub_binder:",
text "\tlea L" <> pprCLabel dflags lbl
<> text "$lazy_ptr-1b(%eax),%eax",
text "\tpushl %eax",
text "\tjmp dyld_stub_binding_helper"
]
$+$ vcat [ text ".section __DATA, __la_sym_ptr"
<> (if pic then int 2 else int 3)
<> text ",lazy_symbol_pointers",
text "L" <> pprCLabel dflags lbl <> ptext (sLit "$lazy_ptr:"),
text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
......@@ -607,71 +617,68 @@ pprImportedSymbol dflags (Platform { platformMini = PlatformMini { platformMini_
<> text "$stub_binder"]
| Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl
= vcat [
-> vcat [
text ".non_lazy_symbol_pointer",
char 'L' <> pprCLabel dflags lbl <> text "$non_lazy_ptr:",
text "\t.indirect_symbol" <+> pprCLabel dflags lbl,
text "\t.long\t0"]
| otherwise
= empty
-> empty
(_, OSDarwin) -> empty
pprImportedSymbol _ (Platform { platformMini = PlatformMini { platformMini_os = OSDarwin } }) _
= empty
-- XCOFF / AIX
--
-- Similar to PPC64 ELF v1, there's dedicated TOC register (r2). To
-- workaround the limitation of a global TOC we use an indirect TOC
-- with the label `ghc_toc_table`.
--
-- See also GCC's `-mminimal-toc` compilation mode or
-- http://www.ibm.com/developerworks/rational/library/overview-toc-aix/
--
-- NB: No DSO-support yet
-- XCOFF / AIX
--
-- Similar to PPC64 ELF v1, there's dedicated TOC register (r2). To
-- workaround the limitation of a global TOC we use an indirect TOC
-- with the label `ghc_toc_table`.
--
-- See also GCC's `-mminimal-toc` compilation mode or
-- http://www.ibm.com/developerworks/rational/library/overview-toc-aix/
--
-- NB: No DSO-support yet
pprImportedSymbol dflags (Platform { platformMini = PlatformMini { platformMini_os = OSAIX } }) importedLbl
= case dynamicLinkerLabelInfo importedLbl of
(_, OSAIX) -> case dynamicLinkerLabelInfo importedLbl of
Just (SymbolPtr, lbl)
-> vcat [
text "LC.." <> pprCLabel dflags lbl <> char ':',
text "\t.long" <+> pprCLabel dflags lbl ]
_ -> empty
-- ELF / Linux
--
-- In theory, we don't need to generate any stubs or symbol pointers
-- by hand for Linux.
--
-- Reality differs from this in two areas.
--
-- 1) If we just use a dynamically imported symbol directly in a read-only
-- section of the main executable (as GCC does), ld generates R_*_COPY
-- relocations, which are fundamentally incompatible with reversed info
-- tables. Therefore, we need a table of imported addresses in a writable
-- section.
-- The "official" GOT mechanism (label@got) isn't intended to be used
-- in position dependent code, so we have to create our own "fake GOT"
-- when not Opt_PIC && WayDyn `elem` ways dflags.
--
-- 2) PowerPC Linux is just plain broken.
-- While it's theoretically possible to use GOT offsets larger
-- than 16 bit, the standard crt*.o files don't, which leads to
-- linker errors as soon as the GOT size exceeds 16 bit.
-- Also, the assembler doesn't support @gotoff labels.
-- In order to be able to use a larger GOT, we have to circumvent the
-- entire GOT mechanism and do it ourselves (this is also what GCC does).
-- When needImportedSymbols is defined,
-- the NCG will keep track of all DynamicLinkerLabels it uses
-- and output each of them using pprImportedSymbol.
pprImportedSymbol dflags platform@(Platform { platformMini = PlatformMini { platformMini_arch = ArchPPC_64 _ } })
importedLbl
| osElfTarget (platformOS platform)
= case dynamicLinkerLabelInfo importedLbl of
-- ELF / Linux
--
-- In theory, we don't need to generate any stubs or symbol pointers
-- by hand for Linux.
--
-- Reality differs from this in two areas.
--
-- 1) If we just use a dynamically imported symbol directly in a read-only
-- section of the main executable (as GCC does), ld generates R_*_COPY
-- relocations, which are fundamentally incompatible with reversed info
-- tables. Therefore, we need a table of imported addresses in a writable
-- section.
-- The "official" GOT mechanism (label@got) isn't intended to be used
-- in position dependent code, so we have to create our own "fake GOT"
-- when not Opt_PIC && WayDyn `elem` ways dflags.
--
-- 2) PowerPC Linux is just plain broken.
-- While it's theoretically possible to use GOT offsets larger
-- than 16 bit, the standard crt*.o files don't, which leads to
-- linker errors as soon as the GOT size exceeds 16 bit.
-- Also, the assembler doesn't support @gotoff labels.
-- In order to be able to use a larger GOT, we have to circumvent the
-- entire GOT mechanism and do it ourselves (this is also what GCC does).
-- When needImportedSymbols is defined,
-- the NCG will keep track of all DynamicLinkerLabels it uses
-- and output each of them using pprImportedSymbol.
(ArchPPC_64 _, _)
| osElfTarget os
-> case dynamicLinkerLabelInfo importedLbl of
Just (SymbolPtr, lbl)
-> vcat [
text ".section \".toc\", \"aw\"",
......@@ -679,11 +686,10 @@ pprImportedSymbol dflags platform@(Platform { platformMini = PlatformMini { plat
text "\t.quad" <+> pprCLabel dflags lbl ]
_ -> empty
pprImportedSymbol dflags platform importedLbl
| osElfTarget (platformOS platform)
= case dynamicLinkerLabelInfo importedLbl of
_ | osElfTarget os
-> case dynamicLinkerLabelInfo importedLbl of
Just (SymbolPtr, lbl)
-> let symbolSize = case wordWidth dflags of
-> let symbolSize = case ncgWordWidth config of
W32 -> sLit "\t.long"
W64 -> sLit "\t.quad"
_ -> panic "Unknown wordRep in pprImportedSymbol"
......@@ -696,8 +702,12 @@ pprImportedSymbol dflags platform importedLbl
-- PLT code stubs are generated automatically by the dynamic linker.
_ -> empty
pprImportedSymbol _ _ _
= panic "PIC.pprImportedSymbol: no match"
_ -> panic "PIC.pprImportedSymbol: no match"
where
platform = ncgPlatform config
arch = platformArch platform
os = platformOS platform
pic = ncgPIC config
--------------------------------------------------------------------------------
-- Generate code to calculate the address that should be put in the
......