1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
|
-----------------------------------------------------------------------------
--
-- Code generator utilities; mostly monadic
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------
module CgUtils ( fixStgRegisters ) where
#include "HsVersions.h"
import CodeGen.Platform
import OldCmm
import CLabel
import DynFlags
import Outputable
-- -----------------------------------------------------------------------------
-- Information about global registers
baseRegOffset :: DynFlags -> GlobalReg -> Int
baseRegOffset dflags (VanillaReg 1 _) = oFFSET_StgRegTable_rR1 dflags
baseRegOffset dflags (VanillaReg 2 _) = oFFSET_StgRegTable_rR2 dflags
baseRegOffset dflags (VanillaReg 3 _) = oFFSET_StgRegTable_rR3 dflags
baseRegOffset dflags (VanillaReg 4 _) = oFFSET_StgRegTable_rR4 dflags
baseRegOffset dflags (VanillaReg 5 _) = oFFSET_StgRegTable_rR5 dflags
baseRegOffset dflags (VanillaReg 6 _) = oFFSET_StgRegTable_rR6 dflags
baseRegOffset dflags (VanillaReg 7 _) = oFFSET_StgRegTable_rR7 dflags
baseRegOffset dflags (VanillaReg 8 _) = oFFSET_StgRegTable_rR8 dflags
baseRegOffset dflags (VanillaReg 9 _) = oFFSET_StgRegTable_rR9 dflags
baseRegOffset dflags (VanillaReg 10 _) = oFFSET_StgRegTable_rR10 dflags
baseRegOffset _ (VanillaReg n _) = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")
baseRegOffset dflags (FloatReg 1) = oFFSET_StgRegTable_rF1 dflags
baseRegOffset dflags (FloatReg 2) = oFFSET_StgRegTable_rF2 dflags
baseRegOffset dflags (FloatReg 3) = oFFSET_StgRegTable_rF3 dflags
baseRegOffset dflags (FloatReg 4) = oFFSET_StgRegTable_rF4 dflags
baseRegOffset _ (FloatReg n) = panic ("Registers above F4 are not supported (tried to use F" ++ show n ++ ")")
baseRegOffset dflags (DoubleReg 1) = oFFSET_StgRegTable_rD1 dflags
baseRegOffset dflags (DoubleReg 2) = oFFSET_StgRegTable_rD2 dflags
baseRegOffset _ (DoubleReg n) = panic ("Registers above D2 are not supported (tried to use D" ++ show n ++ ")")
baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags
baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags
baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags
baseRegOffset _ (LongReg n) = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")
baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags
baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags
baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags
baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags
baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags
baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags
baseRegOffset dflags EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo dflags
baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags
baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags
baseRegOffset _ BaseReg = panic "baseRegOffset:BaseReg"
baseRegOffset _ PicBaseReg = panic "baseRegOffset:PicBaseReg"
-- -----------------------------------------------------------------------------
--
-- STG/Cmm GlobalReg
--
-- -----------------------------------------------------------------------------
-- | We map STG registers onto appropriate CmmExprs. Either they map
-- to real machine registers or stored as offsets from BaseReg. Given
-- a GlobalReg, get_GlobalReg_addr always produces the
-- register table address for it.
get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr
get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0
get_GlobalReg_addr dflags mid
= get_Regtable_addr_from_offset dflags
(globalRegType dflags mid) (baseRegOffset dflags mid)
-- Calculate a literal representing an offset into the register table.
-- Used when we don't have an actual BaseReg to offset from.
regTableOffset :: DynFlags -> Int -> CmmExpr
regTableOffset dflags n =
CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))
get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
get_Regtable_addr_from_offset dflags _ offset =
if haveRegBase (targetPlatform dflags)
then CmmRegOff (CmmGlobal BaseReg) offset
else regTableOffset dflags offset
-- | Fixup global registers so that they assign to locations within the
-- RegTable if they aren't pinned for the current target.
fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl
fixStgRegisters _ top@(CmmData _ _) = top
fixStgRegisters dflags (CmmProc info lbl (ListGraph blocks)) =
let blocks' = map (fixStgRegBlock dflags) blocks
in CmmProc info lbl $ ListGraph blocks'
fixStgRegBlock :: DynFlags -> CmmBasicBlock -> CmmBasicBlock
fixStgRegBlock dflags (BasicBlock id stmts) =
let stmts' = map (fixStgRegStmt dflags) stmts
in BasicBlock id stmts'
fixStgRegStmt :: DynFlags -> CmmStmt -> CmmStmt
fixStgRegStmt dflags stmt
= case stmt of
CmmAssign (CmmGlobal reg) src ->
let src' = fixStgRegExpr dflags src
baseAddr = get_GlobalReg_addr dflags reg
in case reg `elem` activeStgRegs platform of
True -> CmmAssign (CmmGlobal reg) src'
False -> CmmStore baseAddr src'
CmmAssign reg src ->
let src' = fixStgRegExpr dflags src
in CmmAssign reg src'
CmmStore addr src -> CmmStore (fixStgRegExpr dflags addr) (fixStgRegExpr dflags src)
CmmCall target regs args returns ->
let target' = case target of
CmmCallee e conv -> CmmCallee (fixStgRegExpr dflags e) conv
CmmPrim op mStmts ->
CmmPrim op (fmap (map (fixStgRegStmt dflags)) mStmts)
args' = map (\(CmmHinted arg hint) ->
(CmmHinted (fixStgRegExpr dflags arg) hint)) args
in CmmCall target' regs args' returns
CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr dflags test) dest
CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr dflags expr) ids
CmmJump addr live -> CmmJump (fixStgRegExpr dflags addr) live
-- CmmNop, CmmComment, CmmBranch, CmmReturn
_other -> stmt
where platform = targetPlatform dflags
fixStgRegExpr :: DynFlags -> CmmExpr -> CmmExpr
fixStgRegExpr dflags expr
= case expr of
CmmLoad addr ty -> CmmLoad (fixStgRegExpr dflags addr) ty
CmmMachOp mop args -> CmmMachOp mop args'
where args' = map (fixStgRegExpr dflags) args
CmmReg (CmmGlobal reg) ->
-- Replace register leaves with appropriate StixTrees for
-- the given target. MagicIds which map to a reg on this
-- arch are left unchanged. For the rest, BaseReg is taken
-- to mean the address of the reg table in MainCapability,
-- and for all others we generate an indirection to its
-- location in the register table.
case reg `elem` activeStgRegs platform of
True -> expr
False ->
let baseAddr = get_GlobalReg_addr dflags reg
in case reg of
BaseReg -> fixStgRegExpr dflags baseAddr
_other -> fixStgRegExpr dflags
(CmmLoad baseAddr (globalRegType dflags reg))
CmmRegOff (CmmGlobal reg) offset ->
-- RegOf leaves are just a shorthand form. If the reg maps
-- to a real reg, we keep the shorthand, otherwise, we just
-- expand it and defer to the above code.
case reg `elem` activeStgRegs platform of
True -> expr
False -> fixStgRegExpr dflags (CmmMachOp (MO_Add (wordWidth dflags)) [
CmmReg (CmmGlobal reg),
CmmLit (CmmInt (fromIntegral offset)
(wordWidth dflags))])
-- CmmLit, CmmReg (CmmLocal), CmmStackSlot
_other -> expr
where platform = targetPlatform dflags
|
