Hoopl: remove dependency on Hoopl package
[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 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 (CmmGlobal 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