Merging in the new codegen branch
[ghc.git] / compiler / codeGen / CgUtils.hs
1 {-# OPTIONS -w #-}
2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
6 -- for details
7
8 -----------------------------------------------------------------------------
9 --
10 -- Code generator utilities; mostly monadic
11 --
12 -- (c) The University of Glasgow 2004-2006
13 --
14 -----------------------------------------------------------------------------
15
16 module CgUtils (
17 addIdReps,
18 cgLit,
19 emitDataLits, mkDataLits,
20 emitRODataLits, mkRODataLits,
21 emitIf, emitIfThenElse,
22 emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
23 assignTemp, newTemp,
24 emitSimultaneously,
25 emitSwitch, emitLitSwitch,
26 tagToClosure,
27
28 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 ; else_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 emitRtsCall :: LitString -> [CmmHinted CmmExpr] -> Bool -> Code
336 emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
337 -- The 'Nothing' says "save all global registers"
338
339 emitRtsCallWithVols :: LitString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code
340 emitRtsCallWithVols fun args vols safe
341 = emitRtsCall' [] fun args (Just vols) safe
342
343 emitRtsCallWithResult :: LocalReg -> ForeignHint -> LitString
344 -> [CmmHinted CmmExpr] -> Bool -> Code
345 emitRtsCallWithResult res hint fun args safe
346 = emitRtsCall' [CmmHinted res hint] fun args Nothing safe
347
348 -- Make a call to an RTS C procedure
349 emitRtsCall'
350 :: [CmmHinted LocalReg]
351 -> LitString
352 -> [CmmHinted CmmExpr]
353 -> Maybe [GlobalReg]
354 -> Bool -- True <=> CmmSafe call
355 -> Code
356 emitRtsCall' res fun args vols safe = do
357 safety <- if safe
358 then getSRTInfo >>= (return . CmmSafe)
359 else return CmmUnsafe
360 stmtsC caller_save
361 stmtC (CmmCall target res args safety CmmMayReturn)
362 stmtsC caller_load
363 where
364 (caller_save, caller_load) = callerSaveVolatileRegs vols
365 target = CmmCallee fun_expr CCallConv
366 fun_expr = mkLblExpr (mkRtsCodeLabel fun)
367
368 -----------------------------------------------------------------------------
369 --
370 -- Caller-Save Registers
371 --
372 -----------------------------------------------------------------------------
373
374 -- Here we generate the sequence of saves/restores required around a
375 -- foreign call instruction.
376
377 -- TODO: reconcile with includes/Regs.h
378 -- * Regs.h claims that BaseReg should be saved last and loaded first
379 -- * This might not have been tickled before since BaseReg is callee save
380 -- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
381 callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt])
382 callerSaveVolatileRegs vols = (caller_save, caller_load)
383 where
384 caller_save = foldr ($!) [] (map callerSaveGlobalReg regs_to_save)
385 caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save)
386
387 system_regs = [Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery,
388 {-SparkHd,SparkTl,SparkBase,SparkLim,-}BaseReg ]
389
390 regs_to_save = system_regs ++ vol_list
391
392 vol_list = case vols of Nothing -> all_of_em; Just regs -> regs
393
394 all_of_em = [ VanillaReg n VNonGcPtr | n <- [0..mAX_Vanilla_REG] ]
395 -- The VNonGcPtr is a lie, but I don't think it matters
396 ++ [ FloatReg n | n <- [0..mAX_Float_REG] ]
397 ++ [ DoubleReg n | n <- [0..mAX_Double_REG] ]
398 ++ [ LongReg n | n <- [0..mAX_Long_REG] ]
399
400 callerSaveGlobalReg reg next
401 | callerSaves reg =
402 CmmStore (get_GlobalReg_addr reg)
403 (CmmReg (CmmGlobal reg)) : next
404 | otherwise = next
405
406 callerRestoreGlobalReg reg next
407 | callerSaves reg =
408 CmmAssign (CmmGlobal reg)
409 (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
410 : next
411 | otherwise = next
412
413 -- -----------------------------------------------------------------------------
414 -- Global registers
415
416 -- We map STG registers onto appropriate CmmExprs. Either they map
417 -- to real machine registers or stored as offsets from BaseReg. Given
418 -- a GlobalReg, get_GlobalReg_addr always produces the
419 -- register table address for it.
420 -- (See also get_GlobalReg_reg_or_addr in MachRegs)
421
422 get_GlobalReg_addr :: GlobalReg -> CmmExpr
423 get_GlobalReg_addr BaseReg = regTableOffset 0
424 get_GlobalReg_addr mid = get_Regtable_addr_from_offset
425 (globalRegType mid) (baseRegOffset mid)
426
427 -- Calculate a literal representing an offset into the register table.
428 -- Used when we don't have an actual BaseReg to offset from.
429 regTableOffset n =
430 CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
431
432 get_Regtable_addr_from_offset :: CmmType -> Int -> CmmExpr
433 get_Regtable_addr_from_offset rep offset =
434 #ifdef REG_Base
435 CmmRegOff (CmmGlobal BaseReg) offset
436 #else
437 regTableOffset offset
438 #endif
439
440
441 -- | Returns @True@ if this global register is stored in a caller-saves
442 -- machine register.
443
444 callerSaves :: GlobalReg -> Bool
445
446 #ifdef CALLER_SAVES_Base
447 callerSaves BaseReg = True
448 #endif
449 #ifdef CALLER_SAVES_R1
450 callerSaves (VanillaReg 1 _) = True
451 #endif
452 #ifdef CALLER_SAVES_R2
453 callerSaves (VanillaReg 2 _) = True
454 #endif
455 #ifdef CALLER_SAVES_R3
456 callerSaves (VanillaReg 3 _) = True
457 #endif
458 #ifdef CALLER_SAVES_R4
459 callerSaves (VanillaReg 4 _) = True
460 #endif
461 #ifdef CALLER_SAVES_R5
462 callerSaves (VanillaReg 5 _) = True
463 #endif
464 #ifdef CALLER_SAVES_R6
465 callerSaves (VanillaReg 6 _) = True
466 #endif
467 #ifdef CALLER_SAVES_R7
468 callerSaves (VanillaReg 7 _) = True
469 #endif
470 #ifdef CALLER_SAVES_R8
471 callerSaves (VanillaReg 8 _) = True
472 #endif
473 #ifdef CALLER_SAVES_F1
474 callerSaves (FloatReg 1) = True
475 #endif
476 #ifdef CALLER_SAVES_F2
477 callerSaves (FloatReg 2) = True
478 #endif
479 #ifdef CALLER_SAVES_F3
480 callerSaves (FloatReg 3) = True
481 #endif
482 #ifdef CALLER_SAVES_F4
483 callerSaves (FloatReg 4) = True
484 #endif
485 #ifdef CALLER_SAVES_D1
486 callerSaves (DoubleReg 1) = True
487 #endif
488 #ifdef CALLER_SAVES_D2
489 callerSaves (DoubleReg 2) = True
490 #endif
491 #ifdef CALLER_SAVES_L1
492 callerSaves (LongReg 1) = True
493 #endif
494 #ifdef CALLER_SAVES_Sp
495 callerSaves Sp = True
496 #endif
497 #ifdef CALLER_SAVES_SpLim
498 callerSaves SpLim = True
499 #endif
500 #ifdef CALLER_SAVES_Hp
501 callerSaves Hp = True
502 #endif
503 #ifdef CALLER_SAVES_HpLim
504 callerSaves HpLim = True
505 #endif
506 #ifdef CALLER_SAVES_CurrentTSO
507 callerSaves CurrentTSO = True
508 #endif
509 #ifdef CALLER_SAVES_CurrentNursery
510 callerSaves CurrentNursery = True
511 #endif
512 callerSaves _ = False
513
514
515 -- -----------------------------------------------------------------------------
516 -- Information about global registers
517
518 baseRegOffset :: GlobalReg -> Int
519
520 baseRegOffset (VanillaReg 1 _) = oFFSET_StgRegTable_rR1
521 baseRegOffset (VanillaReg 2 _) = oFFSET_StgRegTable_rR2
522 baseRegOffset (VanillaReg 3 _) = oFFSET_StgRegTable_rR3
523 baseRegOffset (VanillaReg 4 _) = oFFSET_StgRegTable_rR4
524 baseRegOffset (VanillaReg 5 _) = oFFSET_StgRegTable_rR5
525 baseRegOffset (VanillaReg 6 _) = oFFSET_StgRegTable_rR6
526 baseRegOffset (VanillaReg 7 _) = oFFSET_StgRegTable_rR7
527 baseRegOffset (VanillaReg 8 _) = oFFSET_StgRegTable_rR8
528 baseRegOffset (VanillaReg 9 _) = oFFSET_StgRegTable_rR9
529 baseRegOffset (VanillaReg 10 _) = oFFSET_StgRegTable_rR10
530 baseRegOffset (FloatReg 1) = oFFSET_StgRegTable_rF1
531 baseRegOffset (FloatReg 2) = oFFSET_StgRegTable_rF2
532 baseRegOffset (FloatReg 3) = oFFSET_StgRegTable_rF3
533 baseRegOffset (FloatReg 4) = oFFSET_StgRegTable_rF4
534 baseRegOffset (DoubleReg 1) = oFFSET_StgRegTable_rD1
535 baseRegOffset (DoubleReg 2) = oFFSET_StgRegTable_rD2
536 baseRegOffset Sp = oFFSET_StgRegTable_rSp
537 baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim
538 baseRegOffset (LongReg 1) = oFFSET_StgRegTable_rL1
539 baseRegOffset Hp = oFFSET_StgRegTable_rHp
540 baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim
541 baseRegOffset CurrentTSO = oFFSET_StgRegTable_rCurrentTSO
542 baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery
543 baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc
544 baseRegOffset EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo
545 baseRegOffset GCEnter1 = oFFSET_stgGCEnter1
546 baseRegOffset GCFun = oFFSET_stgGCFun
547 baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
548 baseRegOffset _ = panic "baseRegOffset:other"
549
550
551 -------------------------------------------------------------------------
552 --
553 -- Strings generate a top-level data block
554 --
555 -------------------------------------------------------------------------
556
557 emitDataLits :: CLabel -> [CmmLit] -> Code
558 -- Emit a data-segment data block
559 emitDataLits lbl lits
560 = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
561
562 mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
563 -- Emit a data-segment data block
564 mkDataLits lbl lits
565 = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
566
567 emitRODataLits :: String -> CLabel -> [CmmLit] -> Code
568 -- Emit a read-only data block
569 emitRODataLits caller lbl lits
570 = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
571 where section | any needsRelocation lits = RelocatableReadOnlyData
572 | otherwise = ReadOnlyData
573 needsRelocation (CmmLabel _) = True
574 needsRelocation (CmmLabelOff _ _) = True
575 needsRelocation _ = False
576
577 mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
578 mkRODataLits lbl lits
579 = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
580 where section | any needsRelocation lits = RelocatableReadOnlyData
581 | otherwise = ReadOnlyData
582 needsRelocation (CmmLabel _) = True
583 needsRelocation (CmmLabelOff _ _) = True
584 needsRelocation _ = False
585
586 mkStringCLit :: String -> FCode CmmLit
587 -- Make a global definition for the string,
588 -- and return its label
589 mkStringCLit str = mkByteStringCLit (map (fromIntegral.ord) str)
590
591 mkByteStringCLit :: [Word8] -> FCode CmmLit
592 mkByteStringCLit bytes
593 = do { uniq <- newUnique
594 ; let lbl = mkStringLitLabel uniq
595 ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
596 ; return (CmmLabel lbl) }
597
598 -------------------------------------------------------------------------
599 --
600 -- Assigning expressions to temporaries
601 --
602 -------------------------------------------------------------------------
603
604 assignTemp :: CmmExpr -> FCode CmmExpr
605 -- For a non-trivial expression, e, create a local
606 -- variable and assign the expression to it
607 assignTemp e
608 | isTrivialCmmExpr e = return e
609 | otherwise = do { reg <- newTemp (cmmExprType e)
610 ; stmtC (CmmAssign (CmmLocal reg) e)
611 ; return (CmmReg (CmmLocal reg)) }
612
613 newTemp :: CmmType -> FCode LocalReg
614 newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) }
615
616 -------------------------------------------------------------------------
617 --
618 -- Building case analysis
619 --
620 -------------------------------------------------------------------------
621
622 emitSwitch
623 :: CmmExpr -- Tag to switch on
624 -> [(ConTagZ, CgStmts)] -- Tagged branches
625 -> Maybe CgStmts -- Default branch (if any)
626 -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
627 -- outside this range is undefined
628 -> Code
629
630 -- ONLY A DEFAULT BRANCH: no case analysis to do
631 emitSwitch tag_expr [] (Just stmts) _ _
632 = emitCgStmts stmts
633
634 -- Right, off we go
635 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
636 = -- Just sort the branches before calling mk_sritch
637 do { mb_deflt_id <-
638 case mb_deflt of
639 Nothing -> return Nothing
640 Just stmts -> do id <- forkCgStmts stmts; return (Just id)
641
642 ; dflags <- getDynFlags
643 ; let via_C | HscC <- hscTarget dflags = True
644 | otherwise = False
645
646 ; stmts <- mk_switch tag_expr (sortLe le branches)
647 mb_deflt_id lo_tag hi_tag via_C
648 ; emitCgStmts stmts
649 }
650 where
651 (t1,_) `le` (t2,_) = t1 <= t2
652
653
654 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
655 -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
656 -> FCode CgStmts
657
658 -- SINGLETON TAG RANGE: no case analysis to do
659 mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C
660 | lo_tag == hi_tag
661 = ASSERT( tag == lo_tag )
662 return stmts
663
664 -- SINGLETON BRANCH, NO DEFUALT: no case analysis to do
665 mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag via_C
666 = return stmts
667 -- The simplifier might have eliminated a case
668 -- so we may have e.g. case xs of
669 -- [] -> e
670 -- In that situation we can be sure the (:) case
671 -- can't happen, so no need to test
672
673 -- SINGLETON BRANCH: one equality check to do
674 mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C
675 = return (CmmCondBranch cond deflt `consCgStmt` stmts)
676 where
677 cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
678 -- We have lo_tag < hi_tag, but there's only one branch,
679 -- so there must be a default
680
681 -- ToDo: we might want to check for the two branch case, where one of
682 -- the branches is the tag 0, because comparing '== 0' is likely to be
683 -- more efficient than other kinds of comparison.
684
685 -- DENSE TAG RANGE: use a switch statment.
686 --
687 -- We also use a switch uncoditionally when compiling via C, because
688 -- this will get emitted as a C switch statement and the C compiler
689 -- should do a good job of optimising it. Also, older GCC versions
690 -- (2.95 in particular) have problems compiling the complicated
691 -- if-trees generated by this code, so compiling to a switch every
692 -- time works around that problem.
693 --
694 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
695 | use_switch -- Use a switch
696 = do { branch_ids <- mapM forkCgStmts (map snd branches)
697 ; let
698 tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
699
700 find_branch :: ConTagZ -> Maybe BlockId
701 find_branch i = assocDefault mb_deflt tagged_blk_ids i
702
703 -- NB. we have eliminated impossible branches at
704 -- either end of the range (see below), so the first
705 -- tag of a real branch is real_lo_tag (not lo_tag).
706 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
707
708 switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
709
710 ; ASSERT(not (all isNothing arms))
711 return (oneCgStmt switch_stmt)
712 }
713
714 -- if we can knock off a bunch of default cases with one if, then do so
715 | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
716 = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
717 ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
718 branch = CmmCondBranch cond deflt
719 ; stmts <- mk_switch tag_expr' branches mb_deflt
720 lowest_branch hi_tag via_C
721 ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
722 }
723
724 | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
725 = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
726 ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
727 branch = CmmCondBranch cond deflt
728 ; stmts <- mk_switch tag_expr' branches mb_deflt
729 lo_tag highest_branch via_C
730 ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
731 }
732
733 | otherwise -- Use an if-tree
734 = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
735 -- To avoid duplication
736 ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
737 lo_tag (mid_tag-1) via_C
738 ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
739 mid_tag hi_tag via_C
740 ; hi_id <- forkCgStmts hi_stmts
741 ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
742 branch_stmt = CmmCondBranch cond hi_id
743 ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
744 }
745 -- we test (e >= mid_tag) rather than (e < mid_tag), because
746 -- the former works better when e is a comparison, and there
747 -- are two tags 0 & 1 (mid_tag == 1). In this case, the code
748 -- generator can reduce the condition to e itself without
749 -- having to reverse the sense of the comparison: comparisons
750 -- can't always be easily reversed (eg. floating
751 -- pt. comparisons).
752 where
753 use_switch = {- pprTrace "mk_switch" (
754 ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
755 text "branches:" <+> ppr (map fst branches) <+>
756 text "n_branches:" <+> int n_branches <+>
757 text "lo_tag:" <+> int lo_tag <+>
758 text "hi_tag:" <+> int hi_tag <+>
759 text "real_lo_tag:" <+> int real_lo_tag <+>
760 text "real_hi_tag:" <+> int real_hi_tag) $ -}
761 ASSERT( n_branches > 1 && n_tags > 1 )
762 n_tags > 2 && (via_C || (dense && big_enough))
763 -- up to 4 branches we use a decision tree, otherwise
764 -- a switch (== jump table in the NCG). This seems to be
765 -- optimal, and corresponds with what gcc does.
766 big_enough = n_branches > 4
767 dense = n_branches > (n_tags `div` 2)
768 n_branches = length branches
769
770 -- ignore default slots at each end of the range if there's
771 -- no default branch defined.
772 lowest_branch = fst (head branches)
773 highest_branch = fst (last branches)
774
775 real_lo_tag
776 | isNothing mb_deflt = lowest_branch
777 | otherwise = lo_tag
778
779 real_hi_tag
780 | isNothing mb_deflt = highest_branch
781 | otherwise = hi_tag
782
783 n_tags = real_hi_tag - real_lo_tag + 1
784
785 -- INVARIANT: Provided hi_tag > lo_tag (which is true)
786 -- lo_tag <= mid_tag < hi_tag
787 -- lo_branches have tags < mid_tag
788 -- hi_branches have tags >= mid_tag
789
790 (mid_tag,_) = branches !! (n_branches `div` 2)
791 -- 2 branches => n_branches `div` 2 = 1
792 -- => branches !! 1 give the *second* tag
793 -- There are always at least 2 branches here
794
795 (lo_branches, hi_branches) = span is_lo branches
796 is_lo (t,_) = t < mid_tag
797
798
799 assignTemp' e
800 | isTrivialCmmExpr e = return (CmmNop, e)
801 | otherwise = do { reg <- newTemp (cmmExprType e)
802 ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
803
804 emitLitSwitch :: CmmExpr -- Tag to switch on
805 -> [(Literal, CgStmts)] -- Tagged branches
806 -> CgStmts -- Default branch (always)
807 -> Code -- Emit the code
808 -- Used for general literals, whose size might not be a word,
809 -- where there is always a default case, and where we don't know
810 -- the range of values for certain. For simplicity we always generate a tree.
811 --
812 -- ToDo: for integers we could do better here, perhaps by generalising
813 -- mk_switch and using that. --SDM 15/09/2004
814 emitLitSwitch scrut [] deflt
815 = emitCgStmts deflt
816 emitLitSwitch scrut branches deflt_blk
817 = do { scrut' <- assignTemp scrut
818 ; deflt_blk_id <- forkCgStmts deflt_blk
819 ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
820 ; emitCgStmts blk }
821 where
822 le (t1,_) (t2,_) = t1 <= t2
823
824 mk_lit_switch :: CmmExpr -> BlockId
825 -> [(Literal,CgStmts)]
826 -> FCode CgStmts
827 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
828 = return (consCgStmt if_stmt blk)
829 where
830 cmm_lit = mkSimpleLit lit
831 rep = cmmLitType cmm_lit
832 ne = if isFloatType rep then MO_F_Ne else MO_Ne
833 cond = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit]
834 if_stmt = CmmCondBranch cond deflt_blk_id
835
836 mk_lit_switch scrut deflt_blk_id branches
837 = do { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
838 ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
839 ; lo_blk_id <- forkCgStmts lo_blk
840 ; let if_stmt = CmmCondBranch cond lo_blk_id
841 ; return (if_stmt `consCgStmt` hi_blk) }
842 where
843 n_branches = length branches
844 (mid_lit,_) = branches !! (n_branches `div` 2)
845 -- See notes above re mid_tag
846
847 (lo_branches, hi_branches) = span is_lo branches
848 is_lo (t,_) = t < mid_lit
849
850 cond = CmmMachOp (mkLtOp mid_lit)
851 [scrut, CmmLit (mkSimpleLit mid_lit)]
852
853 -------------------------------------------------------------------------
854 --
855 -- Simultaneous assignment
856 --
857 -------------------------------------------------------------------------
858
859
860 emitSimultaneously :: CmmStmts -> Code
861 -- Emit code to perform the assignments in the
862 -- input simultaneously, using temporary variables when necessary.
863 --
864 -- The Stmts must be:
865 -- CmmNop, CmmComment, CmmAssign, CmmStore
866 -- and nothing else
867
868
869 -- We use the strongly-connected component algorithm, in which
870 -- * the vertices are the statements
871 -- * an edge goes from s1 to s2 iff
872 -- s1 assigns to something s2 uses
873 -- that is, if s1 should *follow* s2 in the final order
874
875 type CVertex = (Int, CmmStmt) -- Give each vertex a unique number,
876 -- for fast comparison
877
878 emitSimultaneously stmts
879 = codeOnly $
880 case filterOut isNopStmt (stmtList stmts) of
881 -- Remove no-ops
882 [] -> nopC
883 [stmt] -> stmtC stmt -- It's often just one stmt
884 stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
885
886 doSimultaneously1 :: [CVertex] -> Code
887 doSimultaneously1 vertices
888 = let
889 edges = [ (vertex, key1, edges_from stmt1)
890 | vertex@(key1, stmt1) <- vertices
891 ]
892 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
893 stmt1 `mustFollow` stmt2
894 ]
895 components = stronglyConnCompFromEdgedVertices edges
896
897 -- do_components deal with one strongly-connected component
898 -- Not cyclic, or singleton? Just do it
899 do_component (AcyclicSCC (n,stmt)) = stmtC stmt
900 do_component (CyclicSCC [(n,stmt)]) = stmtC stmt
901
902 -- Cyclic? Then go via temporaries. Pick one to
903 -- break the loop and try again with the rest.
904 do_component (CyclicSCC ((n,first_stmt) : rest))
905 = do { from_temp <- go_via_temp first_stmt
906 ; doSimultaneously1 rest
907 ; stmtC from_temp }
908
909 go_via_temp (CmmAssign dest src)
910 = do { tmp <- newTemp (cmmRegType dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
911 ; stmtC (CmmAssign (CmmLocal tmp) src)
912 ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) }
913 go_via_temp (CmmStore dest src)
914 = do { tmp <- newTemp (cmmExprType src) -- TODO FIXME NOW if the pair of assignemnts move across a call this will be wrong
915 ; stmtC (CmmAssign (CmmLocal tmp) src)
916 ; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
917 in
918 mapCs do_component components
919
920 mustFollow :: CmmStmt -> CmmStmt -> Bool
921 CmmAssign reg _ `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
922 CmmStore loc e `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprType e)) stmt
923 CmmNop `mustFollow` stmt = False
924 CmmComment _ `mustFollow` stmt = False
925
926
927 anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool
928 -- True if the fn is true of any input of the stmt
929 anySrc p (CmmAssign _ e) = p e
930 anySrc p (CmmStore e1 e2) = p e1 || p e2 -- Might be used in either side
931 anySrc p (CmmComment _) = False
932 anySrc p CmmNop = False
933 anySrc p other = True -- Conservative
934
935 regUsedIn :: CmmReg -> CmmExpr -> Bool
936 reg `regUsedIn` CmmLit _ = False
937 reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
938 reg `regUsedIn` CmmReg reg' = reg == reg'
939 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
940 reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
941
942 locUsedIn :: CmmExpr -> CmmType -> CmmExpr -> Bool
943 -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
944 -- 'e'. Returns True if it's not sure.
945 locUsedIn loc rep (CmmLit _) = False
946 locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
947 locUsedIn loc rep (CmmReg reg') = False
948 locUsedIn loc rep (CmmRegOff reg' _) = False
949 locUsedIn loc rep (CmmMachOp _ es) = any (locUsedIn loc rep) es
950
951 possiblySameLoc :: CmmExpr -> CmmType -> CmmExpr -> CmmType -> Bool
952 -- Assumes that distinct registers (eg Hp, Sp) do not
953 -- point to the same location, nor any offset thereof.
954 possiblySameLoc (CmmReg r1) rep1 (CmmReg r2) rep2 = r1==r2
955 possiblySameLoc (CmmReg r1) rep1 (CmmRegOff r2 0) rep2 = r1==r2
956 possiblySameLoc (CmmRegOff r1 0) rep1 (CmmReg r2) rep2 = r1==r2
957 possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
958 = r1==r2 && end1 > start2 && end2 > start1
959 where
960 end1 = start1 + widthInBytes (typeWidth rep1)
961 end2 = start2 + widthInBytes (typeWidth rep2)
962
963 possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
964 possiblySameLoc l1 rep1 l2 rep2 = True -- Conservative
965
966 -------------------------------------------------------------------------
967 --
968 -- Static Reference Tables
969 --
970 -------------------------------------------------------------------------
971
972 -- There is just one SRT for each top level binding; all the nested
973 -- bindings use sub-sections of this SRT. The label is passed down to
974 -- the nested bindings via the monad.
975
976 getSRTInfo :: FCode C_SRT
977 getSRTInfo = do
978 srt_lbl <- getSRTLabel
979 srt <- getSRT
980 case srt of
981 -- TODO: Should we panic in this case?
982 -- Someone obviously thinks there should be an SRT
983 NoSRT -> return NoC_SRT
984 SRTEntries {} -> panic "getSRTInfo: SRTEntries. Perhaps you forgot to run SimplStg?"
985 SRT off len bmp
986 | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
987 -> do id <- newUnique
988 let srt_desc_lbl = mkLargeSRTLabel id
989 emitRODataLits "getSRTInfo" srt_desc_lbl
990 ( cmmLabelOffW srt_lbl off
991 : mkWordCLit (fromIntegral len)
992 : map mkWordCLit bmp)
993 return (C_SRT srt_desc_lbl 0 srt_escape)
994
995 SRT off len bmp
996 | otherwise
997 -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
998 -- The fromIntegral converts to StgHalfWord
999
1000 srt_escape = (-1) :: StgHalfWord
1001
1002 clHasCafRefs :: ClosureInfo -> CafInfo
1003 clHasCafRefs (ClosureInfo {closureSRT = srt}) =
1004 case srt of NoC_SRT -> NoCafRefs
1005 _ -> MayHaveCafRefs
1006 clHasCafRefs (ConInfo {}) = NoCafRefs