Draw STG F and D registers from the same pool of available SSE registers on x86-64.
[ghc.git] / compiler / codeGen / CgUtils.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generator utilities; mostly monadic
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module CgUtils ( fixStgRegisters ) where
10
11 #include "HsVersions.h"
12
13 import CodeGen.Platform
14 import OldCmm
15 import CLabel
16 import DynFlags
17 import Outputable
18
19 -- -----------------------------------------------------------------------------
20 -- Information about global registers
21
22 baseRegOffset :: DynFlags -> GlobalReg -> Int
23
24 baseRegOffset dflags (VanillaReg 1 _) = oFFSET_StgRegTable_rR1 dflags
25 baseRegOffset dflags (VanillaReg 2 _) = oFFSET_StgRegTable_rR2 dflags
26 baseRegOffset dflags (VanillaReg 3 _) = oFFSET_StgRegTable_rR3 dflags
27 baseRegOffset dflags (VanillaReg 4 _) = oFFSET_StgRegTable_rR4 dflags
28 baseRegOffset dflags (VanillaReg 5 _) = oFFSET_StgRegTable_rR5 dflags
29 baseRegOffset dflags (VanillaReg 6 _) = oFFSET_StgRegTable_rR6 dflags
30 baseRegOffset dflags (VanillaReg 7 _) = oFFSET_StgRegTable_rR7 dflags
31 baseRegOffset dflags (VanillaReg 8 _) = oFFSET_StgRegTable_rR8 dflags
32 baseRegOffset dflags (VanillaReg 9 _) = oFFSET_StgRegTable_rR9 dflags
33 baseRegOffset dflags (VanillaReg 10 _) = oFFSET_StgRegTable_rR10 dflags
34 baseRegOffset _ (VanillaReg n _) = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")
35 baseRegOffset dflags (FloatReg 1) = oFFSET_StgRegTable_rF1 dflags
36 baseRegOffset dflags (FloatReg 2) = oFFSET_StgRegTable_rF2 dflags
37 baseRegOffset dflags (FloatReg 3) = oFFSET_StgRegTable_rF3 dflags
38 baseRegOffset dflags (FloatReg 4) = oFFSET_StgRegTable_rF4 dflags
39 baseRegOffset dflags (FloatReg 5) = oFFSET_StgRegTable_rF5 dflags
40 baseRegOffset dflags (FloatReg 6) = oFFSET_StgRegTable_rF6 dflags
41 baseRegOffset _ (FloatReg n) = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")
42 baseRegOffset dflags (DoubleReg 1) = oFFSET_StgRegTable_rD1 dflags
43 baseRegOffset dflags (DoubleReg 2) = oFFSET_StgRegTable_rD2 dflags
44 baseRegOffset dflags (DoubleReg 3) = oFFSET_StgRegTable_rD3 dflags
45 baseRegOffset dflags (DoubleReg 4) = oFFSET_StgRegTable_rD4 dflags
46 baseRegOffset dflags (DoubleReg 5) = oFFSET_StgRegTable_rD5 dflags
47 baseRegOffset dflags (DoubleReg 6) = oFFSET_StgRegTable_rD6 dflags
48 baseRegOffset _ (DoubleReg n) = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")
49 baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags
50 baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags
51 baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags
52 baseRegOffset _ (LongReg n) = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")
53 baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags
54 baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags
55 baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags
56 baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags
57 baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags
58 baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags
59 baseRegOffset dflags EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo dflags
60 baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags
61 baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags
62 baseRegOffset _ BaseReg = panic "baseRegOffset:BaseReg"
63 baseRegOffset _ PicBaseReg = panic "baseRegOffset:PicBaseReg"
64
65
66 -- -----------------------------------------------------------------------------
67 --
68 -- STG/Cmm GlobalReg
69 --
70 -- -----------------------------------------------------------------------------
71
72 -- | We map STG registers onto appropriate CmmExprs. Either they map
73 -- to real machine registers or stored as offsets from BaseReg. Given
74 -- a GlobalReg, get_GlobalReg_addr always produces the
75 -- register table address for it.
76 get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr
77 get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0
78 get_GlobalReg_addr dflags mid
79 = get_Regtable_addr_from_offset dflags
80 (globalRegType dflags mid) (baseRegOffset dflags mid)
81
82 -- Calculate a literal representing an offset into the register table.
83 -- Used when we don't have an actual BaseReg to offset from.
84 regTableOffset :: DynFlags -> Int -> CmmExpr
85 regTableOffset dflags n =
86 CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))
87
88 get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
89 get_Regtable_addr_from_offset dflags _ offset =
90 if haveRegBase (targetPlatform dflags)
91 then CmmRegOff (CmmGlobal BaseReg) offset
92 else regTableOffset dflags offset
93
94 -- | Fixup global registers so that they assign to locations within the
95 -- RegTable if they aren't pinned for the current target.
96 fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl
97 fixStgRegisters _ top@(CmmData _ _) = top
98
99 fixStgRegisters dflags (CmmProc info lbl live (ListGraph blocks)) =
100 let blocks' = map (fixStgRegBlock dflags) blocks
101 in CmmProc info lbl live $ ListGraph blocks'
102
103 fixStgRegBlock :: DynFlags -> CmmBasicBlock -> CmmBasicBlock
104 fixStgRegBlock dflags (BasicBlock id stmts) =
105 let stmts' = map (fixStgRegStmt dflags) stmts
106 in BasicBlock id stmts'
107
108 fixStgRegStmt :: DynFlags -> CmmStmt -> CmmStmt
109 fixStgRegStmt dflags stmt
110 = case stmt of
111 CmmAssign (CmmGlobal reg) src ->
112 let src' = fixStgRegExpr dflags src
113 baseAddr = get_GlobalReg_addr dflags reg
114 in case reg `elem` activeStgRegs platform of
115 True -> CmmAssign (CmmGlobal reg) src'
116 False -> CmmStore baseAddr src'
117
118 CmmAssign reg src ->
119 let src' = fixStgRegExpr dflags src
120 in CmmAssign reg src'
121
122 CmmStore addr src -> CmmStore (fixStgRegExpr dflags addr) (fixStgRegExpr dflags src)
123
124 CmmCall target regs args returns ->
125 let target' = case target of
126 CmmCallee e conv -> CmmCallee (fixStgRegExpr dflags e) conv
127 CmmPrim op mStmts ->
128 CmmPrim op (fmap (map (fixStgRegStmt dflags)) mStmts)
129 args' = map (\(CmmHinted arg hint) ->
130 (CmmHinted (fixStgRegExpr dflags arg) hint)) args
131 in CmmCall target' regs args' returns
132
133 CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr dflags test) dest
134
135 CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr dflags expr) ids
136
137 CmmJump addr live -> CmmJump (fixStgRegExpr dflags addr) live
138
139 -- CmmNop, CmmComment, CmmBranch, CmmReturn
140 _other -> stmt
141 where platform = targetPlatform dflags
142
143
144 fixStgRegExpr :: DynFlags -> CmmExpr -> CmmExpr
145 fixStgRegExpr dflags expr
146 = case expr of
147 CmmLoad addr ty -> CmmLoad (fixStgRegExpr dflags addr) ty
148
149 CmmMachOp mop args -> CmmMachOp mop args'
150 where args' = map (fixStgRegExpr dflags) args
151
152 CmmReg (CmmGlobal reg) ->
153 -- Replace register leaves with appropriate StixTrees for
154 -- the given target. MagicIds which map to a reg on this
155 -- arch are left unchanged. For the rest, BaseReg is taken
156 -- to mean the address of the reg table in MainCapability,
157 -- and for all others we generate an indirection to its
158 -- location in the register table.
159 case reg `elem` activeStgRegs platform of
160 True -> expr
161 False ->
162 let baseAddr = get_GlobalReg_addr dflags reg
163 in case reg of
164 BaseReg -> fixStgRegExpr dflags baseAddr
165 _other -> fixStgRegExpr dflags
166 (CmmLoad baseAddr (globalRegType dflags reg))
167
168 CmmRegOff (CmmGlobal reg) offset ->
169 -- RegOf leaves are just a shorthand form. If the reg maps
170 -- to a real reg, we keep the shorthand, otherwise, we just
171 -- expand it and defer to the above code.
172 case reg `elem` activeStgRegs platform of
173 True -> expr
174 False -> fixStgRegExpr dflags (CmmMachOp (MO_Add (wordWidth dflags)) [
175 CmmReg (CmmGlobal reg),
176 CmmLit (CmmInt (fromIntegral offset)
177 (wordWidth dflags))])
178
179 -- CmmLit, CmmReg (CmmLocal), CmmStackSlot
180 _other -> expr
181 where platform = targetPlatform dflags
182