Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Glasgow Haskell Compiler
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
0
Merge Requests
0
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Packages & Registries
Packages & Registries
Package Registry
Container Registry
Analytics
Analytics
CI / CD
Code Review
Insights
Issue
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
d127a697
Commit
d127a697
authored
Sep 04, 2013
by
parcs
Browse files
Options
Browse Files
Download
Plain Diff
Merge remote-tracking branch 'origin/master' into ghc-parmake-gsoc
parents
a2e338f3
32ade417
Changes
78
Hide whitespace changes
Inline
Side-by-side
Showing
78 changed files
with
1122 additions
and
783 deletions
+1122
-783
aclocal.m4
aclocal.m4
+13
-1
boot
boot
+1
-1
compiler/basicTypes/MkId.lhs
compiler/basicTypes/MkId.lhs
+23
-10
compiler/cmm/CmmNode.hs
compiler/cmm/CmmNode.hs
+76
-5
compiler/cmm/CmmSink.hs
compiler/cmm/CmmSink.hs
+76
-44
compiler/codeGen/StgCmm.hs
compiler/codeGen/StgCmm.hs
+1
-1
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmBind.hs
+2
-1
compiler/codeGen/StgCmmCon.hs
compiler/codeGen/StgCmmCon.hs
+1
-1
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmExpr.hs
+1
-1
compiler/codeGen/StgCmmForeign.hs
compiler/codeGen/StgCmmForeign.hs
+1
-1
compiler/codeGen/StgCmmHeap.hs
compiler/codeGen/StgCmmHeap.hs
+1
-1
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmLayout.hs
+1
-1
compiler/codeGen/StgCmmPrim.hs
compiler/codeGen/StgCmmPrim.hs
+1
-1
compiler/coreSyn/CoreLint.lhs
compiler/coreSyn/CoreLint.lhs
+18
-5
compiler/coreSyn/CorePrep.lhs
compiler/coreSyn/CorePrep.lhs
+1
-1
compiler/coreSyn/CoreSyn.lhs
compiler/coreSyn/CoreSyn.lhs
+22
-9
compiler/coreSyn/CoreUnfold.lhs
compiler/coreSyn/CoreUnfold.lhs
+1
-1
compiler/coreSyn/PprCore.lhs
compiler/coreSyn/PprCore.lhs
+0
-1
compiler/deSugar/Desugar.lhs
compiler/deSugar/Desugar.lhs
+15
-14
compiler/iface/IfaceSyn.lhs
compiler/iface/IfaceSyn.lhs
+3
-12
compiler/iface/MkIface.lhs
compiler/iface/MkIface.lhs
+0
-1
compiler/iface/TcIface.lhs
compiler/iface/TcIface.lhs
+10
-36
compiler/main/HscMain.hs
compiler/main/HscMain.hs
+19
-29
compiler/main/TidyPgm.lhs
compiler/main/TidyPgm.lhs
+1
-1
compiler/prelude/primops.txt.pp
compiler/prelude/primops.txt.pp
+23
-0
compiler/rename/RnExpr.lhs
compiler/rename/RnExpr.lhs
+4
-2
compiler/rename/RnPat.lhs
compiler/rename/RnPat.lhs
+3
-2
compiler/rename/RnTypes.lhs
compiler/rename/RnTypes.lhs
+3
-1
compiler/simplCore/CoreMonad.lhs
compiler/simplCore/CoreMonad.lhs
+69
-15
compiler/simplCore/OccurAnal.lhs
compiler/simplCore/OccurAnal.lhs
+37
-33
compiler/simplCore/SimplCore.lhs
compiler/simplCore/SimplCore.lhs
+8
-7
compiler/specialise/Specialise.lhs
compiler/specialise/Specialise.lhs
+3
-3
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcBinds.lhs
+2
-3
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcInstDcls.lhs
+2
-2
compiler/typecheck/TcMType.lhs
compiler/typecheck/TcMType.lhs
+2
-4
compiler/typecheck/TcSMonad.lhs
compiler/typecheck/TcSMonad.lhs
+1
-0
compiler/typecheck/TcTyClsDecls.lhs
compiler/typecheck/TcTyClsDecls.lhs
+9
-7
compiler/typecheck/TcTyDecls.lhs
compiler/typecheck/TcTyDecls.lhs
+19
-3
compiler/typecheck/TcType.lhs
compiler/typecheck/TcType.lhs
+1
-1
compiler/typecheck/TcValidity.lhs
compiler/typecheck/TcValidity.lhs
+13
-10
compiler/types/Coercion.lhs
compiler/types/Coercion.lhs
+2
-3
compiler/types/Type.lhs
compiler/types/Type.lhs
+1
-9
compiler/types/TypeRep.lhs
compiler/types/TypeRep.lhs
+16
-2
docs/users_guide/7.8.1-notes.xml
docs/users_guide/7.8.1-notes.xml
+18
-1
docs/users_guide/flags.xml
docs/users_guide/flags.xml
+125
-108
docs/users_guide/glasgow_exts.xml
docs/users_guide/glasgow_exts.xml
+134
-104
driver/ghc-usage.txt
driver/ghc-usage.txt
+3
-0
includes/rts/Linker.h
includes/rts/Linker.h
+2
-0
includes/stg/MiscClosures.h
includes/stg/MiscClosures.h
+3
-0
includes/stg/SMP.h
includes/stg/SMP.h
+16
-11
libraries/haskeline
libraries/haskeline
+1
-1
libraries/time
libraries/time
+1
-1
mk/config.mk.in
mk/config.mk.in
+1
-0
mk/install.mk.in
mk/install.mk.in
+1
-1
mk/validate-settings.mk
mk/validate-settings.mk
+9
-0
packages
packages
+48
-46
rts/Capability.c
rts/Capability.c
+43
-40
rts/Capability.h
rts/Capability.h
+4
-4
rts/CheckUnload.c
rts/CheckUnload.c
+7
-6
rts/Linker.c
rts/Linker.c
+3
-2
rts/PrimOps.cmm
rts/PrimOps.cmm
+58
-2
rts/Profiling.c
rts/Profiling.c
+1
-1
rts/Proftimer.c
rts/Proftimer.c
+1
-1
rts/RetainerProfile.c
rts/RetainerProfile.c
+1
-1
rts/Schedule.c
rts/Schedule.c
+35
-52
rts/Stats.c
rts/Stats.c
+17
-17
rts/Task.c
rts/Task.c
+0
-28
rts/Task.h
rts/Task.h
+0
-5
rts/Threads.c
rts/Threads.c
+1
-1
rts/Timer.c
rts/Timer.c
+1
-1
rts/sm/Compact.c
rts/sm/Compact.c
+1
-1
rts/sm/GC.c
rts/sm/GC.c
+23
-29
rts/sm/Sanity.c
rts/sm/Sanity.c
+7
-7
rts/sm/Storage.c
rts/sm/Storage.c
+5
-5
rules/shell-wrapper.mk
rules/shell-wrapper.mk
+1
-1
sync-all
sync-all
+2
-1
utils/hp2ps/Axes.c
utils/hp2ps/Axes.c
+8
-4
validate
validate
+35
-15
No files found.
aclocal.m4
View file @
d127a697
...
...
@@ -1184,6 +1184,7 @@ AC_SUBST(GccLT46)
dnl Check to see if the C compiler is clang or llvm-gcc
dnl
GccIsClang=NO
AC_DEFUN([FP_CC_LLVM_BACKEND],
[AC_REQUIRE([AC_PROG_CC])
AC_MSG_CHECKING([whether C compiler is clang])
...
...
@@ -1191,6 +1192,7 @@ $CC -x c /dev/null -dM -E > conftest.txt 2>&1
if grep "__clang__" conftest.txt >/dev/null 2>&1; then
AC_SUBST([CC_CLANG_BACKEND], [1])
AC_SUBST([CC_LLVM_BACKEND], [1])
GccIsClang=YES
AC_MSG_RESULT([yes])
else
AC_MSG_RESULT([no])
...
...
@@ -1205,6 +1207,7 @@ else
AC_MSG_RESULT([no])
fi
fi
AC_SUBST(GccIsClang)
rm -f conftest.txt
])
...
...
@@ -2049,7 +2052,16 @@ AC_DEFUN([FIND_GCC],[
then
$1="$CC"
else
FP_ARG_WITH_PATH_GNU_PROG([$1], [$2], [$3])
FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL([$1], [$2], [$3])
# From Xcode 5 on, OS X command line tools do not include gcc anymore. Use clang.
if test -z "$$1"
then
FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL([$1], [clang], [clang])
fi
if test -z "$$1"
then
AC_MSG_ERROR([cannot find $3 nor clang in your PATH])
fi
fi
AC_SUBST($1)
])
...
...
boot
View file @
d127a697
...
...
@@ -58,7 +58,7 @@ sub sanity_check_tree {
if
(
/^#/
)
{
# Comment; do nothing
}
elsif
(
/^([a-zA-Z0-9\/.-]+) +([^ ]+) +[^ ]+$/
)
{
elsif
(
/^([a-zA-Z0-9\/.-]+) +([^ ]+) +[^ ]+
+[^ ]+
$/
)
{
$dir
=
$
1
;
$tag
=
$
2
;
...
...
compiler/basicTypes/MkId.lhs
View file @
d127a697
...
...
@@ -695,8 +695,7 @@ dataConArgUnpack arg_ty
-- An interface file specified Unpacked, but we couldn't unpack it
isUnpackableType :: FamInstEnvs -> Type -> Bool
-- True if we can unpack the UNPACK fields of the constructor
-- without involving the NameSet tycons
-- True if we can unpack the UNPACK the argument type
-- See Note [Recursive unboxing]
-- We look "deeply" inside rather than relying on the DataCons
-- we encounter on the way, because otherwise we might well
...
...
@@ -730,9 +729,11 @@ isUnpackableType fam_envs ty
-- NB: dataConStrictMarks gives the *user* request;
-- We'd get a black hole if we used dataConRepBangs
attempt_unpack (HsUnpack {}) = True
attempt_unpack (HsUserBang (Just unpk) _) = unpk
attempt_unpack _ = False
attempt_unpack (HsUnpack {}) = True
attempt_unpack (HsUserBang (Just unpk) bang) = bang && unpk
attempt_unpack (HsUserBang Nothing bang) = bang -- Be conservative
attempt_unpack HsStrict = False
attempt_unpack HsNoBang = False
\end{code}
Note [Unpack one-wide fields]
...
...
@@ -761,14 +762,26 @@ Here we can represent T with an Int#.
Note [Recursive unboxing]
~~~~~~~~~~~~~~~~~~~~~~~~~
Be careful not to try to unbox this!
data T = MkT {-# UNPACK #-} !T Int
Reason: consider
Consider
data R = MkR {-# UNPACK #-} !S Int
data S = MkS {-# UNPACK #-} !Int
The representation arguments of MkR are the *representation* arguments
of S (plus Int); the rep args of MkS are Int#. This is obviously no
good for T, because then we'd get an infinite number of arguments.
of S (plus Int); the rep args of MkS are Int#. This is all fine.
But be careful not to try to unbox this!
data T = MkT {-# UNPACK #-} !T Int
Because then we'd get an infinite number of arguments.
Here is a more complicated case:
data S = MkS {-# UNPACK #-} !T Int
data T = MkT {-# UNPACK #-} !S Int
Each of S and T must decide independendently whether to unpack
and they had better not both say yes. So they must both say no.
Also behave conservatively when there is no UNPACK pragma
data T = MkS !T Int
with -funbox-strict-fields or -funbox-small-strict-fields
we need to behave as if there was an UNPACK pragma there.
But it's the *argument* type that matters. This is fine:
data S = MkS S !Int
...
...
compiler/cmm/CmmNode.hs
View file @
d127a697
...
...
@@ -52,7 +52,7 @@ data CmmNode e x where
[
CmmActual
]
->
-- zero or more arguments
CmmNode
O
O
-- Semantics: clobbers any GlobalRegs for which callerSaves r == True
-- See Note [
foreign calls clobber GlobalReg
s]
-- See Note [
Unsafe foreign calls clobber caller-save register
s]
--
-- Invariant: the arguments and the ForeignTarget must not
-- mention any registers for which CodeGen.Platform.callerSaves
...
...
@@ -158,8 +158,8 @@ made manifest in CmmLayoutStack, where they are lowered into the above
sequence.
-}
{- Note [
foreign calls clobber GlobalReg
s]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
{- Note [
Unsafe foreign calls clobber caller-save register
s]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~~~~~
A foreign call is defined to clobber any GlobalRegs that are mapped to
caller-saves machine registers (according to the prevailing C ABI).
...
...
@@ -329,8 +329,9 @@ instance DefinerOfRegs GlobalReg (CmmNode e x) where
foldRegsDefd
dflags
f
z
n
=
case
n
of
CmmAssign
lhs
_
->
fold
f
z
lhs
CmmUnsafeForeignCall
tgt
_
_
->
fold
f
z
(
foreignTargetRegs
tgt
)
CmmCall
{}
->
fold
f
z
activeRegs
CmmForeignCall
{
tgt
=
tgt
}
->
fold
f
z
(
foreignTargetRegs
tgt
)
CmmCall
{}
->
fold
f
z
activeRegs
CmmForeignCall
{}
->
fold
f
z
activeRegs
-- See Note [Safe foreign calls clobber STG registers]
_
->
z
where
fold
::
forall
a
b
.
DefinerOfRegs
GlobalReg
a
=>
...
...
@@ -344,6 +345,74 @@ instance DefinerOfRegs GlobalReg (CmmNode e x) where
foreignTargetRegs
(
ForeignTarget
_
(
ForeignConvention
_
_
_
CmmNeverReturns
))
=
[]
foreignTargetRegs
_
=
activeCallerSavesRegs
-- Note [Safe foreign calls clobber STG registers]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- During stack layout phase every safe foreign call is expanded into a block
-- that contains unsafe foreign call (instead of safe foreign call) and ends
-- with a normal call (See Note [Foreign calls]). This means that we must
-- treat safe foreign call as if it was a normal call (because eventually it
-- will be). This is important if we try to run sinking pass before stack
-- layout phase. Consider this example of what might go wrong (this is cmm
-- code from stablename001 test). Here is code after common block elimination
-- (before stack layout):
--
-- c1q6:
-- _s1pf::P64 = R1;
-- _c1q8::I64 = performMajorGC;
-- I64[(young<c1q9> + 8)] = c1q9;
-- foreign call "ccall" arg hints: [] result hints: [] (_c1q8::I64)(...)
-- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
-- c1q9:
-- I64[(young<c1qb> + 8)] = c1qb;
-- R1 = _s1pc::P64;
-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
--
-- If we run sinking pass now (still before stack layout) we will get this:
--
-- c1q6:
-- I64[(young<c1q9> + 8)] = c1q9;
-- foreign call "ccall" arg hints: [] result hints: [] performMajorGC(...)
-- returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
-- c1q9:
-- I64[(young<c1qb> + 8)] = c1qb;
-- _s1pf::P64 = R1; <------ _s1pf sunk past safe foreign call
-- R1 = _s1pc::P64;
-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
--
-- Notice that _s1pf was sunk past a foreign call. When we run stack layout
-- safe call to performMajorGC will be turned into:
--
-- c1q6:
-- _s1pc::P64 = P64[Sp + 8];
-- I64[Sp - 8] = c1q9;
-- Sp = Sp - 8;
-- I64[I64[CurrentTSO + 24] + 16] = Sp;
-- P64[CurrentNursery + 8] = Hp + 8;
-- (_u1qI::I64) = call "ccall" arg hints: [PtrHint,]
-- result hints: [PtrHint] suspendThread(BaseReg, 0);
-- call "ccall" arg hints: [] result hints: [] performMajorGC();
-- (_u1qJ::I64) = call "ccall" arg hints: [PtrHint]
-- result hints: [PtrHint] resumeThread(_u1qI::I64);
-- BaseReg = _u1qJ::I64;
-- _u1qK::P64 = CurrentTSO;
-- _u1qL::P64 = I64[_u1qK::P64 + 24];
-- Sp = I64[_u1qL::P64 + 16];
-- SpLim = _u1qL::P64 + 192;
-- HpAlloc = 0;
-- Hp = I64[CurrentNursery + 8] - 8;
-- HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1);
-- call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8;
-- c1q9:
-- I64[(young<c1qb> + 8)] = c1qb;
-- _s1pf::P64 = R1; <------ INCORRECT!
-- R1 = _s1pc::P64;
-- call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
--
-- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that
-- call is clearly incorrect. This is what would happen if we assumed that
-- safe foreign call has the same semantics as unsafe foreign call. To prevent
-- this we need to treat safe foreign call as if was normal call.
-----------------------------------
-- mapping Expr in CmmNode
...
...
@@ -429,6 +498,8 @@ foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
foldExpForeignTarget
_
(
PrimTarget
_
)
z
=
z
-- Take a folder on expressions and apply it recursively.
-- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad
-- itself, delegating all the other CmmExpr forms to 'f'.
wrapRecExpf
::
(
CmmExpr
->
z
->
z
)
->
CmmExpr
->
z
->
z
wrapRecExpf
f
e
@
(
CmmMachOp
_
es
)
z
=
foldr
(
wrapRecExpf
f
)
(
f
e
z
)
es
wrapRecExpf
f
e
@
(
CmmLoad
addr
_
)
z
=
wrapRecExpf
f
addr
(
f
e
z
)
...
...
compiler/cmm/CmmSink.hs
View file @
d127a697
...
...
@@ -43,38 +43,52 @@ import qualified Data.Set as Set
--
-- * Start by doing liveness analysis.
--
-- * Keep a list of assignments A; earlier ones may refer to later ones
-- * Keep a list of assignments A; earlier ones may refer to later ones.
-- Currently we only sink assignments to local registers, because we don't
-- have liveness information about global registers.
--
-- * Walk forwards through the graph, look at each node N:
-- * If any assignments in A (1) occur only once in N, and (2) are
-- not live after N, inline the assignment and remove it
-- from A.
-- * If N is an assignment:
-- * If the register is not live after N, discard it
-- * otherwise pick up the assignment and add it to A
-- * If N is a non-assignment node:
--
-- * If it is a dead assignment, i.e. assignment to a register that is
-- not used after N, discard it.
--
-- * Try to inline based on current list of assignments
-- * If any assignments in A (1) occur only once in N, and (2) are
-- not live after N, inline the assignment and remove it
-- from A.
--
-- * If an assignment in A is cheap (RHS is local register), then
-- inline the assignment and keep it in A in case it is used afterwards.
--
-- * Otherwise don't inline.
--
-- * If N is assignment to a local register pick up the assignment
-- and add it to A.
--
-- * If N is not an assignment to a local register:
-- * remove any assignments from A that conflict with N, and
-- place them before N in the current block. (we call this
-- "dropping" the assignments).
-- place them before N in the current block. We call this
-- "dropping" the assignments.
--
-- * An assignment conflicts with N if it:
-- - assigns to a register mentioned in N
-- - mentions a register assigned by N
-- - reads from memory written by N
-- * do this recursively, dropping dependent assignments
-- * At a multi-way branch:
-- * drop any assignments that are live on more than one branch
-- * if any successor has more than one predecessor (a
-- join-point), drop everything live in that successor
--
-- As a side-effect we'll delete some dead assignments (transitively,
-- even). This isn't as good as removeDeadAssignments, but it's much
-- cheaper.
-- If we do this *before* stack layout, we might be able to avoid
-- saving some things across calls/procpoints.
--
-- *but*, that will invalidate the liveness analysis, and we'll have
-- to re-do it.
-- * At an exit node:
-- * drop any assignments that are live on more than one successor
-- and are not trivial
-- * if any successor has more than one predecessor (a join-point),
-- drop everything live in that successor. Since we only propagate
-- assignments that are not dead at the successor, we will therefore
-- eliminate all assignments dead at this point. Thus analysis of a
-- join-point will always begin with an empty list of assignments.
--
--
-- As a result of above algorithm, sinking deletes some dead assignments
-- (transitively, even). This isn't as good as removeDeadAssignments,
-- but it's much cheaper.
-- -----------------------------------------------------------------------------
-- things that we aren't optimising very well yet.
...
...
@@ -122,6 +136,12 @@ type Assignment = (LocalReg, CmmExpr, AbsMem)
-- Assignment caches AbsMem, an abstraction of the memory read by
-- the RHS of the assignment.
type
Assignments
=
[
Assignment
]
-- A sequence of assignements; kept in *reverse* order
-- So the list [ x=e1, y=e2 ] means the sequence of assignments
-- y = e2
-- x = e1
cmmSink
::
DynFlags
->
CmmGraph
->
CmmGraph
cmmSink
dflags
graph
=
ofBlockList
(
g_entry
graph
)
$
sink
mapEmpty
$
blocks
where
...
...
@@ -132,7 +152,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
join_pts
=
findJoinPoints
blocks
sink
::
BlockEnv
[
Assignment
]
->
[
CmmBlock
]
->
[
CmmBlock
]
sink
::
BlockEnv
Assignments
->
[
CmmBlock
]
->
[
CmmBlock
]
sink
_
[]
=
[]
sink
sunk
(
b
:
bs
)
=
-- pprTrace "sink" (ppr lbl) $
...
...
@@ -209,7 +229,8 @@ isSmall _ = False
isTrivial
::
CmmExpr
->
Bool
isTrivial
(
CmmReg
(
CmmLocal
_
))
=
True
-- isTrivial (CmmLit _) = True
-- isTrivial (CmmLit _) = True -- Disabled because it used to make thing worse.
-- Needs further investigation
isTrivial
_
=
False
--
...
...
@@ -234,7 +255,7 @@ findJoinPoints blocks = mapFilter (>1) succ_counts
-- filter the list of assignments to remove any assignments that
-- are not live in a continuation.
--
filterAssignments
::
DynFlags
->
LocalRegSet
->
[
Assignment
]
->
[
Assignment
]
filterAssignments
::
DynFlags
->
LocalRegSet
->
Assignments
->
Assignments
filterAssignments
dflags
live
assigs
=
reverse
(
go
assigs
[]
)
where
go
[]
kept
=
kept
go
(
a
@
(
r
,
_
,
_
)
:
as
)
kept
|
needed
=
go
as
(
a
:
kept
)
...
...
@@ -249,26 +270,36 @@ filterAssignments dflags live assigs = reverse (go assigs [])
-- -----------------------------------------------------------------------------
-- Walk through the nodes of a block, sinking and inlining assignments
-- as we go.
--
-- On input we pass in a:
-- * list of nodes in the block
-- * a list of assignments that appeared *before* this block and
-- that are being sunk.
--
-- On output we get:
-- * a new block
-- * a list of assignments that will be placed *after* that block.
--
walk
::
DynFlags
->
[(
LocalRegSet
,
CmmNode
O
O
)]
-- nodes of the block, annotated with
-- the set of registers live *after*
-- this node.
->
[
Assignment
]
-- The current list of
->
Assignments
-- The current list of
-- assignments we are sinking.
-- Later assignments may refer
-- to earlier ones.
->
(
Block
CmmNode
O
O
-- The new block
,
[
Assignment
]
-- Assignments to sink further
,
Assignments
-- Assignments to sink further
)
walk
dflags
nodes
assigs
=
go
nodes
emptyBlock
assigs
where
go
[]
block
as
=
(
block
,
as
)
go
((
live
,
node
)
:
ns
)
block
as
|
shouldDiscard
node
live
=
go
ns
block
as
|
shouldDiscard
node
live
=
go
ns
block
as
-- discard dead assignment
|
Just
a
<-
shouldSink
dflags
node2
=
go
ns
block
(
a
:
as1
)
|
otherwise
=
go
ns
block'
as'
where
...
...
@@ -316,17 +347,17 @@ shouldDiscard node live
CmmAssign
r
(
CmmReg
r'
)
|
r
==
r'
->
True
CmmAssign
(
CmmLocal
r
)
_
->
not
(
r
`
Set
.
member
`
live
)
_otherwise
->
False
toNode
::
Assignment
->
CmmNode
O
O
toNode
(
r
,
rhs
,
_
)
=
CmmAssign
(
CmmLocal
r
)
rhs
dropAssignmentsSimple
::
DynFlags
->
(
Assignment
->
Bool
)
->
[
Assignment
]
->
([
CmmNode
O
O
],
[
Assignment
]
)
dropAssignmentsSimple
::
DynFlags
->
(
Assignment
->
Bool
)
->
Assignments
->
([
CmmNode
O
O
],
Assignments
)
dropAssignmentsSimple
dflags
f
=
dropAssignments
dflags
(
\
a
_
->
(
f
a
,
()
))
()
dropAssignments
::
DynFlags
->
(
Assignment
->
s
->
(
Bool
,
s
))
->
s
->
[
Assignment
]
->
([
CmmNode
O
O
],
[
Assignment
]
)
dropAssignments
::
DynFlags
->
(
Assignment
->
s
->
(
Bool
,
s
))
->
s
->
Assignments
->
([
CmmNode
O
O
],
Assignments
)
dropAssignments
dflags
should_drop
state
assigs
=
(
dropped
,
reverse
kept
)
where
...
...
@@ -351,16 +382,16 @@ tryToInline
-- that is live after the node, unless
-- it is small enough to duplicate.
->
CmmNode
O
x
-- The node to inline into
->
[
Assignment
]
-- Assignments to inline
->
Assignments
-- Assignments to inline
->
(
CmmNode
O
x
-- New node
,
[
Assignment
]
-- Remaining assignments
,
Assignments
-- Remaining assignments
)
tryToInline
dflags
live
node
assigs
=
go
usages
node
[]
assigs
where
usages
::
UniqFM
Int
usages
=
foldRegsUsed
dflags
addUsage
emptyUFM
node
usages
::
UniqFM
Int
-- Maps each LocalReg to a count of how often it is used
usages
=
fold
Local
RegsUsed
dflags
addUsage
emptyUFM
node
go
_usages
node
_skipped
[]
=
(
node
,
[]
)
...
...
@@ -371,10 +402,10 @@ tryToInline dflags live node assigs = go usages node [] assigs
|
otherwise
=
dont_inline
where
inline_and_discard
=
go
usages'
inl_node
skipped
rest
where
usages'
=
foldRegsUsed
dflags
addUsage
usages
rhs
where
usages'
=
fold
Local
RegsUsed
dflags
addUsage
usages
rhs
dont_inline
=
keep
node
-- don't inline the assignment, keep it
inline_and_keep
=
keep
inl_node
-- inline the assignment, keep it
dont_inline
=
keep
node
-- don't inline the assignment, keep it
inline_and_keep
=
keep
inl_node
--
inline the assignment, keep it
keep
node'
=
(
final_node
,
a
:
rest'
)
where
(
final_node
,
rest'
)
=
go
usages'
node'
(
l
:
skipped
)
rest
...
...
@@ -470,10 +501,10 @@ conflicts dflags (r, rhs, addr) node
|
SpMem
{}
<-
addr
,
CmmAssign
(
CmmGlobal
Sp
)
_
<-
node
=
True
-- (4) assignments that read caller-saves GlobalRegs conflict with a
-- foreign call. See Note [
foreign calls clobber GlobalRegs].
-- foreign call. See Note [
Unsafe foreign calls clobber caller-save registers]
|
CmmUnsafeForeignCall
{}
<-
node
,
anyCallerSavesRegs
dflags
rhs
=
True
-- (5) foreign calls clobber heap: see Note [
f
oreign calls clobber heap]
-- (5) foreign calls clobber heap: see Note [
F
oreign calls clobber heap]
|
CmmUnsafeForeignCall
{}
<-
node
,
memConflicts
addr
AnyMem
=
True
-- (6) native calls clobber any memory
...
...
@@ -532,7 +563,8 @@ data AbsMem
-- that was written in the same basic block. To take advantage of
-- non-aliasing of heap memory we will have to be more clever.
-- Note [foreign calls clobber]
-- Note [Foreign calls clobber heap]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- It is tempting to say that foreign calls clobber only
-- non-heap/stack memory, but unfortunately we break this invariant in
...
...
compiler/codeGen/StgCmm.hs
View file @
d127a697
...
...
@@ -11,7 +11,7 @@ module StgCmm ( codeGen ) where
#
define
FAST_STRING_NOT_NEEDED
#
include
"HsVersions.h"
import
StgCmmProf
import
StgCmmProf
(
initCostCentres
,
ldvEnter
)
import
StgCmmMonad
import
StgCmmEnv
import
StgCmmBind
...
...
compiler/codeGen/StgCmmBind.hs
View file @
d127a697
...
...
@@ -20,7 +20,8 @@ import StgCmmMonad
import
StgCmmEnv
import
StgCmmCon
import
StgCmmHeap
import
StgCmmProf
import
StgCmmProf
(
curCCS
,
ldvEnterClosure
,
enterCostCentreFun
,
enterCostCentreThunk
,
initUpdFrameProf
,
costCentreFrom
)
import
StgCmmTicky
import
StgCmmLayout
import
StgCmmUtils
...
...
compiler/codeGen/StgCmmCon.hs
View file @
d127a697
...
...
@@ -23,7 +23,7 @@ import StgCmmEnv
import
StgCmmHeap
import
StgCmmUtils
import
StgCmmClosure
import
StgCmmProf
import
StgCmmProf
(
curCCS
)
import
CmmExpr
import
CLabel
...
...
compiler/codeGen/StgCmmExpr.hs
View file @
d127a697
...
...
@@ -17,7 +17,7 @@ import StgCmmMonad
import
StgCmmHeap
import
StgCmmEnv
import
StgCmmCon
import
StgCmmProf
import
StgCmmProf
(
saveCurrentCostCentre
,
restoreCurrentCostCentre
,
emitSetCCC
)
import
StgCmmLayout
import
StgCmmPrim
import
StgCmmHpc
...
...
compiler/codeGen/StgCmmForeign.hs
View file @
d127a697
...
...
@@ -18,7 +18,7 @@ module StgCmmForeign (
#
include
"HsVersions.h"
import
StgSyn
import
StgCmmProf
import
StgCmmProf
(
storeCurCCS
,
ccsType
,
curCCS
)
import
StgCmmEnv
import
StgCmmMonad
import
StgCmmUtils
...
...
compiler/codeGen/StgCmmHeap.hs
View file @
d127a697
...
...
@@ -28,7 +28,7 @@ import CLabel
import
StgCmmLayout
import
StgCmmUtils
import
StgCmmMonad
import
StgCmmProf
import
StgCmmProf
(
profDynAlloc
,
dynProfHdr
,
staticProfHdr
)
import
StgCmmTicky
import
StgCmmClosure
import
StgCmmEnv
...
...
compiler/codeGen/StgCmmLayout.hs
View file @
d127a697
...
...
@@ -29,7 +29,7 @@ import StgCmmArgRep -- notably: ( slowCallPattern )
import
StgCmmTicky
import
StgCmmMonad
import
StgCmmUtils
import
StgCmmProf
import
StgCmmProf
(
curCCS
)
import
MkGraph
import
SMRep
...
...
compiler/codeGen/StgCmmPrim.hs
View file @
d127a697
...
...
@@ -21,7 +21,7 @@ import StgCmmMonad
import
StgCmmUtils
import
StgCmmTicky
import
StgCmmHeap
import
StgCmmProf
import
StgCmmProf
(
costCentreFrom
,
curCCS
)
import
DynFlags
import
Platform
...
...
compiler/coreSyn/CoreLint.lhs
View file @
d127a697
...
...
@@ -16,7 +16,7 @@ A ``lint'' pass to check for Core correctness
{-# OPTIONS_GHC -fprof-auto #-}
module CoreLint ( lintCoreBindings, lintUnfolding ) where
module CoreLint ( lintCoreBindings, lintUnfolding
, lintExpr
) where
#include "HsVersions.h"
...
...
@@ -120,14 +120,15 @@ find an occurence of an Id, we fetch it from the in-scope set.
\begin{code}
lintCoreBindings :: CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
lintCoreBindings ::
[Var] ->
CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
-- Returns (warnings, errors)
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
lintCoreBindings binds
lintCoreBindings
local_in_scope
binds
= initL $
addLoc TopLevelBindings $
addInScopeVars binders $
addLoc TopLevelBindings $
addInScopeVars local_in_scope $
addInScopeVars binders $
-- Put all the top-level binders in scope at the start
-- This is because transformation rules can bring something
-- into use 'unexpectedly'
...
...
@@ -178,6 +179,18 @@ lintUnfolding locn vars expr
(_warns, errs) = initL (addLoc (ImportedUnfolding locn) $
addInScopeVars vars $
lintCoreExpr expr)
lintExpr :: [Var] -- Treat these as in scope
-> CoreExpr
-> Maybe MsgDoc -- Nothing => OK
lintExpr vars expr
| isEmptyBag errs = Nothing
| otherwise = Just (pprMessageBag errs)
where
(_warns, errs) = initL (addLoc TopLevelBindings $
addInScopeVars vars $
lintCoreExpr expr)
\end{code}
%************************************************************************
...
...
compiler/coreSyn/CorePrep.lhs
View file @
d127a697
...
...
@@ -172,7 +172,7 @@ corePrepPgm dflags hsc_env binds data_tycons = do
floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
return (deFloatTop (floats1 `appendFloats` floats2))
endPass
dflags
CorePrep binds_out []
endPass
hsc_env
CorePrep binds_out []
return binds_out
corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
...
...
compiler/coreSyn/CoreSyn.lhs
View file @
d127a697
...
...
@@ -714,7 +714,9 @@ data Unfolding
------------------------------------------------
data UnfoldingSource
= InlineRhs -- The current rhs of the function
= -- See also Note [Historical note: unfoldings for wrappers]
InlineRhs -- The current rhs of the function
-- Replace uf_tmpl each time around
| InlineStable -- From an INLINE or INLINABLE pragma
...
...
@@ -739,13 +741,6 @@ data UnfoldingSource
-- (see MkId.lhs, calls to mkCompulsoryUnfolding).
-- Inline absolutely always, however boring the context.
| InlineWrapper -- This unfolding is the wrapper in a
-- worker/wrapper split from the strictness
-- analyser
--
-- cf some history in TcIface's Note [wrappers
-- in interface files]
-- | 'UnfoldingGuidance' says when unfolding should take place
...
...
@@ -775,6 +770,25 @@ data UnfoldingGuidance
| UnfNever -- The RHS is big, so don't inline it
\end{code}
Note [Historical note: unfoldings for wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We used to have a nice clever scheme in interface files for
wrappers. A wrapper's unfolding can be reconstructed from its worker's
id and its strictness. This decreased .hi file size (sometimes
significantly, for modules like GHC.Classes with many high-arity w/w
splits) and had a slight corresponding effect on compile times.
However, when we added the second demand analysis, this scheme lead to
some Core lint errors. The second analysis could change the strictness
signatures, which sometimes resulted in a wrapper's regenerated
unfolding applying the wrapper to too many arguments.