ghc/compiler/nativeGen/SparcCode.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1995
   3 %
   4
   5 \section[SparcCode]{The Native (Sparc) Machine Code}
   6
   7 \begin{code}
   8 #define ILIT2(x) ILIT(x)
   9 #include "HsVersions.h"
  10
  11 module SparcCode (
  12         Addr(..),Cond(..),Imm(..),RI(..),Size(..),
  13         SparcCode(..),SparcInstr(..),SparcRegs,
  14         strImmLit, --UNUSED: strImmLab,
  15
  16         printLabeledCodes,
  17
  18         baseRegOffset, stgRegMap, callerSaves,
  19
  20         is13Bits, offset,
  21
  22         kindToSize,
  23
  24         g0, o0, f0, fp, sp, argRegs,
  25
  26         freeRegs, reservedRegs,
  27
  28         -- and, for self-sufficiency ...
  29         CLabel, CodeSegment, OrdList, PrimKind, Reg, UniqSet(..),
  30         UniqFM, FiniteMap, Unique, MagicId, CSeq, BitSet
  31     ) where
  32
  33 IMPORT_Trace
  34
  35 import AbsCSyn          ( MagicId(..) )
  36 import AsmRegAlloc      ( MachineCode(..), MachineRegisters(..), FutureLive(..),
  37                           Reg(..), RegUsage(..), RegLiveness(..)
  38                         )
  39 import BitSet
  40 import CgCompInfo       ( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG )
  41 import CLabelInfo       ( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
  42 import FiniteMap
  43 import Maybes           ( Maybe(..), maybeToBool )
  44 import OrdList          ( OrdList, mkUnitList, flattenOrdList )
  45 import Outputable
  46 import PrimKind         ( PrimKind(..) )
  47 import UniqSet
  48 import Stix
  49 import Unpretty
  50 import Util
  51 \end{code}
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection[SparcReg]{The Native (Sparc) Machine Register Table}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59 The sparc has 64 registers of interest; 32 integer registers and 32 floating
  60 point registers.  The mapping of STG registers to sparc machine registers
  61 is defined in StgRegs.h.  We are, of course, prepared for any eventuality.
  62
  63 ToDo: Deal with stg registers that live as offsets from BaseReg!(JSM)
  64
  65 \begin{code}
  66
  67 gReg,lReg,iReg,oReg,fReg :: Int -> Int
  68 gReg x = x
  69 oReg x = (8 + x)
  70 lReg x = (16 + x)
  71 iReg x = (24 + x)
  72 fReg x = (32 + x)
  73
  74 fPair :: Reg -> Reg
  75 fPair (FixedReg i) = FixedReg (i _ADD_ ILIT(1))
  76 fPair (MappedReg i) = MappedReg (i _ADD_ ILIT(1))
  77
  78 g0, fp, sp, o0, f0 :: Reg
  79 g0 = case (gReg 0) of { IBOX(g0) -> FixedReg g0 }
  80 fp = case (iReg 6) of { IBOX(i6) -> FixedReg i6 }
  81 sp = case (oReg 6) of { IBOX(o6) -> FixedReg o6 }
  82 o0 = realReg  (oReg 0)
  83 f0 = realReg  (fReg 0)
  84
  85 argRegs :: [Reg]
  86 argRegs = map realReg [oReg i | i <- [0..5]]
  87
  88 realReg n@IBOX(i) = if _IS_TRUE_(freeReg i) then MappedReg i else FixedReg i
  89
  90 \end{code}
  91
  92 %************************************************************************
  93 %*                                                                      *
  94 \subsection[TheSparcCode]{The datatype for sparc assembly language}
  95 %*                                                                      *
  96 %************************************************************************
  97
  98 Here is a definition of the Sparc assembly language.
  99
 100 \begin{code}
 101
 102 data Imm = ImmInt Int
 103          | ImmInteger Integer         -- Sigh.
 104          | ImmCLbl CLabel             -- AbstractC Label (with baggage)
 105          | ImmLab  Unpretty           -- Simple string label (underscored)
 106          | ImmLit Unpretty            -- Simple string
 107          | LO Imm                     -- Possible restrictions
 108          | HI Imm
 109          deriving ()
 110
 111 --UNUSED:strImmLab s = ImmLab (uppStr s)
 112 strImmLit s = ImmLit (uppStr s)
 113
 114 data Addr = AddrRegReg Reg Reg
 115           | AddrRegImm Reg Imm
 116           deriving ()
 117
 118 data Cond = ALWAYS
 119           | NEVER
 120           | GEU
 121           | LU
 122           | EQ
 123           | GT
 124           | GE
 125           | GU
 126           | LT
 127           | LE
 128           | LEU
 129           | NE
 130           | NEG
 131           | POS
 132           | VC
 133           | VS
 134           deriving ()
 135
 136 data RI = RIReg Reg
 137         | RIImm Imm
 138         deriving ()
 139
 140 riZero :: RI -> Bool
 141 riZero (RIImm (ImmInt 0))           = True
 142 riZero (RIImm (ImmInteger 0))       = True
 143 riZero (RIReg (FixedReg ILIT(0)))   = True
 144 riZero _                            = False
 145
 146 data Size = SB
 147           | HW
 148           | UB
 149           | UHW
 150           | W
 151           | D
 152           | F
 153           | DF
 154           deriving ()
 155
 156 data SparcInstr =
 157
 158 -- Loads and stores.
 159
 160                 LD            Size Addr Reg -- size, src, dst
 161               | ST            Size Reg Addr -- size, src, dst
 162
 163 -- Int Arithmetic.
 164
 165               | ADD           Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst
 166               | SUB           Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst
 167
 168 -- Simple bit-twiddling.
 169
 170               | AND           Bool Reg RI Reg -- cc?, src1, src2, dst
 171               | ANDN          Bool Reg RI Reg -- cc?, src1, src2, dst
 172               | OR            Bool Reg RI Reg -- cc?, src1, src2, dst
 173               | ORN           Bool Reg RI Reg -- cc?, src1, src2, dst
 174               | XOR           Bool Reg RI Reg -- cc?, src1, src2, dst
 175               | XNOR          Bool Reg RI Reg -- cc?, src1, src2, dst
 176               | SLL           Reg RI Reg -- src1, src2, dst
 177               | SRL           Reg RI Reg -- src1, src2, dst
 178               | SRA           Reg RI Reg -- src1, src2, dst
 179               | SETHI         Imm Reg -- src, dst
 180               | NOP           -- Really SETHI 0, %g0, but worth an alias
 181
 182 -- Float Arithmetic.
 183
 184 -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single instructions
 185 -- right up until we spit them out.
 186
 187               | FABS          Size Reg Reg -- src dst
 188               | FADD          Size Reg Reg Reg -- src1, src2, dst
 189               | FCMP          Bool Size Reg Reg -- exception?, src1, src2, dst
 190               | FDIV          Size Reg Reg Reg -- src1, src2, dst
 191               | FMOV          Size Reg Reg -- src, dst
 192               | FMUL          Size Reg Reg Reg -- src1, src2, dst
 193               | FNEG          Size Reg Reg -- src, dst
 194               | FSQRT         Size Reg Reg -- src, dst
 195               | FSUB          Size Reg Reg Reg -- src1, src2, dst
 196               | FxTOy         Size Size Reg Reg -- src, dst
 197
 198 -- Jumping around.
 199
 200               | BI            Cond Bool Imm -- cond, annul?, target
 201               | BF            Cond Bool Imm -- cond, annul?, target
 202
 203               | JMP           Addr -- target
 204               | CALL          Imm Int Bool -- target, args, terminal
 205
 206 -- Pseudo-ops.
 207
 208               | LABEL CLabel
 209               | COMMENT FAST_STRING
 210               | SEGMENT CodeSegment
 211               | ASCII Bool String   -- needs backslash conversion?
 212               | DATA Size [Imm]
 213
 214 type SparcCode  = OrdList SparcInstr
 215
 216 \end{code}
 217
 218 %************************************************************************
 219 %*                                                                      *
 220 \subsection[TheSparcPretty]{Pretty-printing the Sparc Assembly Language}
 221 %*                                                                      *
 222 %************************************************************************
 223
 224 \begin{code}
 225
 226 printLabeledCodes :: PprStyle -> [SparcInstr] -> Unpretty
 227 printLabeledCodes sty codes = uppAboves (map (pprSparcInstr sty) codes)
 228
 229 \end{code}
 230
 231 Printing the pieces...
 232
 233 \begin{code}
 234
 235 pprReg :: Reg -> Unpretty
 236
 237 pprReg (FixedReg i) = pprSparcReg i
 238 pprReg (MappedReg i) = pprSparcReg i
 239 pprReg other = uppStr (show other)   -- should only happen when debugging
 240
 241 pprSparcReg :: FAST_INT -> Unpretty
 242 pprSparcReg i = uppPStr
 243     (case i of {
 244         ILIT( 0) -> SLIT("%g0");  ILIT( 1) -> SLIT("%g1");
 245         ILIT( 2) -> SLIT("%g2");  ILIT( 3) -> SLIT("%g3");
 246         ILIT( 4) -> SLIT("%g4");  ILIT( 5) -> SLIT("%g5");
 247         ILIT( 6) -> SLIT("%g6");  ILIT( 7) -> SLIT("%g7");
 248         ILIT( 8) -> SLIT("%o0");  ILIT( 9) -> SLIT("%o1");
 249         ILIT(10) -> SLIT("%o2");  ILIT(11) -> SLIT("%o3");
 250         ILIT(12) -> SLIT("%o4");  ILIT(13) -> SLIT("%o5");
 251         ILIT(14) -> SLIT("%o6");  ILIT(15) -> SLIT("%o7");
 252         ILIT(16) -> SLIT("%l0");  ILIT(17) -> SLIT("%l1");
 253         ILIT(18) -> SLIT("%l2");  ILIT(19) -> SLIT("%l3");
 254         ILIT(20) -> SLIT("%l4");  ILIT(21) -> SLIT("%l5");
 255         ILIT(22) -> SLIT("%l6");  ILIT(23) -> SLIT("%l7");
 256         ILIT(24) -> SLIT("%i0");  ILIT(25) -> SLIT("%i1");
 257         ILIT(26) -> SLIT("%i2");  ILIT(27) -> SLIT("%i3");
 258         ILIT(28) -> SLIT("%i4");  ILIT(29) -> SLIT("%i5");
 259         ILIT(30) -> SLIT("%i6");  ILIT(31) -> SLIT("%i7");
 260         ILIT(32) -> SLIT("%f0");  ILIT(33) -> SLIT("%f1");
 261         ILIT(34) -> SLIT("%f2");  ILIT(35) -> SLIT("%f3");
 262         ILIT(36) -> SLIT("%f4");  ILIT(37) -> SLIT("%f5");
 263         ILIT(38) -> SLIT("%f6");  ILIT(39) -> SLIT("%f7");
 264         ILIT(40) -> SLIT("%f8");  ILIT(41) -> SLIT("%f9");
 265         ILIT(42) -> SLIT("%f10"); ILIT(43) -> SLIT("%f11");
 266         ILIT(44) -> SLIT("%f12"); ILIT(45) -> SLIT("%f13");
 267         ILIT(46) -> SLIT("%f14"); ILIT(47) -> SLIT("%f15");
 268         ILIT(48) -> SLIT("%f16"); ILIT(49) -> SLIT("%f17");
 269         ILIT(50) -> SLIT("%f18"); ILIT(51) -> SLIT("%f19");
 270         ILIT(52) -> SLIT("%f20"); ILIT(53) -> SLIT("%f21");
 271         ILIT(54) -> SLIT("%f22"); ILIT(55) -> SLIT("%f23");
 272         ILIT(56) -> SLIT("%f24"); ILIT(57) -> SLIT("%f25");
 273         ILIT(58) -> SLIT("%f26"); ILIT(59) -> SLIT("%f27");
 274         ILIT(60) -> SLIT("%f28"); ILIT(61) -> SLIT("%f29");
 275         ILIT(62) -> SLIT("%f30"); ILIT(63) -> SLIT("%f31");
 276         _ -> SLIT("very naughty sparc register")
 277     })
 278
 279 pprCond :: Cond -> Unpretty
 280 pprCond x = uppPStr
 281     (case x of {
 282         ALWAYS  -> SLIT("");    NEVER -> SLIT("n");
 283         GEU     -> SLIT("geu"); LU    -> SLIT("lu");
 284         EQ      -> SLIT("e");   GT    -> SLIT("g");
 285         GE      -> SLIT("ge");  GU    -> SLIT("gu");
 286         LT      -> SLIT("l");   LE    -> SLIT("le");
 287         LEU     -> SLIT("leu"); NE    -> SLIT("ne");
 288         NEG     -> SLIT("neg"); POS   -> SLIT("pos");
 289         VC      -> SLIT("vc");  VS    -> SLIT("vs")
 290     })
 291
 292 pprImm :: PprStyle -> Imm -> Unpretty
 293
 294 pprImm sty (ImmInt i) = uppInt i
 295 pprImm sty (ImmInteger i) = uppInteger i
 296
 297 pprImm sty (LO i) =
 298     uppBesides [
 299           pp_lo,
 300           pprImm sty i,
 301           uppRparen
 302     ]
 303   where
 304 #ifdef USE_FAST_STRINGS
 305     pp_lo = uppPStr (_packCString (A# "%lo("#))
 306 #else
 307     pp_lo = uppStr "%lo("
 308 #endif
 309
 310 pprImm sty (HI i) =
 311     uppBesides [
 312           pp_hi,
 313           pprImm sty i,
 314           uppRparen
 315     ]
 316   where
 317 #ifdef USE_FAST_STRINGS
 318     pp_hi = uppPStr (_packCString (A# "%hi("#))
 319 #else
 320     pp_hi = uppStr "%hi("
 321 #endif
 322
 323 pprImm sty (ImmCLbl l) = pprCLabel sty l
 324
 325 pprImm (PprForAsm _ False _) (ImmLab s) = s
 326 pprImm _                     (ImmLab s) = uppBeside (uppChar '_') s
 327
 328 pprImm sty (ImmLit s) = s
 329
 330 pprAddr :: PprStyle -> Addr -> Unpretty
 331 pprAddr sty (AddrRegReg r1 (FixedReg ILIT(0))) = pprReg r1
 332
 333 pprAddr sty (AddrRegReg r1 r2) =
 334     uppBesides [
 335         pprReg r1,
 336         uppChar '+',
 337         pprReg r2
 338     ]
 339
 340 pprAddr sty (AddrRegImm r1 (ImmInt i))
 341     | i == 0 = pprReg r1
 342     | i < -4096 || i > 4095 = large_offset_error i
 343     | i < 0  =
 344         uppBesides [
 345             pprReg r1,
 346             uppChar '-',
 347             uppInt (-i)
 348         ]
 349
 350 pprAddr sty (AddrRegImm r1 (ImmInteger i))
 351     | i == 0 = pprReg r1
 352     | i < -4096 || i > 4095 = large_offset_error i
 353     | i < 0  =
 354         uppBesides [
 355             pprReg r1,
 356             uppChar '-',
 357             uppInteger (-i)
 358         ]
 359
 360 pprAddr sty (AddrRegImm r1 imm) =
 361     uppBesides [
 362         pprReg r1,
 363         uppChar '+',
 364         pprImm sty imm
 365     ]
 366
 367 large_offset_error i
 368   = error ("ERROR: SPARC native-code generator cannot handle large offset ("++show i++");\nprobably because of large constant data structures;\nworkaround: use -fvia-C on this module.\n")
 369
 370 pprRI :: PprStyle -> RI -> Unpretty
 371 pprRI sty (RIReg r) = pprReg r
 372 pprRI sty (RIImm r) = pprImm sty r
 373
 374 pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Unpretty
 375 pprSizeRegReg name size reg1 reg2 =
 376     uppBesides [
 377         uppChar '\t',
 378         uppPStr name,
 379         (case size of
 380             F  -> uppPStr SLIT("s\t")
 381             DF -> uppPStr SLIT("d\t")),
 382         pprReg reg1,
 383         uppComma,
 384         pprReg reg2
 385     ]
 386
 387 pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> Unpretty
 388 pprSizeRegRegReg name size reg1 reg2 reg3 =
 389     uppBesides [
 390         uppChar '\t',
 391         uppPStr name,
 392         (case size of
 393             F  -> uppPStr SLIT("s\t")
 394             DF -> uppPStr SLIT("d\t")),
 395         pprReg reg1,
 396         uppComma,
 397         pprReg reg2,
 398         uppComma,
 399         pprReg reg3
 400     ]
 401
 402 pprRegRIReg :: PprStyle -> FAST_STRING -> Bool -> Reg -> RI -> Reg -> Unpretty
 403 pprRegRIReg sty name b reg1 ri reg2 =
 404     uppBesides [
 405         uppChar '\t',
 406         uppPStr name,
 407         if b then uppPStr SLIT("cc\t") else uppChar '\t',
 408         pprReg reg1,
 409         uppComma,
 410         pprRI sty ri,
 411         uppComma,
 412         pprReg reg2
 413     ]
 414
 415 pprRIReg :: PprStyle -> FAST_STRING -> Bool -> RI -> Reg -> Unpretty
 416 pprRIReg sty name b ri reg1 =
 417     uppBesides [
 418         uppChar '\t',
 419         uppPStr name,
 420         if b then uppPStr SLIT("cc\t") else uppChar '\t',
 421         pprRI sty ri,
 422         uppComma,
 423         pprReg reg1
 424     ]
 425
 426 pprSize :: Size -> Unpretty
 427 pprSize x = uppPStr
 428     (case x of
 429         SB  -> SLIT("sb")
 430         HW  -> SLIT("hw")
 431         UB  -> SLIT("ub")
 432         UHW -> SLIT("uhw")
 433         W   -> SLIT("")
 434         F   -> SLIT("")
 435         D   -> SLIT("d")
 436         DF  -> SLIT("d")
 437     )
 438
 439 #ifdef USE_FAST_STRINGS
 440 pp_ld_lbracket    = uppPStr (_packCString (A# "\tld\t["#))
 441 pp_rbracket_comma = uppPStr (_packCString (A# "],"#))
 442 pp_comma_lbracket = uppPStr (_packCString (A# ",["#))
 443 pp_comma_a        = uppPStr (_packCString (A# ",a"#))
 444 #else
 445 pp_ld_lbracket    = uppStr "\tld\t["
 446 pp_rbracket_comma = uppStr "],"
 447 pp_comma_lbracket = uppStr ",["
 448 pp_comma_a        = uppStr ",a"
 449 #endif
 450
 451 pprSparcInstr :: PprStyle -> SparcInstr -> Unpretty
 452
 453 -- a clumsy hack for now, to handle possible alignment problems
 454
 455 pprSparcInstr sty (LD DF addr reg) | maybeToBool addrOff =
 456     uppBesides [
 457         pp_ld_lbracket,
 458         pprAddr sty addr,
 459         pp_rbracket_comma,
 460         pprReg reg,
 461
 462         uppChar '\n',
 463         pp_ld_lbracket,
 464         pprAddr sty addr2,
 465         pp_rbracket_comma,
 466         pprReg (fPair reg)
 467     ]
 468   where
 469     addrOff = offset addr 4
 470     addr2 = case addrOff of Just x -> x
 471
 472 pprSparcInstr sty (LD size addr reg) =
 473     uppBesides [
 474         uppPStr SLIT("\tld"),
 475         pprSize size,
 476         uppChar '\t',
 477         uppLbrack,
 478         pprAddr sty addr,
 479         pp_rbracket_comma,
 480         pprReg reg
 481     ]
 482
 483 -- The same clumsy hack as above
 484
 485 pprSparcInstr sty (ST DF reg addr) | maybeToBool addrOff =
 486     uppBesides [
 487         uppPStr SLIT("\tst\t"),
 488         pprReg reg,
 489         pp_comma_lbracket,
 490         pprAddr sty addr,
 491
 492         uppPStr SLIT("]\n\tst\t"),
 493         pprReg (fPair reg),
 494         pp_comma_lbracket,
 495         pprAddr sty addr2,
 496         uppRbrack
 497     ]
 498   where
 499     addrOff = offset addr 4
 500     addr2 = case addrOff of Just x -> x
 501
 502 pprSparcInstr sty (ST size reg addr) =
 503     uppBesides [
 504         uppPStr SLIT("\tst"),
 505         pprSize size,
 506         uppChar '\t',
 507         pprReg reg,
 508         pp_comma_lbracket,
 509         pprAddr sty addr,
 510         uppRbrack
 511     ]
 512
 513 pprSparcInstr sty (ADD x cc reg1 ri reg2)
 514  | not x && not cc && riZero ri =
 515     uppBesides [
 516         uppPStr SLIT("\tmov\t"),
 517         pprReg reg1,
 518         uppComma,
 519         pprReg reg2
 520     ]
 521  | otherwise = pprRegRIReg sty (if x then SLIT("addx") else SLIT("add")) cc reg1 ri reg2
 522
 523 pprSparcInstr sty (SUB x cc reg1 ri reg2)
 524  | not x && cc && reg2 == g0 =
 525     uppBesides [
 526         uppPStr SLIT("\tcmp\t"),
 527         pprReg reg1,
 528         uppComma,
 529         pprRI sty ri
 530     ]
 531  | not x && not cc && riZero ri =
 532     uppBesides [
 533         uppPStr SLIT("\tmov\t"),
 534         pprReg reg1,
 535         uppComma,
 536         pprReg reg2
 537     ]
 538  | otherwise = pprRegRIReg sty (if x then SLIT("subx") else SLIT("sub")) cc reg1 ri reg2
 539
 540 pprSparcInstr sty (AND b reg1 ri reg2) = pprRegRIReg sty SLIT("and") b reg1 ri reg2
 541 pprSparcInstr sty (ANDN b reg1 ri reg2) = pprRegRIReg sty SLIT("andn") b reg1 ri reg2
 542
 543 pprSparcInstr sty (OR b reg1 ri reg2)
 544  | not b && reg1 == g0 =
 545     uppBesides [
 546         uppPStr SLIT("\tmov\t"),
 547         pprRI sty ri,
 548         uppComma,
 549         pprReg reg2
 550     ]
 551  | otherwise = pprRegRIReg sty SLIT("or") b reg1 ri reg2
 552
 553 pprSparcInstr sty (ORN b reg1 ri reg2) = pprRegRIReg sty SLIT("orn") b reg1 ri reg2
 554
 555 pprSparcInstr sty (XOR b reg1 ri reg2) = pprRegRIReg sty SLIT("xor") b reg1 ri reg2
 556 pprSparcInstr sty (XNOR b reg1 ri reg2) = pprRegRIReg sty SLIT("xnor") b reg1 ri reg2
 557
 558 pprSparcInstr sty (SLL reg1 ri reg2) = pprRegRIReg sty SLIT("sll") False reg1 ri reg2
 559 pprSparcInstr sty (SRL reg1 ri reg2) = pprRegRIReg sty SLIT("srl") False reg1 ri reg2
 560 pprSparcInstr sty (SRA reg1 ri reg2) = pprRegRIReg sty SLIT("sra") False reg1 ri reg2
 561
 562 pprSparcInstr sty (SETHI imm reg) =
 563     uppBesides [
 564         uppPStr SLIT("\tsethi\t"),
 565         pprImm sty imm,
 566         uppComma,
 567         pprReg reg
 568     ]
 569
 570 pprSparcInstr sty (NOP) = uppPStr SLIT("\tnop")
 571
 572 pprSparcInstr sty (FABS F reg1 reg2) = pprSizeRegReg SLIT("fabs") F reg1 reg2
 573 pprSparcInstr sty (FABS DF reg1 reg2) =
 574     uppBeside (pprSizeRegReg SLIT("fabs") F reg1 reg2)
 575     (if (reg1 == reg2) then uppNil
 576      else uppBeside (uppChar '\n')
 577           (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
 578
 579 pprSparcInstr sty (FADD size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fadd") size reg1 reg2 reg3
 580 pprSparcInstr sty (FCMP e size reg1 reg2) =
 581     pprSizeRegReg (if e then SLIT("fcmpe") else SLIT("fcmp")) size reg1 reg2
 582 pprSparcInstr sty (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fdiv") size reg1 reg2 reg3
 583
 584 pprSparcInstr sty (FMOV F reg1 reg2) = pprSizeRegReg SLIT("fmov") F reg1 reg2
 585 pprSparcInstr sty (FMOV DF reg1 reg2) =
 586     uppBeside (pprSizeRegReg SLIT("fmov") F reg1 reg2)
 587     (if (reg1 == reg2) then uppNil
 588      else uppBeside (uppChar '\n')
 589           (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
 590
 591 pprSparcInstr sty (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fmul") size reg1 reg2 reg3
 592
 593 pprSparcInstr sty (FNEG F reg1 reg2) = pprSizeRegReg SLIT("fneg") F reg1 reg2
 594 pprSparcInstr sty (FNEG DF reg1 reg2) =
 595     uppBeside (pprSizeRegReg SLIT("fneg") F reg1 reg2)
 596     (if (reg1 == reg2) then uppNil
 597      else uppBeside (uppChar '\n')
 598           (pprSizeRegReg SLIT("fmov") F (fPair reg1) (fPair reg2)))
 599
 600 pprSparcInstr sty (FSQRT size reg1 reg2) = pprSizeRegReg SLIT("fsqrt") size reg1 reg2
 601 pprSparcInstr sty (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg SLIT("fsub") size reg1 reg2 reg3
 602 pprSparcInstr sty (FxTOy size1 size2 reg1 reg2) =
 603     uppBesides [
 604         uppPStr SLIT("\tf"),
 605         uppPStr
 606         (case size1 of
 607             W  -> SLIT("ito")
 608             F  -> SLIT("sto")
 609             DF -> SLIT("dto")),
 610         uppPStr
 611         (case size2 of
 612             W  -> SLIT("i\t")
 613             F  -> SLIT("s\t")
 614             DF -> SLIT("d\t")),
 615         pprReg reg1,
 616         uppComma,
 617         pprReg reg2
 618     ]
 619
 620
 621 pprSparcInstr sty (BI cond b lab) =
 622     uppBesides [
 623         uppPStr SLIT("\tb"), pprCond cond,
 624         if b then pp_comma_a else uppNil,
 625         uppChar '\t',
 626         pprImm sty lab
 627     ]
 628
 629 pprSparcInstr sty (BF cond b lab) =
 630     uppBesides [
 631         uppPStr SLIT("\tfb"), pprCond cond,
 632         if b then pp_comma_a else uppNil,
 633         uppChar '\t',
 634         pprImm sty lab
 635     ]
 636
 637 pprSparcInstr sty (JMP addr) = uppBeside (uppPStr SLIT("\tjmp\t")) (pprAddr sty addr)
 638
 639 pprSparcInstr sty (CALL imm n _) =
 640     uppBesides [
 641         uppPStr SLIT("\tcall\t"),
 642         pprImm sty imm,
 643         uppComma,
 644         uppInt n
 645     ]
 646
 647 pprSparcInstr sty (LABEL clab) =
 648     uppBesides [
 649         if (externallyVisibleCLabel clab) then
 650             uppBesides [uppPStr SLIT("\t.global\t"), pprLab, uppChar '\n']
 651         else
 652             uppNil,
 653         pprLab,
 654         uppChar ':'
 655     ]
 656     where pprLab = pprCLabel sty clab
 657
 658 pprSparcInstr sty (COMMENT s) = uppBeside (uppPStr SLIT("! ")) (uppPStr s)
 659
 660 pprSparcInstr sty (SEGMENT TextSegment)
 661     = uppPStr SLIT("\t.text\n\t.align 4")
 662
 663 pprSparcInstr sty (SEGMENT DataSegment)
 664     = uppPStr SLIT("\t.data\n\t.align 8")   -- Less than 8 will break double constants
 665
 666 pprSparcInstr sty (ASCII False str) =
 667     uppBesides [
 668         uppStr "\t.asciz \"",
 669         uppStr str,
 670         uppChar '"'
 671     ]
 672
 673 pprSparcInstr sty (ASCII True str) = uppBeside (uppStr "\t.ascii \"") (asciify str 60)
 674     where
 675         asciify :: String -> Int -> Unpretty
 676         asciify [] _ = uppStr ("\\0\"")
 677         asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60)
 678         asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
 679         asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
 680         asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
 681         asciify [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\""))
 682         asciify (c:(cs@(d:_))) n | isDigit d =
 683                                         uppBeside (uppStr (charToC c)) (asciify cs 0)
 684                                  | otherwise =
 685                                         uppBeside (uppStr (charToC c)) (asciify cs (n-1))
 686
 687 pprSparcInstr sty (DATA s xs) = uppInterleave (uppChar '\n') (map pp_item xs)
 688     where pp_item x = case s of
 689             SB -> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x)
 690             UB -> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x)
 691             W  -> uppBeside (uppPStr SLIT("\t.word\t")) (pprImm sty x)
 692             DF -> uppBeside (uppPStr SLIT("\t.double\t")) (pprImm sty x)
 693
 694 \end{code}
 695
 696 %************************************************************************
 697 %*                                                                      *
 698 \subsection[Schedule]{Register allocation information}
 699 %*                                                                      *
 700 %************************************************************************
 701
 702 Getting the conflicts right is a bit tedious for doubles.  We'd have to
 703 add a conflict function to the MachineRegisters class, and we'd have to
 704 put a PrimKind in the MappedReg datatype, or use some kludge (e.g. register
 705 64 + n is really the same as 32 + n, except that it's used for a double,
 706 so it also conflicts with 33 + n) to deal with it.  It's just not worth the
 707 bother, so we just partition the free floating point registers into two
 708 sets: one for single precision and one for double precision.  We never seem
 709 to run out of floating point registers anyway.
 710
 711 \begin{code}
 712
 713 data SparcRegs = SRegs BitSet BitSet BitSet
 714
 715 instance MachineRegisters SparcRegs where
 716     mkMRegs xs = SRegs (mkBS ints) (mkBS singles') (mkBS doubles')
 717       where
 718         (ints, floats) = partition (< 32) xs
 719         (singles, doubles) = partition (< 48) floats
 720         singles' = map (subtract 32) singles
 721         doubles' = map (subtract 32) (filter even doubles)
 722
 723     possibleMRegs FloatKind (SRegs _ singles _) = [ x + 32 | x <- listBS singles]
 724     possibleMRegs DoubleKind (SRegs _ _ doubles) = [ x + 32 | x <- listBS doubles]
 725     possibleMRegs _ (SRegs ints _ _) = listBS ints
 726
 727     useMReg (SRegs ints singles doubles) n =
 728         if n _LT_ ILIT(32) then SRegs (ints `minusBS` singletonBS IBOX(n)) singles doubles
 729         else if n _LT_ ILIT(48) then SRegs ints (singles `minusBS` singletonBS (IBOX(n _SUB_ ILIT(32)))) doubles
 730         else SRegs ints singles (doubles `minusBS` singletonBS (IBOX(n _SUB_ ILIT(32))))
 731
 732     useMRegs (SRegs ints singles doubles) xs =
 733         SRegs (ints `minusBS` ints')
 734               (singles `minusBS` singles')
 735               (doubles `minusBS` doubles')
 736       where
 737         SRegs ints' singles' doubles' = mkMRegs xs
 738
 739     freeMReg (SRegs ints singles doubles) n =
 740         if n _LT_ ILIT(32) then SRegs (ints `unionBS` singletonBS IBOX(n)) singles doubles
 741         else if n _LT_ ILIT(48) then SRegs ints (singles `unionBS` singletonBS (IBOX(n _SUB_ ILIT(32)))) doubles
 742         else SRegs ints singles (doubles `unionBS` singletonBS (IBOX(n _SUB_ ILIT(32))))
 743
 744     freeMRegs (SRegs ints singles doubles) xs =
 745         SRegs (ints `unionBS` ints')
 746               (singles `unionBS` singles')
 747               (doubles `unionBS` doubles')
 748       where
 749         SRegs ints' singles' doubles' = mkMRegs xs
 750
 751 instance MachineCode SparcInstr where
 752     -- Alas, we don't do anything clever with our OrdLists
 753 --OLD:
 754 --  flatten = flattenOrdList
 755
 756     regUsage = sparcRegUsage
 757     regLiveness = sparcRegLiveness
 758     patchRegs = sparcPatchRegs
 759
 760     -- We spill just below the frame pointer, leaving two words per spill location.
 761     spillReg dyn (MemoryReg i pk) = mkUnitList (ST (kindToSize pk) dyn (fpRel (-2 * i)))
 762     loadReg (MemoryReg i pk) dyn = mkUnitList (LD (kindToSize pk) (fpRel (-2 * i)) dyn)
 763
 764 -- Duznae work for offsets greater than 13 bits; we just hope for the best
 765 fpRel :: Int -> Addr
 766 fpRel n = AddrRegImm fp (ImmInt (n * 4))
 767
 768 kindToSize :: PrimKind -> Size
 769 kindToSize PtrKind          = W
 770 kindToSize CodePtrKind      = W
 771 kindToSize DataPtrKind      = W
 772 kindToSize RetKind          = W
 773 kindToSize InfoPtrKind      = W
 774 kindToSize CostCentreKind   = W
 775 kindToSize CharKind         = UB
 776 kindToSize IntKind          = W
 777 kindToSize WordKind         = W
 778 kindToSize AddrKind         = W
 779 kindToSize FloatKind        = F
 780 kindToSize DoubleKind       = DF
 781 kindToSize ArrayKind        = W
 782 kindToSize ByteArrayKind    = W
 783 kindToSize StablePtrKind    = W
 784 kindToSize MallocPtrKind    = W
 785
 786 \end{code}
 787
 788 @sparcRegUsage@ returns the sets of src and destination registers used by
 789 a particular instruction.  Machine registers that are pre-allocated
 790 to stgRegs are filtered out, because they are uninteresting from a
 791 register allocation standpoint.  (We wouldn't want them to end up on
 792 the free list!)
 793
 794 \begin{code}
 795
 796 sparcRegUsage :: SparcInstr -> RegUsage
 797 sparcRegUsage instr = case instr of
 798     LD sz addr reg      -> usage (regAddr addr, [reg])
 799     ST sz reg addr      -> usage (reg : regAddr addr, [])
 800     ADD x cc r1 ar r2   -> usage (r1 : regRI ar, [r2])
 801     SUB x cc r1 ar r2   -> usage (r1 : regRI ar, [r2])
 802     AND b r1 ar r2      -> usage (r1 : regRI ar, [r2])
 803     ANDN b r1 ar r2     -> usage (r1 : regRI ar, [r2])
 804     OR b r1 ar r2       -> usage (r1 : regRI ar, [r2])
 805     ORN b r1 ar r2      -> usage (r1 : regRI ar, [r2])
 806     XOR b r1 ar r2      -> usage (r1 : regRI ar, [r2])
 807     XNOR b r1 ar r2     -> usage (r1 : regRI ar, [r2])
 808     SLL r1 ar r2        -> usage (r1 : regRI ar, [r2])
 809     SRL r1 ar r2        -> usage (r1 : regRI ar, [r2])
 810     SRA r1 ar r2        -> usage (r1 : regRI ar, [r2])
 811     SETHI imm reg       -> usage ([], [reg])
 812     FABS s r1 r2        -> usage ([r1], [r2])
 813     FADD s r1 r2 r3     -> usage ([r1, r2], [r3])
 814     FCMP e s r1 r2      -> usage ([r1, r2], [])
 815     FDIV s r1 r2 r3     -> usage ([r1, r2], [r3])
 816     FMOV s r1 r2        -> usage ([r1], [r2])
 817     FMUL s r1 r2 r3     -> usage ([r1, r2], [r3])
 818     FNEG s r1 r2        -> usage ([r1], [r2])
 819     FSQRT s r1 r2       -> usage ([r1], [r2])
 820     FSUB s r1 r2 r3     -> usage ([r1, r2], [r3])
 821     FxTOy s1 s2 r1 r2   -> usage ([r1], [r2])
 822
 823     -- We assume that all local jumps will be BI/BF.  JMP must be out-of-line.
 824     JMP addr            -> RU (mkUniqSet (filter interesting (regAddr addr))) freeSet
 825
 826     CALL _ n True       -> endUsage
 827     CALL _ n False      -> RU (argSet n) callClobberedSet
 828
 829     _                   -> noUsage
 830
 831   where
 832     usage (src, dst) = RU (mkUniqSet (filter interesting src))
 833                           (mkUniqSet (filter interesting dst))
 834
 835     interesting (FixedReg _) = False
 836     interesting _ = True
 837
 838     regAddr (AddrRegReg r1 r2) = [r1, r2]
 839     regAddr (AddrRegImm r1 _)  = [r1]
 840
 841     regRI (RIReg r) = [r]
 842     regRI  _    = []
 843
 844 freeRegs :: [Reg]
 845 freeRegs = freeMappedRegs (\ x -> x) [0..63]
 846
 847 freeMappedRegs :: (Int -> Int) -> [Int] -> [Reg]
 848
 849 freeMappedRegs modify nums
 850   = foldr free [] nums
 851   where
 852     free n acc
 853       = let
 854             modified_i = case (modify n) of { IBOX(x) -> x }
 855         in
 856         if _IS_TRUE_(freeReg modified_i) then (MappedReg modified_i) : acc else acc
 857
 858 freeSet :: UniqSet Reg
 859 freeSet = mkUniqSet freeRegs
 860
 861 noUsage :: RegUsage
 862 noUsage = RU emptyUniqSet emptyUniqSet
 863
 864 endUsage :: RegUsage
 865 endUsage = RU emptyUniqSet freeSet
 866
 867 -- Color me CAF-like
 868 argSet :: Int -> UniqSet Reg
 869 argSet 0 = emptyUniqSet
 870 argSet 1 = mkUniqSet (freeMappedRegs oReg [0])
 871 argSet 2 = mkUniqSet (freeMappedRegs oReg [0,1])
 872 argSet 3 = mkUniqSet (freeMappedRegs oReg [0,1,2])
 873 argSet 4 = mkUniqSet (freeMappedRegs oReg [0,1,2,3])
 874 argSet 5 = mkUniqSet (freeMappedRegs oReg [0,1,2,3,4])
 875 argSet 6 = mkUniqSet (freeMappedRegs oReg [0,1,2,3,4,5])
 876
 877 callClobberedSet :: UniqSet Reg
 878 callClobberedSet = mkUniqSet callClobberedRegs
 879   where
 880     callClobberedRegs = freeMappedRegs (\x -> x)
 881       ( oReg 7 :
 882         [oReg i | i <- [0..5]] ++
 883         [gReg i | i <- [1..7]] ++
 884         [fReg i | i <- [0..31]] )
 885
 886 \end{code}
 887
 888 @sparcRegLiveness@ takes future liveness information and modifies it according to
 889 the semantics of branches and labels.  (An out-of-line branch clobbers the liveness
 890 passed back by the following instruction; a forward local branch passes back the
 891 liveness from the target label; a conditional branch merges the liveness from the
 892 target and the liveness from its successor; a label stashes away the current liveness
 893 in the future liveness environment).
 894
 895 \begin{code}
 896 sparcRegLiveness :: SparcInstr -> RegLiveness -> RegLiveness
 897 sparcRegLiveness instr info@(RL live future@(FL all env)) = case instr of
 898
 899     -- We assume that all local jumps will be BI/BF.  JMP must be out-of-line.
 900
 901     BI ALWAYS _ (ImmCLbl lbl)   -> RL (lookup lbl) future
 902     BI _ _ (ImmCLbl lbl)        -> RL (lookup lbl `unionUniqSets` live) future
 903     BF ALWAYS _ (ImmCLbl lbl)   -> RL (lookup lbl) future
 904     BF _ _ (ImmCLbl lbl)        -> RL (lookup lbl `unionUniqSets` live) future
 905     JMP _                       -> RL emptyUniqSet future
 906     CALL _ i True   -> RL emptyUniqSet future
 907     CALL _ i False  -> RL live future
 908     LABEL lbl       -> RL live (FL (all `unionUniqSets` live) (addToFM env lbl live))
 909     _               -> info
 910
 911   where
 912     lookup lbl = case lookupFM env lbl of
 913         Just regs -> regs
 914         Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel (PprForAsm (\_->False) False id) lbl)) ++
 915                           " in future?") emptyUniqSet
 916
 917 \end{code}
 918
 919 @sparcPatchRegs@ takes an instruction (possibly with MemoryReg/UnmappedReg registers) and
 920 changes all register references according to the supplied environment.
 921
 922 \begin{code}
 923
 924 sparcPatchRegs :: SparcInstr -> (Reg -> Reg) -> SparcInstr
 925 sparcPatchRegs instr env = case instr of
 926     LD sz addr reg -> LD sz (fixAddr addr) (env reg)
 927     ST sz reg addr -> ST sz (env reg) (fixAddr addr)
 928     ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2)
 929     SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2)
 930     AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2)
 931     ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2)
 932     OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2)
 933     ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2)
 934     XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2)
 935     XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2)
 936     SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2)
 937     SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2)
 938     SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2)
 939     SETHI imm reg -> SETHI imm (env reg)
 940     FABS s r1 r2 -> FABS s (env r1) (env r2)
 941     FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3)
 942     FCMP e s r1 r2 -> FCMP e s (env r1) (env r2)
 943     FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3)
 944     FMOV s r1 r2 -> FMOV s (env r1) (env r2)
 945     FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3)
 946     FNEG s r1 r2 -> FNEG s (env r1) (env r2)
 947     FSQRT s r1 r2 -> FSQRT s (env r1) (env r2)
 948     FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3)
 949     FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2)
 950     JMP addr -> JMP (fixAddr addr)
 951     _ -> instr
 952
 953   where
 954     fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)
 955     fixAddr (AddrRegImm r1 i)  = AddrRegImm (env r1) i
 956
 957     fixRI (RIReg r) = RIReg (env r)
 958     fixRI other = other
 959 \end{code}
 960
 961 Sometimes, we want to be able to modify addresses at compile time.
 962 (Okay, just for chrCode of a fetch.)
 963
 964 \begin{code}
 965
 966 #ifdef __GLASGOW_HASKELL__
 967
 968 {-# SPECIALIZE
 969     is13Bits :: Int -> Bool
 970   #-}
 971 {-# SPECIALIZE
 972     is13Bits :: Integer -> Bool
 973   #-}
 974
 975 #endif
 976
 977 is13Bits :: Integral a => a -> Bool
 978 is13Bits x = x >= -4096 && x < 4096
 979
 980 offset :: Addr -> Int -> Maybe Addr
 981
 982 offset (AddrRegImm reg (ImmInt n)) off
 983   | is13Bits n2 = Just (AddrRegImm reg (ImmInt n2))
 984   | otherwise = Nothing
 985   where n2 = n + off
 986
 987 offset (AddrRegImm reg (ImmInteger n)) off
 988   | is13Bits n2 = Just (AddrRegImm reg (ImmInt (fromInteger n2)))
 989   | otherwise = Nothing
 990   where n2 = n + toInteger off
 991
 992 offset (AddrRegReg reg (FixedReg ILIT(0))) off
 993   | is13Bits off = Just (AddrRegImm reg (ImmInt off))
 994   | otherwise = Nothing
 995
 996 offset _ _ = Nothing
 997
 998 \end{code}
 999
1000 If you value your sanity, do not venture below this line.
1001
1002 \begin{code}
1003
1004 -- platform.h is generate and tells us what the target architecture is
1005 #include "../../includes/platform.h"
1006 #include "../../includes/MachRegs.h"
1007 #if sunos4_TARGET_OS
1008 #include "../../includes/sparc-sun-sunos4.h"
1009 #else
1010 #include "../../includes/sparc-sun-solaris2.h"
1011 #endif
1012
1013 -- Redefine the literals used for Sparc register names in the header
1014 -- files.  Gag me with a spoon, eh?
1015
1016 #define g0 0
1017 #define g1 1
1018 #define g2 2
1019 #define g3 3
1020 #define g4 4
1021 #define g5 5
1022 #define g6 6
1023 #define g7 7
1024 #define o0 8
1025 #define o1 9
1026 #define o2 10
1027 #define o3 11
1028 #define o4 12
1029 #define o5 13
1030 #define o6 14
1031 #define o7 15
1032 #define l0 16
1033 #define l1 17
1034 #define l2 18
1035 #define l3 19
1036 #define l4 20
1037 #define l5 21
1038 #define l6 22
1039 #define l7 23
1040 #define i0 24
1041 #define i1 25
1042 #define i2 26
1043 #define i3 27
1044 #define i4 28
1045 #define i5 29
1046 #define i6 30
1047 #define i7 31
1048 #define f0 32
1049 #define f1 33
1050 #define f2 34
1051 #define f3 35
1052 #define f4 36
1053 #define f5 37
1054 #define f6 38
1055 #define f7 39
1056 #define f8 40
1057 #define f9 41
1058 #define f10 42
1059 #define f11 43
1060 #define f12 44
1061 #define f13 45
1062 #define f14 46
1063 #define f15 47
1064 #define f16 48
1065 #define f17 49
1066 #define f18 50
1067 #define f19 51
1068 #define f20 52
1069 #define f21 53
1070 #define f22 54
1071 #define f23 55
1072 #define f24 56
1073 #define f25 57
1074 #define f26 58
1075 #define f27 59
1076 #define f28 60
1077 #define f29 61
1078 #define f30 62
1079 #define f31 63
1080
1081 baseRegOffset :: MagicId -> Int
1082 baseRegOffset StkOReg                   = OFFSET_StkO
1083 baseRegOffset (VanillaReg _ ILIT2(1))   = OFFSET_R1
1084 baseRegOffset (VanillaReg _ ILIT2(2))   = OFFSET_R2
1085 baseRegOffset (VanillaReg _ ILIT2(3))   = OFFSET_R3
1086 baseRegOffset (VanillaReg _ ILIT2(4))   = OFFSET_R4
1087 baseRegOffset (VanillaReg _ ILIT2(5))   = OFFSET_R5
1088 baseRegOffset (VanillaReg _ ILIT2(6))   = OFFSET_R6
1089 baseRegOffset (VanillaReg _ ILIT2(7))   = OFFSET_R7
1090 baseRegOffset (VanillaReg _ ILIT2(8))   = OFFSET_R8
1091 baseRegOffset (FloatReg ILIT2(1))       = OFFSET_Flt1
1092 baseRegOffset (FloatReg ILIT2(2))       = OFFSET_Flt2
1093 baseRegOffset (FloatReg ILIT2(3))       = OFFSET_Flt3
1094 baseRegOffset (FloatReg ILIT2(4))       = OFFSET_Flt4
1095 baseRegOffset (DoubleReg ILIT2(1))      = OFFSET_Dbl1
1096 baseRegOffset (DoubleReg ILIT2(2))      = OFFSET_Dbl2
1097 baseRegOffset TagReg                    = OFFSET_Tag
1098 baseRegOffset RetReg                    = OFFSET_Ret
1099 baseRegOffset SpA                       = OFFSET_SpA
1100 baseRegOffset SuA                       = OFFSET_SuA
1101 baseRegOffset SpB                       = OFFSET_SpB
1102 baseRegOffset SuB                       = OFFSET_SuB
1103 baseRegOffset Hp                        = OFFSET_Hp
1104 baseRegOffset HpLim                     = OFFSET_HpLim
1105 baseRegOffset LivenessReg               = OFFSET_Liveness
1106 --baseRegOffset ActivityReg             = OFFSET_Activity
1107 #ifdef DEBUG
1108 baseRegOffset BaseReg                   = panic "baseRegOffset:BaseReg"
1109 baseRegOffset StdUpdRetVecReg           = panic "baseRegOffset:StgUpdRetVecReg"
1110 baseRegOffset StkStubReg                = panic "baseRegOffset:StkStubReg"
1111 baseRegOffset CurCostCentre             = panic "baseRegOffset:CurCostCentre"
1112 baseRegOffset VoidReg                   = panic "baseRegOffset:VoidReg"
1113 #endif
1114
1115 callerSaves :: MagicId -> Bool
1116 #ifdef CALLER_SAVES_Base
1117 callerSaves BaseReg             = True
1118 #endif
1119 #ifdef CALLER_SAVES_StkO
1120 callerSaves StkOReg             = True
1121 #endif
1122 #ifdef CALLER_SAVES_R1
1123 callerSaves (VanillaReg _ ILIT2(1))     = True
1124 #endif
1125 #ifdef CALLER_SAVES_R2
1126 callerSaves (VanillaReg _ ILIT2(2))    = True
1127 #endif
1128 #ifdef CALLER_SAVES_R3
1129 callerSaves (VanillaReg _ ILIT2(3))    = True
1130 #endif
1131 #ifdef CALLER_SAVES_R4
1132 callerSaves (VanillaReg _ ILIT2(4))    = True
1133 #endif
1134 #ifdef CALLER_SAVES_R5
1135 callerSaves (VanillaReg _ ILIT2(5))    = True
1136 #endif
1137 #ifdef CALLER_SAVES_R6
1138 callerSaves (VanillaReg _ ILIT2(6))    = True
1139 #endif
1140 #ifdef CALLER_SAVES_R7
1141 callerSaves (VanillaReg _ ILIT2(7))     = True
1142 #endif
1143 #ifdef CALLER_SAVES_R8
1144 callerSaves (VanillaReg _ ILIT2(8))    = True
1145 #endif
1146 #ifdef CALLER_SAVES_FltReg1
1147 callerSaves (FloatReg ILIT2(1))         = True
1148 #endif
1149 #ifdef CALLER_SAVES_FltReg2
1150 callerSaves (FloatReg ILIT2(2))         = True
1151 #endif
1152 #ifdef CALLER_SAVES_FltReg3
1153 callerSaves (FloatReg ILIT2(3))         = True
1154 #endif
1155 #ifdef CALLER_SAVES_FltReg4
1156 callerSaves (FloatReg ILIT2(4))         = True
1157 #endif
1158 #ifdef CALLER_SAVES_DblReg1
1159 callerSaves (DoubleReg ILIT2(1))        = True
1160 #endif
1161 #ifdef CALLER_SAVES_DblReg2
1162 callerSaves (DoubleReg ILIT2(2))        = True
1163 #endif
1164 #ifdef CALLER_SAVES_Tag
1165 callerSaves TagReg              = True
1166 #endif
1167 #ifdef CALLER_SAVES_Ret
1168 callerSaves RetReg              = True
1169 #endif
1170 #ifdef CALLER_SAVES_SpA
1171 callerSaves SpA                 = True
1172 #endif
1173 #ifdef CALLER_SAVES_SuA
1174 callerSaves SuA                 = True
1175 #endif
1176 #ifdef CALLER_SAVES_SpB
1177 callerSaves SpB                 = True
1178 #endif
1179 #ifdef CALLER_SAVES_SuB
1180 callerSaves SuB                 = True
1181 #endif
1182 #ifdef CALLER_SAVES_Hp
1183 callerSaves Hp                  = True
1184 #endif
1185 #ifdef CALLER_SAVES_HpLim
1186 callerSaves HpLim               = True
1187 #endif
1188 #ifdef CALLER_SAVES_Liveness
1189 callerSaves LivenessReg         = True
1190 #endif
1191 #ifdef CALLER_SAVES_Activity
1192 --callerSaves ActivityReg               = True
1193 #endif
1194 #ifdef CALLER_SAVES_StdUpdRetVec
1195 callerSaves StdUpdRetVecReg     = True
1196 #endif
1197 #ifdef CALLER_SAVES_StkStub
1198 callerSaves StkStubReg          = True
1199 #endif
1200 callerSaves _                   = False
1201
1202 stgRegMap :: MagicId -> Maybe Reg
1203 #ifdef REG_Base
1204 stgRegMap BaseReg          = Just (FixedReg ILIT(REG_Base))
1205 #endif
1206 #ifdef REG_StkO
1207 stgRegMap StkOReg          = Just (FixedReg ILIT(REG_StkOReg))
1208 #endif
1209 #ifdef REG_R1
1210 stgRegMap (VanillaReg _ ILIT2(1)) = Just (FixedReg ILIT(REG_R1))
1211 #endif
1212 #ifdef REG_R2
1213 stgRegMap (VanillaReg _ ILIT2(2)) = Just (FixedReg ILIT(REG_R2))
1214 #endif
1215 #ifdef REG_R3
1216 stgRegMap (VanillaReg _ ILIT2(3)) = Just (FixedReg ILIT(REG_R3))
1217 #endif
1218 #ifdef REG_R4
1219 stgRegMap (VanillaReg _ ILIT2(4)) = Just (FixedReg ILIT(REG_R4))
1220 #endif
1221 #ifdef REG_R5
1222 stgRegMap (VanillaReg _ ILIT2(5)) = Just (FixedReg ILIT(REG_R5))
1223 #endif
1224 #ifdef REG_R6
1225 stgRegMap (VanillaReg _ ILIT2(6)) = Just (FixedReg ILIT(REG_R6))
1226 #endif
1227 #ifdef REG_R7
1228 stgRegMap (VanillaReg _ ILIT2(7)) = Just (FixedReg ILIT(REG_R7))
1229 #endif
1230 #ifdef REG_R8
1231 stgRegMap (VanillaReg _ ILIT2(8)) = Just (FixedReg ILIT(REG_R8))
1232 #endif
1233 #ifdef REG_Flt1
1234 stgRegMap (FloatReg ILIT2(1))      = Just (FixedReg ILIT(REG_Flt1))
1235 #endif
1236 #ifdef REG_Flt2
1237 stgRegMap (FloatReg ILIT2(2))      = Just (FixedReg ILIT(REG_Flt2))
1238 #endif
1239 #ifdef REG_Flt3
1240 stgRegMap (FloatReg ILIT2(3))      = Just (FixedReg ILIT(REG_Flt3))
1241 #endif
1242 #ifdef REG_Flt4
1243 stgRegMap (FloatReg ILIT2(4))      = Just (FixedReg ILIT(REG_Flt4))
1244 #endif
1245 #ifdef REG_Dbl1
1246 stgRegMap (DoubleReg ILIT2(1))     = Just (FixedReg ILIT(REG_Dbl1))
1247 #endif
1248 #ifdef REG_Dbl2
1249 stgRegMap (DoubleReg ILIT2(2))     = Just (FixedReg ILIT(REG_Dbl2))
1250 #endif
1251 #ifdef REG_Tag
1252 stgRegMap TagReg           = Just (FixedReg ILIT(REG_TagReg))
1253 #endif
1254 #ifdef REG_Ret
1255 stgRegMap RetReg           = Just (FixedReg ILIT(REG_Ret))
1256 #endif
1257 #ifdef REG_SpA
1258 stgRegMap SpA              = Just (FixedReg ILIT(REG_SpA))
1259 #endif
1260 #ifdef REG_SuA
1261 stgRegMap SuA              = Just (FixedReg ILIT(REG_SuA))
1262 #endif
1263 #ifdef REG_SpB
1264 stgRegMap SpB              = Just (FixedReg ILIT(REG_SpB))
1265 #endif
1266 #ifdef REG_SuB
1267 stgRegMap SuB              = Just (FixedReg ILIT(REG_SuB))
1268 #endif
1269 #ifdef REG_Hp
1270 stgRegMap Hp               = Just (FixedReg ILIT(REG_Hp))
1271 #endif
1272 #ifdef REG_HpLim
1273 stgRegMap HpLim            = Just (FixedReg ILIT(REG_HpLim))
1274 #endif
1275 #ifdef REG_Liveness
1276 stgRegMap LivenessReg      = Just (FixedReg ILIT(REG_Liveness))
1277 #endif
1278 #ifdef REG_Activity
1279 --stgRegMap ActivityReg    = Just (FixedReg ILIT(REG_Activity))
1280 #endif
1281 #ifdef REG_StdUpdRetVec
1282 stgRegMap StdUpdRetVecReg  = Just (FixedReg ILIT(REG_StdUpdRetVec))
1283 #endif
1284 #ifdef REG_StkStub
1285 stgRegMap StkStubReg       = Just (FixedReg ILIT(REG_StkStub))
1286 #endif
1287 stgRegMap _                = Nothing
1288
1289 \end{code}
1290
1291 Here is the list of registers we can use in register allocation.
1292
1293 \begin{code}
1294
1295 freeReg :: FAST_INT -> FAST_BOOL
1296
1297 freeReg ILIT(g0) = _FALSE_  --  %g0 is always 0.
1298 freeReg ILIT(g5) = _FALSE_  --  %g5 is reserved (ABI).
1299 freeReg ILIT(g6) = _FALSE_  --  %g6 is reserved (ABI).
1300 freeReg ILIT(g7) = _FALSE_  --  %g7 is reserved (ABI).
1301 freeReg ILIT(i6) = _FALSE_  --  %i6 is our frame pointer.
1302 freeReg ILIT(o6) = _FALSE_  --  %o6 is our stack pointer.
1303
1304 #ifdef REG_Base
1305 freeReg ILIT(REG_Base) = _FALSE_
1306 #endif
1307 #ifdef REG_StkO
1308 freeReg ILIT(REG_StkO) = _FALSE_
1309 #endif
1310 #ifdef REG_R1
1311 freeReg ILIT(REG_R1) = _FALSE_
1312 #endif
1313 #ifdef REG_R2
1314 freeReg ILIT(REG_R2) = _FALSE_
1315 #endif
1316 #ifdef REG_R3
1317 freeReg ILIT(REG_R3) = _FALSE_
1318 #endif
1319 #ifdef REG_R4
1320 freeReg ILIT(REG_R4) = _FALSE_
1321 #endif
1322 #ifdef REG_R5
1323 freeReg ILIT(REG_R5) = _FALSE_
1324 #endif
1325 #ifdef REG_R6
1326 freeReg ILIT(REG_R6) = _FALSE_
1327 #endif
1328 #ifdef REG_R7
1329 freeReg ILIT(REG_R7) = _FALSE_
1330 #endif
1331 #ifdef REG_R8
1332 freeReg ILIT(REG_R8) = _FALSE_
1333 #endif
1334 #ifdef REG_Flt1
1335 freeReg ILIT(REG_Flt1) = _FALSE_
1336 #endif
1337 #ifdef REG_Flt2
1338 freeReg ILIT(REG_Flt2) = _FALSE_
1339 #endif
1340 #ifdef REG_Flt3
1341 freeReg ILIT(REG_Flt3) = _FALSE_
1342 #endif
1343 #ifdef REG_Flt4
1344 freeReg ILIT(REG_Flt4) = _FALSE_
1345 #endif
1346 #ifdef REG_Dbl1
1347 freeReg ILIT(REG_Dbl1) = _FALSE_
1348 #endif
1349 #ifdef REG_Dbl2
1350 freeReg ILIT(REG_Dbl2) = _FALSE_
1351 #endif
1352 #ifdef REG_Tag
1353 freeReg ILIT(REG_Tag) = _FALSE_
1354 #endif
1355 #ifdef REG_Ret
1356 freeReg ILIT(REG_Ret) = _FALSE_
1357 #endif
1358 #ifdef REG_SpA
1359 freeReg ILIT(REG_SpA) = _FALSE_
1360 #endif
1361 #ifdef REG_SuA
1362 freeReg ILIT(REG_SuA) = _FALSE_
1363 #endif
1364 #ifdef REG_SpB
1365 freeReg ILIT(REG_SpB) = _FALSE_
1366 #endif
1367 #ifdef REG_SuB
1368 freeReg ILIT(REG_SuB) = _FALSE_
1369 #endif
1370 #ifdef REG_Hp
1371 freeReg ILIT(REG_Hp) = _FALSE_
1372 #endif
1373 #ifdef REG_HpLim
1374 freeReg ILIT(REG_HpLim) = _FALSE_
1375 #endif
1376 #ifdef REG_Liveness
1377 freeReg ILIT(REG_Liveness) = _FALSE_
1378 #endif
1379 #ifdef REG_Activity
1380 --freeReg ILIT(REG_Activity) = _FALSE_
1381 #endif
1382 #ifdef REG_StdUpdRetVec
1383 freeReg ILIT(REG_StdUpdRetVec) = _FALSE_
1384 #endif
1385 #ifdef REG_StkStub
1386 freeReg ILIT(REG_StkStub) = _FALSE_
1387 #endif
1388 freeReg n
1389 #ifdef REG_Dbl1
1390   | n _EQ_ (ILIT(REG_Dbl1) _ADD_ ILIT(1)) = _FALSE_
1391 #endif
1392 #ifdef REG_Dbl2
1393   | n _EQ_ (ILIT(REG_Dbl2) _ADD_ ILIT(1)) = _FALSE_
1394 #endif
1395   | otherwise = _TRUE_
1396
1397 reservedRegs :: [Int]
1398 reservedRegs = [NCG_Reserved_I1, NCG_Reserved_I2,
1399                 NCG_Reserved_F1, NCG_Reserved_F2,
1400                 NCG_Reserved_D1, NCG_Reserved_D2]
1401
1402 \end{code}
1403