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