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