compiler/nativeGen/MachCodeGen.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Generating machine code (instruction selection)
   4 --
   5 -- (c) The University of Glasgow 1996-2004
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 -- This is a big module, but, if you pay attention to
  10 -- (a) the sectioning, (b) the type signatures, and
  11 -- (c) the #if blah_TARGET_ARCH} things, the
  12 -- structure should not be too overwhelming.
  13
  14 module MachCodeGen ( cmmTopCodeGen, InstrBlock ) where
  15
  16 #include "HsVersions.h"
  17 #include "nativeGen/NCG.h"
  18 #include "MachDeps.h"
  19
  20 -- NCG stuff:
  21 import MachInstrs
  22 import MachRegs
  23 import NCGMonad
  24 import PositionIndependentCode
  25 import RegAllocInfo ( mkBranchInstr )
  26
  27 -- Our intermediate code:
  28 import PprCmm           ( pprExpr )
  29 import Cmm
  30 import MachOp
  31 import CLabel
  32
  33 -- The rest:
  34 import StaticFlags      ( opt_PIC )
  35 import ForeignCall      ( CCallConv(..) )
  36 import OrdList
  37 import Pretty
  38 import Outputable
  39 import FastString
  40 import FastTypes        ( isFastTrue )
  41 import Constants        ( wORD_SIZE )
  42
  43 #ifdef DEBUG
  44 import Outputable       ( assertPanic )
  45 import Debug.Trace      ( trace )
  46 #endif
  47
  48 import Control.Monad    ( mapAndUnzipM )
  49 import Data.Maybe       ( fromJust )
  50 import Data.Bits
  51 import Data.Word
  52 import Data.Int
  53
  54 -- -----------------------------------------------------------------------------
  55 -- Top-level of the instruction selector
  56
  57 -- | 'InstrBlock's are the insn sequences generated by the insn selectors.
  58 -- They are really trees of insns to facilitate fast appending, where a
  59 -- left-to-right traversal (pre-order?) yields the insns in the correct
  60 -- order.
  61
  62 type InstrBlock = OrdList Instr
  63
  64 cmmTopCodeGen :: CmmTop -> NatM [NatCmmTop]
  65 cmmTopCodeGen (CmmProc info lab params blocks) = do
  66   (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
  67   picBaseMb <- getPicBaseMaybeNat
  68   let proc = CmmProc info lab params (concat nat_blocks)
  69       tops = proc : concat statics
  70   case picBaseMb of
  71       Just picBase -> initializePicBase picBase tops
  72       Nothing -> return tops
  73
  74 cmmTopCodeGen (CmmData sec dat) = do
  75   return [CmmData sec dat]  -- no translation, we just use CmmStatic
  76
  77 basicBlockCodeGen :: CmmBasicBlock -> NatM ([NatBasicBlock],[NatCmmTop])
  78 basicBlockCodeGen (BasicBlock id stmts) = do
  79   instrs <- stmtsToInstrs stmts
  80   -- code generation may introduce new basic block boundaries, which
  81   -- are indicated by the NEWBLOCK instruction.  We must split up the
  82   -- instruction stream into basic blocks again.  Also, we extract
  83   -- LDATAs here too.
  84   let
  85         (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
  86
  87         mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
  88           = ([], BasicBlock id instrs : blocks, statics)
  89         mkBlocks (LDATA sec dat) (instrs,blocks,statics)
  90           = (instrs, blocks, CmmData sec dat:statics)
  91         mkBlocks instr (instrs,blocks,statics)
  92           = (instr:instrs, blocks, statics)
  93   -- in
  94   return (BasicBlock id top : other_blocks, statics)
  95
  96 stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
  97 stmtsToInstrs stmts
  98    = do instrss <- mapM stmtToInstrs stmts
  99         return (concatOL instrss)
 100
 101 stmtToInstrs :: CmmStmt -> NatM InstrBlock
 102 stmtToInstrs stmt = case stmt of
 103     CmmNop         -> return nilOL
 104     CmmComment s   -> return (unitOL (COMMENT s))
 105
 106     CmmAssign reg src
 107       | isFloatingRep kind -> assignReg_FltCode kind reg src
 108 #if WORD_SIZE_IN_BITS==32
 109       | kind == I64        -> assignReg_I64Code      reg src
 110 #endif
 111       | otherwise          -> assignReg_IntCode kind reg src
 112         where kind = cmmRegRep reg
 113
 114     CmmStore addr src
 115       | isFloatingRep kind -> assignMem_FltCode kind addr src
 116 #if WORD_SIZE_IN_BITS==32
 117       | kind == I64      -> assignMem_I64Code      addr src
 118 #endif
 119       | otherwise        -> assignMem_IntCode kind addr src
 120         where kind = cmmExprRep src
 121
 122     CmmCall target result_regs args vols
 123        -> genCCall target result_regs args vols
 124
 125     CmmBranch id          -> genBranch id
 126     CmmCondBranch arg id  -> genCondJump id arg
 127     CmmSwitch arg ids     -> genSwitch arg ids
 128     CmmJump arg params    -> genJump arg
 129
 130 -- -----------------------------------------------------------------------------
 131 -- General things for putting together code sequences
 132
 133 -- Expand CmmRegOff.  ToDo: should we do it this way around, or convert
 134 -- CmmExprs into CmmRegOff?
 135 mangleIndexTree :: CmmExpr -> CmmExpr
 136 mangleIndexTree (CmmRegOff reg off)
 137   = CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) rep)]
 138   where rep = cmmRegRep reg
 139
 140 -- -----------------------------------------------------------------------------
 141 --  Code gen for 64-bit arithmetic on 32-bit platforms
 142
 143 {-
 144 Simple support for generating 64-bit code (ie, 64 bit values and 64
 145 bit assignments) on 32-bit platforms.  Unlike the main code generator
 146 we merely shoot for generating working code as simply as possible, and
 147 pay little attention to code quality.  Specifically, there is no
 148 attempt to deal cleverly with the fixed-vs-floating register
 149 distinction; all values are generated into (pairs of) floating
 150 registers, even if this would mean some redundant reg-reg moves as a
 151 result.  Only one of the VRegUniques is returned, since it will be
 152 of the VRegUniqueLo form, and the upper-half VReg can be determined
 153 by applying getHiVRegFromLo to it.
 154 -}
 155
 156 data ChildCode64        -- a.k.a "Register64"
 157    = ChildCode64
 158         InstrBlock      -- code
 159         Reg             -- the lower 32-bit temporary which contains the
 160                         -- result; use getHiVRegFromLo to find the other
 161                         -- VRegUnique.  Rules of this simplified insn
 162                         -- selection game are therefore that the returned
 163                         -- Reg may be modified
 164
 165 #if WORD_SIZE_IN_BITS==32
 166 assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
 167 assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock
 168 #endif
 169
 170 #ifndef x86_64_TARGET_ARCH
 171 iselExpr64        :: CmmExpr -> NatM ChildCode64
 172 #endif
 173
 174 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 175
 176 #if i386_TARGET_ARCH
 177
 178 assignMem_I64Code addrTree valueTree = do
 179   Amode addr addr_code <- getAmode addrTree
 180   ChildCode64 vcode rlo <- iselExpr64 valueTree
 181   let
 182         rhi = getHiVRegFromLo rlo
 183
 184         -- Little-endian store
 185         mov_lo = MOV I32 (OpReg rlo) (OpAddr addr)
 186         mov_hi = MOV I32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))
 187   -- in
 188   return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
 189
 190
 191 assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do
 192    ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
 193    let
 194          r_dst_lo = mkVReg u_dst I32
 195          r_dst_hi = getHiVRegFromLo r_dst_lo
 196          r_src_hi = getHiVRegFromLo r_src_lo
 197          mov_lo = MOV I32 (OpReg r_src_lo) (OpReg r_dst_lo)
 198          mov_hi = MOV I32 (OpReg r_src_hi) (OpReg r_dst_hi)
 199    -- in
 200    return (
 201         vcode `snocOL` mov_lo `snocOL` mov_hi
 202      )
 203
 204 assignReg_I64Code lvalue valueTree
 205    = panic "assignReg_I64Code(i386): invalid lvalue"
 206
 207 ------------
 208
 209 iselExpr64 (CmmLit (CmmInt i _)) = do
 210   (rlo,rhi) <- getNewRegPairNat I32
 211   let
 212         r = fromIntegral (fromIntegral i :: Word32)
 213         q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32)
 214         code = toOL [
 215                 MOV I32 (OpImm (ImmInteger r)) (OpReg rlo),
 216                 MOV I32 (OpImm (ImmInteger q)) (OpReg rhi)
 217                 ]
 218   -- in
 219   return (ChildCode64 code rlo)
 220
 221 iselExpr64 (CmmLoad addrTree I64) = do
 222    Amode addr addr_code <- getAmode addrTree
 223    (rlo,rhi) <- getNewRegPairNat I32
 224    let
 225         mov_lo = MOV I32 (OpAddr addr) (OpReg rlo)
 226         mov_hi = MOV I32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)
 227    -- in
 228    return (
 229             ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
 230                         rlo
 231      )
 232
 233 iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64)))
 234    = return (ChildCode64 nilOL (mkVReg vu I32))
 235
 236 -- we handle addition, but rather badly
 237 iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do
 238    ChildCode64 code1 r1lo <- iselExpr64 e1
 239    (rlo,rhi) <- getNewRegPairNat I32
 240    let
 241         r = fromIntegral (fromIntegral i :: Word32)
 242         q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32)
 243         r1hi = getHiVRegFromLo r1lo
 244         code =  code1 `appOL`
 245                 toOL [ MOV I32 (OpReg r1lo) (OpReg rlo),
 246                        ADD I32 (OpImm (ImmInteger r)) (OpReg rlo),
 247                        MOV I32 (OpReg r1hi) (OpReg rhi),
 248                        ADC I32 (OpImm (ImmInteger q)) (OpReg rhi) ]
 249    -- in
 250    return (ChildCode64 code rlo)
 251
 252 iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
 253    ChildCode64 code1 r1lo <- iselExpr64 e1
 254    ChildCode64 code2 r2lo <- iselExpr64 e2
 255    (rlo,rhi) <- getNewRegPairNat I32
 256    let
 257         r1hi = getHiVRegFromLo r1lo
 258         r2hi = getHiVRegFromLo r2lo
 259         code =  code1 `appOL`
 260                 code2 `appOL`
 261                 toOL [ MOV I32 (OpReg r1lo) (OpReg rlo),
 262                        ADD I32 (OpReg r2lo) (OpReg rlo),
 263                        MOV I32 (OpReg r1hi) (OpReg rhi),
 264                        ADC I32 (OpReg r2hi) (OpReg rhi) ]
 265    -- in
 266    return (ChildCode64 code rlo)
 267
 268 iselExpr64 expr
 269    = pprPanic "iselExpr64(i386)" (ppr expr)
 270
 271 #endif /* i386_TARGET_ARCH */
 272
 273 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 274
 275 #if sparc_TARGET_ARCH
 276
 277 assignMem_I64Code addrTree valueTree = do
 278      Amode addr addr_code <- getAmode addrTree
 279      ChildCode64 vcode rlo <- iselExpr64 valueTree
 280      (src, code) <- getSomeReg addrTree
 281      let
 282          rhi = getHiVRegFromLo rlo
 283          -- Big-endian store
 284          mov_hi = ST I32 rhi (AddrRegImm src (ImmInt 0))
 285          mov_lo = ST I32 rlo (AddrRegImm src (ImmInt 4))
 286      return (vcode `appOL` code `snocOL` mov_hi `snocOL` mov_lo)
 287
 288 assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do
 289      ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
 290      let
 291          r_dst_lo = mkVReg u_dst pk
 292          r_dst_hi = getHiVRegFromLo r_dst_lo
 293          r_src_hi = getHiVRegFromLo r_src_lo
 294          mov_lo = mkMOV r_src_lo r_dst_lo
 295          mov_hi = mkMOV r_src_hi r_dst_hi
 296          mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
 297      return (vcode `snocOL` mov_hi `snocOL` mov_lo)
 298 assignReg_I64Code lvalue valueTree
 299    = panic "assignReg_I64Code(sparc): invalid lvalue"
 300
 301
 302 -- Don't delete this -- it's very handy for debugging.
 303 --iselExpr64 expr
 304 --   | trace ("iselExpr64: " ++ showSDoc (ppr expr)) False
 305 --   = panic "iselExpr64(???)"
 306
 307 iselExpr64 (CmmLoad addrTree I64) = do
 308      Amode (AddrRegReg r1 r2) addr_code <- getAmode addrTree
 309      rlo <- getNewRegNat I32
 310      let rhi = getHiVRegFromLo rlo
 311          mov_hi = LD I32 (AddrRegImm r1 (ImmInt 0)) rhi
 312          mov_lo = LD I32 (AddrRegImm r1 (ImmInt 4)) rlo
 313      return (
 314             ChildCode64 (addr_code `snocOL` mov_hi `snocOL` mov_lo)
 315                          rlo
 316           )
 317
 318 iselExpr64 (CmmReg (CmmLocal (LocalReg uq I64))) = do
 319      r_dst_lo <-  getNewRegNat I32
 320      let r_dst_hi = getHiVRegFromLo r_dst_lo
 321          r_src_lo = mkVReg uq I32
 322          r_src_hi = getHiVRegFromLo r_src_lo
 323          mov_lo = mkMOV r_src_lo r_dst_lo
 324          mov_hi = mkMOV r_src_hi r_dst_hi
 325          mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
 326      return (
 327             ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo
 328          )
 329
 330 iselExpr64 expr
 331    = pprPanic "iselExpr64(sparc)" (ppr expr)
 332
 333 #endif /* sparc_TARGET_ARCH */
 334
 335 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 336
 337 #if powerpc_TARGET_ARCH
 338
 339 getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock)
 340 getI64Amodes addrTree = do
 341     Amode hi_addr addr_code <- getAmode addrTree
 342     case addrOffset hi_addr 4 of
 343         Just lo_addr -> return (hi_addr, lo_addr, addr_code)
 344         Nothing      -> do (hi_ptr, code) <- getSomeReg addrTree
 345                            return (AddrRegImm hi_ptr (ImmInt 0),
 346                                    AddrRegImm hi_ptr (ImmInt 4),
 347                                    code)
 348
 349 assignMem_I64Code addrTree valueTree = do
 350         (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
 351         ChildCode64 vcode rlo <- iselExpr64 valueTree
 352         let
 353                 rhi = getHiVRegFromLo rlo
 354
 355                 -- Big-endian store
 356                 mov_hi = ST I32 rhi hi_addr
 357                 mov_lo = ST I32 rlo lo_addr
 358         -- in
 359         return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
 360
 361 assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do
 362    ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
 363    let
 364          r_dst_lo = mkVReg u_dst I32
 365          r_dst_hi = getHiVRegFromLo r_dst_lo
 366          r_src_hi = getHiVRegFromLo r_src_lo
 367          mov_lo = MR r_dst_lo r_src_lo
 368          mov_hi = MR r_dst_hi r_src_hi
 369    -- in
 370    return (
 371         vcode `snocOL` mov_lo `snocOL` mov_hi
 372      )
 373
 374 assignReg_I64Code lvalue valueTree
 375    = panic "assignReg_I64Code(powerpc): invalid lvalue"
 376
 377
 378 -- Don't delete this -- it's very handy for debugging.
 379 --iselExpr64 expr
 380 --   | trace ("iselExpr64: " ++ showSDoc (pprCmmExpr expr)) False
 381 --   = panic "iselExpr64(???)"
 382
 383 iselExpr64 (CmmLoad addrTree I64) = do
 384     (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
 385     (rlo, rhi) <- getNewRegPairNat I32
 386     let mov_hi = LD I32 rhi hi_addr
 387         mov_lo = LD I32 rlo lo_addr
 388     return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
 389                          rlo
 390
 391 iselExpr64 (CmmReg (CmmLocal (LocalReg vu I64)))
 392    = return (ChildCode64 nilOL (mkVReg vu I32))
 393
 394 iselExpr64 (CmmLit (CmmInt i _)) = do
 395   (rlo,rhi) <- getNewRegPairNat I32
 396   let
 397         half0 = fromIntegral (fromIntegral i :: Word16)
 398         half1 = fromIntegral ((fromIntegral i `shiftR` 16) :: Word16)
 399         half2 = fromIntegral ((fromIntegral i `shiftR` 32) :: Word16)
 400         half3 = fromIntegral ((fromIntegral i `shiftR` 48) :: Word16)
 401
 402         code = toOL [
 403                 LIS rlo (ImmInt half1),
 404                 OR rlo rlo (RIImm $ ImmInt half0),
 405                 LIS rhi (ImmInt half3),
 406                 OR rlo rlo (RIImm $ ImmInt half2)
 407                 ]
 408   -- in
 409   return (ChildCode64 code rlo)
 410
 411 iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
 412    ChildCode64 code1 r1lo <- iselExpr64 e1
 413    ChildCode64 code2 r2lo <- iselExpr64 e2
 414    (rlo,rhi) <- getNewRegPairNat I32
 415    let
 416         r1hi = getHiVRegFromLo r1lo
 417         r2hi = getHiVRegFromLo r2lo
 418         code =  code1 `appOL`
 419                 code2 `appOL`
 420                 toOL [ ADDC rlo r1lo r2lo,
 421                        ADDE rhi r1hi r2hi ]
 422    -- in
 423    return (ChildCode64 code rlo)
 424
 425 iselExpr64 expr
 426    = pprPanic "iselExpr64(powerpc)" (ppr expr)
 427
 428 #endif /* powerpc_TARGET_ARCH */
 429
 430
 431 -- -----------------------------------------------------------------------------
 432 -- The 'Register' type
 433
 434 -- 'Register's passed up the tree.  If the stix code forces the register
 435 -- to live in a pre-decided machine register, it comes out as @Fixed@;
 436 -- otherwise, it comes out as @Any@, and the parent can decide which
 437 -- register to put it in.
 438
 439 data Register
 440   = Fixed   MachRep Reg InstrBlock
 441   | Any     MachRep (Reg -> InstrBlock)
 442
 443 swizzleRegisterRep :: Register -> MachRep -> Register
 444 swizzleRegisterRep (Fixed _ reg code) rep = Fixed rep reg code
 445 swizzleRegisterRep (Any _ codefn)     rep = Any rep codefn
 446
 447
 448 -- -----------------------------------------------------------------------------
 449 -- Utils based on getRegister, below
 450
 451 -- The dual to getAnyReg: compute an expression into a register, but
 452 -- we don't mind which one it is.
 453 getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
 454 getSomeReg expr = do
 455   r <- getRegister expr
 456   case r of
 457     Any rep code -> do
 458         tmp <- getNewRegNat rep
 459         return (tmp, code tmp)
 460     Fixed _ reg code ->
 461         return (reg, code)
 462
 463 -- -----------------------------------------------------------------------------
 464 -- Grab the Reg for a CmmReg
 465
 466 getRegisterReg :: CmmReg -> Reg
 467
 468 getRegisterReg (CmmLocal (LocalReg u pk))
 469   = mkVReg u pk
 470
 471 getRegisterReg (CmmGlobal mid)
 472   = case get_GlobalReg_reg_or_addr mid of
 473        Left (RealReg rrno) -> RealReg rrno
 474        _other -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
 475           -- By this stage, the only MagicIds remaining should be the
 476           -- ones which map to a real machine register on this
 477           -- platform.  Hence ...
 478
 479
 480 -- -----------------------------------------------------------------------------
 481 -- Generate code to get a subtree into a Register
 482
 483 -- Don't delete this -- it's very handy for debugging.
 484 --getRegister expr
 485 --   | trace ("getRegister: " ++ showSDoc (pprCmmExpr expr)) False
 486 --   = panic "getRegister(???)"
 487
 488 getRegister :: CmmExpr -> NatM Register
 489
 490 #if !x86_64_TARGET_ARCH
 491     -- on x86_64, we have %rip for PicBaseReg, but it's not a full-featured
 492     -- register, it can only be used for rip-relative addressing.
 493 getRegister (CmmReg (CmmGlobal PicBaseReg))
 494   = do
 495       reg <- getPicBaseNat wordRep
 496       return (Fixed wordRep reg nilOL)
 497 #endif
 498
 499 getRegister (CmmReg reg)
 500   = return (Fixed (cmmRegRep reg) (getRegisterReg reg) nilOL)
 501
 502 getRegister tree@(CmmRegOff _ _)
 503   = getRegister (mangleIndexTree tree)
 504
 505
 506 #if WORD_SIZE_IN_BITS==32
 507     -- for 32-bit architectuers, support some 64 -> 32 bit conversions:
 508     -- TO_W_(x), TO_W_(x >> 32)
 509
 510 getRegister (CmmMachOp (MO_U_Conv I64 I32)
 511              [CmmMachOp (MO_U_Shr I64) [x,CmmLit (CmmInt 32 _)]]) = do
 512   ChildCode64 code rlo <- iselExpr64 x
 513   return $ Fixed I32 (getHiVRegFromLo rlo) code
 514
 515 getRegister (CmmMachOp (MO_S_Conv I64 I32)
 516              [CmmMachOp (MO_U_Shr I64) [x,CmmLit (CmmInt 32 _)]]) = do
 517   ChildCode64 code rlo <- iselExpr64 x
 518   return $ Fixed I32 (getHiVRegFromLo rlo) code
 519
 520 getRegister (CmmMachOp (MO_U_Conv I64 I32) [x]) = do
 521   ChildCode64 code rlo <- iselExpr64 x
 522   return $ Fixed I32 rlo code
 523
 524 getRegister (CmmMachOp (MO_S_Conv I64 I32) [x]) = do
 525   ChildCode64 code rlo <- iselExpr64 x
 526   return $ Fixed I32 rlo code
 527
 528 #endif
 529
 530 -- end of machine-"independent" bit; here we go on the rest...
 531
 532 #if alpha_TARGET_ARCH
 533
 534 getRegister (StDouble d)
 535   = getBlockIdNat                   `thenNat` \ lbl ->
 536     getNewRegNat PtrRep             `thenNat` \ tmp ->
 537     let code dst = mkSeqInstrs [
 538             LDATA RoDataSegment lbl [
 539                     DATA TF [ImmLab (rational d)]
 540                 ],
 541             LDA tmp (AddrImm (ImmCLbl lbl)),
 542             LD TF dst (AddrReg tmp)]
 543     in
 544         return (Any F64 code)
 545
 546 getRegister (StPrim primop [x]) -- unary PrimOps
 547   = case primop of
 548       IntNegOp -> trivialUCode (NEG Q False) x
 549
 550       NotOp    -> trivialUCode NOT x
 551
 552       FloatNegOp  -> trivialUFCode FloatRep  (FNEG TF) x
 553       DoubleNegOp -> trivialUFCode F64 (FNEG TF) x
 554
 555       OrdOp -> coerceIntCode IntRep x
 556       ChrOp -> chrCode x
 557
 558       Float2IntOp  -> coerceFP2Int    x
 559       Int2FloatOp  -> coerceInt2FP pr x
 560       Double2IntOp -> coerceFP2Int    x
 561       Int2DoubleOp -> coerceInt2FP pr x
 562
 563       Double2FloatOp -> coerceFltCode x
 564       Float2DoubleOp -> coerceFltCode x
 565
 566       other_op -> getRegister (StCall fn CCallConv F64 [x])
 567         where
 568           fn = case other_op of
 569                  FloatExpOp    -> FSLIT("exp")
 570                  FloatLogOp    -> FSLIT("log")
 571                  FloatSqrtOp   -> FSLIT("sqrt")
 572                  FloatSinOp    -> FSLIT("sin")
 573                  FloatCosOp    -> FSLIT("cos")
 574                  FloatTanOp    -> FSLIT("tan")
 575                  FloatAsinOp   -> FSLIT("asin")
 576                  FloatAcosOp   -> FSLIT("acos")
 577                  FloatAtanOp   -> FSLIT("atan")
 578                  FloatSinhOp   -> FSLIT("sinh")
 579                  FloatCoshOp   -> FSLIT("cosh")
 580                  FloatTanhOp   -> FSLIT("tanh")
 581                  DoubleExpOp   -> FSLIT("exp")
 582                  DoubleLogOp   -> FSLIT("log")
 583                  DoubleSqrtOp  -> FSLIT("sqrt")
 584                  DoubleSinOp   -> FSLIT("sin")
 585                  DoubleCosOp   -> FSLIT("cos")
 586                  DoubleTanOp   -> FSLIT("tan")
 587                  DoubleAsinOp  -> FSLIT("asin")
 588                  DoubleAcosOp  -> FSLIT("acos")
 589                  DoubleAtanOp  -> FSLIT("atan")
 590                  DoubleSinhOp  -> FSLIT("sinh")
 591                  DoubleCoshOp  -> FSLIT("cosh")
 592                  DoubleTanhOp  -> FSLIT("tanh")
 593   where
 594     pr = panic "MachCode.getRegister: no primrep needed for Alpha"
 595
 596 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
 597   = case primop of
 598       CharGtOp -> trivialCode (CMP LTT) y x
 599       CharGeOp -> trivialCode (CMP LE) y x
 600       CharEqOp -> trivialCode (CMP EQQ) x y
 601       CharNeOp -> int_NE_code x y
 602       CharLtOp -> trivialCode (CMP LTT) x y
 603       CharLeOp -> trivialCode (CMP LE) x y
 604
 605       IntGtOp  -> trivialCode (CMP LTT) y x
 606       IntGeOp  -> trivialCode (CMP LE) y x
 607       IntEqOp  -> trivialCode (CMP EQQ) x y
 608       IntNeOp  -> int_NE_code x y
 609       IntLtOp  -> trivialCode (CMP LTT) x y
 610       IntLeOp  -> trivialCode (CMP LE) x y
 611
 612       WordGtOp -> trivialCode (CMP ULT) y x
 613       WordGeOp -> trivialCode (CMP ULE) x y
 614       WordEqOp -> trivialCode (CMP EQQ)  x y
 615       WordNeOp -> int_NE_code x y
 616       WordLtOp -> trivialCode (CMP ULT) x y
 617       WordLeOp -> trivialCode (CMP ULE) x y
 618
 619       AddrGtOp -> trivialCode (CMP ULT) y x
 620       AddrGeOp -> trivialCode (CMP ULE) y x
 621       AddrEqOp -> trivialCode (CMP EQQ)  x y
 622       AddrNeOp -> int_NE_code x y
 623       AddrLtOp -> trivialCode (CMP ULT) x y
 624       AddrLeOp -> trivialCode (CMP ULE) x y
 625
 626       FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
 627       FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
 628       FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
 629       FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
 630       FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
 631       FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
 632
 633       DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
 634       DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
 635       DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
 636       DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
 637       DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
 638       DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
 639
 640       IntAddOp  -> trivialCode (ADD Q False) x y
 641       IntSubOp  -> trivialCode (SUB Q False) x y
 642       IntMulOp  -> trivialCode (MUL Q False) x y
 643       IntQuotOp -> trivialCode (DIV Q False) x y
 644       IntRemOp  -> trivialCode (REM Q False) x y
 645
 646       WordAddOp  -> trivialCode (ADD Q False) x y
 647       WordSubOp  -> trivialCode (SUB Q False) x y
 648       WordMulOp  -> trivialCode (MUL Q False) x y
 649       WordQuotOp -> trivialCode (DIV Q True) x y
 650       WordRemOp  -> trivialCode (REM Q True) x y
 651
 652       FloatAddOp -> trivialFCode  FloatRep (FADD TF) x y
 653       FloatSubOp -> trivialFCode  FloatRep (FSUB TF) x y
 654       FloatMulOp -> trivialFCode  FloatRep (FMUL TF) x y
 655       FloatDivOp -> trivialFCode  FloatRep (FDIV TF) x y
 656
 657       DoubleAddOp -> trivialFCode  F64 (FADD TF) x y
 658       DoubleSubOp -> trivialFCode  F64 (FSUB TF) x y
 659       DoubleMulOp -> trivialFCode  F64 (FMUL TF) x y
 660       DoubleDivOp -> trivialFCode  F64 (FDIV TF) x y
 661
 662       AddrAddOp  -> trivialCode (ADD Q False) x y
 663       AddrSubOp  -> trivialCode (SUB Q False) x y
 664       AddrRemOp  -> trivialCode (REM Q True) x y
 665
 666       AndOp  -> trivialCode AND x y
 667       OrOp   -> trivialCode OR  x y
 668       XorOp  -> trivialCode XOR x y
 669       SllOp  -> trivialCode SLL x y
 670       SrlOp  -> trivialCode SRL x y
 671
 672       ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
 673       ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
 674       ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
 675
 676       FloatPowerOp  -> getRegister (StCall FSLIT("pow") CCallConv F64 [x,y])
 677       DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv F64 [x,y])
 678   where
 679     {- ------------------------------------------------------------
 680         Some bizarre special code for getting condition codes into
 681         registers.  Integer non-equality is a test for equality
 682         followed by an XOR with 1.  (Integer comparisons always set
 683         the result register to 0 or 1.)  Floating point comparisons of
 684         any kind leave the result in a floating point register, so we
 685         need to wrangle an integer register out of things.
 686     -}
 687     int_NE_code :: StixTree -> StixTree -> NatM Register
 688
 689     int_NE_code x y
 690       = trivialCode (CMP EQQ) x y       `thenNat` \ register ->
 691         getNewRegNat IntRep             `thenNat` \ tmp ->
 692         let
 693             code = registerCode register tmp
 694             src  = registerName register tmp
 695             code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
 696         in
 697         return (Any IntRep code__2)
 698
 699     {- ------------------------------------------------------------
 700         Comments for int_NE_code also apply to cmpF_code
 701     -}
 702     cmpF_code
 703         :: (Reg -> Reg -> Reg -> Instr)
 704         -> Cond
 705         -> StixTree -> StixTree
 706         -> NatM Register
 707
 708     cmpF_code instr cond x y
 709       = trivialFCode pr instr x y       `thenNat` \ register ->
 710         getNewRegNat F64                `thenNat` \ tmp ->
 711         getBlockIdNat                   `thenNat` \ lbl ->
 712         let
 713             code = registerCode register tmp
 714             result  = registerName register tmp
 715
 716             code__2 dst = code . mkSeqInstrs [
 717                 OR zeroh (RIImm (ImmInt 1)) dst,
 718                 BF cond  result (ImmCLbl lbl),
 719                 OR zeroh (RIReg zeroh) dst,
 720                 NEWBLOCK lbl]
 721         in
 722         return (Any IntRep code__2)
 723       where
 724         pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
 725       ------------------------------------------------------------
 726
 727 getRegister (CmmLoad pk mem)
 728   = getAmode mem                    `thenNat` \ amode ->
 729     let
 730         code = amodeCode amode
 731         src   = amodeAddr amode
 732         size = primRepToSize pk
 733         code__2 dst = code . mkSeqInstr (LD size dst src)
 734     in
 735     return (Any pk code__2)
 736
 737 getRegister (StInt i)
 738   | fits8Bits i
 739   = let
 740         code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
 741     in
 742     return (Any IntRep code)
 743   | otherwise
 744   = let
 745         code dst = mkSeqInstr (LDI Q dst src)
 746     in
 747     return (Any IntRep code)
 748   where
 749     src = ImmInt (fromInteger i)
 750
 751 getRegister leaf
 752   | isJust imm
 753   = let
 754         code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
 755     in
 756     return (Any PtrRep code)
 757   where
 758     imm = maybeImm leaf
 759     imm__2 = case imm of Just x -> x
 760
 761 #endif /* alpha_TARGET_ARCH */
 762
 763 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 764
 765 #if i386_TARGET_ARCH
 766
 767 getRegister (CmmLit (CmmFloat f F32)) = do
 768     lbl <- getNewLabelNat
 769     dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl
 770     Amode addr addr_code <- getAmode dynRef
 771     let code dst =
 772             LDATA ReadOnlyData
 773                         [CmmDataLabel lbl,
 774                          CmmStaticLit (CmmFloat f F32)]
 775             `consOL` (addr_code `snocOL`
 776             GLD F32 addr dst)
 777     -- in
 778     return (Any F32 code)
 779
 780
 781 getRegister (CmmLit (CmmFloat d F64))
 782   | d == 0.0
 783   = let code dst = unitOL (GLDZ dst)
 784     in  return (Any F64 code)
 785
 786   | d == 1.0
 787   = let code dst = unitOL (GLD1 dst)
 788     in  return (Any F64 code)
 789
 790   | otherwise = do
 791     lbl <- getNewLabelNat
 792     dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl
 793     Amode addr addr_code <- getAmode dynRef
 794     let code dst =
 795             LDATA ReadOnlyData
 796                         [CmmDataLabel lbl,
 797                          CmmStaticLit (CmmFloat d F64)]
 798             `consOL` (addr_code `snocOL`
 799             GLD F64 addr dst)
 800     -- in
 801     return (Any F64 code)
 802
 803 #endif /* i386_TARGET_ARCH */
 804
 805 #if x86_64_TARGET_ARCH
 806
 807 getRegister (CmmLit (CmmFloat 0.0 rep)) = do
 808    let code dst = unitOL  (XOR rep (OpReg dst) (OpReg dst))
 809         -- I don't know why there are xorpd, xorps, and pxor instructions.
 810         -- They all appear to do the same thing --SDM
 811    return (Any rep code)
 812
 813 getRegister (CmmLit (CmmFloat f rep)) = do
 814     lbl <- getNewLabelNat
 815     let code dst = toOL [
 816             LDATA ReadOnlyData
 817                         [CmmDataLabel lbl,
 818                          CmmStaticLit (CmmFloat f rep)],
 819             MOV rep (OpAddr (ripRel (ImmCLbl lbl))) (OpReg dst)
 820             ]
 821     -- in
 822     return (Any rep code)
 823
 824 #endif /* x86_64_TARGET_ARCH */
 825
 826 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 827
 828 -- catch simple cases of zero- or sign-extended load
 829 getRegister (CmmMachOp (MO_U_Conv I8 I32) [CmmLoad addr _]) = do
 830   code <- intLoadCode (MOVZxL I8) addr
 831   return (Any I32 code)
 832
 833 getRegister (CmmMachOp (MO_S_Conv I8 I32) [CmmLoad addr _]) = do
 834   code <- intLoadCode (MOVSxL I8) addr
 835   return (Any I32 code)
 836
 837 getRegister (CmmMachOp (MO_U_Conv I16 I32) [CmmLoad addr _]) = do
 838   code <- intLoadCode (MOVZxL I16) addr
 839   return (Any I32 code)
 840
 841 getRegister (CmmMachOp (MO_S_Conv I16 I32) [CmmLoad addr _]) = do
 842   code <- intLoadCode (MOVSxL I16) addr
 843   return (Any I32 code)
 844
 845 #endif
 846
 847 #if x86_64_TARGET_ARCH
 848
 849 -- catch simple cases of zero- or sign-extended load
 850 getRegister (CmmMachOp (MO_U_Conv I8 I64) [CmmLoad addr _]) = do
 851   code <- intLoadCode (MOVZxL I8) addr
 852   return (Any I64 code)
 853
 854 getRegister (CmmMachOp (MO_S_Conv I8 I64) [CmmLoad addr _]) = do
 855   code <- intLoadCode (MOVSxL I8) addr
 856   return (Any I64 code)
 857
 858 getRegister (CmmMachOp (MO_U_Conv I16 I64) [CmmLoad addr _]) = do
 859   code <- intLoadCode (MOVZxL I16) addr
 860   return (Any I64 code)
 861
 862 getRegister (CmmMachOp (MO_S_Conv I16 I64) [CmmLoad addr _]) = do
 863   code <- intLoadCode (MOVSxL I16) addr
 864   return (Any I64 code)
 865
 866 getRegister (CmmMachOp (MO_U_Conv I32 I64) [CmmLoad addr _]) = do
 867   code <- intLoadCode (MOV I32) addr -- 32-bit loads zero-extend
 868   return (Any I64 code)
 869
 870 getRegister (CmmMachOp (MO_S_Conv I32 I64) [CmmLoad addr _]) = do
 871   code <- intLoadCode (MOVSxL I32) addr
 872   return (Any I64 code)
 873
 874 #endif
 875
 876 #if x86_64_TARGET_ARCH
 877 getRegister (CmmMachOp (MO_Add I64) [CmmReg (CmmGlobal PicBaseReg),
 878                                      CmmLit displacement])
 879     = return $ Any I64 (\dst -> unitOL $
 880         LEA I64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))
 881 #endif
 882
 883 #if x86_64_TARGET_ARCH
 884 getRegister (CmmMachOp (MO_S_Neg F32) [x]) = do
 885   x_code <- getAnyReg x
 886   lbl <- getNewLabelNat
 887   let
 888     code dst = x_code dst `appOL` toOL [
 889         -- This is how gcc does it, so it can't be that bad:
 890         LDATA ReadOnlyData16 [
 891                 CmmAlign 16,
 892                 CmmDataLabel lbl,
 893                 CmmStaticLit (CmmInt 0x80000000 I32),
 894                 CmmStaticLit (CmmInt 0 I32),
 895                 CmmStaticLit (CmmInt 0 I32),
 896                 CmmStaticLit (CmmInt 0 I32)
 897         ],
 898         XOR F32 (OpAddr (ripRel (ImmCLbl lbl))) (OpReg dst)
 899                 -- xorps, so we need the 128-bit constant
 900                 -- ToDo: rip-relative
 901         ]
 902   --
 903   return (Any F32 code)
 904
 905 getRegister (CmmMachOp (MO_S_Neg F64) [x]) = do
 906   x_code <- getAnyReg x
 907   lbl <- getNewLabelNat
 908   let
 909         -- This is how gcc does it, so it can't be that bad:
 910     code dst = x_code dst `appOL` toOL [
 911         LDATA ReadOnlyData16 [
 912                 CmmAlign 16,
 913                 CmmDataLabel lbl,
 914                 CmmStaticLit (CmmInt 0x8000000000000000 I64),
 915                 CmmStaticLit (CmmInt 0 I64)
 916         ],
 917                 -- gcc puts an unpck here.  Wonder if we need it.
 918         XOR F64 (OpAddr (ripRel (ImmCLbl lbl))) (OpReg dst)
 919                 -- xorpd, so we need the 128-bit constant
 920         ]
 921   --
 922   return (Any F64 code)
 923 #endif
 924
 925 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
 926
 927 getRegister (CmmMachOp mop [x]) -- unary MachOps
 928   = case mop of
 929 #if i386_TARGET_ARCH
 930       MO_S_Neg F32 -> trivialUFCode F32 (GNEG F32) x
 931       MO_S_Neg F64 -> trivialUFCode F64 (GNEG F64) x
 932 #endif
 933
 934       MO_S_Neg rep -> trivialUCode rep (NEGI rep) x
 935       MO_Not rep   -> trivialUCode rep (NOT  rep) x
 936
 937       -- Nop conversions
 938       MO_U_Conv I32 I8  -> toI8Reg  I32 x
 939       MO_S_Conv I32 I8  -> toI8Reg  I32 x
 940       MO_U_Conv I16 I8  -> toI8Reg  I16 x
 941       MO_S_Conv I16 I8  -> toI8Reg  I16 x
 942       MO_U_Conv I32 I16 -> toI16Reg I32 x
 943       MO_S_Conv I32 I16 -> toI16Reg I32 x
 944 #if x86_64_TARGET_ARCH
 945       MO_U_Conv I64 I32 -> conversionNop I64 x
 946       MO_S_Conv I64 I32 -> conversionNop I64 x
 947       MO_U_Conv I64 I16 -> toI16Reg I64 x
 948       MO_S_Conv I64 I16 -> toI16Reg I64 x
 949       MO_U_Conv I64 I8  -> toI8Reg  I64 x
 950       MO_S_Conv I64 I8  -> toI8Reg  I64 x
 951 #endif
 952
 953       MO_U_Conv rep1 rep2 | rep1 == rep2 -> conversionNop rep1 x
 954       MO_S_Conv rep1 rep2 | rep1 == rep2 -> conversionNop rep1 x
 955
 956       -- widenings
 957       MO_U_Conv I8  I32 -> integerExtend I8  I32 MOVZxL x
 958       MO_U_Conv I16 I32 -> integerExtend I16 I32 MOVZxL x
 959       MO_U_Conv I8  I16 -> integerExtend I8  I16 MOVZxL x
 960
 961       MO_S_Conv I8  I32 -> integerExtend I8  I32 MOVSxL x
 962       MO_S_Conv I16 I32 -> integerExtend I16 I32 MOVSxL x
 963       MO_S_Conv I8  I16 -> integerExtend I8  I16 MOVSxL x
 964
 965 #if x86_64_TARGET_ARCH
 966       MO_U_Conv I8  I64 -> integerExtend I8  I64 MOVZxL x
 967       MO_U_Conv I16 I64 -> integerExtend I16 I64 MOVZxL x
 968       MO_U_Conv I32 I64 -> integerExtend I32 I64 MOVZxL x
 969       MO_S_Conv I8  I64 -> integerExtend I8  I64 MOVSxL x
 970       MO_S_Conv I16 I64 -> integerExtend I16 I64 MOVSxL x
 971       MO_S_Conv I32 I64 -> integerExtend I32 I64 MOVSxL x
 972         -- for 32-to-64 bit zero extension, amd64 uses an ordinary movl.
 973         -- However, we don't want the register allocator to throw it
 974         -- away as an unnecessary reg-to-reg move, so we keep it in
 975         -- the form of a movzl and print it as a movl later.
 976 #endif
 977
 978 #if i386_TARGET_ARCH
 979       MO_S_Conv F32 F64 -> conversionNop F64 x
 980       MO_S_Conv F64 F32 -> conversionNop F32 x
 981 #else
 982       MO_S_Conv F32 F64 -> coerceFP2FP F64 x
 983       MO_S_Conv F64 F32 -> coerceFP2FP F32 x
 984 #endif
 985
 986       MO_S_Conv from to
 987         | isFloatingRep from -> coerceFP2Int from to x
 988         | isFloatingRep to   -> coerceInt2FP from to x
 989
 990       other -> pprPanic "getRegister" (pprMachOp mop)
 991    where
 992         -- signed or unsigned extension.
 993         integerExtend from to instr expr = do
 994             (reg,e_code) <- if from == I8 then getByteReg expr
 995                                           else getSomeReg expr
 996             let
 997                 code dst =
 998                   e_code `snocOL`
 999                   instr from (OpReg reg) (OpReg dst)
1000             return (Any to code)
1001
1002         toI8Reg new_rep expr
1003             = do codefn <- getAnyReg expr
1004                  return (Any new_rep codefn)
1005                 -- HACK: use getAnyReg to get a byte-addressable register.
1006                 -- If the source was a Fixed register, this will add the
1007                 -- mov instruction to put it into the desired destination.
1008                 -- We're assuming that the destination won't be a fixed
1009                 -- non-byte-addressable register; it won't be, because all
1010                 -- fixed registers are word-sized.
1011
1012         toI16Reg = toI8Reg -- for now
1013
1014         conversionNop new_rep expr
1015             = do e_code <- getRegister expr
1016                  return (swizzleRegisterRep e_code new_rep)
1017
1018
1019 getRegister e@(CmmMachOp mop [x, y]) -- dyadic MachOps
1020   = ASSERT2(cmmExprRep x /= I8, pprExpr e)
1021     case mop of
1022       MO_Eq F32   -> condFltReg EQQ x y
1023       MO_Ne F32   -> condFltReg NE x y
1024       MO_S_Gt F32 -> condFltReg GTT x y
1025       MO_S_Ge F32 -> condFltReg GE x y
1026       MO_S_Lt F32 -> condFltReg LTT x y
1027       MO_S_Le F32 -> condFltReg LE x y
1028
1029       MO_Eq F64   -> condFltReg EQQ x y
1030       MO_Ne F64   -> condFltReg NE x y
1031       MO_S_Gt F64 -> condFltReg GTT x y
1032       MO_S_Ge F64 -> condFltReg GE x y
1033       MO_S_Lt F64 -> condFltReg LTT x y
1034       MO_S_Le F64 -> condFltReg LE x y
1035
1036       MO_Eq rep   -> condIntReg EQQ x y
1037       MO_Ne rep   -> condIntReg NE x y
1038
1039       MO_S_Gt rep -> condIntReg GTT x y
1040       MO_S_Ge rep -> condIntReg GE x y
1041       MO_S_Lt rep -> condIntReg LTT x y
1042       MO_S_Le rep -> condIntReg LE x y
1043
1044       MO_U_Gt rep -> condIntReg GU  x y
1045       MO_U_Ge rep -> condIntReg GEU x y
1046       MO_U_Lt rep -> condIntReg LU  x y
1047       MO_U_Le rep -> condIntReg LEU x y
1048
1049 #if i386_TARGET_ARCH
1050       MO_Add F32 -> trivialFCode F32 GADD x y
1051       MO_Sub F32 -> trivialFCode F32 GSUB x y
1052
1053       MO_Add F64 -> trivialFCode F64 GADD x y
1054       MO_Sub F64 -> trivialFCode F64 GSUB x y
1055
1056       MO_S_Quot F32 -> trivialFCode F32 GDIV x y
1057       MO_S_Quot F64 -> trivialFCode F64 GDIV x y
1058 #endif
1059
1060 #if x86_64_TARGET_ARCH
1061       MO_Add F32 -> trivialFCode F32 ADD x y
1062       MO_Sub F32 -> trivialFCode F32 SUB x y
1063
1064       MO_Add F64 -> trivialFCode F64 ADD x y
1065       MO_Sub F64 -> trivialFCode F64 SUB x y
1066
1067       MO_S_Quot F32 -> trivialFCode F32 FDIV x y
1068       MO_S_Quot F64 -> trivialFCode F64 FDIV x y
1069 #endif
1070
1071       MO_Add rep -> add_code rep x y
1072       MO_Sub rep -> sub_code rep x y
1073
1074       MO_S_Quot rep -> div_code rep True  True  x y
1075       MO_S_Rem  rep -> div_code rep True  False x y
1076       MO_U_Quot rep -> div_code rep False True  x y
1077       MO_U_Rem  rep -> div_code rep False False x y
1078
1079 #if i386_TARGET_ARCH
1080       MO_Mul   F32 -> trivialFCode F32 GMUL x y
1081       MO_Mul   F64 -> trivialFCode F64 GMUL x y
1082 #endif
1083
1084 #if x86_64_TARGET_ARCH
1085       MO_Mul   F32 -> trivialFCode F32 MUL x y
1086       MO_Mul   F64 -> trivialFCode F64 MUL x y
1087 #endif
1088
1089       MO_Mul   rep -> let op = IMUL rep in
1090                       trivialCode rep op (Just op) x y
1091
1092       MO_S_MulMayOflo rep -> imulMayOflo rep x y
1093
1094       MO_And rep -> let op = AND rep in
1095                     trivialCode rep op (Just op) x y
1096       MO_Or  rep -> let op = OR  rep in
1097                     trivialCode rep op (Just op) x y
1098       MO_Xor rep -> let op = XOR rep in
1099                     trivialCode rep op (Just op) x y
1100
1101         {- Shift ops on x86s have constraints on their source, it
1102            either has to be Imm, CL or 1
1103             => trivialCode is not restrictive enough (sigh.)
1104         -}
1105       MO_Shl rep   -> shift_code rep (SHL rep) x y {-False-}
1106       MO_U_Shr rep -> shift_code rep (SHR rep) x y {-False-}
1107       MO_S_Shr rep -> shift_code rep (SAR rep) x y {-False-}
1108
1109       other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)
1110   where
1111     --------------------
1112     imulMayOflo :: MachRep -> CmmExpr -> CmmExpr -> NatM Register
1113     imulMayOflo rep a b = do
1114          (a_reg, a_code) <- getNonClobberedReg a
1115          b_code <- getAnyReg b
1116          let
1117              shift_amt  = case rep of
1118                            I32 -> 31
1119                            I64 -> 63
1120                            _ -> panic "shift_amt"
1121
1122              code = a_code `appOL` b_code eax `appOL`
1123                         toOL [
1124                            IMUL2 rep (OpReg a_reg),   -- result in %edx:%eax
1125                            SAR rep (OpImm (ImmInt shift_amt)) (OpReg eax),
1126                                 -- sign extend lower part
1127                            SUB rep (OpReg edx) (OpReg eax)
1128                                 -- compare against upper
1129                            -- eax==0 if high part == sign extended low part
1130                         ]
1131          -- in
1132          return (Fixed rep eax code)
1133
1134     --------------------
1135     shift_code :: MachRep
1136                -> (Operand -> Operand -> Instr)
1137                -> CmmExpr
1138                -> CmmExpr
1139                -> NatM Register
1140
1141     {- Case1: shift length as immediate -}
1142     shift_code rep instr x y@(CmmLit lit) = do
1143           x_code <- getAnyReg x
1144           let
1145                code dst
1146                   = x_code dst `snocOL`
1147                     instr (OpImm (litToImm lit)) (OpReg dst)
1148           -- in
1149           return (Any rep code)
1150
1151     {- Case2: shift length is complex (non-immediate) -}
1152     shift_code rep instr x y{-amount-} = do
1153         (x_reg, x_code) <- getNonClobberedReg x
1154         y_code <- getAnyReg y
1155         let
1156            code = x_code `appOL`
1157                   y_code ecx `snocOL`
1158                   instr (OpReg ecx) (OpReg x_reg)
1159         -- in
1160         return (Fixed rep x_reg code)
1161
1162     --------------------
1163     add_code :: MachRep -> CmmExpr -> CmmExpr -> NatM Register
1164     add_code rep x (CmmLit (CmmInt y _))
1165         | not (is64BitInteger y) = add_int rep x y
1166     add_code rep x y = trivialCode rep (ADD rep) (Just (ADD rep)) x y
1167
1168     --------------------
1169     sub_code :: MachRep -> CmmExpr -> CmmExpr -> NatM Register
1170     sub_code rep x (CmmLit (CmmInt y _))
1171         | not (is64BitInteger (-y)) = add_int rep x (-y)
1172     sub_code rep x y = trivialCode rep (SUB rep) Nothing x y
1173
1174     -- our three-operand add instruction:
1175     add_int rep x y = do
1176         (x_reg, x_code) <- getSomeReg x
1177         let
1178             imm = ImmInt (fromInteger y)
1179             code dst
1180                = x_code `snocOL`
1181                  LEA rep
1182                         (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm))
1183                         (OpReg dst)
1184         --
1185         return (Any rep code)
1186
1187     ----------------------
1188     div_code rep signed quotient x y = do
1189            (y_op, y_code) <- getRegOrMem y -- cannot be clobbered
1190            x_code <- getAnyReg x
1191            let
1192              widen | signed    = CLTD rep
1193                    | otherwise = XOR rep (OpReg edx) (OpReg edx)
1194
1195              instr | signed    = IDIV
1196                    | otherwise = DIV
1197
1198              code = y_code `appOL`
1199                     x_code eax `appOL`
1200                     toOL [widen, instr rep y_op]
1201
1202              result | quotient  = eax
1203                     | otherwise = edx
1204
1205            -- in
1206            return (Fixed rep result code)
1207
1208
1209 getRegister (CmmLoad mem pk)
1210   | isFloatingRep pk
1211   = do
1212     Amode src mem_code <- getAmode mem
1213     let
1214         code dst = mem_code `snocOL`
1215                    IF_ARCH_i386(GLD pk src dst,
1216                                 MOV pk (OpAddr src) (OpReg dst))
1217     --
1218     return (Any pk code)
1219
1220 #if i386_TARGET_ARCH
1221 getRegister (CmmLoad mem pk)
1222   | pk /= I64
1223   = do
1224     code <- intLoadCode (instr pk) mem
1225     return (Any pk code)
1226   where
1227         instr I8  = MOVZxL pk
1228         instr I16 = MOV I16
1229         instr I32 = MOV I32
1230         -- we always zero-extend 8-bit loads, if we
1231         -- can't think of anything better.  This is because
1232         -- we can't guarantee access to an 8-bit variant of every register
1233         -- (esi and edi don't have 8-bit variants), so to make things
1234         -- simpler we do our 8-bit arithmetic with full 32-bit registers.
1235 #endif
1236
1237 #if x86_64_TARGET_ARCH
1238 -- Simpler memory load code on x86_64
1239 getRegister (CmmLoad mem pk)
1240   = do
1241     code <- intLoadCode (MOV pk) mem
1242     return (Any pk code)
1243 #endif
1244
1245 getRegister (CmmLit (CmmInt 0 rep))
1246   = let
1247         -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits
1248         adj_rep = case rep of I64 -> I32; _ -> rep
1249         rep1 = IF_ARCH_i386( rep, adj_rep )
1250         code dst
1251            = unitOL (XOR rep1 (OpReg dst) (OpReg dst))
1252     in
1253         return (Any rep code)
1254
1255 #if x86_64_TARGET_ARCH
1256   -- optimisation for loading small literals on x86_64: take advantage
1257   -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit
1258   -- instruction forms are shorter.
1259 getRegister (CmmLit lit)
1260   | I64 <- cmmLitRep lit, not (isBigLit lit)
1261   = let
1262         imm = litToImm lit
1263         code dst = unitOL (MOV I32 (OpImm imm) (OpReg dst))
1264     in
1265         return (Any I64 code)
1266   where
1267    isBigLit (CmmInt i I64) = i < 0 || i > 0xffffffff
1268    isBigLit _ = False
1269         -- note1: not the same as is64BitLit, because that checks for
1270         -- signed literals that fit in 32 bits, but we want unsigned
1271         -- literals here.
1272         -- note2: all labels are small, because we're assuming the
1273         -- small memory model (see gcc docs, -mcmodel=small).
1274 #endif
1275
1276 getRegister (CmmLit lit)
1277   = let
1278         rep = cmmLitRep lit
1279         imm = litToImm lit
1280         code dst = unitOL (MOV rep (OpImm imm) (OpReg dst))
1281     in
1282         return (Any rep code)
1283
1284 getRegister other = pprPanic "getRegister(x86)" (ppr other)
1285
1286
1287 intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr
1288    -> NatM (Reg -> InstrBlock)
1289 intLoadCode instr mem = do
1290   Amode src mem_code <- getAmode mem
1291   return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))
1292
1293 -- Compute an expression into *any* register, adding the appropriate
1294 -- move instruction if necessary.
1295 getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)
1296 getAnyReg expr = do
1297   r <- getRegister expr
1298   anyReg r
1299
1300 anyReg :: Register -> NatM (Reg -> InstrBlock)
1301 anyReg (Any _ code)          = return code
1302 anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)
1303
1304 -- A bit like getSomeReg, but we want a reg that can be byte-addressed.
1305 -- Fixed registers might not be byte-addressable, so we make sure we've
1306 -- got a temporary, inserting an extra reg copy if necessary.
1307 getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)
1308 #if x86_64_TARGET_ARCH
1309 getByteReg = getSomeReg -- all regs are byte-addressable on x86_64
1310 #else
1311 getByteReg expr = do
1312   r <- getRegister expr
1313   case r of
1314     Any rep code -> do
1315         tmp <- getNewRegNat rep
1316         return (tmp, code tmp)
1317     Fixed rep reg code
1318         | isVirtualReg reg -> return (reg,code)
1319         | otherwise -> do
1320             tmp <- getNewRegNat rep
1321             return (tmp, code `snocOL` reg2reg rep reg tmp)
1322         -- ToDo: could optimise slightly by checking for byte-addressable
1323         -- real registers, but that will happen very rarely if at all.
1324 #endif
1325
1326 -- Another variant: this time we want the result in a register that cannot
1327 -- be modified by code to evaluate an arbitrary expression.
1328 getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)
1329 getNonClobberedReg expr = do
1330   r <- getRegister expr
1331   case r of
1332     Any rep code -> do
1333         tmp <- getNewRegNat rep
1334         return (tmp, code tmp)
1335     Fixed rep reg code
1336         -- only free regs can be clobbered
1337         | RealReg rr <- reg, isFastTrue (freeReg rr) -> do
1338                 tmp <- getNewRegNat rep
1339                 return (tmp, code `snocOL` reg2reg rep reg tmp)
1340         | otherwise ->
1341                 return (reg, code)
1342
1343 reg2reg :: MachRep -> Reg -> Reg -> Instr
1344 reg2reg rep src dst
1345 #if i386_TARGET_ARCH
1346   | isFloatingRep rep = GMOV src dst
1347 #endif
1348   | otherwise         = MOV rep (OpReg src) (OpReg dst)
1349
1350 #endif /* i386_TARGET_ARCH || x86_64_TARGET_ARCH */
1351
1352 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1353
1354 #if sparc_TARGET_ARCH
1355
1356 getRegister (CmmLit (CmmFloat f F32)) = do
1357     lbl <- getNewLabelNat
1358     let code dst = toOL [
1359             LDATA ReadOnlyData
1360                         [CmmDataLabel lbl,
1361                          CmmStaticLit (CmmFloat f F32)],
1362             SETHI (HI (ImmCLbl lbl)) dst,
1363             LD F32 (AddrRegImm dst (LO (ImmCLbl lbl))) dst]
1364     return (Any F32 code)
1365
1366 getRegister (CmmLit (CmmFloat d F64)) = do
1367     lbl <- getNewLabelNat
1368     let code dst = toOL [
1369             LDATA ReadOnlyData
1370                         [CmmDataLabel lbl,
1371                          CmmStaticLit (CmmFloat d F64)],
1372             SETHI (HI (ImmCLbl lbl)) dst,
1373             LD F64 (AddrRegImm dst (LO (ImmCLbl lbl))) dst]
1374     return (Any F64 code)
1375
1376 getRegister (CmmMachOp mop [x]) -- unary MachOps
1377   = case mop of
1378       MO_S_Neg F32     -> trivialUFCode F32 (FNEG F32) x
1379       MO_S_Neg F64     -> trivialUFCode F64 (FNEG F64) x
1380
1381       MO_S_Neg rep     -> trivialUCode rep (SUB False False g0) x
1382       MO_Not rep       -> trivialUCode rep (XNOR False g0) x
1383
1384       MO_U_Conv I32 I8 -> trivialCode I8 (AND False) x (CmmLit (CmmInt 255 I8))
1385
1386       MO_U_Conv F64 F32-> coerceDbl2Flt x
1387       MO_U_Conv F32 F64-> coerceFlt2Dbl x
1388
1389       MO_S_Conv F32 I32-> coerceFP2Int F32 I32 x
1390       MO_S_Conv I32 F32-> coerceInt2FP I32 F32 x
1391       MO_S_Conv F64 I32-> coerceFP2Int F64 I32 x
1392       MO_S_Conv I32 F64-> coerceInt2FP I32 F64 x
1393
1394       -- Conversions which are a nop on sparc
1395       MO_U_Conv from to
1396         | from == to   -> conversionNop to   x
1397       MO_U_Conv I32 to -> conversionNop to   x
1398       MO_S_Conv I32 to -> conversionNop to   x
1399
1400       -- widenings
1401       MO_U_Conv I8 I32  -> integerExtend False I8 I32  x
1402       MO_U_Conv I16 I32 -> integerExtend False I16 I32 x
1403       MO_U_Conv I8 I16  -> integerExtend False I8 I16  x
1404       MO_S_Conv I16 I32 -> integerExtend True I16 I32  x
1405
1406       other_op -> panic "Unknown unary mach op"
1407     where
1408         -- XXX SLL/SRL?
1409         integerExtend signed from to expr = do
1410            (reg, e_code) <- getSomeReg expr
1411            let
1412                code dst =
1413                    e_code `snocOL`
1414                    ((if signed then SRA else SRL)
1415                           reg (RIImm (ImmInt 0)) dst)
1416            return (Any to code)
1417         conversionNop new_rep expr
1418             = do e_code <- getRegister expr
1419                  return (swizzleRegisterRep e_code new_rep)
1420
1421 getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps
1422   = case mop of
1423       MO_Eq F32 -> condFltReg EQQ x y
1424       MO_Ne F32 -> condFltReg NE x y
1425
1426       MO_S_Gt F32 -> condFltReg GTT x y
1427       MO_S_Ge F32 -> condFltReg GE x y
1428       MO_S_Lt F32 -> condFltReg LTT x y
1429       MO_S_Le F32 -> condFltReg LE x y
1430
1431       MO_Eq F64 -> condFltReg EQQ x y
1432       MO_Ne F64 -> condFltReg NE x y
1433
1434       MO_S_Gt F64 -> condFltReg GTT x y
1435       MO_S_Ge F64 -> condFltReg GE x y
1436       MO_S_Lt F64 -> condFltReg LTT x y
1437       MO_S_Le F64 -> condFltReg LE x y
1438
1439       MO_Eq rep -> condIntReg EQQ x y
1440       MO_Ne rep -> condIntReg NE x y
1441
1442       MO_S_Gt rep -> condIntReg GTT x y
1443       MO_S_Ge rep -> condIntReg GE x y
1444       MO_S_Lt rep -> condIntReg LTT x y
1445       MO_S_Le rep -> condIntReg LE x y
1446
1447       MO_U_Gt I32  -> condIntReg GTT x y
1448       MO_U_Ge I32  -> condIntReg GE x y
1449       MO_U_Lt I32  -> condIntReg LTT x y
1450       MO_U_Le I32  -> condIntReg LE x y
1451
1452       MO_U_Gt I16 -> condIntReg GU  x y
1453       MO_U_Ge I16 -> condIntReg GEU x y
1454       MO_U_Lt I16 -> condIntReg LU  x y
1455       MO_U_Le I16 -> condIntReg LEU x y
1456
1457       MO_Add I32 -> trivialCode I32 (ADD False False) x y
1458       MO_Sub I32 -> trivialCode I32 (SUB False False) x y
1459
1460       MO_S_MulMayOflo rep -> imulMayOflo rep x y
1461 {-
1462       -- ToDo: teach about V8+ SPARC div instructions
1463       MO_S_Quot I32 -> idiv FSLIT(".div")  x y
1464       MO_S_Rem I32  -> idiv FSLIT(".rem")  x y
1465       MO_U_Quot I32 -> idiv FSLIT(".udiv")  x y
1466       MO_U_Rem I32  -> idiv FSLIT(".urem")  x y
1467 -}
1468       MO_Add F32  -> trivialFCode F32 FADD  x y
1469       MO_Sub F32   -> trivialFCode F32  FSUB x y
1470       MO_Mul F32   -> trivialFCode F32  FMUL  x y
1471       MO_S_Quot F32   -> trivialFCode F32  FDIV x y
1472
1473       MO_Add F64   -> trivialFCode F64 FADD  x y
1474       MO_Sub F64   -> trivialFCode F64  FSUB x y
1475       MO_Mul F64   -> trivialFCode F64  FMUL x y
1476       MO_S_Quot F64   -> trivialFCode F64  FDIV x y
1477
1478       MO_And rep   -> trivialCode rep (AND False) x y
1479       MO_Or rep    -> trivialCode rep (OR  False) x y
1480       MO_Xor rep   -> trivialCode rep (XOR False) x y
1481
1482       MO_Mul rep -> trivialCode rep (SMUL False) x y
1483
1484       MO_Shl rep   -> trivialCode rep SLL  x y
1485       MO_U_Shr rep   -> trivialCode rep SRL x y
1486       MO_S_Shr rep   -> trivialCode rep SRA x y
1487
1488 {-
1489       MO_F32_Pwr  -> getRegister (StCall (Left FSLIT("pow")) CCallConv F64
1490                                          [promote x, promote y])
1491                        where promote x = CmmMachOp MO_F32_to_Dbl [x]
1492       MO_F64_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv F64
1493                                         [x, y])
1494 -}
1495       other -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop)
1496   where
1497     --idiv fn x y = getRegister (StCall (Left fn) CCallConv I32 [x, y])
1498
1499     --------------------
1500     imulMayOflo :: MachRep -> CmmExpr -> CmmExpr -> NatM Register
1501     imulMayOflo rep a b = do
1502          (a_reg, a_code) <- getSomeReg a
1503          (b_reg, b_code) <- getSomeReg b
1504          res_lo <- getNewRegNat I32
1505          res_hi <- getNewRegNat I32
1506          let
1507             shift_amt  = case rep of
1508                           I32 -> 31
1509                           I64 -> 63
1510                           _ -> panic "shift_amt"
1511             code dst = a_code `appOL` b_code `appOL`
1512                        toOL [
1513                            SMUL False a_reg (RIReg b_reg) res_lo,
1514                            RDY res_hi,
1515                            SRA res_lo (RIImm (ImmInt shift_amt)) res_lo,
1516                            SUB False False res_lo (RIReg res_hi) dst
1517                         ]
1518          return (Any I32 code)
1519
1520 getRegister (CmmLoad mem pk) = do
1521     Amode src code <- getAmode mem
1522     let
1523         code__2 dst = code `snocOL` LD pk src dst
1524     return (Any pk code__2)
1525
1526 getRegister (CmmLit (CmmInt i _))
1527   | fits13Bits i
1528   = let
1529         src = ImmInt (fromInteger i)
1530         code dst = unitOL (OR False g0 (RIImm src) dst)
1531     in
1532         return (Any I32 code)
1533
1534 getRegister (CmmLit lit)
1535   = let rep = cmmLitRep lit
1536         imm = litToImm lit
1537         code dst = toOL [
1538             SETHI (HI imm) dst,
1539             OR False dst (RIImm (LO imm)) dst]
1540     in return (Any I32 code)
1541
1542 #endif /* sparc_TARGET_ARCH */
1543
1544 #if powerpc_TARGET_ARCH
1545 getRegister (CmmLoad mem pk)
1546   | pk /= I64
1547   = do
1548         Amode addr addr_code <- getAmode mem
1549         let code dst = ASSERT((regClass dst == RcDouble) == isFloatingRep pk)
1550                        addr_code `snocOL` LD pk dst addr
1551         return (Any pk code)
1552
1553 -- catch simple cases of zero- or sign-extended load
1554 getRegister (CmmMachOp (MO_U_Conv I8 I32) [CmmLoad mem _]) = do
1555     Amode addr addr_code <- getAmode mem
1556     return (Any I32 (\dst -> addr_code `snocOL` LD I8 dst addr))
1557
1558 -- Note: there is no Load Byte Arithmetic instruction, so no signed case here
1559
1560 getRegister (CmmMachOp (MO_U_Conv I16 I32) [CmmLoad mem _]) = do
1561     Amode addr addr_code <- getAmode mem
1562     return (Any I32 (\dst -> addr_code `snocOL` LD I16 dst addr))
1563
1564 getRegister (CmmMachOp (MO_S_Conv I16 I32) [CmmLoad mem _]) = do
1565     Amode addr addr_code <- getAmode mem
1566     return (Any I32 (\dst -> addr_code `snocOL` LA I16 dst addr))
1567
1568 getRegister (CmmMachOp mop [x]) -- unary MachOps
1569   = case mop of
1570       MO_Not rep   -> trivialUCode rep NOT x
1571
1572       MO_S_Conv F64 F32 -> trivialUCode F32 FRSP x
1573       MO_S_Conv F32 F64 -> conversionNop F64 x
1574
1575       MO_S_Conv from to
1576         | from == to         -> conversionNop to x
1577         | isFloatingRep from -> coerceFP2Int from to x
1578         | isFloatingRep to   -> coerceInt2FP from to x
1579
1580         -- narrowing is a nop: we treat the high bits as undefined
1581       MO_S_Conv I32 to -> conversionNop to x
1582       MO_S_Conv I16 I8 -> conversionNop I8 x
1583       MO_S_Conv I8 to -> trivialUCode to (EXTS I8) x
1584       MO_S_Conv I16 to -> trivialUCode to (EXTS I16) x
1585
1586       MO_U_Conv from to
1587         | from == to -> conversionNop to x
1588         -- narrowing is a nop: we treat the high bits as undefined
1589       MO_U_Conv I32 to -> conversionNop to x
1590       MO_U_Conv I16 I8 -> conversionNop I8 x
1591       MO_U_Conv I8 to -> trivialCode to False AND x (CmmLit (CmmInt 255 I32))
1592       MO_U_Conv I16 to -> trivialCode to False AND x (CmmLit (CmmInt 65535 I32))
1593
1594       MO_S_Neg F32      -> trivialUCode F32 FNEG x
1595       MO_S_Neg F64      -> trivialUCode F64 FNEG x
1596       MO_S_Neg rep      -> trivialUCode rep NEG x
1597
1598     where
1599         conversionNop new_rep expr
1600             = do e_code <- getRegister expr
1601                  return (swizzleRegisterRep e_code new_rep)
1602
1603 getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps
1604   = case mop of
1605       MO_Eq F32 -> condFltReg EQQ x y
1606       MO_Ne F32 -> condFltReg NE  x y
1607
1608       MO_S_Gt F32 -> condFltReg GTT x y
1609       MO_S_Ge F32 -> condFltReg GE  x y
1610       MO_S_Lt F32 -> condFltReg LTT x y
1611       MO_S_Le F32 -> condFltReg LE  x y
1612
1613       MO_Eq F64 -> condFltReg EQQ x y
1614       MO_Ne F64 -> condFltReg NE  x y
1615
1616       MO_S_Gt F64 -> condFltReg GTT x y
1617       MO_S_Ge F64 -> condFltReg GE  x y
1618       MO_S_Lt F64 -> condFltReg LTT x y
1619       MO_S_Le F64 -> condFltReg LE  x y
1620
1621       MO_Eq rep -> condIntReg EQQ  (extendUExpr rep x) (extendUExpr rep y)
1622       MO_Ne rep -> condIntReg NE   (extendUExpr rep x) (extendUExpr rep y)
1623
1624       MO_S_Gt rep -> condIntReg GTT  (extendSExpr rep x) (extendSExpr rep y)
1625       MO_S_Ge rep -> condIntReg GE   (extendSExpr rep x) (extendSExpr rep y)
1626       MO_S_Lt rep -> condIntReg LTT  (extendSExpr rep x) (extendSExpr rep y)
1627       MO_S_Le rep -> condIntReg LE   (extendSExpr rep x) (extendSExpr rep y)
1628
1629       MO_U_Gt rep -> condIntReg GU   (extendUExpr rep x) (extendUExpr rep y)
1630       MO_U_Ge rep -> condIntReg GEU  (extendUExpr rep x) (extendUExpr rep y)
1631       MO_U_Lt rep -> condIntReg LU   (extendUExpr rep x) (extendUExpr rep y)
1632       MO_U_Le rep -> condIntReg LEU  (extendUExpr rep x) (extendUExpr rep y)
1633
1634       MO_Add F32   -> trivialCodeNoImm F32 (FADD F32) x y
1635       MO_Sub F32   -> trivialCodeNoImm F32 (FSUB F32) x y
1636       MO_Mul F32   -> trivialCodeNoImm F32 (FMUL F32) x y
1637       MO_S_Quot F32   -> trivialCodeNoImm F32 (FDIV F32) x y
1638
1639       MO_Add F64   -> trivialCodeNoImm F64 (FADD F64) x y
1640       MO_Sub F64   -> trivialCodeNoImm F64 (FSUB F64) x y
1641       MO_Mul F64   -> trivialCodeNoImm F64 (FMUL F64) x y
1642       MO_S_Quot F64   -> trivialCodeNoImm F64 (FDIV F64) x y
1643
1644          -- optimize addition with 32-bit immediate
1645          -- (needed for PIC)
1646       MO_Add I32 ->
1647         case y of
1648           CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate I32 True (-imm)
1649             -> trivialCode I32 True ADD x (CmmLit $ CmmInt imm immrep)
1650           CmmLit lit
1651             -> do
1652                 (src, srcCode) <- getSomeReg x
1653                 let imm = litToImm lit
1654                     code dst = srcCode `appOL` toOL [
1655                                     ADDIS dst src (HA imm),
1656                                     ADD dst dst (RIImm (LO imm))
1657                                 ]
1658                 return (Any I32 code)
1659           _ -> trivialCode I32 True ADD x y
1660
1661       MO_Add rep -> trivialCode rep True ADD x y
1662       MO_Sub rep ->
1663         case y of    -- subfi ('substract from' with immediate) doesn't exist
1664           CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (-imm)
1665             -> trivialCode rep True ADD x (CmmLit $ CmmInt (-imm) immrep)
1666           _ -> trivialCodeNoImm rep SUBF y x
1667
1668       MO_Mul rep -> trivialCode rep True MULLW x y
1669
1670       MO_S_MulMayOflo I32 -> trivialCodeNoImm I32 MULLW_MayOflo x y
1671
1672       MO_S_MulMayOflo rep -> panic "S_MulMayOflo (rep /= I32): not implemented"
1673       MO_U_MulMayOflo rep -> panic "U_MulMayOflo: not implemented"
1674
1675       MO_S_Quot rep -> trivialCodeNoImm rep DIVW (extendSExpr rep x) (extendSExpr rep y)
1676       MO_U_Quot rep -> trivialCodeNoImm rep DIVWU (extendUExpr rep x) (extendUExpr rep y)
1677
1678       MO_S_Rem rep -> remainderCode rep DIVW (extendSExpr rep x) (extendSExpr rep y)
1679       MO_U_Rem rep -> remainderCode rep DIVWU (extendUExpr rep x) (extendUExpr rep y)
1680
1681       MO_And rep   -> trivialCode rep False AND x y
1682       MO_Or rep    -> trivialCode rep False OR x y
1683       MO_Xor rep   -> trivialCode rep False XOR x y
1684
1685       MO_Shl rep   -> trivialCode rep False SLW x y
1686       MO_S_Shr rep -> trivialCode rep False SRAW (extendSExpr rep x) y
1687       MO_U_Shr rep -> trivialCode rep False SRW (extendUExpr rep x) y
1688
1689 getRegister (CmmLit (CmmInt i rep))
1690   | Just imm <- makeImmediate rep True i
1691   = let
1692         code dst = unitOL (LI dst imm)
1693     in
1694         return (Any rep code)
1695
1696 getRegister (CmmLit (CmmFloat f frep)) = do
1697     lbl <- getNewLabelNat
1698     dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl
1699     Amode addr addr_code <- getAmode dynRef
1700     let code dst =
1701             LDATA ReadOnlyData  [CmmDataLabel lbl,
1702                                  CmmStaticLit (CmmFloat f frep)]
1703             `consOL` (addr_code `snocOL` LD frep dst addr)
1704     return (Any frep code)
1705
1706 getRegister (CmmLit lit)
1707   = let rep = cmmLitRep lit
1708         imm = litToImm lit
1709         code dst = toOL [
1710               LIS dst (HI imm),
1711               OR dst dst (RIImm (LO imm))
1712           ]
1713     in return (Any rep code)
1714
1715 getRegister other = pprPanic "getRegister(ppc)" (pprExpr other)
1716
1717     -- extend?Rep: wrap integer expression of type rep
1718     -- in a conversion to I32
1719 extendSExpr I32 x = x
1720 extendSExpr rep x = CmmMachOp (MO_S_Conv rep I32) [x]
1721 extendUExpr I32 x = x
1722 extendUExpr rep x = CmmMachOp (MO_U_Conv rep I32) [x]
1723
1724 #endif /* powerpc_TARGET_ARCH */
1725
1726
1727 -- -----------------------------------------------------------------------------
1728 --  The 'Amode' type: Memory addressing modes passed up the tree.
1729
1730 data Amode = Amode AddrMode InstrBlock
1731
1732 {-
1733 Now, given a tree (the argument to an CmmLoad) that references memory,
1734 produce a suitable addressing mode.
1735
1736 A Rule of the Game (tm) for Amodes: use of the addr bit must
1737 immediately follow use of the code part, since the code part puts
1738 values in registers which the addr then refers to.  So you can't put
1739 anything in between, lest it overwrite some of those registers.  If
1740 you need to do some other computation between the code part and use of
1741 the addr bit, first store the effective address from the amode in a
1742 temporary, then do the other computation, and then use the temporary:
1743
1744     code
1745     LEA amode, tmp
1746     ... other computation ...
1747     ... (tmp) ...
1748 -}
1749
1750 getAmode :: CmmExpr -> NatM Amode
1751 getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree)
1752
1753 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1754
1755 #if alpha_TARGET_ARCH
1756
1757 getAmode (StPrim IntSubOp [x, StInt i])
1758   = getNewRegNat PtrRep         `thenNat` \ tmp ->
1759     getRegister x               `thenNat` \ register ->
1760     let
1761         code = registerCode register tmp
1762         reg  = registerName register tmp
1763         off  = ImmInt (-(fromInteger i))
1764     in
1765     return (Amode (AddrRegImm reg off) code)
1766
1767 getAmode (StPrim IntAddOp [x, StInt i])
1768   = getNewRegNat PtrRep         `thenNat` \ tmp ->
1769     getRegister x               `thenNat` \ register ->
1770     let
1771         code = registerCode register tmp
1772         reg  = registerName register tmp
1773         off  = ImmInt (fromInteger i)
1774     in
1775     return (Amode (AddrRegImm reg off) code)
1776
1777 getAmode leaf
1778   | isJust imm
1779   = return (Amode (AddrImm imm__2) id)
1780   where
1781     imm = maybeImm leaf
1782     imm__2 = case imm of Just x -> x
1783
1784 getAmode other
1785   = getNewRegNat PtrRep         `thenNat` \ tmp ->
1786     getRegister other           `thenNat` \ register ->
1787     let
1788         code = registerCode register tmp
1789         reg  = registerName register tmp
1790     in
1791     return (Amode (AddrReg reg) code)
1792
1793 #endif /* alpha_TARGET_ARCH */
1794
1795 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1796
1797 #if x86_64_TARGET_ARCH
1798
1799 getAmode (CmmMachOp (MO_Add I64) [CmmReg (CmmGlobal PicBaseReg),
1800                                      CmmLit displacement])
1801     = return $ Amode (ripRel (litToImm displacement)) nilOL
1802
1803 #endif
1804
1805 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1806
1807 -- This is all just ridiculous, since it carefully undoes
1808 -- what mangleIndexTree has just done.
1809 getAmode (CmmMachOp (MO_Sub rep) [x, CmmLit lit@(CmmInt i _)])
1810   | not (is64BitLit lit)
1811   -- ASSERT(rep == I32)???
1812   = do (x_reg, x_code) <- getSomeReg x
1813        let off = ImmInt (-(fromInteger i))
1814        return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)
1815
1816 getAmode (CmmMachOp (MO_Add rep) [x, CmmLit lit@(CmmInt i _)])
1817   | not (is64BitLit lit)
1818   -- ASSERT(rep == I32)???
1819   = do (x_reg, x_code) <- getSomeReg x
1820        let off = ImmInt (fromInteger i)
1821        return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)
1822
1823 -- Turn (lit1 << n  + lit2) into  (lit2 + lit1 << n) so it will be
1824 -- recognised by the next rule.
1825 getAmode (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _),
1826                                   b@(CmmLit _)])
1827   = getAmode (CmmMachOp (MO_Add rep) [b,a])
1828
1829 getAmode (CmmMachOp (MO_Add rep) [x, CmmMachOp (MO_Shl _)
1830                                         [y, CmmLit (CmmInt shift _)]])
1831   | shift == 0 || shift == 1 || shift == 2 || shift == 3
1832   = x86_complex_amode x y shift 0
1833
1834 getAmode (CmmMachOp (MO_Add rep)
1835                 [x, CmmMachOp (MO_Add _)
1836                         [CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)],
1837                          CmmLit (CmmInt offset _)]])
1838   | shift == 0 || shift == 1 || shift == 2 || shift == 3
1839   && not (is64BitInteger offset)
1840   = x86_complex_amode x y shift offset
1841
1842 getAmode (CmmMachOp (MO_Add rep) [x,y])
1843   = x86_complex_amode x y 0 0
1844
1845 getAmode (CmmLit lit) | not (is64BitLit lit)
1846   = return (Amode (ImmAddr (litToImm lit) 0) nilOL)
1847
1848 getAmode expr = do
1849   (reg,code) <- getSomeReg expr
1850   return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)
1851
1852
1853 x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode
1854 x86_complex_amode base index shift offset
1855   = do (x_reg, x_code) <- getNonClobberedReg base
1856         -- x must be in a temp, because it has to stay live over y_code
1857         -- we could compre x_reg and y_reg and do something better here...
1858        (y_reg, y_code) <- getSomeReg index
1859        let
1860            code = x_code `appOL` y_code
1861            base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8
1862        return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))
1863                code)
1864
1865 #endif /* i386_TARGET_ARCH || x86_64_TARGET_ARCH */
1866
1867 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1868
1869 #if sparc_TARGET_ARCH
1870
1871 getAmode (CmmMachOp (MO_Sub rep) [x, CmmLit (CmmInt i _)])
1872   | fits13Bits (-i)
1873   = do
1874        (reg, code) <- getSomeReg x
1875        let
1876          off  = ImmInt (-(fromInteger i))
1877        return (Amode (AddrRegImm reg off) code)
1878
1879
1880 getAmode (CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt i _)])
1881   | fits13Bits i
1882   = do
1883        (reg, code) <- getSomeReg x
1884        let
1885          off  = ImmInt (fromInteger i)
1886        return (Amode (AddrRegImm reg off) code)
1887
1888 getAmode (CmmMachOp (MO_Add rep) [x, y])
1889   = do
1890     (regX, codeX) <- getSomeReg x
1891     (regY, codeY) <- getSomeReg y
1892     let
1893         code = codeX `appOL` codeY
1894     return (Amode (AddrRegReg regX regY) code)
1895
1896 -- XXX Is this same as "leaf" in Stix?
1897 getAmode (CmmLit lit)
1898   = do
1899       tmp <- getNewRegNat I32
1900       let
1901         code = unitOL (SETHI (HI imm__2) tmp)
1902       return (Amode (AddrRegImm tmp (LO imm__2)) code)
1903       where
1904          imm__2 = litToImm lit
1905
1906 getAmode other
1907   = do
1908        (reg, code) <- getSomeReg other
1909        let
1910             off  = ImmInt 0
1911        return (Amode (AddrRegImm reg off) code)
1912
1913 #endif /* sparc_TARGET_ARCH */
1914
1915 #ifdef powerpc_TARGET_ARCH
1916 getAmode (CmmMachOp (MO_Sub I32) [x, CmmLit (CmmInt i _)])
1917   | Just off <- makeImmediate I32 True (-i)
1918   = do
1919         (reg, code) <- getSomeReg x
1920         return (Amode (AddrRegImm reg off) code)
1921
1922
1923 getAmode (CmmMachOp (MO_Add I32) [x, CmmLit (CmmInt i _)])
1924   | Just off <- makeImmediate I32 True i
1925   = do
1926         (reg, code) <- getSomeReg x
1927         return (Amode (AddrRegImm reg off) code)
1928
1929    -- optimize addition with 32-bit immediate
1930    -- (needed for PIC)
1931 getAmode (CmmMachOp (MO_Add I32) [x, CmmLit lit])
1932   = do
1933         tmp <- getNewRegNat I32
1934         (src, srcCode) <- getSomeReg x
1935         let imm = litToImm lit
1936             code = srcCode `snocOL` ADDIS tmp src (HA imm)
1937         return (Amode (AddrRegImm tmp (LO imm)) code)
1938
1939 getAmode (CmmLit lit)
1940   = do
1941         tmp <- getNewRegNat I32
1942         let imm = litToImm lit
1943             code = unitOL (LIS tmp (HA imm))
1944         return (Amode (AddrRegImm tmp (LO imm)) code)
1945
1946 getAmode (CmmMachOp (MO_Add I32) [x, y])
1947   = do
1948         (regX, codeX) <- getSomeReg x
1949         (regY, codeY) <- getSomeReg y
1950         return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
1951
1952 getAmode other
1953   = do
1954         (reg, code) <- getSomeReg other
1955         let
1956             off  = ImmInt 0
1957         return (Amode (AddrRegImm reg off) code)
1958 #endif /* powerpc_TARGET_ARCH */
1959
1960 -- -----------------------------------------------------------------------------
1961 -- getOperand: sometimes any operand will do.
1962
1963 -- getNonClobberedOperand: the value of the operand will remain valid across
1964 -- the computation of an arbitrary expression, unless the expression
1965 -- is computed directly into a register which the operand refers to
1966 -- (see trivialCode where this function is used for an example).
1967
1968 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
1969
1970 getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)
1971 #if x86_64_TARGET_ARCH
1972 getNonClobberedOperand (CmmLit lit)
1973   | isSuitableFloatingPointLit lit = do
1974     lbl <- getNewLabelNat
1975     let code = unitOL (LDATA ReadOnlyData  [CmmDataLabel lbl,
1976                                            CmmStaticLit lit])
1977     return (OpAddr (ripRel (ImmCLbl lbl)), code)
1978 #endif
1979 getNonClobberedOperand (CmmLit lit)
1980   | not (is64BitLit lit) && not (isFloatingRep (cmmLitRep lit)) =
1981     return (OpImm (litToImm lit), nilOL)
1982 getNonClobberedOperand (CmmLoad mem pk)
1983   | IF_ARCH_i386(not (isFloatingRep pk) && pk /= I64, True) = do
1984     Amode src mem_code <- getAmode mem
1985     (src',save_code) <-
1986         if (amodeCouldBeClobbered src)
1987                 then do
1988                    tmp <- getNewRegNat wordRep
1989                    return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),
1990                            unitOL (LEA I32 (OpAddr src) (OpReg tmp)))
1991                 else
1992                    return (src, nilOL)
1993     return (OpAddr src', save_code `appOL` mem_code)
1994 getNonClobberedOperand e = do
1995     (reg, code) <- getNonClobberedReg e
1996     return (OpReg reg, code)
1997
1998 amodeCouldBeClobbered :: AddrMode -> Bool
1999 amodeCouldBeClobbered amode = any regClobbered (addrModeRegs amode)
2000
2001 regClobbered (RealReg rr) = isFastTrue (freeReg rr)
2002 regClobbered _ = False
2003
2004 -- getOperand: the operand is not required to remain valid across the
2005 -- computation of an arbitrary expression.
2006 getOperand :: CmmExpr -> NatM (Operand, InstrBlock)
2007 #if x86_64_TARGET_ARCH
2008 getOperand (CmmLit lit)
2009   | isSuitableFloatingPointLit lit = do
2010     lbl <- getNewLabelNat
2011     let code = unitOL (LDATA ReadOnlyData  [CmmDataLabel lbl,
2012                                            CmmStaticLit lit])
2013     return (OpAddr (ripRel (ImmCLbl lbl)), code)
2014 #endif
2015 getOperand (CmmLit lit)
2016   | not (is64BitLit lit) && not (isFloatingRep (cmmLitRep lit)) = do
2017     return (OpImm (litToImm lit), nilOL)
2018 getOperand (CmmLoad mem pk)
2019   | IF_ARCH_i386(not (isFloatingRep pk) && pk /= I64, True) = do
2020     Amode src mem_code <- getAmode mem
2021     return (OpAddr src, mem_code)
2022 getOperand e = do
2023     (reg, code) <- getSomeReg e
2024     return (OpReg reg, code)
2025
2026 isOperand :: CmmExpr -> Bool
2027 isOperand (CmmLoad _ _) = True
2028 isOperand (CmmLit lit)  = not (is64BitLit lit)
2029                           || isSuitableFloatingPointLit lit
2030 isOperand _             = False
2031
2032 -- if we want a floating-point literal as an operand, we can
2033 -- use it directly from memory.  However, if the literal is
2034 -- zero, we're better off generating it into a register using
2035 -- xor.
2036 isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0
2037 isSuitableFloatingPointLit _ = False
2038
2039 getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)
2040 getRegOrMem (CmmLoad mem pk)
2041   | IF_ARCH_i386(not (isFloatingRep pk) && pk /= I64, True) = do
2042     Amode src mem_code <- getAmode mem
2043     return (OpAddr src, mem_code)
2044 getRegOrMem e = do
2045     (reg, code) <- getNonClobberedReg e
2046     return (OpReg reg, code)
2047
2048 #if x86_64_TARGET_ARCH
2049 is64BitLit (CmmInt i I64) = is64BitInteger i
2050    -- assume that labels are in the range 0-2^31-1: this assumes the
2051    -- small memory model (see gcc docs, -mcmodel=small).
2052 #endif
2053 is64BitLit x = False
2054 #endif
2055
2056 is64BitInteger :: Integer -> Bool
2057 is64BitInteger i = i64 > 0x7fffffff || i64 < -0x80000000
2058   where i64 = fromIntegral i :: Int64
2059   -- a CmmInt is intended to be truncated to the appropriate
2060   -- number of bits, so here we truncate it to Int64.  This is
2061   -- important because e.g. -1 as a CmmInt might be either
2062   -- -1 or 18446744073709551615.
2063
2064 -- -----------------------------------------------------------------------------
2065 --  The 'CondCode' type:  Condition codes passed up the tree.
2066
2067 data CondCode = CondCode Bool Cond InstrBlock
2068
2069 -- Set up a condition code for a conditional branch.
2070
2071 getCondCode :: CmmExpr -> NatM CondCode
2072
2073 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2074
2075 #if alpha_TARGET_ARCH
2076 getCondCode = panic "MachCode.getCondCode: not on Alphas"
2077 #endif /* alpha_TARGET_ARCH */
2078
2079 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2080
2081 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
2082 -- yes, they really do seem to want exactly the same!
2083
2084 getCondCode (CmmMachOp mop [x, y])
2085   =
2086     case mop of
2087       MO_Eq F32 -> condFltCode EQQ x y
2088       MO_Ne F32 -> condFltCode NE  x y
2089
2090       MO_S_Gt F32 -> condFltCode GTT x y
2091       MO_S_Ge F32 -> condFltCode GE  x y
2092       MO_S_Lt F32 -> condFltCode LTT x y
2093       MO_S_Le F32 -> condFltCode LE  x y
2094
2095       MO_Eq F64 -> condFltCode EQQ x y
2096       MO_Ne F64 -> condFltCode NE  x y
2097
2098       MO_S_Gt F64 -> condFltCode GTT x y
2099       MO_S_Ge F64 -> condFltCode GE  x y
2100       MO_S_Lt F64 -> condFltCode LTT x y
2101       MO_S_Le F64 -> condFltCode LE  x y
2102
2103       MO_Eq rep -> condIntCode EQQ  x y
2104       MO_Ne rep -> condIntCode NE   x y
2105
2106       MO_S_Gt rep -> condIntCode GTT  x y
2107       MO_S_Ge rep -> condIntCode GE   x y
2108       MO_S_Lt rep -> condIntCode LTT  x y
2109       MO_S_Le rep -> condIntCode LE   x y
2110
2111       MO_U_Gt rep -> condIntCode GU   x y
2112       MO_U_Ge rep -> condIntCode GEU  x y
2113       MO_U_Lt rep -> condIntCode LU   x y
2114       MO_U_Le rep -> condIntCode LEU  x y
2115
2116       other -> pprPanic "getCondCode(x86,x86_64,sparc)" (ppr (CmmMachOp mop [x,y]))
2117
2118 getCondCode other =  pprPanic "getCondCode(2)(x86,sparc)" (ppr other)
2119
2120 #elif powerpc_TARGET_ARCH
2121
2122 -- almost the same as everywhere else - but we need to
2123 -- extend small integers to 32 bit first
2124
2125 getCondCode (CmmMachOp mop [x, y])
2126   = case mop of
2127       MO_Eq F32 -> condFltCode EQQ x y
2128       MO_Ne F32 -> condFltCode NE  x y
2129
2130       MO_S_Gt F32 -> condFltCode GTT x y
2131       MO_S_Ge F32 -> condFltCode GE  x y
2132       MO_S_Lt F32 -> condFltCode LTT x y
2133       MO_S_Le F32 -> condFltCode LE  x y
2134
2135       MO_Eq F64 -> condFltCode EQQ x y
2136       MO_Ne F64 -> condFltCode NE  x y
2137
2138       MO_S_Gt F64 -> condFltCode GTT x y
2139       MO_S_Ge F64 -> condFltCode GE  x y
2140       MO_S_Lt F64 -> condFltCode LTT x y
2141       MO_S_Le F64 -> condFltCode LE  x y
2142
2143       MO_Eq rep -> condIntCode EQQ  (extendUExpr rep x) (extendUExpr rep y)
2144       MO_Ne rep -> condIntCode NE   (extendUExpr rep x) (extendUExpr rep y)
2145
2146       MO_S_Gt rep -> condIntCode GTT  (extendSExpr rep x) (extendSExpr rep y)
2147       MO_S_Ge rep -> condIntCode GE   (extendSExpr rep x) (extendSExpr rep y)
2148       MO_S_Lt rep -> condIntCode LTT  (extendSExpr rep x) (extendSExpr rep y)
2149       MO_S_Le rep -> condIntCode LE   (extendSExpr rep x) (extendSExpr rep y)
2150
2151       MO_U_Gt rep -> condIntCode GU   (extendUExpr rep x) (extendUExpr rep y)
2152       MO_U_Ge rep -> condIntCode GEU  (extendUExpr rep x) (extendUExpr rep y)
2153       MO_U_Lt rep -> condIntCode LU   (extendUExpr rep x) (extendUExpr rep y)
2154       MO_U_Le rep -> condIntCode LEU  (extendUExpr rep x) (extendUExpr rep y)
2155
2156       other -> pprPanic "getCondCode(powerpc)" (pprMachOp mop)
2157
2158 getCondCode other =  panic "getCondCode(2)(powerpc)"
2159
2160
2161 #endif
2162
2163
2164 -- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
2165 -- passed back up the tree.
2166
2167 condIntCode, condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
2168
2169 #if alpha_TARGET_ARCH
2170 condIntCode = panic "MachCode.condIntCode: not on Alphas"
2171 condFltCode = panic "MachCode.condFltCode: not on Alphas"
2172 #endif /* alpha_TARGET_ARCH */
2173
2174 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2175 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
2176
2177 -- memory vs immediate
2178 condIntCode cond (CmmLoad x pk) (CmmLit lit) | not (is64BitLit lit) = do
2179     Amode x_addr x_code <- getAmode x
2180     let
2181         imm  = litToImm lit
2182         code = x_code `snocOL`
2183                   CMP pk (OpImm imm) (OpAddr x_addr)
2184     --
2185     return (CondCode False cond code)
2186
2187 -- anything vs zero
2188 condIntCode cond x (CmmLit (CmmInt 0 pk)) = do
2189     (x_reg, x_code) <- getSomeReg x
2190     let
2191         code = x_code `snocOL`
2192                   TEST pk (OpReg x_reg) (OpReg x_reg)
2193     --
2194     return (CondCode False cond code)
2195
2196 -- anything vs operand
2197 condIntCode cond x y | isOperand y = do
2198     (x_reg, x_code) <- getNonClobberedReg x
2199     (y_op,  y_code) <- getOperand y
2200     let
2201         code = x_code `appOL` y_code `snocOL`
2202                   CMP (cmmExprRep x) y_op (OpReg x_reg)
2203     -- in
2204     return (CondCode False cond code)
2205
2206 -- anything vs anything
2207 condIntCode cond x y = do
2208   (y_reg, y_code) <- getNonClobberedReg y
2209   (x_op, x_code) <- getRegOrMem x
2210   let
2211         code = y_code `appOL`
2212                x_code `snocOL`
2213                   CMP (cmmExprRep x) (OpReg y_reg) x_op
2214   -- in
2215   return (CondCode False cond code)
2216 #endif
2217
2218 #if i386_TARGET_ARCH
2219 condFltCode cond x y
2220   = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) do
2221   (x_reg, x_code) <- getNonClobberedReg x
2222   (y_reg, y_code) <- getSomeReg y
2223   let
2224         code = x_code `appOL` y_code `snocOL`
2225                 GCMP cond x_reg y_reg
2226   -- The GCMP insn does the test and sets the zero flag if comparable
2227   -- and true.  Hence we always supply EQQ as the condition to test.
2228   return (CondCode True EQQ code)
2229 #endif /* i386_TARGET_ARCH */
2230
2231 #if x86_64_TARGET_ARCH
2232 -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be
2233 -- an operand, but the right must be a reg.  We can probably do better
2234 -- than this general case...
2235 condFltCode cond x y = do
2236   (x_reg, x_code) <- getNonClobberedReg x
2237   (y_op, y_code) <- getOperand y
2238   let
2239         code = x_code `appOL`
2240                y_code `snocOL`
2241                   CMP (cmmExprRep x) y_op (OpReg x_reg)
2242         -- NB(1): we need to use the unsigned comparison operators on the
2243         -- result of this comparison.
2244   -- in
2245   return (CondCode True (condToUnsigned cond) code)
2246 #endif
2247
2248 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2249
2250 #if sparc_TARGET_ARCH
2251
2252 condIntCode cond x (CmmLit (CmmInt y rep))
2253   | fits13Bits y
2254   = do
2255        (src1, code) <- getSomeReg x
2256        let
2257            src2 = ImmInt (fromInteger y)
2258            code' = code `snocOL` SUB False True src1 (RIImm src2) g0
2259        return (CondCode False cond code')
2260
2261 condIntCode cond x y = do
2262     (src1, code1) <- getSomeReg x
2263     (src2, code2) <- getSomeReg y
2264     let
2265         code__2 = code1 `appOL` code2 `snocOL`
2266                   SUB False True src1 (RIReg src2) g0
2267     return (CondCode False cond code__2)
2268
2269 -----------
2270 condFltCode cond x y = do
2271     (src1, code1) <- getSomeReg x
2272     (src2, code2) <- getSomeReg y
2273     tmp <- getNewRegNat F64
2274     let
2275         promote x = FxTOy F32 F64 x tmp
2276
2277         pk1   = cmmExprRep x
2278         pk2   = cmmExprRep y
2279
2280         code__2 =
2281                 if pk1 == pk2 then
2282                     code1 `appOL` code2 `snocOL`
2283                     FCMP True pk1 src1 src2
2284                 else if pk1 == F32 then
2285                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
2286                     FCMP True F64 tmp src2
2287                 else
2288                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
2289                     FCMP True F64 src1 tmp
2290     return (CondCode True cond code__2)
2291
2292 #endif /* sparc_TARGET_ARCH */
2293
2294 #if powerpc_TARGET_ARCH
2295 --  ###FIXME: I16 and I8!
2296 condIntCode cond x (CmmLit (CmmInt y rep))
2297   | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y
2298   = do
2299         (src1, code) <- getSomeReg x
2300         let
2301             code' = code `snocOL`
2302                 (if condUnsigned cond then CMPL else CMP) I32 src1 (RIImm src2)
2303         return (CondCode False cond code')
2304
2305 condIntCode cond x y = do
2306     (src1, code1) <- getSomeReg x
2307     (src2, code2) <- getSomeReg y
2308     let
2309         code' = code1 `appOL` code2 `snocOL`
2310                   (if condUnsigned cond then CMPL else CMP) I32 src1 (RIReg src2)
2311     return (CondCode False cond code')
2312
2313 condFltCode cond x y = do
2314     (src1, code1) <- getSomeReg x
2315     (src2, code2) <- getSomeReg y
2316     let
2317         code'  = code1 `appOL` code2 `snocOL` FCMP src1 src2
2318         code'' = case cond of -- twiddle CR to handle unordered case
2319                     GE -> code' `snocOL` CRNOR ltbit eqbit gtbit
2320                     LE -> code' `snocOL` CRNOR gtbit eqbit ltbit
2321                     _ -> code'
2322                  where
2323                     ltbit = 0 ; eqbit = 2 ; gtbit = 1
2324     return (CondCode True cond code'')
2325
2326 #endif /* powerpc_TARGET_ARCH */
2327
2328 -- -----------------------------------------------------------------------------
2329 -- Generating assignments
2330
2331 -- Assignments are really at the heart of the whole code generation
2332 -- business.  Almost all top-level nodes of any real importance are
2333 -- assignments, which correspond to loads, stores, or register
2334 -- transfers.  If we're really lucky, some of the register transfers
2335 -- will go away, because we can use the destination register to
2336 -- complete the code generation for the right hand side.  This only
2337 -- fails when the right hand side is forced into a fixed register
2338 -- (e.g. the result of a call).
2339
2340 assignMem_IntCode :: MachRep -> CmmExpr -> CmmExpr -> NatM InstrBlock
2341 assignReg_IntCode :: MachRep -> CmmReg  -> CmmExpr -> NatM InstrBlock
2342
2343 assignMem_FltCode :: MachRep -> CmmExpr -> CmmExpr -> NatM InstrBlock
2344 assignReg_FltCode :: MachRep -> CmmReg  -> CmmExpr -> NatM InstrBlock
2345
2346 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2347
2348 #if alpha_TARGET_ARCH
2349
2350 assignIntCode pk (CmmLoad dst _) src
2351   = getNewRegNat IntRep             `thenNat` \ tmp ->
2352     getAmode dst                    `thenNat` \ amode ->
2353     getRegister src                 `thenNat` \ register ->
2354     let
2355         code1   = amodeCode amode []
2356         dst__2  = amodeAddr amode
2357         code2   = registerCode register tmp []
2358         src__2  = registerName register tmp
2359         sz      = primRepToSize pk
2360         code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2361     in
2362     return code__2
2363
2364 assignIntCode pk dst src
2365   = getRegister dst                         `thenNat` \ register1 ->
2366     getRegister src                         `thenNat` \ register2 ->
2367     let
2368         dst__2  = registerName register1 zeroh
2369         code    = registerCode register2 dst__2
2370         src__2  = registerName register2 dst__2
2371         code__2 = if isFixed register2
2372                   then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2373                   else code
2374     in
2375     return code__2
2376
2377 #endif /* alpha_TARGET_ARCH */
2378
2379 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2380
2381 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
2382
2383 -- integer assignment to memory
2384
2385 -- specific case of adding/subtracting an integer to a particular address.
2386 -- ToDo: catch other cases where we can use an operation directly on a memory
2387 -- address.
2388 assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _,
2389                                                  CmmLit (CmmInt i _)])
2390    | addr == addr2, pk /= I64 || not (is64BitInteger i),
2391      Just instr <- check op
2392    = do Amode amode code_addr <- getAmode addr
2393         let code = code_addr `snocOL`
2394                    instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)
2395         return code
2396    where
2397         check (MO_Add _) = Just ADD
2398         check (MO_Sub _) = Just SUB
2399         check _ = Nothing
2400         -- ToDo: more?
2401
2402 -- general case
2403 assignMem_IntCode pk addr src = do
2404     Amode addr code_addr <- getAmode addr
2405     (code_src, op_src)   <- get_op_RI src
2406     let
2407         code = code_src `appOL`
2408                code_addr `snocOL`
2409                   MOV pk op_src (OpAddr addr)
2410         -- NOTE: op_src is stable, so it will still be valid
2411         -- after code_addr.  This may involve the introduction
2412         -- of an extra MOV to a temporary register, but we hope
2413         -- the register allocator will get rid of it.
2414     --
2415     return code
2416   where
2417     get_op_RI :: CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator
2418     get_op_RI (CmmLit lit) | not (is64BitLit lit)
2419       = return (nilOL, OpImm (litToImm lit))
2420     get_op_RI op
2421       = do (reg,code) <- getNonClobberedReg op
2422            return (code, OpReg reg)
2423
2424
2425 -- Assign; dst is a reg, rhs is mem
2426 assignReg_IntCode pk reg (CmmLoad src _) = do
2427   load_code <- intLoadCode (MOV pk) src
2428   return (load_code (getRegisterReg reg))
2429
2430 -- dst is a reg, but src could be anything
2431 assignReg_IntCode pk reg src = do
2432   code <- getAnyReg src
2433   return (code (getRegisterReg reg))
2434
2435 #endif /* i386_TARGET_ARCH */
2436
2437 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2438
2439 #if sparc_TARGET_ARCH
2440
2441 assignMem_IntCode pk addr src = do
2442     (srcReg, code) <- getSomeReg src
2443     Amode dstAddr addr_code <- getAmode addr
2444     return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
2445
2446 assignReg_IntCode pk reg src = do
2447     r <- getRegister src
2448     return $ case r of
2449         Any _ code         -> code dst
2450         Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg dst) freg
2451     where
2452       dst = getRegisterReg reg
2453
2454
2455 #endif /* sparc_TARGET_ARCH */
2456
2457 #if powerpc_TARGET_ARCH
2458
2459 assignMem_IntCode pk addr src = do
2460     (srcReg, code) <- getSomeReg src
2461     Amode dstAddr addr_code <- getAmode addr
2462     return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
2463
2464 -- dst is a reg, but src could be anything
2465 assignReg_IntCode pk reg src
2466     = do
2467         r <- getRegister src
2468         return $ case r of
2469             Any _ code         -> code dst
2470             Fixed _ freg fcode -> fcode `snocOL` MR dst freg
2471     where
2472         dst = getRegisterReg reg
2473
2474 #endif /* powerpc_TARGET_ARCH */
2475
2476
2477 -- -----------------------------------------------------------------------------
2478 -- Floating-point assignments
2479
2480 #if alpha_TARGET_ARCH
2481
2482 assignFltCode pk (CmmLoad dst _) src
2483   = getNewRegNat pk                 `thenNat` \ tmp ->
2484     getAmode dst                    `thenNat` \ amode ->
2485     getRegister src                         `thenNat` \ register ->
2486     let
2487         code1   = amodeCode amode []
2488         dst__2  = amodeAddr amode
2489         code2   = registerCode register tmp []
2490         src__2  = registerName register tmp
2491         sz      = primRepToSize pk
2492         code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2493     in
2494     return code__2
2495
2496 assignFltCode pk dst src
2497   = getRegister dst                         `thenNat` \ register1 ->
2498     getRegister src                         `thenNat` \ register2 ->
2499     let
2500         dst__2  = registerName register1 zeroh
2501         code    = registerCode register2 dst__2
2502         src__2  = registerName register2 dst__2
2503         code__2 = if isFixed register2
2504                   then code . mkSeqInstr (FMOV src__2 dst__2)
2505                   else code
2506     in
2507     return code__2
2508
2509 #endif /* alpha_TARGET_ARCH */
2510
2511 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2512
2513 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
2514
2515 -- Floating point assignment to memory
2516 assignMem_FltCode pk addr src = do
2517   (src_reg, src_code) <- getNonClobberedReg src
2518   Amode addr addr_code <- getAmode addr
2519   let
2520         code = src_code `appOL`
2521                addr_code `snocOL`
2522                 IF_ARCH_i386(GST pk src_reg addr,
2523                              MOV pk (OpReg src_reg) (OpAddr addr))
2524   return code
2525
2526 -- Floating point assignment to a register/temporary
2527 assignReg_FltCode pk reg src = do
2528   src_code <- getAnyReg src
2529   return (src_code (getRegisterReg reg))
2530
2531 #endif /* i386_TARGET_ARCH */
2532
2533 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2534
2535 #if sparc_TARGET_ARCH
2536
2537 -- Floating point assignment to memory
2538 assignMem_FltCode pk addr src = do
2539     Amode dst__2 code1 <- getAmode addr
2540     (src__2, code2) <- getSomeReg src
2541     tmp1 <- getNewRegNat pk
2542     let
2543         pk__2   = cmmExprRep src
2544         code__2 = code1 `appOL` code2 `appOL`
2545             if   pk == pk__2
2546             then unitOL (ST pk src__2 dst__2)
2547             else toOL [FxTOy pk__2 pk src__2 tmp1, ST pk tmp1 dst__2]
2548     return code__2
2549
2550 -- Floating point assignment to a register/temporary
2551 -- ToDo: Verify correctness
2552 assignReg_FltCode pk reg src = do
2553     r <- getRegister src
2554     v1 <- getNewRegNat pk
2555     return $ case r of
2556         Any _ code         -> code dst
2557         Fixed _ freg fcode -> fcode `snocOL` FMOV pk freg v1
2558     where
2559       dst = getRegisterReg reg
2560
2561 #endif /* sparc_TARGET_ARCH */
2562
2563 #if powerpc_TARGET_ARCH
2564
2565 -- Easy, isn't it?
2566 assignMem_FltCode = assignMem_IntCode
2567 assignReg_FltCode = assignReg_IntCode
2568
2569 #endif /* powerpc_TARGET_ARCH */
2570
2571
2572 -- -----------------------------------------------------------------------------
2573 -- Generating an non-local jump
2574
2575 -- (If applicable) Do not fill the delay slots here; you will confuse the
2576 -- register allocator.
2577
2578 genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
2579
2580 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2581
2582 #if alpha_TARGET_ARCH
2583
2584 genJump (CmmLabel lbl)
2585   | isAsmTemp lbl = returnInstr (BR target)
2586   | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2587   where
2588     target = ImmCLbl lbl
2589
2590 genJump tree
2591   = getRegister tree                `thenNat` \ register ->
2592     getNewRegNat PtrRep             `thenNat` \ tmp ->
2593     let
2594         dst    = registerName register pv
2595         code   = registerCode register pv
2596         target = registerName register pv
2597     in
2598     if isFixed register then
2599         returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2600     else
2601     return (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2602
2603 #endif /* alpha_TARGET_ARCH */
2604
2605 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2606
2607 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
2608
2609 genJump (CmmLoad mem pk) = do
2610   Amode target code <- getAmode mem
2611   return (code `snocOL` JMP (OpAddr target))
2612
2613 genJump (CmmLit lit) = do
2614   return (unitOL (JMP (OpImm (litToImm lit))))
2615
2616 genJump expr = do
2617   (reg,code) <- getSomeReg expr
2618   return (code `snocOL` JMP (OpReg reg))
2619
2620 #endif /* i386_TARGET_ARCH */
2621
2622 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2623
2624 #if sparc_TARGET_ARCH
2625
2626 genJump (CmmLit (CmmLabel lbl))
2627   = return (toOL [CALL (Left target) 0 True, NOP])
2628   where
2629     target = ImmCLbl lbl
2630
2631 genJump tree
2632   = do
2633         (target, code) <- getSomeReg tree
2634         return (code `snocOL` JMP (AddrRegReg target g0)  `snocOL` NOP)
2635
2636 #endif /* sparc_TARGET_ARCH */
2637
2638 #if powerpc_TARGET_ARCH
2639 genJump (CmmLit (CmmLabel lbl))
2640   = return (unitOL $ JMP lbl)
2641
2642 genJump tree
2643   = do
2644         (target,code) <- getSomeReg tree
2645         return (code `snocOL` MTCTR target `snocOL` BCTR [])
2646 #endif /* powerpc_TARGET_ARCH */
2647
2648
2649 -- -----------------------------------------------------------------------------
2650 --  Unconditional branches
2651
2652 genBranch :: BlockId -> NatM InstrBlock
2653
2654 genBranch = return . toOL . mkBranchInstr
2655
2656 -- -----------------------------------------------------------------------------
2657 --  Conditional jumps
2658
2659 {-
2660 Conditional jumps are always to local labels, so we can use branch
2661 instructions.  We peek at the arguments to decide what kind of
2662 comparison to do.
2663
2664 ALPHA: For comparisons with 0, we're laughing, because we can just do
2665 the desired conditional branch.
2666
2667 I386: First, we have to ensure that the condition
2668 codes are set according to the supplied comparison operation.
2669
2670 SPARC: First, we have to ensure that the condition codes are set
2671 according to the supplied comparison operation.  We generate slightly
2672 different code for floating point comparisons, because a floating
2673 point operation cannot directly precede a @BF@.  We assume the worst
2674 and fill that slot with a @NOP@.
2675
2676 SPARC: Do not fill the delay slots here; you will confuse the register
2677 allocator.
2678 -}
2679
2680
2681 genCondJump
2682     :: BlockId      -- the branch target
2683     -> CmmExpr      -- the condition on which to branch
2684     -> NatM InstrBlock
2685
2686 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2687
2688 #if alpha_TARGET_ARCH
2689
2690 genCondJump id (StPrim op [x, StInt 0])
2691   = getRegister x                           `thenNat` \ register ->
2692     getNewRegNat (registerRep register)
2693                                     `thenNat` \ tmp ->
2694     let
2695         code   = registerCode register tmp
2696         value  = registerName register tmp
2697         pk     = registerRep register
2698         target = ImmCLbl lbl
2699     in
2700     returnSeq code [BI (cmpOp op) value target]
2701   where
2702     cmpOp CharGtOp = GTT
2703     cmpOp CharGeOp = GE
2704     cmpOp CharEqOp = EQQ
2705     cmpOp CharNeOp = NE
2706     cmpOp CharLtOp = LTT
2707     cmpOp CharLeOp = LE
2708     cmpOp IntGtOp = GTT
2709     cmpOp IntGeOp = GE
2710     cmpOp IntEqOp = EQQ
2711     cmpOp IntNeOp = NE
2712     cmpOp IntLtOp = LTT
2713     cmpOp IntLeOp = LE
2714     cmpOp WordGtOp = NE
2715     cmpOp WordGeOp = ALWAYS
2716     cmpOp WordEqOp = EQQ
2717     cmpOp WordNeOp = NE
2718     cmpOp WordLtOp = NEVER
2719     cmpOp WordLeOp = EQQ
2720     cmpOp AddrGtOp = NE
2721     cmpOp AddrGeOp = ALWAYS
2722     cmpOp AddrEqOp = EQQ
2723     cmpOp AddrNeOp = NE
2724     cmpOp AddrLtOp = NEVER
2725     cmpOp AddrLeOp = EQQ
2726
2727 genCondJump lbl (StPrim op [x, StDouble 0.0])
2728   = getRegister x                           `thenNat` \ register ->
2729     getNewRegNat (registerRep register)
2730                                     `thenNat` \ tmp ->
2731     let
2732         code   = registerCode register tmp
2733         value  = registerName register tmp
2734         pk     = registerRep register
2735         target = ImmCLbl lbl
2736     in
2737     return (code . mkSeqInstr (BF (cmpOp op) value target))
2738   where
2739     cmpOp FloatGtOp = GTT
2740     cmpOp FloatGeOp = GE
2741     cmpOp FloatEqOp = EQQ
2742     cmpOp FloatNeOp = NE
2743     cmpOp FloatLtOp = LTT
2744     cmpOp FloatLeOp = LE
2745     cmpOp DoubleGtOp = GTT
2746     cmpOp DoubleGeOp = GE
2747     cmpOp DoubleEqOp = EQQ
2748     cmpOp DoubleNeOp = NE
2749     cmpOp DoubleLtOp = LTT
2750     cmpOp DoubleLeOp = LE
2751
2752 genCondJump lbl (StPrim op [x, y])
2753   | fltCmpOp op
2754   = trivialFCode pr instr x y       `thenNat` \ register ->
2755     getNewRegNat F64                `thenNat` \ tmp ->
2756     let
2757         code   = registerCode register tmp
2758         result = registerName register tmp
2759         target = ImmCLbl lbl
2760     in
2761     return (code . mkSeqInstr (BF cond result target))
2762   where
2763     pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2764
2765     fltCmpOp op = case op of
2766         FloatGtOp -> True
2767         FloatGeOp -> True
2768         FloatEqOp -> True
2769         FloatNeOp -> True
2770         FloatLtOp -> True
2771         FloatLeOp -> True
2772         DoubleGtOp -> True
2773         DoubleGeOp -> True
2774         DoubleEqOp -> True
2775         DoubleNeOp -> True
2776         DoubleLtOp -> True
2777         DoubleLeOp -> True
2778         _ -> False
2779     (instr, cond) = case op of
2780         FloatGtOp -> (FCMP TF LE, EQQ)
2781         FloatGeOp -> (FCMP TF LTT, EQQ)
2782         FloatEqOp -> (FCMP TF EQQ, NE)
2783         FloatNeOp -> (FCMP TF EQQ, EQQ)
2784         FloatLtOp -> (FCMP TF LTT, NE)
2785         FloatLeOp -> (FCMP TF LE, NE)
2786         DoubleGtOp -> (FCMP TF LE, EQQ)
2787         DoubleGeOp -> (FCMP TF LTT, EQQ)
2788         DoubleEqOp -> (FCMP TF EQQ, NE)
2789         DoubleNeOp -> (FCMP TF EQQ, EQQ)
2790         DoubleLtOp -> (FCMP TF LTT, NE)
2791         DoubleLeOp -> (FCMP TF LE, NE)
2792
2793 genCondJump lbl (StPrim op [x, y])
2794   = trivialCode instr x y           `thenNat` \ register ->
2795     getNewRegNat IntRep             `thenNat` \ tmp ->
2796     let
2797         code   = registerCode register tmp
2798         result = registerName register tmp
2799         target = ImmCLbl lbl
2800     in
2801     return (code . mkSeqInstr (BI cond result target))
2802   where
2803     (instr, cond) = case op of
2804         CharGtOp -> (CMP LE, EQQ)
2805         CharGeOp -> (CMP LTT, EQQ)
2806         CharEqOp -> (CMP EQQ, NE)
2807         CharNeOp -> (CMP EQQ, EQQ)
2808         CharLtOp -> (CMP LTT, NE)
2809         CharLeOp -> (CMP LE, NE)
2810         IntGtOp -> (CMP LE, EQQ)
2811         IntGeOp -> (CMP LTT, EQQ)
2812         IntEqOp -> (CMP EQQ, NE)
2813         IntNeOp -> (CMP EQQ, EQQ)
2814         IntLtOp -> (CMP LTT, NE)
2815         IntLeOp -> (CMP LE, NE)
2816         WordGtOp -> (CMP ULE, EQQ)
2817         WordGeOp -> (CMP ULT, EQQ)
2818         WordEqOp -> (CMP EQQ, NE)
2819         WordNeOp -> (CMP EQQ, EQQ)
2820         WordLtOp -> (CMP ULT, NE)
2821         WordLeOp -> (CMP ULE, NE)
2822         AddrGtOp -> (CMP ULE, EQQ)
2823         AddrGeOp -> (CMP ULT, EQQ)
2824         AddrEqOp -> (CMP EQQ, NE)
2825         AddrNeOp -> (CMP EQQ, EQQ)
2826         AddrLtOp -> (CMP ULT, NE)
2827         AddrLeOp -> (CMP ULE, NE)
2828
2829 #endif /* alpha_TARGET_ARCH */
2830
2831 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2832
2833 #if i386_TARGET_ARCH
2834
2835 genCondJump id bool = do
2836   CondCode _ cond code <- getCondCode bool
2837   return (code `snocOL` JXX cond id)
2838
2839 #endif
2840
2841 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2842
2843 #if x86_64_TARGET_ARCH
2844
2845 genCondJump id bool = do
2846   CondCode is_float cond cond_code <- getCondCode bool
2847   if not is_float
2848     then
2849         return (cond_code `snocOL` JXX cond id)
2850     else do
2851         lbl <- getBlockIdNat
2852
2853         -- see comment with condFltReg
2854         let code = case cond of
2855                         NE  -> or_unordered
2856                         GU  -> plain_test
2857                         GEU -> plain_test
2858                         _   -> and_ordered
2859
2860             plain_test = unitOL (
2861                   JXX cond id
2862                 )
2863             or_unordered = toOL [
2864                   JXX cond id,
2865                   JXX PARITY id
2866                 ]
2867             and_ordered = toOL [
2868                   JXX PARITY lbl,
2869                   JXX cond id,
2870                   JXX ALWAYS lbl,
2871                   NEWBLOCK lbl
2872                 ]
2873         return (cond_code `appOL` code)
2874
2875 #endif
2876
2877 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2878
2879 #if sparc_TARGET_ARCH
2880
2881 genCondJump (BlockId id) bool = do
2882   CondCode is_float cond code <- getCondCode bool
2883   return (
2884        code `appOL`
2885        toOL (
2886          if   is_float
2887          then [NOP, BF cond False (ImmCLbl (mkAsmTempLabel id)), NOP]
2888          else [BI cond False (ImmCLbl (mkAsmTempLabel id)), NOP]
2889        )
2890     )
2891
2892 #endif /* sparc_TARGET_ARCH */
2893
2894
2895 #if powerpc_TARGET_ARCH
2896
2897 genCondJump id bool = do
2898   CondCode is_float cond code <- getCondCode bool
2899   return (code `snocOL` BCC cond id)
2900
2901 #endif /* powerpc_TARGET_ARCH */
2902
2903
2904 -- -----------------------------------------------------------------------------
2905 --  Generating C calls
2906
2907 -- Now the biggest nightmare---calls.  Most of the nastiness is buried in
2908 -- @get_arg@, which moves the arguments to the correct registers/stack
2909 -- locations.  Apart from that, the code is easy.
2910 --
2911 -- (If applicable) Do not fill the delay slots here; you will confuse the
2912 -- register allocator.
2913
2914 genCCall
2915     :: CmmCallTarget            -- function to call
2916     -> [(CmmReg,MachHint)]      -- where to put the result
2917     -> [(CmmExpr,MachHint)]     -- arguments (of mixed type)
2918     -> Maybe [GlobalReg]        -- volatile regs to save
2919     -> NatM InstrBlock
2920
2921 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2922
2923 #if alpha_TARGET_ARCH
2924
2925 ccallResultRegs =
2926
2927 genCCall fn cconv result_regs args
2928   = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2929                           `thenNat` \ ((unused,_), argCode) ->
2930     let
2931         nRegs = length allArgRegs - length unused
2932         code = asmSeqThen (map ($ []) argCode)
2933     in
2934         returnSeq code [
2935             LDA pv (AddrImm (ImmLab (ptext fn))),
2936             JSR ra (AddrReg pv) nRegs,
2937             LDGP gp (AddrReg ra)]
2938   where
2939     ------------------------
2940     {-  Try to get a value into a specific register (or registers) for
2941         a call.  The first 6 arguments go into the appropriate
2942         argument register (separate registers for integer and floating
2943         point arguments, but used in lock-step), and the remaining
2944         arguments are dumped to the stack, beginning at 0(sp).  Our
2945         first argument is a pair of the list of remaining argument
2946         registers to be assigned for this call and the next stack
2947         offset to use for overflowing arguments.  This way,
2948         @get_Arg@ can be applied to all of a call's arguments using
2949         @mapAccumLNat@.
2950     -}
2951     get_arg
2952         :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
2953         -> StixTree             -- Current argument
2954         -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2955
2956     -- We have to use up all of our argument registers first...
2957
2958     get_arg ((iDst,fDst):dsts, offset) arg
2959       = getRegister arg                     `thenNat` \ register ->
2960         let
2961             reg  = if isFloatingRep pk then fDst else iDst
2962             code = registerCode register reg
2963             src  = registerName register reg
2964             pk   = registerRep register
2965         in
2966         return (
2967             if isFloatingRep pk then
2968                 ((dsts, offset), if isFixed register then
2969                     code . mkSeqInstr (FMOV src fDst)
2970                     else code)
2971             else
2972                 ((dsts, offset), if isFixed register then
2973                     code . mkSeqInstr (OR src (RIReg src) iDst)
2974                     else code))
2975
2976     -- Once we have run out of argument registers, we move to the
2977     -- stack...
2978
2979     get_arg ([], offset) arg
2980       = getRegister arg                 `thenNat` \ register ->
2981         getNewRegNat (registerRep register)
2982                                         `thenNat` \ tmp ->
2983         let
2984             code = registerCode register tmp
2985             src  = registerName register tmp
2986             pk   = registerRep register
2987             sz   = primRepToSize pk
2988         in
2989         return (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2990
2991 #endif /* alpha_TARGET_ARCH */
2992
2993 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2994
2995 #if i386_TARGET_ARCH
2996
2997 genCCall (CmmPrim MO_WriteBarrier) _ _ _ = return nilOL
2998         -- write barrier compiles to no code on x86/x86-64;
2999         -- we keep it this long in order to prevent earlier optimisations.
3000
3001 -- we only cope with a single result for foreign calls
3002 genCCall (CmmPrim op) [(r,_)] args vols = do
3003   case op of
3004         MO_F32_Sqrt -> actuallyInlineFloatOp F32  (GSQRT F32) args
3005         MO_F64_Sqrt -> actuallyInlineFloatOp F64 (GSQRT F64) args
3006
3007         MO_F32_Sin  -> actuallyInlineFloatOp F32  (GSIN F32) args
3008         MO_F64_Sin  -> actuallyInlineFloatOp F64 (GSIN F64) args
3009
3010         MO_F32_Cos  -> actuallyInlineFloatOp F32  (GCOS F32) args
3011         MO_F64_Cos  -> actuallyInlineFloatOp F64 (GCOS F64) args
3012
3013         MO_F32_Tan  -> actuallyInlineFloatOp F32  (GTAN F32) args
3014         MO_F64_Tan  -> actuallyInlineFloatOp F64 (GTAN F64) args
3015
3016         other_op    -> outOfLineFloatOp op r args vols
3017  where
3018   actuallyInlineFloatOp rep instr [(x,_)]
3019         = do res <- trivialUFCode rep instr x
3020              any <- anyReg res
3021              return (any (getRegisterReg r))
3022
3023 genCCall target dest_regs args vols = do
3024     let
3025         sizes               = map (arg_size . cmmExprRep . fst) (reverse args)
3026 #if !darwin_TARGET_OS
3027         tot_arg_size        = sum sizes
3028 #else
3029         raw_arg_size        = sum sizes
3030         tot_arg_size        = roundTo 16 raw_arg_size
3031         arg_pad_size        = tot_arg_size - raw_arg_size
3032     delta0 <- getDeltaNat
3033     setDeltaNat (delta0 - arg_pad_size)
3034 #endif
3035
3036     push_codes <- mapM push_arg (reverse args)
3037     delta <- getDeltaNat
3038
3039     -- in
3040     -- deal with static vs dynamic call targets
3041     (callinsns,cconv) <-
3042       case target of
3043         -- CmmPrim -> ...
3044         CmmForeignCall (CmmLit (CmmLabel lbl)) conv
3045            -> -- ToDo: stdcall arg sizes
3046               return (unitOL (CALL (Left fn_imm) []), conv)
3047            where fn_imm = ImmCLbl lbl
3048         CmmForeignCall expr conv
3049            -> do (dyn_c, dyn_r, dyn_rep) <- get_op expr
3050                  ASSERT(dyn_rep == I32)
3051                   return (dyn_c `snocOL` CALL (Right dyn_r) [], conv)
3052
3053     let push_code
3054 #if darwin_TARGET_OS
3055             | arg_pad_size /= 0
3056             = toOL [SUB I32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),
3057                     DELTA (delta0 - arg_pad_size)]
3058               `appOL` concatOL push_codes
3059             | otherwise
3060 #endif
3061             = concatOL push_codes
3062         call = callinsns `appOL`
3063                toOL (
3064                         -- Deallocate parameters after call for ccall;
3065                         -- but not for stdcall (callee does it)
3066                   (if cconv == StdCallConv || tot_arg_size==0 then [] else
3067                    [ADD I32 (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
3068                   ++
3069                   [DELTA (delta + tot_arg_size)]
3070                )
3071     -- in
3072     setDeltaNat (delta + tot_arg_size)
3073
3074     let
3075         -- assign the results, if necessary
3076         assign_code []     = nilOL
3077         assign_code [(dest,_hint)] =
3078           case rep of
3079                 I64 -> toOL [MOV I32 (OpReg eax) (OpReg r_dest),
3080                              MOV I32 (OpReg edx) (OpReg r_dest_hi)]
3081                 F32 -> unitOL (GMOV fake0 r_dest)
3082                 F64 -> unitOL (GMOV fake0 r_dest)
3083                 rep -> unitOL (MOV rep (OpReg eax) (OpReg r_dest))
3084           where
3085                 r_dest_hi = getHiVRegFromLo r_dest
3086                 rep = cmmRegRep dest
3087                 r_dest = getRegisterReg dest
3088         assign_code many = panic "genCCall.assign_code many"
3089
3090     return (push_code `appOL`
3091             call `appOL`
3092             assign_code dest_regs)
3093
3094   where
3095     arg_size F64 = 8
3096     arg_size F32 = 4
3097     arg_size I64 = 8
3098     arg_size _   = 4
3099
3100     roundTo a x | x `mod` a == 0 = x
3101                 | otherwise = x + a - (x `mod` a)
3102
3103
3104     push_arg :: (CmmExpr,MachHint){-current argument-}
3105                     -> NatM InstrBlock  -- code
3106
3107     push_arg (arg,_hint) -- we don't need the hints on x86
3108       | arg_rep == I64 = do
3109         ChildCode64 code r_lo <- iselExpr64 arg
3110         delta <- getDeltaNat
3111         setDeltaNat (delta - 8)
3112         let
3113             r_hi = getHiVRegFromLo r_lo
3114         -- in
3115         return (       code `appOL`
3116                        toOL [PUSH I32 (OpReg r_hi), DELTA (delta - 4),
3117                              PUSH I32 (OpReg r_lo), DELTA (delta - 8),
3118                              DELTA (delta-8)]
3119             )
3120
3121       | otherwise = do
3122         (code, reg, sz) <- get_op arg
3123         delta <- getDeltaNat
3124         let size = arg_size sz
3125         setDeltaNat (delta-size)
3126         if (case sz of F64 -> True; F32 -> True; _ -> False)
3127            then return (code `appOL`
3128                         toOL [SUB I32 (OpImm (ImmInt size)) (OpReg esp),
3129                               DELTA (delta-size),
3130                               GST sz reg (AddrBaseIndex (EABaseReg esp)
3131                                                         EAIndexNone
3132                                                         (ImmInt 0))]
3133                        )
3134            else return (code `snocOL`
3135                         PUSH I32 (OpReg reg) `snocOL`
3136                         DELTA (delta-size)
3137                        )
3138       where
3139          arg_rep = cmmExprRep arg
3140
3141     ------------
3142     get_op :: CmmExpr -> NatM (InstrBlock, Reg, MachRep) -- code, reg, size
3143     get_op op = do
3144         (reg,code) <- getSomeReg op
3145         return (code, reg, cmmExprRep op)
3146
3147 #endif /* i386_TARGET_ARCH */
3148
3149 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
3150
3151 outOfLineFloatOp :: CallishMachOp -> CmmReg -> [(CmmExpr,MachHint)]
3152   -> Maybe [GlobalReg] -> NatM InstrBlock
3153 outOfLineFloatOp mop res args vols
3154   = do
3155       targetExpr <- cmmMakeDynamicReference addImportNat CallReference lbl
3156       let target = CmmForeignCall targetExpr CCallConv
3157
3158       if cmmRegRep res == F64
3159         then
3160           stmtToInstrs (CmmCall target [(res,FloatHint)] args vols)
3161         else do
3162           uq <- getUniqueNat
3163           let
3164             tmp = CmmLocal (LocalReg uq F64)
3165           -- in
3166           code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args vols)
3167           code2 <- stmtToInstrs (CmmAssign res (CmmReg tmp))
3168           return (code1 `appOL` code2)
3169   where
3170         lbl = mkForeignLabel fn Nothing False
3171
3172         fn = case mop of
3173               MO_F32_Sqrt  -> FSLIT("sqrtf")
3174               MO_F32_Sin   -> FSLIT("sinf")
3175               MO_F32_Cos   -> FSLIT("cosf")
3176               MO_F32_Tan   -> FSLIT("tanf")
3177               MO_F32_Exp   -> FSLIT("expf")
3178               MO_F32_Log   -> FSLIT("logf")
3179
3180               MO_F32_Asin  -> FSLIT("asinf")
3181               MO_F32_Acos  -> FSLIT("acosf")
3182               MO_F32_Atan  -> FSLIT("atanf")
3183
3184               MO_F32_Sinh  -> FSLIT("sinhf")
3185               MO_F32_Cosh  -> FSLIT("coshf")
3186               MO_F32_Tanh  -> FSLIT("tanhf")
3187               MO_F32_Pwr   -> FSLIT("powf")
3188
3189               MO_F64_Sqrt  -> FSLIT("sqrt")
3190               MO_F64_Sin   -> FSLIT("sin")
3191               MO_F64_Cos   -> FSLIT("cos")
3192               MO_F64_Tan   -> FSLIT("tan")
3193               MO_F64_Exp   -> FSLIT("exp")
3194               MO_F64_Log   -> FSLIT("log")
3195
3196               MO_F64_Asin  -> FSLIT("asin")
3197               MO_F64_Acos  -> FSLIT("acos")
3198               MO_F64_Atan  -> FSLIT("atan")
3199
3200               MO_F64_Sinh  -> FSLIT("sinh")
3201               MO_F64_Cosh  -> FSLIT("cosh")
3202               MO_F64_Tanh  -> FSLIT("tanh")
3203               MO_F64_Pwr   -> FSLIT("pow")
3204
3205 #endif /* i386_TARGET_ARCH || x86_64_TARGET_ARCH */
3206
3207 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3208
3209 #if x86_64_TARGET_ARCH
3210
3211 genCCall (CmmPrim MO_WriteBarrier) _ _ _ = return nilOL
3212         -- write barrier compiles to no code on x86/x86-64;
3213         -- we keep it this long in order to prevent earlier optimisations.
3214
3215 genCCall (CmmPrim op) [(r,_)] args vols =
3216   outOfLineFloatOp op r args vols
3217
3218 genCCall target dest_regs args vols = do
3219
3220         -- load up the register arguments
3221     (stack_args, aregs, fregs, load_args_code)
3222          <- load_args args allArgRegs allFPArgRegs nilOL
3223
3224     let
3225         fp_regs_used  = reverse (drop (length fregs) (reverse allFPArgRegs))
3226         int_regs_used = reverse (drop (length aregs) (reverse allArgRegs))
3227         arg_regs = [eax] ++ int_regs_used ++ fp_regs_used
3228                 -- for annotating the call instruction with
3229
3230         sse_regs = length fp_regs_used
3231
3232         tot_arg_size = arg_size * length stack_args
3233
3234         -- On entry to the called function, %rsp should be aligned
3235         -- on a 16-byte boundary +8 (i.e. the first stack arg after
3236         -- the return address is 16-byte aligned).  In STG land
3237         -- %rsp is kept 16-byte aligned (see StgCRun.c), so we just
3238         -- need to make sure we push a multiple of 16-bytes of args,
3239         -- plus the return address, to get the correct alignment.
3240         -- Urg, this is hard.  We need to feed the delta back into
3241         -- the arg pushing code.
3242     (real_size, adjust_rsp) <-
3243         if tot_arg_size `rem` 16 == 0
3244             then return (tot_arg_size, nilOL)
3245             else do -- we need to adjust...
3246                 delta <- getDeltaNat
3247                 setDeltaNat (delta-8)
3248                 return (tot_arg_size+8, toOL [
3249                                 SUB I64 (OpImm (ImmInt 8)) (OpReg rsp),
3250                                 DELTA (delta-8)
3251                         ])
3252
3253         -- push the stack args, right to left
3254     push_code <- push_args (reverse stack_args) nilOL
3255     delta <- getDeltaNat
3256
3257     -- deal with static vs dynamic call targets
3258     (callinsns,cconv) <-
3259       case target of
3260         -- CmmPrim -> ...
3261         CmmForeignCall (CmmLit (CmmLabel lbl)) conv
3262            -> -- ToDo: stdcall arg sizes
3263               return (unitOL (CALL (Left fn_imm) arg_regs), conv)
3264            where fn_imm = ImmCLbl lbl
3265         CmmForeignCall expr conv
3266            -> do (dyn_r, dyn_c) <- getSomeReg expr
3267                  return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)
3268
3269     let
3270         -- The x86_64 ABI requires us to set %al to the number of SSE
3271         -- registers that contain arguments, if the called routine
3272         -- is a varargs function.  We don't know whether it's a
3273         -- varargs function or not, so we have to assume it is.
3274         --
3275         -- It's not safe to omit this assignment, even if the number
3276         -- of SSE regs in use is zero.  If %al is larger than 8
3277         -- on entry to a varargs function, seg faults ensue.
3278         assign_eax n = unitOL (MOV I32 (OpImm (ImmInt n)) (OpReg eax))
3279
3280     let call = callinsns `appOL`
3281                toOL (
3282                         -- Deallocate parameters after call for ccall;
3283                         -- but not for stdcall (callee does it)
3284                   (if cconv == StdCallConv || real_size==0 then [] else
3285                    [ADD wordRep (OpImm (ImmInt real_size)) (OpReg esp)])
3286                   ++
3287                   [DELTA (delta + real_size)]
3288                )
3289     -- in
3290     setDeltaNat (delta + real_size)
3291
3292     let
3293         -- assign the results, if necessary
3294         assign_code []     = nilOL
3295         assign_code [(dest,_hint)] =
3296           case rep of
3297                 F32 -> unitOL (MOV rep (OpReg xmm0) (OpReg r_dest))
3298                 F64 -> unitOL (MOV rep (OpReg xmm0) (OpReg r_dest))
3299                 rep -> unitOL (MOV rep (OpReg rax) (OpReg r_dest))
3300           where
3301                 rep = cmmRegRep dest
3302                 r_dest = getRegisterReg dest
3303         assign_code many = panic "genCCall.assign_code many"
3304
3305     return (load_args_code      `appOL`
3306             adjust_rsp          `appOL`
3307             push_code           `appOL`
3308             assign_eax sse_regs `appOL`
3309             call                `appOL`
3310             assign_code dest_regs)
3311
3312   where
3313     arg_size = 8 -- always, at the mo
3314
3315     load_args :: [(CmmExpr,MachHint)]
3316               -> [Reg]                  -- int regs avail for args
3317               -> [Reg]                  -- FP regs avail for args
3318               -> InstrBlock
3319               -> NatM ([(CmmExpr,MachHint)],[Reg],[Reg],InstrBlock)
3320     load_args args [] [] code     =  return (args, [], [], code)
3321         -- no more regs to use
3322     load_args [] aregs fregs code =  return ([], aregs, fregs, code)
3323         -- no more args to push
3324     load_args ((arg,hint) : rest) aregs fregs code
3325         | isFloatingRep arg_rep =
3326         case fregs of
3327           [] -> push_this_arg
3328           (r:rs) -> do
3329              arg_code <- getAnyReg arg
3330              load_args rest aregs rs (code `appOL` arg_code r)
3331         | otherwise =
3332         case aregs of
3333           [] -> push_this_arg
3334           (r:rs) -> do
3335              arg_code <- getAnyReg arg
3336              load_args rest rs fregs (code `appOL` arg_code r)
3337         where
3338           arg_rep = cmmExprRep arg
3339
3340           push_this_arg = do
3341             (args',ars,frs,code') <- load_args rest aregs fregs code
3342             return ((arg,hint):args', ars, frs, code')
3343
3344     push_args [] code = return code
3345     push_args ((arg,hint):rest) code
3346        | isFloatingRep arg_rep = do
3347          (arg_reg, arg_code) <- getSomeReg arg
3348          delta <- getDeltaNat
3349          setDeltaNat (delta-arg_size)
3350          let code' = code `appOL` toOL [
3351                         MOV arg_rep (OpReg arg_reg) (OpAddr  (spRel 0)),
3352                         SUB wordRep (OpImm (ImmInt arg_size)) (OpReg rsp) ,
3353                         DELTA (delta-arg_size)]
3354          push_args rest code'
3355
3356        | otherwise = do
3357        -- we only ever generate word-sized function arguments.  Promotion
3358        -- has already happened: our Int8# type is kept sign-extended
3359        -- in an Int#, for example.
3360          ASSERT(arg_rep == I64) return ()
3361          (arg_op, arg_code) <- getOperand arg
3362          delta <- getDeltaNat
3363          setDeltaNat (delta-arg_size)
3364          let code' = code `appOL` toOL [PUSH I64 arg_op,
3365                                         DELTA (delta-arg_size)]
3366          push_args rest code'
3367         where
3368           arg_rep = cmmExprRep arg
3369 #endif
3370
3371 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3372
3373 #if sparc_TARGET_ARCH
3374 {-
3375    The SPARC calling convention is an absolute
3376    nightmare.  The first 6x32 bits of arguments are mapped into
3377    %o0 through %o5, and the remaining arguments are dumped to the
3378    stack, beginning at [%sp+92].  (Note that %o6 == %sp.)
3379
3380    If we have to put args on the stack, move %o6==%sp down by
3381    the number of words to go on the stack, to ensure there's enough space.
3382
3383    According to Fraser and Hanson's lcc book, page 478, fig 17.2,
3384    16 words above the stack pointer is a word for the address of
3385    a structure return value.  I use this as a temporary location
3386    for moving values from float to int regs.  Certainly it isn't
3387    safe to put anything in the 16 words starting at %sp, since
3388    this area can get trashed at any time due to window overflows
3389    caused by signal handlers.
3390
3391    A final complication (if the above isn't enough) is that
3392    we can't blithely calculate the arguments one by one into
3393    %o0 .. %o5.  Consider the following nested calls:
3394
3395        fff a (fff b c)
3396
3397    Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately
3398    the inner call will itself use %o0, which trashes the value put there
3399    in preparation for the outer call.  Upshot: we need to calculate the
3400    args into temporary regs, and move those to arg regs or onto the
3401    stack only immediately prior to the call proper.  Sigh.
3402 -}
3403
3404 genCCall target dest_regs argsAndHints vols = do
3405     let
3406         args = map fst argsAndHints
3407     argcode_and_vregs <- mapM arg_to_int_vregs args
3408     let
3409         (argcodes, vregss) = unzip argcode_and_vregs
3410         n_argRegs          = length allArgRegs
3411         n_argRegs_used     = min (length vregs) n_argRegs
3412         vregs              = concat vregss
3413     -- deal with static vs dynamic call targets
3414     callinsns <- (case target of
3415         CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> do
3416                 return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
3417         CmmForeignCall expr conv -> do
3418                 (dyn_c, [dyn_r]) <- arg_to_int_vregs expr
3419                 return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
3420         CmmPrim mop -> do
3421                   (res, reduce) <- outOfLineFloatOp mop
3422                   lblOrMopExpr <- case res of
3423                        Left lbl -> do
3424                             return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
3425                        Right mopExpr -> do
3426                             (dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr
3427                             return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
3428                   if reduce then panic "genCCall(sparc): can not reduce" else return lblOrMopExpr
3429
3430       )
3431     let
3432         argcode = concatOL argcodes
3433         (move_sp_down, move_sp_up)
3434            = let diff = length vregs - n_argRegs
3435                  nn   = if odd diff then diff + 1 else diff -- keep 8-byte alignment
3436              in  if   nn <= 0
3437                  then (nilOL, nilOL)
3438                  else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
3439         transfer_code
3440            = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
3441     return (argcode       `appOL`
3442             move_sp_down  `appOL`
3443             transfer_code `appOL`
3444             callinsns     `appOL`
3445             unitOL NOP    `appOL`
3446             move_sp_up)
3447   where
3448      -- move args from the integer vregs into which they have been
3449      -- marshalled, into %o0 .. %o5, and the rest onto the stack.
3450      move_final :: [Reg] -> [Reg] -> Int -> [Instr]
3451
3452      move_final [] _ offset          -- all args done
3453         = []
3454
3455      move_final (v:vs) [] offset     -- out of aregs; move to stack
3456         = ST I32 v (spRel offset)
3457           : move_final vs [] (offset+1)
3458
3459      move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
3460         = OR False g0 (RIReg v) a
3461           : move_final vs az offset
3462
3463      -- generate code to calculate an argument, and move it into one
3464      -- or two integer vregs.
3465      arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg])
3466      arg_to_int_vregs arg
3467         | (cmmExprRep arg) == I64
3468         = do
3469           (ChildCode64 code r_lo) <- iselExpr64 arg
3470           let
3471               r_hi = getHiVRegFromLo r_lo
3472           return (code, [r_hi, r_lo])
3473         | otherwise
3474         = do
3475           (src, code) <- getSomeReg arg
3476           tmp <- getNewRegNat (cmmExprRep arg)
3477           let
3478               pk   = cmmExprRep arg
3479           case pk of
3480              F64 -> do
3481                       v1 <- getNewRegNat I32
3482                       v2 <- getNewRegNat I32
3483                       return (
3484                         code                          `snocOL`
3485                         FMOV F64 src f0                `snocOL`
3486                         ST   F32  f0 (spRel 16)         `snocOL`
3487                         LD   I32  (spRel 16) v1         `snocOL`
3488                         ST   F32  (fPair f0) (spRel 16) `snocOL`
3489                         LD   I32  (spRel 16) v2
3490                         ,
3491                         [v1,v2]
3492                        )
3493              F32 -> do
3494                       v1 <- getNewRegNat I32
3495                       return (
3496                         code                    `snocOL`
3497                         ST   F32  src (spRel 16)  `snocOL`
3498                         LD   I32  (spRel 16) v1
3499                         ,
3500                         [v1]
3501                        )
3502              other -> do
3503                         v1 <- getNewRegNat I32
3504                         return (
3505                           code `snocOL` OR False g0 (RIReg src) v1
3506                           ,
3507                           [v1]
3508                          )
3509 outOfLineFloatOp mop =
3510     do
3511       mopExpr <- cmmMakeDynamicReference addImportNat CallReference $
3512                   mkForeignLabel functionName Nothing True
3513       let mopLabelOrExpr = case mopExpr of
3514                         CmmLit (CmmLabel lbl) -> Left lbl
3515                         _ -> Right mopExpr
3516       return (mopLabelOrExpr, reduce)
3517             where
3518                 (reduce, functionName) = case mop of
3519                   MO_F32_Exp    -> (True,  FSLIT("exp"))
3520                   MO_F32_Log    -> (True,  FSLIT("log"))
3521                   MO_F32_Sqrt   -> (True,  FSLIT("sqrt"))
3522
3523                   MO_F32_Sin    -> (True,  FSLIT("sin"))
3524                   MO_F32_Cos    -> (True,  FSLIT("cos"))
3525                   MO_F32_Tan    -> (True,  FSLIT("tan"))
3526
3527                   MO_F32_Asin   -> (True,  FSLIT("asin"))
3528                   MO_F32_Acos   -> (True,  FSLIT("acos"))
3529                   MO_F32_Atan   -> (True,  FSLIT("atan"))
3530
3531                   MO_F32_Sinh   -> (True,  FSLIT("sinh"))
3532                   MO_F32_Cosh   -> (True,  FSLIT("cosh"))
3533                   MO_F32_Tanh   -> (True,  FSLIT("tanh"))
3534
3535                   MO_F64_Exp    -> (False, FSLIT("exp"))
3536                   MO_F64_Log    -> (False, FSLIT("log"))
3537                   MO_F64_Sqrt   -> (False, FSLIT("sqrt"))
3538
3539                   MO_F64_Sin    -> (False, FSLIT("sin"))
3540                   MO_F64_Cos    -> (False, FSLIT("cos"))
3541                   MO_F64_Tan    -> (False, FSLIT("tan"))
3542
3543                   MO_F64_Asin   -> (False, FSLIT("asin"))
3544                   MO_F64_Acos   -> (False, FSLIT("acos"))
3545                   MO_F64_Atan   -> (False, FSLIT("atan"))
3546
3547                   MO_F64_Sinh   -> (False, FSLIT("sinh"))
3548                   MO_F64_Cosh   -> (False, FSLIT("cosh"))
3549                   MO_F64_Tanh   -> (False, FSLIT("tanh"))
3550
3551                   other -> pprPanic "outOfLineFloatOp(sparc) "
3552                                 (pprCallishMachOp mop)
3553
3554 #endif /* sparc_TARGET_ARCH */
3555
3556 #if powerpc_TARGET_ARCH
3557
3558 #if darwin_TARGET_OS || linux_TARGET_OS
3559 {-
3560     The PowerPC calling convention for Darwin/Mac OS X
3561     is described in Apple's document
3562     "Inside Mac OS X - Mach-O Runtime Architecture".
3563
3564     PowerPC Linux uses the System V Release 4 Calling Convention
3565     for PowerPC. It is described in the
3566     "System V Application Binary Interface PowerPC Processor Supplement".
3567
3568     Both conventions are similar:
3569     Parameters may be passed in general-purpose registers starting at r3, in
3570     floating point registers starting at f1, or on the stack.
3571
3572     But there are substantial differences:
3573     * The number of registers used for parameter passing and the exact set of
3574       nonvolatile registers differs (see MachRegs.lhs).
3575     * On Darwin, stack space is always reserved for parameters, even if they are
3576       passed in registers. The called routine may choose to save parameters from
3577       registers to the corresponding space on the stack.
3578     * On Darwin, a corresponding amount of GPRs is skipped when a floating point
3579       parameter is passed in an FPR.
3580     * SysV insists on either passing I64 arguments on the stack, or in two GPRs,
3581       starting with an odd-numbered GPR. It may skip a GPR to achieve this.
3582       Darwin just treats an I64 like two separate I32s (high word first).
3583     * I64 and F64 arguments are 8-byte aligned on the stack for SysV, but only
3584       4-byte aligned like everything else on Darwin.
3585     * The SysV spec claims that F32 is represented as F64 on the stack. GCC on
3586       PowerPC Linux does not agree, so neither do we.
3587
3588     According to both conventions, The parameter area should be part of the
3589     caller's stack frame, allocated in the caller's prologue code (large enough
3590     to hold the parameter lists for all called routines). The NCG already
3591     uses the stack for register spilling, leaving 64 bytes free at the top.
3592     If we need a larger parameter area than that, we just allocate a new stack
3593     frame just before ccalling.
3594 -}
3595
3596
3597 genCCall (CmmPrim MO_WriteBarrier) _ _ _
3598  = return $ unitOL LWSYNC
3599
3600 genCCall target dest_regs argsAndHints vols
3601   = ASSERT (not $ any (`elem` [I8,I16]) argReps)
3602         -- we rely on argument promotion in the codeGen
3603     do
3604         (finalStack,passArgumentsCode,usedRegs) <- passArguments
3605                                                         (zip args argReps)
3606                                                         allArgRegs allFPArgRegs
3607                                                         initialStackOffset
3608                                                         (toOL []) []
3609
3610         (labelOrExpr, reduceToF32) <- case target of
3611             CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False)
3612             CmmForeignCall expr conv -> return  (Right expr, False)
3613             CmmPrim mop -> outOfLineFloatOp mop
3614
3615         let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode
3616             codeAfter = move_sp_up finalStack `appOL` moveResult reduceToF32
3617
3618         case labelOrExpr of
3619             Left lbl -> do
3620                 return (         codeBefore
3621                         `snocOL` BL lbl usedRegs
3622                         `appOL`  codeAfter)
3623             Right dyn -> do
3624                 (dynReg, dynCode) <- getSomeReg dyn
3625                 return (         dynCode
3626                         `snocOL` MTCTR dynReg
3627                         `appOL`  codeBefore
3628                         `snocOL` BCTRL usedRegs
3629                         `appOL`  codeAfter)
3630     where
3631 #if darwin_TARGET_OS
3632         initialStackOffset = 24
3633             -- size of linkage area + size of arguments, in bytes
3634         stackDelta _finalStack = roundTo 16 $ (24 +) $ max 32 $ sum $
3635                                        map machRepByteWidth argReps
3636 #elif linux_TARGET_OS
3637         initialStackOffset = 8
3638         stackDelta finalStack = roundTo 16 finalStack
3639 #endif
3640         args = map fst argsAndHints
3641         argReps = map cmmExprRep args
3642
3643         roundTo a x | x `mod` a == 0 = x
3644                     | otherwise = x + a - (x `mod` a)
3645
3646         move_sp_down finalStack
3647                | delta > 64 =
3648                         toOL [STU I32 sp (AddrRegImm sp (ImmInt (-delta))),
3649                               DELTA (-delta)]
3650                | otherwise = nilOL
3651                where delta = stackDelta finalStack
3652         move_sp_up finalStack
3653                | delta > 64 =
3654                         toOL [ADD sp sp (RIImm (ImmInt delta)),
3655                               DELTA 0]
3656                | otherwise = nilOL
3657                where delta = stackDelta finalStack
3658
3659
3660         passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed)
3661         passArguments ((arg,I64):args) gprs fprs stackOffset
3662                accumCode accumUsed =
3663             do
3664                 ChildCode64 code vr_lo <- iselExpr64 arg
3665                 let vr_hi = getHiVRegFromLo vr_lo
3666
3667 #if darwin_TARGET_OS
3668                 passArguments args
3669                               (drop 2 gprs)
3670                               fprs
3671                               (stackOffset+8)
3672                               (accumCode `appOL` code
3673                                     `snocOL` storeWord vr_hi gprs stackOffset
3674                                     `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
3675                               ((take 2 gprs) ++ accumUsed)
3676             where
3677                 storeWord vr (gpr:_) offset = MR gpr vr
3678                 storeWord vr [] offset = ST I32 vr (AddrRegImm sp (ImmInt offset))
3679
3680 #elif linux_TARGET_OS
3681                 let stackOffset' = roundTo 8 stackOffset
3682                     stackCode = accumCode `appOL` code
3683                         `snocOL` ST I32 vr_hi (AddrRegImm sp (ImmInt stackOffset'))
3684                         `snocOL` ST I32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4)))
3685                     regCode hireg loreg =
3686                         accumCode `appOL` code
3687                             `snocOL` MR hireg vr_hi
3688                             `snocOL` MR loreg vr_lo
3689
3690                 case gprs of
3691                     hireg : loreg : regs | even (length gprs) ->
3692                         passArguments args regs fprs stackOffset
3693                                       (regCode hireg loreg) (hireg : loreg : accumUsed)
3694                     _skipped : hireg : loreg : regs ->
3695                         passArguments args regs fprs stackOffset
3696                                       (regCode hireg loreg) (hireg : loreg : accumUsed)
3697                     _ -> -- only one or no regs left
3698                         passArguments args [] fprs (stackOffset'+8)
3699                                       stackCode accumUsed
3700 #endif
3701
3702         passArguments ((arg,rep):args) gprs fprs stackOffset accumCode accumUsed
3703             | reg : _ <- regs = do
3704                 register <- getRegister arg
3705                 let code = case register of
3706                             Fixed _ freg fcode -> fcode `snocOL` MR reg freg
3707                             Any _ acode -> acode reg
3708                 passArguments args
3709                               (drop nGprs gprs)
3710                               (drop nFprs fprs)
3711 #if darwin_TARGET_OS
3712         -- The Darwin ABI requires that we reserve stack slots for register parameters
3713                               (stackOffset + stackBytes)
3714 #elif linux_TARGET_OS
3715         -- ... the SysV ABI doesn't.
3716                               stackOffset
3717 #endif
3718                               (accumCode `appOL` code)
3719                               (reg : accumUsed)
3720             | otherwise = do
3721                 (vr, code) <- getSomeReg arg
3722                 passArguments args
3723                               (drop nGprs gprs)
3724                               (drop nFprs fprs)
3725                               (stackOffset' + stackBytes)
3726                               (accumCode `appOL` code `snocOL` ST rep vr stackSlot)
3727                               accumUsed
3728             where
3729 #if darwin_TARGET_OS
3730         -- stackOffset is at least 4-byte aligned
3731         -- The Darwin ABI is happy with that.
3732                 stackOffset' = stackOffset
3733 #else
3734         -- ... the SysV ABI requires 8-byte alignment for doubles.
3735                 stackOffset' | rep == F64 = roundTo 8 stackOffset
3736                              | otherwise  =           stackOffset
3737 #endif
3738                 stackSlot = AddrRegImm sp (ImmInt stackOffset')
3739                 (nGprs, nFprs, stackBytes, regs) = case rep of
3740                     I32 -> (1, 0, 4, gprs)
3741 #if darwin_TARGET_OS
3742         -- The Darwin ABI requires that we skip a corresponding number of GPRs when
3743         -- we use the FPRs.
3744                     F32 -> (1, 1, 4, fprs)
3745                     F64 -> (2, 1, 8, fprs)
3746 #elif linux_TARGET_OS
3747         -- ... the SysV ABI doesn't.
3748                     F32 -> (0, 1, 4, fprs)
3749                     F64 -> (0, 1, 8, fprs)
3750 #endif
3751
3752         moveResult reduceToF32 =
3753             case dest_regs of
3754                 [] -> nilOL
3755                 [(dest, _hint)]
3756                     | reduceToF32 && rep == F32 -> unitOL (FRSP r_dest f1)
3757                     | rep == F32 || rep == F64 -> unitOL (MR r_dest f1)
3758                     | rep == I64 -> toOL [MR (getHiVRegFromLo r_dest) r3,
3759                                           MR r_dest r4]
3760                     | otherwise -> unitOL (MR r_dest r3)
3761                     where rep = cmmRegRep dest
3762                           r_dest = getRegisterReg dest
3763
3764         outOfLineFloatOp mop =
3765             do
3766                 mopExpr <- cmmMakeDynamicReference addImportNat CallReference $
3767                               mkForeignLabel functionName Nothing True
3768                 let mopLabelOrExpr = case mopExpr of
3769                         CmmLit (CmmLabel lbl) -> Left lbl
3770                         _ -> Right mopExpr
3771                 return (mopLabelOrExpr, reduce)
3772             where
3773                 (functionName, reduce) = case mop of
3774                     MO_F32_Exp   -> (FSLIT("exp"), True)
3775                     MO_F32_Log   -> (FSLIT("log"), True)
3776                     MO_F32_Sqrt  -> (FSLIT("sqrt"), True)
3777
3778                     MO_F32_Sin   -> (FSLIT("sin"), True)
3779                     MO_F32_Cos   -> (FSLIT("cos"), True)
3780                     MO_F32_Tan   -> (FSLIT("tan"), True)
3781
3782                     MO_F32_Asin  -> (FSLIT("asin"), True)
3783                     MO_F32_Acos  -> (FSLIT("acos"), True)
3784                     MO_F32_Atan  -> (FSLIT("atan"), True)
3785
3786                     MO_F32_Sinh  -> (FSLIT("sinh"), True)
3787                     MO_F32_Cosh  -> (FSLIT("cosh"), True)
3788                     MO_F32_Tanh  -> (FSLIT("tanh"), True)
3789                     MO_F32_Pwr   -> (FSLIT("pow"), True)
3790
3791                     MO_F64_Exp   -> (FSLIT("exp"), False)
3792                     MO_F64_Log   -> (FSLIT("log"), False)
3793                     MO_F64_Sqrt  -> (FSLIT("sqrt"), False)
3794
3795                     MO_F64_Sin   -> (FSLIT("sin"), False)
3796                     MO_F64_Cos   -> (FSLIT("cos"), False)
3797                     MO_F64_Tan   -> (FSLIT("tan"), False)
3798
3799                     MO_F64_Asin  -> (FSLIT("asin"), False)
3800                     MO_F64_Acos  -> (FSLIT("acos"), False)
3801                     MO_F64_Atan  -> (FSLIT("atan"), False)
3802
3803                     MO_F64_Sinh  -> (FSLIT("sinh"), False)
3804                     MO_F64_Cosh  -> (FSLIT("cosh"), False)
3805                     MO_F64_Tanh  -> (FSLIT("tanh"), False)
3806                     MO_F64_Pwr   -> (FSLIT("pow"), False)
3807                     other -> pprPanic "genCCall(ppc): unknown callish op"
3808                                     (pprCallishMachOp other)
3809
3810 #endif /* darwin_TARGET_OS || linux_TARGET_OS */
3811
3812 #endif /* powerpc_TARGET_ARCH */
3813
3814
3815 -- -----------------------------------------------------------------------------
3816 -- Generating a table-branch
3817
3818 genSwitch :: CmmExpr -> [Maybe BlockId] -> NatM InstrBlock
3819
3820 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
3821 genSwitch expr ids
3822   | opt_PIC
3823   = do
3824         (reg,e_code) <- getSomeReg expr
3825         lbl <- getNewLabelNat
3826         dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl
3827         (tableReg,t_code) <- getSomeReg $ dynRef
3828         let
3829             jumpTable = map jumpTableEntryRel ids
3830
3831             jumpTableEntryRel Nothing
3832                 = CmmStaticLit (CmmInt 0 wordRep)
3833             jumpTableEntryRel (Just (BlockId id))
3834                 = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
3835                 where blockLabel = mkAsmTempLabel id
3836
3837             op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
3838                                        (EAIndex reg wORD_SIZE) (ImmInt 0))
3839
3840 #if x86_64_TARGET_ARCH && darwin_TARGET_OS
3841     -- on Mac OS X/x86_64, put the jump table in the text section
3842     -- to work around a limitation of the linker.
3843     -- ld64 is unable to handle the relocations for
3844     --     .quad L1 - L0
3845     -- if L0 is not preceded by a non-anonymous label in its section.
3846
3847             code = e_code `appOL` t_code `appOL` toOL [
3848                             ADD wordRep op (OpReg tableReg),
3849                             JMP_TBL (OpReg tableReg) [ id | Just id <- ids ],
3850                             LDATA Text (CmmDataLabel lbl : jumpTable)
3851                     ]
3852 #else
3853             code = e_code `appOL` t_code `appOL` toOL [
3854                             LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
3855                             ADD wordRep op (OpReg tableReg),
3856                             JMP_TBL (OpReg tableReg) [ id | Just id <- ids ]
3857                     ]
3858 #endif
3859         return code
3860   | otherwise
3861   = do
3862         (reg,e_code) <- getSomeReg expr
3863         lbl <- getNewLabelNat
3864         let
3865             jumpTable = map jumpTableEntry ids
3866             op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg wORD_SIZE) (ImmCLbl lbl))
3867             code = e_code `appOL` toOL [
3868                     LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
3869                     JMP_TBL op [ id | Just id <- ids ]
3870                  ]
3871         -- in
3872         return code
3873 #elif powerpc_TARGET_ARCH
3874 genSwitch expr ids
3875   | opt_PIC
3876   = do
3877         (reg,e_code) <- getSomeReg expr
3878         tmp <- getNewRegNat I32
3879         lbl <- getNewLabelNat
3880         dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl
3881         (tableReg,t_code) <- getSomeReg $ dynRef
3882         let
3883             jumpTable = map jumpTableEntryRel ids
3884
3885             jumpTableEntryRel Nothing
3886                 = CmmStaticLit (CmmInt 0 wordRep)
3887             jumpTableEntryRel (Just (BlockId id))
3888                 = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
3889                 where blockLabel = mkAsmTempLabel id
3890
3891             code = e_code `appOL` t_code `appOL` toOL [
3892                             LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
3893                             SLW tmp reg (RIImm (ImmInt 2)),
3894                             LD I32 tmp (AddrRegReg tableReg tmp),
3895                             ADD tmp tmp (RIReg tableReg),
3896                             MTCTR tmp,
3897                             BCTR [ id | Just id <- ids ]
3898                     ]
3899         return code
3900   | otherwise
3901   = do
3902         (reg,e_code) <- getSomeReg expr
3903         tmp <- getNewRegNat I32
3904         lbl <- getNewLabelNat
3905         let
3906             jumpTable = map jumpTableEntry ids
3907
3908             code = e_code `appOL` toOL [
3909                             LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
3910                             SLW tmp reg (RIImm (ImmInt 2)),
3911                             ADDIS tmp tmp (HA (ImmCLbl lbl)),
3912                             LD I32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
3913                             MTCTR tmp,
3914                             BCTR [ id | Just id <- ids ]
3915                     ]
3916         return code
3917 #else
3918 genSwitch expr ids = panic "ToDo: genSwitch"
3919 #endif
3920
3921 jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordRep)
3922 jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel)
3923     where blockLabel = mkAsmTempLabel id
3924
3925 -- -----------------------------------------------------------------------------
3926 -- Support bits
3927 -- -----------------------------------------------------------------------------
3928
3929
3930 -- -----------------------------------------------------------------------------
3931 -- 'condIntReg' and 'condFltReg': condition codes into registers
3932
3933 -- Turn those condition codes into integers now (when they appear on
3934 -- the right hand side of an assignment).
3935 --
3936 -- (If applicable) Do not fill the delay slots here; you will confuse the
3937 -- register allocator.
3938
3939 condIntReg, condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
3940
3941 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3942
3943 #if alpha_TARGET_ARCH
3944 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
3945 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
3946 #endif /* alpha_TARGET_ARCH */
3947
3948 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3949
3950 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
3951
3952 condIntReg cond x y = do
3953   CondCode _ cond cond_code <- condIntCode cond x y
3954   tmp <- getNewRegNat I8
3955   let
3956         code dst = cond_code `appOL` toOL [
3957                     SETCC cond (OpReg tmp),
3958                     MOVZxL I8 (OpReg tmp) (OpReg dst)
3959                   ]
3960   -- in
3961   return (Any I32 code)
3962
3963 #endif
3964
3965 #if i386_TARGET_ARCH
3966
3967 condFltReg cond x y = do
3968   CondCode _ cond cond_code <- condFltCode cond x y
3969   tmp <- getNewRegNat I8
3970   let
3971         code dst = cond_code `appOL` toOL [
3972                     SETCC cond (OpReg tmp),
3973                     MOVZxL I8 (OpReg tmp) (OpReg dst)
3974                   ]
3975   -- in
3976   return (Any I32 code)
3977
3978 #endif
3979
3980 #if x86_64_TARGET_ARCH
3981
3982 condFltReg cond x y = do
3983   CondCode _ cond cond_code <- condFltCode cond x y
3984   tmp1 <- getNewRegNat wordRep
3985   tmp2 <- getNewRegNat wordRep
3986   let
3987         -- We have to worry about unordered operands (eg. comparisons
3988         -- against NaN).  If the operands are unordered, the comparison
3989         -- sets the parity flag, carry flag and zero flag.
3990         -- All comparisons are supposed to return false for unordered
3991         -- operands except for !=, which returns true.
3992         --
3993         -- Optimisation: we don't have to test the parity flag if we
3994         -- know the test has already excluded the unordered case: eg >
3995         -- and >= test for a zero carry flag, which can only occur for
3996         -- ordered operands.
3997         --
3998         -- ToDo: by reversing comparisons we could avoid testing the
3999         -- parity flag in more cases.
4000
4001         code dst =
4002            cond_code `appOL`
4003              (case cond of
4004                 NE  -> or_unordered dst
4005                 GU  -> plain_test   dst
4006                 GEU -> plain_test   dst
4007                 _   -> and_ordered  dst)
4008
4009         plain_test dst = toOL [
4010                     SETCC cond (OpReg tmp1),
4011                     MOVZxL I8 (OpReg tmp1) (OpReg dst)
4012                  ]
4013         or_unordered dst = toOL [
4014                     SETCC cond (OpReg tmp1),
4015                     SETCC PARITY (OpReg tmp2),
4016                     OR I8 (OpReg tmp1) (OpReg tmp2),
4017                     MOVZxL I8 (OpReg tmp2) (OpReg dst)
4018                   ]
4019         and_ordered dst = toOL [
4020                     SETCC cond (OpReg tmp1),
4021                     SETCC NOTPARITY (OpReg tmp2),
4022                     AND I8 (OpReg tmp1) (OpReg tmp2),
4023                     MOVZxL I8 (OpReg tmp2) (OpReg dst)
4024                   ]
4025   -- in
4026   return (Any I32 code)
4027
4028 #endif
4029
4030 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4031
4032 #if sparc_TARGET_ARCH
4033
4034 condIntReg EQQ x (CmmLit (CmmInt 0 d)) = do
4035     (src, code) <- getSomeReg x
4036     tmp <- getNewRegNat I32
4037     let
4038         code__2 dst = code `appOL` toOL [
4039             SUB False True g0 (RIReg src) g0,
4040             SUB True False g0 (RIImm (ImmInt (-1))) dst]
4041     return (Any I32 code__2)
4042
4043 condIntReg EQQ x y = do
4044     (src1, code1) <- getSomeReg x
4045     (src2, code2) <- getSomeReg y
4046     tmp1 <- getNewRegNat I32
4047     tmp2 <- getNewRegNat I32
4048     let
4049         code__2 dst = code1 `appOL` code2 `appOL` toOL [
4050             XOR False src1 (RIReg src2) dst,
4051             SUB False True g0 (RIReg dst) g0,
4052             SUB True False g0 (RIImm (ImmInt (-1))) dst]
4053     return (Any I32 code__2)
4054
4055 condIntReg NE x (CmmLit (CmmInt 0 d)) = do
4056     (src, code) <- getSomeReg x
4057     tmp <- getNewRegNat I32
4058     let
4059         code__2 dst = code `appOL` toOL [
4060             SUB False True g0 (RIReg src) g0,
4061             ADD True False g0 (RIImm (ImmInt 0)) dst]
4062     return (Any I32 code__2)
4063
4064 condIntReg NE x y = do
4065     (src1, code1) <- getSomeReg x
4066     (src2, code2) <- getSomeReg y
4067     tmp1 <- getNewRegNat I32
4068     tmp2 <- getNewRegNat I32
4069     let
4070         code__2 dst = code1 `appOL` code2 `appOL` toOL [
4071             XOR False src1 (RIReg src2) dst,
4072             SUB False True g0 (RIReg dst) g0,
4073             ADD True False g0 (RIImm (ImmInt 0)) dst]
4074     return (Any I32 code__2)
4075
4076 condIntReg cond x y = do
4077     BlockId lbl1 <- getBlockIdNat
4078     BlockId lbl2 <- getBlockIdNat
4079     CondCode _ cond cond_code <- condIntCode cond x y
4080     let
4081         code__2 dst = cond_code `appOL` toOL [
4082             BI cond False (ImmCLbl (mkAsmTempLabel lbl1)), NOP,
4083             OR False g0 (RIImm (ImmInt 0)) dst,
4084             BI ALWAYS False (ImmCLbl (mkAsmTempLabel lbl2)), NOP,
4085             NEWBLOCK (BlockId lbl1),
4086             OR False g0 (RIImm (ImmInt 1)) dst,
4087             NEWBLOCK (BlockId lbl2)]
4088     return (Any I32 code__2)
4089
4090 condFltReg cond x y = do
4091     BlockId lbl1 <- getBlockIdNat
4092     BlockId lbl2 <- getBlockIdNat
4093     CondCode _ cond cond_code <- condFltCode cond x y
4094     let
4095         code__2 dst = cond_code `appOL` toOL [
4096             NOP,
4097             BF cond False (ImmCLbl (mkAsmTempLabel lbl1)), NOP,
4098             OR False g0 (RIImm (ImmInt 0)) dst,
4099             BI ALWAYS False (ImmCLbl (mkAsmTempLabel lbl2)), NOP,
4100             NEWBLOCK (BlockId lbl1),
4101             OR False g0 (RIImm (ImmInt 1)) dst,
4102             NEWBLOCK (BlockId lbl2)]
4103     return (Any I32 code__2)
4104
4105 #endif /* sparc_TARGET_ARCH */
4106
4107 #if powerpc_TARGET_ARCH
4108 condReg getCond = do
4109     lbl1 <- getBlockIdNat
4110     lbl2 <- getBlockIdNat
4111     CondCode _ cond cond_code <- getCond
4112     let
4113 {-        code dst = cond_code `appOL` toOL [
4114                 BCC cond lbl1,
4115                 LI dst (ImmInt 0),
4116                 BCC ALWAYS lbl2,
4117                 NEWBLOCK lbl1,
4118                 LI dst (ImmInt 1),
4119                 BCC ALWAYS lbl2,
4120                 NEWBLOCK lbl2
4121             ]-}
4122         code dst = cond_code
4123             `appOL` negate_code
4124             `appOL` toOL [
4125                 MFCR dst,
4126                 RLWINM dst dst (bit + 1) 31 31
4127             ]
4128
4129         negate_code | do_negate = unitOL (CRNOR bit bit bit)
4130                     | otherwise = nilOL
4131
4132         (bit, do_negate) = case cond of
4133             LTT -> (0, False)
4134             LE  -> (1, True)
4135             EQQ -> (2, False)
4136             GE  -> (0, True)
4137             GTT -> (1, False)
4138
4139             NE  -> (2, True)
4140
4141             LU  -> (0, False)
4142             LEU -> (1, True)
4143             GEU -> (0, True)
4144             GU  -> (1, False)
4145
4146     return (Any I32 code)
4147
4148 condIntReg cond x y = condReg (condIntCode cond x y)
4149 condFltReg cond x y = condReg (condFltCode cond x y)
4150 #endif /* powerpc_TARGET_ARCH */
4151
4152
4153 -- -----------------------------------------------------------------------------
4154 -- 'trivial*Code': deal with trivial instructions
4155
4156 -- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',
4157 -- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.
4158 -- Only look for constants on the right hand side, because that's
4159 -- where the generic optimizer will have put them.
4160
4161 -- Similarly, for unary instructions, we don't have to worry about
4162 -- matching an StInt as the argument, because genericOpt will already
4163 -- have handled the constant-folding.
4164
4165 trivialCode
4166     :: MachRep
4167     -> IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
4168       ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
4169                      -> Maybe (Operand -> Operand -> Instr)
4170       ,IF_ARCH_x86_64 ((Operand -> Operand -> Instr)
4171                      -> Maybe (Operand -> Operand -> Instr)
4172       ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
4173       ,IF_ARCH_powerpc(Bool -> (Reg -> Reg -> RI -> Instr)
4174       ,)))))
4175     -> CmmExpr -> CmmExpr -- the two arguments
4176     -> NatM Register
4177
4178 #ifndef powerpc_TARGET_ARCH
4179 trivialFCode
4180     :: MachRep
4181     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
4182       ,IF_ARCH_sparc((MachRep -> Reg -> Reg -> Reg -> Instr)
4183       ,IF_ARCH_i386 ((MachRep -> Reg -> Reg -> Reg -> Instr)
4184       ,IF_ARCH_x86_64 ((MachRep -> Operand -> Operand -> Instr)
4185       ,))))
4186     -> CmmExpr -> CmmExpr -- the two arguments
4187     -> NatM Register
4188 #endif
4189
4190 trivialUCode
4191     :: MachRep
4192     -> IF_ARCH_alpha((RI -> Reg -> Instr)
4193       ,IF_ARCH_i386 ((Operand -> Instr)
4194       ,IF_ARCH_x86_64 ((Operand -> Instr)
4195       ,IF_ARCH_sparc((RI -> Reg -> Instr)
4196       ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
4197       ,)))))
4198     -> CmmExpr  -- the one argument
4199     -> NatM Register
4200
4201 #ifndef powerpc_TARGET_ARCH
4202 trivialUFCode
4203     :: MachRep
4204     -> IF_ARCH_alpha((Reg -> Reg -> Instr)
4205       ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
4206       ,IF_ARCH_x86_64 ((Reg -> Reg -> Instr)
4207       ,IF_ARCH_sparc((Reg -> Reg -> Instr)
4208       ,))))
4209     -> CmmExpr -- the one argument
4210     -> NatM Register
4211 #endif
4212
4213 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4214
4215 #if alpha_TARGET_ARCH
4216
4217 trivialCode instr x (StInt y)
4218   | fits8Bits y
4219   = getRegister x               `thenNat` \ register ->
4220     getNewRegNat IntRep         `thenNat` \ tmp ->
4221     let
4222         code = registerCode register tmp
4223         src1 = registerName register tmp
4224         src2 = ImmInt (fromInteger y)
4225         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
4226     in
4227     return (Any IntRep code__2)
4228
4229 trivialCode instr x y
4230   = getRegister x               `thenNat` \ register1 ->
4231     getRegister y               `thenNat` \ register2 ->
4232     getNewRegNat IntRep         `thenNat` \ tmp1 ->
4233     getNewRegNat IntRep         `thenNat` \ tmp2 ->
4234     let
4235         code1 = registerCode register1 tmp1 []
4236         src1  = registerName register1 tmp1
4237         code2 = registerCode register2 tmp2 []
4238         src2  = registerName register2 tmp2
4239         code__2 dst = asmSeqThen [code1, code2] .
4240                      mkSeqInstr (instr src1 (RIReg src2) dst)
4241     in
4242     return (Any IntRep code__2)
4243
4244 ------------
4245 trivialUCode instr x
4246   = getRegister x               `thenNat` \ register ->
4247     getNewRegNat IntRep         `thenNat` \ tmp ->
4248     let
4249         code = registerCode register tmp
4250         src  = registerName register tmp
4251         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
4252     in
4253     return (Any IntRep code__2)
4254
4255 ------------
4256 trivialFCode _ instr x y
4257   = getRegister x               `thenNat` \ register1 ->
4258     getRegister y               `thenNat` \ register2 ->
4259     getNewRegNat F64    `thenNat` \ tmp1 ->
4260     getNewRegNat F64    `thenNat` \ tmp2 ->
4261     let
4262         code1 = registerCode register1 tmp1
4263         src1  = registerName register1 tmp1
4264
4265         code2 = registerCode register2 tmp2
4266         src2  = registerName register2 tmp2
4267
4268         code__2 dst = asmSeqThen [code1 [], code2 []] .
4269                       mkSeqInstr (instr src1 src2 dst)
4270     in
4271     return (Any F64 code__2)
4272
4273 trivialUFCode _ instr x
4274   = getRegister x               `thenNat` \ register ->
4275     getNewRegNat F64    `thenNat` \ tmp ->
4276     let
4277         code = registerCode register tmp
4278         src  = registerName register tmp
4279         code__2 dst = code . mkSeqInstr (instr src dst)
4280     in
4281     return (Any F64 code__2)
4282
4283 #endif /* alpha_TARGET_ARCH */
4284
4285 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4286
4287 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
4288
4289 {-
4290 The Rules of the Game are:
4291
4292 * You cannot assume anything about the destination register dst;
4293   it may be anything, including a fixed reg.
4294
4295 * You may compute an operand into a fixed reg, but you may not
4296   subsequently change the contents of that fixed reg.  If you
4297   want to do so, first copy the value either to a temporary
4298   or into dst.  You are free to modify dst even if it happens
4299   to be a fixed reg -- that's not your problem.
4300
4301 * You cannot assume that a fixed reg will stay live over an
4302   arbitrary computation.  The same applies to the dst reg.
4303
4304 * Temporary regs obtained from getNewRegNat are distinct from
4305   each other and from all other regs, and stay live over
4306   arbitrary computations.
4307
4308 --------------------
4309
4310 SDM's version of The Rules:
4311
4312 * If getRegister returns Any, that means it can generate correct
4313   code which places the result in any register, period.  Even if that
4314   register happens to be read during the computation.
4315
4316   Corollary #1: this means that if you are generating code for an
4317   operation with two arbitrary operands, you cannot assign the result
4318   of the first operand into the destination register before computing
4319   the second operand.  The second operand might require the old value
4320   of the destination register.
4321
4322   Corollary #2: A function might be able to generate more efficient
4323   code if it knows the destination register is a new temporary (and
4324   therefore not read by any of the sub-computations).
4325
4326 * If getRegister returns Any, then the code it generates may modify only:
4327         (a) fresh temporaries
4328         (b) the destination register
4329         (c) known registers (eg. %ecx is used by shifts)
4330   In particular, it may *not* modify global registers, unless the global
4331   register happens to be the destination register.
4332 -}
4333
4334 trivialCode rep instr (Just revinstr) (CmmLit lit_a) b
4335   | not (is64BitLit lit_a) = do
4336   b_code <- getAnyReg b
4337   let
4338        code dst
4339          = b_code dst `snocOL`
4340            revinstr (OpImm (litToImm lit_a)) (OpReg dst)
4341   -- in
4342   return (Any rep code)
4343
4344 trivialCode rep instr maybe_revinstr a b = genTrivialCode rep instr a b
4345
4346 -- This is re-used for floating pt instructions too.
4347 genTrivialCode rep instr a b = do
4348   (b_op, b_code) <- getNonClobberedOperand b
4349   a_code <- getAnyReg a
4350   tmp <- getNewRegNat rep
4351   let
4352      -- We want the value of b to stay alive across the computation of a.
4353      -- But, we want to calculate a straight into the destination register,
4354      -- because the instruction only has two operands (dst := dst `op` src).
4355      -- The troublesome case is when the result of b is in the same register
4356      -- as the destination reg.  In this case, we have to save b in a
4357      -- new temporary across the computation of a.
4358      code dst
4359         | dst `regClashesWithOp` b_op =
4360                 b_code `appOL`
4361                 unitOL (MOV rep b_op (OpReg tmp)) `appOL`
4362                 a_code dst `snocOL`
4363                 instr (OpReg tmp) (OpReg dst)
4364         | otherwise =
4365                 b_code `appOL`
4366                 a_code dst `snocOL`
4367                 instr b_op (OpReg dst)
4368   -- in
4369   return (Any rep code)
4370
4371 reg `regClashesWithOp` OpReg reg2   = reg == reg2
4372 reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)
4373 reg `regClashesWithOp` _            = False
4374
4375 -----------
4376
4377 trivialUCode rep instr x = do
4378   x_code <- getAnyReg x
4379   let
4380      code dst =
4381         x_code dst `snocOL`
4382         instr (OpReg dst)
4383   -- in
4384   return (Any rep code)
4385
4386 -----------
4387
4388 #if i386_TARGET_ARCH
4389
4390 trivialFCode pk instr x y = do
4391   (x_reg, x_code) <- getNonClobberedReg x -- these work for float regs too
4392   (y_reg, y_code) <- getSomeReg y
4393   let
4394      code dst =
4395         x_code `appOL`
4396         y_code `snocOL`
4397         instr pk x_reg y_reg dst
4398   -- in
4399   return (Any pk code)
4400
4401 #endif
4402
4403 #if x86_64_TARGET_ARCH
4404
4405 trivialFCode pk instr x y = genTrivialCode  pk (instr pk) x y
4406
4407 #endif
4408
4409 -------------
4410
4411 trivialUFCode rep instr x = do
4412   (x_reg, x_code) <- getSomeReg x
4413   let
4414      code dst =
4415         x_code `snocOL`
4416         instr x_reg dst
4417   -- in
4418   return (Any rep code)
4419
4420 #endif /* i386_TARGET_ARCH */
4421
4422 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4423
4424 #if sparc_TARGET_ARCH
4425
4426 trivialCode pk instr x (CmmLit (CmmInt y d))
4427   | fits13Bits y
4428   = do
4429       (src1, code) <- getSomeReg x
4430       tmp <- getNewRegNat I32
4431       let
4432         src2 = ImmInt (fromInteger y)
4433         code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
4434       return (Any I32 code__2)
4435
4436 trivialCode pk instr x y = do
4437     (src1, code1) <- getSomeReg x
4438     (src2, code2) <- getSomeReg y
4439     tmp1 <- getNewRegNat I32
4440     tmp2 <- getNewRegNat I32
4441     let
4442         code__2 dst = code1 `appOL` code2 `snocOL`
4443                       instr src1 (RIReg src2) dst
4444     return (Any I32 code__2)
4445
4446 ------------
4447 trivialFCode pk instr x y = do
4448     (src1, code1) <- getSomeReg x
4449     (src2, code2) <- getSomeReg y
4450     tmp1 <- getNewRegNat (cmmExprRep x)
4451     tmp2 <- getNewRegNat (cmmExprRep y)
4452     tmp <- getNewRegNat F64
4453     let
4454         promote x = FxTOy F32 F64 x tmp
4455
4456         pk1   = cmmExprRep x
4457         pk2   = cmmExprRep y
4458
4459         code__2 dst =
4460                 if pk1 == pk2 then
4461                     code1 `appOL` code2 `snocOL`
4462                     instr pk src1 src2 dst
4463                 else if pk1 == F32 then
4464                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
4465                     instr F64 tmp src2 dst
4466                 else
4467                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
4468                     instr F64 src1 tmp dst
4469     return (Any (if pk1 == pk2 then pk1 else F64) code__2)
4470
4471 ------------
4472 trivialUCode pk instr x = do
4473     (src, code) <- getSomeReg x
4474     tmp <- getNewRegNat pk
4475     let
4476         code__2 dst = code `snocOL` instr (RIReg src) dst
4477     return (Any pk code__2)
4478
4479 -------------
4480 trivialUFCode pk instr x = do
4481     (src, code) <- getSomeReg x
4482     tmp <- getNewRegNat pk
4483     let
4484         code__2 dst = code `snocOL` instr src dst
4485     return (Any pk code__2)
4486
4487 #endif /* sparc_TARGET_ARCH */
4488
4489 #if powerpc_TARGET_ARCH
4490
4491 {-
4492 Wolfgang's PowerPC version of The Rules:
4493
4494 A slightly modified version of The Rules to take advantage of the fact
4495 that PowerPC instructions work on all registers and don't implicitly
4496 clobber any fixed registers.
4497
4498 * The only expression for which getRegister returns Fixed is (CmmReg reg).
4499
4500 * If getRegister returns Any, then the code it generates may modify only:
4501         (a) fresh temporaries
4502         (b) the destination register
4503   It may *not* modify global registers, unless the global
4504   register happens to be the destination register.
4505   It may not clobber any other registers. In fact, only ccalls clobber any
4506   fixed registers.
4507   Also, it may not modify the counter register (used by genCCall).
4508
4509   Corollary: If a getRegister for a subexpression returns Fixed, you need
4510   not move it to a fresh temporary before evaluating the next subexpression.
4511   The Fixed register won't be modified.
4512   Therefore, we don't need a counterpart for the x86's getStableReg on PPC.
4513
4514 * SDM's First Rule is valid for PowerPC, too: subexpressions can depend on
4515   the value of the destination register.
4516 -}
4517
4518 trivialCode rep signed instr x (CmmLit (CmmInt y _))
4519     | Just imm <- makeImmediate rep signed y
4520     = do
4521         (src1, code1) <- getSomeReg x
4522         let code dst = code1 `snocOL` instr dst src1 (RIImm imm)
4523         return (Any rep code)
4524
4525 trivialCode rep signed instr x y = do
4526     (src1, code1) <- getSomeReg x
4527     (src2, code2) <- getSomeReg y
4528     let code dst = code1 `appOL` code2 `snocOL` instr dst src1 (RIReg src2)
4529     return (Any rep code)
4530
4531 trivialCodeNoImm :: MachRep -> (Reg -> Reg -> Reg -> Instr)
4532     -> CmmExpr -> CmmExpr -> NatM Register
4533 trivialCodeNoImm rep instr x y = do
4534     (src1, code1) <- getSomeReg x
4535     (src2, code2) <- getSomeReg y
4536     let code dst = code1 `appOL` code2 `snocOL` instr dst src1 src2
4537     return (Any rep code)
4538
4539 trivialUCode rep instr x = do
4540     (src, code) <- getSomeReg x
4541     let code' dst = code `snocOL` instr dst src
4542     return (Any rep code')
4543
4544 -- There is no "remainder" instruction on the PPC, so we have to do
4545 -- it the hard way.
4546 -- The "div" parameter is the division instruction to use (DIVW or DIVWU)
4547
4548 remainderCode :: MachRep -> (Reg -> Reg -> Reg -> Instr)
4549     -> CmmExpr -> CmmExpr -> NatM Register
4550 remainderCode rep div x y = do
4551     (src1, code1) <- getSomeReg x
4552     (src2, code2) <- getSomeReg y
4553     let code dst = code1 `appOL` code2 `appOL` toOL [
4554                 div dst src1 src2,
4555                 MULLW dst dst (RIReg src2),
4556                 SUBF dst dst src1
4557             ]
4558     return (Any rep code)
4559
4560 #endif /* powerpc_TARGET_ARCH */
4561
4562
4563 -- -----------------------------------------------------------------------------
4564 --  Coercing to/from integer/floating-point...
4565
4566 -- @coerce(Int2FP|FP2Int)@ are more complicated integer/float
4567 -- conversions.  We have to store temporaries in memory to move
4568 -- between the integer and the floating point register sets.
4569
4570 -- @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
4571 -- pretend, on sparc at least, that double and float regs are seperate
4572 -- kinds, so the value has to be computed into one kind before being
4573 -- explicitly "converted" to live in the other kind.
4574
4575 coerceInt2FP :: MachRep -> MachRep -> CmmExpr -> NatM Register
4576 coerceFP2Int :: MachRep -> MachRep -> CmmExpr -> NatM Register
4577
4578 #if sparc_TARGET_ARCH
4579 coerceDbl2Flt :: CmmExpr -> NatM Register
4580 coerceFlt2Dbl :: CmmExpr -> NatM Register
4581 #endif
4582
4583 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4584
4585 #if alpha_TARGET_ARCH
4586
4587 coerceInt2FP _ x
4588   = getRegister x               `thenNat` \ register ->
4589     getNewRegNat IntRep         `thenNat` \ reg ->
4590     let
4591         code = registerCode register reg
4592         src  = registerName register reg
4593
4594         code__2 dst = code . mkSeqInstrs [
4595             ST Q src (spRel 0),
4596             LD TF dst (spRel 0),
4597             CVTxy Q TF dst dst]
4598     in
4599     return (Any F64 code__2)
4600
4601 -------------
4602 coerceFP2Int x
4603   = getRegister x               `thenNat` \ register ->
4604     getNewRegNat F64    `thenNat` \ tmp ->
4605     let
4606         code = registerCode register tmp
4607         src  = registerName register tmp
4608
4609         code__2 dst = code . mkSeqInstrs [
4610             CVTxy TF Q src tmp,
4611             ST TF tmp (spRel 0),
4612             LD Q dst (spRel 0)]
4613     in
4614     return (Any IntRep code__2)
4615
4616 #endif /* alpha_TARGET_ARCH */
4617
4618 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4619
4620 #if i386_TARGET_ARCH
4621
4622 coerceInt2FP from to x = do
4623   (x_reg, x_code) <- getSomeReg x
4624   let
4625         opc  = case to of F32 -> GITOF; F64 -> GITOD
4626         code dst = x_code `snocOL` opc x_reg dst
4627         -- ToDo: works for non-I32 reps?
4628   -- in
4629   return (Any to code)
4630
4631 ------------
4632
4633 coerceFP2Int from to x = do
4634   (x_reg, x_code) <- getSomeReg x
4635   let
4636         opc  = case from of F32 -> GFTOI; F64 -> GDTOI
4637         code dst = x_code `snocOL` opc x_reg dst
4638         -- ToDo: works for non-I32 reps?
4639   -- in
4640   return (Any to code)
4641
4642 #endif /* i386_TARGET_ARCH */
4643
4644 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4645
4646 #if x86_64_TARGET_ARCH
4647
4648 coerceFP2Int from to x = do
4649   (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand
4650   let
4651         opc  = case from of F32 -> CVTSS2SI; F64 -> CVTSD2SI
4652         code dst = x_code `snocOL` opc x_op dst
4653   -- in
4654   return (Any to code) -- works even if the destination rep is <I32
4655
4656 coerceInt2FP from to x = do
4657   (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand
4658   let
4659         opc  = case to of F32 -> CVTSI2SS; F64 -> CVTSI2SD
4660         code dst = x_code `snocOL` opc x_op dst
4661   -- in
4662   return (Any to code) -- works even if the destination rep is <I32
4663
4664 coerceFP2FP :: MachRep -> CmmExpr -> NatM Register
4665 coerceFP2FP to x = do
4666   (x_reg, x_code) <- getSomeReg x
4667   let
4668         opc  = case to of F32 -> CVTSD2SS; F64 -> CVTSS2SD
4669         code dst = x_code `snocOL` opc x_reg dst
4670   -- in
4671   return (Any to code)
4672
4673 #endif
4674
4675 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4676
4677 #if sparc_TARGET_ARCH
4678
4679 coerceInt2FP pk1 pk2 x = do
4680     (src, code) <- getSomeReg x
4681     let
4682         code__2 dst = code `appOL` toOL [
4683             ST pk1 src (spRel (-2)),
4684             LD pk1 (spRel (-2)) dst,
4685             FxTOy pk1 pk2 dst dst]
4686     return (Any pk2 code__2)
4687
4688 ------------
4689 coerceFP2Int pk fprep x = do
4690     (src, code) <- getSomeReg x
4691     reg <- getNewRegNat fprep
4692     tmp <- getNewRegNat pk
4693     let
4694         code__2 dst = ASSERT(fprep == F64 || fprep == F32)
4695             code `appOL` toOL [
4696             FxTOy fprep pk src tmp,
4697             ST pk tmp (spRel (-2)),
4698             LD pk (spRel (-2)) dst]
4699     return (Any pk code__2)
4700
4701 ------------
4702 coerceDbl2Flt x = do
4703     (src, code) <- getSomeReg x
4704     return (Any F32 (\dst -> code `snocOL` FxTOy F64 F32 src dst))
4705
4706 ------------
4707 coerceFlt2Dbl x = do
4708     (src, code) <- getSomeReg x
4709     return (Any F64 (\dst -> code `snocOL` FxTOy F32 F64 src dst))
4710
4711 #endif /* sparc_TARGET_ARCH */
4712
4713 #if powerpc_TARGET_ARCH
4714 coerceInt2FP fromRep toRep x = do
4715     (src, code) <- getSomeReg x
4716     lbl <- getNewLabelNat
4717     itmp <- getNewRegNat I32
4718     ftmp <- getNewRegNat F64
4719     dynRef <- cmmMakeDynamicReference addImportNat DataReference lbl
4720     Amode addr addr_code <- getAmode dynRef
4721     let
4722         code' dst = code `appOL` maybe_exts `appOL` toOL [
4723                 LDATA ReadOnlyData
4724                                 [CmmDataLabel lbl,
4725                                  CmmStaticLit (CmmInt 0x43300000 I32),
4726                                  CmmStaticLit (CmmInt 0x80000000 I32)],
4727                 XORIS itmp src (ImmInt 0x8000),
4728                 ST I32 itmp (spRel 3),
4729                 LIS itmp (ImmInt 0x4330),
4730                 ST I32 itmp (spRel 2),
4731                 LD F64 ftmp (spRel 2)
4732             ] `appOL` addr_code `appOL` toOL [
4733                 LD F64 dst addr,
4734                 FSUB F64 dst ftmp dst
4735             ] `appOL` maybe_frsp dst
4736
4737         maybe_exts = case fromRep of
4738                         I8 ->  unitOL $ EXTS I8 src src
4739                         I16 -> unitOL $ EXTS I16 src src
4740                         I32 -> nilOL
4741         maybe_frsp dst = case toRep of
4742                         F32 -> unitOL $ FRSP dst dst
4743                         F64 -> nilOL
4744     return (Any toRep code')
4745
4746 coerceFP2Int fromRep toRep x = do
4747     -- the reps don't really matter: F*->F64 and I32->I* are no-ops
4748     (src, code) <- getSomeReg x
4749     tmp <- getNewRegNat F64
4750     let
4751         code' dst = code `appOL` toOL [
4752                 -- convert to int in FP reg
4753             FCTIWZ tmp src,
4754                 -- store value (64bit) from FP to stack
4755             ST F64 tmp (spRel 2),
4756                 -- read low word of value (high word is undefined)
4757             LD I32 dst (spRel 3)]
4758     return (Any toRep code')
4759 #endif /* powerpc_TARGET_ARCH */
4760
4761
4762 -- -----------------------------------------------------------------------------
4763 -- eXTRA_STK_ARGS_HERE
4764
4765 -- We (allegedly) put the first six C-call arguments in registers;
4766 -- where do we start putting the rest of them?
4767
4768 -- Moved from MachInstrs (SDM):
4769
4770 #if alpha_TARGET_ARCH || sparc_TARGET_ARCH
4771 eXTRA_STK_ARGS_HERE :: Int
4772 eXTRA_STK_ARGS_HERE
4773   = IF_ARCH_alpha(0, IF_ARCH_sparc(23, ???))
4774 #endif
4775