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         assignNonPtrTemp, newNonPtrTemp,
  17         assignPtrTemp, newPtrTemp,
  18         emitSimultaneously,
  19         emitSwitch, emitLitSwitch,
  20         tagToClosure,
  21
  22         callerSaveVolatileRegs, get_GlobalReg_addr,
  23
  24         cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
  25         cmmOffsetExprW, cmmOffsetExprB,
  26         cmmRegOffW, cmmRegOffB,
  27         cmmLabelOffW, cmmLabelOffB,
  28         cmmOffsetW, cmmOffsetB,
  29         cmmOffsetLitW, cmmOffsetLitB,
  30         cmmLoadIndexW,
  31
  32         addToMem, addToMemE,
  33         mkWordCLit,
  34         mkStringCLit, mkByteStringCLit,
  35         packHalfWordsCLit,
  36         blankWord,
  37
  38         getSRTInfo
  39   ) where
  40
  41 #include "HsVersions.h"
  42 #include "MachRegs.h"
  43
  44 import CgMonad
  45 import TyCon
  46 import Id
  47 import Constants
  48 import SMRep
  49 import PprCmm           ( {- instances -} )
  50 import Cmm
  51 import CLabel
  52 import CmmUtils
  53 import MachOp
  54 import ForeignCall
  55 import ClosureInfo
  56 import StgSyn (SRT(..))
  57 import Literal
  58 import Digraph
  59 import ListSetOps
  60 import Util
  61 import DynFlags
  62 import FastString
  63 import PackageConfig
  64 import Outputable
  65
  66 import Data.Char
  67 import Data.Bits
  68 import Data.Word
  69 import Data.Maybe
  70
  71 -------------------------------------------------------------------------
  72 --
  73 --      Random small functions
  74 --
  75 -------------------------------------------------------------------------
  76
  77 addIdReps :: [Id] -> [(CgRep, Id)]
  78 addIdReps ids = [(idCgRep id, id) | id <- ids]
  79
  80 -------------------------------------------------------------------------
  81 --
  82 --      Literals
  83 --
  84 -------------------------------------------------------------------------
  85
  86 cgLit :: Literal -> FCode CmmLit
  87 cgLit (MachStr s) = mkByteStringCLit (bytesFS s)
  88  -- not unpackFS; we want the UTF-8 byte stream.
  89 cgLit other_lit   = return (mkSimpleLit other_lit)
  90
  91 mkSimpleLit :: Literal -> CmmLit
  92 mkSimpleLit (MachChar   c)    = CmmInt (fromIntegral (ord c)) wordRep
  93 mkSimpleLit MachNullAddr      = zeroCLit
  94 mkSimpleLit (MachInt i)       = CmmInt i wordRep
  95 mkSimpleLit (MachInt64 i)     = CmmInt i I64
  96 mkSimpleLit (MachWord i)      = CmmInt i wordRep
  97 mkSimpleLit (MachWord64 i)    = CmmInt i I64
  98 mkSimpleLit (MachFloat r)     = CmmFloat r F32
  99 mkSimpleLit (MachDouble r)    = CmmFloat r F64
 100 mkSimpleLit (MachLabel fs ms) = CmmLabel (mkForeignLabel fs ms is_dyn)
 101                               where
 102                                 is_dyn = False  -- ToDo: fix me
 103
 104 mkLtOp :: Literal -> MachOp
 105 -- On signed literals we must do a signed comparison
 106 mkLtOp (MachInt _)    = MO_S_Lt wordRep
 107 mkLtOp (MachFloat _)  = MO_S_Lt F32
 108 mkLtOp (MachDouble _) = MO_S_Lt F64
 109 mkLtOp lit            = MO_U_Lt (cmmLitRep (mkSimpleLit lit))
 110
 111
 112 ---------------------------------------------------
 113 --
 114 --      Cmm data type functions
 115 --
 116 ---------------------------------------------------
 117
 118 -----------------------
 119 -- The "B" variants take byte offsets
 120 cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
 121 cmmRegOffB = cmmRegOff
 122
 123 cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr
 124 cmmOffsetB = cmmOffset
 125
 126 cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr
 127 cmmOffsetExprB = cmmOffsetExpr
 128
 129 cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
 130 cmmLabelOffB = cmmLabelOff
 131
 132 cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
 133 cmmOffsetLitB = cmmOffsetLit
 134
 135 -----------------------
 136 -- The "W" variants take word offsets
 137 cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr
 138 -- The second arg is a *word* offset; need to change it to bytes
 139 cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n)
 140 cmmOffsetExprW e wd_off = cmmIndexExpr wordRep e wd_off
 141
 142 cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr
 143 cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n)
 144
 145 cmmRegOffW :: CmmReg -> WordOff -> CmmExpr
 146 cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE)
 147
 148 cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit
 149 cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off)
 150
 151 cmmLabelOffW :: CLabel -> WordOff -> CmmLit
 152 cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off)
 153
 154 cmmLoadIndexW :: CmmExpr -> Int -> CmmExpr
 155 cmmLoadIndexW base off
 156   = CmmLoad (cmmOffsetW base off) wordRep
 157
 158 -----------------------
 159 cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord :: CmmExpr -> CmmExpr -> CmmExpr
 160 cmmOrWord  e1 e2 = CmmMachOp mo_wordOr  [e1, e2]
 161 cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
 162 cmmNeWord  e1 e2 = CmmMachOp mo_wordNe  [e1, e2]
 163 cmmEqWord  e1 e2 = CmmMachOp mo_wordEq  [e1, e2]
 164 cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
 165 cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
 166 cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
 167
 168 cmmNegate :: CmmExpr -> CmmExpr
 169 cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
 170 cmmNegate e                       = CmmMachOp (MO_S_Neg (cmmExprRep e)) [e]
 171
 172 blankWord :: CmmStatic
 173 blankWord = CmmUninitialised wORD_SIZE
 174
 175 -----------------------
 176 --      Making literals
 177
 178 mkWordCLit :: StgWord -> CmmLit
 179 mkWordCLit wd = CmmInt (fromIntegral wd) wordRep
 180
 181 packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit
 182 -- Make a single word literal in which the lower_half_word is
 183 -- at the lower address, and the upper_half_word is at the
 184 -- higher address
 185 -- ToDo: consider using half-word lits instead
 186 --       but be careful: that's vulnerable when reversed
 187 packHalfWordsCLit lower_half_word upper_half_word
 188 #ifdef WORDS_BIGENDIAN
 189    = mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)
 190                  .|. fromIntegral upper_half_word)
 191 #else
 192    = mkWordCLit ((fromIntegral lower_half_word)
 193                  .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS))
 194 #endif
 195
 196 --------------------------------------------------------------------------
 197 --
 198 -- Incrementing a memory location
 199 --
 200 --------------------------------------------------------------------------
 201
 202 addToMem :: MachRep     -- rep of the counter
 203          -> CmmExpr     -- Address
 204          -> Int         -- What to add (a word)
 205          -> CmmStmt
 206 addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) rep))
 207
 208 addToMemE :: MachRep    -- rep of the counter
 209           -> CmmExpr    -- Address
 210           -> CmmExpr    -- What to add (a word-typed expression)
 211           -> CmmStmt
 212 addToMemE rep ptr n
 213   = CmmStore ptr (CmmMachOp (MO_Add rep) [CmmLoad ptr rep, n])
 214
 215 -------------------------------------------------------------------------
 216 --
 217 --      Converting a closure tag to a closure for enumeration types
 218 --      (this is the implementation of tagToEnum#).
 219 --
 220 -------------------------------------------------------------------------
 221
 222 tagToClosure :: PackageId -> TyCon -> CmmExpr -> CmmExpr
 223 tagToClosure this_pkg tycon tag
 224   = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep
 225   where closure_tbl = CmmLit (CmmLabel lbl)
 226         lbl = mkClosureTableLabel this_pkg (tyConName tycon)
 227
 228 -------------------------------------------------------------------------
 229 --
 230 --      Conditionals and rts calls
 231 --
 232 -------------------------------------------------------------------------
 233
 234 emitIf :: CmmExpr       -- Boolean
 235        -> Code          -- Then part
 236        -> Code
 237 -- Emit (if e then x)
 238 -- ToDo: reverse the condition to avoid the extra branch instruction if possible
 239 -- (some conditionals aren't reversible. eg. floating point comparisons cannot
 240 -- be inverted because there exist some values for which both comparisons
 241 -- return False, such as NaN.)
 242 emitIf cond then_part
 243   = do { then_id <- newLabelC
 244        ; join_id <- newLabelC
 245        ; stmtC (CmmCondBranch cond then_id)
 246        ; stmtC (CmmBranch join_id)
 247        ; labelC then_id
 248        ; then_part
 249        ; labelC join_id
 250        }
 251
 252 emitIfThenElse :: CmmExpr       -- Boolean
 253                 -> Code         -- Then part
 254                 -> Code         -- Else part
 255                 -> Code
 256 -- Emit (if e then x else y)
 257 emitIfThenElse cond then_part else_part
 258   = do { then_id <- newLabelC
 259        ; else_id <- newLabelC
 260        ; join_id <- newLabelC
 261        ; stmtC (CmmCondBranch cond then_id)
 262        ; else_part
 263        ; stmtC (CmmBranch join_id)
 264        ; labelC then_id
 265        ; then_part
 266        ; labelC join_id
 267        }
 268
 269 emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Bool -> Code
 270 emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
 271    -- The 'Nothing' says "save all global registers"
 272
 273 emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Bool -> Code
 274 emitRtsCallWithVols fun args vols safe
 275    = emitRtsCall' [] fun args (Just vols) safe
 276
 277 emitRtsCallWithResult :: LocalReg -> MachHint -> LitString
 278         -> [(CmmExpr,MachHint)] -> Bool -> Code
 279 emitRtsCallWithResult res hint fun args safe
 280    = emitRtsCall' [(res,hint)] fun args Nothing safe
 281
 282 -- Make a call to an RTS C procedure
 283 emitRtsCall'
 284    :: CmmHintFormals
 285    -> LitString
 286    -> [(CmmExpr,MachHint)]
 287    -> Maybe [GlobalReg]
 288    -> Bool -- True <=> CmmSafe call
 289    -> Code
 290 emitRtsCall' res fun args vols safe = do
 291   safety <- if safe
 292             then getSRTInfo >>= (return . CmmSafe)
 293             else return CmmUnsafe
 294   stmtsC caller_save
 295   stmtC (CmmCall target res args safety)
 296   stmtsC caller_load
 297   where
 298     (caller_save, caller_load) = callerSaveVolatileRegs vols
 299     target   = CmmForeignCall fun_expr CCallConv
 300     fun_expr = mkLblExpr (mkRtsCodeLabel fun)
 301
 302 -----------------------------------------------------------------------------
 303 --
 304 --      Caller-Save Registers
 305 --
 306 -----------------------------------------------------------------------------
 307
 308 -- Here we generate the sequence of saves/restores required around a
 309 -- foreign call instruction.
 310
 311 -- TODO: reconcile with includes/Regs.h
 312 --  * Regs.h claims that BaseReg should be saved last and loaded first
 313 --    * This might not have been tickled before since BaseReg is callee save
 314 --  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
 315 callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt])
 316 callerSaveVolatileRegs vols = (caller_save, caller_load)
 317   where
 318     caller_save = foldr ($!) [] (map callerSaveGlobalReg    regs_to_save)
 319     caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save)
 320
 321     system_regs = [Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery,
 322                    {-SparkHd,SparkTl,SparkBase,SparkLim,-}BaseReg ]
 323
 324     regs_to_save = system_regs ++ vol_list
 325
 326     vol_list = case vols of Nothing -> all_of_em; Just regs -> regs
 327
 328     all_of_em = [ VanillaReg n | n <- [0..mAX_Vanilla_REG] ]
 329              ++ [ FloatReg   n | n <- [0..mAX_Float_REG] ]
 330              ++ [ DoubleReg  n | n <- [0..mAX_Double_REG] ]
 331              ++ [ LongReg    n | n <- [0..mAX_Long_REG] ]
 332
 333     callerSaveGlobalReg reg next
 334         | callerSaves reg =
 335                 CmmStore (get_GlobalReg_addr reg)
 336                          (CmmReg (CmmGlobal reg)) : next
 337         | otherwise = next
 338
 339     callerRestoreGlobalReg reg next
 340         | callerSaves reg =
 341                 CmmAssign (CmmGlobal reg)
 342                           (CmmLoad (get_GlobalReg_addr reg) (globalRegRep reg))
 343                         : next
 344         | otherwise = next
 345
 346 -- -----------------------------------------------------------------------------
 347 -- Global registers
 348
 349 -- We map STG registers onto appropriate CmmExprs.  Either they map
 350 -- to real machine registers or stored as offsets from BaseReg.  Given
 351 -- a GlobalReg, get_GlobalReg_addr always produces the
 352 -- register table address for it.
 353 -- (See also get_GlobalReg_reg_or_addr in MachRegs)
 354
 355 get_GlobalReg_addr              :: GlobalReg -> CmmExpr
 356 get_GlobalReg_addr BaseReg = regTableOffset 0
 357 get_GlobalReg_addr mid     = get_Regtable_addr_from_offset
 358                                 (globalRegRep mid) (baseRegOffset mid)
 359
 360 -- Calculate a literal representing an offset into the register table.
 361 -- Used when we don't have an actual BaseReg to offset from.
 362 regTableOffset n =
 363   CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
 364
 365 get_Regtable_addr_from_offset   :: MachRep -> Int -> CmmExpr
 366 get_Regtable_addr_from_offset rep offset =
 367 #ifdef REG_Base
 368   CmmRegOff (CmmGlobal BaseReg) offset
 369 #else
 370   regTableOffset offset
 371 #endif
 372
 373
 374 -- | Returns 'True' if this global register is stored in a caller-saves
 375 -- machine register.
 376
 377 callerSaves :: GlobalReg -> Bool
 378
 379 #ifdef CALLER_SAVES_Base
 380 callerSaves BaseReg             = True
 381 #endif
 382 #ifdef CALLER_SAVES_R1
 383 callerSaves (VanillaReg 1)      = True
 384 #endif
 385 #ifdef CALLER_SAVES_R2
 386 callerSaves (VanillaReg 2)      = True
 387 #endif
 388 #ifdef CALLER_SAVES_R3
 389 callerSaves (VanillaReg 3)      = True
 390 #endif
 391 #ifdef CALLER_SAVES_R4
 392 callerSaves (VanillaReg 4)      = True
 393 #endif
 394 #ifdef CALLER_SAVES_R5
 395 callerSaves (VanillaReg 5)      = True
 396 #endif
 397 #ifdef CALLER_SAVES_R6
 398 callerSaves (VanillaReg 6)      = True
 399 #endif
 400 #ifdef CALLER_SAVES_R7
 401 callerSaves (VanillaReg 7)      = True
 402 #endif
 403 #ifdef CALLER_SAVES_R8
 404 callerSaves (VanillaReg 8)      = True
 405 #endif
 406 #ifdef CALLER_SAVES_F1
 407 callerSaves (FloatReg 1)        = True
 408 #endif
 409 #ifdef CALLER_SAVES_F2
 410 callerSaves (FloatReg 2)        = True
 411 #endif
 412 #ifdef CALLER_SAVES_F3
 413 callerSaves (FloatReg 3)        = True
 414 #endif
 415 #ifdef CALLER_SAVES_F4
 416 callerSaves (FloatReg 4)        = True
 417 #endif
 418 #ifdef CALLER_SAVES_D1
 419 callerSaves (DoubleReg 1)       = True
 420 #endif
 421 #ifdef CALLER_SAVES_D2
 422 callerSaves (DoubleReg 2)       = True
 423 #endif
 424 #ifdef CALLER_SAVES_L1
 425 callerSaves (LongReg 1)         = True
 426 #endif
 427 #ifdef CALLER_SAVES_Sp
 428 callerSaves Sp                  = True
 429 #endif
 430 #ifdef CALLER_SAVES_SpLim
 431 callerSaves SpLim               = True
 432 #endif
 433 #ifdef CALLER_SAVES_Hp
 434 callerSaves Hp                  = True
 435 #endif
 436 #ifdef CALLER_SAVES_HpLim
 437 callerSaves HpLim               = True
 438 #endif
 439 #ifdef CALLER_SAVES_CurrentTSO
 440 callerSaves CurrentTSO          = True
 441 #endif
 442 #ifdef CALLER_SAVES_CurrentNursery
 443 callerSaves CurrentNursery      = True
 444 #endif
 445 callerSaves _                   = False
 446
 447
 448 -- -----------------------------------------------------------------------------
 449 -- Information about global registers
 450
 451 baseRegOffset :: GlobalReg -> Int
 452
 453 baseRegOffset (VanillaReg 1)      = oFFSET_StgRegTable_rR1
 454 baseRegOffset (VanillaReg 2)      = oFFSET_StgRegTable_rR2
 455 baseRegOffset (VanillaReg 3)      = oFFSET_StgRegTable_rR3
 456 baseRegOffset (VanillaReg 4)      = oFFSET_StgRegTable_rR4
 457 baseRegOffset (VanillaReg 5)      = oFFSET_StgRegTable_rR5
 458 baseRegOffset (VanillaReg 6)      = oFFSET_StgRegTable_rR6
 459 baseRegOffset (VanillaReg 7)      = oFFSET_StgRegTable_rR7
 460 baseRegOffset (VanillaReg 8)      = oFFSET_StgRegTable_rR8
 461 baseRegOffset (VanillaReg 9)      = oFFSET_StgRegTable_rR9
 462 baseRegOffset (VanillaReg 10)     = oFFSET_StgRegTable_rR10
 463 baseRegOffset (FloatReg  1)       = oFFSET_StgRegTable_rF1
 464 baseRegOffset (FloatReg  2)       = oFFSET_StgRegTable_rF2
 465 baseRegOffset (FloatReg  3)       = oFFSET_StgRegTable_rF3
 466 baseRegOffset (FloatReg  4)       = oFFSET_StgRegTable_rF4
 467 baseRegOffset (DoubleReg 1)       = oFFSET_StgRegTable_rD1
 468 baseRegOffset (DoubleReg 2)       = oFFSET_StgRegTable_rD2
 469 baseRegOffset Sp                  = oFFSET_StgRegTable_rSp
 470 baseRegOffset SpLim               = oFFSET_StgRegTable_rSpLim
 471 baseRegOffset (LongReg 1)         = oFFSET_StgRegTable_rL1
 472 baseRegOffset Hp                  = oFFSET_StgRegTable_rHp
 473 baseRegOffset HpLim               = oFFSET_StgRegTable_rHpLim
 474 baseRegOffset CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO
 475 baseRegOffset CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery
 476 baseRegOffset HpAlloc             = oFFSET_StgRegTable_rHpAlloc
 477 baseRegOffset GCEnter1            = oFFSET_stgGCEnter1
 478 baseRegOffset GCFun               = oFFSET_stgGCFun
 479 #ifdef DEBUG
 480 baseRegOffset BaseReg             = panic "baseRegOffset:BaseReg"
 481 baseRegOffset _                   = panic "baseRegOffset:other"
 482 #endif
 483
 484
 485 -------------------------------------------------------------------------
 486 --
 487 --      Strings gnerate a top-level data block
 488 --
 489 -------------------------------------------------------------------------
 490
 491 emitDataLits :: CLabel -> [CmmLit] -> Code
 492 -- Emit a data-segment data block
 493 emitDataLits lbl lits
 494   = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 495
 496 mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
 497 -- Emit a data-segment data block
 498 mkDataLits lbl lits
 499   = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 500
 501 emitRODataLits :: CLabel -> [CmmLit] -> Code
 502 -- Emit a read-only data block
 503 emitRODataLits lbl lits
 504   = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
 505   where section | any needsRelocation lits = RelocatableReadOnlyData
 506                 | otherwise                = ReadOnlyData
 507         needsRelocation (CmmLabel _)      = True
 508         needsRelocation (CmmLabelOff _ _) = True
 509         needsRelocation _                 = False
 510
 511 mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
 512 mkRODataLits lbl lits
 513   = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
 514   where section | any needsRelocation lits = RelocatableReadOnlyData
 515                 | otherwise                = ReadOnlyData
 516         needsRelocation (CmmLabel _)      = True
 517         needsRelocation (CmmLabelOff _ _) = True
 518         needsRelocation _                 = False
 519
 520 mkStringCLit :: String -> FCode CmmLit
 521 -- Make a global definition for the string,
 522 -- and return its label
 523 mkStringCLit str = mkByteStringCLit (map (fromIntegral.ord) str)
 524
 525 mkByteStringCLit :: [Word8] -> FCode CmmLit
 526 mkByteStringCLit bytes
 527   = do  { uniq <- newUnique
 528         ; let lbl = mkStringLitLabel uniq
 529         ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
 530         ; return (CmmLabel lbl) }
 531
 532 -------------------------------------------------------------------------
 533 --
 534 --      Assigning expressions to temporaries
 535 --
 536 -------------------------------------------------------------------------
 537
 538 assignNonPtrTemp :: CmmExpr -> FCode CmmExpr
 539 -- For a non-trivial expression, e, create a local
 540 -- variable and assign the expression to it
 541 assignNonPtrTemp e
 542   | isTrivialCmmExpr e = return e
 543   | otherwise          = do { reg <- newNonPtrTemp (cmmExprRep e)
 544                             ; stmtC (CmmAssign (CmmLocal reg) e)
 545                             ; return (CmmReg (CmmLocal reg)) }
 546
 547 assignPtrTemp :: CmmExpr -> FCode CmmExpr
 548 -- For a non-trivial expression, e, create a local
 549 -- variable and assign the expression to it
 550 assignPtrTemp e
 551   | isTrivialCmmExpr e = return e
 552   | otherwise          = do { reg <- newPtrTemp (cmmExprRep e)
 553                             ; stmtC (CmmAssign (CmmLocal reg) e)
 554                             ; return (CmmReg (CmmLocal reg)) }
 555
 556 newNonPtrTemp :: MachRep -> FCode LocalReg
 557 newNonPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindNonPtr) }
 558
 559 newPtrTemp :: MachRep -> FCode LocalReg
 560 newPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindPtr) }
 561
 562
 563 -------------------------------------------------------------------------
 564 --
 565 --      Building case analysis
 566 --
 567 -------------------------------------------------------------------------
 568
 569 emitSwitch
 570         :: CmmExpr                -- Tag to switch on
 571         -> [(ConTagZ, CgStmts)]   -- Tagged branches
 572         -> Maybe CgStmts          -- Default branch (if any)
 573         -> ConTagZ -> ConTagZ     -- Min and Max possible values; behaviour
 574                                   --    outside this range is undefined
 575         -> Code
 576
 577 -- ONLY A DEFAULT BRANCH: no case analysis to do
 578 emitSwitch tag_expr [] (Just stmts) _ _
 579   = emitCgStmts stmts
 580
 581 -- Right, off we go
 582 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
 583   =     -- Just sort the branches before calling mk_sritch
 584     do  { mb_deflt_id <-
 585                 case mb_deflt of
 586                   Nothing    -> return Nothing
 587                   Just stmts -> do id <- forkCgStmts stmts; return (Just id)
 588
 589         ; dflags <- getDynFlags
 590         ; let via_C | HscC <- hscTarget dflags = True
 591                     | otherwise                = False
 592
 593         ; stmts <- mk_switch tag_expr (sortLe le branches)
 594                         mb_deflt_id lo_tag hi_tag via_C
 595         ; emitCgStmts stmts
 596         }
 597   where
 598     (t1,_) `le` (t2,_) = t1 <= t2
 599
 600
 601 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
 602           -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
 603           -> FCode CgStmts
 604
 605 -- SINGLETON TAG RANGE: no case analysis to do
 606 mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C
 607   | lo_tag == hi_tag
 608   = ASSERT( tag == lo_tag )
 609     return stmts
 610
 611 -- SINGLETON BRANCH, NO DEFUALT: no case analysis to do
 612 mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag via_C
 613   = return stmts
 614         -- The simplifier might have eliminated a case
 615         --       so we may have e.g. case xs of
 616         --                               [] -> e
 617         -- In that situation we can be sure the (:) case
 618         -- can't happen, so no need to test
 619
 620 -- SINGLETON BRANCH: one equality check to do
 621 mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C
 622   = return (CmmCondBranch cond deflt `consCgStmt` stmts)
 623   where
 624     cond  =  cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
 625         -- We have lo_tag < hi_tag, but there's only one branch,
 626         -- so there must be a default
 627
 628 -- ToDo: we might want to check for the two branch case, where one of
 629 -- the branches is the tag 0, because comparing '== 0' is likely to be
 630 -- more efficient than other kinds of comparison.
 631
 632 -- DENSE TAG RANGE: use a switch statment.
 633 --
 634 -- We also use a switch uncoditionally when compiling via C, because
 635 -- this will get emitted as a C switch statement and the C compiler
 636 -- should do a good job of optimising it.  Also, older GCC versions
 637 -- (2.95 in particular) have problems compiling the complicated
 638 -- if-trees generated by this code, so compiling to a switch every
 639 -- time works around that problem.
 640 --
 641 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
 642   | use_switch  -- Use a switch
 643   = do  { branch_ids <- mapM forkCgStmts (map snd branches)
 644         ; let
 645                 tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
 646
 647                 find_branch :: ConTagZ -> Maybe BlockId
 648                 find_branch i = assocDefault mb_deflt tagged_blk_ids i
 649
 650                 -- NB. we have eliminated impossible branches at
 651                 -- either end of the range (see below), so the first
 652                 -- tag of a real branch is real_lo_tag (not lo_tag).
 653                 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
 654
 655                 switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
 656
 657         ; ASSERT(not (all isNothing arms))
 658           return (oneCgStmt switch_stmt)
 659         }
 660
 661   -- if we can knock off a bunch of default cases with one if, then do so
 662   | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
 663   = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
 664        ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
 665              branch = CmmCondBranch cond deflt
 666        ; stmts <- mk_switch tag_expr' branches mb_deflt
 667                         lowest_branch hi_tag via_C
 668        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 669        }
 670
 671   | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
 672   = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
 673        ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
 674              branch = CmmCondBranch cond deflt
 675        ; stmts <- mk_switch tag_expr' branches mb_deflt
 676                         lo_tag highest_branch via_C
 677        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 678        }
 679
 680   | otherwise   -- Use an if-tree
 681   = do  { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
 682                 -- To avoid duplication
 683         ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
 684                                 lo_tag (mid_tag-1) via_C
 685         ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
 686                                 mid_tag hi_tag via_C
 687         ; hi_id <- forkCgStmts hi_stmts
 688         ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
 689               branch_stmt = CmmCondBranch cond hi_id
 690         ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
 691         }
 692         -- we test (e >= mid_tag) rather than (e < mid_tag), because
 693         -- the former works better when e is a comparison, and there
 694         -- are two tags 0 & 1 (mid_tag == 1).  In this case, the code
 695         -- generator can reduce the condition to e itself without
 696         -- having to reverse the sense of the comparison: comparisons
 697         -- can't always be easily reversed (eg. floating
 698         -- pt. comparisons).
 699   where
 700     use_switch   = {- pprTrace "mk_switch" (
 701                         ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
 702                         text "branches:" <+> ppr (map fst branches) <+>
 703                         text "n_branches:" <+> int n_branches <+>
 704                         text "lo_tag:" <+> int lo_tag <+>
 705                         text "hi_tag:" <+> int hi_tag <+>
 706                         text "real_lo_tag:" <+> int real_lo_tag <+>
 707                         text "real_hi_tag:" <+> int real_hi_tag) $ -}
 708                    ASSERT( n_branches > 1 && n_tags > 1 )
 709                    n_tags > 2 && (via_C || (dense && big_enough))
 710                  -- up to 4 branches we use a decision tree, otherwise
 711                  -- a switch (== jump table in the NCG).  This seems to be
 712                  -- optimal, and corresponds with what gcc does.
 713     big_enough   = n_branches > 4
 714     dense        = n_branches > (n_tags `div` 2)
 715     n_branches   = length branches
 716
 717     -- ignore default slots at each end of the range if there's
 718     -- no default branch defined.
 719     lowest_branch  = fst (head branches)
 720     highest_branch = fst (last branches)
 721
 722     real_lo_tag
 723         | isNothing mb_deflt = lowest_branch
 724         | otherwise          = lo_tag
 725
 726     real_hi_tag
 727         | isNothing mb_deflt = highest_branch
 728         | otherwise          = hi_tag
 729
 730     n_tags = real_hi_tag - real_lo_tag + 1
 731
 732         -- INVARIANT: Provided hi_tag > lo_tag (which is true)
 733         --      lo_tag <= mid_tag < hi_tag
 734         --      lo_branches have tags <  mid_tag
 735         --      hi_branches have tags >= mid_tag
 736
 737     (mid_tag,_) = branches !! (n_branches `div` 2)
 738         -- 2 branches => n_branches `div` 2 = 1
 739         --            => branches !! 1 give the *second* tag
 740         -- There are always at least 2 branches here
 741
 742     (lo_branches, hi_branches) = span is_lo branches
 743     is_lo (t,_) = t < mid_tag
 744
 745
 746 assignNonPtrTemp' e
 747   | isTrivialCmmExpr e = return (CmmNop, e)
 748   | otherwise          = do { reg <- newNonPtrTemp (cmmExprRep e)
 749                             ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
 750
 751 emitLitSwitch :: CmmExpr                        -- Tag to switch on
 752               -> [(Literal, CgStmts)]           -- Tagged branches
 753               -> CgStmts                        -- Default branch (always)
 754               -> Code                           -- Emit the code
 755 -- Used for general literals, whose size might not be a word,
 756 -- where there is always a default case, and where we don't know
 757 -- the range of values for certain.  For simplicity we always generate a tree.
 758 --
 759 -- ToDo: for integers we could do better here, perhaps by generalising
 760 -- mk_switch and using that.  --SDM 15/09/2004
 761 emitLitSwitch scrut [] deflt
 762   = emitCgStmts deflt
 763 emitLitSwitch scrut branches deflt_blk
 764   = do  { scrut' <- assignNonPtrTemp scrut
 765         ; deflt_blk_id <- forkCgStmts deflt_blk
 766         ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
 767         ; emitCgStmts blk }
 768   where
 769     le (t1,_) (t2,_) = t1 <= t2
 770
 771 mk_lit_switch :: CmmExpr -> BlockId
 772               -> [(Literal,CgStmts)]
 773               -> FCode CgStmts
 774 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
 775   = return (consCgStmt if_stmt blk)
 776   where
 777     cmm_lit = mkSimpleLit lit
 778     rep     = cmmLitRep cmm_lit
 779     cond    = CmmMachOp (MO_Ne rep) [scrut, CmmLit cmm_lit]
 780     if_stmt = CmmCondBranch cond deflt_blk_id
 781
 782 mk_lit_switch scrut deflt_blk_id branches
 783   = do  { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
 784         ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
 785         ; lo_blk_id <- forkCgStmts lo_blk
 786         ; let if_stmt = CmmCondBranch cond lo_blk_id
 787         ; return (if_stmt `consCgStmt` hi_blk) }
 788   where
 789     n_branches = length branches
 790     (mid_lit,_) = branches !! (n_branches `div` 2)
 791         -- See notes above re mid_tag
 792
 793     (lo_branches, hi_branches) = span is_lo branches
 794     is_lo (t,_) = t < mid_lit
 795
 796     cond    = CmmMachOp (mkLtOp mid_lit)
 797                         [scrut, CmmLit (mkSimpleLit mid_lit)]
 798
 799 -------------------------------------------------------------------------
 800 --
 801 --      Simultaneous assignment
 802 --
 803 -------------------------------------------------------------------------
 804
 805
 806 emitSimultaneously :: CmmStmts -> Code
 807 -- Emit code to perform the assignments in the
 808 -- input simultaneously, using temporary variables when necessary.
 809 --
 810 -- The Stmts must be:
 811 --      CmmNop, CmmComment, CmmAssign, CmmStore
 812 -- and nothing else
 813
 814
 815 -- We use the strongly-connected component algorithm, in which
 816 --      * the vertices are the statements
 817 --      * an edge goes from s1 to s2 iff
 818 --              s1 assigns to something s2 uses
 819 --        that is, if s1 should *follow* s2 in the final order
 820
 821 type CVertex = (Int, CmmStmt)   -- Give each vertex a unique number,
 822                                 -- for fast comparison
 823
 824 emitSimultaneously stmts
 825   = codeOnly $
 826     case filterOut isNopStmt (stmtList stmts) of
 827         -- Remove no-ops
 828       []        -> nopC
 829       [stmt]    -> stmtC stmt   -- It's often just one stmt
 830       stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
 831
 832 doSimultaneously1 :: [CVertex] -> Code
 833 doSimultaneously1 vertices
 834   = let
 835         edges = [ (vertex, key1, edges_from stmt1)
 836                 | vertex@(key1, stmt1) <- vertices
 837                 ]
 838         edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
 839                                     stmt1 `mustFollow` stmt2
 840                            ]
 841         components = stronglyConnComp edges
 842
 843         -- do_components deal with one strongly-connected component
 844         -- Not cyclic, or singleton?  Just do it
 845         do_component (AcyclicSCC (n,stmt))  = stmtC stmt
 846         do_component (CyclicSCC [(n,stmt)]) = stmtC stmt
 847
 848                 -- Cyclic?  Then go via temporaries.  Pick one to
 849                 -- break the loop and try again with the rest.
 850         do_component (CyclicSCC ((n,first_stmt) : rest))
 851           = do  { from_temp <- go_via_temp first_stmt
 852                 ; doSimultaneously1 rest
 853                 ; stmtC from_temp }
 854
 855         go_via_temp (CmmAssign dest src)
 856           = do  { tmp <- newNonPtrTemp (cmmRegRep dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
 857                 ; stmtC (CmmAssign (CmmLocal tmp) src)
 858                 ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) }
 859         go_via_temp (CmmStore dest src)
 860           = do  { tmp <- newNonPtrTemp (cmmExprRep src) -- TODO FIXME NOW if the pair of assignemnts move across a call this will be wrong
 861                 ; stmtC (CmmAssign (CmmLocal tmp) src)
 862                 ; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
 863     in
 864     mapCs do_component components
 865
 866 mustFollow :: CmmStmt -> CmmStmt -> Bool
 867 CmmAssign reg _  `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
 868 CmmStore loc e   `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprRep e)) stmt
 869 CmmNop           `mustFollow` stmt = False
 870 CmmComment _     `mustFollow` stmt = False
 871
 872
 873 anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool
 874 -- True if the fn is true of any input of the stmt
 875 anySrc p (CmmAssign _ e)    = p e
 876 anySrc p (CmmStore e1 e2)   = p e1 || p e2      -- Might be used in either side
 877 anySrc p (CmmComment _)     = False
 878 anySrc p CmmNop             = False
 879 anySrc p other              = True              -- Conservative
 880
 881 regUsedIn :: CmmReg -> CmmExpr -> Bool
 882 reg `regUsedIn` CmmLit _         = False
 883 reg `regUsedIn` CmmLoad e  _     = reg `regUsedIn` e
 884 reg `regUsedIn` CmmReg reg'      = reg == reg'
 885 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
 886 reg `regUsedIn` CmmMachOp _ es   = any (reg `regUsedIn`) es
 887
 888 locUsedIn :: CmmExpr -> MachRep -> CmmExpr -> Bool
 889 -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
 890 -- 'e'.  Returns True if it's not sure.
 891 locUsedIn loc rep (CmmLit _)         = False
 892 locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
 893 locUsedIn loc rep (CmmReg reg')      = False
 894 locUsedIn loc rep (CmmRegOff reg' _) = False
 895 locUsedIn loc rep (CmmMachOp _ es)   = any (locUsedIn loc rep) es
 896
 897 possiblySameLoc :: CmmExpr -> MachRep -> CmmExpr -> MachRep -> Bool
 898 -- Assumes that distinct registers (eg Hp, Sp) do not
 899 -- point to the same location, nor any offset thereof.
 900 possiblySameLoc (CmmReg r1)       rep1 (CmmReg r2)      rep2  = r1==r2
 901 possiblySameLoc (CmmReg r1)       rep1 (CmmRegOff r2 0) rep2  = r1==r2
 902 possiblySameLoc (CmmRegOff r1 0)  rep1 (CmmReg r2)      rep2  = r1==r2
 903 possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
 904   = r1==r2 && end1 > start2 && end2 > start1
 905   where
 906     end1 = start1 + machRepByteWidth rep1
 907     end2 = start2 + machRepByteWidth rep2
 908
 909 possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
 910 possiblySameLoc l1 rep1 l2         rep2 = True  -- Conservative
 911
 912 -------------------------------------------------------------------------
 913 --
 914 --      Static Reference Tables
 915 --
 916 -------------------------------------------------------------------------
 917
 918 -- There is just one SRT for each top level binding; all the nested
 919 -- bindings use sub-sections of this SRT.  The label is passed down to
 920 -- the nested bindings via the monad.
 921
 922 getSRTInfo :: FCode C_SRT
 923 getSRTInfo = do
 924   srt_lbl <- getSRTLabel
 925   srt <- getSRT
 926   case srt of
 927     -- TODO: Should we panic in this case?
 928     -- Someone obviously thinks there should be an SRT
 929     NoSRT -> return NoC_SRT
 930     SRT off len bmp
 931       | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
 932       -> do id <- newUnique
 933             let srt_desc_lbl = mkLargeSRTLabel id
 934             emitRODataLits srt_desc_lbl
 935              ( cmmLabelOffW srt_lbl off
 936                : mkWordCLit (fromIntegral len)
 937                : map mkWordCLit bmp)
 938             return (C_SRT srt_desc_lbl 0 srt_escape)
 939
 940     SRT off len bmp
 941       | otherwise
 942       -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
 943                 -- The fromIntegral converts to StgHalfWord
 944
 945 srt_escape = (-1) :: StgHalfWord