Remove dead code from CgUtils
[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 callerSaveVolatileRegs, get_GlobalReg_addr,
29
30 cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
31 cmmUGtWord,
32 cmmOffsetExprW, cmmOffsetExprB,
33 cmmRegOffW, cmmRegOffB,
34 cmmLabelOffW, cmmLabelOffB,
35 cmmOffsetW, cmmOffsetB,
36 cmmOffsetLitW, cmmOffsetLitB,
37 cmmLoadIndexW,
38 cmmConstrTag, cmmConstrTag1,
39
40 tagForCon, tagCons, isSmallFamily,
41 cmmUntag, cmmIsTagged, cmmGetTag,
42
43 addToMem, addToMemE,
44 mkWordCLit,
45 mkStringCLit, mkByteStringCLit,
46 packHalfWordsCLit,
47 blankWord,
48
49 getSRTInfo, clHasCafRefs
50 ) where
51
52 #include "HsVersions.h"
53 #include "../includes/MachRegs.h"
54
55 import BlockId
56 import CgMonad
57 import TyCon
58 import DataCon
59 import Id
60 import IdInfo
61 import Constants
62 import SMRep
63 import PprCmm ( {- instances -} )
64 import Cmm
65 import CLabel
66 import CmmUtils
67 import ForeignCall
68 import ClosureInfo
69 import StgSyn (SRT(..))
70 import Literal
71 import Digraph
72 import ListSetOps
73 import Util
74 import DynFlags
75 import FastString
76 import PackageConfig
77 import Outputable
78
79 import Data.Char
80 import Data.Bits
81 import Data.Word
82 import Data.Maybe
83
84 -------------------------------------------------------------------------
85 --
86 -- Random small functions
87 --
88 -------------------------------------------------------------------------
89
90 addIdReps :: [Id] -> [(CgRep, Id)]
91 addIdReps ids = [(idCgRep id, id) | id <- ids]
92
93 -------------------------------------------------------------------------
94 --
95 -- Literals
96 --
97 -------------------------------------------------------------------------
98
99 cgLit :: Literal -> FCode CmmLit
100 cgLit (MachStr s) = mkByteStringCLit (bytesFS s)
101 -- not unpackFS; we want the UTF-8 byte stream.
102 cgLit other_lit = return (mkSimpleLit other_lit)
103
104 mkSimpleLit :: Literal -> CmmLit
105 mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth
106 mkSimpleLit MachNullAddr = zeroCLit
107 mkSimpleLit (MachInt i) = CmmInt i wordWidth
108 mkSimpleLit (MachInt64 i) = CmmInt i W64
109 mkSimpleLit (MachWord i) = CmmInt i wordWidth
110 mkSimpleLit (MachWord64 i) = CmmInt i W64
111 mkSimpleLit (MachFloat r) = CmmFloat r W32
112 mkSimpleLit (MachDouble r) = CmmFloat r W64
113 mkSimpleLit (MachLabel fs ms) = CmmLabel (mkForeignLabel fs ms is_dyn)
114 where
115 is_dyn = False -- ToDo: fix me
116
117 mkLtOp :: Literal -> MachOp
118 -- On signed literals we must do a signed comparison
119 mkLtOp (MachInt _) = MO_S_Lt wordWidth
120 mkLtOp (MachFloat _) = MO_F_Lt W32
121 mkLtOp (MachDouble _) = MO_F_Lt W64
122 mkLtOp lit = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit)))
123
124
125 ---------------------------------------------------
126 --
127 -- Cmm data type functions
128 --
129 ---------------------------------------------------
130
131 -----------------------
132 -- The "B" variants take byte offsets
133 cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
134 cmmRegOffB = cmmRegOff
135
136 cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr
137 cmmOffsetB = cmmOffset
138
139 cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr
140 cmmOffsetExprB = cmmOffsetExpr
141
142 cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
143 cmmLabelOffB = cmmLabelOff
144
145 cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
146 cmmOffsetLitB = cmmOffsetLit
147
148 -----------------------
149 -- The "W" variants take word offsets
150 cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr
151 -- The second arg is a *word* offset; need to change it to bytes
152 cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n)
153 cmmOffsetExprW e wd_off = cmmIndexExpr wordWidth e wd_off
154
155 cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr
156 cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n)
157
158 cmmRegOffW :: CmmReg -> WordOff -> CmmExpr
159 cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE)
160
161 cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit
162 cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off)
163
164 cmmLabelOffW :: CLabel -> WordOff -> CmmLit
165 cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off)
166
167 cmmLoadIndexW :: CmmExpr -> Int -> CmmType -> CmmExpr
168 cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty
169
170 -----------------------
171 cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord :: CmmExpr -> CmmExpr -> CmmExpr
172 cmmOrWord e1 e2 = CmmMachOp mo_wordOr [e1, e2]
173 cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
174 cmmNeWord e1 e2 = CmmMachOp mo_wordNe [e1, e2]
175 cmmEqWord e1 e2 = CmmMachOp mo_wordEq [e1, e2]
176 cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
177 cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
178 cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
179 --cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
180 --cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
181 cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
182
183 cmmNegate :: CmmExpr -> CmmExpr
184 cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
185 cmmNegate e = CmmMachOp (MO_S_Neg (cmmExprWidth e)) [e]
186
187 blankWord :: CmmStatic
188 blankWord = CmmUninitialised wORD_SIZE
189
190 -- Tagging --
191 -- Tag bits mask
192 --cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
193 cmmTagMask = CmmLit (mkIntCLit tAG_MASK)
194 cmmPointerMask = CmmLit (mkIntCLit (complement tAG_MASK))
195
196 -- Used to untag a possibly tagged pointer
197 -- A static label need not be untagged
198 cmmUntag e@(CmmLit (CmmLabel _)) = e
199 -- Default case
200 cmmUntag e = (e `cmmAndWord` cmmPointerMask)
201
202 cmmGetTag e = (e `cmmAndWord` cmmTagMask)
203
204 -- Test if a closure pointer is untagged
205 cmmIsTagged e = (e `cmmAndWord` cmmTagMask)
206 `cmmNeWord` CmmLit zeroCLit
207
208 cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` (CmmLit (mkIntCLit 1))
209 -- Get constructor tag, but one based.
210 cmmConstrTag1 e = e `cmmAndWord` cmmTagMask
211
212 {-
213 The family size of a data type (the number of constructors)
214 can be either:
215 * small, if the family size < 2**tag_bits
216 * big, otherwise.
217
218 Small families can have the constructor tag in the tag
219 bits.
220 Big families only use the tag value 1 to represent
221 evaluatedness.
222 -}
223 isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
224
225 tagForCon con = tag
226 where
227 con_tag = dataConTagZ con
228 fam_size = tyConFamilySize (dataConTyCon con)
229 tag | isSmallFamily fam_size = con_tag + 1
230 | otherwise = 1
231
232 --Tag an expression, to do: refactor, this appears in some other module.
233 tagCons con expr = cmmOffsetB expr (tagForCon con)
234
235 -- Copied from CgInfoTbls.hs
236 -- We keep the *zero-indexed* tag in the srt_len field of the info
237 -- table of a data constructor.
238 dataConTagZ :: DataCon -> ConTagZ
239 dataConTagZ con = dataConTag con - fIRST_TAG
240
241 -----------------------
242 -- Making literals
243
244 mkWordCLit :: StgWord -> CmmLit
245 mkWordCLit wd = CmmInt (fromIntegral wd) wordWidth
246
247 packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit
248 -- Make a single word literal in which the lower_half_word is
249 -- at the lower address, and the upper_half_word is at the
250 -- higher address
251 -- ToDo: consider using half-word lits instead
252 -- but be careful: that's vulnerable when reversed
253 packHalfWordsCLit lower_half_word upper_half_word
254 #ifdef WORDS_BIGENDIAN
255 = mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)
256 .|. fromIntegral upper_half_word)
257 #else
258 = mkWordCLit ((fromIntegral lower_half_word)
259 .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS))
260 #endif
261
262 --------------------------------------------------------------------------
263 --
264 -- Incrementing a memory location
265 --
266 --------------------------------------------------------------------------
267
268 addToMem :: Width -- rep of the counter
269 -> CmmExpr -- Address
270 -> Int -- What to add (a word)
271 -> CmmStmt
272 addToMem width ptr n = addToMemE width ptr (CmmLit (CmmInt (toInteger n) width))
273
274 addToMemE :: Width -- rep of the counter
275 -> CmmExpr -- Address
276 -> CmmExpr -- What to add (a word-typed expression)
277 -> CmmStmt
278 addToMemE width ptr n
279 = CmmStore ptr (CmmMachOp (MO_Add width) [CmmLoad ptr (cmmBits width), n])
280
281 -------------------------------------------------------------------------
282 --
283 -- Converting a closure tag to a closure for enumeration types
284 -- (this is the implementation of tagToEnum#).
285 --
286 -------------------------------------------------------------------------
287
288 tagToClosure :: TyCon -> CmmExpr -> CmmExpr
289 tagToClosure tycon tag
290 = CmmLoad (cmmOffsetExprW closure_tbl tag) gcWord
291 where closure_tbl = CmmLit (CmmLabel lbl)
292 lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
293
294 -------------------------------------------------------------------------
295 --
296 -- Conditionals and rts calls
297 --
298 -------------------------------------------------------------------------
299
300 emitIf :: CmmExpr -- Boolean
301 -> Code -- Then part
302 -> Code
303 -- Emit (if e then x)
304 -- ToDo: reverse the condition to avoid the extra branch instruction if possible
305 -- (some conditionals aren't reversible. eg. floating point comparisons cannot
306 -- be inverted because there exist some values for which both comparisons
307 -- return False, such as NaN.)
308 emitIf cond then_part
309 = do { then_id <- newLabelC
310 ; join_id <- newLabelC
311 ; stmtC (CmmCondBranch cond then_id)
312 ; stmtC (CmmBranch join_id)
313 ; labelC then_id
314 ; then_part
315 ; labelC join_id
316 }
317
318 emitIfThenElse :: CmmExpr -- Boolean
319 -> Code -- Then part
320 -> Code -- Else part
321 -> Code
322 -- Emit (if e then x else y)
323 emitIfThenElse cond then_part else_part
324 = do { then_id <- newLabelC
325 ; join_id <- newLabelC
326 ; stmtC (CmmCondBranch cond then_id)
327 ; else_part
328 ; stmtC (CmmBranch join_id)
329 ; labelC then_id
330 ; then_part
331 ; labelC join_id
332 }
333
334 emitRtsCall :: LitString -> [CmmHinted CmmExpr] -> Bool -> Code
335 emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
336 -- The 'Nothing' says "save all global registers"
337
338 emitRtsCallWithVols :: LitString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code
339 emitRtsCallWithVols fun args vols safe
340 = emitRtsCall' [] fun args (Just vols) safe
341
342 emitRtsCallWithResult :: LocalReg -> ForeignHint -> LitString
343 -> [CmmHinted CmmExpr] -> Bool -> Code
344 emitRtsCallWithResult res hint fun args safe
345 = emitRtsCall' [CmmHinted res hint] fun args Nothing safe
346
347 -- Make a call to an RTS C procedure
348 emitRtsCall'
349 :: [CmmHinted LocalReg]
350 -> LitString
351 -> [CmmHinted CmmExpr]
352 -> Maybe [GlobalReg]
353 -> Bool -- True <=> CmmSafe call
354 -> Code
355 emitRtsCall' res fun args vols safe = do
356 safety <- if safe
357 then getSRTInfo >>= (return . CmmSafe)
358 else return CmmUnsafe
359 stmtsC caller_save
360 stmtC (CmmCall target res args safety CmmMayReturn)
361 stmtsC caller_load
362 where
363 (caller_save, caller_load) = callerSaveVolatileRegs vols
364 target = CmmCallee fun_expr CCallConv
365 fun_expr = mkLblExpr (mkRtsCodeLabel fun)
366
367 -----------------------------------------------------------------------------
368 --
369 -- Caller-Save Registers
370 --
371 -----------------------------------------------------------------------------
372
373 -- Here we generate the sequence of saves/restores required around a
374 -- foreign call instruction.
375
376 -- TODO: reconcile with includes/Regs.h
377 -- * Regs.h claims that BaseReg should be saved last and loaded first
378 -- * This might not have been tickled before since BaseReg is callee save
379 -- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
380 callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt])
381 callerSaveVolatileRegs vols = (caller_save, caller_load)
382 where
383 caller_save = foldr ($!) [] (map callerSaveGlobalReg regs_to_save)
384 caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save)
385
386 system_regs = [Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery,
387 {-SparkHd,SparkTl,SparkBase,SparkLim,-}BaseReg ]
388
389 regs_to_save = system_regs ++ vol_list
390
391 vol_list = case vols of Nothing -> all_of_em; Just regs -> regs
392
393 all_of_em = [ VanillaReg n VNonGcPtr | n <- [0..mAX_Vanilla_REG] ]
394 -- The VNonGcPtr is a lie, but I don't think it matters
395 ++ [ FloatReg n | n <- [0..mAX_Float_REG] ]
396 ++ [ DoubleReg n | n <- [0..mAX_Double_REG] ]
397 ++ [ LongReg n | n <- [0..mAX_Long_REG] ]
398
399 callerSaveGlobalReg reg next
400 | callerSaves reg =
401 CmmStore (get_GlobalReg_addr reg)
402 (CmmReg (CmmGlobal reg)) : next
403 | otherwise = next
404
405 callerRestoreGlobalReg reg next
406 | callerSaves reg =
407 CmmAssign (CmmGlobal reg)
408 (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
409 : next
410 | otherwise = next
411
412 -- -----------------------------------------------------------------------------
413 -- Global registers
414
415 -- We map STG registers onto appropriate CmmExprs. Either they map
416 -- to real machine registers or stored as offsets from BaseReg. Given
417 -- a GlobalReg, get_GlobalReg_addr always produces the
418 -- register table address for it.
419 -- (See also get_GlobalReg_reg_or_addr in MachRegs)
420
421 get_GlobalReg_addr :: GlobalReg -> CmmExpr
422 get_GlobalReg_addr BaseReg = regTableOffset 0
423 get_GlobalReg_addr mid = get_Regtable_addr_from_offset
424 (globalRegType mid) (baseRegOffset mid)
425
426 -- Calculate a literal representing an offset into the register table.
427 -- Used when we don't have an actual BaseReg to offset from.
428 regTableOffset n =
429 CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
430
431 get_Regtable_addr_from_offset :: CmmType -> Int -> CmmExpr
432 get_Regtable_addr_from_offset rep offset =
433 #ifdef REG_Base
434 CmmRegOff (CmmGlobal BaseReg) offset
435 #else
436 regTableOffset offset
437 #endif
438
439
440 -- | Returns @True@ if this global register is stored in a caller-saves
441 -- machine register.
442
443 callerSaves :: GlobalReg -> Bool
444
445 #ifdef CALLER_SAVES_Base
446 callerSaves BaseReg = True
447 #endif
448 #ifdef CALLER_SAVES_R1
449 callerSaves (VanillaReg 1 _) = True
450 #endif
451 #ifdef CALLER_SAVES_R2
452 callerSaves (VanillaReg 2 _) = True
453 #endif
454 #ifdef CALLER_SAVES_R3
455 callerSaves (VanillaReg 3 _) = True
456 #endif
457 #ifdef CALLER_SAVES_R4
458 callerSaves (VanillaReg 4 _) = True
459 #endif
460 #ifdef CALLER_SAVES_R5
461 callerSaves (VanillaReg 5 _) = True
462 #endif
463 #ifdef CALLER_SAVES_R6
464 callerSaves (VanillaReg 6 _) = True
465 #endif
466 #ifdef CALLER_SAVES_R7
467 callerSaves (VanillaReg 7 _) = True
468 #endif
469 #ifdef CALLER_SAVES_R8
470 callerSaves (VanillaReg 8 _) = True
471 #endif
472 #ifdef CALLER_SAVES_F1
473 callerSaves (FloatReg 1) = True
474 #endif
475 #ifdef CALLER_SAVES_F2
476 callerSaves (FloatReg 2) = True
477 #endif
478 #ifdef CALLER_SAVES_F3
479 callerSaves (FloatReg 3) = True
480 #endif
481 #ifdef CALLER_SAVES_F4
482 callerSaves (FloatReg 4) = True
483 #endif
484 #ifdef CALLER_SAVES_D1
485 callerSaves (DoubleReg 1) = True
486 #endif
487 #ifdef CALLER_SAVES_D2
488 callerSaves (DoubleReg 2) = True
489 #endif
490 #ifdef CALLER_SAVES_L1
491 callerSaves (LongReg 1) = True
492 #endif
493 #ifdef CALLER_SAVES_Sp
494 callerSaves Sp = True
495 #endif
496 #ifdef CALLER_SAVES_SpLim
497 callerSaves SpLim = True
498 #endif
499 #ifdef CALLER_SAVES_Hp
500 callerSaves Hp = True
501 #endif
502 #ifdef CALLER_SAVES_HpLim
503 callerSaves HpLim = True
504 #endif
505 #ifdef CALLER_SAVES_CurrentTSO
506 callerSaves CurrentTSO = True
507 #endif
508 #ifdef CALLER_SAVES_CurrentNursery
509 callerSaves CurrentNursery = True
510 #endif
511 callerSaves _ = False
512
513
514 -- -----------------------------------------------------------------------------
515 -- Information about global registers
516
517 baseRegOffset :: GlobalReg -> Int
518
519 baseRegOffset (VanillaReg 1 _) = oFFSET_StgRegTable_rR1
520 baseRegOffset (VanillaReg 2 _) = oFFSET_StgRegTable_rR2
521 baseRegOffset (VanillaReg 3 _) = oFFSET_StgRegTable_rR3
522 baseRegOffset (VanillaReg 4 _) = oFFSET_StgRegTable_rR4
523 baseRegOffset (VanillaReg 5 _) = oFFSET_StgRegTable_rR5
524 baseRegOffset (VanillaReg 6 _) = oFFSET_StgRegTable_rR6
525 baseRegOffset (VanillaReg 7 _) = oFFSET_StgRegTable_rR7
526 baseRegOffset (VanillaReg 8 _) = oFFSET_StgRegTable_rR8
527 baseRegOffset (VanillaReg 9 _) = oFFSET_StgRegTable_rR9
528 baseRegOffset (VanillaReg 10 _) = oFFSET_StgRegTable_rR10
529 baseRegOffset (FloatReg 1) = oFFSET_StgRegTable_rF1
530 baseRegOffset (FloatReg 2) = oFFSET_StgRegTable_rF2
531 baseRegOffset (FloatReg 3) = oFFSET_StgRegTable_rF3
532 baseRegOffset (FloatReg 4) = oFFSET_StgRegTable_rF4
533 baseRegOffset (DoubleReg 1) = oFFSET_StgRegTable_rD1
534 baseRegOffset (DoubleReg 2) = oFFSET_StgRegTable_rD2
535 baseRegOffset Sp = oFFSET_StgRegTable_rSp
536 baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim
537 baseRegOffset (LongReg 1) = oFFSET_StgRegTable_rL1
538 baseRegOffset Hp = oFFSET_StgRegTable_rHp
539 baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim
540 baseRegOffset CurrentTSO = oFFSET_StgRegTable_rCurrentTSO
541 baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery
542 baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc
543 baseRegOffset EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo
544 baseRegOffset GCEnter1 = oFFSET_stgGCEnter1
545 baseRegOffset GCFun = oFFSET_stgGCFun
546 baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
547 baseRegOffset _ = panic "baseRegOffset:other"
548
549
550 -------------------------------------------------------------------------
551 --
552 -- Strings generate a top-level data block
553 --
554 -------------------------------------------------------------------------
555
556 emitDataLits :: CLabel -> [CmmLit] -> Code
557 -- Emit a data-segment data block
558 emitDataLits lbl lits
559 = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
560
561 mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
562 -- Emit a data-segment data block
563 mkDataLits lbl lits
564 = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
565
566 emitRODataLits :: String -> CLabel -> [CmmLit] -> Code
567 -- Emit a read-only data block
568 emitRODataLits caller lbl lits
569 = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
570 where section | any needsRelocation lits = RelocatableReadOnlyData
571 | otherwise = ReadOnlyData
572 needsRelocation (CmmLabel _) = True
573 needsRelocation (CmmLabelOff _ _) = True
574 needsRelocation _ = False
575
576 mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
577 mkRODataLits lbl lits
578 = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
579 where section | any needsRelocation lits = RelocatableReadOnlyData
580 | otherwise = ReadOnlyData
581 needsRelocation (CmmLabel _) = True
582 needsRelocation (CmmLabelOff _ _) = True
583 needsRelocation _ = False
584
585 mkStringCLit :: String -> FCode CmmLit
586 -- Make a global definition for the string,
587 -- and return its label
588 mkStringCLit str = mkByteStringCLit (map (fromIntegral.ord) str)
589
590 mkByteStringCLit :: [Word8] -> FCode CmmLit
591 mkByteStringCLit bytes
592 = do { uniq <- newUnique
593 ; let lbl = mkStringLitLabel uniq
594 ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
595 ; return (CmmLabel lbl) }
596
597 -------------------------------------------------------------------------
598 --
599 -- Assigning expressions to temporaries
600 --
601 -------------------------------------------------------------------------
602
603 assignTemp :: CmmExpr -> FCode CmmExpr
604 -- For a non-trivial expression, e, create a local
605 -- variable and assign the expression to it
606 assignTemp e
607 | isTrivialCmmExpr e = return e
608 | otherwise = do { 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 regUsedIn :: CmmReg -> CmmExpr -> Bool
935 reg `regUsedIn` CmmLit _ = False
936 reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
937 reg `regUsedIn` CmmReg reg' = reg == reg'
938 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
939 reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
940
941 locUsedIn :: CmmExpr -> CmmType -> CmmExpr -> Bool
942 -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
943 -- 'e'. Returns True if it's not sure.
944 locUsedIn loc rep (CmmLit _) = False
945 locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
946 locUsedIn loc rep (CmmReg reg') = False
947 locUsedIn loc rep (CmmRegOff reg' _) = False
948 locUsedIn loc rep (CmmMachOp _ es) = any (locUsedIn loc rep) es
949
950 possiblySameLoc :: CmmExpr -> CmmType -> CmmExpr -> CmmType -> Bool
951 -- Assumes that distinct registers (eg Hp, Sp) do not
952 -- point to the same location, nor any offset thereof.
953 possiblySameLoc (CmmReg r1) rep1 (CmmReg r2) rep2 = r1==r2
954 possiblySameLoc (CmmReg r1) rep1 (CmmRegOff r2 0) rep2 = r1==r2
955 possiblySameLoc (CmmRegOff r1 0) rep1 (CmmReg r2) rep2 = r1==r2
956 possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
957 = r1==r2 && end1 > start2 && end2 > start1
958 where
959 end1 = start1 + widthInBytes (typeWidth rep1)
960 end2 = start2 + widthInBytes (typeWidth rep2)
961
962 possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
963 possiblySameLoc l1 rep1 l2 rep2 = True -- Conservative
964
965 -------------------------------------------------------------------------
966 --
967 -- Static Reference Tables
968 --
969 -------------------------------------------------------------------------
970
971 -- There is just one SRT for each top level binding; all the nested
972 -- bindings use sub-sections of this SRT. The label is passed down to
973 -- the nested bindings via the monad.
974
975 getSRTInfo :: FCode C_SRT
976 getSRTInfo = do
977 srt_lbl <- getSRTLabel
978 srt <- getSRT
979 case srt of
980 -- TODO: Should we panic in this case?
981 -- Someone obviously thinks there should be an SRT
982 NoSRT -> return NoC_SRT
983 SRTEntries {} -> panic "getSRTInfo: SRTEntries. Perhaps you forgot to run SimplStg?"
984 SRT off len bmp
985 | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
986 -> do id <- newUnique
987 let srt_desc_lbl = mkLargeSRTLabel id
988 emitRODataLits "getSRTInfo" srt_desc_lbl
989 ( cmmLabelOffW srt_lbl off
990 : mkWordCLit (fromIntegral len)
991 : map mkWordCLit bmp)
992 return (C_SRT srt_desc_lbl 0 srt_escape)
993
994 SRT off len bmp
995 | otherwise
996 -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
997 -- The fromIntegral converts to StgHalfWord
998
999 srt_escape = (-1) :: StgHalfWord
1000
1001 clHasCafRefs :: ClosureInfo -> CafInfo
1002 clHasCafRefs (ClosureInfo {closureSRT = srt}) =
1003 case srt of NoC_SRT -> NoCafRefs
1004 _ -> MayHaveCafRefs
1005 clHasCafRefs (ConInfo {}) = NoCafRefs