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