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