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