Merge branch 'master' of http://darcs.haskell.org/ghc into ghc-generics
[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 -- | Assign the expression to a temporary register and return an
605 -- expression referring to this register.
606 assignTemp_ :: CmmExpr -> FCode CmmExpr
607 assignTemp_ e = do
608 reg <- newTemp (cmmExprType e)
609 stmtC (CmmAssign (CmmLocal reg) e)
610 return (CmmReg (CmmLocal reg))
611
612 newTemp :: CmmType -> FCode LocalReg
613 newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) }
614
615 -------------------------------------------------------------------------
616 --
617 -- Building case analysis
618 --
619 -------------------------------------------------------------------------
620
621 emitSwitch
622 :: CmmExpr -- Tag to switch on
623 -> [(ConTagZ, CgStmts)] -- Tagged branches
624 -> Maybe CgStmts -- Default branch (if any)
625 -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
626 -- outside this range is undefined
627 -> Code
628
629 -- ONLY A DEFAULT BRANCH: no case analysis to do
630 emitSwitch tag_expr [] (Just stmts) _ _
631 = emitCgStmts stmts
632
633 -- Right, off we go
634 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
635 = -- Just sort the branches before calling mk_sritch
636 do { mb_deflt_id <-
637 case mb_deflt of
638 Nothing -> return Nothing
639 Just stmts -> do id <- forkCgStmts stmts; return (Just id)
640
641 ; dflags <- getDynFlags
642 ; let via_C | HscC <- hscTarget dflags = True
643 | otherwise = False
644
645 ; stmts <- mk_switch tag_expr (sortLe le branches)
646 mb_deflt_id lo_tag hi_tag via_C
647 ; emitCgStmts stmts
648 }
649 where
650 (t1,_) `le` (t2,_) = t1 <= t2
651
652
653 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
654 -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
655 -> FCode CgStmts
656
657 -- SINGLETON TAG RANGE: no case analysis to do
658 mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C
659 | lo_tag == hi_tag
660 = ASSERT( tag == lo_tag )
661 return stmts
662
663 -- SINGLETON BRANCH, NO DEFUALT: no case analysis to do
664 mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag via_C
665 = return stmts
666 -- The simplifier might have eliminated a case
667 -- so we may have e.g. case xs of
668 -- [] -> e
669 -- In that situation we can be sure the (:) case
670 -- can't happen, so no need to test
671
672 -- SINGLETON BRANCH: one equality check to do
673 mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C
674 = return (CmmCondBranch cond deflt `consCgStmt` stmts)
675 where
676 cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
677 -- We have lo_tag < hi_tag, but there's only one branch,
678 -- so there must be a default
679
680 -- ToDo: we might want to check for the two branch case, where one of
681 -- the branches is the tag 0, because comparing '== 0' is likely to be
682 -- more efficient than other kinds of comparison.
683
684 -- DENSE TAG RANGE: use a switch statment.
685 --
686 -- We also use a switch uncoditionally when compiling via C, because
687 -- this will get emitted as a C switch statement and the C compiler
688 -- should do a good job of optimising it. Also, older GCC versions
689 -- (2.95 in particular) have problems compiling the complicated
690 -- if-trees generated by this code, so compiling to a switch every
691 -- time works around that problem.
692 --
693 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
694 | use_switch -- Use a switch
695 = do { branch_ids <- mapM forkCgStmts (map snd branches)
696 ; let
697 tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
698
699 find_branch :: ConTagZ -> Maybe BlockId
700 find_branch i = assocDefault mb_deflt tagged_blk_ids i
701
702 -- NB. we have eliminated impossible branches at
703 -- either end of the range (see below), so the first
704 -- tag of a real branch is real_lo_tag (not lo_tag).
705 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
706
707 switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
708
709 ; ASSERT(not (all isNothing arms))
710 return (oneCgStmt switch_stmt)
711 }
712
713 -- if we can knock off a bunch of default cases with one if, then do so
714 | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
715 = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
716 ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
717 branch = CmmCondBranch cond deflt
718 ; stmts <- mk_switch tag_expr' branches mb_deflt
719 lowest_branch hi_tag via_C
720 ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
721 }
722
723 | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
724 = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
725 ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
726 branch = CmmCondBranch cond deflt
727 ; stmts <- mk_switch tag_expr' branches mb_deflt
728 lo_tag highest_branch via_C
729 ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
730 }
731
732 | otherwise -- Use an if-tree
733 = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
734 -- To avoid duplication
735 ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
736 lo_tag (mid_tag-1) via_C
737 ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
738 mid_tag hi_tag via_C
739 ; hi_id <- forkCgStmts hi_stmts
740 ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
741 branch_stmt = CmmCondBranch cond hi_id
742 ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
743 }
744 -- we test (e >= mid_tag) rather than (e < mid_tag), because
745 -- the former works better when e is a comparison, and there
746 -- are two tags 0 & 1 (mid_tag == 1). In this case, the code
747 -- generator can reduce the condition to e itself without
748 -- having to reverse the sense of the comparison: comparisons
749 -- can't always be easily reversed (eg. floating
750 -- pt. comparisons).
751 where
752 use_switch = {- pprTrace "mk_switch" (
753 ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
754 text "branches:" <+> ppr (map fst branches) <+>
755 text "n_branches:" <+> int n_branches <+>
756 text "lo_tag:" <+> int lo_tag <+>
757 text "hi_tag:" <+> int hi_tag <+>
758 text "real_lo_tag:" <+> int real_lo_tag <+>
759 text "real_hi_tag:" <+> int real_hi_tag) $ -}
760 ASSERT( n_branches > 1 && n_tags > 1 )
761 n_tags > 2 && (via_C || (dense && big_enough))
762 -- up to 4 branches we use a decision tree, otherwise
763 -- a switch (== jump table in the NCG). This seems to be
764 -- optimal, and corresponds with what gcc does.
765 big_enough = n_branches > 4
766 dense = n_branches > (n_tags `div` 2)
767 n_branches = length branches
768
769 -- ignore default slots at each end of the range if there's
770 -- no default branch defined.
771 lowest_branch = fst (head branches)
772 highest_branch = fst (last branches)
773
774 real_lo_tag
775 | isNothing mb_deflt = lowest_branch
776 | otherwise = lo_tag
777
778 real_hi_tag
779 | isNothing mb_deflt = highest_branch
780 | otherwise = hi_tag
781
782 n_tags = real_hi_tag - real_lo_tag + 1
783
784 -- INVARIANT: Provided hi_tag > lo_tag (which is true)
785 -- lo_tag <= mid_tag < hi_tag
786 -- lo_branches have tags < mid_tag
787 -- hi_branches have tags >= mid_tag
788
789 (mid_tag,_) = branches !! (n_branches `div` 2)
790 -- 2 branches => n_branches `div` 2 = 1
791 -- => branches !! 1 give the *second* tag
792 -- There are always at least 2 branches here
793
794 (lo_branches, hi_branches) = span is_lo branches
795 is_lo (t,_) = t < mid_tag
796
797
798 assignTemp' e
799 | isTrivialCmmExpr e = return (CmmNop, e)
800 | otherwise = do { reg <- newTemp (cmmExprType e)
801 ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
802
803 emitLitSwitch :: CmmExpr -- Tag to switch on
804 -> [(Literal, CgStmts)] -- Tagged branches
805 -> CgStmts -- Default branch (always)
806 -> Code -- Emit the code
807 -- Used for general literals, whose size might not be a word,
808 -- where there is always a default case, and where we don't know
809 -- the range of values for certain. For simplicity we always generate a tree.
810 --
811 -- ToDo: for integers we could do better here, perhaps by generalising
812 -- mk_switch and using that. --SDM 15/09/2004
813 emitLitSwitch scrut [] deflt
814 = emitCgStmts deflt
815 emitLitSwitch scrut branches deflt_blk
816 = do { scrut' <- assignTemp scrut
817 ; deflt_blk_id <- forkCgStmts deflt_blk
818 ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
819 ; emitCgStmts blk }
820 where
821 le (t1,_) (t2,_) = t1 <= t2
822
823 mk_lit_switch :: CmmExpr -> BlockId
824 -> [(Literal,CgStmts)]
825 -> FCode CgStmts
826 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
827 = return (consCgStmt if_stmt blk)
828 where
829 cmm_lit = mkSimpleLit lit
830 rep = cmmLitType cmm_lit
831 ne = if isFloatType rep then MO_F_Ne else MO_Ne
832 cond = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit]
833 if_stmt = CmmCondBranch cond deflt_blk_id
834
835 mk_lit_switch scrut deflt_blk_id branches
836 = do { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
837 ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
838 ; lo_blk_id <- forkCgStmts lo_blk
839 ; let if_stmt = CmmCondBranch cond lo_blk_id
840 ; return (if_stmt `consCgStmt` hi_blk) }
841 where
842 n_branches = length branches
843 (mid_lit,_) = branches !! (n_branches `div` 2)
844 -- See notes above re mid_tag
845
846 (lo_branches, hi_branches) = span is_lo branches
847 is_lo (t,_) = t < mid_lit
848
849 cond = CmmMachOp (mkLtOp mid_lit)
850 [scrut, CmmLit (mkSimpleLit mid_lit)]
851
852 -------------------------------------------------------------------------
853 --
854 -- Simultaneous assignment
855 --
856 -------------------------------------------------------------------------
857
858
859 emitSimultaneously :: CmmStmts -> Code
860 -- Emit code to perform the assignments in the
861 -- input simultaneously, using temporary variables when necessary.
862 --
863 -- The Stmts must be:
864 -- CmmNop, CmmComment, CmmAssign, CmmStore
865 -- and nothing else
866
867
868 -- We use the strongly-connected component algorithm, in which
869 -- * the vertices are the statements
870 -- * an edge goes from s1 to s2 iff
871 -- s1 assigns to something s2 uses
872 -- that is, if s1 should *follow* s2 in the final order
873
874 type CVertex = (Int, CmmStmt) -- Give each vertex a unique number,
875 -- for fast comparison
876
877 emitSimultaneously stmts
878 = codeOnly $
879 case filterOut isNopStmt (stmtList stmts) of
880 -- Remove no-ops
881 [] -> nopC
882 [stmt] -> stmtC stmt -- It's often just one stmt
883 stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
884
885 doSimultaneously1 :: [CVertex] -> Code
886 doSimultaneously1 vertices
887 = let
888 edges = [ (vertex, key1, edges_from stmt1)
889 | vertex@(key1, stmt1) <- vertices
890 ]
891 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
892 stmt1 `mustFollow` stmt2
893 ]
894 components = stronglyConnCompFromEdgedVertices edges
895
896 -- do_components deal with one strongly-connected component
897 -- Not cyclic, or singleton? Just do it
898 do_component (AcyclicSCC (n,stmt)) = stmtC stmt
899 do_component (CyclicSCC [(n,stmt)]) = stmtC stmt
900
901 -- Cyclic? Then go via temporaries. Pick one to
902 -- break the loop and try again with the rest.
903 do_component (CyclicSCC ((n,first_stmt) : rest))
904 = do { from_temp <- go_via_temp first_stmt
905 ; doSimultaneously1 rest
906 ; stmtC from_temp }
907
908 go_via_temp (CmmAssign dest src)
909 = do { tmp <- newTemp (cmmRegType dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
910 ; stmtC (CmmAssign (CmmLocal tmp) src)
911 ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) }
912 go_via_temp (CmmStore dest src)
913 = do { tmp <- newTemp (cmmExprType src) -- TODO FIXME NOW if the pair of assignemnts move across a call this will be wrong
914 ; stmtC (CmmAssign (CmmLocal tmp) src)
915 ; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
916 in
917 mapCs do_component components
918
919 mustFollow :: CmmStmt -> CmmStmt -> Bool
920 CmmAssign reg _ `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
921 CmmStore loc e `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprType e)) stmt
922 CmmNop `mustFollow` stmt = False
923 CmmComment _ `mustFollow` stmt = False
924
925
926 anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool
927 -- True if the fn is true of any input of the stmt
928 anySrc p (CmmAssign _ e) = p e
929 anySrc p (CmmStore e1 e2) = p e1 || p e2 -- Might be used in either side
930 anySrc p (CmmComment _) = False
931 anySrc p CmmNop = False
932 anySrc p other = True -- Conservative
933
934 locUsedIn :: CmmExpr -> CmmType -> CmmExpr -> Bool
935 -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
936 -- 'e'. Returns True if it's not sure.
937 locUsedIn loc rep (CmmLit _) = False
938 locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
939 locUsedIn loc rep (CmmReg reg') = False
940 locUsedIn loc rep (CmmRegOff reg' _) = False
941 locUsedIn loc rep (CmmMachOp _ es) = any (locUsedIn loc rep) es
942
943 possiblySameLoc :: CmmExpr -> CmmType -> CmmExpr -> CmmType -> Bool
944 -- Assumes that distinct registers (eg Hp, Sp) do not
945 -- point to the same location, nor any offset thereof.
946 possiblySameLoc (CmmReg r1) rep1 (CmmReg r2) rep2 = r1==r2
947 possiblySameLoc (CmmReg r1) rep1 (CmmRegOff r2 0) rep2 = r1==r2
948 possiblySameLoc (CmmRegOff r1 0) rep1 (CmmReg r2) rep2 = r1==r2
949 possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
950 = r1==r2 && end1 > start2 && end2 > start1
951 where
952 end1 = start1 + widthInBytes (typeWidth rep1)
953 end2 = start2 + widthInBytes (typeWidth rep2)
954
955 possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
956 possiblySameLoc l1 rep1 l2 rep2 = True -- Conservative
957
958 -------------------------------------------------------------------------
959 --
960 -- Static Reference Tables
961 --
962 -------------------------------------------------------------------------
963
964 -- There is just one SRT for each top level binding; all the nested
965 -- bindings use sub-sections of this SRT. The label is passed down to
966 -- the nested bindings via the monad.
967
968 getSRTInfo :: FCode C_SRT
969 getSRTInfo = do
970 srt_lbl <- getSRTLabel
971 srt <- getSRT
972 case srt of
973 -- TODO: Should we panic in this case?
974 -- Someone obviously thinks there should be an SRT
975 NoSRT -> return NoC_SRT
976 SRTEntries {} -> panic "getSRTInfo: SRTEntries. Perhaps you forgot to run SimplStg?"
977 SRT off len bmp
978 | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
979 -> do id <- newUnique
980 let srt_desc_lbl = mkLargeSRTLabel id
981 emitRODataLits "getSRTInfo" srt_desc_lbl
982 ( cmmLabelOffW srt_lbl off
983 : mkWordCLit (fromIntegral len)
984 : map mkWordCLit bmp)
985 return (C_SRT srt_desc_lbl 0 srt_escape)
986
987 SRT off len bmp
988 | otherwise
989 -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
990 -- The fromIntegral converts to StgHalfWord
991
992 srt_escape = (-1) :: StgHalfWord
993
994 clHasCafRefs :: ClosureInfo -> CafInfo
995 clHasCafRefs (ClosureInfo {closureSRT = srt}) =
996 case srt of NoC_SRT -> NoCafRefs
997 _ -> MayHaveCafRefs
998 clHasCafRefs (ConInfo {}) = NoCafRefs
999
1000 -- -----------------------------------------------------------------------------
1001 --
1002 -- STG/Cmm GlobalReg
1003 --
1004 -- -----------------------------------------------------------------------------
1005
1006 -- | Here is where the STG register map is defined for each target arch.
1007 -- The order matters (for the llvm backend anyway)! We must make sure to
1008 -- maintain the order here with the order used in the LLVM calling conventions.
1009 -- Note that also, this isn't all registers, just the ones that are currently
1010 -- possbily mapped to real registers.
1011 activeStgRegs :: [GlobalReg]
1012 activeStgRegs = [
1013 #ifdef REG_Base
1014 BaseReg
1015 #endif
1016 #ifdef REG_Sp
1017 ,Sp
1018 #endif
1019 #ifdef REG_Hp
1020 ,Hp
1021 #endif
1022 #ifdef REG_R1
1023 ,VanillaReg 1 VGcPtr
1024 #endif
1025 #ifdef REG_R2
1026 ,VanillaReg 2 VGcPtr
1027 #endif
1028 #ifdef REG_R3
1029 ,VanillaReg 3 VGcPtr
1030 #endif
1031 #ifdef REG_R4
1032 ,VanillaReg 4 VGcPtr
1033 #endif
1034 #ifdef REG_R5
1035 ,VanillaReg 5 VGcPtr
1036 #endif
1037 #ifdef REG_R6
1038 ,VanillaReg 6 VGcPtr
1039 #endif
1040 #ifdef REG_R7
1041 ,VanillaReg 7 VGcPtr
1042 #endif
1043 #ifdef REG_R8
1044 ,VanillaReg 8 VGcPtr
1045 #endif
1046 #ifdef REG_SpLim
1047 ,SpLim
1048 #endif
1049 #ifdef REG_F1
1050 ,FloatReg 1
1051 #endif
1052 #ifdef REG_F2
1053 ,FloatReg 2
1054 #endif
1055 #ifdef REG_F3
1056 ,FloatReg 3
1057 #endif
1058 #ifdef REG_F4
1059 ,FloatReg 4
1060 #endif
1061 #ifdef REG_D1
1062 ,DoubleReg 1
1063 #endif
1064 #ifdef REG_D2
1065 ,DoubleReg 2
1066 #endif
1067 ]
1068
1069 -- | We map STG registers onto appropriate CmmExprs. Either they map
1070 -- to real machine registers or stored as offsets from BaseReg. Given
1071 -- a GlobalReg, get_GlobalReg_addr always produces the
1072 -- register table address for it.
1073 get_GlobalReg_addr :: GlobalReg -> CmmExpr
1074 get_GlobalReg_addr BaseReg = regTableOffset 0
1075 get_GlobalReg_addr mid = get_Regtable_addr_from_offset
1076 (globalRegType mid) (baseRegOffset mid)
1077
1078 -- Calculate a literal representing an offset into the register table.
1079 -- Used when we don't have an actual BaseReg to offset from.
1080 regTableOffset n =
1081 CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
1082
1083 get_Regtable_addr_from_offset :: CmmType -> Int -> CmmExpr
1084 get_Regtable_addr_from_offset rep offset =
1085 #ifdef REG_Base
1086 CmmRegOff (CmmGlobal BaseReg) offset
1087 #else
1088 regTableOffset offset
1089 #endif
1090
1091 -- | Fixup global registers so that they assign to locations within the
1092 -- RegTable if they aren't pinned for the current target.
1093 fixStgRegisters :: RawCmmTop -> RawCmmTop
1094 fixStgRegisters top@(CmmData _ _) = top
1095
1096 fixStgRegisters (CmmProc info lbl (ListGraph blocks)) =
1097 let blocks' = map fixStgRegBlock blocks
1098 in CmmProc info lbl $ ListGraph blocks'
1099
1100 fixStgRegBlock :: CmmBasicBlock -> CmmBasicBlock
1101 fixStgRegBlock (BasicBlock id stmts) =
1102 let stmts' = map fixStgRegStmt stmts
1103 in BasicBlock id stmts'
1104
1105 fixStgRegStmt :: CmmStmt -> CmmStmt
1106 fixStgRegStmt stmt
1107 = case stmt of
1108 CmmAssign (CmmGlobal reg) src ->
1109 let src' = fixStgRegExpr src
1110 baseAddr = get_GlobalReg_addr reg
1111 in case reg `elem` activeStgRegs of
1112 True -> CmmAssign (CmmGlobal reg) src'
1113 False -> CmmStore baseAddr src'
1114
1115 CmmAssign reg src ->
1116 let src' = fixStgRegExpr src
1117 in CmmAssign reg src'
1118
1119 CmmStore addr src -> CmmStore (fixStgRegExpr addr) (fixStgRegExpr src)
1120
1121 CmmCall target regs args srt returns ->
1122 let target' = case target of
1123 CmmCallee e conv -> CmmCallee (fixStgRegExpr e) conv
1124 other -> other
1125 args' = map (\(CmmHinted arg hint) ->
1126 (CmmHinted (fixStgRegExpr arg) hint)) args
1127 in CmmCall target' regs args' srt returns
1128
1129 CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr test) dest
1130
1131 CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr expr) ids
1132
1133 CmmJump addr regs -> CmmJump (fixStgRegExpr addr) regs
1134
1135 -- CmmNop, CmmComment, CmmBranch, CmmReturn
1136 _other -> stmt
1137
1138
1139 fixStgRegExpr :: CmmExpr -> CmmExpr
1140 fixStgRegExpr expr
1141 = case expr of
1142 CmmLoad addr ty -> CmmLoad (fixStgRegExpr addr) ty
1143
1144 CmmMachOp mop args -> CmmMachOp mop args'
1145 where args' = map fixStgRegExpr args
1146
1147 CmmReg (CmmGlobal reg) ->
1148 -- Replace register leaves with appropriate StixTrees for
1149 -- the given target. MagicIds which map to a reg on this
1150 -- arch are left unchanged. For the rest, BaseReg is taken
1151 -- to mean the address of the reg table in MainCapability,
1152 -- and for all others we generate an indirection to its
1153 -- location in the register table.
1154 case reg `elem` activeStgRegs of
1155 True -> expr
1156 False ->
1157 let baseAddr = get_GlobalReg_addr reg
1158 in case reg of
1159 BaseReg -> fixStgRegExpr baseAddr
1160 _other -> fixStgRegExpr
1161 (CmmLoad baseAddr (globalRegType reg))
1162
1163 CmmRegOff (CmmGlobal reg) offset ->
1164 -- RegOf leaves are just a shorthand form. If the reg maps
1165 -- to a real reg, we keep the shorthand, otherwise, we just
1166 -- expand it and defer to the above code.
1167 case reg `elem` activeStgRegs of
1168 True -> expr
1169 False -> fixStgRegExpr (CmmMachOp (MO_Add wordWidth) [
1170 CmmReg (CmmGlobal reg),
1171 CmmLit (CmmInt (fromIntegral offset)
1172 wordWidth)])
1173
1174 -- CmmLit, CmmReg (CmmLocal), CmmStackSlot
1175 _other -> expr
1176