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