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