Merge in new code generator branch.
[ghc.git] / compiler / codeGen / CgUtils.hs
1 {-# OPTIONS -w #-}
2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
6 -- for details
7
8 -----------------------------------------------------------------------------
9 --
10 -- Code generator utilities; mostly monadic
11 --
12 -- (c) The University of Glasgow 2004-2006
13 --
14 -----------------------------------------------------------------------------
15
16 module CgUtils (
17 addIdReps,
18 cgLit,
19 emitDataLits, mkDataLits,
20 emitRODataLits, mkRODataLits,
21 emitIf, emitIfThenElse,
22 emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
23 assignTemp, newTemp,
24 emitSimultaneously,
25 emitSwitch, emitLitSwitch,
26 tagToClosure,
27
28 callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
29 activeStgRegs, fixStgRegisters,
30
31 cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
32 cmmUGtWord,
33 cmmOffsetExprW, cmmOffsetExprB,
34 cmmRegOffW, cmmRegOffB,
35 cmmLabelOffW, cmmLabelOffB,
36 cmmOffsetW, cmmOffsetB,
37 cmmOffsetLitW, cmmOffsetLitB,
38 cmmLoadIndexW,
39 cmmConstrTag, cmmConstrTag1,
40
41 tagForCon, tagCons, isSmallFamily,
42 cmmUntag, cmmIsTagged, cmmGetTag,
43
44 addToMem, addToMemE,
45 mkWordCLit,
46 mkStringCLit, mkByteStringCLit,
47 packHalfWordsCLit,
48 blankWord,
49
50 getSRTInfo, clHasCafRefs
51 ) where
52
53 #include "HsVersions.h"
54 #include "../includes/stg/MachRegs.h"
55
56 import BlockId
57 import CgMonad
58 import TyCon
59 import DataCon
60 import Id
61 import IdInfo
62 import Constants
63 import SMRep
64 import OldCmm
65 import OldCmmUtils
66 import CLabel
67 import ForeignCall
68 import ClosureInfo
69 import StgSyn (SRT(..))
70 import Module
71 import Literal
72 import Digraph
73 import ListSetOps
74 import Util
75 import DynFlags
76 import FastString
77 import PackageConfig
78 import Outputable
79
80 import Data.Char
81 import Data.Bits
82 import Data.Word
83 import Data.Maybe
84
85 -------------------------------------------------------------------------
86 --
87 -- Random small functions
88 --
89 -------------------------------------------------------------------------
90
91 addIdReps :: [Id] -> [(CgRep, Id)]
92 addIdReps ids = [(idCgRep id, id) | id <- ids]
93
94 -------------------------------------------------------------------------
95 --
96 -- Literals
97 --
98 -------------------------------------------------------------------------
99
100 cgLit :: Literal -> FCode CmmLit
101 cgLit (MachStr s) = mkByteStringCLit (bytesFS s)
102 -- not unpackFS; we want the UTF-8 byte stream.
103 cgLit other_lit = return (mkSimpleLit other_lit)
104
105 mkSimpleLit :: Literal -> CmmLit
106 mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth
107 mkSimpleLit MachNullAddr = zeroCLit
108 mkSimpleLit (MachInt i) = CmmInt i wordWidth
109 mkSimpleLit (MachInt64 i) = CmmInt i W64
110 mkSimpleLit (MachWord i) = CmmInt i wordWidth
111 mkSimpleLit (MachWord64 i) = CmmInt i W64
112 mkSimpleLit (MachFloat r) = CmmFloat r W32
113 mkSimpleLit (MachDouble r) = CmmFloat r W64
114 mkSimpleLit (MachLabel fs ms fod)
115 = CmmLabel (mkForeignLabel fs ms labelSrc fod)
116 where
117 -- TODO: Literal labels might not actually be in the current package...
118 labelSrc = ForeignLabelInThisPackage
119
120 mkLtOp :: Literal -> MachOp
121 -- On signed literals we must do a signed comparison
122 mkLtOp (MachInt _) = MO_S_Lt wordWidth
123 mkLtOp (MachFloat _) = MO_F_Lt W32
124 mkLtOp (MachDouble _) = MO_F_Lt W64
125 mkLtOp lit = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit)))
126
127
128 ---------------------------------------------------
129 --
130 -- Cmm data type functions
131 --
132 ---------------------------------------------------
133
134 -----------------------
135 -- The "B" variants take byte offsets
136 cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
137 cmmRegOffB = cmmRegOff
138
139 cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr
140 cmmOffsetB = cmmOffset
141
142 cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr
143 cmmOffsetExprB = cmmOffsetExpr
144
145 cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
146 cmmLabelOffB = cmmLabelOff
147
148 cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
149 cmmOffsetLitB = cmmOffsetLit
150
151 -----------------------
152 -- The "W" variants take word offsets
153 cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr
154 -- The second arg is a *word* offset; need to change it to bytes
155 cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n)
156 cmmOffsetExprW e wd_off = cmmIndexExpr wordWidth e wd_off
157
158 cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr
159 cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n)
160
161 cmmRegOffW :: CmmReg -> WordOff -> CmmExpr
162 cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE)
163
164 cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit
165 cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off)
166
167 cmmLabelOffW :: CLabel -> WordOff -> CmmLit
168 cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off)
169
170 cmmLoadIndexW :: CmmExpr -> Int -> CmmType -> CmmExpr
171 cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty
172
173 -----------------------
174 cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord :: CmmExpr -> CmmExpr -> CmmExpr
175 cmmOrWord e1 e2 = CmmMachOp mo_wordOr [e1, e2]
176 cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
177 cmmNeWord e1 e2 = CmmMachOp mo_wordNe [e1, e2]
178 cmmEqWord e1 e2 = CmmMachOp mo_wordEq [e1, e2]
179 cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
180 cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
181 cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
182 --cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
183 --cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
184 cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
185
186 cmmNegate :: CmmExpr -> CmmExpr
187 cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
188 cmmNegate e = CmmMachOp (MO_S_Neg (cmmExprWidth e)) [e]
189
190 blankWord :: CmmStatic
191 blankWord = CmmUninitialised wORD_SIZE
192
193 -- Tagging --
194 -- Tag bits mask
195 --cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
196 cmmTagMask = CmmLit (mkIntCLit tAG_MASK)
197 cmmPointerMask = CmmLit (mkIntCLit (complement tAG_MASK))
198
199 -- Used to untag a possibly tagged pointer
200 -- A static label need not be untagged
201 cmmUntag e@(CmmLit (CmmLabel _)) = e
202 -- Default case
203 cmmUntag e = (e `cmmAndWord` cmmPointerMask)
204
205 cmmGetTag e = (e `cmmAndWord` cmmTagMask)
206
207 -- Test if a closure pointer is untagged
208 cmmIsTagged e = (e `cmmAndWord` cmmTagMask)
209 `cmmNeWord` CmmLit zeroCLit
210
211 cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` (CmmLit (mkIntCLit 1))
212 -- Get constructor tag, but one based.
213 cmmConstrTag1 e = e `cmmAndWord` cmmTagMask
214
215 {-
216 The family size of a data type (the number of constructors)
217 can be either:
218 * small, if the family size < 2**tag_bits
219 * big, otherwise.
220
221 Small families can have the constructor tag in the tag
222 bits.
223 Big families only use the tag value 1 to represent
224 evaluatedness.
225 -}
226 isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
227
228 tagForCon con = tag
229 where
230 con_tag = dataConTagZ con
231 fam_size = tyConFamilySize (dataConTyCon con)
232 tag | isSmallFamily fam_size = con_tag + 1
233 | otherwise = 1
234
235 --Tag an expression, to do: refactor, this appears in some other module.
236 tagCons con expr = cmmOffsetB expr (tagForCon con)
237
238 -- Copied from CgInfoTbls.hs
239 -- We keep the *zero-indexed* tag in the srt_len field of the info
240 -- table of a data constructor.
241 dataConTagZ :: DataCon -> ConTagZ
242 dataConTagZ con = dataConTag con - fIRST_TAG
243
244 -----------------------
245 -- Making literals
246
247 mkWordCLit :: StgWord -> CmmLit
248 mkWordCLit wd = CmmInt (fromIntegral wd) wordWidth
249
250 packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit
251 -- Make a single word literal in which the lower_half_word is
252 -- at the lower address, and the upper_half_word is at the
253 -- higher address
254 -- ToDo: consider using half-word lits instead
255 -- but be careful: that's vulnerable when reversed
256 packHalfWordsCLit lower_half_word upper_half_word
257 #ifdef WORDS_BIGENDIAN
258 = mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)
259 .|. fromIntegral upper_half_word)
260 #else
261 = mkWordCLit ((fromIntegral lower_half_word)
262 .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS))
263 #endif
264
265 --------------------------------------------------------------------------
266 --
267 -- Incrementing a memory location
268 --
269 --------------------------------------------------------------------------
270
271 addToMem :: Width -- rep of the counter
272 -> CmmExpr -- Address
273 -> Int -- What to add (a word)
274 -> CmmStmt
275 addToMem width ptr n = addToMemE width ptr (CmmLit (CmmInt (toInteger n) width))
276
277 addToMemE :: Width -- rep of the counter
278 -> CmmExpr -- Address
279 -> CmmExpr -- What to add (a word-typed expression)
280 -> CmmStmt
281 addToMemE width ptr n
282 = CmmStore ptr (CmmMachOp (MO_Add width) [CmmLoad ptr (cmmBits width), n])
283
284 -------------------------------------------------------------------------
285 --
286 -- Converting a closure tag to a closure for enumeration types
287 -- (this is the implementation of tagToEnum#).
288 --
289 -------------------------------------------------------------------------
290
291 tagToClosure :: TyCon -> CmmExpr -> CmmExpr
292 tagToClosure tycon tag
293 = CmmLoad (cmmOffsetExprW closure_tbl tag) gcWord
294 where closure_tbl = CmmLit (CmmLabel lbl)
295 lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
296
297 -------------------------------------------------------------------------
298 --
299 -- Conditionals and rts calls
300 --
301 -------------------------------------------------------------------------
302
303 emitIf :: CmmExpr -- Boolean
304 -> Code -- Then part
305 -> Code
306 -- Emit (if e then x)
307 -- ToDo: reverse the condition to avoid the extra branch instruction if possible
308 -- (some conditionals aren't reversible. eg. floating point comparisons cannot
309 -- be inverted because there exist some values for which both comparisons
310 -- return False, such as NaN.)
311 emitIf cond then_part
312 = do { then_id <- newLabelC
313 ; join_id <- newLabelC
314 ; stmtC (CmmCondBranch cond then_id)
315 ; stmtC (CmmBranch join_id)
316 ; labelC then_id
317 ; then_part
318 ; labelC join_id
319 }
320
321 emitIfThenElse :: CmmExpr -- Boolean
322 -> Code -- Then part
323 -> Code -- Else part
324 -> Code
325 -- Emit (if e then x else y)
326 emitIfThenElse cond then_part else_part
327 = do { then_id <- newLabelC
328 ; join_id <- newLabelC
329 ; stmtC (CmmCondBranch cond then_id)
330 ; else_part
331 ; stmtC (CmmBranch join_id)
332 ; labelC then_id
333 ; then_part
334 ; labelC join_id
335 }
336
337
338 -- | Emit code to call a Cmm function.
339 emitRtsCall
340 :: PackageId -- ^ package the function is in
341 -> FastString -- ^ name of function
342 -> [CmmHinted CmmExpr] -- ^ function args
343 -> Bool -- ^ whether this is a safe call
344 -> Code -- ^ cmm code
345
346 emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe
347 -- The 'Nothing' says "save all global registers"
348
349 emitRtsCallWithVols :: PackageId -> FastString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code
350 emitRtsCallWithVols pkg fun args vols safe
351 = emitRtsCall' [] pkg fun args (Just vols) safe
352
353 emitRtsCallWithResult
354 :: LocalReg -> ForeignHint
355 -> PackageId -> FastString
356 -> [CmmHinted CmmExpr] -> Bool -> Code
357 emitRtsCallWithResult res hint pkg fun args safe
358 = emitRtsCall' [CmmHinted res hint] pkg fun args Nothing safe
359
360 -- Make a call to an RTS C procedure
361 emitRtsCall'
362 :: [CmmHinted LocalReg]
363 -> PackageId
364 -> FastString
365 -> [CmmHinted CmmExpr]
366 -> Maybe [GlobalReg]
367 -> Bool -- True <=> CmmSafe call
368 -> Code
369 emitRtsCall' res pkg fun args vols safe = do
370 safety <- if safe
371 then getSRTInfo >>= (return . CmmSafe)
372 else return CmmUnsafe
373 stmtsC caller_save
374 stmtC (CmmCall target res args safety CmmMayReturn)
375 stmtsC caller_load
376 where
377 (caller_save, caller_load) = callerSaveVolatileRegs vols
378 target = CmmCallee fun_expr CCallConv
379 fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
380
381 -----------------------------------------------------------------------------
382 --
383 -- Caller-Save Registers
384 --
385 -----------------------------------------------------------------------------
386
387 -- Here we generate the sequence of saves/restores required around a
388 -- foreign call instruction.
389
390 -- TODO: reconcile with includes/Regs.h
391 -- * Regs.h claims that BaseReg should be saved last and loaded first
392 -- * This might not have been tickled before since BaseReg is callee save
393 -- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
394 callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt])
395 callerSaveVolatileRegs vols = (caller_save, caller_load)
396 where
397 caller_save = foldr ($!) [] (map callerSaveGlobalReg regs_to_save)
398 caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save)
399
400 system_regs = [Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery,
401 {-SparkHd,SparkTl,SparkBase,SparkLim,-}BaseReg ]
402
403 regs_to_save = system_regs ++ vol_list
404
405 vol_list = case vols of Nothing -> all_of_em; Just regs -> regs
406
407 all_of_em = [ VanillaReg n VNonGcPtr | n <- [0..mAX_Vanilla_REG] ]
408 -- The VNonGcPtr is a lie, but I don't think it matters
409 ++ [ FloatReg n | n <- [0..mAX_Float_REG] ]
410 ++ [ DoubleReg n | n <- [0..mAX_Double_REG] ]
411 ++ [ LongReg n | n <- [0..mAX_Long_REG] ]
412
413 callerSaveGlobalReg reg next
414 | callerSaves reg =
415 CmmStore (get_GlobalReg_addr reg)
416 (CmmReg (CmmGlobal reg)) : next
417 | otherwise = next
418
419 callerRestoreGlobalReg reg next
420 | callerSaves reg =
421 CmmAssign (CmmGlobal reg)
422 (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
423 : next
424 | otherwise = next
425
426
427 -- | Returns @True@ if this global register is stored in a caller-saves
428 -- machine register.
429
430 callerSaves :: GlobalReg -> Bool
431
432 #ifdef CALLER_SAVES_Base
433 callerSaves BaseReg = True
434 #endif
435 #ifdef CALLER_SAVES_R1
436 callerSaves (VanillaReg 1 _) = True
437 #endif
438 #ifdef CALLER_SAVES_R2
439 callerSaves (VanillaReg 2 _) = True
440 #endif
441 #ifdef CALLER_SAVES_R3
442 callerSaves (VanillaReg 3 _) = True
443 #endif
444 #ifdef CALLER_SAVES_R4
445 callerSaves (VanillaReg 4 _) = True
446 #endif
447 #ifdef CALLER_SAVES_R5
448 callerSaves (VanillaReg 5 _) = True
449 #endif
450 #ifdef CALLER_SAVES_R6
451 callerSaves (VanillaReg 6 _) = True
452 #endif
453 #ifdef CALLER_SAVES_R7
454 callerSaves (VanillaReg 7 _) = True
455 #endif
456 #ifdef CALLER_SAVES_R8
457 callerSaves (VanillaReg 8 _) = True
458 #endif
459 #ifdef CALLER_SAVES_F1
460 callerSaves (FloatReg 1) = True
461 #endif
462 #ifdef CALLER_SAVES_F2
463 callerSaves (FloatReg 2) = True
464 #endif
465 #ifdef CALLER_SAVES_F3
466 callerSaves (FloatReg 3) = True
467 #endif
468 #ifdef CALLER_SAVES_F4
469 callerSaves (FloatReg 4) = True
470 #endif
471 #ifdef CALLER_SAVES_D1
472 callerSaves (DoubleReg 1) = True
473 #endif
474 #ifdef CALLER_SAVES_D2
475 callerSaves (DoubleReg 2) = True
476 #endif
477 #ifdef CALLER_SAVES_L1
478 callerSaves (LongReg 1) = True
479 #endif
480 #ifdef CALLER_SAVES_Sp
481 callerSaves Sp = True
482 #endif
483 #ifdef CALLER_SAVES_SpLim
484 callerSaves SpLim = True
485 #endif
486 #ifdef CALLER_SAVES_Hp
487 callerSaves Hp = True
488 #endif
489 #ifdef CALLER_SAVES_HpLim
490 callerSaves HpLim = True
491 #endif
492 #ifdef CALLER_SAVES_CurrentTSO
493 callerSaves CurrentTSO = True
494 #endif
495 #ifdef CALLER_SAVES_CurrentNursery
496 callerSaves CurrentNursery = True
497 #endif
498 callerSaves _ = False
499
500
501 -- -----------------------------------------------------------------------------
502 -- Information about global registers
503
504 baseRegOffset :: GlobalReg -> Int
505
506 baseRegOffset (VanillaReg 1 _) = oFFSET_StgRegTable_rR1
507 baseRegOffset (VanillaReg 2 _) = oFFSET_StgRegTable_rR2
508 baseRegOffset (VanillaReg 3 _) = oFFSET_StgRegTable_rR3
509 baseRegOffset (VanillaReg 4 _) = oFFSET_StgRegTable_rR4
510 baseRegOffset (VanillaReg 5 _) = oFFSET_StgRegTable_rR5
511 baseRegOffset (VanillaReg 6 _) = oFFSET_StgRegTable_rR6
512 baseRegOffset (VanillaReg 7 _) = oFFSET_StgRegTable_rR7
513 baseRegOffset (VanillaReg 8 _) = oFFSET_StgRegTable_rR8
514 baseRegOffset (VanillaReg 9 _) = oFFSET_StgRegTable_rR9
515 baseRegOffset (VanillaReg 10 _) = oFFSET_StgRegTable_rR10
516 baseRegOffset (FloatReg 1) = oFFSET_StgRegTable_rF1
517 baseRegOffset (FloatReg 2) = oFFSET_StgRegTable_rF2
518 baseRegOffset (FloatReg 3) = oFFSET_StgRegTable_rF3
519 baseRegOffset (FloatReg 4) = oFFSET_StgRegTable_rF4
520 baseRegOffset (DoubleReg 1) = oFFSET_StgRegTable_rD1
521 baseRegOffset (DoubleReg 2) = oFFSET_StgRegTable_rD2
522 baseRegOffset Sp = oFFSET_StgRegTable_rSp
523 baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim
524 baseRegOffset (LongReg 1) = oFFSET_StgRegTable_rL1
525 baseRegOffset Hp = oFFSET_StgRegTable_rHp
526 baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim
527 baseRegOffset CurrentTSO = oFFSET_StgRegTable_rCurrentTSO
528 baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery
529 baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc
530 baseRegOffset EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo
531 baseRegOffset GCEnter1 = oFFSET_stgGCEnter1
532 baseRegOffset GCFun = oFFSET_stgGCFun
533 baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
534 baseRegOffset _ = panic "baseRegOffset:other"
535
536
537 -------------------------------------------------------------------------
538 --
539 -- Strings generate a top-level data block
540 --
541 -------------------------------------------------------------------------
542
543 emitDataLits :: CLabel -> [CmmLit] -> Code
544 -- Emit a data-segment data block
545 emitDataLits lbl lits
546 = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
547
548 mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
549 -- Emit a data-segment data block
550 mkDataLits lbl lits
551 = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
552
553 emitRODataLits :: String -> CLabel -> [CmmLit] -> Code
554 -- Emit a read-only data block
555 emitRODataLits caller lbl lits
556 = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
557 where section | any needsRelocation lits = RelocatableReadOnlyData
558 | otherwise = ReadOnlyData
559 needsRelocation (CmmLabel _) = True
560 needsRelocation (CmmLabelOff _ _) = True
561 needsRelocation _ = False
562
563 mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
564 mkRODataLits lbl lits
565 = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
566 where section | any needsRelocation lits = RelocatableReadOnlyData
567 | otherwise = ReadOnlyData
568 needsRelocation (CmmLabel _) = True
569 needsRelocation (CmmLabelOff _ _) = True
570 needsRelocation _ = False
571
572 mkStringCLit :: String -> FCode CmmLit
573 -- Make a global definition for the string,
574 -- and return its label
575 mkStringCLit str = mkByteStringCLit (map (fromIntegral.ord) str)
576
577 mkByteStringCLit :: [Word8] -> FCode CmmLit
578 mkByteStringCLit bytes
579 = do { uniq <- newUnique
580 ; let lbl = mkStringLitLabel uniq
581 ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
582 ; return (CmmLabel lbl) }
583
584 -------------------------------------------------------------------------
585 --
586 -- Assigning expressions to temporaries
587 --
588 -------------------------------------------------------------------------
589
590 assignTemp :: CmmExpr -> FCode CmmExpr
591 -- For a non-trivial expression, e, create a local
592 -- variable and assign the expression to it
593 assignTemp e
594 | isTrivialCmmExpr e = return e
595 | otherwise = do { reg <- newTemp (cmmExprType e)
596 ; stmtC (CmmAssign (CmmLocal reg) e)
597 ; return (CmmReg (CmmLocal reg)) }
598
599 newTemp :: CmmType -> FCode LocalReg
600 newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) }
601
602 -------------------------------------------------------------------------
603 --
604 -- Building case analysis
605 --
606 -------------------------------------------------------------------------
607
608 emitSwitch
609 :: CmmExpr -- Tag to switch on
610 -> [(ConTagZ, CgStmts)] -- Tagged branches
611 -> Maybe CgStmts -- Default branch (if any)
612 -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
613 -- outside this range is undefined
614 -> Code
615
616 -- ONLY A DEFAULT BRANCH: no case analysis to do
617 emitSwitch tag_expr [] (Just stmts) _ _
618 = emitCgStmts stmts
619
620 -- Right, off we go
621 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
622 = -- Just sort the branches before calling mk_sritch
623 do { mb_deflt_id <-
624 case mb_deflt of
625 Nothing -> return Nothing
626 Just stmts -> do id <- forkCgStmts stmts; return (Just id)
627
628 ; dflags <- getDynFlags
629 ; let via_C | HscC <- hscTarget dflags = True
630 | otherwise = False
631
632 ; stmts <- mk_switch tag_expr (sortLe le branches)
633 mb_deflt_id lo_tag hi_tag via_C
634 ; emitCgStmts stmts
635 }
636 where
637 (t1,_) `le` (t2,_) = t1 <= t2
638
639
640 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
641 -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
642 -> FCode CgStmts
643
644 -- SINGLETON TAG RANGE: no case analysis to do
645 mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C
646 | lo_tag == hi_tag
647 = ASSERT( tag == lo_tag )
648 return stmts
649
650 -- SINGLETON BRANCH, NO DEFUALT: no case analysis to do
651 mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag via_C
652 = return stmts
653 -- The simplifier might have eliminated a case
654 -- so we may have e.g. case xs of
655 -- [] -> e
656 -- In that situation we can be sure the (:) case
657 -- can't happen, so no need to test
658
659 -- SINGLETON BRANCH: one equality check to do
660 mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C
661 = return (CmmCondBranch cond deflt `consCgStmt` stmts)
662 where
663 cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
664 -- We have lo_tag < hi_tag, but there's only one branch,
665 -- so there must be a default
666
667 -- ToDo: we might want to check for the two branch case, where one of
668 -- the branches is the tag 0, because comparing '== 0' is likely to be
669 -- more efficient than other kinds of comparison.
670
671 -- DENSE TAG RANGE: use a switch statment.
672 --
673 -- We also use a switch uncoditionally when compiling via C, because
674 -- this will get emitted as a C switch statement and the C compiler
675 -- should do a good job of optimising it. Also, older GCC versions
676 -- (2.95 in particular) have problems compiling the complicated
677 -- if-trees generated by this code, so compiling to a switch every
678 -- time works around that problem.
679 --
680 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
681 | use_switch -- Use a switch
682 = do { branch_ids <- mapM forkCgStmts (map snd branches)
683 ; let
684 tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
685
686 find_branch :: ConTagZ -> Maybe BlockId
687 find_branch i = assocDefault mb_deflt tagged_blk_ids i
688
689 -- NB. we have eliminated impossible branches at
690 -- either end of the range (see below), so the first
691 -- tag of a real branch is real_lo_tag (not lo_tag).
692 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
693
694 switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
695
696 ; ASSERT(not (all isNothing arms))
697 return (oneCgStmt switch_stmt)
698 }
699
700 -- if we can knock off a bunch of default cases with one if, then do so
701 | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
702 = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
703 ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
704 branch = CmmCondBranch cond deflt
705 ; stmts <- mk_switch tag_expr' branches mb_deflt
706 lowest_branch hi_tag via_C
707 ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
708 }
709
710 | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
711 = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
712 ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
713 branch = CmmCondBranch cond deflt
714 ; stmts <- mk_switch tag_expr' branches mb_deflt
715 lo_tag highest_branch via_C
716 ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
717 }
718
719 | otherwise -- Use an if-tree
720 = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
721 -- To avoid duplication
722 ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
723 lo_tag (mid_tag-1) via_C
724 ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
725 mid_tag hi_tag via_C
726 ; hi_id <- forkCgStmts hi_stmts
727 ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
728 branch_stmt = CmmCondBranch cond hi_id
729 ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
730 }
731 -- we test (e >= mid_tag) rather than (e < mid_tag), because
732 -- the former works better when e is a comparison, and there
733 -- are two tags 0 & 1 (mid_tag == 1). In this case, the code
734 -- generator can reduce the condition to e itself without
735 -- having to reverse the sense of the comparison: comparisons
736 -- can't always be easily reversed (eg. floating
737 -- pt. comparisons).
738 where
739 use_switch = {- pprTrace "mk_switch" (
740 ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
741 text "branches:" <+> ppr (map fst branches) <+>
742 text "n_branches:" <+> int n_branches <+>
743 text "lo_tag:" <+> int lo_tag <+>
744 text "hi_tag:" <+> int hi_tag <+>
745 text "real_lo_tag:" <+> int real_lo_tag <+>
746 text "real_hi_tag:" <+> int real_hi_tag) $ -}
747 ASSERT( n_branches > 1 && n_tags > 1 )
748 n_tags > 2 && (via_C || (dense && big_enough))
749 -- up to 4 branches we use a decision tree, otherwise
750 -- a switch (== jump table in the NCG). This seems to be
751 -- optimal, and corresponds with what gcc does.
752 big_enough = n_branches > 4
753 dense = n_branches > (n_tags `div` 2)
754 n_branches = length branches
755
756 -- ignore default slots at each end of the range if there's
757 -- no default branch defined.
758 lowest_branch = fst (head branches)
759 highest_branch = fst (last branches)
760
761 real_lo_tag
762 | isNothing mb_deflt = lowest_branch
763 | otherwise = lo_tag
764
765 real_hi_tag
766 | isNothing mb_deflt = highest_branch
767 | otherwise = hi_tag
768
769 n_tags = real_hi_tag - real_lo_tag + 1
770
771 -- INVARIANT: Provided hi_tag > lo_tag (which is true)
772 -- lo_tag <= mid_tag < hi_tag
773 -- lo_branches have tags < mid_tag
774 -- hi_branches have tags >= mid_tag
775
776 (mid_tag,_) = branches !! (n_branches `div` 2)
777 -- 2 branches => n_branches `div` 2 = 1
778 -- => branches !! 1 give the *second* tag
779 -- There are always at least 2 branches here
780
781 (lo_branches, hi_branches) = span is_lo branches
782 is_lo (t,_) = t < mid_tag
783
784
785 assignTemp' e
786 | isTrivialCmmExpr e = return (CmmNop, e)
787 | otherwise = do { reg <- newTemp (cmmExprType e)
788 ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
789
790 emitLitSwitch :: CmmExpr -- Tag to switch on
791 -> [(Literal, CgStmts)] -- Tagged branches
792 -> CgStmts -- Default branch (always)
793 -> Code -- Emit the code
794 -- Used for general literals, whose size might not be a word,
795 -- where there is always a default case, and where we don't know
796 -- the range of values for certain. For simplicity we always generate a tree.
797 --
798 -- ToDo: for integers we could do better here, perhaps by generalising
799 -- mk_switch and using that. --SDM 15/09/2004
800 emitLitSwitch scrut [] deflt
801 = emitCgStmts deflt
802 emitLitSwitch scrut branches deflt_blk
803 = do { scrut' <- assignTemp scrut
804 ; deflt_blk_id <- forkCgStmts deflt_blk
805 ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
806 ; emitCgStmts blk }
807 where
808 le (t1,_) (t2,_) = t1 <= t2
809
810 mk_lit_switch :: CmmExpr -> BlockId
811 -> [(Literal,CgStmts)]
812 -> FCode CgStmts
813 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
814 = return (consCgStmt if_stmt blk)
815 where
816 cmm_lit = mkSimpleLit lit
817 rep = cmmLitType cmm_lit
818 ne = if isFloatType rep then MO_F_Ne else MO_Ne
819 cond = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit]
820 if_stmt = CmmCondBranch cond deflt_blk_id
821
822 mk_lit_switch scrut deflt_blk_id branches
823 = do { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
824 ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
825 ; lo_blk_id <- forkCgStmts lo_blk
826 ; let if_stmt = CmmCondBranch cond lo_blk_id
827 ; return (if_stmt `consCgStmt` hi_blk) }
828 where
829 n_branches = length branches
830 (mid_lit,_) = branches !! (n_branches `div` 2)
831 -- See notes above re mid_tag
832
833 (lo_branches, hi_branches) = span is_lo branches
834 is_lo (t,_) = t < mid_lit
835
836 cond = CmmMachOp (mkLtOp mid_lit)
837 [scrut, CmmLit (mkSimpleLit mid_lit)]
838
839 -------------------------------------------------------------------------
840 --
841 -- Simultaneous assignment
842 --
843 -------------------------------------------------------------------------
844
845
846 emitSimultaneously :: CmmStmts -> Code
847 -- Emit code to perform the assignments in the
848 -- input simultaneously, using temporary variables when necessary.
849 --
850 -- The Stmts must be:
851 -- CmmNop, CmmComment, CmmAssign, CmmStore
852 -- and nothing else
853
854
855 -- We use the strongly-connected component algorithm, in which
856 -- * the vertices are the statements
857 -- * an edge goes from s1 to s2 iff
858 -- s1 assigns to something s2 uses
859 -- that is, if s1 should *follow* s2 in the final order
860
861 type CVertex = (Int, CmmStmt) -- Give each vertex a unique number,
862 -- for fast comparison
863
864 emitSimultaneously stmts
865 = codeOnly $
866 case filterOut isNopStmt (stmtList stmts) of
867 -- Remove no-ops
868 [] -> nopC
869 [stmt] -> stmtC stmt -- It's often just one stmt
870 stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
871
872 doSimultaneously1 :: [CVertex] -> Code
873 doSimultaneously1 vertices
874 = let
875 edges = [ (vertex, key1, edges_from stmt1)
876 | vertex@(key1, stmt1) <- vertices
877 ]
878 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
879 stmt1 `mustFollow` stmt2
880 ]
881 components = stronglyConnCompFromEdgedVertices edges
882
883 -- do_components deal with one strongly-connected component
884 -- Not cyclic, or singleton? Just do it
885 do_component (AcyclicSCC (n,stmt)) = stmtC stmt
886 do_component (CyclicSCC [(n,stmt)]) = stmtC stmt
887
888 -- Cyclic? Then go via temporaries. Pick one to
889 -- break the loop and try again with the rest.
890 do_component (CyclicSCC ((n,first_stmt) : rest))
891 = do { from_temp <- go_via_temp first_stmt
892 ; doSimultaneously1 rest
893 ; stmtC from_temp }
894
895 go_via_temp (CmmAssign dest src)
896 = do { tmp <- newTemp (cmmRegType dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
897 ; stmtC (CmmAssign (CmmLocal tmp) src)
898 ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) }
899 go_via_temp (CmmStore dest src)
900 = do { tmp <- newTemp (cmmExprType src) -- TODO FIXME NOW if the pair of assignemnts move across a call this will be wrong
901 ; stmtC (CmmAssign (CmmLocal tmp) src)
902 ; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
903 in
904 mapCs do_component components
905
906 mustFollow :: CmmStmt -> CmmStmt -> Bool
907 CmmAssign reg _ `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
908 CmmStore loc e `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprType e)) stmt
909 CmmNop `mustFollow` stmt = False
910 CmmComment _ `mustFollow` stmt = False
911
912
913 anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool
914 -- True if the fn is true of any input of the stmt
915 anySrc p (CmmAssign _ e) = p e
916 anySrc p (CmmStore e1 e2) = p e1 || p e2 -- Might be used in either side
917 anySrc p (CmmComment _) = False
918 anySrc p CmmNop = False
919 anySrc p other = True -- Conservative
920
921 locUsedIn :: CmmExpr -> CmmType -> CmmExpr -> Bool
922 -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
923 -- 'e'. Returns True if it's not sure.
924 locUsedIn loc rep (CmmLit _) = False
925 locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
926 locUsedIn loc rep (CmmReg reg') = False
927 locUsedIn loc rep (CmmRegOff reg' _) = False
928 locUsedIn loc rep (CmmMachOp _ es) = any (locUsedIn loc rep) es
929
930 possiblySameLoc :: CmmExpr -> CmmType -> CmmExpr -> CmmType -> Bool
931 -- Assumes that distinct registers (eg Hp, Sp) do not
932 -- point to the same location, nor any offset thereof.
933 possiblySameLoc (CmmReg r1) rep1 (CmmReg r2) rep2 = r1==r2
934 possiblySameLoc (CmmReg r1) rep1 (CmmRegOff r2 0) rep2 = r1==r2
935 possiblySameLoc (CmmRegOff r1 0) rep1 (CmmReg r2) rep2 = r1==r2
936 possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
937 = r1==r2 && end1 > start2 && end2 > start1
938 where
939 end1 = start1 + widthInBytes (typeWidth rep1)
940 end2 = start2 + widthInBytes (typeWidth rep2)
941
942 possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
943 possiblySameLoc l1 rep1 l2 rep2 = True -- Conservative
944
945 -------------------------------------------------------------------------
946 --
947 -- Static Reference Tables
948 --
949 -------------------------------------------------------------------------
950
951 -- There is just one SRT for each top level binding; all the nested
952 -- bindings use sub-sections of this SRT. The label is passed down to
953 -- the nested bindings via the monad.
954
955 getSRTInfo :: FCode C_SRT
956 getSRTInfo = do
957 srt_lbl <- getSRTLabel
958 srt <- getSRT
959 case srt of
960 -- TODO: Should we panic in this case?
961 -- Someone obviously thinks there should be an SRT
962 NoSRT -> return NoC_SRT
963 SRTEntries {} -> panic "getSRTInfo: SRTEntries. Perhaps you forgot to run SimplStg?"
964 SRT off len bmp
965 | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
966 -> do id <- newUnique
967 let srt_desc_lbl = mkLargeSRTLabel id
968 emitRODataLits "getSRTInfo" srt_desc_lbl
969 ( cmmLabelOffW srt_lbl off
970 : mkWordCLit (fromIntegral len)
971 : map mkWordCLit bmp)
972 return (C_SRT srt_desc_lbl 0 srt_escape)
973
974 SRT off len bmp
975 | otherwise
976 -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
977 -- The fromIntegral converts to StgHalfWord
978
979 srt_escape = (-1) :: StgHalfWord
980
981 clHasCafRefs :: ClosureInfo -> CafInfo
982 clHasCafRefs (ClosureInfo {closureSRT = srt}) =
983 case srt of NoC_SRT -> NoCafRefs
984 _ -> MayHaveCafRefs
985 clHasCafRefs (ConInfo {}) = NoCafRefs
986
987 -- -----------------------------------------------------------------------------
988 --
989 -- STG/Cmm GlobalReg
990 --
991 -- -----------------------------------------------------------------------------
992
993 -- | Here is where the STG register map is defined for each target arch.
994 -- The order matters (for the llvm backend anyway)! We must make sure to
995 -- maintain the order here with the order used in the LLVM calling conventions.
996 -- Note that also, this isn't all registers, just the ones that are currently
997 -- possbily mapped to real registers.
998 activeStgRegs :: [GlobalReg]
999 activeStgRegs = [
1000 #ifdef REG_Base
1001 BaseReg
1002 #endif
1003 #ifdef REG_Sp
1004 ,Sp
1005 #endif
1006 #ifdef REG_Hp
1007 ,Hp
1008 #endif
1009 #ifdef REG_R1
1010 ,VanillaReg 1 VGcPtr
1011 #endif
1012 #ifdef REG_R2
1013 ,VanillaReg 2 VGcPtr
1014 #endif
1015 #ifdef REG_R3
1016 ,VanillaReg 3 VGcPtr
1017 #endif
1018 #ifdef REG_R4
1019 ,VanillaReg 4 VGcPtr
1020 #endif
1021 #ifdef REG_R5
1022 ,VanillaReg 5 VGcPtr
1023 #endif
1024 #ifdef REG_R6
1025 ,VanillaReg 6 VGcPtr
1026 #endif
1027 #ifdef REG_R7
1028 ,VanillaReg 7 VGcPtr
1029 #endif
1030 #ifdef REG_R8
1031 ,VanillaReg 8 VGcPtr
1032 #endif
1033 #ifdef REG_SpLim
1034 ,SpLim
1035 #endif
1036 #ifdef REG_F1
1037 ,FloatReg 1
1038 #endif
1039 #ifdef REG_F2
1040 ,FloatReg 2
1041 #endif
1042 #ifdef REG_F3
1043 ,FloatReg 3
1044 #endif
1045 #ifdef REG_F4
1046 ,FloatReg 4
1047 #endif
1048 #ifdef REG_D1
1049 ,DoubleReg 1
1050 #endif
1051 #ifdef REG_D2
1052 ,DoubleReg 2
1053 #endif
1054 ]
1055
1056 -- | We map STG registers onto appropriate CmmExprs. Either they map
1057 -- to real machine registers or stored as offsets from BaseReg. Given
1058 -- a GlobalReg, get_GlobalReg_addr always produces the
1059 -- register table address for it.
1060 get_GlobalReg_addr :: GlobalReg -> CmmExpr
1061 get_GlobalReg_addr BaseReg = regTableOffset 0
1062 get_GlobalReg_addr mid = get_Regtable_addr_from_offset
1063 (globalRegType mid) (baseRegOffset mid)
1064
1065 -- Calculate a literal representing an offset into the register table.
1066 -- Used when we don't have an actual BaseReg to offset from.
1067 regTableOffset n =
1068 CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
1069
1070 get_Regtable_addr_from_offset :: CmmType -> Int -> CmmExpr
1071 get_Regtable_addr_from_offset rep offset =
1072 #ifdef REG_Base
1073 CmmRegOff (CmmGlobal BaseReg) offset
1074 #else
1075 regTableOffset offset
1076 #endif
1077
1078 -- | Fixup global registers so that they assign to locations within the
1079 -- RegTable if they aren't pinned for the current target.
1080 fixStgRegisters :: RawCmmTop -> RawCmmTop
1081 fixStgRegisters top@(CmmData _ _) = top
1082
1083 fixStgRegisters (CmmProc info lbl (ListGraph blocks)) =
1084 let blocks' = map fixStgRegBlock blocks
1085 in CmmProc info lbl $ ListGraph blocks'
1086
1087 fixStgRegBlock :: CmmBasicBlock -> CmmBasicBlock
1088 fixStgRegBlock (BasicBlock id stmts) =
1089 let stmts' = map fixStgRegStmt stmts
1090 in BasicBlock id stmts'
1091
1092 fixStgRegStmt :: CmmStmt -> CmmStmt
1093 fixStgRegStmt stmt
1094 = case stmt of
1095 CmmAssign (CmmGlobal reg) src ->
1096 let src' = fixStgRegExpr src
1097 baseAddr = get_GlobalReg_addr reg
1098 in case reg `elem` activeStgRegs of
1099 True -> CmmAssign (CmmGlobal reg) src'
1100 False -> CmmStore baseAddr src'
1101
1102 CmmAssign reg src ->
1103 let src' = fixStgRegExpr src
1104 in CmmAssign reg src'
1105
1106 CmmStore addr src -> CmmStore (fixStgRegExpr addr) (fixStgRegExpr src)
1107
1108 CmmCall target regs args srt returns ->
1109 let target' = case target of
1110 CmmCallee e conv -> CmmCallee (fixStgRegExpr e) conv
1111 other -> other
1112 args' = map (\(CmmHinted arg hint) ->
1113 (CmmHinted (fixStgRegExpr arg) hint)) args
1114 in CmmCall target' regs args' srt returns
1115
1116 CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr test) dest
1117
1118 CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr expr) ids
1119
1120 CmmJump addr regs -> CmmJump (fixStgRegExpr addr) regs
1121
1122 -- CmmNop, CmmComment, CmmBranch, CmmReturn
1123 _other -> stmt
1124
1125
1126 fixStgRegExpr :: CmmExpr -> CmmExpr
1127 fixStgRegExpr expr
1128 = case expr of
1129 CmmLoad addr ty -> CmmLoad (fixStgRegExpr addr) ty
1130
1131 CmmMachOp mop args -> CmmMachOp mop args'
1132 where args' = map fixStgRegExpr args
1133
1134 CmmReg (CmmGlobal reg) ->
1135 -- Replace register leaves with appropriate StixTrees for
1136 -- the given target. MagicIds which map to a reg on this
1137 -- arch are left unchanged. For the rest, BaseReg is taken
1138 -- to mean the address of the reg table in MainCapability,
1139 -- and for all others we generate an indirection to its
1140 -- location in the register table.
1141 case reg `elem` activeStgRegs of
1142 True -> expr
1143 False ->
1144 let baseAddr = get_GlobalReg_addr reg
1145 in case reg of
1146 BaseReg -> fixStgRegExpr baseAddr
1147 _other -> fixStgRegExpr
1148 (CmmLoad baseAddr (globalRegType reg))
1149
1150 CmmRegOff (CmmGlobal reg) offset ->
1151 -- RegOf leaves are just a shorthand form. If the reg maps
1152 -- to a real reg, we keep the shorthand, otherwise, we just
1153 -- expand it and defer to the above code.
1154 case reg `elem` activeStgRegs of
1155 True -> expr
1156 False -> fixStgRegExpr (CmmMachOp (MO_Add wordWidth) [
1157 CmmReg (CmmGlobal reg),
1158 CmmLit (CmmInt (fromIntegral offset)
1159 wordWidth)])
1160
1161 -- CmmLit, CmmReg (CmmLocal), CmmStackSlot
1162 _other -> expr
1163