compiler/nativeGen/Alpha/CodeGen.hs

   1 module Alpha.CodeGen ()
   2
   3 where
   4
   5 {-
   6
   7 getRegister :: CmmExpr -> NatM Register
   8
   9 #if !x86_64_TARGET_ARCH
  10     -- on x86_64, we have %rip for PicBaseReg, but it's not a full-featured
  11     -- register, it can only be used for rip-relative addressing.
  12 getRegister (CmmReg (CmmGlobal PicBaseReg))
  13   = do
  14       reg <- getPicBaseNat wordSize
  15       return (Fixed wordSize reg nilOL)
  16 #endif
  17
  18 getRegister (CmmReg reg)
  19   = return (Fixed (cmmTypeSize (cmmRegType reg))
  20                   (getRegisterReg reg) nilOL)
  21
  22 getRegister tree@(CmmRegOff _ _)
  23   = getRegister (mangleIndexTree tree)
  24
  25
  26 #if WORD_SIZE_IN_BITS==32
  27     -- for 32-bit architectuers, support some 64 -> 32 bit conversions:
  28     -- TO_W_(x), TO_W_(x >> 32)
  29
  30 getRegister (CmmMachOp (MO_UU_Conv W64 W32)
  31              [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
  32   ChildCode64 code rlo <- iselExpr64 x
  33   return $ Fixed II32 (getHiVRegFromLo rlo) code
  34
  35 getRegister (CmmMachOp (MO_SS_Conv W64 W32)
  36              [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
  37   ChildCode64 code rlo <- iselExpr64 x
  38   return $ Fixed II32 (getHiVRegFromLo rlo) code
  39
  40 getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do
  41   ChildCode64 code rlo <- iselExpr64 x
  42   return $ Fixed II32 rlo code
  43
  44 getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do
  45   ChildCode64 code rlo <- iselExpr64 x
  46   return $ Fixed II32 rlo code
  47
  48 #endif
  49
  50 -- end of machine-"independent" bit; here we go on the rest...
  51
  52
  53 getRegister (StDouble d)
  54   = getBlockIdNat                   `thenNat` \ lbl ->
  55     getNewRegNat PtrRep             `thenNat` \ tmp ->
  56     let code dst = mkSeqInstrs [
  57             LDATA RoDataSegment lbl [
  58                     DATA TF [ImmLab (rational d)]
  59                 ],
  60             LDA tmp (AddrImm (ImmCLbl lbl)),
  61             LD TF dst (AddrReg tmp)]
  62     in
  63         return (Any FF64 code)
  64
  65 getRegister (StPrim primop [x]) -- unary PrimOps
  66   = case primop of
  67       IntNegOp -> trivialUCode (NEG Q False) x
  68
  69       NotOp    -> trivialUCode NOT x
  70
  71       FloatNegOp  -> trivialUFCode FloatRep (FNEG TF) x
  72       DoubleNegOp -> trivialUFCode FF64 (FNEG TF) x
  73
  74       OrdOp -> coerceIntCode IntRep x
  75       ChrOp -> chrCode x
  76
  77       Float2IntOp  -> coerceFP2Int    x
  78       Int2FloatOp  -> coerceInt2FP pr x
  79       Double2IntOp -> coerceFP2Int    x
  80       Int2DoubleOp -> coerceInt2FP pr x
  81
  82       Double2FloatOp -> coerceFltCode x
  83       Float2DoubleOp -> coerceFltCode x
  84
  85       other_op -> getRegister (StCall fn CCallConv FF64 [x])
  86         where
  87           fn = case other_op of
  88                  FloatExpOp    -> fsLit "exp"
  89                  FloatLogOp    -> fsLit "log"
  90                  FloatSqrtOp   -> fsLit "sqrt"
  91                  FloatSinOp    -> fsLit "sin"
  92                  FloatCosOp    -> fsLit "cos"
  93                  FloatTanOp    -> fsLit "tan"
  94                  FloatAsinOp   -> fsLit "asin"
  95                  FloatAcosOp   -> fsLit "acos"
  96                  FloatAtanOp   -> fsLit "atan"
  97                  FloatSinhOp   -> fsLit "sinh"
  98                  FloatCoshOp   -> fsLit "cosh"
  99                  FloatTanhOp   -> fsLit "tanh"
 100                  DoubleExpOp   -> fsLit "exp"
 101                  DoubleLogOp   -> fsLit "log"
 102                  DoubleSqrtOp  -> fsLit "sqrt"
 103                  DoubleSinOp   -> fsLit "sin"
 104                  DoubleCosOp   -> fsLit "cos"
 105                  DoubleTanOp   -> fsLit "tan"
 106                  DoubleAsinOp  -> fsLit "asin"
 107                  DoubleAcosOp  -> fsLit "acos"
 108                  DoubleAtanOp  -> fsLit "atan"
 109                  DoubleSinhOp  -> fsLit "sinh"
 110                  DoubleCoshOp  -> fsLit "cosh"
 111                  DoubleTanhOp  -> fsLit "tanh"
 112   where
 113     pr = panic "MachCode.getRegister: no primrep needed for Alpha"
 114
 115 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
 116   = case primop of
 117       CharGtOp -> trivialCode (CMP LTT) y x
 118       CharGeOp -> trivialCode (CMP LE) y x
 119       CharEqOp -> trivialCode (CMP EQQ) x y
 120       CharNeOp -> int_NE_code x y
 121       CharLtOp -> trivialCode (CMP LTT) x y
 122       CharLeOp -> trivialCode (CMP LE) x y
 123
 124       IntGtOp  -> trivialCode (CMP LTT) y x
 125       IntGeOp  -> trivialCode (CMP LE) y x
 126       IntEqOp  -> trivialCode (CMP EQQ) x y
 127       IntNeOp  -> int_NE_code x y
 128       IntLtOp  -> trivialCode (CMP LTT) x y
 129       IntLeOp  -> trivialCode (CMP LE) x y
 130
 131       WordGtOp -> trivialCode (CMP ULT) y x
 132       WordGeOp -> trivialCode (CMP ULE) x y
 133       WordEqOp -> trivialCode (CMP EQQ)  x y
 134       WordNeOp -> int_NE_code x y
 135       WordLtOp -> trivialCode (CMP ULT) x y
 136       WordLeOp -> trivialCode (CMP ULE) x y
 137
 138       AddrGtOp -> trivialCode (CMP ULT) y x
 139       AddrGeOp -> trivialCode (CMP ULE) y x
 140       AddrEqOp -> trivialCode (CMP EQQ)  x y
 141       AddrNeOp -> int_NE_code x y
 142       AddrLtOp -> trivialCode (CMP ULT) x y
 143       AddrLeOp -> trivialCode (CMP ULE) x y
 144
 145       FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
 146       FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
 147       FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
 148       FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
 149       FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
 150       FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
 151
 152       DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
 153       DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
 154       DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
 155       DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
 156       DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
 157       DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
 158
 159       IntAddOp  -> trivialCode (ADD Q False) x y
 160       IntSubOp  -> trivialCode (SUB Q False) x y
 161       IntMulOp  -> trivialCode (MUL Q False) x y
 162       IntQuotOp -> trivialCode (DIV Q False) x y
 163       IntRemOp  -> trivialCode (REM Q False) x y
 164
 165       WordAddOp  -> trivialCode (ADD Q False) x y
 166       WordSubOp  -> trivialCode (SUB Q False) x y
 167       WordMulOp  -> trivialCode (MUL Q False) x y
 168       WordQuotOp -> trivialCode (DIV Q True) x y
 169       WordRemOp  -> trivialCode (REM Q True) x y
 170
 171       FloatAddOp -> trivialFCode  W32 (FADD TF) x y
 172       FloatSubOp -> trivialFCode  W32 (FSUB TF) x y
 173       FloatMulOp -> trivialFCode  W32 (FMUL TF) x y
 174       FloatDivOp -> trivialFCode  W32 (FDIV TF) x y
 175
 176       DoubleAddOp -> trivialFCode  W64 (FADD TF) x y
 177       DoubleSubOp -> trivialFCode  W64 (FSUB TF) x y
 178       DoubleMulOp -> trivialFCode  W64 (FMUL TF) x y
 179       DoubleDivOp -> trivialFCode  W64 (FDIV TF) x y
 180
 181       AddrAddOp  -> trivialCode (ADD Q False) x y
 182       AddrSubOp  -> trivialCode (SUB Q False) x y
 183       AddrRemOp  -> trivialCode (REM Q True) x y
 184
 185       AndOp  -> trivialCode AND x y
 186       OrOp   -> trivialCode OR  x y
 187       XorOp  -> trivialCode XOR x y
 188       SllOp  -> trivialCode SLL x y
 189       SrlOp  -> trivialCode SRL x y
 190
 191       ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
 192       ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
 193       ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
 194
 195       FloatPowerOp  -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y])
 196       DoublePowerOp -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y])
 197   where
 198     {- ------------------------------------------------------------
 199         Some bizarre special code for getting condition codes into
 200         registers.  Integer non-equality is a test for equality
 201         followed by an XOR with 1.  (Integer comparisons always set
 202         the result register to 0 or 1.)  Floating point comparisons of
 203         any kind leave the result in a floating point register, so we
 204         need to wrangle an integer register out of things.
 205     -}
 206     int_NE_code :: StixTree -> StixTree -> NatM Register
 207
 208     int_NE_code x y
 209       = trivialCode (CMP EQQ) x y       `thenNat` \ register ->
 210         getNewRegNat IntRep             `thenNat` \ tmp ->
 211         let
 212             code = registerCode register tmp
 213             src  = registerName register tmp
 214             code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
 215         in
 216         return (Any IntRep code__2)
 217
 218     {- ------------------------------------------------------------
 219         Comments for int_NE_code also apply to cmpF_code
 220     -}
 221     cmpF_code
 222         :: (Reg -> Reg -> Reg -> Instr)
 223         -> Cond
 224         -> StixTree -> StixTree
 225         -> NatM Register
 226
 227     cmpF_code instr cond x y
 228       = trivialFCode pr instr x y       `thenNat` \ register ->
 229         getNewRegNat FF64               `thenNat` \ tmp ->
 230         getBlockIdNat                   `thenNat` \ lbl ->
 231         let
 232             code = registerCode register tmp
 233             result  = registerName register tmp
 234
 235             code__2 dst = code . mkSeqInstrs [
 236                 OR zeroh (RIImm (ImmInt 1)) dst,
 237                 BF cond  result (ImmCLbl lbl),
 238                 OR zeroh (RIReg zeroh) dst,
 239                 NEWBLOCK lbl]
 240         in
 241         return (Any IntRep code__2)
 242       where
 243         pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
 244       ------------------------------------------------------------
 245
 246 getRegister (CmmLoad pk mem)
 247   = getAmode mem                    `thenNat` \ amode ->
 248     let
 249         code = amodeCode amode
 250         src   = amodeAddr amode
 251         size = primRepToSize pk
 252         code__2 dst = code . mkSeqInstr (LD size dst src)
 253     in
 254     return (Any pk code__2)
 255
 256 getRegister (StInt i)
 257   | fits8Bits i
 258   = let
 259         code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
 260     in
 261     return (Any IntRep code)
 262   | otherwise
 263   = let
 264         code dst = mkSeqInstr (LDI Q dst src)
 265     in
 266     return (Any IntRep code)
 267   where
 268     src = ImmInt (fromInteger i)
 269
 270 getRegister leaf
 271   | isJust imm
 272   = let
 273         code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
 274     in
 275     return (Any PtrRep code)
 276   where
 277     imm = maybeImm leaf
 278     imm__2 = case imm of Just x -> x
 279
 280
 281 getAmode :: CmmExpr -> NatM Amode
 282 getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree)
 283
 284 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 285
 286 #if alpha_TARGET_ARCH
 287
 288 getAmode (StPrim IntSubOp [x, StInt i])
 289   = getNewRegNat PtrRep         `thenNat` \ tmp ->
 290     getRegister x               `thenNat` \ register ->
 291     let
 292         code = registerCode register tmp
 293         reg  = registerName register tmp
 294         off  = ImmInt (-(fromInteger i))
 295     in
 296     return (Amode (AddrRegImm reg off) code)
 297
 298 getAmode (StPrim IntAddOp [x, StInt i])
 299   = getNewRegNat PtrRep         `thenNat` \ tmp ->
 300     getRegister x               `thenNat` \ register ->
 301     let
 302         code = registerCode register tmp
 303         reg  = registerName register tmp
 304         off  = ImmInt (fromInteger i)
 305     in
 306     return (Amode (AddrRegImm reg off) code)
 307
 308 getAmode leaf
 309   | isJust imm
 310   = return (Amode (AddrImm imm__2) id)
 311   where
 312     imm = maybeImm leaf
 313     imm__2 = case imm of Just x -> x
 314
 315 getAmode other
 316   = getNewRegNat PtrRep         `thenNat` \ tmp ->
 317     getRegister other           `thenNat` \ register ->
 318     let
 319         code = registerCode register tmp
 320         reg  = registerName register tmp
 321     in
 322     return (Amode (AddrReg reg) code)
 323
 324 #endif /* alpha_TARGET_ARCH */
 325
 326
 327 -- -----------------------------------------------------------------------------
 328 -- Generating assignments
 329
 330 -- Assignments are really at the heart of the whole code generation
 331 -- business.  Almost all top-level nodes of any real importance are
 332 -- assignments, which correspond to loads, stores, or register
 333 -- transfers.  If we're really lucky, some of the register transfers
 334 -- will go away, because we can use the destination register to
 335 -- complete the code generation for the right hand side.  This only
 336 -- fails when the right hand side is forced into a fixed register
 337 -- (e.g. the result of a call).
 338
 339 assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
 340 assignReg_IntCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock
 341
 342 assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
 343 assignReg_FltCode :: Size -> CmmReg  -> CmmExpr -> NatM InstrBlock
 344
 345
 346 assignIntCode pk (CmmLoad dst _) src
 347   = getNewRegNat IntRep             `thenNat` \ tmp ->
 348     getAmode dst                    `thenNat` \ amode ->
 349     getRegister src                 `thenNat` \ register ->
 350     let
 351         code1   = amodeCode amode []
 352         dst__2  = amodeAddr amode
 353         code2   = registerCode register tmp []
 354         src__2  = registerName register tmp
 355         sz      = primRepToSize pk
 356         code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
 357     in
 358     return code__2
 359
 360 assignIntCode pk dst src
 361   = getRegister dst                         `thenNat` \ register1 ->
 362     getRegister src                         `thenNat` \ register2 ->
 363     let
 364         dst__2  = registerName register1 zeroh
 365         code    = registerCode register2 dst__2
 366         src__2  = registerName register2 dst__2
 367         code__2 = if isFixed register2
 368                   then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
 369                   else code
 370     in
 371     return code__2
 372
 373 assignFltCode pk (CmmLoad dst _) src
 374   = getNewRegNat pk                 `thenNat` \ tmp ->
 375     getAmode dst                    `thenNat` \ amode ->
 376     getRegister src                         `thenNat` \ register ->
 377     let
 378         code1   = amodeCode amode []
 379         dst__2  = amodeAddr amode
 380         code2   = registerCode register tmp []
 381         src__2  = registerName register tmp
 382         sz      = primRepToSize pk
 383         code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
 384     in
 385     return code__2
 386
 387 assignFltCode pk dst src
 388   = getRegister dst                         `thenNat` \ register1 ->
 389     getRegister src                         `thenNat` \ register2 ->
 390     let
 391         dst__2  = registerName register1 zeroh
 392         code    = registerCode register2 dst__2
 393         src__2  = registerName register2 dst__2
 394         code__2 = if isFixed register2
 395                   then code . mkSeqInstr (FMOV src__2 dst__2)
 396                   else code
 397     in
 398     return code__2
 399
 400
 401 -- -----------------------------------------------------------------------------
 402 -- Generating an non-local jump
 403
 404 -- (If applicable) Do not fill the delay slots here; you will confuse the
 405 -- register allocator.
 406
 407 genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
 408
 409 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 410
 411
 412 genJump (CmmLabel lbl)
 413   | isAsmTemp lbl = returnInstr (BR target)
 414   | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
 415   where
 416     target = ImmCLbl lbl
 417
 418 genJump tree
 419   = getRegister tree                `thenNat` \ register ->
 420     getNewRegNat PtrRep             `thenNat` \ tmp ->
 421     let
 422         dst    = registerName register pv
 423         code   = registerCode register pv
 424         target = registerName register pv
 425     in
 426     if isFixed register then
 427         returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
 428     else
 429     return (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
 430
 431
 432 -- -----------------------------------------------------------------------------
 433 --  Unconditional branches
 434
 435 genBranch :: BlockId -> NatM InstrBlock
 436
 437 genBranch = return . toOL . mkBranchInstr
 438
 439
 440 -- -----------------------------------------------------------------------------
 441 --  Conditional jumps
 442
 443 {-
 444 Conditional jumps are always to local labels, so we can use branch
 445 instructions.  We peek at the arguments to decide what kind of
 446 comparison to do.
 447
 448 ALPHA: For comparisons with 0, we're laughing, because we can just do
 449 the desired conditional branch.
 450
 451 -}
 452
 453
 454 genCondJump
 455     :: BlockId      -- the branch target
 456     -> CmmExpr      -- the condition on which to branch
 457     -> NatM InstrBlock
 458
 459 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 460
 461 genCondJump id (StPrim op [x, StInt 0])
 462   = getRegister x                           `thenNat` \ register ->
 463     getNewRegNat (registerRep register)
 464                                     `thenNat` \ tmp ->
 465     let
 466         code   = registerCode register tmp
 467         value  = registerName register tmp
 468         pk     = registerRep register
 469         target = ImmCLbl lbl
 470     in
 471     returnSeq code [BI (cmpOp op) value target]
 472   where
 473     cmpOp CharGtOp = GTT
 474     cmpOp CharGeOp = GE
 475     cmpOp CharEqOp = EQQ
 476     cmpOp CharNeOp = NE
 477     cmpOp CharLtOp = LTT
 478     cmpOp CharLeOp = LE
 479     cmpOp IntGtOp = GTT
 480     cmpOp IntGeOp = GE
 481     cmpOp IntEqOp = EQQ
 482     cmpOp IntNeOp = NE
 483     cmpOp IntLtOp = LTT
 484     cmpOp IntLeOp = LE
 485     cmpOp WordGtOp = NE
 486     cmpOp WordGeOp = ALWAYS
 487     cmpOp WordEqOp = EQQ
 488     cmpOp WordNeOp = NE
 489     cmpOp WordLtOp = NEVER
 490     cmpOp WordLeOp = EQQ
 491     cmpOp AddrGtOp = NE
 492     cmpOp AddrGeOp = ALWAYS
 493     cmpOp AddrEqOp = EQQ
 494     cmpOp AddrNeOp = NE
 495     cmpOp AddrLtOp = NEVER
 496     cmpOp AddrLeOp = EQQ
 497
 498 genCondJump lbl (StPrim op [x, StDouble 0.0])
 499   = getRegister x                           `thenNat` \ register ->
 500     getNewRegNat (registerRep register)
 501                                     `thenNat` \ tmp ->
 502     let
 503         code   = registerCode register tmp
 504         value  = registerName register tmp
 505         pk     = registerRep register
 506         target = ImmCLbl lbl
 507     in
 508     return (code . mkSeqInstr (BF (cmpOp op) value target))
 509   where
 510     cmpOp FloatGtOp = GTT
 511     cmpOp FloatGeOp = GE
 512     cmpOp FloatEqOp = EQQ
 513     cmpOp FloatNeOp = NE
 514     cmpOp FloatLtOp = LTT
 515     cmpOp FloatLeOp = LE
 516     cmpOp DoubleGtOp = GTT
 517     cmpOp DoubleGeOp = GE
 518     cmpOp DoubleEqOp = EQQ
 519     cmpOp DoubleNeOp = NE
 520     cmpOp DoubleLtOp = LTT
 521     cmpOp DoubleLeOp = LE
 522
 523 genCondJump lbl (StPrim op [x, y])
 524   | fltCmpOp op
 525   = trivialFCode pr instr x y       `thenNat` \ register ->
 526     getNewRegNat FF64               `thenNat` \ tmp ->
 527     let
 528         code   = registerCode register tmp
 529         result = registerName register tmp
 530         target = ImmCLbl lbl
 531     in
 532     return (code . mkSeqInstr (BF cond result target))
 533   where
 534     pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
 535
 536     fltCmpOp op = case op of
 537         FloatGtOp -> True
 538         FloatGeOp -> True
 539         FloatEqOp -> True
 540         FloatNeOp -> True
 541         FloatLtOp -> True
 542         FloatLeOp -> True
 543         DoubleGtOp -> True
 544         DoubleGeOp -> True
 545         DoubleEqOp -> True
 546         DoubleNeOp -> True
 547         DoubleLtOp -> True
 548         DoubleLeOp -> True
 549         _ -> False
 550     (instr, cond) = case op of
 551         FloatGtOp -> (FCMP TF LE, EQQ)
 552         FloatGeOp -> (FCMP TF LTT, EQQ)
 553         FloatEqOp -> (FCMP TF EQQ, NE)
 554         FloatNeOp -> (FCMP TF EQQ, EQQ)
 555         FloatLtOp -> (FCMP TF LTT, NE)
 556         FloatLeOp -> (FCMP TF LE, NE)
 557         DoubleGtOp -> (FCMP TF LE, EQQ)
 558         DoubleGeOp -> (FCMP TF LTT, EQQ)
 559         DoubleEqOp -> (FCMP TF EQQ, NE)
 560         DoubleNeOp -> (FCMP TF EQQ, EQQ)
 561         DoubleLtOp -> (FCMP TF LTT, NE)
 562         DoubleLeOp -> (FCMP TF LE, NE)
 563
 564 genCondJump lbl (StPrim op [x, y])
 565   = trivialCode instr x y           `thenNat` \ register ->
 566     getNewRegNat IntRep             `thenNat` \ tmp ->
 567     let
 568         code   = registerCode register tmp
 569         result = registerName register tmp
 570         target = ImmCLbl lbl
 571     in
 572     return (code . mkSeqInstr (BI cond result target))
 573   where
 574     (instr, cond) = case op of
 575         CharGtOp -> (CMP LE, EQQ)
 576         CharGeOp -> (CMP LTT, EQQ)
 577         CharEqOp -> (CMP EQQ, NE)
 578         CharNeOp -> (CMP EQQ, EQQ)
 579         CharLtOp -> (CMP LTT, NE)
 580         CharLeOp -> (CMP LE, NE)
 581         IntGtOp -> (CMP LE, EQQ)
 582         IntGeOp -> (CMP LTT, EQQ)
 583         IntEqOp -> (CMP EQQ, NE)
 584         IntNeOp -> (CMP EQQ, EQQ)
 585         IntLtOp -> (CMP LTT, NE)
 586         IntLeOp -> (CMP LE, NE)
 587         WordGtOp -> (CMP ULE, EQQ)
 588         WordGeOp -> (CMP ULT, EQQ)
 589         WordEqOp -> (CMP EQQ, NE)
 590         WordNeOp -> (CMP EQQ, EQQ)
 591         WordLtOp -> (CMP ULT, NE)
 592         WordLeOp -> (CMP ULE, NE)
 593         AddrGtOp -> (CMP ULE, EQQ)
 594         AddrGeOp -> (CMP ULT, EQQ)
 595         AddrEqOp -> (CMP EQQ, NE)
 596         AddrNeOp -> (CMP EQQ, EQQ)
 597         AddrLtOp -> (CMP ULT, NE)
 598         AddrLeOp -> (CMP ULE, NE)
 599
 600 -- -----------------------------------------------------------------------------
 601 --  Generating C calls
 602
 603 -- Now the biggest nightmare---calls.  Most of the nastiness is buried in
 604 -- @get_arg@, which moves the arguments to the correct registers/stack
 605 -- locations.  Apart from that, the code is easy.
 606 --
 607 -- (If applicable) Do not fill the delay slots here; you will confuse the
 608 -- register allocator.
 609
 610 genCCall
 611     :: CmmCallTarget            -- function to call
 612     -> HintedCmmFormals         -- where to put the result
 613     -> HintedCmmActuals         -- arguments (of mixed type)
 614     -> NatM InstrBlock
 615
 616 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 617
 618 ccallResultRegs =
 619
 620 genCCall fn cconv result_regs args
 621   = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
 622                           `thenNat` \ ((unused,_), argCode) ->
 623     let
 624         nRegs = length allArgRegs - length unused
 625         code = asmSeqThen (map ($ []) argCode)
 626     in
 627         returnSeq code [
 628             LDA pv (AddrImm (ImmLab (ptext fn))),
 629             JSR ra (AddrReg pv) nRegs,
 630             LDGP gp (AddrReg ra)]
 631   where
 632     ------------------------
 633     {-  Try to get a value into a specific register (or registers) for
 634         a call.  The first 6 arguments go into the appropriate
 635         argument register (separate registers for integer and floating
 636         point arguments, but used in lock-step), and the remaining
 637         arguments are dumped to the stack, beginning at 0(sp).  Our
 638         first argument is a pair of the list of remaining argument
 639         registers to be assigned for this call and the next stack
 640         offset to use for overflowing arguments.  This way,
 641         @get_Arg@ can be applied to all of a call's arguments using
 642         @mapAccumLNat@.
 643     -}
 644     get_arg
 645         :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
 646         -> StixTree             -- Current argument
 647         -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
 648
 649     -- We have to use up all of our argument registers first...
 650
 651     get_arg ((iDst,fDst):dsts, offset) arg
 652       = getRegister arg                     `thenNat` \ register ->
 653         let
 654             reg  = if isFloatType pk then fDst else iDst
 655             code = registerCode register reg
 656             src  = registerName register reg
 657             pk   = registerRep register
 658         in
 659         return (
 660             if isFloatType pk then
 661                 ((dsts, offset), if isFixed register then
 662                     code . mkSeqInstr (FMOV src fDst)
 663                     else code)
 664             else
 665                 ((dsts, offset), if isFixed register then
 666                     code . mkSeqInstr (OR src (RIReg src) iDst)
 667                     else code))
 668
 669     -- Once we have run out of argument registers, we move to the
 670     -- stack...
 671
 672     get_arg ([], offset) arg
 673       = getRegister arg                 `thenNat` \ register ->
 674         getNewRegNat (registerRep register)
 675                                         `thenNat` \ tmp ->
 676         let
 677             code = registerCode register tmp
 678             src  = registerName register tmp
 679             pk   = registerRep register
 680             sz   = primRepToSize pk
 681         in
 682         return (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
 683
 684 trivialCode instr x (StInt y)
 685   | fits8Bits y
 686   = getRegister x               `thenNat` \ register ->
 687     getNewRegNat IntRep         `thenNat` \ tmp ->
 688     let
 689         code = registerCode register tmp
 690         src1 = registerName register tmp
 691         src2 = ImmInt (fromInteger y)
 692         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
 693     in
 694     return (Any IntRep code__2)
 695
 696 trivialCode instr x y
 697   = getRegister x               `thenNat` \ register1 ->
 698     getRegister y               `thenNat` \ register2 ->
 699     getNewRegNat IntRep         `thenNat` \ tmp1 ->
 700     getNewRegNat IntRep         `thenNat` \ tmp2 ->
 701     let
 702         code1 = registerCode register1 tmp1 []
 703         src1  = registerName register1 tmp1
 704         code2 = registerCode register2 tmp2 []
 705         src2  = registerName register2 tmp2
 706         code__2 dst = asmSeqThen [code1, code2] .
 707                      mkSeqInstr (instr src1 (RIReg src2) dst)
 708     in
 709     return (Any IntRep code__2)
 710
 711 ------------
 712 trivialUCode instr x
 713   = getRegister x               `thenNat` \ register ->
 714     getNewRegNat IntRep         `thenNat` \ tmp ->
 715     let
 716         code = registerCode register tmp
 717         src  = registerName register tmp
 718         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
 719     in
 720     return (Any IntRep code__2)
 721
 722 ------------
 723 trivialFCode _ instr x y
 724   = getRegister x               `thenNat` \ register1 ->
 725     getRegister y               `thenNat` \ register2 ->
 726     getNewRegNat FF64   `thenNat` \ tmp1 ->
 727     getNewRegNat FF64   `thenNat` \ tmp2 ->
 728     let
 729         code1 = registerCode register1 tmp1
 730         src1  = registerName register1 tmp1
 731
 732         code2 = registerCode register2 tmp2
 733         src2  = registerName register2 tmp2
 734
 735         code__2 dst = asmSeqThen [code1 [], code2 []] .
 736                       mkSeqInstr (instr src1 src2 dst)
 737     in
 738     return (Any FF64 code__2)
 739
 740 trivialUFCode _ instr x
 741   = getRegister x               `thenNat` \ register ->
 742     getNewRegNat FF64   `thenNat` \ tmp ->
 743     let
 744         code = registerCode register tmp
 745         src  = registerName register tmp
 746         code__2 dst = code . mkSeqInstr (instr src dst)
 747     in
 748     return (Any FF64 code__2)
 749
 750 #if alpha_TARGET_ARCH
 751
 752 coerceInt2FP _ x
 753   = getRegister x               `thenNat` \ register ->
 754     getNewRegNat IntRep         `thenNat` \ reg ->
 755     let
 756         code = registerCode register reg
 757         src  = registerName register reg
 758
 759         code__2 dst = code . mkSeqInstrs [
 760             ST Q src (spRel 0),
 761             LD TF dst (spRel 0),
 762             CVTxy Q TF dst dst]
 763     in
 764     return (Any FF64 code__2)
 765
 766 -------------
 767 coerceFP2Int x
 768   = getRegister x               `thenNat` \ register ->
 769     getNewRegNat FF64   `thenNat` \ tmp ->
 770     let
 771         code = registerCode register tmp
 772         src  = registerName register tmp
 773
 774         code__2 dst = code . mkSeqInstrs [
 775             CVTxy TF Q src tmp,
 776             ST TF tmp (spRel 0),
 777             LD Q dst (spRel 0)]
 778     in
 779     return (Any IntRep code__2)
 780
 781 #endif /* alpha_TARGET_ARCH */
 782
 783
 784 -}
 785
 786
 787
 788
 789