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