74da7317d4d262adf367b25ca3d20404498716e6
[ghc.git] / compiler / codeGen / StgCmmUtils.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generator utilities; mostly monadic
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module StgCmmUtils (
10 cgLit, mkSimpleLit,
11 emitDataLits, mkDataLits,
12 emitRODataLits, mkRODataLits,
13 emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
14 assignTemp, newTemp, withTemp,
15
16 newUnboxedTupleRegs,
17
18 mkMultiAssign, mkCmmSwitch, mkCmmLitSwitch,
19 emitSwitch,
20
21 tagToClosure, mkTaggedObjectLoad,
22
23 callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
24
25 cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
26 cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
27 cmmOffsetExprW, cmmOffsetExprB,
28 cmmRegOffW, cmmRegOffB,
29 cmmLabelOffW, cmmLabelOffB,
30 cmmOffsetW, cmmOffsetB,
31 cmmOffsetLitW, cmmOffsetLitB,
32 cmmLoadIndexW,
33 cmmConstrTag, cmmConstrTag1,
34
35 cmmUntag, cmmIsTagged, cmmGetTag,
36
37 addToMem, addToMemE, addToMemLbl,
38 mkWordCLit,
39 mkStringCLit, mkByteStringCLit,
40 packHalfWordsCLit,
41 blankWord,
42
43 getSRTInfo, clHasCafRefs, srt_escape
44 ) where
45
46 #include "HsVersions.h"
47 #include "../includes/stg/MachRegs.h"
48
49 import StgCmmMonad
50 import StgCmmClosure
51 import BlockId
52 import CmmDecl
53 import CmmExpr hiding (regUsedIn)
54 import MkGraph
55 import CLabel
56 import CmmUtils
57
58 import ForeignCall
59 import IdInfo
60 import Type
61 import TyCon
62 import Constants
63 import SMRep
64 import StgSyn ( SRT(..) )
65 import Module
66 import Literal
67 import Digraph
68 import ListSetOps
69 import Util
70 import Unique
71 import DynFlags
72 import FastString
73 import Outputable
74
75 import Data.Char
76 import Data.Bits
77 import Data.Word
78 import Data.Maybe
79
80
81 -------------------------------------------------------------------------
82 --
83 -- Literals
84 --
85 -------------------------------------------------------------------------
86
87 cgLit :: Literal -> FCode CmmLit
88 cgLit (MachStr s) = mkByteStringCLit (bytesFS s)
89 -- not unpackFS; we want the UTF-8 byte stream.
90 cgLit other_lit = return (mkSimpleLit other_lit)
91
92 mkSimpleLit :: Literal -> CmmLit
93 mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth
94 mkSimpleLit MachNullAddr = zeroCLit
95 mkSimpleLit (MachInt i) = CmmInt i wordWidth
96 mkSimpleLit (MachInt64 i) = CmmInt i W64
97 mkSimpleLit (MachWord i) = CmmInt i wordWidth
98 mkSimpleLit (MachWord64 i) = CmmInt i W64
99 mkSimpleLit (MachFloat r) = CmmFloat r W32
100 mkSimpleLit (MachDouble r) = CmmFloat r W64
101 mkSimpleLit (MachLabel fs ms fod)
102 = CmmLabel (mkForeignLabel fs ms labelSrc fod)
103 where
104 -- TODO: Literal labels might not actually be in the current package...
105 labelSrc = ForeignLabelInThisPackage
106 mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other)
107
108 mkLtOp :: Literal -> MachOp
109 -- On signed literals we must do a signed comparison
110 mkLtOp (MachInt _) = MO_S_Lt wordWidth
111 mkLtOp (MachFloat _) = MO_F_Lt W32
112 mkLtOp (MachDouble _) = MO_F_Lt W64
113 mkLtOp lit = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit)))
114 -- ToDo: seems terribly indirect!
115
116
117 ---------------------------------------------------
118 --
119 -- Cmm data type functions
120 --
121 ---------------------------------------------------
122
123 -- The "B" variants take byte offsets
124 cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
125 cmmRegOffB = cmmRegOff
126
127 cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr
128 cmmOffsetB = cmmOffset
129
130 cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr
131 cmmOffsetExprB = cmmOffsetExpr
132
133 cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
134 cmmLabelOffB = cmmLabelOff
135
136 cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
137 cmmOffsetLitB = cmmOffsetLit
138
139 -----------------------
140 -- The "W" variants take word offsets
141 cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr
142 -- The second arg is a *word* offset; need to change it to bytes
143 cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n)
144 cmmOffsetExprW e wd_off = cmmIndexExpr wordWidth e wd_off
145
146 cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr
147 cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n)
148
149 cmmRegOffW :: CmmReg -> WordOff -> CmmExpr
150 cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE)
151
152 cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit
153 cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off)
154
155 cmmLabelOffW :: CLabel -> WordOff -> CmmLit
156 cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off)
157
158 cmmLoadIndexW :: CmmExpr -> Int -> CmmType -> CmmExpr
159 cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty
160
161 -----------------------
162 cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
163 cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
164 cmmUShrWord, cmmAddWord, cmmMulWord
165 :: CmmExpr -> CmmExpr -> CmmExpr
166 cmmOrWord e1 e2 = CmmMachOp mo_wordOr [e1, e2]
167 cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
168 cmmNeWord e1 e2 = CmmMachOp mo_wordNe [e1, e2]
169 cmmEqWord e1 e2 = CmmMachOp mo_wordEq [e1, e2]
170 cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
171 cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
172 cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
173 --cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
174 cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
175 cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2]
176 cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
177 cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2]
178
179 cmmNegate :: CmmExpr -> CmmExpr
180 cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
181 cmmNegate e = CmmMachOp (MO_S_Neg (cmmExprWidth e)) [e]
182
183 blankWord :: CmmStatic
184 blankWord = CmmUninitialised wORD_SIZE
185
186 -- Tagging --
187 -- Tag bits mask
188 --cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
189 cmmTagMask, cmmPointerMask :: CmmExpr
190 cmmTagMask = CmmLit (mkIntCLit tAG_MASK)
191 cmmPointerMask = CmmLit (mkIntCLit (complement tAG_MASK))
192
193 -- Used to untag a possibly tagged pointer
194 -- A static label need not be untagged
195 cmmUntag, cmmGetTag :: CmmExpr -> CmmExpr
196 cmmUntag e@(CmmLit (CmmLabel _)) = e
197 -- Default case
198 cmmUntag e = (e `cmmAndWord` cmmPointerMask)
199
200 cmmGetTag e = (e `cmmAndWord` cmmTagMask)
201
202 -- Test if a closure pointer is untagged
203 cmmIsTagged :: CmmExpr -> CmmExpr
204 cmmIsTagged e = (e `cmmAndWord` cmmTagMask)
205 `cmmNeWord` CmmLit zeroCLit
206
207 cmmConstrTag, cmmConstrTag1 :: CmmExpr -> CmmExpr
208 cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` (CmmLit (mkIntCLit 1))
209 -- Get constructor tag, but one based.
210 cmmConstrTag1 e = e `cmmAndWord` cmmTagMask
211
212 -----------------------
213 -- Making literals
214
215 mkWordCLit :: StgWord -> CmmLit
216 mkWordCLit wd = CmmInt (fromIntegral wd) wordWidth
217
218 packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit
219 -- Make a single word literal in which the lower_half_word is
220 -- at the lower address, and the upper_half_word is at the
221 -- higher address
222 -- ToDo: consider using half-word lits instead
223 -- but be careful: that's vulnerable when reversed
224 packHalfWordsCLit lower_half_word upper_half_word
225 #ifdef WORDS_BIGENDIAN
226 = mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)
227 .|. fromIntegral upper_half_word)
228 #else
229 = mkWordCLit ((fromIntegral lower_half_word)
230 .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS))
231 #endif
232
233 --------------------------------------------------------------------------
234 --
235 -- Incrementing a memory location
236 --
237 --------------------------------------------------------------------------
238
239 addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
240 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
241
242 addToMem :: CmmType -- rep of the counter
243 -> CmmExpr -- Address
244 -> Int -- What to add (a word)
245 -> CmmAGraph
246 addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))
247
248 addToMemE :: CmmType -- rep of the counter
249 -> CmmExpr -- Address
250 -> CmmExpr -- What to add (a word-typed expression)
251 -> CmmAGraph
252 addToMemE rep ptr n
253 = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])
254
255
256 -------------------------------------------------------------------------
257 --
258 -- Loading a field from an object,
259 -- where the object pointer is itself tagged
260 --
261 -------------------------------------------------------------------------
262
263 mkTaggedObjectLoad :: LocalReg -> LocalReg -> WordOff -> DynTag -> CmmAGraph
264 -- (loadTaggedObjectField reg base off tag) generates assignment
265 -- reg = bitsK[ base + off - tag ]
266 -- where K is fixed by 'reg'
267 mkTaggedObjectLoad reg base offset tag
268 = mkAssign (CmmLocal reg)
269 (CmmLoad (cmmOffsetB (CmmReg (CmmLocal base))
270 (wORD_SIZE*offset - tag))
271 (localRegType reg))
272
273 -------------------------------------------------------------------------
274 --
275 -- Converting a closure tag to a closure for enumeration types
276 -- (this is the implementation of tagToEnum#).
277 --
278 -------------------------------------------------------------------------
279
280 tagToClosure :: TyCon -> CmmExpr -> CmmExpr
281 tagToClosure tycon tag
282 = CmmLoad (cmmOffsetExprW closure_tbl tag) bWord
283 where closure_tbl = CmmLit (CmmLabel lbl)
284 lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
285
286 -------------------------------------------------------------------------
287 --
288 -- Conditionals and rts calls
289 --
290 -------------------------------------------------------------------------
291
292 emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
293 emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe
294 -- The 'Nothing' says "save all global registers"
295
296 emitRtsCallWithVols :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode ()
297 emitRtsCallWithVols pkg fun args vols safe
298 = emitRtsCall' [] pkg fun args (Just vols) safe
299
300 emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString
301 -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
302 emitRtsCallWithResult res hint pkg fun args safe
303 = emitRtsCall' [(res,hint)] pkg fun args Nothing safe
304
305 -- Make a call to an RTS C procedure
306 emitRtsCall'
307 :: [(LocalReg,ForeignHint)]
308 -> PackageId
309 -> FastString
310 -> [(CmmExpr,ForeignHint)]
311 -> Maybe [GlobalReg]
312 -> Bool -- True <=> CmmSafe call
313 -> FCode ()
314 emitRtsCall' res pkg fun args _vols safe
315 = --error "emitRtsCall'"
316 do { updfr_off <- getUpdFrameOff
317 ; emit caller_save
318 ; emit $ call updfr_off
319 ; emit caller_load }
320 where
321 call updfr_off =
322 if safe then
323 mkCmmCall fun_expr res' args' updfr_off
324 else
325 mkUnsafeCall (ForeignTarget fun_expr
326 (ForeignConvention CCallConv arg_hints res_hints)) res' args'
327 (args', arg_hints) = unzip args
328 (res', res_hints) = unzip res
329 (caller_save, caller_load) = callerSaveVolatileRegs
330 fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
331
332
333 -----------------------------------------------------------------------------
334 --
335 -- Caller-Save Registers
336 --
337 -----------------------------------------------------------------------------
338
339 -- Here we generate the sequence of saves/restores required around a
340 -- foreign call instruction.
341
342 -- TODO: reconcile with includes/Regs.h
343 -- * Regs.h claims that BaseReg should be saved last and loaded first
344 -- * This might not have been tickled before since BaseReg is callee save
345 -- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
346 --
347 -- This code isn't actually used right now, because callerSaves
348 -- only ever returns true in the current universe for registers NOT in
349 -- system_regs (just do a grep for CALLER_SAVES in
350 -- includes/stg/MachRegs.h). It's all one giant no-op, and for
351 -- good reason: having to save system registers on every foreign call
352 -- would be very expensive, so we avoid assigning them to those
353 -- registers when we add support for an architecture.
354 --
355 -- Note that the old code generator actually does more work here: it
356 -- also saves other global registers. We can't (nor want) to do that
357 -- here, as we don't have liveness information. And really, we
358 -- shouldn't be doing the workaround at this point in the pipeline, see
359 -- Note [Register parameter passing] and the ToDo on CmmCall in
360 -- cmm/CmmNode.hs. Right now the workaround is to avoid inlining across
361 -- unsafe foreign calls in rewriteAssignments, but this is strictly
362 -- temporary.
363 callerSaveVolatileRegs :: (CmmAGraph, CmmAGraph)
364 callerSaveVolatileRegs = (caller_save, caller_load)
365 where
366 caller_save = catAGraphs (map callerSaveGlobalReg regs_to_save)
367 caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
368
369 system_regs = [ Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery
370 {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
371 , BaseReg ]
372
373 regs_to_save = filter callerSaves system_regs
374
375 callerSaveGlobalReg reg
376 = mkStore (get_GlobalReg_addr reg) (CmmReg (CmmGlobal reg))
377
378 callerRestoreGlobalReg reg
379 = mkAssign (CmmGlobal reg)
380 (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
381
382 -- -----------------------------------------------------------------------------
383 -- Global registers
384
385 -- We map STG registers onto appropriate CmmExprs. Either they map
386 -- to real machine registers or stored as offsets from BaseReg. Given
387 -- a GlobalReg, get_GlobalReg_addr always produces the
388 -- register table address for it.
389 -- (See also get_GlobalReg_reg_or_addr in MachRegs)
390
391 get_GlobalReg_addr :: GlobalReg -> CmmExpr
392 get_GlobalReg_addr BaseReg = regTableOffset 0
393 get_GlobalReg_addr mid = get_Regtable_addr_from_offset
394 (globalRegType mid) (baseRegOffset mid)
395
396 -- Calculate a literal representing an offset into the register table.
397 -- Used when we don't have an actual BaseReg to offset from.
398 regTableOffset :: Int -> CmmExpr
399 regTableOffset n =
400 CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
401
402 get_Regtable_addr_from_offset :: CmmType -> Int -> CmmExpr
403 get_Regtable_addr_from_offset _rep offset =
404 #ifdef REG_Base
405 CmmRegOff (CmmGlobal BaseReg) offset
406 #else
407 regTableOffset offset
408 #endif
409
410
411 -- | Returns 'True' if this global register is stored in a caller-saves
412 -- machine register.
413
414 callerSaves :: GlobalReg -> Bool
415
416 #ifdef CALLER_SAVES_Base
417 callerSaves BaseReg = True
418 #endif
419 #ifdef CALLER_SAVES_R1
420 callerSaves (VanillaReg 1 _) = True
421 #endif
422 #ifdef CALLER_SAVES_R2
423 callerSaves (VanillaReg 2 _) = True
424 #endif
425 #ifdef CALLER_SAVES_R3
426 callerSaves (VanillaReg 3 _) = True
427 #endif
428 #ifdef CALLER_SAVES_R4
429 callerSaves (VanillaReg 4 _) = True
430 #endif
431 #ifdef CALLER_SAVES_R5
432 callerSaves (VanillaReg 5 _) = True
433 #endif
434 #ifdef CALLER_SAVES_R6
435 callerSaves (VanillaReg 6 _) = True
436 #endif
437 #ifdef CALLER_SAVES_R7
438 callerSaves (VanillaReg 7 _) = True
439 #endif
440 #ifdef CALLER_SAVES_R8
441 callerSaves (VanillaReg 8 _) = True
442 #endif
443 #ifdef CALLER_SAVES_F1
444 callerSaves (FloatReg 1) = True
445 #endif
446 #ifdef CALLER_SAVES_F2
447 callerSaves (FloatReg 2) = True
448 #endif
449 #ifdef CALLER_SAVES_F3
450 callerSaves (FloatReg 3) = True
451 #endif
452 #ifdef CALLER_SAVES_F4
453 callerSaves (FloatReg 4) = True
454 #endif
455 #ifdef CALLER_SAVES_D1
456 callerSaves (DoubleReg 1) = True
457 #endif
458 #ifdef CALLER_SAVES_D2
459 callerSaves (DoubleReg 2) = True
460 #endif
461 #ifdef CALLER_SAVES_L1
462 callerSaves (LongReg 1) = True
463 #endif
464 #ifdef CALLER_SAVES_Sp
465 callerSaves Sp = True
466 #endif
467 #ifdef CALLER_SAVES_SpLim
468 callerSaves SpLim = True
469 #endif
470 #ifdef CALLER_SAVES_Hp
471 callerSaves Hp = True
472 #endif
473 #ifdef CALLER_SAVES_HpLim
474 callerSaves HpLim = True
475 #endif
476 #ifdef CALLER_SAVES_CurrentTSO
477 callerSaves CurrentTSO = True
478 #endif
479 #ifdef CALLER_SAVES_CurrentNursery
480 callerSaves CurrentNursery = True
481 #endif
482 callerSaves _ = False
483
484
485 -- -----------------------------------------------------------------------------
486 -- Information about global registers
487
488 baseRegOffset :: GlobalReg -> Int
489
490 baseRegOffset Sp = oFFSET_StgRegTable_rSp
491 baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim
492 baseRegOffset (LongReg 1) = oFFSET_StgRegTable_rL1
493 baseRegOffset Hp = oFFSET_StgRegTable_rHp
494 baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim
495 baseRegOffset CurrentTSO = oFFSET_StgRegTable_rCurrentTSO
496 baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery
497 baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc
498 baseRegOffset GCEnter1 = oFFSET_stgGCEnter1
499 baseRegOffset GCFun = oFFSET_stgGCFun
500 baseRegOffset reg = pprPanic "baseRegOffset:" (ppr reg)
501
502 -------------------------------------------------------------------------
503 --
504 -- Strings generate a top-level data block
505 --
506 -------------------------------------------------------------------------
507
508 emitDataLits :: CLabel -> [CmmLit] -> FCode ()
509 -- Emit a data-segment data block
510 emitDataLits lbl lits
511 = emitData Data (Statics lbl $ map CmmStaticLit lits)
512
513 mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info stmt
514 -- Emit a data-segment data block
515 mkDataLits lbl lits
516 = CmmData Data (Statics lbl $ map CmmStaticLit lits)
517
518 emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
519 -- Emit a read-only data block
520 emitRODataLits lbl lits
521 = emitData section (Statics lbl $ map CmmStaticLit lits)
522 where section | any needsRelocation lits = RelocatableReadOnlyData
523 | otherwise = ReadOnlyData
524 needsRelocation (CmmLabel _) = True
525 needsRelocation (CmmLabelOff _ _) = True
526 needsRelocation _ = False
527
528 mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info stmt
529 mkRODataLits lbl lits
530 = CmmData section (Statics lbl $ map CmmStaticLit lits)
531 where section | any needsRelocation lits = RelocatableReadOnlyData
532 | otherwise = ReadOnlyData
533 needsRelocation (CmmLabel _) = True
534 needsRelocation (CmmLabelOff _ _) = True
535 needsRelocation _ = False
536
537 mkStringCLit :: String -> FCode CmmLit
538 -- Make a global definition for the string,
539 -- and return its label
540 mkStringCLit str = mkByteStringCLit (map (fromIntegral . ord) str)
541
542 mkByteStringCLit :: [Word8] -> FCode CmmLit
543 mkByteStringCLit bytes
544 = do { uniq <- newUnique
545 ; let lbl = mkStringLitLabel uniq
546 ; emitData ReadOnlyData $ Statics lbl [CmmString bytes]
547 ; return (CmmLabel lbl) }
548
549 -------------------------------------------------------------------------
550 --
551 -- Assigning expressions to temporaries
552 --
553 -------------------------------------------------------------------------
554
555 assignTemp :: CmmExpr -> FCode LocalReg
556 -- Make sure the argument is in a local register.
557 -- We don't bother being particularly aggressive with avoiding
558 -- unnecessary local registers, since we can rely on a later
559 -- optimization pass to inline as necessary (and skipping out
560 -- on things like global registers can be a little dangerous
561 -- due to them being trashed on foreign calls--though it means
562 -- the optimization pass doesn't have to do as much work)
563 assignTemp (CmmReg (CmmLocal reg)) = return reg
564 assignTemp e = do { uniq <- newUnique
565 ; let reg = LocalReg uniq (cmmExprType e)
566 ; emit (mkAssign (CmmLocal reg) e)
567 ; return reg }
568
569 newTemp :: CmmType -> FCode LocalReg
570 newTemp rep = do { uniq <- newUnique
571 ; return (LocalReg uniq rep) }
572
573 newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
574 -- Choose suitable local regs to use for the components
575 -- of an unboxed tuple that we are about to return to
576 -- the Sequel. If the Sequel is a join point, using the
577 -- regs it wants will save later assignments.
578 newUnboxedTupleRegs res_ty
579 = ASSERT( isUnboxedTupleType res_ty )
580 do { sequel <- getSequel
581 ; regs <- choose_regs sequel
582 ; ASSERT( regs `equalLength` reps )
583 return (regs, map primRepForeignHint reps) }
584 where
585 ty_args = tyConAppArgs (repType res_ty)
586 reps = [ rep
587 | ty <- ty_args
588 , let rep = typePrimRep ty
589 , not (isVoidRep rep) ]
590 choose_regs (AssignTo regs _) = return regs
591 choose_regs _other = mapM (newTemp . primRepCmmType) reps
592
593
594
595 -------------------------------------------------------------------------
596 -- mkMultiAssign
597 -------------------------------------------------------------------------
598
599 mkMultiAssign :: [LocalReg] -> [CmmExpr] -> CmmAGraph
600 -- Emit code to perform the assignments in the
601 -- input simultaneously, using temporary variables when necessary.
602
603 type Key = Int
604 type Vrtx = (Key, Stmt) -- Give each vertex a unique number,
605 -- for fast comparison
606 type Stmt = (LocalReg, CmmExpr) -- r := e
607
608 -- We use the strongly-connected component algorithm, in which
609 -- * the vertices are the statements
610 -- * an edge goes from s1 to s2 iff
611 -- s1 assigns to something s2 uses
612 -- that is, if s1 should *follow* s2 in the final order
613
614 mkMultiAssign [] [] = mkNop
615 mkMultiAssign [reg] [rhs] = mkAssign (CmmLocal reg) rhs
616 mkMultiAssign regs rhss = ASSERT( equalLength regs rhss )
617 unscramble ([1..] `zip` (regs `zip` rhss))
618
619 unscramble :: [Vrtx] -> CmmAGraph
620 unscramble vertices
621 = catAGraphs (map do_component components)
622 where
623 edges :: [ (Vrtx, Key, [Key]) ]
624 edges = [ (vertex, key1, edges_from stmt1)
625 | vertex@(key1, stmt1) <- vertices ]
626
627 edges_from :: Stmt -> [Key]
628 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
629 stmt1 `mustFollow` stmt2 ]
630
631 components :: [SCC Vrtx]
632 components = stronglyConnCompFromEdgedVertices edges
633
634 -- do_components deal with one strongly-connected component
635 -- Not cyclic, or singleton? Just do it
636 do_component :: SCC Vrtx -> CmmAGraph
637 do_component (AcyclicSCC (_,stmt)) = mk_graph stmt
638 do_component (CyclicSCC []) = panic "do_component"
639 do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt
640
641 -- Cyclic? Then go via temporaries. Pick one to
642 -- break the loop and try again with the rest.
643 do_component (CyclicSCC ((_,first_stmt) : rest))
644 = withUnique $ \u ->
645 let (to_tmp, from_tmp) = split u first_stmt
646 in mk_graph to_tmp
647 <*> unscramble rest
648 <*> mk_graph from_tmp
649
650 split :: Unique -> Stmt -> (Stmt, Stmt)
651 split uniq (reg, rhs)
652 = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
653 where
654 rep = cmmExprType rhs
655 tmp = LocalReg uniq rep
656
657 mk_graph :: Stmt -> CmmAGraph
658 mk_graph (reg, rhs) = mkAssign (CmmLocal reg) rhs
659
660 mustFollow :: Stmt -> Stmt -> Bool
661 (reg, _) `mustFollow` (_, rhs) = reg `regUsedIn` rhs
662
663 regUsedIn :: LocalReg -> CmmExpr -> Bool
664 reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
665 reg `regUsedIn` CmmReg (CmmLocal reg') = reg == reg'
666 reg `regUsedIn` CmmRegOff (CmmLocal reg') _ = reg == reg'
667 reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
668 _reg `regUsedIn` _other = False -- The CmmGlobal cases
669
670 -------------------------------------------------------------------------
671 -- mkSwitch
672 -------------------------------------------------------------------------
673
674
675 emitSwitch :: CmmExpr -- Tag to switch on
676 -> [(ConTagZ, CmmAGraph)] -- Tagged branches
677 -> Maybe CmmAGraph -- Default branch (if any)
678 -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
679 -- outside this range is undefined
680 -> FCode ()
681 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
682 = do { dflags <- getDynFlags
683 ; emit (mkCmmSwitch (via_C dflags) tag_expr branches mb_deflt lo_tag hi_tag) }
684 where
685 via_C dflags | HscC <- hscTarget dflags = True
686 | otherwise = False
687
688
689 mkCmmSwitch :: Bool -- True <=> never generate a conditional tree
690 -> CmmExpr -- Tag to switch on
691 -> [(ConTagZ, CmmAGraph)] -- Tagged branches
692 -> Maybe CmmAGraph -- Default branch (if any)
693 -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
694 -- outside this range is undefined
695 -> CmmAGraph
696
697 -- First, two rather common cases in which there is no work to do
698 mkCmmSwitch _ _ [] (Just code) _ _ = code
699 mkCmmSwitch _ _ [(_,code)] Nothing _ _ = code
700
701 -- Right, off we go
702 mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag
703 = withFreshLabel "switch join" $ \ join_lbl ->
704 label_default join_lbl mb_deflt $ \ mb_deflt ->
705 label_branches join_lbl branches $ \ branches ->
706 assignTemp' tag_expr $ \tag_expr' ->
707
708 mk_switch tag_expr' (sortLe le branches) mb_deflt
709 lo_tag hi_tag via_C
710 -- Sort the branches before calling mk_switch
711 <*> mkLabel join_lbl
712
713 where
714 (t1,_) `le` (t2,_) = t1 <= t2
715
716 mk_switch :: CmmExpr -> [(ConTagZ, BlockId)]
717 -> Maybe BlockId
718 -> ConTagZ -> ConTagZ -> Bool
719 -> CmmAGraph
720
721 -- SINGLETON TAG RANGE: no case analysis to do
722 mk_switch _tag_expr [(tag, lbl)] _ lo_tag hi_tag _via_C
723 | lo_tag == hi_tag
724 = ASSERT( tag == lo_tag )
725 mkBranch lbl
726
727 -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
728 mk_switch _tag_expr [(_tag,lbl)] Nothing _ _ _
729 = mkBranch lbl
730 -- The simplifier might have eliminated a case
731 -- so we may have e.g. case xs of
732 -- [] -> e
733 -- In that situation we can be sure the (:) case
734 -- can't happen, so no need to test
735
736 -- SINGLETON BRANCH: one equality check to do
737 mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _
738 = mkCbranch cond deflt lbl
739 where
740 cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
741 -- We have lo_tag < hi_tag, but there's only one branch,
742 -- so there must be a default
743
744 -- ToDo: we might want to check for the two branch case, where one of
745 -- the branches is the tag 0, because comparing '== 0' is likely to be
746 -- more efficient than other kinds of comparison.
747
748 -- DENSE TAG RANGE: use a switch statment.
749 --
750 -- We also use a switch uncoditionally when compiling via C, because
751 -- this will get emitted as a C switch statement and the C compiler
752 -- should do a good job of optimising it. Also, older GCC versions
753 -- (2.95 in particular) have problems compiling the complicated
754 -- if-trees generated by this code, so compiling to a switch every
755 -- time works around that problem.
756 --
757 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
758 | use_switch -- Use a switch
759 = let
760 find_branch :: ConTagZ -> Maybe BlockId
761 find_branch i = case (assocMaybe branches i) of
762 Just lbl -> Just lbl
763 Nothing -> mb_deflt
764
765 -- NB. we have eliminated impossible branches at
766 -- either end of the range (see below), so the first
767 -- tag of a real branch is real_lo_tag (not lo_tag).
768 arms :: [Maybe BlockId]
769 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
770 in
771 mkSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
772
773 -- if we can knock off a bunch of default cases with one if, then do so
774 | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
775 = mkCmmIfThenElse
776 (cmmULtWord tag_expr (CmmLit (mkIntCLit lowest_branch)))
777 (mkBranch deflt)
778 (mk_switch tag_expr branches mb_deflt
779 lowest_branch hi_tag via_C)
780
781 | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
782 = mkCmmIfThenElse
783 (cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch)))
784 (mkBranch deflt)
785 (mk_switch tag_expr branches mb_deflt
786 lo_tag highest_branch via_C)
787
788 | otherwise -- Use an if-tree
789 = mkCmmIfThenElse
790 (cmmUGeWord tag_expr (CmmLit (mkIntCLit mid_tag)))
791 (mk_switch tag_expr hi_branches mb_deflt
792 mid_tag hi_tag via_C)
793 (mk_switch tag_expr lo_branches mb_deflt
794 lo_tag (mid_tag-1) via_C)
795 -- we test (e >= mid_tag) rather than (e < mid_tag), because
796 -- the former works better when e is a comparison, and there
797 -- are two tags 0 & 1 (mid_tag == 1). In this case, the code
798 -- generator can reduce the condition to e itself without
799 -- having to reverse the sense of the comparison: comparisons
800 -- can't always be easily reversed (eg. floating
801 -- pt. comparisons).
802 where
803 use_switch = {- pprTrace "mk_switch" (
804 ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
805 text "branches:" <+> ppr (map fst branches) <+>
806 text "n_branches:" <+> int n_branches <+>
807 text "lo_tag:" <+> int lo_tag <+>
808 text "hi_tag:" <+> int hi_tag <+>
809 text "real_lo_tag:" <+> int real_lo_tag <+>
810 text "real_hi_tag:" <+> int real_hi_tag) $ -}
811 ASSERT( n_branches > 1 && n_tags > 1 )
812 n_tags > 2 && (via_C || (dense && big_enough))
813 -- up to 4 branches we use a decision tree, otherwise
814 -- a switch (== jump table in the NCG). This seems to be
815 -- optimal, and corresponds with what gcc does.
816 big_enough = n_branches > 4
817 dense = n_branches > (n_tags `div` 2)
818 n_branches = length branches
819
820 -- ignore default slots at each end of the range if there's
821 -- no default branch defined.
822 lowest_branch = fst (head branches)
823 highest_branch = fst (last branches)
824
825 real_lo_tag
826 | isNothing mb_deflt = lowest_branch
827 | otherwise = lo_tag
828
829 real_hi_tag
830 | isNothing mb_deflt = highest_branch
831 | otherwise = hi_tag
832
833 n_tags = real_hi_tag - real_lo_tag + 1
834
835 -- INVARIANT: Provided hi_tag > lo_tag (which is true)
836 -- lo_tag <= mid_tag < hi_tag
837 -- lo_branches have tags < mid_tag
838 -- hi_branches have tags >= mid_tag
839
840 (mid_tag,_) = branches !! (n_branches `div` 2)
841 -- 2 branches => n_branches `div` 2 = 1
842 -- => branches !! 1 give the *second* tag
843 -- There are always at least 2 branches here
844
845 (lo_branches, hi_branches) = span is_lo branches
846 is_lo (t,_) = t < mid_tag
847
848 --------------
849 mkCmmLitSwitch :: CmmExpr -- Tag to switch on
850 -> [(Literal, CmmAGraph)] -- Tagged branches
851 -> CmmAGraph -- Default branch (always)
852 -> CmmAGraph -- Emit the code
853 -- Used for general literals, whose size might not be a word,
854 -- where there is always a default case, and where we don't know
855 -- the range of values for certain. For simplicity we always generate a tree.
856 --
857 -- ToDo: for integers we could do better here, perhaps by generalising
858 -- mk_switch and using that. --SDM 15/09/2004
859 mkCmmLitSwitch _scrut [] deflt = deflt
860 mkCmmLitSwitch scrut branches deflt
861 = assignTemp' scrut $ \ scrut' ->
862 withFreshLabel "switch join" $ \ join_lbl ->
863 label_code join_lbl deflt $ \ deflt ->
864 label_branches join_lbl branches $ \ branches ->
865 mk_lit_switch scrut' deflt (sortLe le branches)
866 <*> mkLabel join_lbl
867 where
868 le (t1,_) (t2,_) = t1 <= t2
869
870 mk_lit_switch :: CmmExpr -> BlockId
871 -> [(Literal,BlockId)]
872 -> CmmAGraph
873 mk_lit_switch scrut deflt [(lit,blk)]
874 = mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk
875 where
876 cmm_lit = mkSimpleLit lit
877 cmm_ty = cmmLitType cmm_lit
878 rep = typeWidth cmm_ty
879 ne = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep
880
881 mk_lit_switch scrut deflt_blk_id branches
882 = mkCmmIfThenElse cond
883 (mk_lit_switch scrut deflt_blk_id lo_branches)
884 (mk_lit_switch scrut deflt_blk_id hi_branches)
885 where
886 n_branches = length branches
887 (mid_lit,_) = branches !! (n_branches `div` 2)
888 -- See notes above re mid_tag
889
890 (lo_branches, hi_branches) = span is_lo branches
891 is_lo (t,_) = t < mid_lit
892
893 cond = CmmMachOp (mkLtOp mid_lit)
894 [scrut, CmmLit (mkSimpleLit mid_lit)]
895
896
897 --------------
898 label_default :: BlockId -> Maybe CmmAGraph
899 -> (Maybe BlockId -> CmmAGraph)
900 -> CmmAGraph
901 label_default _ Nothing thing_inside
902 = thing_inside Nothing
903 label_default join_lbl (Just code) thing_inside
904 = label_code join_lbl code $ \ lbl ->
905 thing_inside (Just lbl)
906
907 --------------
908 label_branches :: BlockId -> [(a,CmmAGraph)]
909 -> ([(a,BlockId)] -> CmmAGraph)
910 -> CmmAGraph
911 label_branches _join_lbl [] thing_inside
912 = thing_inside []
913 label_branches join_lbl ((tag,code):branches) thing_inside
914 = label_code join_lbl code $ \ lbl ->
915 label_branches join_lbl branches $ \ branches' ->
916 thing_inside ((tag,lbl):branches')
917
918 --------------
919 label_code :: BlockId -> CmmAGraph -> (BlockId -> CmmAGraph) -> CmmAGraph
920 -- (label_code J code fun)
921 -- generates
922 -- [L: code; goto J] fun L
923 label_code join_lbl code thing_inside
924 = withFreshLabel "switch" $ \lbl ->
925 outOfLine (mkLabel lbl <*> code <*> mkBranch join_lbl)
926 <*> thing_inside lbl
927
928
929 --------------
930 assignTemp' :: CmmExpr -> (CmmExpr -> CmmAGraph) -> CmmAGraph
931 assignTemp' e thing_inside
932 | isTrivialCmmExpr e = thing_inside e
933 | otherwise = withTemp (cmmExprType e) $ \ lreg ->
934 let reg = CmmLocal lreg in
935 mkAssign reg e <*> thing_inside (CmmReg reg)
936
937 withTemp :: CmmType -> (LocalReg -> CmmAGraph) -> CmmAGraph
938 withTemp rep thing_inside
939 = withUnique $ \uniq -> thing_inside (LocalReg uniq rep)
940
941
942 -------------------------------------------------------------------------
943 --
944 -- Static Reference Tables
945 --
946 -------------------------------------------------------------------------
947
948 -- There is just one SRT for each top level binding; all the nested
949 -- bindings use sub-sections of this SRT. The label is passed down to
950 -- the nested bindings via the monad.
951
952 getSRTInfo :: SRT -> FCode C_SRT
953 getSRTInfo (SRTEntries {}) = panic "getSRTInfo"
954
955 getSRTInfo (SRT off len bmp)
956 | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
957 = do { id <- newUnique
958 -- ; top_srt <- getSRTLabel
959 ; let srt_desc_lbl = mkLargeSRTLabel id
960 -- JD: We're not constructing and emitting SRTs in the back end,
961 -- which renders this code wrong (it now names a now-non-existent label).
962 -- ; emitRODataLits srt_desc_lbl
963 -- ( cmmLabelOffW top_srt off
964 -- : mkWordCLit (fromIntegral len)
965 -- : map mkWordCLit bmp)
966 ; return (C_SRT srt_desc_lbl 0 srt_escape) }
967
968 | otherwise
969 = do { top_srt <- getSRTLabel
970 ; return (C_SRT top_srt off (fromIntegral (head bmp))) }
971 -- The fromIntegral converts to StgHalfWord
972
973 getSRTInfo NoSRT
974 = -- TODO: Should we panic in this case?
975 -- Someone obviously thinks there should be an SRT
976 return NoC_SRT
977
978
979 srt_escape :: StgHalfWord
980 srt_escape = -1