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