ghc/compiler/nativeGen/I386Code.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1995
   3 %
   4
   5 \section[I386Code]{The Native (I386) Machine Code}
   6
   7 \begin{code}
   8 #define ILIT2(x) ILIT(x)
   9 #include "HsVersions.h"
  10
  11 module I386Code (
  12         Addr(..),
  13         Cond(..), Imm(..), Operand(..), Size(..),
  14         Base(..), Index(..), Displacement(..),
  15         I386Code(..),I386Instr(..),I386Regs,
  16         strImmLit,
  17         spRel,
  18
  19         printLabeledCodes,
  20
  21         baseRegOffset, stgRegMap, callerSaves,
  22
  23         is13Bits, offset,
  24
  25         kindToSize,
  26
  27         st0, st1, eax, ebx, ecx, edx, esi, edi, ebp, esp,
  28
  29         freeRegs, reservedRegs
  30
  31         -- and, for self-sufficiency ...
  32     ) where
  33
  34 import AbsCSyn          ( MagicId(..) )
  35 import AsmRegAlloc      ( MachineCode(..), MachineRegisters(..), FutureLive(..),
  36                           Reg(..), RegUsage(..), RegLiveness(..)
  37                         )
  38 import BitSet
  39 import CgCompInfo       ( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG )
  40 import CLabel           ( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
  41 import FiniteMap
  42 import Maybes           ( Maybe(..), maybeToBool )
  43 import OrdList          ( OrdList, mkUnitList, flattenOrdList )
  44 import Outputable
  45 import UniqSet
  46 import Stix
  47 import Unpretty
  48 import Util
  49 \end{code}
  50
  51 %************************************************************************
  52 %*                                                                      *
  53 \subsection[I386Reg]{The Native (I386) Machine Register Table}
  54 %*                                                                      *
  55 %************************************************************************
  56
  57 - All registers except 7 (esp) are available for use.
  58 - Only ebx, esi, edi and esp are available across a C call (they are callee-saves).
  59 - Registers 0-7 have 16-bit counterparts (ax, bx etc.)
  60 - Registers 0-3 have 8 bit counterparts (ah, bh etc.)
  61 - Registers 8-15 hold extended floating point values.
  62
  63 ToDo: Deal with stg registers that live as offsets from BaseReg!(JSM)
  64
  65 \begin{code}
  66
  67 gReg,fReg :: Int -> Int
  68 gReg x = x
  69 fReg x = (8 + x)
  70
  71 st0, st1, st2, st3, st4, st5, st6, st7, eax, ebx, ecx, edx, esp :: Reg
  72 eax = case (gReg 0) of { IBOX(g0) -> FixedReg g0 }
  73 ebx = case (gReg 1) of { IBOX(g1) -> FixedReg g1 }
  74 ecx = case (gReg 2) of { IBOX(g2) -> FixedReg g2 }
  75 edx = case (gReg 3) of { IBOX(g3) -> FixedReg g3 }
  76 esi = case (gReg 4) of { IBOX(g4) -> FixedReg g4 }
  77 edi = case (gReg 5) of { IBOX(g5) -> FixedReg g5 }
  78 ebp = case (gReg 6) of { IBOX(g6) -> FixedReg g6 }
  79 esp = case (gReg 7) of { IBOX(g7) -> FixedReg g7 }
  80 st0 = realReg  (fReg 0)
  81 st1 = realReg  (fReg 1)
  82 st2 = realReg  (fReg 2)
  83 st3 = realReg  (fReg 3)
  84 st4 = realReg  (fReg 4)
  85 st5 = realReg  (fReg 5)
  86 st6 = realReg  (fReg 6)
  87 st7 = realReg  (fReg 7)
  88
  89 realReg n@IBOX(i) = if _IS_TRUE_(freeReg i) then MappedReg i else FixedReg i
  90
  91 \end{code}
  92
  93 %************************************************************************
  94 %*                                                                      *
  95 \subsection[TheI386Code]{The datatype for i386 assembly language}
  96 %*                                                                      *
  97 %************************************************************************
  98
  99 Here is a definition of the I386 assembly language.
 100
 101 \begin{code}
 102
 103 data Imm = ImmInt Int
 104          | ImmInteger Integer         -- Sigh.
 105          | ImmCLbl CLabel             -- AbstractC Label (with baggage)
 106          | ImmLab  Unpretty           -- Simple string label (underscored)
 107          | ImmLit Unpretty            -- Simple string
 108          deriving ()
 109
 110 strImmLit s = ImmLit (uppStr s)
 111
 112 data Cond = ALWAYS
 113           | GEU
 114           | LU
 115           | EQ
 116           | GT
 117           | GE
 118           | GU
 119           | LT
 120           | LE
 121           | LEU
 122           | NE
 123           | NEG
 124           | POS
 125           deriving ()
 126
 127
 128 data Size = B
 129           | HB
 130           | S -- unused ?
 131           | L
 132           | F
 133           | D
 134           deriving ()
 135
 136 data Operand = OpReg  Reg       -- register
 137              | OpImm  Imm       -- immediate value
 138              | OpAddr Addr      -- memory reference
 139              deriving ()
 140
 141 data Addr = Addr Base Index Displacement
 142           | ImmAddr Imm Int
 143           -- deriving Eq
 144
 145 type Base         = Maybe Reg
 146 type Index        = Maybe (Reg, Int)    -- Int is 2, 4 or 8
 147 type Displacement = Imm
 148
 149 data I386Instr =
 150
 151 -- Moves.
 152
 153                 MOV           Size Operand Operand
 154               | MOVZX         Size Operand Operand -- size is the size of operand 2
 155               | MOVSX         Size Operand Operand -- size is the size of operand 2
 156
 157 -- Load effective address (also a very useful three-operand add instruction :-)
 158
 159               | LEA           Size Operand Operand
 160
 161 -- Int Arithmetic.
 162
 163               | ADD           Size Operand Operand
 164               | SUB           Size Operand Operand
 165
 166 -- Multiplication (signed and unsigned), Division (signed and unsigned),
 167 -- result in %eax, %edx.
 168
 169               | IMUL          Size Operand Operand
 170               | IDIV          Size Operand
 171
 172 -- Simple bit-twiddling.
 173
 174               | AND           Size Operand Operand
 175               | OR            Size Operand Operand
 176               | XOR           Size Operand Operand
 177               | NOT           Size Operand
 178               | NEGI          Size Operand -- NEG instruction (name clash with Cond)
 179               | SHL           Size Operand Operand -- 1st operand must be an Imm
 180               | SAR           Size Operand Operand -- 1st operand must be an Imm
 181               | SHR           Size Operand Operand -- 1st operand must be an Imm
 182               | NOP
 183
 184 -- Float Arithmetic. -- ToDo for 386
 185
 186 -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single instructions
 187 -- right up until we spit them out.
 188
 189               | SAHF          -- stores ah into flags
 190               | FABS
 191               | FADD          Size Operand -- src
 192               | FADDP
 193               | FIADD         Size Addr -- src
 194               | FCHS
 195               | FCOM          Size Operand -- src
 196               | FCOS
 197               | FDIV          Size Operand -- src
 198               | FDIVP
 199               | FIDIV         Size Addr -- src
 200               | FDIVR         Size Operand -- src
 201               | FDIVRP
 202               | FIDIVR        Size Addr -- src
 203               | FICOM         Size Addr -- src
 204               | FILD          Size Addr Reg -- src, dst
 205               | FIST          Size Addr -- dst
 206               | FLD           Size Operand -- src
 207               | FLD1
 208               | FLDZ
 209               | FMUL          Size Operand -- src
 210               | FMULP
 211               | FIMUL         Size Addr -- src
 212               | FRNDINT
 213               | FSIN
 214               | FSQRT
 215               | FST           Size Operand -- dst
 216               | FSTP          Size Operand -- dst
 217               | FSUB          Size Operand -- src
 218               | FSUBP
 219               | FISUB         Size Addr -- src
 220               | FSUBR         Size Operand -- src
 221               | FSUBRP
 222               | FISUBR        Size Addr -- src
 223               | FTST
 224               | FCOMP         Size Operand -- src
 225               | FUCOMPP
 226               | FXCH
 227               | FNSTSW
 228               | FNOP
 229
 230 -- Comparison
 231
 232               | TEST          Size Operand Operand
 233               | CMP           Size Operand Operand
 234               | SETCC         Cond Operand
 235
 236 -- Stack Operations.
 237
 238               | PUSH          Size Operand
 239               | POP           Size Operand
 240
 241 -- Jumping around.
 242
 243               | JMP           Operand -- target
 244               | JXX           Cond CLabel -- target
 245               | CALL          Imm
 246
 247 -- Other things.
 248
 249               | CLTD -- sign extend %eax into %edx:%eax
 250
 251 -- Pseudo-ops.
 252
 253               | LABEL CLabel
 254               | COMMENT FAST_STRING
 255               | SEGMENT CodeSegment
 256               | ASCII Bool String   -- needs backslash conversion?
 257               | DATA Size [Imm]
 258
 259 type I386Code   = OrdList I386Instr
 260
 261 \end{code}
 262
 263 %************************************************************************
 264 %*                                                                      *
 265 \subsection[TheI386Pretty]{Pretty-printing the I386 Assembly Language}
 266 %*                                                                      *
 267 %************************************************************************
 268
 269 \begin{code}
 270
 271 printLabeledCodes :: PprStyle -> [I386Instr] -> Unpretty
 272 printLabeledCodes sty codes = uppAboves (map (pprI386Instr sty) codes)
 273
 274 \end{code}
 275
 276 Printing the pieces...
 277
 278 \begin{code}
 279
 280 pprReg :: Size -> Reg -> Unpretty
 281
 282 pprReg s (FixedReg i)  = pprI386Reg s i
 283 pprReg s (MappedReg i) = pprI386Reg s i
 284 pprReg s other         = uppStr (show other) -- should only happen when debugging
 285
 286 pprI386Reg :: Size -> FAST_INT -> Unpretty
 287 pprI386Reg B i = uppPStr
 288     (case i of {
 289         ILIT( 0) -> SLIT("%al");  ILIT( 1) -> SLIT("%bl");
 290         ILIT( 2) -> SLIT("%cl");  ILIT( 3) -> SLIT("%dl");
 291         _ -> SLIT("very naughty I386 byte register")
 292     })
 293
 294 pprI386Reg HB i = uppPStr
 295     (case i of {
 296         ILIT( 0) -> SLIT("%ah");  ILIT( 1) -> SLIT("%bh");
 297         ILIT( 2) -> SLIT("%ch");  ILIT( 3) -> SLIT("%dh");
 298         _ -> SLIT("very naughty I386 high byte register")
 299     })
 300
 301 pprI386Reg S i = uppPStr
 302     (case i of {
 303         ILIT( 0) -> SLIT("%ax");  ILIT( 1) -> SLIT("%bx");
 304         ILIT( 2) -> SLIT("%cx");  ILIT( 3) -> SLIT("%dx");
 305         ILIT( 4) -> SLIT("%si");  ILIT( 5) -> SLIT("%di");
 306         ILIT( 6) -> SLIT("%bp");  ILIT( 7) -> SLIT("%sp");
 307         _ -> SLIT("very naughty I386 word register")
 308     })
 309
 310 pprI386Reg L i = uppPStr
 311     (case i of {
 312         ILIT( 0) -> SLIT("%eax");  ILIT( 1) -> SLIT("%ebx");
 313         ILIT( 2) -> SLIT("%ecx");  ILIT( 3) -> SLIT("%edx");
 314         ILIT( 4) -> SLIT("%esi");  ILIT( 5) -> SLIT("%edi");
 315         ILIT( 6) -> SLIT("%ebp");  ILIT( 7) -> SLIT("%esp");
 316         _ -> SLIT("very naughty I386 double word register")
 317     })
 318
 319 pprI386Reg F i = uppPStr
 320     (case i of {
 321 --ToDo: rm these
 322         ILIT( 8) -> SLIT("%st(0)");  ILIT( 9) -> SLIT("%st(1)");
 323         ILIT(10) -> SLIT("%st(2)");  ILIT(11) -> SLIT("%st(3)");
 324         ILIT(12) -> SLIT("%st(4)");  ILIT(13) -> SLIT("%st(5)");
 325         ILIT(14) -> SLIT("%st(6)");  ILIT(15) -> SLIT("%st(7)");
 326         _ -> SLIT("very naughty I386 float register")
 327     })
 328
 329 pprI386Reg D i = uppPStr
 330     (case i of {
 331 --ToDo: rm these
 332         ILIT( 8) -> SLIT("%st(0)");  ILIT( 9) -> SLIT("%st(1)");
 333         ILIT(10) -> SLIT("%st(2)");  ILIT(11) -> SLIT("%st(3)");
 334         ILIT(12) -> SLIT("%st(4)");  ILIT(13) -> SLIT("%st(5)");
 335         ILIT(14) -> SLIT("%st(6)");  ILIT(15) -> SLIT("%st(7)");
 336         _ -> SLIT("very naughty I386 float register")
 337     })
 338
 339 pprCond :: Cond -> Unpretty -- ToDo
 340 pprCond x = uppPStr
 341     (case x of {
 342         GEU     -> SLIT("ae");  LU    -> SLIT("b");
 343         EQ      -> SLIT("e");   GT    -> SLIT("g");
 344         GE      -> SLIT("ge");  GU    -> SLIT("a");
 345         LT      -> SLIT("l");   LE    -> SLIT("le");
 346         LEU     -> SLIT("be");  NE    -> SLIT("ne");
 347         NEG     -> SLIT("s");   POS   -> SLIT("ns");
 348         ALWAYS  -> SLIT("mp");  -- hack
 349         _       -> error "Spix: iI386Code: unknown conditional!"
 350     })
 351
 352 pprDollImm :: PprStyle -> Imm -> Unpretty
 353
 354 pprDollImm sty i     = uppBesides [ uppPStr SLIT("$"), pprImm sty i]
 355
 356 pprImm :: PprStyle -> Imm -> Unpretty
 357
 358 pprImm sty (ImmInt i)     = uppInt i
 359 pprImm sty (ImmInteger i) = uppInteger i
 360 pprImm sty (ImmCLbl l)    = pprCLabel sty l
 361 pprImm sty (ImmLab l)     = l
 362
 363 --pprImm (PprForAsm _ False _) (ImmLab s) = s
 364 --pprImm _                     (ImmLab s) = uppBeside (uppChar '_') s
 365
 366 pprImm sty (ImmLit s) = s
 367
 368 pprAddr :: PprStyle -> Addr -> Unpretty
 369 pprAddr sty (ImmAddr imm off)
 370   =  uppBesides [pprImm sty imm,
 371                  if off > 0 then uppChar '+' else uppPStr SLIT(""),
 372                  if off == 0 then uppPStr SLIT("") else uppInt off
 373                 ]
 374 pprAddr sty (Addr Nothing Nothing displacement)
 375   =  uppBesides [pprDisp sty displacement]
 376 pprAddr sty (Addr base index displacement)
 377   =  uppBesides [pprDisp sty displacement,
 378                  uppChar '(',
 379                  pprBase base,
 380                  pprIndex index,
 381                  uppChar ')'
 382                 ]
 383   where
 384     pprBase (Just r) = uppBesides [pprReg L r,
 385                                    case index of
 386                                      Nothing -> uppPStr SLIT("")
 387                                      _       -> uppChar ','
 388                                   ]
 389     pprBase _        = uppPStr SLIT("")
 390     pprIndex (Just (r,i)) = uppBesides [pprReg L r, uppChar ',', uppInt i]
 391     pprIndex _       = uppPStr SLIT("")
 392
 393 pprDisp sty (ImmInt 0) = uppPStr SLIT("")
 394 --pprDisp sty (ImmInteger 0) = uppPStr SLIT("")
 395 pprDisp sty d = pprImm sty d
 396
 397 pprOperand :: PprStyle -> Size -> Operand -> Unpretty
 398 pprOperand sty s (OpReg r) = pprReg s r
 399 pprOperand sty s (OpImm i) = pprDollImm sty i
 400 pprOperand sty s (OpAddr ea) = pprAddr sty ea
 401
 402 pprSize :: Size -> Unpretty
 403 pprSize x = uppPStr
 404     (case x of
 405         B  -> SLIT("b")
 406         HB -> SLIT("b")
 407         S  -> SLIT("w")
 408         L  -> SLIT("l")
 409         F  -> SLIT("s")
 410         D  -> SLIT("l")
 411     )
 412
 413 pprSizeOp :: PprStyle -> FAST_STRING -> Size -> Operand -> Unpretty
 414 pprSizeOp sty name size op1 =
 415     uppBesides [
 416         uppChar '\t',
 417         uppPStr name,
 418         pprSize size,
 419         uppChar ' ',
 420         pprOperand sty size op1
 421     ]
 422
 423 pprSizeOpOp :: PprStyle -> FAST_STRING -> Size -> Operand -> Operand -> Unpretty
 424 pprSizeOpOp sty name size op1 op2 =
 425     uppBesides [
 426         uppChar '\t',
 427         uppPStr name,
 428         pprSize size,
 429         uppChar ' ',
 430         pprOperand sty size op1,
 431         uppComma,
 432         pprOperand sty size op2
 433     ]
 434
 435 pprSizeOpReg :: PprStyle -> FAST_STRING -> Size -> Operand -> Reg -> Unpretty
 436 pprSizeOpReg sty name size op1 reg =
 437     uppBesides [
 438         uppChar '\t',
 439         uppPStr name,
 440         pprSize size,
 441         uppChar ' ',
 442         pprOperand sty size op1,
 443         uppComma,
 444         pprReg size reg
 445     ]
 446
 447 pprSizeAddr :: PprStyle -> FAST_STRING -> Size -> Addr -> Unpretty
 448 pprSizeAddr sty name size op =
 449     uppBesides [
 450         uppChar '\t',
 451         uppPStr name,
 452         pprSize size,
 453         uppChar ' ',
 454         pprAddr sty op
 455     ]
 456
 457 pprSizeAddrReg :: PprStyle -> FAST_STRING -> Size -> Addr -> Reg -> Unpretty
 458 pprSizeAddrReg sty name size op dst =
 459     uppBesides [
 460         uppChar '\t',
 461         uppPStr name,
 462         pprSize size,
 463         uppChar ' ',
 464         pprAddr sty op,
 465         uppComma,
 466         pprReg size dst
 467     ]
 468
 469 pprOpOp :: PprStyle -> FAST_STRING -> Size -> Operand -> Operand -> Unpretty
 470 pprOpOp sty name size op1 op2 =
 471     uppBesides [
 472         uppChar '\t',
 473         uppPStr name,
 474         uppChar ' ',
 475         pprOperand sty size op1,
 476         uppComma,
 477         pprOperand sty size op2
 478     ]
 479
 480 pprSizeOpOpCoerce :: PprStyle -> FAST_STRING -> Size -> Size -> Operand -> Operand -> Unpretty
 481 pprSizeOpOpCoerce sty name size1 size2 op1 op2 =
 482     uppBesides [ uppChar '\t', uppPStr name, uppChar ' ',
 483         pprOperand sty size1 op1,
 484         uppComma,
 485         pprOperand sty size2 op2
 486     ]
 487
 488 pprCondInstr :: PprStyle -> FAST_STRING -> Cond -> Unpretty -> Unpretty
 489 pprCondInstr sty name cond arg =
 490     uppBesides [ uppChar '\t', uppPStr name, pprCond cond, uppChar ' ', arg]
 491
 492 pprI386Instr :: PprStyle -> I386Instr -> Unpretty
 493 pprI386Instr sty (MOV size (OpReg src) (OpReg dst)) -- hack
 494   | src == dst
 495   = uppPStr SLIT("")
 496 pprI386Instr sty (MOV size src dst)
 497   = pprSizeOpOp sty SLIT("mov") size src dst
 498 pprI386Instr sty (MOVZX size src dst) = pprSizeOpOpCoerce sty SLIT("movzx") L size src dst
 499 pprI386Instr sty (MOVSX size src dst) = pprSizeOpOpCoerce sty SLIT("movxs") L size src dst
 500
 501 -- here we do some patching, since the physical registers are only set late
 502 -- in the code generation.
 503 pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
 504   | reg1 == reg3
 505   = pprSizeOpOp sty SLIT("add") size (OpReg reg2) dst
 506 pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
 507   | reg2 == reg3
 508   = pprSizeOpOp sty SLIT("add") size (OpReg reg1) dst
 509 pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) Nothing displ)) dst@(OpReg reg3))
 510   | reg1 == reg3
 511   = pprI386Instr sty (ADD size (OpImm displ) dst)
 512 pprI386Instr sty (LEA size src dst) = pprSizeOpOp sty SLIT("lea") size src dst
 513
 514 pprI386Instr sty (ADD size (OpImm (ImmInt (-1))) dst)
 515   = pprSizeOp sty SLIT("dec") size dst
 516 pprI386Instr sty (ADD size (OpImm (ImmInt 1)) dst)
 517   = pprSizeOp sty SLIT("inc") size dst
 518 pprI386Instr sty (ADD size src dst)
 519   = pprSizeOpOp sty SLIT("add") size src dst
 520 pprI386Instr sty (SUB size src dst) = pprSizeOpOp sty SLIT("sub") size src dst
 521 pprI386Instr sty (IMUL size op1 op2) = pprSizeOpOp sty SLIT("imul") size op1 op2
 522 pprI386Instr sty (IDIV size op) = pprSizeOp sty SLIT("idiv") size op
 523
 524 pprI386Instr sty (AND size src dst) = pprSizeOpOp sty SLIT("and") size src dst
 525 pprI386Instr sty (OR  size src dst) = pprSizeOpOp sty SLIT("or")  size src dst
 526 pprI386Instr sty (XOR size src dst) = pprSizeOpOp sty SLIT("xor")  size src dst
 527 pprI386Instr sty (NOT size op) = pprSizeOp sty SLIT("not") size op
 528 pprI386Instr sty (NEGI size op) = pprSizeOp sty SLIT("neg") size op
 529 pprI386Instr sty (SHL size imm dst) = pprSizeOpOp sty SLIT("shl")  size imm dst
 530 pprI386Instr sty (SAR size imm dst) = pprSizeOpOp sty SLIT("sar")  size imm dst
 531 pprI386Instr sty (SHR size imm dst) = pprSizeOpOp sty SLIT("shr")  size imm dst
 532
 533 pprI386Instr sty (CMP size src dst) = pprSizeOpOp sty SLIT("cmp")  size src dst
 534 pprI386Instr sty (TEST size src dst) = pprSizeOpOp sty SLIT("test")  size src dst
 535 pprI386Instr sty (PUSH size op) = pprSizeOp sty SLIT("push") size op
 536 pprI386Instr sty (POP size op) = pprSizeOp sty SLIT("pop") size op
 537
 538 pprI386Instr sty (NOP) = uppPStr SLIT("\tnop")
 539 pprI386Instr sty (CLTD) = uppPStr SLIT("\tcltd")
 540
 541 pprI386Instr sty (SETCC cond op) = pprCondInstr sty SLIT("set") cond (pprOperand sty B op)
 542
 543 pprI386Instr sty (JXX cond lab) = pprCondInstr sty SLIT("j") cond (pprCLabel sty lab)
 544
 545 pprI386Instr sty (JMP (OpImm imm)) = uppBeside (uppPStr SLIT("\tjmp ")) (pprImm sty imm)
 546 pprI386Instr sty (JMP op) = uppBeside (uppPStr SLIT("\tjmp *")) (pprOperand sty L op)
 547
 548 pprI386Instr sty (CALL imm) =
 549     uppBesides [ uppPStr SLIT("\tcall "), pprImm sty imm ]
 550
 551 pprI386Instr sty SAHF = uppPStr SLIT("\tsahf")
 552 pprI386Instr sty FABS = uppPStr SLIT("\tfabs")
 553
 554 pprI386Instr sty (FADD sz src@(OpAddr _))
 555   = uppBesides [uppPStr SLIT("\tfadd"), pprSize sz, uppChar ' ', pprOperand sty sz src]
 556 pprI386Instr sty (FADD sz src)
 557   = uppPStr SLIT("\tfadd")
 558 pprI386Instr sty FADDP
 559   = uppPStr SLIT("\tfaddp")
 560 pprI386Instr sty (FMUL sz src)
 561   = uppBesides [uppPStr SLIT("\tfmul"), pprSize sz, uppChar ' ', pprOperand sty sz src]
 562 pprI386Instr sty FMULP
 563   = uppPStr SLIT("\tfmulp")
 564 pprI386Instr sty (FIADD size op) = pprSizeAddr sty SLIT("fiadd") size op
 565 pprI386Instr sty FCHS = uppPStr SLIT("\tfchs")
 566 pprI386Instr sty (FCOM size op) = pprSizeOp sty SLIT("fcom") size op
 567 pprI386Instr sty FCOS = uppPStr SLIT("\tfcos")
 568 pprI386Instr sty (FIDIV size op) = pprSizeAddr sty SLIT("fidiv") size op
 569 pprI386Instr sty (FDIV sz src)
 570   = uppBesides [uppPStr SLIT("\tfdiv"), pprSize sz, uppChar ' ', pprOperand sty sz src]
 571 pprI386Instr sty FDIVP
 572   = uppPStr SLIT("\tfdivp")
 573 pprI386Instr sty (FDIVR sz src)
 574   = uppBesides [uppPStr SLIT("\tfdivr"), pprSize sz, uppChar ' ', pprOperand sty sz src]
 575 pprI386Instr sty FDIVRP
 576   = uppPStr SLIT("\tfdivpr")
 577 pprI386Instr sty (FIDIVR size op) = pprSizeAddr sty SLIT("fidivr") size op
 578 pprI386Instr sty (FICOM size op) = pprSizeAddr sty SLIT("ficom") size op
 579 pprI386Instr sty (FILD sz op reg) = pprSizeAddrReg sty SLIT("fild") sz op reg
 580 pprI386Instr sty (FIST size op) = pprSizeAddr sty SLIT("fist") size op
 581 pprI386Instr sty (FLD sz (OpImm (ImmCLbl src)))
 582   = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppChar ' ',pprCLabel sty src]
 583 pprI386Instr sty (FLD sz src)
 584   = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppChar ' ',pprOperand sty sz src]
 585 pprI386Instr sty FLD1 = uppPStr SLIT("\tfld1")
 586 pprI386Instr sty FLDZ = uppPStr SLIT("\tfldz")
 587 pprI386Instr sty (FIMUL size op) = pprSizeAddr sty SLIT("fimul") size op
 588 pprI386Instr sty FRNDINT = uppPStr SLIT("\tfrndint")
 589 pprI386Instr sty FSIN = uppPStr SLIT("\tfsin")
 590 pprI386Instr sty FSQRT = uppPStr SLIT("\tfsqrt")
 591 pprI386Instr sty (FST sz dst)
 592   = uppBesides [uppPStr SLIT("\tfst"), pprSize sz, uppChar ' ', pprOperand sty sz dst]
 593 pprI386Instr sty (FSTP sz dst)
 594   = uppBesides [uppPStr SLIT("\tfstp"), pprSize sz, uppChar ' ', pprOperand sty sz dst]
 595 pprI386Instr sty (FISUB size op) = pprSizeAddr sty SLIT("fisub") size op
 596 pprI386Instr sty (FSUB sz src)
 597   = uppBesides [uppPStr SLIT("\tfsub"), pprSize sz, uppChar ' ', pprOperand sty sz src]
 598 pprI386Instr sty FSUBP
 599   = uppPStr SLIT("\tfsubp")
 600 pprI386Instr sty (FSUBR size src)
 601   = pprSizeOp sty SLIT("fsubr") size src
 602 pprI386Instr sty FSUBRP
 603   = uppPStr SLIT("\tfsubpr")
 604 pprI386Instr sty (FISUBR size op)
 605   = pprSizeAddr sty SLIT("fisubr") size op
 606 pprI386Instr sty FTST = uppPStr SLIT("\tftst")
 607 pprI386Instr sty (FCOMP sz op)
 608   = uppBesides [uppPStr SLIT("\tfcomp"), pprSize sz, uppChar ' ', pprOperand sty sz op]
 609 pprI386Instr sty FUCOMPP = uppPStr SLIT("\tfucompp")
 610 pprI386Instr sty FXCH = uppPStr SLIT("\tfxch")
 611 pprI386Instr sty FNSTSW = uppPStr SLIT("\tfnstsw %ax")
 612 pprI386Instr sty FNOP = uppPStr SLIT("")
 613
 614 pprI386Instr sty (LABEL clab) =
 615     uppBesides [
 616         if (externallyVisibleCLabel clab) then
 617             uppBesides [uppPStr SLIT(".globl "), pprLab, uppChar '\n']
 618         else
 619             uppNil,
 620         pprLab,
 621         uppChar ':'
 622     ]
 623     where pprLab = pprCLabel sty clab
 624
 625 pprI386Instr sty (COMMENT s) = uppBeside (uppPStr SLIT("# ")) (uppPStr s)
 626
 627 pprI386Instr sty (SEGMENT TextSegment)
 628     = uppPStr SLIT(".text\n\t.align 4")
 629
 630 pprI386Instr sty (SEGMENT DataSegment)
 631     = uppPStr SLIT(".data\n\t.align 2")
 632
 633 pprI386Instr sty (ASCII False str) =
 634     uppBesides [
 635         uppStr "\t.asciz \"",
 636         uppStr str,
 637         uppChar '"'
 638     ]
 639
 640 pprI386Instr sty (ASCII True str) = uppBeside (uppStr "\t.ascii \"") (asciify str 60)
 641     where
 642         asciify :: String -> Int -> Unpretty
 643         asciify [] _ = uppStr ("\\0\"")
 644         asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60)
 645         asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
 646         asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
 647         asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
 648         asciify [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\""))
 649         asciify (c:(cs@(d:_))) n | isDigit d =
 650                                         uppBeside (uppStr (charToC c)) (asciify cs 0)
 651                                  | otherwise =
 652                                         uppBeside (uppStr (charToC c)) (asciify cs (n-1))
 653
 654 pprI386Instr sty (DATA s xs) = uppInterleave (uppChar '\n') (map pp_item xs)
 655     where pp_item x = case s of
 656             B -> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x)
 657             HB-> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x)
 658             S -> uppBeside (uppPStr SLIT("\t.word\t")) (pprImm sty x)
 659             L -> uppBeside (uppPStr SLIT("\t.long\t")) (pprImm sty x)
 660             F -> uppBeside (uppPStr SLIT("\t.long\t")) (pprImm sty x)
 661             D -> uppBeside (uppPStr SLIT("\t.double\t")) (pprImm sty x)
 662
 663 \end{code}
 664
 665 %************************************************************************
 666 %*                                                                      *
 667 \subsection[Schedule]{Register allocation information}
 668 %*                                                                      *
 669 %************************************************************************
 670
 671 \begin{code}
 672
 673 data I386Regs = SRegs BitSet BitSet
 674
 675 instance MachineRegisters I386Regs where
 676     mkMRegs xs = SRegs (mkBS ints) (mkBS floats')
 677       where
 678         (ints, floats) = partition (< 8) xs
 679         floats' = map (subtract 8) floats
 680
 681     possibleMRegs FloatRep (SRegs _ floats) = [ x + 8 | x <- listBS floats]
 682     possibleMRegs DoubleRep (SRegs _ floats) = [ x + 8 | x <- listBS floats]
 683     possibleMRegs _ (SRegs ints _) = listBS ints
 684
 685     useMReg (SRegs ints floats) n =
 686         if n _LT_ ILIT(8) then SRegs (ints `minusBS` singletonBS IBOX(n)) floats
 687         else SRegs ints (floats `minusBS` singletonBS (IBOX(n _SUB_ ILIT(8))))
 688
 689     useMRegs (SRegs ints floats) xs =
 690         SRegs (ints `minusBS` ints')
 691               (floats `minusBS` floats')
 692       where
 693         SRegs ints' floats' = mkMRegs xs
 694
 695     freeMReg (SRegs ints floats) n =
 696         if n _LT_ ILIT(8) then SRegs (ints `unionBS` singletonBS IBOX(n)) floats
 697         else SRegs ints (floats `unionBS` singletonBS (IBOX(n _SUB_ ILIT(8))))
 698
 699     freeMRegs (SRegs ints floats) xs =
 700         SRegs (ints `unionBS` ints')
 701               (floats `unionBS` floats')
 702       where
 703         SRegs ints' floats' = mkMRegs xs
 704
 705 instance MachineCode I386Instr where
 706     regUsage = i386RegUsage
 707     regLiveness = i386RegLiveness
 708     patchRegs = i386PatchRegs
 709
 710     -- We spill just below the stack pointer, leaving two words per spill location.
 711     spillReg dyn (MemoryReg i pk)
 712       = trace "spillsave"
 713         (mkUnitList (MOV (kindToSize pk) (OpReg dyn) (OpAddr (spRel (-2 * i)))))
 714     loadReg (MemoryReg i pk) dyn
 715       = trace "spillload"
 716         (mkUnitList (MOV (kindToSize pk) (OpAddr (spRel (-2 * i))) (OpReg dyn)))
 717
 718 --spRel gives us a stack relative addressing mode for volatile temporaries
 719 --and for excess call arguments.
 720
 721 spRel
 722     :: Int      -- desired stack offset in words, positive or negative
 723     -> Addr
 724 spRel n = Addr (Just esp) Nothing (ImmInt (n * 4))
 725
 726 kindToSize :: PrimRep -> Size
 727 kindToSize PtrRep           = L
 728 kindToSize CodePtrRep       = L
 729 kindToSize DataPtrRep       = L
 730 kindToSize RetRep           = L
 731 kindToSize CostCentreRep   = L
 732 kindToSize CharRep          = L
 733 kindToSize IntRep           = L
 734 kindToSize WordRep          = L
 735 kindToSize AddrRep          = L
 736 kindToSize FloatRep         = F
 737 kindToSize DoubleRep        = D
 738 kindToSize ArrayRep         = L
 739 kindToSize ByteArrayRep    = L
 740 kindToSize StablePtrRep    = L
 741 kindToSize MallocPtrRep    = L
 742
 743 \end{code}
 744
 745 @i386RegUsage@ returns the sets of src and destination registers used by
 746 a particular instruction.  Machine registers that are pre-allocated
 747 to stgRegs are filtered out, because they are uninteresting from a
 748 register allocation standpoint.  (We wouldn't want them to end up on
 749 the free list!)
 750
 751 \begin{code}
 752
 753 i386RegUsage :: I386Instr -> RegUsage
 754 i386RegUsage instr = case instr of
 755     MOV  sz src dst     -> usage2 src dst
 756     MOVZX sz src dst    -> usage2 src dst
 757     MOVSX sz src dst    -> usage2 src dst
 758     LEA  sz src dst     -> usage2 src dst
 759     ADD  sz src dst     -> usage2 src dst
 760     SUB  sz src dst     -> usage2 src dst
 761     IMUL sz src dst     -> usage2 src dst
 762     IDIV sz src         -> usage (eax:edx:opToReg src) [eax,edx]
 763     AND  sz src dst     -> usage2 src dst
 764     OR   sz src dst     -> usage2 src dst
 765     XOR  sz src dst     -> usage2 src dst
 766     NOT  sz op          -> usage1 op
 767     NEGI sz op          -> usage1 op
 768     SHL  sz imm dst     -> usage1 dst -- imm has to be an Imm
 769     SAR  sz imm dst     -> usage1 dst -- imm has to be an Imm
 770     SHR  sz imm dst     -> usage1 dst -- imm has to be an Imm
 771     PUSH sz op          -> usage (opToReg op) []
 772     POP  sz op          -> usage [] (opToReg op)
 773     TEST sz src dst     -> usage (opToReg src ++ opToReg dst) []
 774     CMP  sz src dst     -> usage (opToReg src ++ opToReg dst) []
 775     SETCC cond op       -> usage [] (opToReg op)
 776     JXX cond label      -> usage [] []
 777     JMP op              -> usage (opToReg op) freeRegs
 778     CALL imm            -> usage [] callClobberedRegs
 779     CLTD                -> usage [eax] [edx]
 780     NOP                 -> usage [] []
 781     SAHF                -> usage [eax] []
 782     FABS                -> usage [st0] [st0]
 783     FADD sz src         -> usage (st0:opToReg src) [st0] -- allFPRegs
 784     FADDP               -> usage [st0,st1] [st0] -- allFPRegs
 785     FIADD sz asrc       -> usage (addrToRegs asrc) [st0]
 786     FCHS                -> usage [st0] [st0]
 787     FCOM sz src         -> usage (st0:opToReg src) []
 788     FCOS                -> usage [st0] [st0]
 789     FDIV sz src         -> usage (st0:opToReg src) [st0]
 790     FDIVP               -> usage [st0,st1] [st0]
 791     FDIVRP              -> usage [st0,st1] [st0]
 792     FIDIV sz asrc       -> usage (addrToRegs asrc) [st0]
 793     FDIVR sz src        -> usage (st0:opToReg src) [st0]
 794     FIDIVR sz asrc      -> usage (addrToRegs asrc) [st0]
 795     FICOM sz asrc       -> usage (addrToRegs asrc) []
 796     FILD sz asrc dst    -> usage (addrToRegs asrc) [dst] -- allFPRegs
 797     FIST sz adst        -> usage (st0:addrToRegs adst) []
 798     FLD  sz src         -> usage (opToReg src) [st0] -- allFPRegs
 799     FLD1                -> usage [] [st0] -- allFPRegs
 800     FLDZ                -> usage [] [st0] -- allFPRegs
 801     FMUL sz src         -> usage (st0:opToReg src) [st0]
 802     FMULP               -> usage [st0,st1] [st0]
 803     FIMUL sz asrc       -> usage (addrToRegs asrc) [st0]
 804     FRNDINT             -> usage [st0] [st0]
 805     FSIN                -> usage [st0] [st0]
 806     FSQRT               -> usage [st0] [st0]
 807     FST sz (OpReg r)    -> usage [st0] [r]
 808     FST sz dst          -> usage (st0:opToReg dst) []
 809     FSTP sz (OpReg r)   -> usage [st0] [r] -- allFPRegs
 810     FSTP sz dst         -> usage (st0:opToReg dst) [] -- allFPRegs
 811     FSUB sz src         -> usage (st0:opToReg src) [st0] -- allFPRegs
 812     FSUBR sz src        -> usage (st0:opToReg src) [st0] -- allFPRegs
 813     FISUB sz asrc       -> usage (addrToRegs asrc) [st0]
 814     FSUBP               -> usage [st0,st1] [st0] -- allFPRegs
 815     FSUBRP              -> usage [st0,st1] [st0] -- allFPRegs
 816     FISUBR sz asrc      -> usage (addrToRegs asrc) [st0]
 817     FTST                -> usage [st0] []
 818     FCOMP sz op         -> usage (st0:opToReg op) [st0] -- allFPRegs
 819     FUCOMPP             -> usage [st0, st1] [] --  allFPRegs
 820     FXCH                -> usage [st0, st1] [st0, st1]
 821     FNSTSW              -> usage [] [eax]
 822     _                   -> noUsage
 823
 824  where
 825
 826     usage2 :: Operand -> Operand -> RegUsage
 827     usage2 op (OpReg reg) = usage (opToReg op) [reg]
 828     usage2 op (OpAddr ea) = usage (opToReg op ++ addrToRegs ea) []
 829     usage2 op (OpImm imm) = usage (opToReg op) []
 830     usage1 :: Operand -> RegUsage
 831     usage1 (OpReg reg)    = usage [reg] [reg]
 832     usage1 (OpAddr ea)    = usage (addrToRegs ea) []
 833     allFPRegs = [st0,st1,st2,st3,st4,st5,st6,st7]
 834     --callClobberedRegs = [ eax, ecx, edx ] -- according to gcc, anyway.
 835     callClobberedRegs = [eax]
 836
 837 -- General purpose register collecting functions.
 838
 839     opToReg (OpReg reg)   = [reg]
 840     opToReg (OpImm imm)   = []
 841     opToReg (OpAddr  ea)  = addrToRegs ea
 842
 843     addrToRegs (Addr base index _) = baseToReg base ++ indexToReg index
 844       where  baseToReg Nothing       = []
 845              baseToReg (Just r)      = [r]
 846              indexToReg Nothing      = []
 847              indexToReg (Just (r,_)) = [r]
 848     addrToRegs (ImmAddr _ _) = []
 849
 850     usage src dst = RU (mkUniqSet (filter interesting src))
 851                        (mkUniqSet (filter interesting dst))
 852
 853     interesting (FixedReg _) = False
 854     interesting _ = True
 855
 856 freeRegs :: [Reg]
 857 freeRegs = freeMappedRegs (\ x -> x) [0..15]
 858
 859 freeMappedRegs :: (Int -> Int) -> [Int] -> [Reg]
 860
 861 freeMappedRegs modify nums
 862   = foldr free [] nums
 863   where
 864     free n acc
 865       = let
 866             modified_i = case (modify n) of { IBOX(x) -> x }
 867         in
 868         if _IS_TRUE_(freeReg modified_i) then (MappedReg modified_i) : acc else acc
 869
 870 freeSet :: UniqSet Reg
 871 freeSet = mkUniqSet freeRegs
 872
 873 noUsage :: RegUsage
 874 noUsage = RU emptyUniqSet emptyUniqSet
 875
 876 endUsage :: RegUsage
 877 endUsage = RU emptyUniqSet freeSet
 878
 879 \end{code}
 880
 881 @i386RegLiveness@ takes future liveness information and modifies it according to
 882 the semantics of branches and labels.  (An out-of-line branch clobbers the liveness
 883 passed back by the following instruction; a forward local branch passes back the
 884 liveness from the target label; a conditional branch merges the liveness from the
 885 target and the liveness from its successor; a label stashes away the current liveness
 886 in the future liveness environment).
 887
 888 \begin{code}
 889 i386RegLiveness :: I386Instr -> RegLiveness -> RegLiveness
 890 i386RegLiveness instr info@(RL live future@(FL all env)) = case instr of
 891
 892     JXX _ lbl   -> RL (lookup lbl `unionUniqSets` live) future
 893     JMP _       -> RL emptyUniqSet future
 894     CALL _      -> RL live future
 895     LABEL lbl   -> RL live (FL (all `unionUniqSets` live) (addToFM env lbl live))
 896     _               -> info
 897
 898   where
 899     lookup lbl = case lookupFM env lbl of
 900         Just regs -> regs
 901         Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel (PprForAsm (\_->False) False id) lbl)) ++
 902                           " in future?") emptyUniqSet
 903
 904 \end{code}
 905
 906 @i386PatchRegs@ takes an instruction (possibly with MemoryReg/UnmappedReg registers) and
 907 changes all register references according to the supplied environment.
 908
 909 \begin{code}
 910
 911 i386PatchRegs :: I386Instr -> (Reg -> Reg) -> I386Instr
 912 i386PatchRegs instr env = case instr of
 913     MOV  sz src dst     -> patch2 (MOV  sz) src dst
 914     MOVZX sz src dst    -> patch2 (MOVZX sz) src dst
 915     MOVSX sz src dst    -> patch2 (MOVSX sz) src dst
 916     LEA  sz src dst     -> patch2 (LEA  sz) src dst
 917     ADD  sz src dst     -> patch2 (ADD  sz) src dst
 918     SUB  sz src dst     -> patch2 (SUB  sz) src dst
 919     IMUL sz src dst     -> patch2 (IMUL sz) src dst
 920     IDIV sz src         -> patch1 (IDIV sz) src
 921     AND  sz src dst     -> patch2 (AND  sz) src dst
 922     OR   sz src dst     -> patch2 (OR   sz) src dst
 923     XOR  sz src dst     -> patch2 (XOR  sz) src dst
 924     NOT  sz op          -> patch1 (NOT  sz) op
 925     NEGI sz op          -> patch1 (NEGI sz) op
 926     SHL  sz imm dst     -> patch1 (SHL  sz imm) dst
 927     SAR  sz imm dst     -> patch1 (SAR  sz imm) dst
 928     SHR  sz imm dst     -> patch1 (SHR  sz imm) dst
 929     TEST sz src dst     -> patch2 (TEST sz) src dst
 930     CMP  sz src dst     -> patch2 (CMP  sz) src dst
 931     PUSH sz op          -> patch1 (PUSH sz) op
 932     POP  sz op          -> patch1 (POP  sz) op
 933     SETCC cond op       -> patch1 (SETCC cond) op
 934     JMP op              -> patch1 JMP op
 935     FADD sz src         -> FADD sz (patchOp src)
 936     FIADD sz asrc       -> FIADD sz (lookupAddr asrc)
 937     FCOM sz src         -> patch1 (FCOM sz) src
 938     FDIV sz src         -> FDIV sz (patchOp src)
 939     --FDIVP sz src      -> FDIVP sz (patchOp src)
 940     FIDIV sz asrc       -> FIDIV sz (lookupAddr asrc)
 941     FDIVR sz src        -> FDIVR sz (patchOp src)
 942     --FDIVRP sz src     -> FDIVRP sz (patchOp src)
 943     FIDIVR sz asrc      -> FIDIVR sz (lookupAddr asrc)
 944     FICOM sz asrc       -> FICOM sz (lookupAddr asrc)
 945     FILD sz asrc dst    -> FILD sz (lookupAddr asrc) (env dst)
 946     FIST sz adst        -> FIST sz (lookupAddr adst)
 947     FLD sz src          -> patch1 (FLD sz) (patchOp src)
 948     FMUL sz src         -> FMUL sz (patchOp src)
 949     --FMULP sz src      -> FMULP sz (patchOp src)
 950     FIMUL sz asrc       -> FIMUL sz (lookupAddr asrc)
 951     FST sz dst          -> FST sz (patchOp dst)
 952     FSTP sz dst         -> FSTP sz (patchOp dst)
 953     FSUB sz src         -> FSUB sz (patchOp src)
 954     --FSUBP sz src      -> FSUBP sz (patchOp src)
 955     FISUB sz asrc       -> FISUB sz (lookupAddr asrc)
 956     FSUBR sz src        -> FSUBR sz (patchOp src)
 957     --FSUBRP sz src     -> FSUBRP sz (patchOp src)
 958     FISUBR sz asrc      -> FISUBR sz (lookupAddr asrc)
 959     FCOMP sz src        -> FCOMP sz (patchOp src)
 960     _                   -> instr
 961
 962   where
 963                 patch1 insn op = insn (patchOp op)
 964                 patch2 insn src dst = insn (patchOp src) (patchOp dst)
 965
 966                 patchOp (OpReg  reg) = OpReg (env reg)
 967                 patchOp (OpImm  imm) = OpImm imm
 968                 patchOp (OpAddr ea)  = OpAddr (lookupAddr ea)
 969
 970                 lookupAddr (Addr base index disp)
 971                         = Addr (lookupBase base) (lookupIndex index) disp
 972                         where lookupBase Nothing        = Nothing
 973                               lookupBase (Just r)       = Just (env r)
 974                               lookupIndex Nothing       = Nothing
 975                               lookupIndex (Just (r,i))  = Just (env r, i)
 976                 lookupAddr (ImmAddr imm off)
 977                         = ImmAddr imm off
 978
 979 \end{code}
 980
 981 Sometimes, we want to be able to modify addresses at compile time.
 982 (Okay, just for chrCode of a fetch.)
 983
 984 \begin{code}
 985 {-# SPECIALIZE
 986     is13Bits :: Int -> Bool
 987   #-}
 988 {-# SPECIALIZE
 989     is13Bits :: Integer -> Bool
 990   #-}
 991
 992 is13Bits :: Integral a => a -> Bool
 993 is13Bits x = x >= -4096 && x < 4096
 994
 995 offset :: Addr -> Int -> Maybe Addr
 996 offset (Addr reg index (ImmInt n)) off
 997   = Just (Addr reg index (ImmInt n2))
 998   where n2 = n + off
 999
1000 offset (Addr reg index (ImmInteger n)) off
1001   = Just (Addr reg index (ImmInt (fromInteger n2)))
1002   where n2 = n + toInteger off
1003
1004 offset (ImmAddr imm off1) off2
1005   = Just (ImmAddr imm off3)
1006   where off3 = off1 + off2
1007
1008 offset _ _ = Nothing
1009 \end{code}
1010
1011 If you value your sanity, do not venture below this line.
1012
1013 \begin{code}
1014
1015 -- platform.h is generate and tells us what the target architecture is
1016 #include "../../includes/platform.h"
1017 #define STOLEN_X86_REGS 5
1018 #include "../../includes/MachRegs.h"
1019 #include "../../includes/i386-unknown-linuxaout.h"
1020
1021 -- Redefine the literals used for I386 register names in the header
1022 -- files.  Gag me with a spoon, eh?
1023
1024 #define eax 0
1025 #define ebx 1
1026 #define ecx 2
1027 #define edx 3
1028 #define esi 4
1029 #define edi 5
1030 #define ebp 6
1031 #define esp 7
1032 #define st0 8
1033 #define st1 9
1034 #define st2 10
1035 #define st3 11
1036 #define st4 12
1037 #define st5 13
1038 #define st6 14
1039 #define st7 15
1040 #define CALLER_SAVES_Hp
1041 -- ToDo: rm when we give esp back
1042 #define REG_Hp esp
1043 #define REG_R2 ecx
1044
1045 baseRegOffset :: MagicId -> Int
1046 baseRegOffset StkOReg                   = OFFSET_StkO
1047 baseRegOffset (VanillaReg _ ILIT2(1))   = OFFSET_R1
1048 baseRegOffset (VanillaReg _ ILIT2(2))   = OFFSET_R2
1049 baseRegOffset (VanillaReg _ ILIT2(3))   = OFFSET_R3
1050 baseRegOffset (VanillaReg _ ILIT2(4))   = OFFSET_R4
1051 baseRegOffset (VanillaReg _ ILIT2(5))   = OFFSET_R5
1052 baseRegOffset (VanillaReg _ ILIT2(6))   = OFFSET_R6
1053 baseRegOffset (VanillaReg _ ILIT2(7))   = OFFSET_R7
1054 baseRegOffset (VanillaReg _ ILIT2(8))   = OFFSET_R8
1055 baseRegOffset (FloatReg ILIT2(1))       = OFFSET_Flt1
1056 baseRegOffset (FloatReg ILIT2(2))       = OFFSET_Flt2
1057 baseRegOffset (FloatReg ILIT2(3))       = OFFSET_Flt3
1058 baseRegOffset (FloatReg ILIT2(4))       = OFFSET_Flt4
1059 baseRegOffset (DoubleReg ILIT2(1))      = OFFSET_Dbl1
1060 baseRegOffset (DoubleReg ILIT2(2))      = OFFSET_Dbl2
1061 baseRegOffset TagReg                    = OFFSET_Tag
1062 baseRegOffset RetReg                    = OFFSET_Ret
1063 baseRegOffset SpA                       = OFFSET_SpA
1064 baseRegOffset SuA                       = OFFSET_SuA
1065 baseRegOffset SpB                       = OFFSET_SpB
1066 baseRegOffset SuB                       = OFFSET_SuB
1067 baseRegOffset Hp                        = OFFSET_Hp
1068 baseRegOffset HpLim                     = OFFSET_HpLim
1069 baseRegOffset LivenessReg               = OFFSET_Liveness
1070 --baseRegOffset ActivityReg             = OFFSET_Activity
1071 #ifdef DEBUG
1072 baseRegOffset BaseReg                   = panic "baseRegOffset:BaseReg"
1073 baseRegOffset StdUpdRetVecReg           = panic "baseRegOffset:StgUpdRetVecReg"
1074 baseRegOffset StkStubReg                = panic "baseRegOffset:StkStubReg"
1075 baseRegOffset CurCostCentre             = panic "baseRegOffset:CurCostCentre"
1076 baseRegOffset VoidReg                   = panic "baseRegOffset:VoidReg"
1077 #endif
1078
1079 callerSaves :: MagicId -> Bool
1080 #ifdef CALLER_SAVES_Base
1081 callerSaves BaseReg             = True
1082 #endif
1083 #ifdef CALLER_SAVES_StkO
1084 callerSaves StkOReg             = True
1085 #endif
1086 #ifdef CALLER_SAVES_R1
1087 callerSaves (VanillaReg _ ILIT2(1))     = True
1088 #endif
1089 #ifdef CALLER_SAVES_R2
1090 callerSaves (VanillaReg _ ILIT2(2))    = True
1091 #endif
1092 #ifdef CALLER_SAVES_R3
1093 callerSaves (VanillaReg _ ILIT2(3))    = True
1094 #endif
1095 #ifdef CALLER_SAVES_R4
1096 callerSaves (VanillaReg _ ILIT2(4))    = True
1097 #endif
1098 #ifdef CALLER_SAVES_R5
1099 callerSaves (VanillaReg _ ILIT2(5))    = True
1100 #endif
1101 #ifdef CALLER_SAVES_R6
1102 callerSaves (VanillaReg _ ILIT2(6))    = True
1103 #endif
1104 #ifdef CALLER_SAVES_R7
1105 callerSaves (VanillaReg _ ILIT2(7))     = True
1106 #endif
1107 #ifdef CALLER_SAVES_R8
1108 callerSaves (VanillaReg _ ILIT2(8))    = True
1109 #endif
1110 #ifdef CALLER_SAVES_FltReg1
1111 callerSaves (FloatReg ILIT2(1))         = True
1112 #endif
1113 #ifdef CALLER_SAVES_FltReg2
1114 callerSaves (FloatReg ILIT2(2))         = True
1115 #endif
1116 #ifdef CALLER_SAVES_FltReg3
1117 callerSaves (FloatReg ILIT2(3))         = True
1118 #endif
1119 #ifdef CALLER_SAVES_FltReg4
1120 callerSaves (FloatReg ILIT2(4))         = True
1121 #endif
1122 #ifdef CALLER_SAVES_DblReg1
1123 callerSaves (DoubleReg ILIT2(1))        = True
1124 #endif
1125 #ifdef CALLER_SAVES_DblReg2
1126 callerSaves (DoubleReg ILIT2(2))        = True
1127 #endif
1128 #ifdef CALLER_SAVES_Tag
1129 callerSaves TagReg              = True
1130 #endif
1131 #ifdef CALLER_SAVES_Ret
1132 callerSaves RetReg              = True
1133 #endif
1134 #ifdef CALLER_SAVES_SpA
1135 callerSaves SpA                 = True
1136 #endif
1137 #ifdef CALLER_SAVES_SuA
1138 callerSaves SuA                 = True
1139 #endif
1140 #ifdef CALLER_SAVES_SpB
1141 callerSaves SpB                 = True
1142 #endif
1143 #ifdef CALLER_SAVES_SuB
1144 callerSaves SuB                 = True
1145 #endif
1146 #ifdef CALLER_SAVES_Hp
1147 callerSaves Hp                  = True
1148 #endif
1149 #ifdef CALLER_SAVES_HpLim
1150 callerSaves HpLim               = True
1151 #endif
1152 #ifdef CALLER_SAVES_Liveness
1153 callerSaves LivenessReg         = True
1154 #endif
1155 #ifdef CALLER_SAVES_Activity
1156 --callerSaves ActivityReg               = True
1157 #endif
1158 #ifdef CALLER_SAVES_StdUpdRetVec
1159 callerSaves StdUpdRetVecReg     = True
1160 #endif
1161 #ifdef CALLER_SAVES_StkStub
1162 callerSaves StkStubReg          = True
1163 #endif
1164 callerSaves _                   = False
1165
1166 stgRegMap :: MagicId -> Maybe Reg
1167
1168 #ifdef REG_Base
1169 stgRegMap BaseReg          = Just (FixedReg ILIT(REG_Base))
1170 #endif
1171 #ifdef REG_StkO
1172 stgRegMap StkOReg          = Just (FixedReg ILIT(REG_StkOReg))
1173 #endif
1174 #ifdef REG_R1
1175 stgRegMap (VanillaReg _ ILIT2(1)) = Just (FixedReg ILIT(REG_R1))
1176 #endif
1177 #ifdef REG_R2
1178 stgRegMap (VanillaReg _ ILIT2(2)) = Just (FixedReg ILIT(REG_R2))
1179 #endif
1180 #ifdef REG_R3
1181 stgRegMap (VanillaReg _ ILIT2(3)) = Just (FixedReg ILIT(REG_R3))
1182 #endif
1183 #ifdef REG_R4
1184 stgRegMap (VanillaReg _ ILIT2(4)) = Just (FixedReg ILIT(REG_R4))
1185 #endif
1186 #ifdef REG_R5
1187 stgRegMap (VanillaReg _ ILIT2(5)) = Just (FixedReg ILIT(REG_R5))
1188 #endif
1189 #ifdef REG_R6
1190 stgRegMap (VanillaReg _ ILIT2(6)) = Just (FixedReg ILIT(REG_R6))
1191 #endif
1192 #ifdef REG_R7
1193 stgRegMap (VanillaReg _ ILIT2(7)) = Just (FixedReg ILIT(REG_R7))
1194 #endif
1195 #ifdef REG_R8
1196 stgRegMap (VanillaReg _ ILIT2(8)) = Just (FixedReg ILIT(REG_R8))
1197 #endif
1198 #ifdef REG_Flt1
1199 stgRegMap (FloatReg ILIT2(1))      = Just (FixedReg ILIT(REG_Flt1))
1200 #endif
1201 #ifdef REG_Flt2
1202 stgRegMap (FloatReg ILIT2(2))      = Just (FixedReg ILIT(REG_Flt2))
1203 #endif
1204 #ifdef REG_Flt3
1205 stgRegMap (FloatReg ILIT2(3))      = Just (FixedReg ILIT(REG_Flt3))
1206 #endif
1207 #ifdef REG_Flt4
1208 stgRegMap (FloatReg ILIT2(4))      = Just (FixedReg ILIT(REG_Flt4))
1209 #endif
1210 #ifdef REG_Dbl1
1211 stgRegMap (DoubleReg ILIT2(1))     = Just (FixedReg ILIT(REG_Dbl1))
1212 #endif
1213 #ifdef REG_Dbl2
1214 stgRegMap (DoubleReg ILIT2(2))     = Just (FixedReg ILIT(REG_Dbl2))
1215 #endif
1216 #ifdef REG_Tag
1217 stgRegMap TagReg           = Just (FixedReg ILIT(REG_TagReg))
1218 #endif
1219 #ifdef REG_Ret
1220 stgRegMap RetReg           = Just (FixedReg ILIT(REG_Ret))
1221 #endif
1222 #ifdef REG_SpA
1223 stgRegMap SpA              = Just (FixedReg ILIT(REG_SpA))
1224 #endif
1225 #ifdef REG_SuA
1226 stgRegMap SuA              = Just (FixedReg ILIT(REG_SuA))
1227 #endif
1228 #ifdef REG_SpB
1229 stgRegMap SpB              = Just (FixedReg ILIT(REG_SpB))
1230 #endif
1231 #ifdef REG_SuB
1232 stgRegMap SuB              = Just (FixedReg ILIT(REG_SuB))
1233 #endif
1234 #ifdef REG_Hp
1235 stgRegMap Hp               = Just (FixedReg ILIT(REG_Hp))
1236 #endif
1237 #ifdef REG_HpLim
1238 stgRegMap HpLim            = Just (FixedReg ILIT(REG_HpLim))
1239 #endif
1240 #ifdef REG_Liveness
1241 stgRegMap LivenessReg      = Just (FixedReg ILIT(REG_Liveness))
1242 #endif
1243 #ifdef REG_Activity
1244 --stgRegMap ActivityReg    = Just (FixedReg ILIT(REG_Activity))
1245 #endif
1246 #ifdef REG_StdUpdRetVec
1247 stgRegMap StdUpdRetVecReg  = Just (FixedReg ILIT(REG_StdUpdRetVec))
1248 #endif
1249 #ifdef REG_StkStub
1250 stgRegMap StkStubReg       = Just (FixedReg ILIT(REG_StkStub))
1251 #endif
1252
1253 stgRegMap _                = Nothing
1254
1255 \end{code}
1256
1257 Here is the list of registers we can use in register allocation.
1258
1259 \begin{code}
1260 freeReg :: FAST_INT -> FAST_BOOL
1261
1262 --freeReg ILIT(esp) = _FALSE_  --       %esp is our stack pointer.
1263
1264 #ifdef REG_Base
1265 freeReg ILIT(REG_Base) = _FALSE_
1266 #endif
1267 #ifdef REG_StkO
1268 freeReg ILIT(REG_StkO) = _FALSE_
1269 #endif
1270 #ifdef REG_R1
1271 freeReg ILIT(REG_R1) = _FALSE_
1272 #endif
1273 #ifdef REG_R2
1274 freeReg ILIT(REG_R2) = _FALSE_
1275 #endif
1276 #ifdef REG_R3
1277 freeReg ILIT(REG_R3) = _FALSE_
1278 #endif
1279 #ifdef REG_R4
1280 freeReg ILIT(REG_R4) = _FALSE_
1281 #endif
1282 #ifdef REG_R5
1283 freeReg ILIT(REG_R5) = _FALSE_
1284 #endif
1285 #ifdef REG_R6
1286 freeReg ILIT(REG_R6) = _FALSE_
1287 #endif
1288 #ifdef REG_R7
1289 freeReg ILIT(REG_R7) = _FALSE_
1290 #endif
1291 #ifdef REG_R8
1292 freeReg ILIT(REG_R8) = _FALSE_
1293 #endif
1294 #ifdef REG_Flt1
1295 freeReg ILIT(REG_Flt1) = _FALSE_
1296 #endif
1297 #ifdef REG_Flt2
1298 freeReg ILIT(REG_Flt2) = _FALSE_
1299 #endif
1300 #ifdef REG_Flt3
1301 freeReg ILIT(REG_Flt3) = _FALSE_
1302 #endif
1303 #ifdef REG_Flt4
1304 freeReg ILIT(REG_Flt4) = _FALSE_
1305 #endif
1306 #ifdef REG_Dbl1
1307 freeReg ILIT(REG_Dbl1) = _FALSE_
1308 #endif
1309 #ifdef REG_Dbl2
1310 freeReg ILIT(REG_Dbl2) = _FALSE_
1311 #endif
1312 #ifdef REG_Tag
1313 freeReg ILIT(REG_Tag) = _FALSE_
1314 #endif
1315 #ifdef REG_Ret
1316 freeReg ILIT(REG_Ret) = _FALSE_
1317 #endif
1318 #ifdef REG_SpA
1319 freeReg ILIT(REG_SpA) = _FALSE_
1320 #endif
1321 #ifdef REG_SuA
1322 freeReg ILIT(REG_SuA) = _FALSE_
1323 #endif
1324 #ifdef REG_SpB
1325 freeReg ILIT(REG_SpB) = _FALSE_
1326 #endif
1327 #ifdef REG_SuB
1328 freeReg ILIT(REG_SuB) = _FALSE_
1329 #endif
1330 #ifdef REG_Hp
1331 freeReg ILIT(REG_Hp) = _FALSE_
1332 #endif
1333 #ifdef REG_HpLim
1334 freeReg ILIT(REG_HpLim) = _FALSE_
1335 #endif
1336 #ifdef REG_Liveness
1337 freeReg ILIT(REG_Liveness) = _FALSE_
1338 #endif
1339 #ifdef REG_Activity
1340 --freeReg ILIT(REG_Activity) = _FALSE_
1341 #endif
1342 #ifdef REG_StdUpdRetVec
1343 freeReg ILIT(REG_StdUpdRetVec) = _FALSE_
1344 #endif
1345 #ifdef REG_StkStub
1346 freeReg ILIT(REG_StkStub) = _FALSE_
1347 #endif
1348 freeReg n
1349 #ifdef REG_Dbl1
1350   | n _EQ_ (ILIT(REG_Dbl1) _ADD_ ILIT(1)) = _FALSE_
1351 #endif
1352 #ifdef REG_Dbl2
1353   | n _EQ_ (ILIT(REG_Dbl2) _ADD_ ILIT(1)) = _FALSE_
1354 #endif
1355
1356   | otherwise = _TRUE_
1357
1358 reservedRegs :: [Int]
1359 reservedRegs = []
1360 --reservedRegs = [NCG_Reserved_I1, NCG_Reserved_I2,
1361 --              NCG_Reserved_F1, NCG_Reserved_F2,
1362 --              NCG_Reserved_D1, NCG_Reserved_D2]
1363
1364 \end{code}
1365