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