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