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