diff options
| author | Ömer Sinan Ağacan <omeragacan@gmail.com> | 2019-10-14 15:44:58 +0300 |
|---|---|---|
| committer | Ömer Sinan Ağacan <omeragacan@gmail.com> | 2020-01-31 12:21:10 +0300 |
| commit | c846618ae0f8601515683a4c7677c20c3272a50f (patch) | |
| tree | 22caa68b7c6cdf3464d078e556f7eac19400b0bf /compiler/GHC | |
| parent | 01b15b835a7555c501df862b4dc8cc8eaff86afc (diff) | |
| download | haskell-c846618ae0f8601515683a4c7677c20c3272a50f.tar.gz | |
Do CafInfo/SRT analysis in Cmm
This patch removes all CafInfo predictions and various hacks to preserve
predicted CafInfos from the compiler and assigns final CafInfos to
interface Ids after code generation. SRT analysis is extended to support
static data, and Cmm generator is modified to allow generating
static_link fields after SRT analysis.
This also fixes `-fcatch-bottoms`, which introduces error calls in case
expressions in CorePrep, which runs *after* CoreTidy (which is where we
decide on CafInfos) and turns previously non-CAFFY things into CAFFY.
Fixes #17648
Fixes #9718
Evaluation
==========
NoFib
-----
Boot with: `make boot mode=fast`
Run: `make mode=fast EXTRA_RUNTEST_OPTS="-cachegrind" NoFibRuns=1`
--------------------------------------------------------------------------------
Program Size Allocs Instrs Reads Writes
--------------------------------------------------------------------------------
CS -0.0% 0.0% -0.0% -0.0% -0.0%
CSD -0.0% 0.0% -0.0% -0.0% -0.0%
FS -0.0% 0.0% -0.0% -0.0% -0.0%
S -0.0% 0.0% -0.0% -0.0% -0.0%
VS -0.0% 0.0% -0.0% -0.0% -0.0%
VSD -0.0% 0.0% -0.0% -0.0% -0.5%
VSM -0.0% 0.0% -0.0% -0.0% -0.0%
anna -0.1% 0.0% -0.0% -0.0% -0.0%
ansi -0.0% 0.0% -0.0% -0.0% -0.0%
atom -0.0% 0.0% -0.0% -0.0% -0.0%
awards -0.0% 0.0% -0.0% -0.0% -0.0%
banner -0.0% 0.0% -0.0% -0.0% -0.0%
bernouilli -0.0% 0.0% -0.0% -0.0% -0.0%
binary-trees -0.0% 0.0% -0.0% -0.0% -0.0%
boyer -0.0% 0.0% -0.0% -0.0% -0.0%
boyer2 -0.0% 0.0% -0.0% -0.0% -0.0%
bspt -0.0% 0.0% -0.0% -0.0% -0.0%
cacheprof -0.0% 0.0% -0.0% -0.0% -0.0%
calendar -0.0% 0.0% -0.0% -0.0% -0.0%
cichelli -0.0% 0.0% -0.0% -0.0% -0.0%
circsim -0.0% 0.0% -0.0% -0.0% -0.0%
clausify -0.0% 0.0% -0.0% -0.0% -0.0%
comp_lab_zift -0.0% 0.0% -0.0% -0.0% -0.0%
compress -0.0% 0.0% -0.0% -0.0% -0.0%
compress2 -0.0% 0.0% -0.0% -0.0% -0.0%
constraints -0.0% 0.0% -0.0% -0.0% -0.0%
cryptarithm1 -0.0% 0.0% -0.0% -0.0% -0.0%
cryptarithm2 -0.0% 0.0% -0.0% -0.0% -0.0%
cse -0.0% 0.0% -0.0% -0.0% -0.0%
digits-of-e1 -0.0% 0.0% -0.0% -0.0% -0.0%
digits-of-e2 -0.0% 0.0% -0.0% -0.0% -0.0%
dom-lt -0.0% 0.0% -0.0% -0.0% -0.0%
eliza -0.0% 0.0% -0.0% -0.0% -0.0%
event -0.0% 0.0% -0.0% -0.0% -0.0%
exact-reals -0.0% 0.0% -0.0% -0.0% -0.0%
exp3_8 -0.0% 0.0% -0.0% -0.0% -0.0%
expert -0.0% 0.0% -0.0% -0.0% -0.0%
fannkuch-redux -0.0% 0.0% -0.0% -0.0% -0.0%
fasta -0.0% 0.0% -0.0% -0.0% -0.0%
fem -0.0% 0.0% -0.0% -0.0% -0.0%
fft -0.0% 0.0% -0.0% -0.0% -0.0%
fft2 -0.0% 0.0% -0.0% -0.0% -0.0%
fibheaps -0.0% 0.0% -0.0% -0.0% -0.0%
fish -0.0% 0.0% -0.0% -0.0% -0.0%
fluid -0.1% 0.0% -0.0% -0.0% -0.0%
fulsom -0.0% 0.0% -0.0% -0.0% -0.0%
gamteb -0.0% 0.0% -0.0% -0.0% -0.0%
gcd -0.0% 0.0% -0.0% -0.0% -0.0%
gen_regexps -0.0% 0.0% -0.0% -0.0% -0.0%
genfft -0.0% 0.0% -0.0% -0.0% -0.0%
gg -0.0% 0.0% -0.0% -0.0% -0.0%
grep -0.0% 0.0% -0.0% -0.0% -0.0%
hidden -0.0% 0.0% -0.0% -0.0% -0.0%
hpg -0.1% 0.0% -0.0% -0.0% -0.0%
ida -0.0% 0.0% -0.0% -0.0% -0.0%
infer -0.0% 0.0% -0.0% -0.0% -0.0%
integer -0.0% 0.0% -0.0% -0.0% -0.0%
integrate -0.0% 0.0% -0.0% -0.0% -0.0%
k-nucleotide -0.0% 0.0% -0.0% -0.0% -0.0%
kahan -0.0% 0.0% -0.0% -0.0% -0.0%
knights -0.0% 0.0% -0.0% -0.0% -0.0%
lambda -0.0% 0.0% -0.0% -0.0% -0.0%
last-piece -0.0% 0.0% -0.0% -0.0% -0.0%
lcss -0.0% 0.0% -0.0% -0.0% -0.0%
life -0.0% 0.0% -0.0% -0.0% -0.0%
lift -0.0% 0.0% -0.0% -0.0% -0.0%
linear -0.1% 0.0% -0.0% -0.0% -0.0%
listcompr -0.0% 0.0% -0.0% -0.0% -0.0%
listcopy -0.0% 0.0% -0.0% -0.0% -0.0%
maillist -0.0% 0.0% -0.0% -0.0% -0.0%
mandel -0.0% 0.0% -0.0% -0.0% -0.0%
mandel2 -0.0% 0.0% -0.0% -0.0% -0.0%
mate -0.0% 0.0% -0.0% -0.0% -0.0%
minimax -0.0% 0.0% -0.0% -0.0% -0.0%
mkhprog -0.0% 0.0% -0.0% -0.0% -0.0%
multiplier -0.0% 0.0% -0.0% -0.0% -0.0%
n-body -0.0% 0.0% -0.0% -0.0% -0.0%
nucleic2 -0.0% 0.0% -0.0% -0.0% -0.0%
para -0.0% 0.0% -0.0% -0.0% -0.0%
paraffins -0.0% 0.0% -0.0% -0.0% -0.0%
parser -0.1% 0.0% -0.0% -0.0% -0.0%
parstof -0.1% 0.0% -0.0% -0.0% -0.0%
pic -0.0% 0.0% -0.0% -0.0% -0.0%
pidigits -0.0% 0.0% -0.0% -0.0% -0.0%
power -0.0% 0.0% -0.0% -0.0% -0.0%
pretty -0.0% 0.0% -0.3% -0.4% -0.4%
primes -0.0% 0.0% -0.0% -0.0% -0.0%
primetest -0.0% 0.0% -0.0% -0.0% -0.0%
prolog -0.0% 0.0% -0.0% -0.0% -0.0%
puzzle -0.0% 0.0% -0.0% -0.0% -0.0%
queens -0.0% 0.0% -0.0% -0.0% -0.0%
reptile -0.0% 0.0% -0.0% -0.0% -0.0%
reverse-complem -0.0% 0.0% -0.0% -0.0% -0.0%
rewrite -0.0% 0.0% -0.0% -0.0% -0.0%
rfib -0.0% 0.0% -0.0% -0.0% -0.0%
rsa -0.0% 0.0% -0.0% -0.0% -0.0%
scc -0.0% 0.0% -0.3% -0.5% -0.4%
sched -0.0% 0.0% -0.0% -0.0% -0.0%
scs -0.0% 0.0% -0.0% -0.0% -0.0%
simple -0.1% 0.0% -0.0% -0.0% -0.0%
solid -0.0% 0.0% -0.0% -0.0% -0.0%
sorting -0.0% 0.0% -0.0% -0.0% -0.0%
spectral-norm -0.0% 0.0% -0.0% -0.0% -0.0%
sphere -0.0% 0.0% -0.0% -0.0% -0.0%
symalg -0.0% 0.0% -0.0% -0.0% -0.0%
tak -0.0% 0.0% -0.0% -0.0% -0.0%
transform -0.0% 0.0% -0.0% -0.0% -0.0%
treejoin -0.0% 0.0% -0.0% -0.0% -0.0%
typecheck -0.0% 0.0% -0.0% -0.0% -0.0%
veritas -0.0% 0.0% -0.0% -0.0% -0.0%
wang -0.0% 0.0% -0.0% -0.0% -0.0%
wave4main -0.0% 0.0% -0.0% -0.0% -0.0%
wheel-sieve1 -0.0% 0.0% -0.0% -0.0% -0.0%
wheel-sieve2 -0.0% 0.0% -0.0% -0.0% -0.0%
x2n1 -0.0% 0.0% -0.0% -0.0% -0.0%
--------------------------------------------------------------------------------
Min -0.1% 0.0% -0.3% -0.5% -0.5%
Max -0.0% 0.0% -0.0% -0.0% -0.0%
Geometric Mean -0.0% -0.0% -0.0% -0.0% -0.0%
--------------------------------------------------------------------------------
Program Size Allocs Instrs Reads Writes
--------------------------------------------------------------------------------
circsim -0.1% 0.0% -0.0% -0.0% -0.0%
constraints -0.0% 0.0% -0.0% -0.0% -0.0%
fibheaps -0.0% 0.0% -0.0% -0.0% -0.0%
gc_bench -0.0% 0.0% -0.0% -0.0% -0.0%
hash -0.0% 0.0% -0.0% -0.0% -0.0%
lcss -0.0% 0.0% -0.0% -0.0% -0.0%
power -0.0% 0.0% -0.0% -0.0% -0.0%
spellcheck -0.0% 0.0% -0.0% -0.0% -0.0%
--------------------------------------------------------------------------------
Min -0.1% 0.0% -0.0% -0.0% -0.0%
Max -0.0% 0.0% -0.0% -0.0% -0.0%
Geometric Mean -0.0% +0.0% -0.0% -0.0% -0.0%
Manual inspection of programs in testsuite/tests/programs
---------------------------------------------------------
I built these programs with a bunch of dump flags and `-O` and compared
STG, Cmm, and Asm dumps and file sizes.
(Below the numbers in parenthesis show number of modules in the program)
These programs have identical compiler (same .hi and .o sizes, STG, and
Cmm and Asm dumps):
- Queens (1), andre_monad (1), cholewo-eval (2), cvh_unboxing (3),
andy_cherry (7), fun_insts (1), hs-boot (4), fast2haskell (2),
jl_defaults (1), jq_readsPrec (1), jules_xref (1), jtod_circint (4),
jules_xref2 (1), lennart_range (1), lex (1), life_space_leak (1),
bargon-mangler-bug (7), record_upd (1), rittri (1), sanders_array (1),
strict_anns (1), thurston-module-arith (2), okeefe_neural (1),
joao-circular (6), 10queens (1)
Programs with different compiler outputs:
- jl_defaults (1): For some reason GHC HEAD marks a lot of top-level
`[Int]` closures as CAFFY for no reason. With this patch we no longer
make them CAFFY and generate less SRT entries. For some reason Main.o
is slightly larger with this patch (1.3%) and the executable sizes are
the same. (I'd expect both to be smaller)
- launchbury (1): Same as jl_defaults: top-level `[Int]` closures marked
as CAFFY for no reason. Similarly `Main.o` is 1.4% larger but the
executable sizes are the same.
- galois_raytrace (13): Differences are in the Parse module. There are a
lot, but some of the changes are caused by the fact that for some
reason (I think a bug) GHC HEAD marks the dictionary for `Functor
Identity` as CAFFY. Parse.o is 0.4% larger, the executable size is the
same.
- north_array: We now generate less SRT entries because some of array
primops used in this program like `NewArrayOp` get eliminated during
Stg-to-Cmm and turn some CAFFY things into non-CAFFY. Main.o gets 24%
larger (9224 bytes from 9000 bytes), executable sizes are the same.
- seward-space-leak: Difference in this program is better shown by this
smaller example:
module Lib where
data CDS
= Case [CDS] [(Int, CDS)]
| Call CDS CDS
instance Eq CDS where
Case sels1 rets1 == Case sels2 rets2 =
sels1 == sels2 && rets1 == rets2
Call a1 b1 == Call a2 b2 =
a1 == a2 && b1 == b2
_ == _ =
False
In this program GHC HEAD builds a new SRT for the recursive group of
`(==)`, `(/=)` and the dictionary closure. Then `/=` points to `==`
in its SRT field, and `==` uses the SRT object as its SRT. With this
patch we use the closure for `/=` as the SRT and add `==` there. Then
`/=` gets an empty SRT field and `==` points to `/=` in its SRT
field.
This change looks fine to me.
Main.o gets 0.07% larger, executable sizes are identical.
head.hackage
------------
head.hackage's CI script builds 428 packages from Hackage using this
patch with no failures.
Compiler performance
--------------------
The compiler perf tests report that the compiler allocates slightly more
(worst case observed so far is 4%). However most programs in the test
suite are small, single file programs. To benchmark compiler performance
on something more realistic I build Cabal (the library, 236 modules)
with different optimisation levels. For the "max residency" row I run
GHC with `+RTS -s -A100k -i0 -h` for more accurate numbers. Other rows
are generated with just `-s`. (This is because `-i0` causes running GC
much more frequently and as a result "bytes copied" gets inflated by
more than 25x in some cases)
* -O0
| | GHC HEAD | This MR | Diff |
| --------------- | -------------- | -------------- | ------ |
| Bytes allocated | 54,413,350,872 | 54,701,099,464 | +0.52% |
| Bytes copied | 4,926,037,184 | 4,990,638,760 | +1.31% |
| Max residency | 421,225,624 | 424,324,264 | +0.73% |
* -O1
| | GHC HEAD | This MR | Diff |
| --------------- | --------------- | --------------- | ------ |
| Bytes allocated | 245,849,209,992 | 246,562,088,672 | +0.28% |
| Bytes copied | 26,943,452,560 | 27,089,972,296 | +0.54% |
| Max residency | 982,643,440 | 991,663,432 | +0.91% |
* -O2
| | GHC HEAD | This MR | Diff |
| --------------- | --------------- | --------------- | ------ |
| Bytes allocated | 291,044,511,408 | 291,863,910,912 | +0.28% |
| Bytes copied | 37,044,237,616 | 36,121,690,472 | -2.49% |
| Max residency | 1,071,600,328 | 1,086,396,256 | +1.38% |
Extra compiler allocations
--------------------------
Runtime allocations of programs are as reported above (NoFib section).
The compiler now allocates more than before. Main source of allocation
in this patch compared to base commit is the new SRT algorithm
(GHC.Cmm.Info.Build). Below is some of the extra work we do with this
patch, numbers generated by profiled stage 2 compiler when building a
pathological case (the test 'ManyConstructors') with '-O2':
- We now sort the final STG for a module, which means traversing the
entire program, generating free variable set for each top-level
binding, doing SCC analysis, and re-ordering the program. In
ManyConstructors this step allocates 97,889,952 bytes.
- We now do SRT analysis on static data, which in a program like
ManyConstructors causes analysing 10,000 bindings that we would
previously just skip. This step allocates 70,898,352 bytes.
- We now maintain an SRT map for the entire module as we compile Cmm
groups:
data ModuleSRTInfo = ModuleSRTInfo
{ ...
, moduleSRTMap :: SRTMap
}
(SRTMap is just a strict Map from the 'containers' library)
This map gets an entry for most bindings in a module (exceptions are
THUNKs and CAFFY static functions). For ManyConstructors this map
gets 50015 entries.
- Once we're done with code generation we generate a NameSet from SRTMap
for the non-CAFFY names in the current module. This set gets the same
number of entries as the SRTMap.
- Finally we update CafInfos in ModDetails for the non-CAFFY Ids, using
the NameSet generated in the previous step. This usually does the
least amount of allocation among the work listed here.
Only place with this patch where we do less work in the CAF analysis in
the tidying pass (CoreTidy). However that doesn't save us much, as the
pass still needs to traverse the whole program and update IdInfos for
other reasons. Only thing we don't here do is the `hasCafRefs` pass over
the RHS of bindings, which is a stateless pass that returns a boolean
value, so it doesn't allocate much.
(Metric changes blow are all increased allocations)
Metric changes
--------------
Metric Increase:
ManyAlternatives
ManyConstructors
T13035
T14683
T1969
T9961
Diffstat (limited to 'compiler/GHC')
26 files changed, 793 insertions, 630 deletions
diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs index 5efecdc534..8850f2e19a 100644 --- a/compiler/GHC/Cmm.hs +++ b/compiler/GHC/Cmm.hs @@ -3,12 +3,11 @@ module GHC.Cmm ( -- * Cmm top-level datatypes - CmmProgram, CmmGroup, GenCmmGroup, - CmmDecl, GenCmmDecl(..), + CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup, + CmmDecl, CmmDeclSRTs, GenCmmDecl(..), CmmGraph, GenCmmGraph(..), - CmmBlock, - RawCmmDecl, RawCmmGroup, - Section(..), SectionType(..), CmmStatics(..), CmmStatic(..), + CmmBlock, RawCmmDecl, + Section(..), SectionType(..), CmmStatics(..), RawCmmStatics(..), CmmStatic(..), isSecConstant, -- ** Blocks containing lists @@ -56,8 +55,12 @@ import Data.ByteString (ByteString) type CmmProgram = [CmmGroup] type GenCmmGroup d h g = [GenCmmDecl d h g] -type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph -type RawCmmGroup = GenCmmGroup CmmStatics (LabelMap CmmStatics) CmmGraph +-- | Cmm group before SRT generation +type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph +-- | Cmm group with SRTs +type CmmGroupSRTs = GenCmmGroup RawCmmStatics CmmTopInfo CmmGraph +-- | "Raw" cmm group (TODO (osa): not sure what that means) +type RawCmmGroup = GenCmmGroup RawCmmStatics (LabelMap RawCmmStatics) CmmGraph ----------------------------------------------------------------------------- -- CmmDecl, GenCmmDecl @@ -89,12 +92,13 @@ data GenCmmDecl d h g Section d -type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph +type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph +type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph type RawCmmDecl = GenCmmDecl - CmmStatics - (LabelMap CmmStatics) + RawCmmStatics + (LabelMap RawCmmStatics) CmmGraph ----------------------------------------------------------------------------- @@ -199,8 +203,20 @@ data CmmStatic | CmmString ByteString -- string of 8-bit values only, not zero terminated. +-- Static data before SRT generation data CmmStatics - = Statics + = CmmStatics + CLabel -- Label of statics + CmmInfoTable + CostCentreStack + [CmmLit] -- Payload + | CmmStaticsRaw + CLabel -- Label of statics + [CmmStatic] -- The static data itself + +-- Static data, after SRTs are generated +data RawCmmStatics + = RawCmmStatics CLabel -- Label of statics [CmmStatic] -- The static data itself diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index e84278bf65..c83dba8f39 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -106,7 +106,8 @@ module GHC.Cmm.CLabel ( pprCLabel, isInfoTableLabel, - isConInfoTableLabel + isConInfoTableLabel, + isIdLabel ) where #include "HsVersions.h" @@ -262,6 +263,10 @@ data CLabel deriving Eq +isIdLabel :: CLabel -> Bool +isIdLabel IdLabel{} = True +isIdLabel _ = False + -- This is laborious, but necessary. We can't derive Ord because -- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the -- implementation. See Note [No Ord for Unique] diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs index 6b940c9867..ae86788d9c 100644 --- a/compiler/GHC/Cmm/DebugBlock.hs +++ b/compiler/GHC/Cmm/DebugBlock.hs @@ -161,7 +161,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes = DebugBlock { dblProcedure = g_entry graph , dblLabel = label , dblCLabel = case info of - Just (Statics infoLbl _) -> infoLbl + Just (RawCmmStatics infoLbl _) -> infoLbl Nothing | g_entry graph == label -> entryLbl | otherwise -> blockLbl label diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs index a10db2b292..9e12fb170d 100644 --- a/compiler/GHC/Cmm/Info.hs +++ b/compiler/GHC/Cmm/Info.hs @@ -2,7 +2,6 @@ module GHC.Cmm.Info ( mkEmptyContInfoTable, cmmToRawCmm, - mkInfoTable, srtEscape, -- info table accessors @@ -67,11 +66,11 @@ mkEmptyContInfoTable info_lbl , cit_srt = Nothing , cit_clo = Nothing } -cmmToRawCmm :: DynFlags -> Stream IO CmmGroup a +cmmToRawCmm :: DynFlags -> Stream IO CmmGroupSRTs a -> IO (Stream IO RawCmmGroup a) cmmToRawCmm dflags cmms = do { uniqs <- mkSplitUniqSupply 'i' - ; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl]) + ; let do_one :: UniqSupply -> [CmmDeclSRTs] -> IO (UniqSupply, [RawCmmDecl]) do_one uniqs cmm = -- NB. strictness fixes a space leak. DO NOT REMOVE. withTimingSilent dflags (text "Cmm -> Raw Cmm") @@ -117,9 +116,8 @@ cmmToRawCmm dflags cmms -- -- * The SRT slot is only there if there is SRT info to record -mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl] -mkInfoTable _ (CmmData sec dat) - = return [CmmData sec dat] +mkInfoTable :: DynFlags -> CmmDeclSRTs -> UniqSM [RawCmmDecl] +mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat] mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) -- @@ -169,7 +167,7 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits -- - return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $ + return (top_decls, (lbl, RawCmmStatics info_lbl $ map CmmStaticLit $ reverse rel_extra_bits ++ rel_std_info)) ----------------------------------------------------- @@ -423,7 +421,7 @@ mkProfLits _ (ProfilingInfo td cd) ; (cd_lit, cd_decl) <- newStringLit cd ; return ((td_lit,cd_lit), [td_decl,cd_decl]) } -newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt) +newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt) newStringLit bytes = do { uniq <- getUniqueM ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) } diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs index 1ba79befcd..8dbe13d937 100644 --- a/compiler/GHC/Cmm/Info/Build.hs +++ b/compiler/GHC/Cmm/Info/Build.hs @@ -1,14 +1,17 @@ {-# LANGUAGE GADTs, BangPatterns, RecordWildCards, - GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections #-} + GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections, + ScopedTypeVariables, OverloadedStrings #-} module GHC.Cmm.Info.Build - ( CAFSet, CAFEnv, cafAnal - , doSRTs, ModuleSRTInfo, emptySRT + ( CAFSet, CAFEnv, cafAnal, cafAnalData + , doSRTs, ModuleSRTInfo (..), emptySRT + , SRTMap, srtMapNonCAFs ) where import GhcPrelude hiding (succ) import Id +import IdInfo import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph @@ -28,6 +31,7 @@ import GHC.Runtime.Layout import UniqSupply import CostCentre import GHC.StgToCmm.Heap +import ErrUtils import Control.Monad import Data.Map (Map) @@ -37,7 +41,9 @@ import qualified Data.Set as Set import Data.Tuple import Control.Monad.Trans.State import Control.Monad.Trans.Class +import Data.List (unzip4) +import NameSet {- Note [SRTs] @@ -183,6 +189,63 @@ and the only SRT closure we generate is g_srt = SRT_2 [c2_closure, c1_closure] +Algorithm +^^^^^^^^^ + +0. let srtMap :: Map CAFLabel (Maybe SRTEntry) = {} + Maps closures to their SRT entries (i.e. how they appear in a SRT payload) + +1. Start with decls :: [CmmDecl]. This corresponds to an SCC of bindings in STG + after code-generation. + +2. CPS-convert each CmmDecl (cpsTop), resulting in a list [CmmDecl]. There might + be multiple CmmDecls in the result, due to proc-point splitting. + +3. In cpsTop, *before* proc-point splitting, when we still have a single + CmmDecl, we do cafAnal for procs: + + * cafAnal performs a backwards analysis on the code blocks + + * For each labelled block, the analysis produces a CAFSet (= Set CAFLabel), + representing all the CAFLabels reachable from this label. + + * A label is added to the set if it refers to a FUN, THUNK, or RET, + and its CafInfo /= NoCafRefs. + (NB. all CafInfo for Ids in the current module should be initialised to + MayHaveCafRefs) + + * The result is CAFEnv = LabelMap CAFSet + + (Why *before* proc-point splitting? Because the analysis needs to propagate + information across branches, and proc-point splitting turns branches into + CmmCalls to top-level CmmDecls. The analysis would fail to find all the + references to CAFFY labels if we did it after proc-point splitting.) + + For static data, cafAnalData simply returns set of all labels that refer to a + FUN, THUNK, and RET whose CafInfos /= NoCafRefs. + +4. The result of cpsTop is (CAFEnv, [CmmDecl]) for procs and (CAFSet, CmmDecl) + for static data. So after `mapM cpsTop decls` we have + [Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)] + +5. For procs concat the decls and union the CAFEnvs to get (CAFEnv, [CmmDecl]) + +6. For static data generate a Map CLabel CAFSet (maps static data to their CAFSets) + +7. Dependency-analyse the decls using CAFEnv and CAFSets, giving us SCC CAFLabel + +8. For each SCC in dependency order + - Let lbls :: [CAFLabel] be the non-recursive labels in this SCC + - Apply CAFEnv to each label and concat the result :: [CAFLabel] + - For each CAFLabel in the set apply srtMap (and ignore Nothing) to get + srt :: [SRTEntry] + - Make a label for this SRT, call it l + - If the SRT is not empty (i.e. the group is CAFFY) add FUN_STATICs in the + group to the SRT (see Note [Invalid optimisation: shortcutting]) + - Add to srtMap: lbls -> if null srt then Nothing else Just l + +9. At the end, for every top-level binding x, if srtMap x == Nothing, then the + binding is non-CAFFY, otherwise it is CAFFY. Optimisations ^^^^^^^^^^^^^ @@ -382,6 +445,35 @@ newtype SRTEntry = SRTEntry CLabel -- --------------------------------------------------------------------- -- CAF analysis +addCafLabel :: CLabel -> CAFSet -> CAFSet +addCafLabel l s + | Just _ <- hasHaskellName l + , let caf_label = mkCAFLabel l + -- For imported Ids hasCAF will have accurate CafInfo + -- Locals are initialized as CAFFY. We turn labels with empty SRTs into + -- non-CAFFYs in doSRTs + , hasCAF l + = Set.insert caf_label s + | otherwise + = s + +cafAnalData + :: CmmStatics + -> CAFSet + +cafAnalData (CmmStaticsRaw _lbl _data) = + Set.empty + +cafAnalData (CmmStatics _lbl _itbl _ccs payload) = + foldl' analyzeStatic Set.empty payload + where + analyzeStatic s lit = + case lit of + CmmLabel c -> addCafLabel c s + CmmLabelOff c _ -> addCafLabel c s + CmmLabelDiffOff c1 c2 _ _ -> addCafLabel c1 $! addCafLabel c2 s + _ -> s + -- | -- For each code block: -- - collect the references reachable from this code block to FUN, @@ -412,17 +504,24 @@ cafLattice = DataflowLattice Set.empty add cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet cafTransfers contLbls entry topLbl - (BlockCC eNode middle xNode) fBase = - let joined = cafsInNode xNode $! live' + block@(BlockCC eNode middle xNode) fBase = + let joined :: CAFSet + joined = cafsInNode xNode $! live' + + result :: CAFSet !result = foldNodesBwdOO cafsInNode middle joined + facts :: [Set CAFLabel] facts = mapMaybe successorFact (successors xNode) + + live' :: CAFSet live' = joinFacts cafLattice facts + successorFact :: Label -> Maybe (Set CAFLabel) successorFact s -- If this is a loop back to the entry, we can refer to the -- entry label. - | s == entry = Just (add topLbl Set.empty) + | s == entry = Just (addCafLabel topLbl Set.empty) -- If this is a continuation, we want to refer to the -- SRT for the continuation's info table | s `setMember` contLbls @@ -432,18 +531,27 @@ cafTransfers contLbls entry topLbl = lookupFact s fBase cafsInNode :: CmmNode e x -> CAFSet -> CAFSet - cafsInNode node set = foldExpDeep addCaf node set + cafsInNode node set = foldExpDeep addCafExpr node set - addCaf expr !set = + addCafExpr :: CmmExpr -> Set CAFLabel -> Set CAFLabel + addCafExpr expr !set = case expr of - CmmLit (CmmLabel c) -> add c set - CmmLit (CmmLabelOff c _) -> add c set - CmmLit (CmmLabelDiffOff c1 c2 _ _) -> add c1 $! add c2 set - _ -> set - add l s | hasCAF l = Set.insert (mkCAFLabel l) s - | otherwise = s - - in mapSingleton (entryLabel eNode) result + CmmLit (CmmLabel c) -> + addCafLabel c set + CmmLit (CmmLabelOff c _) -> + addCafLabel c set + CmmLit (CmmLabelDiffOff c1 c2 _ _) -> + addCafLabel c1 $! addCafLabel c2 set + _ -> + set + in + srtTrace "cafTransfers" (text "block:" <+> ppr block $$ + text "contLbls:" <+> ppr contLbls $$ + text "entry:" <+> ppr entry $$ + text "topLbl:" <+> ppr topLbl $$ + text "cafs in exit:" <+> ppr joined $$ + text "result:" <+> ppr result) $ + mapSingleton (entryLabel eNode) result -- ----------------------------------------------------------------------------- @@ -460,17 +568,24 @@ data ModuleSRTInfo = ModuleSRTInfo -- entries. e.g. if we have an SRT [a,b,c], and we know that b -- points to [c,d], we can omit c and emit [a,b]. -- Used to implement the [Filter] optimisation. + , moduleSRTMap :: SRTMap } + instance Outputable ModuleSRTInfo where ppr ModuleSRTInfo{..} = - text "ModuleSRTInfo:" <+> ppr dedupSRTs <+> ppr flatSRTs + text "ModuleSRTInfo {" $$ + (nest 4 $ text "dedupSRTs =" <+> ppr dedupSRTs $$ + text "flatSRTs =" <+> ppr flatSRTs $$ + text "moduleSRTMap =" <+> ppr moduleSRTMap) $$ char '}' emptySRT :: Module -> ModuleSRTInfo emptySRT mod = ModuleSRTInfo { thisModule = mod , dedupSRTs = Map.empty - , flatSRTs = Map.empty } + , flatSRTs = Map.empty + , moduleSRTMap = Map.empty + } -- ----------------------------------------------------------------------------- -- Constructing SRTs @@ -489,14 +604,33 @@ emptySRT mod = -} +data SomeLabel + = BlockLabel Label + | DeclLabel CLabel + deriving (Eq, Ord) + +instance Outputable SomeLabel where + ppr (BlockLabel l) = text "b:" <+> ppr l + ppr (DeclLabel l) = text "s:" <+> ppr l + +getBlockLabel :: SomeLabel -> Maybe Label +getBlockLabel (BlockLabel l) = Just l +getBlockLabel (DeclLabel _) = Nothing + +getBlockLabels :: [SomeLabel] -> [Label] +getBlockLabels = mapMaybe getBlockLabel + -- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl, -- where the label is -- - the info label for a continuation or dynamic closure -- - the closure label for a top-level function (not a CAF) -getLabelledBlocks :: CmmDecl -> [(Label, CAFLabel)] -getLabelledBlocks (CmmData _ _) = [] +getLabelledBlocks :: CmmDecl -> [(SomeLabel, CAFLabel)] +getLabelledBlocks (CmmData _ (CmmStaticsRaw _ _)) = + [] +getLabelledBlocks (CmmData _ (CmmStatics lbl _ _ _)) = + [ (DeclLabel lbl, mkCAFLabel lbl) ] getLabelledBlocks (CmmProc top_info _ _ _) = - [ (blockId, mkCAFLabel (cit_lbl info)) + [ (BlockLabel blockId, mkCAFLabel (cit_lbl info)) | (blockId, info) <- mapToList (info_tbls top_info) , let rep = cit_rep info , not (isStaticRep rep) || not (isThunkRep rep) @@ -509,20 +643,30 @@ getLabelledBlocks (CmmProc top_info _ _ _) = -- SRTs. CAFs themselves are not included here; see getCAFs below. depAnalSRTs :: CAFEnv + -> Map CLabel CAFSet -- CAFEnv for statics -> [CmmDecl] - -> [SCC (Label, CAFLabel, Set CAFLabel)] -depAnalSRTs cafEnv decls = - srtTrace "depAnalSRTs" (ppr graph) graph + -> [SCC (SomeLabel, CAFLabel, Set CAFLabel)] +depAnalSRTs cafEnv cafEnv_static decls = + srtTrace "depAnalSRTs" (text "decls:" <+> ppr decls $$ + text "nodes:" <+> ppr (map node_payload nodes) $$ + text "graph:" <+> ppr graph) graph where labelledBlocks = concatMap getLabelledBlocks decls labelToBlock = Map.fromList (map swap labelledBlocks) - graph = stronglyConnCompFromEdgedVerticesOrd - [ let cafs' = Set.delete lbl cafs in - DigraphNode (l,lbl,cafs') l - (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs')) - | (l, lbl) <- labelledBlocks - , Just cafs <- [mapLookup l cafEnv] ] + nodes :: [Node SomeLabel (SomeLabel, CAFLabel, Set CAFLabel)] + nodes = [ DigraphNode (l,lbl,cafs') l + (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs')) + | (l, lbl) <- labelledBlocks + , Just (cafs :: Set CAFLabel) <- + [case l of + BlockLabel l -> mapLookup l cafEnv + DeclLabel cl -> Map.lookup cl cafEnv_static] + , let cafs' = Set.delete lbl cafs + ] + + graph :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)] + graph = stronglyConnCompFromEdgedVerticesOrd nodes -- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF. -- These are treated differently from other labelled blocks: @@ -565,11 +709,21 @@ getStaticFuns decls = -- is empty, so we don't need to refer to it from other SRTs. type SRTMap = Map CAFLabel (Maybe SRTEntry) + +-- | Given SRTMap of a module returns the set of non-CAFFY names in the module. +-- Any Names not in the set are CAFFY. +srtMapNonCAFs :: SRTMap -> NameSet +srtMapNonCAFs srtMap = mkNameSet (mapMaybe get_name (Map.toList srtMap)) + where + get_name (CAFLabel l, Nothing) = hasHaskellName l + get_name (_l, Just _srt_entry) = Nothing + -- | resolve a CAFLabel to its SRTEntry using the SRTMap resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry resolveCAF srtMap lbl@(CAFLabel l) = - Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap - + srtTrace "resolveCAF" ("l:" <+> ppr l <+> "resolved:" <+> ppr ret) ret + where + ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap -- | Attach SRTs to all info tables in the CmmDecls, and add SRT -- declarations to the ModuleSRTInfo. @@ -578,16 +732,33 @@ doSRTs :: DynFlags -> ModuleSRTInfo -> [(CAFEnv, [CmmDecl])] - -> IO (ModuleSRTInfo, [CmmDecl]) + -> [(CAFSet, CmmDecl)] + -> IO (ModuleSRTInfo, [CmmDeclSRTs]) -doSRTs dflags moduleSRTInfo tops = do +doSRTs dflags moduleSRTInfo procs data_ = do us <- mkSplitUniqSupply 'u' -- Ignore the original grouping of decls, and combine all the -- CAFEnvs into a single CAFEnv. - let (cafEnvs, declss) = unzip tops - cafEnv = mapUnions cafEnvs - decls = concat declss + let static_data_env :: Map CLabel CAFSet + static_data_env = + Map.fromList $ + flip map data_ $ + \(set, decl) -> + case decl of + CmmProc{} -> + pprPanic "doSRTs" (text "Proc in static data list:" <+> ppr decl) + CmmData _ static -> + case static of + CmmStatics lbl _ _ _ -> (lbl, set) + CmmStaticsRaw lbl _ -> (lbl, set) + + static_data :: Set CLabel + static_data = Map.keysSet static_data_env + + (proc_envs, procss) = unzip procs + cafEnv = mapUnions proc_envs + decls = map snd data_ ++ concat procss staticFuns = mapFromList (getStaticFuns decls) -- Put the decls in dependency order. Why? So that we can implement @@ -597,56 +768,93 @@ doSRTs dflags moduleSRTInfo tops = do -- to do this we need to process blocks before things that depend on -- them. let - sccs = depAnalSRTs cafEnv decls + sccs :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)] + sccs = depAnalSRTs cafEnv static_data_env decls + + cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)] cafsWithSRTs = getCAFs cafEnv decls + srtTraceM "doSRTs" (text "data:" <+> ppr data_ $$ + text "procs:" <+> ppr procs $$ + text "static_data_env:" <+> ppr static_data_env $$ + text "sccs:" <+> ppr sccs $$ + text "cafsWithSRTs:" <+> ppr cafsWithSRTs) + -- On each strongly-connected group of decls, construct the SRT -- closures and the SRT fields for info tables. let result :: - [ ( [CmmDecl] -- generated SRTs + [ ( [CmmDeclSRTs] -- generated SRTs , [(Label, CLabel)] -- SRT fields for info tables , [(Label, [SRTEntry])] -- SRTs to attach to static functions + , Bool -- Whether the group has CAF references ) ] - ((result, _srtMap), moduleSRTInfo') = + + (result, moduleSRTInfo') = initUs_ us $ - flip runStateT moduleSRTInfo $ - flip runStateT Map.empty $ do - nonCAFs <- mapM (doSCC dflags staticFuns) sccs + flip runStateT moduleSRTInfo $ do + nonCAFs <- mapM (doSCC dflags staticFuns static_data) sccs cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) -> - oneSRT dflags staticFuns [l] [cafLbl] True{-is a CAF-} cafs + oneSRT dflags staticFuns [BlockLabel l] [cafLbl] + True{-is a CAF-} cafs static_data return (nonCAFs ++ cAFs) - (declss, pairs, funSRTs) = unzip3 result + (srt_declss, pairs, funSRTs, has_caf_refs) = unzip4 result + srt_decls = concat srt_declss + + unless (null srt_decls) $ + dumpIfSet_dyn dflags Opt_D_dump_srts "SRTs" FormatCMM (ppr srt_decls) -- Next, update the info tables with the SRTs let srtFieldMap = mapFromList (concat pairs) funSRTMap = mapFromList (concat funSRTs) - decls' = concatMap (updInfoSRTs dflags srtFieldMap funSRTMap) decls - - return (moduleSRTInfo', concat declss ++ decls') + has_caf_refs' = or has_caf_refs + decls' = + concatMap (updInfoSRTs dflags srtFieldMap funSRTMap has_caf_refs') decls + + -- Finally update CafInfos for raw static literals (CmmStaticsRaw). Those are + -- not analysed in oneSRT so we never add entries for them to the SRTMap. + let srtMap_w_raws = + foldl' (\(srtMap :: SRTMap) (_, decl) -> + case decl of + CmmData _ CmmStatics{} -> + -- already updated by oneSRT + srtMap + CmmData _ (CmmStaticsRaw lbl _) + | isIdLabel lbl -> + -- not analysed by oneSRT, declare it non-CAFFY here + Map.insert (mkCAFLabel lbl) Nothing srtMap + | otherwise -> + -- Not an IdLabel, ignore + srtMap + CmmProc{} -> + pprPanic "doSRTs" (text "Found Proc in static data list:" <+> ppr decl)) + (moduleSRTMap moduleSRTInfo') data_ + + return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls') -- | Build the SRT for a strongly-connected component of blocks doSCC :: DynFlags - -> LabelMap CLabel -- which blocks are static function entry points - -> SCC (Label, CAFLabel, Set CAFLabel) - -> StateT SRTMap - (StateT ModuleSRTInfo UniqSM) - ( [CmmDecl] -- generated SRTs + -> LabelMap CLabel -- which blocks are static function entry points + -> Set CLabel -- static data + -> SCC (SomeLabel, CAFLabel, Set CAFLabel) + -> StateT ModuleSRTInfo UniqSM + ( [CmmDeclSRTs] -- generated SRTs , [(Label, CLabel)] -- SRT fields for info tables , [(Label, [SRTEntry])] -- SRTs to attach to static functions + , Bool -- Whether the group has CAF references ) -doSCC dflags staticFuns (AcyclicSCC (l, cafLbl, cafs)) = - oneSRT dflags staticFuns [l] [cafLbl] False cafs +doSCC dflags staticFuns static_data (AcyclicSCC (l, cafLbl, cafs)) = + oneSRT dflags staticFuns [l] [cafLbl] False cafs static_data -doSCC dflags staticFuns (CyclicSCC nodes) = do +doSCC dflags staticFuns static_data (CyclicSCC nodes) = do -- build a single SRT for the whole cycle, see Note [recursive SRTs] - let (blockids, lbls, cafsets) = unzip3 nodes + let (lbls, caf_lbls, cafsets) = unzip3 nodes cafs = Set.unions cafsets - oneSRT dflags staticFuns blockids lbls False cafs + oneSRT dflags staticFuns lbls caf_lbls False cafs static_data {- Note [recursive SRTs] @@ -677,34 +885,40 @@ references to static function closures. oneSRT :: DynFlags -> LabelMap CLabel -- which blocks are static function entry points - -> [Label] -- blocks in this set + -> [SomeLabel] -- blocks in this set -> [CAFLabel] -- labels for those blocks -> Bool -- True <=> this SRT is for a CAF -> Set CAFLabel -- SRT for this set - -> StateT SRTMap - (StateT ModuleSRTInfo UniqSM) - ( [CmmDecl] -- SRT objects we built + -> Set CLabel -- Static data labels in this group + -> StateT ModuleSRTInfo UniqSM + ( [CmmDeclSRTs] -- SRT objects we built , [(Label, CLabel)] -- SRT fields for these blocks' itbls , [(Label, [SRTEntry])] -- SRTs to attach to static functions + , Bool -- Whether the group has CAF references ) -oneSRT dflags staticFuns blockids lbls isCAF cafs = do - srtMap <- get - topSRT <- lift get +oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do + topSRT <- get + let + srtMap = moduleSRTMap topSRT + + blockids = getBlockLabels lbls + -- Can we merge this SRT with a FUN_STATIC closure? + maybeFunClosure :: Maybe (CLabel, Label) + otherFunLabels :: [CLabel] (maybeFunClosure, otherFunLabels) = case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of [] -> (Nothing, []) - ((l,b):xs) -> (Just (l,b), map (mkCAFLabel . fst) xs) + ((l,b):xs) -> (Just (l,b), map fst xs) - -- Remove recursive references from the SRT, except for (all but - -- one of the) static functions. See Note [recursive SRTs]. - nonRec = cafs `Set.difference` - (Set.fromList lbls `Set.difference` Set.fromList otherFunLabels) + -- Remove recursive references from the SRT + nonRec :: Set CAFLabel + nonRec = cafs `Set.difference` Set.fromList caf_lbls - -- First resolve all the CAFLabels to SRTEntries - -- Implements the [Inline] optimisation. + -- Resolve references to their SRT entries + resolved :: [SRTEntry] resolved = mapMaybe (resolveCAF srtMap) (Set.toList nonRec) -- The set of all SRTEntries in SRTs that we refer to from here. @@ -714,10 +928,21 @@ oneSRT dflags staticFuns blockids lbls isCAF cafs = do -- Remove SRTEntries that are also in an SRT that we refer to. -- Implements the [Filter] optimisation. - filtered = Set.difference (Set.fromList resolved) allBelow - - srtTrace "oneSRT:" - (ppr cafs <+> ppr resolved <+> ppr allBelow <+> ppr filtered) $ return () + filtered0 = Set.fromList resolved `Set.difference` allBelow + + srtTraceM "oneSRT:" + (text "srtMap:" <+> ppr srtMap $$ + text "nonRec:" <+> ppr nonRec $$ + text "lbls:" <+> ppr lbls $$ + text "caf_lbls:" <+> ppr caf_lbls $$ + text "static_data:" <+> ppr static_data $$ + text "cafs:" <+> ppr cafs $$ + text "blockids:" <+> ppr blockids $$ + text "maybeFunClosure:" <+> ppr maybeFunClosure $$ + text "otherFunLabels:" <+> ppr otherFunLabels $$ + text "resolved:" <+> ppr resolved $$ + text "allBelow:" <+> ppr allBelow $$ + text "filtered0:" <+> ppr filtered0) let isStaticFun = isJust maybeFunClosure @@ -726,76 +951,114 @@ oneSRT dflags staticFuns blockids lbls isCAF cafs = do -- update the SRTMap for the label to point to a closure. It's -- important that we don't do this for static functions or CAFs, -- see Note [Invalid optimisation: shortcutting]. + updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM () updateSRTMap srtEntry = - when (not isCAF && (not isStaticFun || isNothing srtEntry)) $ do - let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls] - put (Map.union newSRTMap srtMap) + srtTrace "updateSRTMap" + (ppr srtEntry <+> "isCAF:" <+> ppr isCAF <+> + "isStaticFun:" <+> ppr isStaticFun) $ + when (not isCAF && (not isStaticFun || isNothing srtEntry)) $ + modify' $ \state -> + let !srt_map = + foldl' (\srt_map cafLbl@(CAFLabel clbl) -> + -- Only map static data to Nothing (== not CAFFY). For CAFFY + -- statics we refer to the static itself instead of a SRT. + if not (Set.member clbl static_data) || isNothing srtEntry then + Map.insert cafLbl srtEntry srt_map + else + srt_map) + (moduleSRTMap state) + caf_lbls + in + state{ moduleSRTMap = srt_map } this_mod = thisModule topSRT - case Set.toList filtered of - [] -> do - srtTrace "oneSRT: empty" (ppr lbls) $ return () - updateSRTMap Nothing - return ([], [], []) - - -- [Inline] - when we have only one entry there is no need to - -- build an SRT object at all, instead we put the singleton SRT - -- entry in the info table. - [one@(SRTEntry lbl)] - | -- Info tables refer to SRTs by offset (as noted in the section - -- "Referring to an SRT from the info table" of Note [SRTs]). However, - -- when dynamic linking is used we cannot guarantee that the offset - -- between the SRT and the info table will fit in the offset field. - -- Consequently we build a singleton SRT in in this case. - not (labelDynamic dflags this_mod lbl) - - -- MachO relocations can't express offsets between compilation units at - -- all, so we are always forced to build a singleton SRT in this case. - && (not (osMachOTarget $ platformOS $ targetPlatform dflags) - || isLocalCLabel this_mod lbl) -> do - - -- If we have a static function closure, then it becomes the - -- SRT object, and everything else points to it. (the only way - -- we could have multiple labels here is if this is a - -- recursive group, see Note [recursive SRTs]) - case maybeFunClosure of - Just (staticFunLbl,staticFunBlock) -> return ([], withLabels, []) - where - withLabels = - [ (b, if b == staticFunBlock then lbl else staticFunLbl) - | b <- blockids ] + allStaticData = + all (\(CAFLabel clbl) -> Set.member clbl static_data) caf_lbls + + if Set.null filtered0 then do + srtTraceM "oneSRT: empty" (ppr caf_lbls) + updateSRTMap Nothing + return ([], [], [], False) + else do + -- We're going to build an SRT for this group, which should include function + -- references in the group. See Note [recursive SRTs]. + let allBelow_funs = + Set.fromList (map (SRTEntry . toClosureLbl) otherFunLabels) + let filtered = filtered0 `Set.union` allBelow_funs + srtTraceM "oneSRT" (text "filtered:" <+> ppr filtered $$ + text "allBelow_funs:" <+> ppr allBelow_funs) + case Set.toList filtered of + [] -> pprPanic "oneSRT" empty -- unreachable + + -- [Inline] - when we have only one entry there is no need to + -- build an SRT object at all, instead we put the singleton SRT + -- entry in the info table. + [one@(SRTEntry lbl)] + | -- Info tables refer to SRTs by offset (as noted in the section + -- "Referring to an SRT from the info table" of Note [SRTs]). However, + -- when dynamic linking is used we cannot guarantee that the offset + -- between the SRT and the info table will fit in the offset field. + -- Consequently we build a singleton SRT in in this case. + not (labelDynamic dflags this_mod lbl) + + -- MachO relocations can't express offsets between compilation units at + -- all, so we are always forced to build a singleton SRT in this case. + && (not (osMachOTarget $ platformOS $ targetPlatform dflags) + || isLocalCLabel this_mod lbl) -> do + + -- If we have a static function closure, then it becomes the + -- SRT object, and everything else points to it. (the only way + -- we could have multiple labels here is if this is a + -- recursive group, see Note [recursive SRTs]) + case maybeFunClosure of + Just (staticFunLbl,staticFunBlock) -> + return ([], withLabels, [], True) + where + withLabels = + [ (b, if b == staticFunBlock then lbl else staticFunLbl) + | b <- blockids ] + Nothing -> do + srtTraceM "oneSRT: one" (text "caf_lbls:" <+> ppr caf_lbls $$ + text "one:" <+> ppr one) + updateSRTMap (Just one) + return ([], map (,lbl) blockids, [], True) + + cafList | allStaticData -> + return ([], [], [], not (null cafList)) + + cafList -> + -- Check whether an SRT with the same entries has been emitted already. + -- Implements the [Common] optimisation. + case Map.lookup filtered (dedupSRTs topSRT) of + Just srtEntry@(SRTEntry srtLbl) -> do + srtTraceM "oneSRT [Common]" (ppr caf_lbls <+> ppr srtLbl) + updateSRTMap (Just srtEntry) + return ([], map (,srtLbl) blockids, [], True) Nothing -> do - updateSRTMap (Just one) - return ([], map (,lbl) blockids, []) - - cafList -> - -- Check whether an SRT with the same entries has been emitted already. - -- Implements the [Common] optimisation. - case Map.lookup filtered (dedupSRTs topSRT) of - Just srtEntry@(SRTEntry srtLbl) -> do - srtTrace "oneSRT [Common]" (ppr lbls <+> ppr srtLbl) $ return () - updateSRTMap (Just srtEntry) - return ([], map (,srtLbl) blockids, []) - Nothing -> do - -- No duplicates: we have to build a new SRT object - srtTrace "oneSRT: new" (ppr lbls <+> ppr filtered) $ return () - (decls, funSRTs, srtEntry) <- - case maybeFunClosure of - Just (fun,block) -> - return ( [], [(block, cafList)], SRTEntry fun ) - Nothing -> do - (decls, entry) <- lift . lift $ buildSRTChain dflags cafList - return (decls, [], entry) - updateSRTMap (Just srtEntry) - let allBelowThis = Set.union allBelow filtered - oldFlatSRTs = flatSRTs topSRT - newFlatSRTs = Map.insert srtEntry allBelowThis oldFlatSRTs - newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT) - lift (put (topSRT { dedupSRTs = newDedupSRTs - , flatSRTs = newFlatSRTs })) - let SRTEntry lbl = srtEntry - return (decls, map (,lbl) blockids, funSRTs) + -- No duplicates: we have to build a new SRT object + (decls, funSRTs, srtEntry) <- + case maybeFunClosure of + Just (fun,block) -> + return ( [], [(block, cafList)], SRTEntry fun ) + Nothing -> do + (decls, entry) <- lift $ buildSRTChain dflags cafList + return (decls, [], entry) + updateSRTMap (Just srtEntry) + let allBelowThis = Set.union allBelow filtered + newFlatSRTs = Map.insert srtEntry allBelowThis (flatSRTs topSRT) + -- When all definition in this group are static data we don't + -- generate any SRTs. + newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT) + modify' (\state -> state{ dedupSRTs = newDedupSRTs, + flatSRTs = newFlatSRTs }) + srtTraceM "oneSRT: new" (text "caf_lbls:" <+> ppr caf_lbls $$ + text "filtered:" <+> ppr filtered $$ + text "srtEntry:" <+> ppr srtEntry $$ + text "newDedupSRTs:" <+> ppr newDedupSRTs $$ + text "newFlatSRTs:" <+> ppr newFlatSRTs) + let SRTEntry lbl = srtEntry + return (decls, map (,lbl) blockids, funSRTs, True) -- | build a static SRT object (or a chain of objects) from a list of @@ -804,8 +1067,8 @@ buildSRTChain :: DynFlags -> [SRTEntry] -> UniqSM - ( [CmmDecl] -- The SRT object(s) - , SRTEntry -- label to use in the info table + ( [CmmDeclSRTs] -- The SRT object(s) + , SRTEntry -- label to use in the info table ) buildSRTChain _ [] = panic "buildSRT: empty" buildSRTChain dflags cafSet = @@ -821,7 +1084,7 @@ buildSRTChain dflags cafSet = mAX_SRT_SIZE = 16 -buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDecl, SRTEntry) +buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry) buildSRT dflags refs = do id <- getUniqueM let @@ -835,20 +1098,30 @@ buildSRT dflags refs = do [] -- no saved info return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl) - -- | Update info tables with references to their SRTs. Also generate -- static closures, splicing in SRT fields as necessary. updInfoSRTs :: DynFlags -> LabelMap CLabel -- SRT labels for each block -> LabelMap [SRTEntry] -- SRTs to merge into FUN_STATIC closures + -> Bool -- Whether the CmmDecl's group has CAF references -> CmmDecl - -> [CmmDecl] + -> [CmmDeclSRTs] + +updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics)) + = [CmmData s (RawCmmStatics lbl statics)] + +updInfoSRTs dflags _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload)) + = [CmmData s (RawCmmStatics lbl (map CmmStaticLit field_lits))] + where + caf_info = if caffy then MayHaveCafRefs else NoCafRefs + field_lits = mkStaticClosureFields dflags itbl ccs caf_info payload -updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g) +updInfoSRTs dflags srt_env funSRTEnv caffy (CmmProc top_info top_l live g) | Just (_,closure) <- maybeStaticClosure = [ proc, closure ] | otherwise = [ proc ] where + caf_info = if caffy then MayHaveCafRefs else NoCafRefs proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info) updInfoTbl l info_tbl @@ -858,7 +1131,7 @@ updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g) -- Generate static closures [FUN]. Note that this also generates -- static closures for thunks (CAFs), because it's easier to treat -- them uniformly in the code generator. - maybeStaticClosure :: Maybe (CmmInfoTable, CmmDecl) + maybeStaticClosure :: Maybe (CmmInfoTable, CmmDeclSRTs) maybeStaticClosure | Just info_tbl@CmmInfoTable{..} <- mapLookup (g_entry g) (info_tbls top_info) @@ -873,20 +1146,20 @@ updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g) Just srtEntries -> srtTrace "maybeStaticFun" (ppr res) (info_tbl { cit_rep = new_rep }, res) where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ] - fields = mkStaticClosureFields dflags info_tbl ccs (idCafInfo id) - srtEntries + fields = mkStaticClosureFields dflags info_tbl ccs caf_info srtEntries new_rep = case cit_rep of HeapRep sta ptrs nptrs ty -> HeapRep sta (ptrs + length srtEntries) nptrs ty _other -> panic "maybeStaticFun" - lbl = mkLocalClosureLabel (idName id) (idCafInfo id) + lbl = mkLocalClosureLabel (idName id) caf_info in Just (newInfo, mkDataLits (Section Data lbl) lbl fields) | otherwise = Nothing -updInfoSRTs _ _ _ t = [t] - srtTrace :: String -> SDoc -> b -> b -- srtTrace = pprTrace srtTrace _ _ b = b + +srtTraceM :: Applicative f => String -> SDoc -> f () +srtTraceM str doc = srtTrace str doc (pure ()) diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index d7235d0167..886f429611 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -394,7 +394,7 @@ cmmdata :: { CmmParse () } : 'section' STRING '{' data_label statics '}' { do lbl <- $4; ss <- sequence $5; - code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) } + code (emitDecl (CmmData (Section (section $2) lbl) (CmmStaticsRaw lbl (concat ss)))) } data_label :: { CmmParse CLabel } : NAME ':' @@ -1175,7 +1175,7 @@ staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () staticClosure pkg cl_label info payload = do dflags <- getDynFlags let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] - code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits + code $ emitRawDataLits (mkCmmDataLabel pkg cl_label) lits foreignCall :: String diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs index 6db9e23ee1..9fd484fdb2 100644 --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -1,4 +1,6 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} module GHC.Cmm.Pipeline ( -- | Converts C-- with an implicit stack and native C-- calls into @@ -27,6 +29,7 @@ import HscTypes import Control.Monad import Outputable import GHC.Platform +import Data.Either (partitionEithers) ----------------------------------------------------------------------------- -- | Top level driver for C-- pipeline @@ -37,14 +40,15 @@ cmmPipeline -- dynamic flags: -dcmm-lint -ddump-cmm-cps -> ModuleSRTInfo -- Info about SRTs generated so far -> CmmGroup -- Input C-- with Procedures - -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C-- + -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C-- cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $ do let dflags = hsc_dflags hsc_env tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog - (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops + let (procs, data_) = partitionEithers tops + (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_ dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (ppr cmms) return (srtInfo, cmms) @@ -54,8 +58,8 @@ cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") dflags = hsc_dflags hsc_env -cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl]) -cpsTop _ p@(CmmData {}) = return (mapEmpty, [p]) +cpsTop :: HscEnv -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)) +cpsTop _ p@(CmmData _ statics) = return (Right (cafAnalData statics, p)) cpsTop hsc_env proc = do ----------- Control-flow optimisations ---------------------------------- @@ -85,7 +89,9 @@ cpsTop hsc_env proc = dump Opt_D_dump_cmm_switch "Post switch plan" g ----------- Proc points ------------------------------------------------- - let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g + let + call_pps :: ProcPointSet -- LabelMap + call_pps = {-# SCC "callProcPoints" #-} callProcPoints g proc_points <- if splitting_proc_points then do @@ -144,7 +150,7 @@ cpsTop hsc_env proc = -- See Note [unreachable blocks] dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g - return (cafEnv, g) + return (Left (cafEnv, g)) where dflags = hsc_dflags hsc_env platform = targetPlatform dflags diff --git a/compiler/GHC/Cmm/Ppr/Decl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs index 2544e6a0d3..e91c4b6277 100644 --- a/compiler/GHC/Cmm/Ppr/Decl.hs +++ b/compiler/GHC/Cmm/Ppr/Decl.hs @@ -54,13 +54,13 @@ import qualified Data.ByteString as BS pprCmms :: (Outputable info, Outputable g) - => [GenCmmGroup CmmStatics info g] -> SDoc + => [GenCmmGroup RawCmmStatics info g] -> SDoc pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) where separator = space $$ text "-------------------" $$ space writeCmms :: (Outputable info, Outputable g) - => DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO () + => DynFlags -> Handle -> [GenCmmGroup RawCmmStatics info g] -> IO () writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms) ----------------------------------------------------------------------------- @@ -72,6 +72,9 @@ instance (Outputable d, Outputable info, Outputable i) instance Outputable CmmStatics where ppr = pprStatics +instance Outputable RawCmmStatics where + ppr = pprRawStatics + instance Outputable CmmStatic where ppr = pprStatic @@ -136,8 +139,14 @@ instance Outputable ForeignHint where -- Strings are printed as C strings, and we print them as I8[], -- following C-- -- + pprStatics :: CmmStatics -> SDoc -pprStatics (Statics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds) +pprStatics (CmmStatics lbl itbl ccs payload) = + ppr lbl <> colon <+> ppr itbl <+> ppr ccs <+> ppr payload +pprStatics (CmmStaticsRaw lbl ds) = pprRawStatics (RawCmmStatics lbl ds) + +pprRawStatics :: RawCmmStatics -> SDoc +pprRawStatics (RawCmmStatics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds) pprStatic :: CmmStatic -> SDoc pprStatic s = case s of diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs index 02d64da936..eda440040d 100644 --- a/compiler/GHC/Cmm/Utils.hs +++ b/compiler/GHC/Cmm/Utils.hs @@ -192,22 +192,22 @@ mkWordCLit :: DynFlags -> Integer -> CmmLit mkWordCLit dflags wd = CmmInt wd (wordWidth dflags) mkByteStringCLit - :: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt) + :: CLabel -> ByteString -> (CmmLit, GenCmmDecl RawCmmStatics info stmt) -- We have to make a top-level decl for the string, -- and return a literal pointing to it mkByteStringCLit lbl bytes - = (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes]) + = (CmmLabel lbl, CmmData (Section sec lbl) $ RawCmmStatics lbl [CmmString bytes]) where -- This can not happen for String literals (as there \NUL is replaced by -- C0 80). However, it can happen with Addr# literals. sec = if 0 `BS.elem` bytes then ReadOnlyData else CString -mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt +mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl RawCmmStatics info stmt -- Build a data-segment data block mkDataLits section lbl lits - = CmmData section (Statics lbl $ map CmmStaticLit lits) + = CmmData section (RawCmmStatics lbl $ map CmmStaticLit lits) -mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl RawCmmStatics info stmt -- Build a read-only data block mkRODataLits lbl lits = mkDataLits section lbl lits diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs index a413820e30..66416c084c 100644 --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -87,7 +87,7 @@ pprTop (CmmProc infos clbl _in_live_regs graph) = (case mapLookup (g_entry graph) infos of Nothing -> empty - Just (Statics info_clbl info_dat) -> + Just (RawCmmStatics info_clbl info_dat) -> pprDataExterns info_dat $$ pprWordArray info_is_in_rodata info_clbl info_dat) $$ (vcat [ @@ -110,21 +110,21 @@ pprTop (CmmProc infos clbl _in_live_regs graph) = -- We only handle (a) arrays of word-sized things and (b) strings. -pprTop (CmmData section (Statics lbl [CmmString str])) = +pprTop (CmmData section (RawCmmStatics lbl [CmmString str])) = pprExternDecl lbl $$ hcat [ pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl, text "[] = ", pprStringInCStyle str, semi ] -pprTop (CmmData section (Statics lbl [CmmUninitialised size])) = +pprTop (CmmData section (RawCmmStatics lbl [CmmUninitialised size])) = pprExternDecl lbl $$ hcat [ pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl, brackets (int size), semi ] -pprTop (CmmData section (Statics lbl lits)) = +pprTop (CmmData section (RawCmmStatics lbl lits)) = pprDataExterns lits $$ pprWordArray (isSecConstant section) lbl lits diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index 83799f6e49..b0738fdb82 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -33,8 +33,7 @@ import DataCon import CostCentre import VarEnv import Module -import Name ( isExternalName, nameOccName, nameModule_maybe ) -import OccName ( occNameFS ) +import Name ( isExternalName, nameModule_maybe ) import BasicTypes ( Arity ) import TysWiredIn ( unboxedUnitDataCon, unitDataConId ) import Literal @@ -268,7 +267,6 @@ coreTopBindToStg dflags this_mod env ccs (NonRec id rhs) bind = StgTopLifted $ StgNonRec id stg_rhs in - assertConsistentCafInfo dflags id bind (ppr bind) -- NB: previously the assertion printed 'rhs' and 'bind' -- as well as 'id', but that led to a black hole -- where printing the assertion error tripped the @@ -296,34 +294,8 @@ coreTopBindToStg dflags this_mod env ccs (Rec pairs) bind = StgTopLifted $ StgRec (zip binders stg_rhss) in - assertConsistentCafInfo dflags (head binders) bind (ppr binders) (env', ccs', bind) --- | CAF consistency issues will generally result in segfaults and are quite --- difficult to debug (see #16846). We enable checking of the --- 'consistentCafInfo' invariant with @-dstg-lint@ to increase the chance that --- we catch these issues. -assertConsistentCafInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a -assertConsistentCafInfo dflags id bind err_doc result - | gopt Opt_DoStgLinting dflags || debugIsOn - , not $ consistentCafInfo id bind = pprPanic "assertConsistentCafInfo" err_doc - | otherwise = result - --- Assertion helper: this checks that the CafInfo on the Id matches --- what CoreToStg has figured out about the binding's SRT. The --- CafInfo will be exact in all cases except when CorePrep has --- floated out a binding, in which case it will be approximate. -consistentCafInfo :: Id -> StgTopBinding -> Bool -consistentCafInfo id bind - = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy ) - safe - where - safe = id_marked_caffy || not binding_is_caffy - exact = id_marked_caffy == binding_is_caffy - id_marked_caffy = mayHaveCafRefs (idCafInfo id) - binding_is_caffy = topStgBindHasCafRefs bind - is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat" - coreToTopStgRhs :: DynFlags -> CollectedCCs diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 14716081d4..59de501fa8 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -30,7 +30,6 @@ import CoreFVs import CoreMonad ( CoreToDo(..) ) import CoreLint ( endPassIO ) import CoreSyn -import CoreSubst import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here import Type import Literal @@ -54,13 +53,11 @@ import ErrUtils import DynFlags import Util import Outputable -import GHC.Platform import FastString import Name ( NamedThing(..), nameSrcSpan ) import SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import Data.Bits import MonadUtils ( mapAccumLM ) -import Data.List ( mapAccumL ) import Control.Monad import CostCentre ( CostCentre, ccFromThisModule ) import qualified Data.Set as S @@ -266,40 +263,6 @@ where x is demanded, in which case we want to finish with x* = f a And then x will actually end up case-bound -Note [CafInfo and floating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What happens when we try to float bindings to the top level? At this -point all the CafInfo is supposed to be correct, and we must make certain -that is true of the new top-level bindings. There are two cases -to consider - -a) The top-level binding is marked asCafRefs. In that case we are - basically fine. The floated bindings had better all be lazy lets, - so they can float to top level, but they'll all have HasCafRefs - (the default) which is safe. - -b) The top-level binding is marked NoCafRefs. This really happens - Example. CoreTidy produces - $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah... - Now CorePrep has to eta-expand to - $fApplicativeSTM = let sat = \xy. retry x y - in D:Alternative sat ...blah... - So what we *want* is - sat [NoCafRefs] = \xy. retry x y - $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah... - - So, gruesomely, we must set the NoCafRefs flag on the sat bindings, - *and* substitute the modified 'sat' into the old RHS. - - It should be the case that 'sat' is itself [NoCafRefs] (a value, no - cafs) else the original top-level binding would not itself have been - marked [NoCafRefs]. The DEBUG check in CoreToStg for - consistentCafInfo will find this. - -This is all very gruesome and horrible. It would be better to figure -out CafInfo later, after CorePrep. We'll do that in due course. -Meanwhile this horrible hack works. - Note [Join points and floating] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Join points can float out of other join points but not out of value bindings: @@ -503,8 +466,6 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs ; return (floats4, rhs4) } where - platform = targetPlatform (cpe_dynFlags env) - arity = idArity bndr -- We must match this arity --------------------- @@ -520,14 +481,12 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs | otherwise = dontFloat floats rhs --------------------- - float_top floats rhs -- Urhgh! See Note [CafInfo and floating] - | mayHaveCafRefs (idCafInfo bndr) - , allLazyTop floats + float_top floats rhs + | allLazyTop floats = return (floats, rhs) - -- So the top-level binding is marked NoCafRefs - | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs - = return (floats', rhs') + | Just floats <- canFloat floats rhs + = return floats | otherwise = dontFloat floats rhs @@ -1321,57 +1280,27 @@ deFloatTop (Floats _ floats) --------------------------------------------------------------------------- -canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs) - -- Note [CafInfo and floating] -canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs +canFloat :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs) +canFloat (Floats ok_to_spec fs) rhs | OkToSpec <- ok_to_spec -- Worth trying - , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs) - = Just (Floats OkToSpec fs', subst_expr subst rhs) + , Just fs' <- go nilOL (fromOL fs) + = Just (Floats OkToSpec fs', rhs) | otherwise = Nothing where - subst_expr = substExpr (text "CorePrep") + go :: OrdList FloatingBind -> [FloatingBind] + -> Maybe (OrdList FloatingBind) - go :: (Subst, OrdList FloatingBind) -> [FloatingBind] - -> Maybe (Subst, OrdList FloatingBind) + go (fbs_out) [] = Just fbs_out - go (subst, fbs_out) [] = Just (subst, fbs_out) + go fbs_out (fb@(FloatLet _) : fbs_in) + = go (fbs_out `snocOL` fb) fbs_in - go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in) - | rhs_ok r - = go (subst', fbs_out `snocOL` new_fb) fbs_in - where - (subst', b') = set_nocaf_bndr subst b - new_fb = FloatLet (NonRec b' (subst_expr subst r)) + go fbs_out (ft@FloatTick{} : fbs_in) + = go (fbs_out `snocOL` ft) fbs_in - go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in) - | all rhs_ok rs - = go (subst', fbs_out `snocOL` new_fb) fbs_in - where - (bs,rs) = unzip prs - (subst', bs') = mapAccumL set_nocaf_bndr subst bs - rs' = map (subst_expr subst') rs - new_fb = FloatLet (Rec (bs' `zip` rs')) + go _ (FloatCase{} : _) = Nothing - go (subst, fbs_out) (ft@FloatTick{} : fbs_in) - = go (subst, fbs_out `snocOL` ft) fbs_in - - go _ _ = Nothing -- Encountered a caffy binding - - ------------ - set_nocaf_bndr subst bndr - = (extendIdSubst subst bndr (Var bndr'), bndr') - where - bndr' = bndr `setIdCafInfo` NoCafRefs - - ------------ - rhs_ok :: CoreExpr -> Bool - -- We can only float to top level from a NoCaf thing if - -- the new binding is static. However it can't mention - -- any non-static things or it would *already* be Caffy - rhs_ok = rhsIsStatic platform (\_ -> False) - (\_nt i -> pprPanic "rhsIsStatic" (integer i)) - -- Integer or Natural literals should not show up wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool wantFloatNested is_rec dmd is_unlifted floats rhs diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 6f3a104925..8da7700e0e 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -23,12 +23,9 @@ import CoreUnfold import CoreFVs import CoreTidy import CoreMonad -import GHC.CoreToStg.Prep -import CoreUtils (rhsIsStatic) import CoreStats (coreBindsStats, CoreStats(..)) import CoreSeq (seqBinds) import CoreLint -import Literal import Rules import PatSyn import ConLike @@ -55,7 +52,6 @@ import DataCon import TyCon import Class import Module -import Packages( isDllName ) import HscTypes import Maybes import UniqSupply @@ -119,7 +115,7 @@ Plan A: mkBootModDetails: omit pragmas, make interfaces small * Drop rules altogether -* Tidy the bindings, to ensure that the Caf and Arity +* Tidy the bindings, to ensure that the Arity information is correct for each top-level binder; the code generator needs it. And to ensure that local names have distinct OccNames in case of object-file splitting @@ -217,7 +213,7 @@ globaliseAndTidyBootId :: Id -> Id -- makes it into a GlobalId -- * unchanged Name (might be Internal or External) -- * unchanged details --- * VanillaIdInfo (makes a conservative assumption about Caf-hood and arity) +-- * VanillaIdInfo (makes a conservative assumption about arity) -- * BootUnfolding (see Note [Inlining and hs-boot files] in GHC.CoreToIface) globaliseAndTidyBootId id = globaliseId id `setIdType` tidyTopType (idType id) @@ -316,8 +312,6 @@ binder * its arity, computed from the number of visible lambdas - * its CAF info, computed from what is free in its RHS - Finally, substitute these new top-level binders consistently throughout, including in unfoldings. We also tidy binders in @@ -359,7 +353,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod = findExternalRules omit_prags binds imp_rules unfold_env } ; (tidy_env, tidy_binds) - <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds + <- tidyTopBinds hsc_env unfold_env tidy_occ_env trimmed_binds -- See Note [Grand plan for static forms] in StaticPtrTable. ; (spt_entries, tidy_binds') <- @@ -1070,22 +1064,13 @@ tidyTopName mod nc_var maybe_ref occ_env id -- * subst_env: A Var->Var mapping that substitutes the new Var for the old tidyTopBinds :: HscEnv - -> Module -> UnfoldEnv -> TidyOccEnv -> CoreProgram -> IO (TidyEnv, CoreProgram) -tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds - = do mkIntegerId <- lookupMkIntegerName dflags hsc_env - mkNaturalId <- lookupMkNaturalName dflags hsc_env - integerSDataCon <- lookupIntegerSDataConName dflags hsc_env - naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env - let cvt_literal nt i = case nt of - LitNumInteger -> Just (cvtLitInteger dflags mkIntegerId integerSDataCon i) - LitNumNatural -> Just (cvtLitNatural dflags mkNaturalId naturalSDataCon i) - _ -> Nothing - result = tidy cvt_literal init_env binds +tidyTopBinds hsc_env unfold_env init_occ_env binds + = do let result = tidy init_env binds seqBinds (snd result) `seq` return result -- This seqBinds avoids a spike in space usage (see #13564) where @@ -1093,35 +1078,28 @@ tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds init_env = (init_occ_env, emptyVarEnv) - tidy cvt_literal = mapAccumL (tidyTopBind dflags this_mod cvt_literal unfold_env) + tidy = mapAccumL (tidyTopBind dflags unfold_env) ------------------------ tidyTopBind :: DynFlags - -> Module - -> (LitNumType -> Integer -> Maybe CoreExpr) -> UnfoldEnv -> TidyEnv -> CoreBind -> (TidyEnv, CoreBind) -tidyTopBind dflags this_mod cvt_literal unfold_env +tidyTopBind dflags unfold_env (occ_env,subst1) (NonRec bndr rhs) = (tidy_env2, NonRec bndr' rhs') where Just (name',show_unfold) = lookupVarEnv unfold_env bndr - caf_info = hasCafRefs dflags this_mod - (subst1, cvt_literal) - (idArity bndr) rhs - (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' - (bndr, rhs) + (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 name' (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr' tidy_env2 = (occ_env, subst2) -tidyTopBind dflags this_mod cvt_literal unfold_env - (occ_env, subst1) (Rec prs) +tidyTopBind dflags unfold_env (occ_env, subst1) (Rec prs) = (tidy_env2, Rec prs') where - prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs) + prs' = [ tidyTopPair dflags show_unfold tidy_env2 name' (id,rhs) | (id,rhs) <- prs, let (name',show_unfold) = expectJust "tidyTopBind" $ lookupVarEnv unfold_env id @@ -1132,21 +1110,11 @@ tidyTopBind dflags this_mod cvt_literal unfold_env bndrs = map fst prs - -- the CafInfo for a recursive group says whether *any* rhs in - -- the group may refer indirectly to a CAF (because then, they all do). - caf_info - | or [ mayHaveCafRefs (hasCafRefs dflags this_mod - (subst1, cvt_literal) - (idArity bndr) rhs) - | (bndr,rhs) <- prs ] = MayHaveCafRefs - | otherwise = NoCafRefs - ----------------------------------------------------------- tidyTopPair :: DynFlags -> Bool -- show unfolding -> TidyEnv -- The TidyEnv is used to tidy the IdInfo -- It is knot-tied: don't look at it! - -> CafInfo -> Name -- New name -> (Id, CoreExpr) -- Binder and RHS before tidying -> (Id, CoreExpr) @@ -1156,7 +1124,7 @@ tidyTopPair :: DynFlags -- group, a variable late in the group might be mentioned -- in the IdInfo of one early in the group -tidyTopPair dflags show_unfold rhs_tidy_env caf_info name' (bndr, rhs) +tidyTopPair dflags show_unfold rhs_tidy_env name' (bndr, rhs) = (bndr1, rhs1) where bndr1 = mkGlobalId details name' ty' idinfo' @@ -1164,28 +1132,22 @@ tidyTopPair dflags show_unfold rhs_tidy_env caf_info name' (bndr, rhs) ty' = tidyTopType (idType bndr) rhs1 = tidyExpr rhs_tidy_env rhs idinfo' = tidyTopIdInfo dflags rhs_tidy_env name' rhs rhs1 (idInfo bndr) - show_unfold caf_info + show_unfold -- tidyTopIdInfo creates the final IdInfo for top-level --- binders. There are two delicate pieces: +-- binders. The delicate piece: -- -- * Arity. After CoreTidy, this arity must not change any more. -- Indeed, CorePrep must eta expand where necessary to make -- the manifest arity equal to the claimed arity. -- --- * CAF info. This must also remain valid through to code generation. --- We add the info here so that it propagates to all --- occurrences of the binders in RHSs, and hence to occurrences in --- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. --- CoreToStg makes use of this when constructing SRTs. tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr - -> IdInfo -> Bool -> CafInfo -> IdInfo -tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info + -> IdInfo -> Bool -> IdInfo +tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold | not is_external -- For internal Ids (not externally visible) = vanillaIdInfo -- we only need enough info for code generation -- Arity and strictness info are enough; -- c.f. CoreTidy.tidyLetBndr - `setCafInfo` caf_info `setArityInfo` arity `setStrictnessInfo` final_sig `setUnfoldingInfo` minimal_unfold_info -- See note [Preserve evaluatedness] @@ -1193,7 +1155,6 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_ | otherwise -- Externally-visible Ids get the whole lot = vanillaIdInfo - `setCafInfo` caf_info `setArityInfo` arity `setStrictnessInfo` final_sig `setOccInfo` robust_occ_info @@ -1257,137 +1218,6 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_ {- ************************************************************************ * * - Figuring out CafInfo for an expression -* * -************************************************************************ - -hasCafRefs decides whether a top-level closure can point into the dynamic heap. -We mark such things as `MayHaveCafRefs' because this information is -used to decide whether a particular closure needs to be referenced -in an SRT or not. - -There are two reasons for setting MayHaveCafRefs: - a) The RHS is a CAF: a top-level updatable thunk. - b) The RHS refers to something that MayHaveCafRefs - -Possible improvement: In an effort to keep the number of CAFs (and -hence the size of the SRTs) down, we could also look at the expression and -decide whether it requires a small bounded amount of heap, so we can ignore -it as a CAF. In these cases however, we would need to use an additional -CAF list to keep track of non-collectable CAFs. - -Note [Disgusting computation of CafRefs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We compute hasCafRefs here, because IdInfo is supposed to be finalised -after tidying. But CorePrep does some transformations that affect CAF-hood. -So we have to *predict* the result here, which is revolting. - -In particular CorePrep expands Integer and Natural literals. So in the -prediction code here we resort to applying the same expansion (cvt_literal). -There are also numerous other ways in which we can introduce inconsistencies -between CorePrep and GHC.Iface.Tidy. See Note [CAFfyness inconsistencies due to -eta expansion in TidyPgm] for one such example. - -Ugh! What ugliness we hath wrought. - - -Note [CAFfyness inconsistencies due to eta expansion in TidyPgm] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Eta expansion during CorePrep can have non-obvious negative consequences on -the CAFfyness computation done by tidying (see Note [Disgusting computation of -CafRefs] in GHC.Iface.Tidy). This late expansion happens/happened for a few -reasons: - - * CorePrep previously eta expanded unsaturated primop applications, as - described in Note [Primop wrappers]). - - * CorePrep still does eta expand unsaturated data constructor applications. - -In particular, consider the program: - - data Ty = Ty (RealWorld# -> (# RealWorld#, Int #)) - - -- Is this CAFfy? - x :: STM Int - x = Ty (retry# @Int) - -Consider whether x is CAFfy. One might be tempted to answer "no". -Afterall, f obviously has no CAF references and the application (retry# -@Int) is essentially just a variable reference at runtime. - -However, when CorePrep expanded the unsaturated application of 'retry#' -it would rewrite this to - - x = \u [] - let sat = retry# @Int - in Ty sat - -This is now a CAF. Failing to handle this properly was the cause of -#16846. We fixed this by eliminating the need to eta expand primops, as -described in Note [Primop wrappers]), However we have not yet done the same for -data constructor applications. - --} - -type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr) - -- The env finds the Caf-ness of the Id - -- The LitNumType -> Integer -> CoreExpr is the desugaring functions for - -- Integer and Natural literals - -- See Note [Disgusting computation of CafRefs] - -hasCafRefs :: DynFlags -> Module - -> CafRefEnv -> Arity -> CoreExpr - -> CafInfo -hasCafRefs dflags this_mod (subst, cvt_literal) arity expr - | is_caf || mentions_cafs = MayHaveCafRefs - | otherwise = NoCafRefs - where - mentions_cafs = cafRefsE expr - is_dynamic_name = isDllName dflags this_mod - is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name - cvt_literal expr) - - -- NB. we pass in the arity of the expression, which is expected - -- to be calculated by exprArity. This is because exprArity - -- knows how much eta expansion is going to be done by - -- CorePrep later on, and we don't want to duplicate that - -- knowledge in rhsIsStatic below. - - cafRefsE :: Expr a -> Bool - cafRefsE (Var id) = cafRefsV id - cafRefsE (Lit lit) = cafRefsL lit - cafRefsE (App f a) = cafRefsE f || cafRefsE a - cafRefsE (Lam _ e) = cafRefsE e - cafRefsE (Let b e) = cafRefsEs (rhssOfBind b) || cafRefsE e - cafRefsE (Case e _ _ alts) = cafRefsE e || cafRefsEs (rhssOfAlts alts) - cafRefsE (Tick _n e) = cafRefsE e - cafRefsE (Cast e _co) = cafRefsE e - cafRefsE (Type _) = False - cafRefsE (Coercion _) = False - - cafRefsEs :: [Expr a] -> Bool - cafRefsEs [] = False - cafRefsEs (e:es) = cafRefsE e || cafRefsEs es - - cafRefsL :: Literal -> Bool - -- Don't forget that mk_integer id might have Caf refs! - -- We first need to convert the Integer into its final form, to - -- see whether mkInteger is used. Same for LitNatural. - cafRefsL (LitNumber nt i _) = case cvt_literal nt i of - Just e -> cafRefsE e - Nothing -> False - cafRefsL _ = False - - cafRefsV :: Id -> Bool - cafRefsV id - | not (isLocalId id) = mayHaveCafRefs (idCafInfo id) - | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id') - | otherwise = False - - -{- -************************************************************************ -* * Old, dead, type-trimming code * * ************************************************************************ diff --git a/compiler/GHC/Iface/Utils.hs b/compiler/GHC/Iface/Utils.hs index d410a2c461..df3671fad1 100644 --- a/compiler/GHC/Iface/Utils.hs +++ b/compiler/GHC/Iface/Utils.hs @@ -160,17 +160,38 @@ mkPartialIface hsc_env mod_details -- | Fully instantiate a interface -- Adds fingerprints and potentially code generator produced information. -mkFullIface :: HscEnv -> PartialModIface -> IO ModIface -mkFullIface hsc_env partial_iface = do +mkFullIface :: HscEnv -> PartialModIface -> Maybe NameSet -> IO ModIface +mkFullIface hsc_env partial_iface mb_non_cafs = do + let decls + | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env) + = mi_decls partial_iface + | otherwise + = updateDeclCafInfos (mi_decls partial_iface) mb_non_cafs + full_iface <- {-# SCC "addFingerprints" #-} - addFingerprints hsc_env partial_iface + addFingerprints hsc_env partial_iface{ mi_decls = decls } -- Debug printing dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface) return full_iface +updateDeclCafInfos :: [IfaceDecl] -> Maybe NameSet -> [IfaceDecl] +updateDeclCafInfos decls Nothing = decls +updateDeclCafInfos decls (Just non_cafs) = map update_decl decls + where + update_decl decl + | IfaceId nm ty details id_info <- decl + , elemNameSet nm non_cafs + = IfaceId nm ty details $ + case id_info of + NoInfo -> HasInfo [HsNoCafRefs] + HasInfo infos -> HasInfo (HsNoCafRefs : infos) + + | otherwise + = decl + -- | Make an interface from the results of typechecking only. Useful -- for non-optimising compilation, or where we aren't generating any -- object code at all ('HscNothing'). @@ -221,7 +242,7 @@ mkIfaceTc hsc_env safe_mode mod_details doc_hdr' doc_map arg_map mod_details - mkFullIface hsc_env partial_iface + mkFullIface hsc_env partial_iface Nothing mkIface_ :: HscEnv -> Module -> HscSource -> Bool -> Dependencies -> GlobalRdrEnv diff --git a/compiler/GHC/Stg/DepAnal.hs b/compiler/GHC/Stg/DepAnal.hs new file mode 100644 index 0000000000..a042902180 --- /dev/null +++ b/compiler/GHC/Stg/DepAnal.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE CPP #-} + +module GHC.Stg.DepAnal (depSortStgPgm) where + +import GhcPrelude + +import GHC.Stg.Syntax +import Id +import Name (Name) +import NameEnv +import Outputable +import UniqSet (nonDetEltsUniqSet) +import VarSet + +import Data.Graph (SCC (..)) + +-------------------------------------------------------------------------------- +-- * Dependency analysis + +-- | Set of bound variables +type BVs = VarSet + +-- | Set of free variables +type FVs = VarSet + +-- | Dependency analysis on STG terms. +-- +-- Dependencies of a binding are just free variables in the binding. This +-- includes imported ids and ids in the current module. For recursive groups we +-- just return one set of free variables which is just the union of dependencies +-- of all bindings in the group. +-- +-- Implementation: pass bound variables (BVs) to recursive calls, get free +-- variables (FVs) back. +-- +annTopBindingsDeps :: [StgTopBinding] -> [(StgTopBinding, FVs)] +annTopBindingsDeps bs = zip bs (map top_bind bs) + where + top_bind :: StgTopBinding -> FVs + + top_bind StgTopStringLit{} = + emptyVarSet + + top_bind (StgTopLifted bs) = + binding emptyVarSet bs + + binding :: BVs -> StgBinding -> FVs + + binding bounds (StgNonRec _ r) = + rhs bounds r + + binding bounds (StgRec bndrs) = + unionVarSets $ + map (bind_non_rec (extendVarSetList bounds (map fst bndrs))) bndrs + + bind_non_rec :: BVs -> (Id, StgRhs) -> FVs + bind_non_rec bounds (_, r) = + rhs bounds r + + rhs :: BVs -> StgRhs -> FVs + + rhs bounds (StgRhsClosure _ _ _ as e) = + expr (extendVarSetList bounds as) e + + rhs bounds (StgRhsCon _ _ as) = + args bounds as + + var :: BVs -> Var -> FVs + var bounds v + | not (elemVarSet v bounds) + = unitVarSet v + | otherwise + = emptyVarSet + + arg :: BVs -> StgArg -> FVs + arg bounds (StgVarArg v) = var bounds v + arg _ StgLitArg{} = emptyVarSet + + args :: BVs -> [StgArg] -> FVs + args bounds as = unionVarSets (map (arg bounds) as) + + expr :: BVs -> StgExpr -> FVs + + expr bounds (StgApp f as) = + var bounds f `unionVarSet` args bounds as + + expr _ StgLit{} = + emptyVarSet + + expr bounds (StgConApp _ as _) = + args bounds as + + expr bounds (StgOpApp _ as _) = + args bounds as + + expr _ lam@StgLam{} = + pprPanic "annTopBindingsDeps" (text "Found lambda:" $$ ppr lam) + + expr bounds (StgCase scrut scrut_bndr _ as) = + expr bounds scrut `unionVarSet` + alts (extendVarSet bounds scrut_bndr) as + + expr bounds (StgLet _ bs e) = + binding bounds bs `unionVarSet` + expr (extendVarSetList bounds (bindersOf bs)) e + + expr bounds (StgLetNoEscape _ bs e) = + binding bounds bs `unionVarSet` + expr (extendVarSetList bounds (bindersOf bs)) e + + expr bounds (StgTick _ e) = + expr bounds e + + alts :: BVs -> [StgAlt] -> FVs + alts bounds = unionVarSets . map (alt bounds) + + alt :: BVs -> StgAlt -> FVs + alt bounds (_, bndrs, e) = + expr (extendVarSetList bounds bndrs) e + +-------------------------------------------------------------------------------- +-- * Dependency sorting + +-- | Dependency sort a STG program so that dependencies come before uses. +depSortStgPgm :: [StgTopBinding] -> [StgTopBinding] +depSortStgPgm = map fst . depSort . annTopBindingsDeps + +-- | Sort free-variable-annotated STG bindings so that dependencies come before +-- uses. +depSort :: [(StgTopBinding, FVs)] -> [(StgTopBinding, FVs)] +depSort = concatMap get_binds . depAnal defs uses + where + uses, defs :: (StgTopBinding, FVs) -> [Name] + + -- TODO (osa): I'm unhappy about two things in this code: + -- + -- * Why do we need Name instead of Id for uses and dependencies? + -- * Why do we need a [Name] instead of `Set Name`? Surely depAnal + -- doesn't need any ordering. + + uses (StgTopStringLit{}, _) = [] + uses (StgTopLifted{}, fvs) = map idName (nonDetEltsUniqSet fvs) + + defs (bind, _) = map idName (bindersOfTop bind) + + get_binds (AcyclicSCC bind) = + [bind] + get_binds (CyclicSCC binds) = + pprPanic "depSortStgBinds" (text "Found cyclic SCC:" $$ ppr binds) diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index e7044a89e0..d2a0b8980e 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -227,25 +227,6 @@ lintAlt (DataAlt _, bndrs, rhs) = do {- ************************************************************************ * * -Utilities -* * -************************************************************************ --} - -bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id] -bindersOf (StgNonRec binder _) = [binder] -bindersOf (StgRec pairs) = [binder | (binder, _) <- pairs] - -bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id] -bindersOfTop (StgTopLifted bind) = bindersOf bind -bindersOfTop (StgTopStringLit binder _) = [binder] - -bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id] -bindersOfTopBinds = foldr ((++) . bindersOfTop) [] - -{- -************************************************************************ -* * The Lint monad * * ************************************************************************ diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs index 13b403fc53..87690b90eb 100644 --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -19,6 +19,7 @@ import GHC.Stg.Syntax import GHC.Stg.Lint ( lintStgTopBindings ) import GHC.Stg.Stats ( showStgStats ) +import GHC.Stg.DepAnal ( depSortStgPgm ) import GHC.Stg.Unarise ( unarise ) import GHC.Stg.CSE ( stgCse ) import GHC.Stg.Lift ( stgLiftLams ) @@ -56,9 +57,18 @@ stg2stg dflags this_mod binds ; binds' <- runStgM 'g' $ foldM do_stg_pass binds (getStgToDo dflags) - ; dump_when Opt_D_dump_stg_final "Final STG:" binds' - - ; return binds' + -- Dependency sort the program as last thing. The program needs to be + -- in dependency order for the SRT algorithm to work (see + -- CmmBuildInfoTables, which also includes a detailed description of + -- the algorithm), and we don't guarantee that the program is already + -- sorted at this point. #16192 is for simplifier not preserving + -- dependency order. We also don't guarantee that StgLiftLams will + -- preserve the order or only create minimal recursive groups, so a + -- sorting pass is necessary. + ; let binds_sorted = depSortStgPgm binds' + ; dump_when Opt_D_dump_stg_final "Final STG:" binds_sorted + + ; return binds_sorted } where diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index 256be34ce8..5c57722a42 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -48,11 +48,12 @@ module GHC.Stg.Syntax ( StgOp(..), -- utils - topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, + stgRhsArity, isDllConApp, stgArgType, stripStgTicksTop, stripStgTicksTopE, stgCaseBndrInScope, + bindersOf, bindersOfTop, bindersOfTopBinds, pprStgBinding, pprGenStgTopBindings, pprStgTopBindings ) where @@ -70,7 +71,6 @@ import DataCon import DynFlags import ForeignCall ( ForeignCall ) import Id -import IdInfo ( mayHaveCafRefs ) import VarSet import Literal ( Literal, literalType ) import Module ( Module ) @@ -475,82 +475,6 @@ stgRhsArity (StgRhsClosure _ _ _ bndrs _) -- The arity never includes type parameters, but they should have gone by now stgRhsArity (StgRhsCon _ _ _) = 0 --- Note [CAF consistency] --- ~~~~~~~~~~~~~~~~~~~~~~ --- --- `topStgBindHasCafRefs` is only used by an assert (`consistentCafInfo` in --- `CoreToStg`) to make sure CAF-ness predicted by `GHC.Iface.Tidy` is consistent with --- reality. --- --- Specifically, if the RHS mentions any Id that itself is marked --- `MayHaveCafRefs`; or if the binding is a top-level updateable thunk; then the --- `Id` for the binding should be marked `MayHaveCafRefs`. The potential trouble --- is that `GHC.Iface.Tidy` computed the CAF info on the `Id` but some transformations --- have taken place since then. - -topStgBindHasCafRefs :: GenStgTopBinding pass -> Bool -topStgBindHasCafRefs (StgTopLifted (StgNonRec _ rhs)) - = topRhsHasCafRefs rhs -topStgBindHasCafRefs (StgTopLifted (StgRec binds)) - = any topRhsHasCafRefs (map snd binds) -topStgBindHasCafRefs StgTopStringLit{} - = False - -topRhsHasCafRefs :: GenStgRhs pass -> Bool -topRhsHasCafRefs (StgRhsClosure _ _ upd _ body) - = -- See Note [CAF consistency] - isUpdatable upd || exprHasCafRefs body -topRhsHasCafRefs (StgRhsCon _ _ args) - = any stgArgHasCafRefs args - -exprHasCafRefs :: GenStgExpr pass -> Bool -exprHasCafRefs (StgApp f args) - = stgIdHasCafRefs f || any stgArgHasCafRefs args -exprHasCafRefs StgLit{} - = False -exprHasCafRefs (StgConApp _ args _) - = any stgArgHasCafRefs args -exprHasCafRefs (StgOpApp _ args _) - = any stgArgHasCafRefs args -exprHasCafRefs (StgLam _ body) - = exprHasCafRefs body -exprHasCafRefs (StgCase scrt _ _ alts) - = exprHasCafRefs scrt || any altHasCafRefs alts -exprHasCafRefs (StgLet _ bind body) - = bindHasCafRefs bind || exprHasCafRefs body -exprHasCafRefs (StgLetNoEscape _ bind body) - = bindHasCafRefs bind || exprHasCafRefs body -exprHasCafRefs (StgTick _ expr) - = exprHasCafRefs expr - -bindHasCafRefs :: GenStgBinding pass -> Bool -bindHasCafRefs (StgNonRec _ rhs) - = rhsHasCafRefs rhs -bindHasCafRefs (StgRec binds) - = any rhsHasCafRefs (map snd binds) - -rhsHasCafRefs :: GenStgRhs pass -> Bool -rhsHasCafRefs (StgRhsClosure _ _ _ _ body) - = exprHasCafRefs body -rhsHasCafRefs (StgRhsCon _ _ args) - = any stgArgHasCafRefs args - -altHasCafRefs :: GenStgAlt pass -> Bool -altHasCafRefs (_, _, rhs) = exprHasCafRefs rhs - -stgArgHasCafRefs :: StgArg -> Bool -stgArgHasCafRefs (StgVarArg id) - = stgIdHasCafRefs id -stgArgHasCafRefs _ - = False - -stgIdHasCafRefs :: Id -> Bool -stgIdHasCafRefs id = - -- We are looking for occurrences of an Id that is bound at top level, and may - -- have CAF refs. At this point (after GHC.Iface.Tidy) top-level Ids (whether - -- imported or defined in this module) are GlobalIds, so the test is easy. - isGlobalId id && mayHaveCafRefs (idCafInfo id) - {- ************************************************************************ * * @@ -682,6 +606,25 @@ data StgOp {- ************************************************************************ * * +Utilities +* * +************************************************************************ +-} + +bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id] +bindersOf (StgNonRec binder _) = [binder] +bindersOf (StgRec pairs) = [binder | (binder, _) <- pairs] + +bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id] +bindersOfTop (StgTopLifted bind) = bindersOf bind +bindersOfTop (StgTopStringLit binder _) = [binder] + +bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id] +bindersOfTopBinds = foldr ((++) . bindersOfTop) [] + +{- +************************************************************************ +* * Pretty-printing * * ************************************************************************ diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index f489ce6456..d83e8fbc7b 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -27,7 +27,6 @@ import GHC.StgToCmm.Hpc import GHC.StgToCmm.Ticky import GHC.Cmm -import GHC.Cmm.Utils import GHC.Cmm.CLabel import GHC.Stg.Syntax @@ -178,7 +177,7 @@ mkModuleInit cost_centre_info this_mod hpc_info cgEnumerationTyCon :: TyCon -> FCode () cgEnumerationTyCon tycon = do dflags <- getDynFlags - emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) + emitRawRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) (tagForCon dflags con) | con <- tyConDataCons tycon] diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index a78ab5cb41..977fa4649e 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -87,15 +87,11 @@ cgTopRhsClosure dflags rec id ccs upd_flag args body = -- hole detection from working in that case. Test -- concurrent/should_run/4030 fails, for instance. -- - gen_code dflags _ closure_label + gen_code _ _ closure_label | StgApp f [] <- body, null args, isNonRec rec = do cg_info <- getCgIdInfo f - let closure_rep = mkStaticClosureFields dflags - indStaticInfoTable ccs MayHaveCafRefs - [unLit (idInfoToAmode cg_info)] - emitDataLits closure_label closure_rep - return () + emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)] gen_code dflags lf_info _closure_label = do { let name = idName id diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs index 2bbeabace6..7d86620708 100644 --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -104,17 +104,8 @@ cgTopRhsCon dflags id con args = -- NB2: all the amodes should be Lits! -- TODO (osa): Why? - ; let closure_rep = mkStaticClosureFields - dflags - info_tbl - dontCareCCS -- Because it's static data - caffy -- Has CAF refs - payload - -- BUILD THE OBJECT - ; emitDataLits closure_label closure_rep - - ; return () } + ; emitDataCon closure_label info_tbl dontCareCCS payload } --------------------------------------------------------------- diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs index 0ac573314a..085d47219f 100644 --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -196,7 +196,9 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload | otherwise = [] static_link_field - | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl + | is_caf + = [mkIntCLit dflags 0] + | staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl = [static_link_value] | otherwise = [] diff --git a/compiler/GHC/StgToCmm/Hpc.hs b/compiler/GHC/StgToCmm/Hpc.hs index a3f4112206..219285efbe 100644 --- a/compiler/GHC/StgToCmm/Hpc.hs +++ b/compiler/GHC/StgToCmm/Hpc.hs @@ -41,7 +41,7 @@ initHpc _ (NoHpcInfo {}) initHpc this_mod (HpcInfo tickCount _hashNo) = do dflags <- getDynFlags when (gopt Opt_Hpc dflags) $ - do emitDataLits (mkHpcTicksLabel this_mod) + emitRawDataLits (mkHpcTicksLabel this_mod) [ (CmmInt 0 W64) | _ <- take tickCount [0 :: Int ..] ] diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs index cf5ce5acfb..581e8279dc 100644 --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -231,7 +231,7 @@ emitCostCentreDecl cc = do is_caf, -- StgInt is_caf zero dflags -- struct _CostCentre *link ] - ; emitDataLits (mkCCLabel cc) lits + ; emitRawDataLits (mkCCLabel cc) lits } emitCostCentreStackDecl :: CostCentreStack -> FCode () @@ -247,7 +247,7 @@ emitCostCentreStackDecl ccs -- layouts of structs containing long-longs, simply -- pad out the struct with zero words until we hit the -- size of the overall struct (which we get via DerivedConstants.h) - emitDataLits (mkCCSLabel ccs) (mk_lits cc) + emitRawDataLits (mkCCSLabel ccs) (mk_lits cc) Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) zero :: DynFlags -> CmmLit diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs index 6e2e2d3a6b..fbb121dae6 100644 --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -240,7 +240,7 @@ emitTickyCounter cloType name args ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args - ; emitDataLits ctr_lbl + ; emitRawDataLits ctr_lbl -- Must match layout of includes/rts/Ticky.h's StgEntCounter -- -- krc: note that all the fields are I32 now; some were I16 diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index 7a784ea85c..373beeed07 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -10,8 +10,9 @@ module GHC.StgToCmm.Utils ( cgLit, mkSimpleLit, - emitDataLits, mkDataLits, - emitRODataLits, mkRODataLits, + emitRawDataLits, mkRawDataLits, + emitRawRODataLits, mkRawRODataLits, + emitDataCon, emitRtsCall, emitRtsCallWithResult, emitRtsCallGen, assignTemp, newTemp, @@ -36,7 +37,7 @@ module GHC.StgToCmm.Utils ( cmmUntag, cmmIsTagged, addToMem, addToMemE, addToMemLblE, addToMemLbl, - mkWordCLit, + mkWordCLit, mkByteStringCLit, newStringCLit, newByteStringCLit, blankWord, @@ -57,7 +58,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.Graph as CmmGraph import GHC.Platform.Regs import GHC.Cmm.CLabel -import GHC.Cmm.Utils +import GHC.Cmm.Utils hiding (mkDataLits, mkRODataLits, mkByteStringCLit) import GHC.Cmm.Switch import GHC.StgToCmm.CgUtils @@ -76,9 +77,11 @@ import DynFlags import FastString import Outputable import GHC.Types.RepType +import CostCentre import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString as BS import qualified Data.Map as M import Data.Char import Data.List @@ -270,13 +273,43 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load) -- ------------------------------------------------------------------------- -emitDataLits :: CLabel -> [CmmLit] -> FCode () +mkRawDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt +-- Build a data-segment data block +mkRawDataLits section lbl lits + = CmmData section (CmmStaticsRaw lbl (map CmmStaticLit lits)) + +mkRawRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt +-- Build a read-only data block +mkRawRODataLits lbl lits + = mkRawDataLits section lbl lits + where + section | any needsRelocation lits = Section RelocatableReadOnlyData lbl + | otherwise = Section ReadOnlyData lbl + needsRelocation (CmmLabel _) = True + needsRelocation (CmmLabelOff _ _) = True + needsRelocation _ = False + +mkByteStringCLit + :: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt) +-- We have to make a top-level decl for the string, +-- and return a literal pointing to it +mkByteStringCLit lbl bytes + = (CmmLabel lbl, CmmData (Section sec lbl) (CmmStaticsRaw lbl [CmmString bytes])) + where + -- This can not happen for String literals (as there \NUL is replaced by + -- C0 80). However, it can happen with Addr# literals. + sec = if 0 `BS.elem` bytes then ReadOnlyData else CString + +emitRawDataLits :: CLabel -> [CmmLit] -> FCode () -- Emit a data-segment data block -emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits) +emitRawDataLits lbl lits = emitDecl (mkRawDataLits (Section Data lbl) lbl lits) -emitRODataLits :: CLabel -> [CmmLit] -> FCode () +emitRawRODataLits :: CLabel -> [CmmLit] -> FCode () -- Emit a read-only data block -emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits) +emitRawRODataLits lbl lits = emitDecl (mkRawRODataLits lbl lits) + +emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode () +emitDataCon lbl itbl ccs payload = emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload)) newStringCLit :: String -> FCode CmmLit -- Make a global definition for the string, |