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