fa5807add05395507c11cb18b712e7c6c588afaf
[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 assignNonPtrTemp, newNonPtrTemp,
24 assignPtrTemp, newPtrTemp,
25 emitSimultaneously,
26 emitSwitch, emitLitSwitch,
27 tagToClosure,
28
29 callerSaveVolatileRegs, get_GlobalReg_addr,
30
31 cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
32 cmmUGtWord,
33 cmmOffsetExprW, cmmOffsetExprB,
34 cmmRegOffW, cmmRegOffB,
35 cmmLabelOffW, cmmLabelOffB,
36 cmmOffsetW, cmmOffsetB,
37 cmmOffsetLitW, cmmOffsetLitB,
38 cmmLoadIndexW,
39 cmmConstrTag, cmmConstrTag1,
40
41 tagForCon, tagCons, isSmallFamily,
42 cmmUntag, cmmIsTagged, cmmGetTag,
43
44 addToMem, addToMemE,
45 mkWordCLit,
46 mkStringCLit, mkByteStringCLit,
47 packHalfWordsCLit,
48 blankWord,
49
50 getSRTInfo
51 ) where
52
53 #include "HsVersions.h"
54 #include "MachRegs.h"
55
56 import CgMonad
57 import TyCon
58 import DataCon
59 import Id
60 import Constants
61 import SMRep
62 import PprCmm ( {- instances -} )
63 import Cmm
64 import CLabel
65 import CmmUtils
66 import MachOp
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)) wordRep
106 mkSimpleLit MachNullAddr = zeroCLit
107 mkSimpleLit (MachInt i) = CmmInt i wordRep
108 mkSimpleLit (MachInt64 i) = CmmInt i I64
109 mkSimpleLit (MachWord i) = CmmInt i wordRep
110 mkSimpleLit (MachWord64 i) = CmmInt i I64
111 mkSimpleLit (MachFloat r) = CmmFloat r F32
112 mkSimpleLit (MachDouble r) = CmmFloat r F64
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 wordRep
120 mkLtOp (MachFloat _) = MO_S_Lt F32
121 mkLtOp (MachDouble _) = MO_S_Lt F64
122 mkLtOp lit = MO_U_Lt (cmmLitRep (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 wordRep 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 -> CmmExpr
168 cmmLoadIndexW base off
169 = CmmLoad (cmmOffsetW base off) wordRep
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 (cmmExprRep 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) wordRep
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 :: MachRep -- rep of the counter
270 -> CmmExpr -- Address
271 -> Int -- What to add (a word)
272 -> CmmStmt
273 addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) rep))
274
275 addToMemE :: MachRep -- rep of the counter
276 -> CmmExpr -- Address
277 -> CmmExpr -- What to add (a word-typed expression)
278 -> CmmStmt
279 addToMemE rep ptr n
280 = CmmStore ptr (CmmMachOp (MO_Add rep) [CmmLoad ptr rep, 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) wordRep
292 where closure_tbl = CmmLit (CmmLabel lbl)
293 lbl = mkClosureTableLabel (tyConName tycon)
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 ; else_id <- newLabelC
327 ; join_id <- newLabelC
328 ; stmtC (CmmCondBranch cond then_id)
329 ; else_part
330 ; stmtC (CmmBranch join_id)
331 ; labelC then_id
332 ; then_part
333 ; labelC join_id
334 }
335
336 emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Bool -> Code
337 emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
338 -- The 'Nothing' says "save all global registers"
339
340 emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Bool -> Code
341 emitRtsCallWithVols fun args vols safe
342 = emitRtsCall' [] fun args (Just vols) safe
343
344 emitRtsCallWithResult :: LocalReg -> MachHint -> LitString
345 -> [(CmmExpr,MachHint)] -> Bool -> Code
346 emitRtsCallWithResult res hint fun args safe
347 = emitRtsCall' [(res,hint)] fun args Nothing safe
348
349 -- Make a call to an RTS C procedure
350 emitRtsCall'
351 :: CmmFormals
352 -> LitString
353 -> [(CmmExpr,MachHint)]
354 -> Maybe [GlobalReg]
355 -> Bool -- True <=> CmmSafe call
356 -> Code
357 emitRtsCall' res fun args vols safe = do
358 safety <- if safe
359 then getSRTInfo >>= (return . CmmSafe)
360 else return CmmUnsafe
361 stmtsC caller_save
362 stmtC (CmmCall target res args safety CmmMayReturn)
363 stmtsC caller_load
364 where
365 (caller_save, caller_load) = callerSaveVolatileRegs vols
366 target = CmmCallee fun_expr CCallConv
367 fun_expr = mkLblExpr (mkRtsCodeLabel fun)
368
369 -----------------------------------------------------------------------------
370 --
371 -- Caller-Save Registers
372 --
373 -----------------------------------------------------------------------------
374
375 -- Here we generate the sequence of saves/restores required around a
376 -- foreign call instruction.
377
378 -- TODO: reconcile with includes/Regs.h
379 -- * Regs.h claims that BaseReg should be saved last and loaded first
380 -- * This might not have been tickled before since BaseReg is callee save
381 -- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
382 callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt])
383 callerSaveVolatileRegs vols = (caller_save, caller_load)
384 where
385 caller_save = foldr ($!) [] (map callerSaveGlobalReg regs_to_save)
386 caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save)
387
388 system_regs = [Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery,
389 {-SparkHd,SparkTl,SparkBase,SparkLim,-}BaseReg ]
390
391 regs_to_save = system_regs ++ vol_list
392
393 vol_list = case vols of Nothing -> all_of_em; Just regs -> regs
394
395 all_of_em = [ VanillaReg n | n <- [0..mAX_Vanilla_REG] ]
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) (globalRegRep 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 (globalRegRep 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 :: MachRep -> 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 GCEnter1 = oFFSET_stgGCEnter1
545 baseRegOffset GCFun = oFFSET_stgGCFun
546 #ifdef DEBUG
547 baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
548 baseRegOffset _ = panic "baseRegOffset:other"
549 #endif
550
551
552 -------------------------------------------------------------------------
553 --
554 -- Strings generate a top-level data block
555 --
556 -------------------------------------------------------------------------
557
558 emitDataLits :: CLabel -> [CmmLit] -> Code
559 -- Emit a data-segment data block
560 emitDataLits lbl lits
561 = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
562
563 mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
564 -- Emit a data-segment data block
565 mkDataLits lbl lits
566 = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
567
568 emitRODataLits :: CLabel -> [CmmLit] -> Code
569 -- Emit a read-only data block
570 emitRODataLits lbl lits
571 = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
572 where section | any needsRelocation lits = RelocatableReadOnlyData
573 | otherwise = ReadOnlyData
574 needsRelocation (CmmLabel _) = True
575 needsRelocation (CmmLabelOff _ _) = True
576 needsRelocation _ = False
577
578 mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
579 mkRODataLits lbl lits
580 = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
581 where section | any needsRelocation lits = RelocatableReadOnlyData
582 | otherwise = ReadOnlyData
583 needsRelocation (CmmLabel _) = True
584 needsRelocation (CmmLabelOff _ _) = True
585 needsRelocation _ = False
586
587 mkStringCLit :: String -> FCode CmmLit
588 -- Make a global definition for the string,
589 -- and return its label
590 mkStringCLit str = mkByteStringCLit (map (fromIntegral.ord) str)
591
592 mkByteStringCLit :: [Word8] -> FCode CmmLit
593 mkByteStringCLit bytes
594 = do { uniq <- newUnique
595 ; let lbl = mkStringLitLabel uniq
596 ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
597 ; return (CmmLabel lbl) }
598
599 -------------------------------------------------------------------------
600 --
601 -- Assigning expressions to temporaries
602 --
603 -------------------------------------------------------------------------
604
605 assignNonPtrTemp :: CmmExpr -> FCode CmmExpr
606 -- For a non-trivial expression, e, create a local
607 -- variable and assign the expression to it
608 assignNonPtrTemp e
609 | isTrivialCmmExpr e = return e
610 | otherwise = do { reg <- newNonPtrTemp (cmmExprRep e)
611 ; stmtC (CmmAssign (CmmLocal reg) e)
612 ; return (CmmReg (CmmLocal reg)) }
613
614 assignPtrTemp :: CmmExpr -> FCode CmmExpr
615 -- For a non-trivial expression, e, create a local
616 -- variable and assign the expression to it
617 assignPtrTemp e
618 | isTrivialCmmExpr e = return e
619 | otherwise = do { reg <- newPtrTemp (cmmExprRep e)
620 ; stmtC (CmmAssign (CmmLocal reg) e)
621 ; return (CmmReg (CmmLocal reg)) }
622
623 newNonPtrTemp :: MachRep -> FCode LocalReg
624 newNonPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep GCKindNonPtr) }
625
626 newPtrTemp :: MachRep -> FCode LocalReg
627 newPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep GCKindPtr) }
628
629
630 -------------------------------------------------------------------------
631 --
632 -- Building case analysis
633 --
634 -------------------------------------------------------------------------
635
636 emitSwitch
637 :: CmmExpr -- Tag to switch on
638 -> [(ConTagZ, CgStmts)] -- Tagged branches
639 -> Maybe CgStmts -- Default branch (if any)
640 -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
641 -- outside this range is undefined
642 -> Code
643
644 -- ONLY A DEFAULT BRANCH: no case analysis to do
645 emitSwitch tag_expr [] (Just stmts) _ _
646 = emitCgStmts stmts
647
648 -- Right, off we go
649 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
650 = -- Just sort the branches before calling mk_sritch
651 do { mb_deflt_id <-
652 case mb_deflt of
653 Nothing -> return Nothing
654 Just stmts -> do id <- forkCgStmts stmts; return (Just id)
655
656 ; dflags <- getDynFlags
657 ; let via_C | HscC <- hscTarget dflags = True
658 | otherwise = False
659
660 ; stmts <- mk_switch tag_expr (sortLe le branches)
661 mb_deflt_id lo_tag hi_tag via_C
662 ; emitCgStmts stmts
663 }
664 where
665 (t1,_) `le` (t2,_) = t1 <= t2
666
667
668 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
669 -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
670 -> FCode CgStmts
671
672 -- SINGLETON TAG RANGE: no case analysis to do
673 mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C
674 | lo_tag == hi_tag
675 = ASSERT( tag == lo_tag )
676 return stmts
677
678 -- SINGLETON BRANCH, NO DEFUALT: no case analysis to do
679 mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag via_C
680 = return stmts
681 -- The simplifier might have eliminated a case
682 -- so we may have e.g. case xs of
683 -- [] -> e
684 -- In that situation we can be sure the (:) case
685 -- can't happen, so no need to test
686
687 -- SINGLETON BRANCH: one equality check to do
688 mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C
689 = return (CmmCondBranch cond deflt `consCgStmt` stmts)
690 where
691 cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
692 -- We have lo_tag < hi_tag, but there's only one branch,
693 -- so there must be a default
694
695 -- ToDo: we might want to check for the two branch case, where one of
696 -- the branches is the tag 0, because comparing '== 0' is likely to be
697 -- more efficient than other kinds of comparison.
698
699 -- DENSE TAG RANGE: use a switch statment.
700 --
701 -- We also use a switch uncoditionally when compiling via C, because
702 -- this will get emitted as a C switch statement and the C compiler
703 -- should do a good job of optimising it. Also, older GCC versions
704 -- (2.95 in particular) have problems compiling the complicated
705 -- if-trees generated by this code, so compiling to a switch every
706 -- time works around that problem.
707 --
708 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
709 | use_switch -- Use a switch
710 = do { branch_ids <- mapM forkCgStmts (map snd branches)
711 ; let
712 tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
713
714 find_branch :: ConTagZ -> Maybe BlockId
715 find_branch i = assocDefault mb_deflt tagged_blk_ids i
716
717 -- NB. we have eliminated impossible branches at
718 -- either end of the range (see below), so the first
719 -- tag of a real branch is real_lo_tag (not lo_tag).
720 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
721
722 switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
723
724 ; ASSERT(not (all isNothing arms))
725 return (oneCgStmt switch_stmt)
726 }
727
728 -- if we can knock off a bunch of default cases with one if, then do so
729 | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
730 = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
731 ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
732 branch = CmmCondBranch cond deflt
733 ; stmts <- mk_switch tag_expr' branches mb_deflt
734 lowest_branch hi_tag via_C
735 ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
736 }
737
738 | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
739 = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
740 ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
741 branch = CmmCondBranch cond deflt
742 ; stmts <- mk_switch tag_expr' branches mb_deflt
743 lo_tag highest_branch via_C
744 ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
745 }
746
747 | otherwise -- Use an if-tree
748 = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
749 -- To avoid duplication
750 ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
751 lo_tag (mid_tag-1) via_C
752 ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
753 mid_tag hi_tag via_C
754 ; hi_id <- forkCgStmts hi_stmts
755 ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
756 branch_stmt = CmmCondBranch cond hi_id
757 ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
758 }
759 -- we test (e >= mid_tag) rather than (e < mid_tag), because
760 -- the former works better when e is a comparison, and there
761 -- are two tags 0 & 1 (mid_tag == 1). In this case, the code
762 -- generator can reduce the condition to e itself without
763 -- having to reverse the sense of the comparison: comparisons
764 -- can't always be easily reversed (eg. floating
765 -- pt. comparisons).
766 where
767 use_switch = {- pprTrace "mk_switch" (
768 ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
769 text "branches:" <+> ppr (map fst branches) <+>
770 text "n_branches:" <+> int n_branches <+>
771 text "lo_tag:" <+> int lo_tag <+>
772 text "hi_tag:" <+> int hi_tag <+>
773 text "real_lo_tag:" <+> int real_lo_tag <+>
774 text "real_hi_tag:" <+> int real_hi_tag) $ -}
775 ASSERT( n_branches > 1 && n_tags > 1 )
776 n_tags > 2 && (via_C || (dense && big_enough))
777 -- up to 4 branches we use a decision tree, otherwise
778 -- a switch (== jump table in the NCG). This seems to be
779 -- optimal, and corresponds with what gcc does.
780 big_enough = n_branches > 4
781 dense = n_branches > (n_tags `div` 2)
782 n_branches = length branches
783
784 -- ignore default slots at each end of the range if there's
785 -- no default branch defined.
786 lowest_branch = fst (head branches)
787 highest_branch = fst (last branches)
788
789 real_lo_tag
790 | isNothing mb_deflt = lowest_branch
791 | otherwise = lo_tag
792
793 real_hi_tag
794 | isNothing mb_deflt = highest_branch
795 | otherwise = hi_tag
796
797 n_tags = real_hi_tag - real_lo_tag + 1
798
799 -- INVARIANT: Provided hi_tag > lo_tag (which is true)
800 -- lo_tag <= mid_tag < hi_tag
801 -- lo_branches have tags < mid_tag
802 -- hi_branches have tags >= mid_tag
803
804 (mid_tag,_) = branches !! (n_branches `div` 2)
805 -- 2 branches => n_branches `div` 2 = 1
806 -- => branches !! 1 give the *second* tag
807 -- There are always at least 2 branches here
808
809 (lo_branches, hi_branches) = span is_lo branches
810 is_lo (t,_) = t < mid_tag
811
812
813 assignNonPtrTemp' e
814 | isTrivialCmmExpr e = return (CmmNop, e)
815 | otherwise = do { reg <- newNonPtrTemp (cmmExprRep e)
816 ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
817
818 emitLitSwitch :: CmmExpr -- Tag to switch on
819 -> [(Literal, CgStmts)] -- Tagged branches
820 -> CgStmts -- Default branch (always)
821 -> Code -- Emit the code
822 -- Used for general literals, whose size might not be a word,
823 -- where there is always a default case, and where we don't know
824 -- the range of values for certain. For simplicity we always generate a tree.
825 --
826 -- ToDo: for integers we could do better here, perhaps by generalising
827 -- mk_switch and using that. --SDM 15/09/2004
828 emitLitSwitch scrut [] deflt
829 = emitCgStmts deflt
830 emitLitSwitch scrut branches deflt_blk
831 = do { scrut' <- assignNonPtrTemp scrut
832 ; deflt_blk_id <- forkCgStmts deflt_blk
833 ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
834 ; emitCgStmts blk }
835 where
836 le (t1,_) (t2,_) = t1 <= t2
837
838 mk_lit_switch :: CmmExpr -> BlockId
839 -> [(Literal,CgStmts)]
840 -> FCode CgStmts
841 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
842 = return (consCgStmt if_stmt blk)
843 where
844 cmm_lit = mkSimpleLit lit
845 rep = cmmLitRep cmm_lit
846 cond = CmmMachOp (MO_Ne 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 = stronglyConnComp 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 <- newNonPtrTemp (cmmRegRep 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 <- newNonPtrTemp (cmmExprRep 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 (cmmExprRep 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 regUsedIn :: CmmReg -> CmmExpr -> Bool
949 reg `regUsedIn` CmmLit _ = False
950 reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
951 reg `regUsedIn` CmmReg reg' = reg == reg'
952 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
953 reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
954
955 locUsedIn :: CmmExpr -> MachRep -> CmmExpr -> Bool
956 -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
957 -- 'e'. Returns True if it's not sure.
958 locUsedIn loc rep (CmmLit _) = False
959 locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
960 locUsedIn loc rep (CmmReg reg') = False
961 locUsedIn loc rep (CmmRegOff reg' _) = False
962 locUsedIn loc rep (CmmMachOp _ es) = any (locUsedIn loc rep) es
963
964 possiblySameLoc :: CmmExpr -> MachRep -> CmmExpr -> MachRep -> Bool
965 -- Assumes that distinct registers (eg Hp, Sp) do not
966 -- point to the same location, nor any offset thereof.
967 possiblySameLoc (CmmReg r1) rep1 (CmmReg r2) rep2 = r1==r2
968 possiblySameLoc (CmmReg r1) rep1 (CmmRegOff r2 0) rep2 = r1==r2
969 possiblySameLoc (CmmRegOff r1 0) rep1 (CmmReg r2) rep2 = r1==r2
970 possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
971 = r1==r2 && end1 > start2 && end2 > start1
972 where
973 end1 = start1 + machRepByteWidth rep1
974 end2 = start2 + machRepByteWidth rep2
975
976 possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
977 possiblySameLoc l1 rep1 l2 rep2 = True -- Conservative
978
979 -------------------------------------------------------------------------
980 --
981 -- Static Reference Tables
982 --
983 -------------------------------------------------------------------------
984
985 -- There is just one SRT for each top level binding; all the nested
986 -- bindings use sub-sections of this SRT. The label is passed down to
987 -- the nested bindings via the monad.
988
989 getSRTInfo :: FCode C_SRT
990 getSRTInfo = do
991 srt_lbl <- getSRTLabel
992 srt <- getSRT
993 case srt of
994 -- TODO: Should we panic in this case?
995 -- Someone obviously thinks there should be an SRT
996 NoSRT -> return NoC_SRT
997 SRT off len bmp
998 | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
999 -> do id <- newUnique
1000 let srt_desc_lbl = mkLargeSRTLabel id
1001 emitRODataLits srt_desc_lbl
1002 ( cmmLabelOffW srt_lbl off
1003 : mkWordCLit (fromIntegral len)
1004 : map mkWordCLit bmp)
1005 return (C_SRT srt_desc_lbl 0 srt_escape)
1006
1007 SRT off len bmp
1008 | otherwise
1009 -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
1010 -- The fromIntegral converts to StgHalfWord
1011
1012 srt_escape = (-1) :: StgHalfWord