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