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