1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
-- | Register coalescing.
module GHC.CmmToAsm.Reg.Graph.Coalesce (
regCoalesce,
slurpJoinMovs
) where
import GHC.Prelude
import GHC.CmmToAsm.Reg.Liveness
import GHC.CmmToAsm.Instr
import GHC.Platform.Reg
import GHC.Cmm
import GHC.Data.Bag
import GHC.Data.Graph.Directed
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Types.Unique.Supply
-- | Do register coalescing on this top level thing
--
-- For Reg -> Reg moves, if the first reg dies at the same time the
-- second reg is born then the mov only serves to join live ranges.
-- The two regs can be renamed to be the same and the move instruction
-- safely erased.
regCoalesce
:: Instruction instr
=> [LiveCmmDecl statics instr]
-> UniqSM [LiveCmmDecl statics instr]
regCoalesce code
= do
let joins = foldl' unionBags emptyBag
$ map slurpJoinMovs code
let alloc = foldl' buildAlloc emptyUFM
$ bagToList joins
let patched = map (patchEraseLive (sinkReg alloc)) code
return patched
-- | Add a v1 = v2 register renaming to the map.
-- The register with the lowest lexical name is set as the
-- canonical version.
buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg
buildAlloc fm (r1, r2)
= let rmin = min r1 r2
rmax = max r1 r2
in addToUFM fm rmax rmin
-- | Determine the canonical name for a register by following
-- v1 = v2 renamings in this map.
sinkReg :: UniqFM Reg -> Reg -> Reg
sinkReg fm r
= case lookupUFM fm r of
Nothing -> r
Just r' -> sinkReg fm r'
-- | Slurp out mov instructions that only serve to join live ranges.
--
-- During a mov, if the source reg dies and the destination reg is
-- born then we can rename the two regs to the same thing and
-- eliminate the move.
slurpJoinMovs
:: Instruction instr
=> LiveCmmDecl statics instr
-> Bag (Reg, Reg)
slurpJoinMovs live
= slurpCmm emptyBag live
where
slurpCmm rs CmmData{}
= rs
slurpCmm rs (CmmProc _ _ _ sccs)
= foldl' slurpBlock rs (flattenSCCs sccs)
slurpBlock rs (BasicBlock _ instrs)
= foldl' slurpLI rs instrs
slurpLI rs (LiveInstr _ Nothing) = rs
slurpLI rs (LiveInstr instr (Just live))
| Just (r1, r2) <- takeRegRegMoveInstr instr
, elementOfUniqSet r1 $ liveDieRead live
, elementOfUniqSet r2 $ liveBorn live
-- only coalesce movs between two virtuals for now,
-- else we end up with allocatable regs in the live
-- regs list..
, isVirtualReg r1 && isVirtualReg r2
= consBag (r1, r2) rs
| otherwise
= rs
|
