compiler/nativeGen/SPARC/CodeGen.hs

   1 {-# OPTIONS -w #-}
   2 -----------------------------------------------------------------------------
   3 --
   4 -- Generating machine code (instruction selection)
   5 --
   6 -- (c) The University of Glasgow 1996-2004
   7 --
   8 -----------------------------------------------------------------------------
   9
  10 module SPARC.CodeGen (
  11         cmmTopCodeGen,
  12         InstrBlock
  13 )
  14
  15 where
  16
  17 #include "HsVersions.h"
  18 #include "nativeGen/NCG.h"
  19 #include "MachDeps.h"
  20
  21 -- NCG stuff:
  22 import SPARC.Instr
  23 import SPARC.Cond
  24 import SPARC.Regs
  25 import SPARC.RegInfo
  26 import Instruction
  27 import Size
  28 import Reg
  29 import PIC
  30 import NCGMonad
  31
  32 -- Our intermediate code:
  33 import BlockId
  34 import Cmm
  35 import CLabel
  36
  37 -- The rest:
  38 import BasicTypes
  39 import StaticFlags      ( opt_PIC )
  40 import OrdList
  41 import qualified Outputable as O
  42 import Outputable
  43 import FastString
  44
  45 import Control.Monad    ( mapAndUnzipM )
  46 import Data.Int
  47 import DynFlags
  48
  49 -- | Top level code generation
  50 cmmTopCodeGen
  51         :: DynFlags
  52         -> RawCmmTop
  53         -> NatM [NatCmmTop Instr]
  54
  55 cmmTopCodeGen _
  56         (CmmProc info lab params (ListGraph blocks))
  57  = do
  58         (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
  59
  60 --      picBaseMb       <- getPicBaseMaybeNat
  61         let proc        = CmmProc info lab params (ListGraph $ concat nat_blocks)
  62         let tops        = proc : concat statics
  63
  64 --      case picBaseMb of
  65 --       Just picBase -> initializePicBase picBase tops
  66 --       Nothing -> return tops
  67
  68         return tops
  69
  70
  71 cmmTopCodeGen _ (CmmData sec dat) = do
  72   return [CmmData sec dat]  -- no translation, we just use CmmStatic
  73
  74
  75
  76 basicBlockCodeGen
  77         :: CmmBasicBlock
  78         -> NatM ( [NatBasicBlock Instr]
  79                 , [NatCmmTop Instr])
  80
  81 basicBlockCodeGen (BasicBlock id stmts) = do
  82   instrs <- stmtsToInstrs stmts
  83   -- code generation may introduce new basic block boundaries, which
  84   -- are indicated by the NEWBLOCK instruction.  We must split up the
  85   -- instruction stream into basic blocks again.  Also, we extract
  86   -- LDATAs here too.
  87   let
  88         (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
  89
  90         mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
  91           = ([], BasicBlock id instrs : blocks, statics)
  92         mkBlocks (LDATA sec dat) (instrs,blocks,statics)
  93           = (instrs, blocks, CmmData sec dat:statics)
  94         mkBlocks instr (instrs,blocks,statics)
  95           = (instr:instrs, blocks, statics)
  96   -- in
  97   return (BasicBlock id top : other_blocks, statics)
  98
  99
 100 stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
 101 stmtsToInstrs stmts
 102    = do instrss <- mapM stmtToInstrs stmts
 103         return (concatOL instrss)
 104
 105
 106 stmtToInstrs :: CmmStmt -> NatM InstrBlock
 107 stmtToInstrs stmt = case stmt of
 108     CmmNop         -> return nilOL
 109     CmmComment s   -> return (unitOL (COMMENT s))
 110
 111     CmmAssign reg src
 112       | isFloatType ty  -> assignReg_FltCode size reg src
 113       | isWord64 ty     -> assignReg_I64Code      reg src
 114       | otherwise       -> assignReg_IntCode size reg src
 115         where ty = cmmRegType reg
 116               size = cmmTypeSize ty
 117
 118     CmmStore addr src
 119       | isFloatType ty  -> assignMem_FltCode size addr src
 120       | isWord64 ty     -> assignMem_I64Code      addr src
 121       | otherwise       -> assignMem_IntCode size addr src
 122         where ty = cmmExprType src
 123               size = cmmTypeSize ty
 124
 125     CmmCall target result_regs args _ _
 126        -> genCCall target result_regs args
 127
 128     CmmBranch   id              -> genBranch id
 129     CmmCondBranch arg id        -> genCondJump id arg
 130     CmmSwitch   arg ids         -> genSwitch arg ids
 131     CmmJump     arg _           -> genJump arg
 132
 133     CmmReturn   _
 134      -> panic "stmtToInstrs: return statement should have been cps'd away"
 135
 136
 137 --------------------------------------------------------------------------------
 138 -- | 'InstrBlock's are the insn sequences generated by the insn selectors.
 139 --      They are really trees of insns to facilitate fast appending, where a
 140 --      left-to-right traversal yields the insns in the correct order.
 141 --
 142 type InstrBlock
 143         = OrdList Instr
 144
 145
 146 -- | Condition codes passed up the tree.
 147 --
 148 data CondCode
 149         = CondCode Bool Cond InstrBlock
 150
 151
 152 -- | a.k.a "Register64"
 153 --      Reg is the lower 32-bit temporary which contains the result.
 154 --      Use getHiVRegFromLo to find the other VRegUnique.
 155 --
 156 --      Rules of this simplified insn selection game are therefore that
 157 --      the returned Reg may be modified
 158 --
 159 data ChildCode64
 160    = ChildCode64
 161         InstrBlock
 162         Reg
 163
 164
 165 -- | Register's passed up the tree.  If the stix code forces the register
 166 --      to live in a pre-decided machine register, it comes out as @Fixed@;
 167 --      otherwise, it comes out as @Any@, and the parent can decide which
 168 --      register to put it in.
 169 --
 170 data Register
 171         = Fixed Size Reg InstrBlock
 172         | Any   Size (Reg -> InstrBlock)
 173
 174
 175 swizzleRegisterRep :: Register -> Size -> Register
 176 swizzleRegisterRep (Fixed _ reg code) size = Fixed size reg code
 177 swizzleRegisterRep (Any _ codefn)     size = Any   size codefn
 178
 179
 180 -- | Grab the Reg for a CmmReg
 181 getRegisterReg :: CmmReg -> Reg
 182
 183 getRegisterReg (CmmLocal (LocalReg u pk))
 184   = mkVReg u (cmmTypeSize pk)
 185
 186 getRegisterReg (CmmGlobal mid)
 187   = case get_GlobalReg_reg_or_addr mid of
 188        Left (RealReg rrno) -> RealReg rrno
 189        _other -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
 190           -- By this stage, the only MagicIds remaining should be the
 191           -- ones which map to a real machine register on this
 192           -- platform.  Hence ...
 193
 194
 195 -- | Memory addressing modes passed up the tree.
 196 data Amode
 197         = Amode AddrMode InstrBlock
 198
 199 {-
 200 Now, given a tree (the argument to an CmmLoad) that references memory,
 201 produce a suitable addressing mode.
 202
 203 A Rule of the Game (tm) for Amodes: use of the addr bit must
 204 immediately follow use of the code part, since the code part puts
 205 values in registers which the addr then refers to.  So you can't put
 206 anything in between, lest it overwrite some of those registers.  If
 207 you need to do some other computation between the code part and use of
 208 the addr bit, first store the effective address from the amode in a
 209 temporary, then do the other computation, and then use the temporary:
 210
 211     code
 212     LEA amode, tmp
 213     ... other computation ...
 214     ... (tmp) ...
 215 -}
 216
 217
 218 -- | Check whether an integer will fit in 32 bits.
 219 --      A CmmInt is intended to be truncated to the appropriate
 220 --      number of bits, so here we truncate it to Int64.  This is
 221 --      important because e.g. -1 as a CmmInt might be either
 222 --      -1 or 18446744073709551615.
 223 --
 224 is32BitInteger :: Integer -> Bool
 225 is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000
 226   where i64 = fromIntegral i :: Int64
 227
 228
 229 -- | Convert a BlockId to some CmmStatic data
 230 jumpTableEntry :: Maybe BlockId -> CmmStatic
 231 jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth)
 232 jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel)
 233     where blockLabel = mkAsmTempLabel id
 234
 235
 236
 237
 238 -- -----------------------------------------------------------------------------
 239 -- General things for putting together code sequences
 240
 241 -- Expand CmmRegOff.  ToDo: should we do it this way around, or convert
 242 -- CmmExprs into CmmRegOff?
 243 mangleIndexTree :: CmmExpr -> CmmExpr
 244 mangleIndexTree (CmmRegOff reg off)
 245   = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
 246   where width = typeWidth (cmmRegType reg)
 247
 248
 249 assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
 250 assignMem_I64Code addrTree valueTree = do
 251      Amode _ addr_code          <- getAmode addrTree
 252      ChildCode64 vcode rlo      <- iselExpr64 valueTree
 253
 254      (src, code) <- getSomeReg addrTree
 255      let
 256          rhi = getHiVRegFromLo rlo
 257          -- Big-endian store
 258          mov_hi = ST II32 rhi (AddrRegImm src (ImmInt 0))
 259          mov_lo = ST II32 rlo (AddrRegImm src (ImmInt 4))
 260
 261      return (vcode `appOL` code `snocOL` mov_hi `snocOL` mov_lo)
 262
 263
 264 assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock
 265 assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do
 266      ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
 267      let
 268          r_dst_lo = mkVReg u_dst (cmmTypeSize pk)
 269          r_dst_hi = getHiVRegFromLo r_dst_lo
 270          r_src_hi = getHiVRegFromLo r_src_lo
 271          mov_lo = mkMOV r_src_lo r_dst_lo
 272          mov_hi = mkMOV r_src_hi r_dst_hi
 273          mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
 274      return (vcode `snocOL` mov_hi `snocOL` mov_lo)
 275 assignReg_I64Code lvalue valueTree
 276    = panic "assignReg_I64Code(sparc): invalid lvalue"
 277
 278
 279 -- Load a 64 bit word
 280 iselExpr64 (CmmLoad addrTree ty)
 281  | isWord64 ty
 282  = do   Amode amode addr_code   <- getAmode addrTree
 283         let result
 284
 285                 | AddrRegReg r1 r2      <- amode
 286                 = do    rlo     <- getNewRegNat II32
 287                         tmp     <- getNewRegNat II32
 288                         let rhi = getHiVRegFromLo rlo
 289
 290                         return  $ ChildCode64
 291                                 (        addr_code
 292                                 `appOL`  toOL
 293                                          [ ADD False False r1 (RIReg r2) tmp
 294                                          , LD II32 (AddrRegImm tmp (ImmInt 0)) rhi
 295                                          , LD II32 (AddrRegImm tmp (ImmInt 4)) rlo ])
 296                                 rlo
 297
 298                 | AddrRegImm r1 (ImmInt i) <- amode
 299                 = do    rlo     <- getNewRegNat II32
 300                         let rhi = getHiVRegFromLo rlo
 301
 302                         return  $ ChildCode64
 303                                 (        addr_code
 304                                 `appOL`  toOL
 305                                          [ LD II32 (AddrRegImm r1 (ImmInt $ 0 + i)) rhi
 306                                          , LD II32 (AddrRegImm r1 (ImmInt $ 4 + i)) rlo ])
 307                                 rlo
 308
 309         result
 310
 311
 312 -- Add a literal to a 64 bit integer
 313 iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)])
 314  = do   ChildCode64 code1 r1_lo <- iselExpr64 e1
 315         let r1_hi       = getHiVRegFromLo r1_lo
 316
 317         r_dst_lo        <- getNewRegNat II32
 318         let r_dst_hi    =  getHiVRegFromLo r_dst_lo
 319
 320         return  $ ChildCode64
 321                         ( toOL
 322                         [ ADD False False r1_lo (RIImm (ImmInteger i)) r_dst_lo
 323                         , ADD True  False r1_hi (RIReg g0)         r_dst_hi ])
 324                         r_dst_lo
 325
 326
 327 -- Addition of II64
 328 iselExpr64 (CmmMachOp (MO_Add width) [e1, e2])
 329  = do   ChildCode64 code1 r1_lo <- iselExpr64 e1
 330         let r1_hi       = getHiVRegFromLo r1_lo
 331
 332         ChildCode64 code2 r2_lo <- iselExpr64 e2
 333         let r2_hi       = getHiVRegFromLo r2_lo
 334
 335         r_dst_lo        <- getNewRegNat II32
 336         let r_dst_hi    = getHiVRegFromLo r_dst_lo
 337
 338         let code =      code1
 339                 `appOL` code2
 340                 `appOL` toOL
 341                         [ ADD False False r1_lo (RIReg r2_lo) r_dst_lo
 342                         , ADD True  False r1_hi (RIReg r2_hi) r_dst_hi ]
 343
 344         return  $ ChildCode64 code r_dst_lo
 345
 346
 347 iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty))) | isWord64 ty = do
 348      r_dst_lo <-  getNewRegNat II32
 349      let r_dst_hi = getHiVRegFromLo r_dst_lo
 350          r_src_lo = mkVReg uq II32
 351          r_src_hi = getHiVRegFromLo r_src_lo
 352          mov_lo = mkMOV r_src_lo r_dst_lo
 353          mov_hi = mkMOV r_src_hi r_dst_hi
 354          mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
 355      return (
 356             ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo
 357          )
 358
 359 -- Convert something into II64
 360 iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr])
 361  = do
 362         r_dst_lo        <- getNewRegNat II32
 363         let r_dst_hi    = getHiVRegFromLo r_dst_lo
 364
 365         -- compute expr and load it into r_dst_lo
 366         (a_reg, a_code) <- getSomeReg expr
 367
 368         let code        = a_code
 369                 `appOL` toOL
 370                         [ mkRegRegMoveInstr g0    r_dst_hi      -- clear high 32 bits
 371                         , mkRegRegMoveInstr a_reg r_dst_lo ]
 372
 373         return  $ ChildCode64 code r_dst_lo
 374
 375
 376 iselExpr64 expr
 377    = pprPanic "iselExpr64(sparc)" (ppr expr)
 378
 379
 380 -- | The dual to getAnyReg: compute an expression into a register, but
 381 --      we don't mind which one it is.
 382 getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
 383 getSomeReg expr = do
 384   r <- getRegister expr
 385   case r of
 386     Any rep code -> do
 387         tmp <- getNewRegNat rep
 388         return (tmp, code tmp)
 389     Fixed _ reg code ->
 390         return (reg, code)
 391
 392
 393 --
 394 getRegister :: CmmExpr -> NatM Register
 395
 396 getRegister (CmmReg reg)
 397   = return (Fixed (cmmTypeSize (cmmRegType reg))
 398                   (getRegisterReg reg) nilOL)
 399
 400 getRegister tree@(CmmRegOff _ _)
 401   = getRegister (mangleIndexTree tree)
 402
 403 getRegister (CmmMachOp (MO_UU_Conv W64 W32)
 404              [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
 405   ChildCode64 code rlo <- iselExpr64 x
 406   return $ Fixed II32 (getHiVRegFromLo rlo) code
 407
 408 getRegister (CmmMachOp (MO_SS_Conv W64 W32)
 409              [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
 410   ChildCode64 code rlo <- iselExpr64 x
 411   return $ Fixed II32 (getHiVRegFromLo rlo) code
 412
 413 getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do
 414   ChildCode64 code rlo <- iselExpr64 x
 415   return $ Fixed II32 rlo code
 416
 417 getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do
 418   ChildCode64 code rlo <- iselExpr64 x
 419   return $ Fixed II32 rlo code
 420
 421
 422
 423 -- Load a literal float into a float register.
 424 --      The actual literal is stored in a new data area, and we load it
 425 --      at runtime.
 426 getRegister (CmmLit (CmmFloat f W32)) = do
 427
 428     -- a label for the new data area
 429     lbl <- getNewLabelNat
 430     tmp <- getNewRegNat II32
 431
 432     let code dst = toOL [
 433             -- the data area
 434             LDATA ReadOnlyData
 435                         [CmmDataLabel lbl,
 436                          CmmStaticLit (CmmFloat f W32)],
 437
 438             -- load the literal
 439             SETHI (HI (ImmCLbl lbl)) tmp,
 440             LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
 441
 442     return (Any FF32 code)
 443
 444 getRegister (CmmLit (CmmFloat d W64)) = do
 445     lbl <- getNewLabelNat
 446     tmp <- getNewRegNat II32
 447     let code dst = toOL [
 448             LDATA ReadOnlyData
 449                         [CmmDataLabel lbl,
 450                          CmmStaticLit (CmmFloat d W64)],
 451             SETHI (HI (ImmCLbl lbl)) tmp,
 452             LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
 453     return (Any FF64 code)
 454
 455 getRegister (CmmMachOp mop [x]) -- unary MachOps
 456   = case mop of
 457       MO_F_Neg W32     -> trivialUFCode FF32 (FNEG FF32) x
 458       MO_F_Neg W64     -> trivialUFCode FF64 (FNEG FF64) x
 459
 460       MO_S_Neg rep     -> trivialUCode (intSize rep) (SUB False False g0) x
 461       MO_Not rep       -> trivialUCode (intSize rep) (XNOR False g0) x
 462
 463       MO_FF_Conv W64 W32-> coerceDbl2Flt x
 464       MO_FF_Conv W32 W64-> coerceFlt2Dbl x
 465
 466       MO_FS_Conv from to -> coerceFP2Int from to x
 467       MO_SF_Conv from to -> coerceInt2FP from to x
 468
 469       -- Conversions which are a nop on sparc
 470       MO_UU_Conv from to
 471         | from == to    -> conversionNop (intSize to)  x
 472       MO_UU_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8))
 473       MO_UU_Conv W32 to -> conversionNop (intSize to) x
 474       MO_SS_Conv W32 to -> conversionNop (intSize to) x
 475
 476       MO_UU_Conv W8  to@W32  -> conversionNop (intSize to)  x
 477       MO_UU_Conv W16 to@W32  -> conversionNop (intSize to)  x
 478       MO_UU_Conv W8  to@W16  -> conversionNop (intSize to)  x
 479
 480       -- sign extension
 481       MO_SS_Conv W8  W32  -> integerExtend W8  W32 x
 482       MO_SS_Conv W16 W32  -> integerExtend W16 W32 x
 483       MO_SS_Conv W8  W16  -> integerExtend W8  W16 x
 484
 485       other_op -> panic ("Unknown unary mach op: " ++ show mop)
 486     where
 487
 488         -- | sign extend and widen
 489         integerExtend
 490                 :: Width                -- ^ width of source expression
 491                 -> Width                -- ^ width of result
 492                 -> CmmExpr              -- ^ source expression
 493                 -> NatM Register
 494
 495         integerExtend from to expr
 496          = do   -- load the expr into some register
 497                 (reg, e_code)   <- getSomeReg expr
 498                 tmp             <- getNewRegNat II32
 499                 let bitCount
 500                         = case (from, to) of
 501                                 (W8,  W32)      -> 24
 502                                 (W16, W32)      -> 16
 503                                 (W8,  W16)      -> 24
 504                 let code dst
 505                         = e_code
 506
 507                         -- local shift word left to load the sign bit
 508                         `snocOL`  SLL reg (RIImm (ImmInt bitCount)) tmp
 509
 510                         -- arithmetic shift right to sign extend
 511                         `snocOL`  SRA tmp (RIImm (ImmInt bitCount)) dst
 512
 513                 return (Any (intSize to) code)
 514
 515
 516         conversionNop new_rep expr
 517             = do e_code <- getRegister expr
 518                  return (swizzleRegisterRep e_code new_rep)
 519
 520 getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps
 521   = case mop of
 522       MO_Eq rep -> condIntReg EQQ x y
 523       MO_Ne rep -> condIntReg NE x y
 524
 525       MO_S_Gt rep -> condIntReg GTT x y
 526       MO_S_Ge rep -> condIntReg GE x y
 527       MO_S_Lt rep -> condIntReg LTT x y
 528       MO_S_Le rep -> condIntReg LE x y
 529
 530       MO_U_Gt W32  -> condIntReg GTT x y
 531       MO_U_Ge W32  -> condIntReg GE x y
 532       MO_U_Lt W32  -> condIntReg LTT x y
 533       MO_U_Le W32  -> condIntReg LE x y
 534
 535       MO_U_Gt W16 -> condIntReg GU  x y
 536       MO_U_Ge W16 -> condIntReg GEU x y
 537       MO_U_Lt W16 -> condIntReg LU  x y
 538       MO_U_Le W16 -> condIntReg LEU x y
 539
 540       MO_Add W32 -> trivialCode W32 (ADD False False) x y
 541       MO_Sub W32 -> trivialCode W32 (SUB False False) x y
 542
 543       MO_S_MulMayOflo rep -> imulMayOflo rep x y
 544
 545       MO_S_Quot W32     -> idiv True  False x y
 546       MO_U_Quot W32     -> idiv False False x y
 547
 548       MO_S_Rem  W32     -> irem True  x y
 549       MO_U_Rem  W32     -> irem False x y
 550
 551       MO_F_Eq w -> condFltReg EQQ x y
 552       MO_F_Ne w -> condFltReg NE x y
 553
 554       MO_F_Gt w -> condFltReg GTT x y
 555       MO_F_Ge w -> condFltReg GE x y
 556       MO_F_Lt w -> condFltReg LTT x y
 557       MO_F_Le w -> condFltReg LE x y
 558
 559       MO_F_Add  w  -> trivialFCode w FADD x y
 560       MO_F_Sub  w  -> trivialFCode w FSUB x y
 561       MO_F_Mul  w  -> trivialFCode w FMUL x y
 562       MO_F_Quot w  -> trivialFCode w FDIV x y
 563
 564       MO_And rep   -> trivialCode rep (AND False) x y
 565       MO_Or rep    -> trivialCode rep (OR  False) x y
 566       MO_Xor rep   -> trivialCode rep (XOR False) x y
 567
 568       MO_Mul rep -> trivialCode rep (SMUL False) x y
 569
 570       MO_Shl rep   -> trivialCode rep SLL  x y
 571       MO_U_Shr rep   -> trivialCode rep SRL x y
 572       MO_S_Shr rep   -> trivialCode rep SRA x y
 573
 574 {-
 575       MO_F32_Pwr  -> getRegister (StCall (Left (fsLit "pow")) CCallConv FF64
 576                                          [promote x, promote y])
 577                        where promote x = CmmMachOp MO_F32_to_Dbl [x]
 578       MO_F64_Pwr -> getRegister (StCall (Left (fsLit "pow")) CCallConv FF64
 579                                         [x, y])
 580 -}
 581       other -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop)
 582   where
 583     -- idiv fn x y = getRegister (StCall (Left fn) CCallConv II32 [x, y])
 584
 585
 586     -- | Generate an integer division instruction.
 587     idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register
 588
 589     -- For unsigned division with a 32 bit numerator,
 590     --          we can just clear the Y register.
 591     idiv False cc x y = do
 592         (a_reg, a_code)         <- getSomeReg x
 593         (b_reg, b_code)         <- getSomeReg y
 594
 595         let code dst
 596                 =       a_code
 597                 `appOL` b_code
 598                 `appOL` toOL
 599                         [ WRY  g0 g0
 600                         , UDIV cc a_reg (RIReg b_reg) dst]
 601
 602         return (Any II32 code)
 603
 604
 605     -- For _signed_ division with a 32 bit numerator,
 606     --          we have to sign extend the numerator into the Y register.
 607     idiv True cc x y = do
 608         (a_reg, a_code)         <- getSomeReg x
 609         (b_reg, b_code)         <- getSomeReg y
 610
 611         tmp                     <- getNewRegNat II32
 612
 613         let code dst
 614                 =       a_code
 615                 `appOL` b_code
 616                 `appOL` toOL
 617                         [ SRA  a_reg (RIImm (ImmInt 16)) tmp            -- sign extend
 618                         , SRA  tmp   (RIImm (ImmInt 16)) tmp
 619
 620                         , WRY  tmp g0
 621                         , SDIV cc a_reg (RIReg b_reg) dst]
 622
 623         return (Any II32 code)
 624
 625
 626     -- | Do an integer remainder.
 627     --
 628     --   NOTE:  The SPARC v8 architecture manual says that integer division
 629     --          instructions _may_ generate a remainder, depending on the implementation.
 630     --          If so it is _recommended_ that the remainder is placed in the Y register.
 631     --
 632     --          The UltraSparc 2007 manual says Y is _undefined_ after division.
 633     --
 634     --          The SPARC T2 doesn't store the remainder, not sure about the others.
 635     --          It's probably best not to worry about it, and just generate our own
 636     --          remainders.
 637     --
 638     irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register
 639
 640     -- For unsigned operands:
 641     --          Division is between a 64 bit numerator and a 32 bit denominator,
 642     --          so we still have to clear the Y register.
 643     irem False x y = do
 644         (a_reg, a_code) <- getSomeReg x
 645         (b_reg, b_code) <- getSomeReg y
 646
 647         tmp_reg         <- getNewRegNat II32
 648
 649         let code dst
 650                 =       a_code
 651                 `appOL` b_code
 652                 `appOL` toOL
 653                         [ WRY   g0 g0
 654                         , UDIV  False         a_reg (RIReg b_reg) tmp_reg
 655                         , UMUL  False       tmp_reg (RIReg b_reg) tmp_reg
 656                         , SUB   False False   a_reg (RIReg tmp_reg) dst]
 657
 658         return  (Any II32 code)
 659
 660
 661     -- For signed operands:
 662     --          Make sure to sign extend into the Y register, or the remainder
 663     --          will have the wrong sign when the numerator is negative.
 664     --
 665     --  TODO:   When sign extending, GCC only shifts the a_reg right by 17 bits,
 666     --          not the full 32. Not sure why this is, something to do with overflow?
 667     --          If anyone cares enough about the speed of signed remainder they
 668     --          can work it out themselves (then tell me). -- BL 2009/01/20
 669
 670     irem True x y = do
 671         (a_reg, a_code) <- getSomeReg x
 672         (b_reg, b_code) <- getSomeReg y
 673
 674         tmp1_reg        <- getNewRegNat II32
 675         tmp2_reg        <- getNewRegNat II32
 676
 677         let code dst
 678                 =       a_code
 679                 `appOL` b_code
 680                 `appOL` toOL
 681                         [ SRA   a_reg      (RIImm (ImmInt 16)) tmp1_reg -- sign extend
 682                         , SRA   tmp1_reg   (RIImm (ImmInt 16)) tmp1_reg -- sign extend
 683                         , WRY   tmp1_reg g0
 684
 685                         , SDIV  False          a_reg (RIReg b_reg)    tmp2_reg
 686                         , SMUL  False       tmp2_reg (RIReg b_reg)    tmp2_reg
 687                         , SUB   False False    a_reg (RIReg tmp2_reg) dst]
 688
 689         return (Any II32 code)
 690
 691
 692     imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
 693     imulMayOflo rep a b = do
 694          (a_reg, a_code) <- getSomeReg a
 695          (b_reg, b_code) <- getSomeReg b
 696          res_lo <- getNewRegNat II32
 697          res_hi <- getNewRegNat II32
 698          let
 699             shift_amt  = case rep of
 700                           W32 -> 31
 701                           W64 -> 63
 702                           _ -> panic "shift_amt"
 703             code dst = a_code `appOL` b_code `appOL`
 704                        toOL [
 705                            SMUL False a_reg (RIReg b_reg) res_lo,
 706                            RDY res_hi,
 707                            SRA res_lo (RIImm (ImmInt shift_amt)) res_lo,
 708                            SUB False False res_lo (RIReg res_hi) dst
 709                         ]
 710          return (Any II32 code)
 711
 712 getRegister (CmmLoad mem pk) = do
 713     Amode src code <- getAmode mem
 714     let
 715         code__2 dst     = code `snocOL` LD (cmmTypeSize pk) src dst
 716     return (Any (cmmTypeSize pk) code__2)
 717
 718 getRegister (CmmLit (CmmInt i _))
 719   | fits13Bits i
 720   = let
 721         src = ImmInt (fromInteger i)
 722         code dst = unitOL (OR False g0 (RIImm src) dst)
 723     in
 724         return (Any II32 code)
 725
 726 getRegister (CmmLit lit)
 727   = let rep = cmmLitType lit
 728         imm = litToImm lit
 729         code dst = toOL [
 730             SETHI (HI imm) dst,
 731             OR False dst (RIImm (LO imm)) dst]
 732     in return (Any II32 code)
 733
 734
 735
 736 getAmode :: CmmExpr -> NatM Amode
 737 getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree)
 738
 739 getAmode (CmmMachOp (MO_Sub rep) [x, CmmLit (CmmInt i _)])
 740   | fits13Bits (-i)
 741   = do
 742        (reg, code) <- getSomeReg x
 743        let
 744          off  = ImmInt (-(fromInteger i))
 745        return (Amode (AddrRegImm reg off) code)
 746
 747
 748 getAmode (CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt i _)])
 749   | fits13Bits i
 750   = do
 751        (reg, code) <- getSomeReg x
 752        let
 753          off  = ImmInt (fromInteger i)
 754        return (Amode (AddrRegImm reg off) code)
 755
 756 getAmode (CmmMachOp (MO_Add rep) [x, y])
 757   = do
 758     (regX, codeX) <- getSomeReg x
 759     (regY, codeY) <- getSomeReg y
 760     let
 761         code = codeX `appOL` codeY
 762     return (Amode (AddrRegReg regX regY) code)
 763
 764 getAmode (CmmLit lit)
 765   = do
 766         let imm__2      = litToImm lit
 767         tmp1    <- getNewRegNat II32
 768         tmp2    <- getNewRegNat II32
 769
 770         let code = toOL [ SETHI (HI imm__2) tmp1
 771                         , OR    False tmp1 (RIImm (LO imm__2)) tmp2]
 772
 773         return (Amode (AddrRegReg tmp2 g0) code)
 774
 775 getAmode other
 776   = do
 777        (reg, code) <- getSomeReg other
 778        let
 779             off  = ImmInt 0
 780        return (Amode (AddrRegImm reg off) code)
 781
 782
 783 getCondCode :: CmmExpr -> NatM CondCode
 784 getCondCode (CmmMachOp mop [x, y])
 785   =
 786     case mop of
 787       MO_F_Eq W32 -> condFltCode EQQ x y
 788       MO_F_Ne W32 -> condFltCode NE  x y
 789       MO_F_Gt W32 -> condFltCode GTT x y
 790       MO_F_Ge W32 -> condFltCode GE  x y
 791       MO_F_Lt W32 -> condFltCode LTT x y
 792       MO_F_Le W32 -> condFltCode LE  x y
 793
 794       MO_F_Eq W64 -> condFltCode EQQ x y
 795       MO_F_Ne W64 -> condFltCode NE  x y
 796       MO_F_Gt W64 -> condFltCode GTT x y
 797       MO_F_Ge W64 -> condFltCode GE  x y
 798       MO_F_Lt W64 -> condFltCode LTT x y
 799       MO_F_Le W64 -> condFltCode LE  x y
 800
 801       MO_Eq rep -> condIntCode EQQ  x y
 802       MO_Ne rep -> condIntCode NE   x y
 803
 804       MO_S_Gt rep -> condIntCode GTT  x y
 805       MO_S_Ge rep -> condIntCode GE   x y
 806       MO_S_Lt rep -> condIntCode LTT  x y
 807       MO_S_Le rep -> condIntCode LE   x y
 808
 809       MO_U_Gt rep -> condIntCode GU   x y
 810       MO_U_Ge rep -> condIntCode GEU  x y
 811       MO_U_Lt rep -> condIntCode LU   x y
 812       MO_U_Le rep -> condIntCode LEU  x y
 813
 814       other -> pprPanic "getCondCode(x86,x86_64,sparc)" (ppr (CmmMachOp mop [x,y]))
 815
 816 getCondCode other =  pprPanic "getCondCode(2)(x86,sparc)" (ppr other)
 817
 818
 819
 820
 821
 822 -- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
 823 -- passed back up the tree.
 824
 825 condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
 826 condIntCode cond x (CmmLit (CmmInt y rep))
 827   | fits13Bits y
 828   = do
 829        (src1, code) <- getSomeReg x
 830        let
 831            src2 = ImmInt (fromInteger y)
 832            code' = code `snocOL` SUB False True src1 (RIImm src2) g0
 833        return (CondCode False cond code')
 834
 835 condIntCode cond x y = do
 836     (src1, code1) <- getSomeReg x
 837     (src2, code2) <- getSomeReg y
 838     let
 839         code__2 = code1 `appOL` code2 `snocOL`
 840                   SUB False True src1 (RIReg src2) g0
 841     return (CondCode False cond code__2)
 842
 843
 844 condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
 845 condFltCode cond x y = do
 846     (src1, code1) <- getSomeReg x
 847     (src2, code2) <- getSomeReg y
 848     tmp <- getNewRegNat FF64
 849     let
 850         promote x = FxTOy FF32 FF64 x tmp
 851
 852         pk1   = cmmExprType x
 853         pk2   = cmmExprType y
 854
 855         code__2 =
 856                 if pk1 `cmmEqType` pk2 then
 857                     code1 `appOL` code2 `snocOL`
 858                     FCMP True (cmmTypeSize pk1) src1 src2
 859                 else if typeWidth pk1 == W32 then
 860                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
 861                     FCMP True FF64 tmp src2
 862                 else
 863                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
 864                     FCMP True FF64 src1 tmp
 865     return (CondCode True cond code__2)
 866
 867
 868
 869 -- -----------------------------------------------------------------------------
 870 -- Generating assignments
 871
 872 -- Assignments are really at the heart of the whole code generation
 873 -- business.  Almost all top-level nodes of any real importance are
 874 -- assignments, which correspond to loads, stores, or register
 875 -- transfers.  If we're really lucky, some of the register transfers
 876 -- will go away, because we can use the destination register to
 877 -- complete the code generation for the right hand side.  This only
 878 -- fails when the right hand side is forced into a fixed register
 879 -- (e.g. the result of a call).
 880
 881 assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
 882 assignMem_IntCode pk addr src = do
 883     (srcReg, code) <- getSomeReg src
 884     Amode dstAddr addr_code <- getAmode addr
 885     return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
 886
 887
 888 assignReg_IntCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock
 889 assignReg_IntCode pk reg src = do
 890     r <- getRegister src
 891     return $ case r of
 892         Any _ code         -> code dst
 893         Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst
 894     where
 895       dst = getRegisterReg reg
 896
 897
 898
 899 -- Floating point assignment to memory
 900 assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
 901 assignMem_FltCode pk addr src = do
 902     Amode dst__2 code1 <- getAmode addr
 903     (src__2, code2) <- getSomeReg src
 904     tmp1 <- getNewRegNat pk
 905     let
 906         pk__2   = cmmExprType src
 907         code__2 = code1 `appOL` code2 `appOL`
 908             if   sizeToWidth pk == typeWidth pk__2
 909             then unitOL (ST pk src__2 dst__2)
 910             else toOL   [ FxTOy (cmmTypeSize pk__2) pk src__2 tmp1
 911                         , ST    pk tmp1 dst__2]
 912     return code__2
 913
 914 -- Floating point assignment to a register/temporary
 915 assignReg_FltCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock
 916 assignReg_FltCode pk dstCmmReg srcCmmExpr = do
 917     srcRegister <- getRegister srcCmmExpr
 918     let dstReg  = getRegisterReg dstCmmReg
 919
 920     return $ case srcRegister of
 921         Any _ code                  -> code dstReg
 922         Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg
 923
 924
 925
 926
 927 genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
 928
 929 genJump (CmmLit (CmmLabel lbl))
 930   = return (toOL [CALL (Left target) 0 True, NOP])
 931   where
 932     target = ImmCLbl lbl
 933
 934 genJump tree
 935   = do
 936         (target, code) <- getSomeReg tree
 937         return (code `snocOL` JMP (AddrRegReg target g0)  `snocOL` NOP)
 938
 939 -- -----------------------------------------------------------------------------
 940 --  Unconditional branches
 941
 942 genBranch :: BlockId -> NatM InstrBlock
 943 genBranch = return . toOL . mkJumpInstr
 944
 945
 946 -- -----------------------------------------------------------------------------
 947 --  Conditional jumps
 948
 949 {-
 950 Conditional jumps are always to local labels, so we can use branch
 951 instructions.  We peek at the arguments to decide what kind of
 952 comparison to do.
 953
 954 SPARC: First, we have to ensure that the condition codes are set
 955 according to the supplied comparison operation.  We generate slightly
 956 different code for floating point comparisons, because a floating
 957 point operation cannot directly precede a @BF@.  We assume the worst
 958 and fill that slot with a @NOP@.
 959
 960 SPARC: Do not fill the delay slots here; you will confuse the register
 961 allocator.
 962 -}
 963
 964
 965 genCondJump
 966     :: BlockId      -- the branch target
 967     -> CmmExpr      -- the condition on which to branch
 968     -> NatM InstrBlock
 969
 970
 971
 972 genCondJump bid bool = do
 973   CondCode is_float cond code <- getCondCode bool
 974   return (
 975        code `appOL`
 976        toOL (
 977          if   is_float
 978          then [NOP, BF cond False bid, NOP]
 979          else [BI cond False bid, NOP]
 980        )
 981     )
 982
 983
 984
 985 -- -----------------------------------------------------------------------------
 986 --  Generating C calls
 987
 988 -- Now the biggest nightmare---calls.  Most of the nastiness is buried in
 989 -- @get_arg@, which moves the arguments to the correct registers/stack
 990 -- locations.  Apart from that, the code is easy.
 991 --
 992 -- (If applicable) Do not fill the delay slots here; you will confuse the
 993 -- register allocator.
 994
 995 genCCall
 996     :: CmmCallTarget            -- function to call
 997     -> HintedCmmFormals         -- where to put the result
 998     -> HintedCmmActuals         -- arguments (of mixed type)
 999     -> NatM InstrBlock
1000
1001
1002 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1003
1004 {-
1005    The SPARC calling convention is an absolute
1006    nightmare.  The first 6x32 bits of arguments are mapped into
1007    %o0 through %o5, and the remaining arguments are dumped to the
1008    stack, beginning at [%sp+92].  (Note that %o6 == %sp.)
1009
1010    If we have to put args on the stack, move %o6==%sp down by
1011    the number of words to go on the stack, to ensure there's enough space.
1012
1013    According to Fraser and Hanson's lcc book, page 478, fig 17.2,
1014    16 words above the stack pointer is a word for the address of
1015    a structure return value.  I use this as a temporary location
1016    for moving values from float to int regs.  Certainly it isn't
1017    safe to put anything in the 16 words starting at %sp, since
1018    this area can get trashed at any time due to window overflows
1019    caused by signal handlers.
1020
1021    A final complication (if the above isn't enough) is that
1022    we can't blithely calculate the arguments one by one into
1023    %o0 .. %o5.  Consider the following nested calls:
1024
1025        fff a (fff b c)
1026
1027    Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately
1028    the inner call will itself use %o0, which trashes the value put there
1029    in preparation for the outer call.  Upshot: we need to calculate the
1030    args into temporary regs, and move those to arg regs or onto the
1031    stack only immediately prior to the call proper.  Sigh.
1032
1033 genCCall
1034     :: CmmCallTarget            -- function to call
1035     -> HintedCmmFormals         -- where to put the result
1036     -> HintedCmmActuals         -- arguments (of mixed type)
1037     -> NatM InstrBlock
1038
1039 -}
1040
1041
1042 -- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream
1043 -- are guaranteed to take place before writes afterwards (unlike on PowerPC).
1044 -- Ref: Section 8.4 of the SPARC V9 Architecture manual.
1045 --
1046 -- In the SPARC case we don't need a barrier.
1047 --
1048 genCCall (CmmPrim (MO_WriteBarrier)) _ _
1049  = do   return nilOL
1050
1051 genCCall target dest_regs argsAndHints
1052  = do
1053         -- strip hints from the arg regs
1054         let args :: [CmmExpr]
1055             args  = map hintlessCmm argsAndHints
1056
1057
1058         -- work out the arguments, and assign them to integer regs
1059         argcode_and_vregs       <- mapM arg_to_int_vregs args
1060         let (argcodes, vregss)  = unzip argcode_and_vregs
1061         let vregs               = concat vregss
1062
1063         let n_argRegs           = length allArgRegs
1064         let n_argRegs_used      = min (length vregs) n_argRegs
1065
1066
1067         -- deal with static vs dynamic call targets
1068         callinsns <- case target of
1069                 CmmCallee (CmmLit (CmmLabel lbl)) conv ->
1070                         return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
1071
1072                 CmmCallee expr conv
1073                  -> do  (dyn_c, [dyn_r]) <- arg_to_int_vregs expr
1074                         return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
1075
1076                 CmmPrim mop
1077                  -> do  res     <- outOfLineFloatOp mop
1078                         lblOrMopExpr <- case res of
1079                                 Left lbl -> do
1080                                         return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
1081
1082                                 Right mopExpr -> do
1083                                         (dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr
1084                                         return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
1085
1086                         return lblOrMopExpr
1087
1088         let argcode = concatOL argcodes
1089
1090         let (move_sp_down, move_sp_up)
1091                    = let diff = length vregs - n_argRegs
1092                          nn   = if odd diff then diff + 1 else diff -- keep 8-byte alignment
1093                      in  if   nn <= 0
1094                          then (nilOL, nilOL)
1095                          else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
1096
1097         let transfer_code
1098                 = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
1099
1100         return
1101          $      argcode                 `appOL`
1102                 move_sp_down            `appOL`
1103                 transfer_code           `appOL`
1104                 callinsns               `appOL`
1105                 unitOL NOP              `appOL`
1106                 move_sp_up              `appOL`
1107                 assign_code dest_regs
1108
1109
1110 -- | Generate code to calculate an argument, and move it into one
1111 --      or two integer vregs.
1112 arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg])
1113 arg_to_int_vregs arg
1114
1115         -- If the expr produces a 64 bit int, then we can just use iselExpr64
1116         | isWord64 (cmmExprType arg)
1117         = do    (ChildCode64 code r_lo) <- iselExpr64 arg
1118                 let r_hi                = getHiVRegFromLo r_lo
1119                 return (code, [r_hi, r_lo])
1120
1121         | otherwise
1122         = do    (src, code)     <- getSomeReg arg
1123                 tmp             <- getNewRegNat (cmmTypeSize $ cmmExprType arg)
1124                 let pk          = cmmExprType arg
1125
1126                 case cmmTypeSize pk of
1127
1128                  -- Load a 64 bit float return value into two integer regs.
1129                  FF64 -> do
1130                         v1 <- getNewRegNat II32
1131                         v2 <- getNewRegNat II32
1132
1133                         let Just f0_high = fPair f0
1134
1135                         let code2 =
1136                                 code                            `snocOL`
1137                                 FMOV FF64 src f0                `snocOL`
1138                                 ST   FF32  f0 (spRel 16)        `snocOL`
1139                                 LD   II32  (spRel 16) v1        `snocOL`
1140                                 ST   FF32  f0_high (spRel 16)   `snocOL`
1141                                 LD   II32  (spRel 16) v2
1142
1143                         return  (code2, [v1,v2])
1144
1145                  -- Load a 32 bit float return value into an integer reg
1146                  FF32 -> do
1147                         v1 <- getNewRegNat II32
1148
1149                         let code2 =
1150                                 code                            `snocOL`
1151                                 ST   FF32  src (spRel 16)       `snocOL`
1152                                 LD   II32  (spRel 16) v1
1153
1154                         return (code2, [v1])
1155
1156                  -- Move an integer return value into its destination reg.
1157                  other -> do
1158                         v1 <- getNewRegNat II32
1159
1160                         let code2 =
1161                                 code                            `snocOL`
1162                                 OR False g0 (RIReg src) v1
1163
1164                         return (code2, [v1])
1165
1166
1167 -- | Move args from the integer vregs into which they have been
1168 --      marshalled, into %o0 .. %o5, and the rest onto the stack.
1169 --
1170 move_final :: [Reg] -> [Reg] -> Int -> [Instr]
1171
1172 -- all args done
1173 move_final [] _ offset
1174         = []
1175
1176 -- out of aregs; move to stack
1177 move_final (v:vs) [] offset
1178         = ST II32 v (spRel offset)
1179         : move_final vs [] (offset+1)
1180
1181 -- move into an arg (%o[0..5]) reg
1182 move_final (v:vs) (a:az) offset
1183         = OR False g0 (RIReg v) a
1184         : move_final vs az offset
1185
1186
1187 -- | Assign results returned from the call into their
1188 --      desination regs.
1189 --
1190 assign_code :: [CmmHinted LocalReg] -> OrdList Instr
1191 assign_code []  = nilOL
1192
1193 assign_code [CmmHinted dest _hint]
1194  = let  rep     = localRegType dest
1195         width   = typeWidth rep
1196         r_dest  = getRegisterReg (CmmLocal dest)
1197
1198         result
1199                 | isFloatType rep
1200                 , W32   <- width
1201                 = unitOL $ FMOV FF32 (RealReg $ fReg 0) r_dest
1202
1203                 | isFloatType rep
1204                 , W64   <- width
1205                 = unitOL $ FMOV FF64 (RealReg $ fReg 0) r_dest
1206
1207                 | not $ isFloatType rep
1208                 , W32   <- width
1209                 = unitOL $ mkRegRegMoveInstr (RealReg $ oReg 0) r_dest
1210
1211                 | not $ isFloatType rep
1212                 , W64           <- width
1213                 , r_dest_hi     <- getHiVRegFromLo r_dest
1214                 = toOL  [ mkRegRegMoveInstr (RealReg $ oReg 0) r_dest_hi
1215                         , mkRegRegMoveInstr (RealReg $ oReg 1) r_dest]
1216    in   result
1217
1218
1219 -- | Generate a call to implement an out-of-line floating point operation
1220 outOfLineFloatOp
1221         :: CallishMachOp
1222         -> NatM (Either CLabel CmmExpr)
1223
1224 outOfLineFloatOp mop
1225  = do   let functionName
1226                 = outOfLineFloatOp_table mop
1227
1228         dflags  <- getDynFlagsNat
1229         mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference
1230                 $  mkForeignLabel functionName Nothing True IsFunction
1231
1232         let mopLabelOrExpr
1233                 = case mopExpr of
1234                         CmmLit (CmmLabel lbl)   -> Left lbl
1235                         _                       -> Right mopExpr
1236
1237         return mopLabelOrExpr
1238
1239
1240 -- | Decide what C function to use to implement a CallishMachOp
1241 --
1242 outOfLineFloatOp_table
1243         :: CallishMachOp
1244         -> FastString
1245
1246 outOfLineFloatOp_table mop
1247  = case mop of
1248         MO_F32_Exp    -> fsLit "expf"
1249         MO_F32_Log    -> fsLit "logf"
1250         MO_F32_Sqrt   -> fsLit "sqrtf"
1251         MO_F32_Pwr    -> fsLit "powf"
1252
1253         MO_F32_Sin    -> fsLit "sinf"
1254         MO_F32_Cos    -> fsLit "cosf"
1255         MO_F32_Tan    -> fsLit "tanf"
1256
1257         MO_F32_Asin   -> fsLit "asinf"
1258         MO_F32_Acos   -> fsLit "acosf"
1259         MO_F32_Atan   -> fsLit "atanf"
1260
1261         MO_F32_Sinh   -> fsLit "sinhf"
1262         MO_F32_Cosh   -> fsLit "coshf"
1263         MO_F32_Tanh   -> fsLit "tanhf"
1264
1265         MO_F64_Exp    -> fsLit "exp"
1266         MO_F64_Log    -> fsLit "log"
1267         MO_F64_Sqrt   -> fsLit "sqrt"
1268         MO_F64_Pwr    -> fsLit "pow"
1269
1270         MO_F64_Sin    -> fsLit "sin"
1271         MO_F64_Cos    -> fsLit "cos"
1272         MO_F64_Tan    -> fsLit "tan"
1273
1274         MO_F64_Asin   -> fsLit "asin"
1275         MO_F64_Acos   -> fsLit "acos"
1276         MO_F64_Atan   -> fsLit "atan"
1277
1278         MO_F64_Sinh   -> fsLit "sinh"
1279         MO_F64_Cosh   -> fsLit "cosh"
1280         MO_F64_Tanh   -> fsLit "tanh"
1281
1282         other -> pprPanic "outOfLineFloatOp(sparc): Unknown callish mach op "
1283                         (pprCallishMachOp mop)
1284
1285
1286 -- -----------------------------------------------------------------------------
1287 -- Generating a table-branch
1288
1289 genSwitch :: CmmExpr -> [Maybe BlockId] -> NatM InstrBlock
1290 genSwitch expr ids
1291         | opt_PIC
1292         = error "MachCodeGen: sparc genSwitch PIC not finished\n"
1293
1294         | otherwise
1295         = do    (e_reg, e_code) <- getSomeReg expr
1296
1297                 base_reg        <- getNewRegNat II32
1298                 offset_reg      <- getNewRegNat II32
1299                 dst             <- getNewRegNat II32
1300
1301                 label           <- getNewLabelNat
1302                 let jumpTable   = map jumpTableEntry ids
1303
1304                 return $ e_code `appOL`
1305                  toOL
1306                         -- the jump table
1307                         [ LDATA ReadOnlyData (CmmDataLabel label : jumpTable)
1308
1309                         -- load base of jump table
1310                         , SETHI (HI (ImmCLbl label)) base_reg
1311                         , OR    False base_reg (RIImm $ LO $ ImmCLbl label) base_reg
1312
1313                         -- the addrs in the table are 32 bits wide..
1314                         , SLL   e_reg (RIImm $ ImmInt 2) offset_reg
1315
1316                         -- load and jump to the destination
1317                         , LD      II32 (AddrRegReg base_reg offset_reg) dst
1318                         , JMP_TBL (AddrRegImm dst (ImmInt 0)) [i | Just i <- ids]
1319                         , NOP ]
1320
1321
1322
1323 -- -----------------------------------------------------------------------------
1324 -- 'condIntReg' and 'condFltReg': condition codes into registers
1325
1326 -- Turn those condition codes into integers now (when they appear on
1327 -- the right hand side of an assignment).
1328 --
1329 -- (If applicable) Do not fill the delay slots here; you will confuse the
1330 -- register allocator.
1331
1332 condIntReg, condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
1333
1334 condIntReg EQQ x (CmmLit (CmmInt 0 d)) = do
1335     (src, code) <- getSomeReg x
1336     tmp <- getNewRegNat II32
1337     let
1338         code__2 dst = code `appOL` toOL [
1339             SUB False True g0 (RIReg src) g0,
1340             SUB True False g0 (RIImm (ImmInt (-1))) dst]
1341     return (Any II32 code__2)
1342
1343 condIntReg EQQ x y = do
1344     (src1, code1) <- getSomeReg x
1345     (src2, code2) <- getSomeReg y
1346     tmp1 <- getNewRegNat II32
1347     tmp2 <- getNewRegNat II32
1348     let
1349         code__2 dst = code1 `appOL` code2 `appOL` toOL [
1350             XOR False src1 (RIReg src2) dst,
1351             SUB False True g0 (RIReg dst) g0,
1352             SUB True False g0 (RIImm (ImmInt (-1))) dst]
1353     return (Any II32 code__2)
1354
1355 condIntReg NE x (CmmLit (CmmInt 0 d)) = do
1356     (src, code) <- getSomeReg x
1357     tmp <- getNewRegNat II32
1358     let
1359         code__2 dst = code `appOL` toOL [
1360             SUB False True g0 (RIReg src) g0,
1361             ADD True False g0 (RIImm (ImmInt 0)) dst]
1362     return (Any II32 code__2)
1363
1364 condIntReg NE x y = do
1365     (src1, code1) <- getSomeReg x
1366     (src2, code2) <- getSomeReg y
1367     tmp1 <- getNewRegNat II32
1368     tmp2 <- getNewRegNat II32
1369     let
1370         code__2 dst = code1 `appOL` code2 `appOL` toOL [
1371             XOR False src1 (RIReg src2) dst,
1372             SUB False True g0 (RIReg dst) g0,
1373             ADD True False g0 (RIImm (ImmInt 0)) dst]
1374     return (Any II32 code__2)
1375
1376 condIntReg cond x y = do
1377     bid1@(BlockId lbl1) <- getBlockIdNat
1378     bid2@(BlockId lbl2) <- getBlockIdNat
1379     CondCode _ cond cond_code <- condIntCode cond x y
1380     let
1381         code__2 dst = cond_code `appOL` toOL [
1382             BI cond False bid1, NOP,
1383             OR False g0 (RIImm (ImmInt 0)) dst,
1384             BI ALWAYS False bid2, NOP,
1385             NEWBLOCK bid1,
1386             OR False g0 (RIImm (ImmInt 1)) dst,
1387             NEWBLOCK bid2]
1388     return (Any II32 code__2)
1389
1390 condFltReg cond x y = do
1391     bid1@(BlockId lbl1) <- getBlockIdNat
1392     bid2@(BlockId lbl2) <- getBlockIdNat
1393     CondCode _ cond cond_code <- condFltCode cond x y
1394     let
1395         code__2 dst = cond_code `appOL` toOL [
1396             NOP,
1397             BF cond False bid1, NOP,
1398             OR False g0 (RIImm (ImmInt 0)) dst,
1399             BI ALWAYS False bid2, NOP,
1400             NEWBLOCK bid1,
1401             OR False g0 (RIImm (ImmInt 1)) dst,
1402             NEWBLOCK bid2]
1403     return (Any II32 code__2)
1404
1405
1406
1407 -- -----------------------------------------------------------------------------
1408 -- 'trivial*Code': deal with trivial instructions
1409
1410 -- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',
1411 -- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.
1412 -- Only look for constants on the right hand side, because that's
1413 -- where the generic optimizer will have put them.
1414
1415 -- Similarly, for unary instructions, we don't have to worry about
1416 -- matching an StInt as the argument, because genericOpt will already
1417 -- have handled the constant-folding.
1418
1419 trivialCode pk instr x (CmmLit (CmmInt y d))
1420   | fits13Bits y
1421   = do
1422       (src1, code) <- getSomeReg x
1423       tmp <- getNewRegNat II32
1424       let
1425         src2 = ImmInt (fromInteger y)
1426         code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
1427       return (Any II32 code__2)
1428
1429 trivialCode pk instr x y = do
1430     (src1, code1) <- getSomeReg x
1431     (src2, code2) <- getSomeReg y
1432     tmp1 <- getNewRegNat II32
1433     tmp2 <- getNewRegNat II32
1434     let
1435         code__2 dst = code1 `appOL` code2 `snocOL`
1436                       instr src1 (RIReg src2) dst
1437     return (Any II32 code__2)
1438
1439 ------------
1440 trivialFCode pk instr x y = do
1441     (src1, code1) <- getSomeReg x
1442     (src2, code2) <- getSomeReg y
1443     tmp1 <- getNewRegNat (cmmTypeSize $ cmmExprType x)
1444     tmp2 <- getNewRegNat (cmmTypeSize $ cmmExprType y)
1445     tmp <- getNewRegNat FF64
1446     let
1447         promote x = FxTOy FF32 FF64 x tmp
1448
1449         pk1   = cmmExprType x
1450         pk2   = cmmExprType y
1451
1452         code__2 dst =
1453                 if pk1 `cmmEqType` pk2 then
1454                     code1 `appOL` code2 `snocOL`
1455                     instr (floatSize pk) src1 src2 dst
1456                 else if typeWidth pk1 == W32 then
1457                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1458                     instr FF64 tmp src2 dst
1459                 else
1460                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1461                     instr FF64 src1 tmp dst
1462     return (Any (cmmTypeSize $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64)
1463                 code__2)
1464
1465 ------------
1466 trivialUCode size instr x = do
1467     (src, code) <- getSomeReg x
1468     tmp <- getNewRegNat size
1469     let
1470         code__2 dst = code `snocOL` instr (RIReg src) dst
1471     return (Any size code__2)
1472
1473 -------------
1474 trivialUFCode pk instr x = do
1475     (src, code) <- getSomeReg x
1476     tmp <- getNewRegNat pk
1477     let
1478         code__2 dst = code `snocOL` instr src dst
1479     return (Any pk code__2)
1480
1481
1482
1483 coerceDbl2Flt :: CmmExpr -> NatM Register
1484 coerceFlt2Dbl :: CmmExpr -> NatM Register
1485
1486
1487 coerceInt2FP width1 width2 x = do
1488     (src, code) <- getSomeReg x
1489     let
1490         code__2 dst = code `appOL` toOL [
1491             ST (intSize width1) src (spRel (-2)),
1492             LD (intSize width1) (spRel (-2)) dst,
1493             FxTOy (intSize width1) (floatSize width2) dst dst]
1494     return (Any (floatSize $ width2) code__2)
1495
1496
1497 -- | Coerce a floating point value to integer
1498 --
1499 --   NOTE: On sparc v9 there are no instructions to move a value from an
1500 --         FP register directly to an int register, so we have to use a load/store.
1501 --
1502 coerceFP2Int width1 width2 x
1503  = do   let fsize1      = floatSize width1
1504             fsize2      = floatSize width2
1505
1506             isize2      = intSize   width2
1507
1508         (fsrc, code)    <- getSomeReg x
1509         fdst            <- getNewRegNat fsize2
1510
1511         let code2 dst
1512                 =       code
1513                 `appOL` toOL
1514                         -- convert float to int format, leaving it in a float reg.
1515                         [ FxTOy fsize1 isize2 fsrc fdst
1516
1517                         -- store the int into mem, then load it back to move
1518                         --      it into an actual int reg.
1519                         , ST    fsize2 fdst (spRel (-2))
1520                         , LD    isize2 (spRel (-2)) dst]
1521
1522         return (Any isize2 code2)
1523
1524 ------------
1525 coerceDbl2Flt x = do
1526     (src, code) <- getSomeReg x
1527     return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst))
1528
1529 ------------
1530 coerceFlt2Dbl x = do
1531     (src, code) <- getSomeReg x
1532     return (Any FF64 (\dst -> code `snocOL` FxTOy FF32 FF64 src dst))
1533
1534
1535
1536 -- eXTRA_STK_ARGS_HERE
1537
1538 -- We (allegedly) put the first six C-call arguments in registers;
1539 -- where do we start putting the rest of them?
1540
1541 -- Moved from Instrs (SDM):
1542
1543 eXTRA_STK_ARGS_HERE :: Int
1544 eXTRA_STK_ARGS_HERE
1545         = 23