Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
3f0afaba
Commit
3f0afaba
authored
Jul 04, 2012
by
Simon Marlow
Browse files
Fix merge-related problems
parent
99fd2469
Changes
12
Hide whitespace changes
Inline
Side-by-side
compiler/cmm/CmmBuildInfoTables.hs
View file @
3f0afaba
...
...
@@ -23,28 +23,20 @@ where
#
include
"HsVersions.h"
-- These should not be imported here!
import
StgCmmForeign
import
StgCmmUtils
import
Constants
import
Digraph
import
qualified
Prelude
as
P
import
Prelude
hiding
(
succ
)
import
Util
import
BlockId
import
Bitmap
import
CLabel
import
Cmm
import
CmmUtils
import
Module
import
FastString
import
ForeignCall
import
IdInfo
import
Data.List
import
Maybes
import
MkGraph
as
M
import
Control.Monad
import
Name
import
OptimizationFuel
import
Outputable
...
...
@@ -57,8 +49,8 @@ import Data.Map (Map)
import
qualified
Data.Map
as
Map
import
Data.Set
(
Set
)
import
qualified
Data.Set
as
Set
import
qualified
FiniteMap
as
Map
foldSet
::
(
a
->
b
->
b
)
->
b
->
Set
a
->
b
#
if
__GLASGOW_HASKELL__
<
704
foldSet
=
Set
.
fold
#
else
...
...
@@ -106,7 +98,7 @@ cafTransfers = mkBTransfer3 first middle last
add
l
s
=
if
hasCAF
l
then
Set
.
insert
(
toClosureLbl
l
)
s
else
s
cafAnal
::
Platform
->
CmmGraph
->
CAFEnv
cafAnal
::
CmmGraph
->
CAFEnv
cafAnal
g
=
dataflowAnalBwd
g
[]
$
analBwd
cafLattice
cafTransfers
-----------------------------------------------------------------------
...
...
compiler/cmm/CmmLayoutStack.hs
View file @
3f0afaba
...
...
@@ -1033,13 +1033,16 @@ walk (n:ns) acc as
(
dropped
,
as'
)
=
partition
should_drop
as
where
should_drop
a
=
a
`
conflicts
`
n
toNodes
::
[(
LocalReg
,
CmmExpr
)]
->
[
CmmNode
O
O
]
toNodes
as
=
[
CmmAssign
(
CmmLocal
r
)
rhs
|
(
r
,
rhs
)
<-
as
]
-- We only sink "r = G" assignments right now, so conflicts is very simple:
(
r
,
rhs
)
`
conflicts
`
CmmAssign
reg
_
|
reg
`
regUsedIn
`
rhs
=
True
conflicts
::
(
LocalReg
,
CmmExpr
)
->
CmmNode
O
O
->
Bool
(
_
,
rhs
)
`
conflicts
`
CmmAssign
reg
_
|
reg
`
regUsedIn
`
rhs
=
True
--(r, CmmLoad _ _) `conflicts` CmmStore _ _ = True
(
r
,
_
)
`
conflicts
`
node
=
foldRegsUsed
(
\
b
r'
->
r
==
r'
||
b
)
False
node
conflictsWithLast
::
(
LocalReg
,
CmmExpr
)
->
CmmNode
O
C
->
Bool
(
r
,
_
)
`
conflictsWithLast
`
node
=
foldRegsUsed
(
\
b
r'
->
r
==
r'
||
b
)
False
node
compiler/cmm/CmmLint.hs
View file @
3f0afaba
...
...
@@ -7,7 +7,7 @@
-----------------------------------------------------------------------------
{-# LANGUAGE GADTs #-}
module
CmmLint
(
cmmLint
,
cmmLintDecl
,
cmmLintGraph
cmmLint
,
cmmLintGraph
)
where
import
Hoopl
...
...
@@ -31,7 +31,7 @@ import Data.Maybe
-- Exported entry points:
cmmLint
::
(
Outputable
d
,
Outputable
h
)
=>
GenCmmGroup
d
h
(
ListGraph
CmmStmt
)
->
Maybe
SDoc
=>
GenCmmGroup
d
h
CmmGraph
->
Maybe
SDoc
cmmLint
tops
=
runCmmLint
(
mapM_
lintCmmDecl
)
tops
cmmLintGraph
::
CmmGraph
->
Maybe
SDoc
...
...
@@ -62,7 +62,7 @@ lintCmmGraph g = mapM_ (lintCmmBlock labels) blocks
lintCmmBlock
::
BlockSet
->
CmmBlock
->
CmmLint
()
lintCmmBlock
labels
block
=
addLintInfo
(
\
_
->
text
"in basic block "
<>
ppr
(
entryLabel
block
))
$
do
=
addLintInfo
(
text
"in basic block "
<>
ppr
(
entryLabel
block
))
$
do
let
(
_
,
middle
,
last
)
=
blockSplit
block
mapM_
lintCmmMiddle
(
blockToList
middle
)
lintCmmLast
labels
last
...
...
@@ -172,7 +172,7 @@ lintCmmLast labels node = case node of
where
checkTarget
id
|
setMember
id
labels
=
return
()
|
otherwise
=
cmmLintErr
(
\
_
->
text
"Branch to nonexistent id"
<+>
ppr
id
)
|
otherwise
=
cmmLintErr
(
text
"Branch to nonexistent id"
<+>
ppr
id
)
lintTarget
::
ForeignTarget
->
CmmLint
()
...
...
@@ -195,18 +195,18 @@ checkCond expr
newtype
CmmLint
a
=
CmmLint
{
unCL
::
Either
SDoc
a
}
instance
Monad
CmmLint
where
CmmLint
m
>>=
k
=
CmmLint
$
\
p
->
case
m
p
of
Left
e
->
Left
e
Right
a
->
unCL
(
k
a
)
p
return
a
=
CmmLint
(
\
_
->
Right
a
)
CmmLint
m
>>=
k
=
CmmLint
$
case
m
of
Left
e
->
Left
e
Right
a
->
unCL
(
k
a
)
return
a
=
CmmLint
(
Right
a
)
cmmLintErr
::
SDoc
->
CmmLint
a
cmmLintErr
msg
=
CmmLint
(
\
p
->
Left
(
msg
p
)
)
cmmLintErr
msg
=
CmmLint
(
Left
msg
)
addLintInfo
::
SDoc
->
CmmLint
a
->
CmmLint
a
addLintInfo
info
thing
=
CmmLint
$
\
p
->
case
unCL
thing
p
of
Left
err
->
Left
(
hang
(
info
p
)
2
err
)
addLintInfo
info
thing
=
CmmLint
$
case
unCL
thing
of
Left
err
->
Left
(
hang
info
2
err
)
Right
a
->
Right
a
cmmLintMachOpErr
::
CmmExpr
->
[
CmmType
]
->
[
Width
]
->
CmmLint
a
...
...
compiler/cmm/CmmOpt.hs
View file @
3f0afaba
...
...
@@ -146,7 +146,6 @@ To inline _smi:
countUses
::
UserOfLocalRegs
a
=>
a
->
UniqFM
Int
countUses
a
=
foldRegsUsed
(
\
m
r
->
addToUFM_C
(
+
)
m
r
1
)
emptyUFM
a
where
count
m
r
=
lookupWithDefaultUFM
m
(
0
::
Int
)
r
cmmMiniInline
::
DynFlags
->
[
CmmBasicBlock
]
->
[
CmmBasicBlock
]
cmmMiniInline
dflags
blocks
=
map
do_inline
blocks
...
...
@@ -158,14 +157,14 @@ cmmMiniInlineStmts _ _ [] = []
cmmMiniInlineStmts
dflags
uses
(
stmt
@
(
CmmAssign
(
CmmLocal
(
LocalReg
u
_
))
expr
)
:
stmts
)
-- not used: just discard this assignment
|
0
<-
lookupWithDefaultUFM
uses
0
u
=
cmmMiniInlineStmts
uses
stmts
=
cmmMiniInlineStmts
dflags
uses
stmts
-- used (foldable to small thing): try to inline at all the use sites
|
Just
n
<-
lookupUFM
uses
u
,
e
<-
wrapRecExp
foldExp
expr
,
isTiny
e
=
ncgDebugTrace
(
"nativeGen: inlining "
++
showSDoc
(
pprStmt
stmt
))
$
ncgDebugTrace
(
"nativeGen: inlining "
++
showSDoc
dflags
(
pprStmt
stmt
))
$
case
lookForInlineMany
u
e
stmts
of
(
m
,
stmts'
)
|
n
==
m
->
cmmMiniInlineStmts
dflags
(
delFromUFM
uses
u
)
stmts'
...
...
@@ -256,6 +255,7 @@ okToInline _ _ = True
-- changed is not one we were relying on. I don't know how much of a
-- performance hit this is (we have to create a regset for every
-- instruction.) -- EZY
okToSkip
::
CmmStmt
->
Unique
->
CmmExpr
->
RegSet
->
Bool
okToSkip
stmt
u
expr
regset
=
case
stmt
of
CmmNop
->
True
...
...
compiler/cmm/CmmPipeline.hs
View file @
3f0afaba
...
...
@@ -12,28 +12,22 @@ module CmmPipeline (
import
CLabel
import
Cmm
import
CmmLint
import
CmmLive
import
CmmBuildInfoTables
import
CmmCommonBlockElim
import
CmmProcPoint
import
CmmRewriteAssignments
import
CmmContFlowOpt
import
OptimizationFuel
import
CmmLayoutStack
import
Hoopl
import
CmmUtils
import
DynFlags
import
ErrUtils
import
HscTypes
import
Data.Maybe
import
Control.Monad
import
Data.Map
(
Map
)
import
qualified
Data.Map
as
Map
import
Data.Set
(
Set
)
import
qualified
Data.Set
as
Set
import
Outputable
import
StaticFlags
import
qualified
Data.Set
as
Set
import
Data.Map
(
Map
)
-----------------------------------------------------------------------------
-- | Top level driver for C-- pipeline
...
...
@@ -133,8 +127,8 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
dumps
Opt_D_dump_cmmz_split
"Post splitting"
gs
------------- More CAFs ------------------------------
let
cafEnv
=
{-# SCC "cafAnal" #-}
cafAnal
platform
g
let
localCAFs
=
{-# SCC "localCAFs" #-}
catMaybes
$
map
(
localCAFInfo
platform
cafEnv
)
gs
let
cafEnv
=
{-# SCC "cafAnal" #-}
cafAnal
g
let
localCAFs
=
{-# SCC "localCAFs" #-}
catMaybes
$
map
(
localCAFInfo
cafEnv
)
gs
mbpprTrace
"localCAFs"
(
ppr
localCAFs
)
$
return
()
-- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
...
...
@@ -155,7 +149,6 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
-- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?)
where
dflags
=
hsc_dflags
hsc_env
platform
=
targetPlatform
dflags
mbpprTrace
x
y
z
|
dopt
Opt_D_dump_cmmz
dflags
=
pprTrace
x
y
z
|
otherwise
=
z
dump
=
dumpGraph
dflags
...
...
@@ -165,9 +158,6 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
-- Runs a required transformation/analysis
run
=
runInfiniteFuelIO
(
hsc_OptFuel
hsc_env
)
-- Runs an optional transformation/analysis (and should
-- thus be subject to optimization fuel)
runOptimization
=
runFuelIO
(
hsc_OptFuel
hsc_env
)
dumpGraph
::
DynFlags
->
DynFlag
->
String
->
CmmGraph
->
IO
()
...
...
@@ -175,8 +165,8 @@ dumpGraph dflags flag name g = do
when
(
dopt
Opt_DoCmmLinting
dflags
)
$
do_lint
g
dumpWith
dflags
flag
name
g
where
do_lint
g
=
case
cmmLintGraph
(
targetPlatform
dflags
)
g
of
Just
err
->
do
{
printDump
err
do_lint
g
=
case
cmmLintGraph
g
of
Just
err
->
do
{
fatalErrorMsg
dflags
err
;
ghcExit
dflags
1
}
Nothing
->
return
()
...
...
compiler/codeGen/CodeGen.lhs
View file @
3f0afaba
...
...
@@ -30,7 +30,7 @@ import CgHpc
import CLabel
import OldCmm
import OldPprCmm
import OldPprCmm
()
import StgSyn
import PrelNames
...
...
@@ -46,6 +46,7 @@ import Module
import ErrUtils
import Panic
import Outputable
import Util
import OrdList
import Stream (Stream, liftIO)
...
...
compiler/codeGen/StgCmmHeap.hs
View file @
3f0afaba
...
...
@@ -338,7 +338,7 @@ entryHeapCheck cl_info offset nodeSet arity args code
args'
=
map
(
CmmReg
.
CmmLocal
)
args
setN
=
case
nodeSet
of
Just
n
->
mkNop
-- No need to assign R1, it already
Just
_
->
mkNop
-- No need to assign R1, it already
-- points to the closure
Nothing
->
mkAssign
nodeReg
$
CmmLit
(
CmmLabel
$
staticClosureLabel
cl_info
)
...
...
compiler/codeGen/StgCmmUtils.hs
View file @
3f0afaba
...
...
@@ -575,8 +575,8 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do
branches_lbls
<-
label_branches
join_lbl
branches
tag_expr'
<-
assignTemp'
tag_expr
emit
=<<
mk_switch
tag_expr'
(
sortBy
(
comparing
fst
)
branches
)
mb_deflt
_lbl
lo_tag
hi_tag
via_C
emit
=<<
mk_switch
tag_expr'
(
sortBy
(
comparing
fst
)
branches_lbl
s
)
mb_deflt_lbl
lo_tag
hi_tag
via_C
-- Sort the branches before calling mk_switch
...
...
compiler/main/CodeOutput.lhs
View file @
3f0afaba
...
...
@@ -28,11 +28,9 @@ import qualified Stream
import ErrUtils
import Outputable
import Module
import Maybes ( firstJusts )
import SrcLoc
import Control.Exception
import Control.Monad
import System.Directory
import System.FilePath
import System.IO
...
...
compiler/main/HscMain.hs
View file @
3f0afaba
...
...
@@ -121,7 +121,6 @@ import SimplStg ( stg2stg )
import
CodeGen
(
codeGen
)
import
qualified
OldCmm
as
Old
import
qualified
Cmm
as
New
import
PprCmm
(
pprCmms
)
import
CmmParse
(
parseCmmFile
)
import
CmmBuildInfoTables
import
CmmPipeline
...
...
@@ -151,7 +150,6 @@ import Exception
import
qualified
Stream
import
Stream
(
Stream
)
import
CLabel
import
Util
import
Data.List
...
...
compiler/nativeGen/AsmCodeGen.lhs
View file @
3f0afaba
...
...
@@ -274,7 +274,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph [])
cmmNativeGenStream :: (
Platform
Outputable statics,
Platform
Outputable instr, Instruction instr)
cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
-> NcgImpl statics instr jumpDest
-> BufHandle
...
...
compiler/utils/Outputable.lhs
View file @
3f0afaba
...
...
@@ -699,8 +699,6 @@ instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
ppr m = ppr (M.toList m)
instance (Outputable elt) => Outputable (IM.IntMap elt) where
ppr m = ppr (IM.toList m)
instance (PlatformOutputable elt) => PlatformOutputable (Set.Set elt) where
pprPlatform platform m = pprPlatform platform (Set.toList m)
\end{code}
%************************************************************************
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment