ghc/compiler/nativeGen/I386Gen.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1995
   3 %
   4
   5 \begin{code}
   6 #include "HsVersions.h"
   7 #include "../includes/i386-unknown-linuxaout.h"
   8
   9 module I386Gen (
  10         i386CodeGen,
  11
  12         -- and, for self-sufficiency
  13         PprStyle, StixTree, CSeq
  14     ) where
  15
  16 IMPORT_Trace
  17
  18 import AbsCSyn      ( AbstractC, MagicId(..), kindFromMagicId )
  19 import PrelInfo     ( PrimOp(..)
  20                       IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  21                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  22                     )
  23 import AsmRegAlloc  ( runRegAllocate, mkReg, extractMappedRegNos,
  24                       Reg(..), RegLiveness(..), RegUsage(..),
  25                       FutureLive(..), MachineRegisters(..), MachineCode(..)
  26                     )
  27 import CLabel   ( CLabel, isAsmTemp )
  28 import I386Code    {- everything -}
  29 import MachDesc
  30 import Maybes       ( maybeToBool, Maybe(..) )
  31 import OrdList      -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
  32 import Outputable
  33 import I386Desc
  34 import Stix
  35 import UniqSupply
  36 import Pretty
  37 import Unpretty
  38 import Util
  39
  40 type CodeBlock a = (OrdList a -> OrdList a)
  41 \end{code}
  42
  43 %************************************************************************
  44 %*                                                                      *
  45 \subsection[I386CodeGen]{Generating I386 Code}
  46 %*                                                                      *
  47 %************************************************************************
  48
  49 This is the top-level code-generation function for the I386.
  50
  51 \begin{code}
  52
  53 i386CodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty
  54 i386CodeGen sty trees =
  55     mapUs genI386Code trees             `thenUs` \ dynamicCodes ->
  56     let
  57         staticCodes = scheduleI386Code dynamicCodes
  58         pretty = printLabeledCodes sty staticCodes
  59     in
  60         returnUs pretty
  61
  62 \end{code}
  63
  64 This bit does the code scheduling.  The scheduler must also deal with
  65 register allocation of temporaries.  Much parallelism can be exposed via
  66 the OrdList, but more might occur, so further analysis might be needed.
  67
  68 \begin{code}
  69
  70 scheduleI386Code :: [I386Code] -> [I386Instr]
  71 scheduleI386Code = concat . map (runRegAllocate freeI386Regs reservedRegs)
  72   where
  73     freeI386Regs :: I386Regs
  74     freeI386Regs = mkMRegs (extractMappedRegNos freeRegs)
  75
  76
  77 \end{code}
  78
  79 Registers passed up the tree.  If the stix code forces the register
  80 to live in a pre-decided machine register, it comes out as @Fixed@;
  81 otherwise, it comes out as @Any@, and the parent can decide which
  82 register to put it in.
  83
  84 \begin{code}
  85
  86 data Register
  87   = Fixed Reg PrimRep (CodeBlock I386Instr)
  88   | Any PrimRep (Reg -> (CodeBlock I386Instr))
  89
  90 registerCode :: Register -> Reg -> CodeBlock I386Instr
  91 registerCode (Fixed _ _ code) reg = code
  92 registerCode (Any _ code) reg = code reg
  93
  94 registerName :: Register -> Reg -> Reg
  95 registerName (Fixed reg _ _) _ = reg
  96 registerName (Any _ _) reg = reg
  97
  98 registerKind :: Register -> PrimRep
  99 registerKind (Fixed _ pk _) = pk
 100 registerKind (Any pk _) = pk
 101
 102 isFixed :: Register -> Bool
 103 isFixed (Fixed _ _ _) = True
 104 isFixed (Any _ _)     = False
 105
 106 \end{code}
 107
 108 Memory addressing modes passed up the tree.
 109
 110 \begin{code}
 111
 112 data Amode = Amode Addr (CodeBlock I386Instr)
 113
 114 amodeAddr (Amode addr _) = addr
 115 amodeCode (Amode _ code) = code
 116
 117 \end{code}
 118
 119 Condition codes passed up the tree.
 120
 121 \begin{code}
 122
 123 data Condition = Condition Bool Cond (CodeBlock I386Instr)
 124
 125 condName (Condition _ cond _) = cond
 126 condFloat (Condition float _ _) = float
 127 condCode (Condition _ _ code) = code
 128
 129 \end{code}
 130
 131 General things for putting together code sequences.
 132
 133 \begin{code}
 134
 135 asmVoid :: OrdList I386Instr
 136 asmVoid = mkEmptyList
 137
 138 asmInstr :: I386Instr -> I386Code
 139 asmInstr i = mkUnitList i
 140
 141 asmSeq :: [I386Instr] -> I386Code
 142 asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
 143
 144 asmParThen :: [I386Code] -> (CodeBlock I386Instr)
 145 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
 146
 147 returnInstr :: I386Instr -> UniqSM (CodeBlock I386Instr)
 148 returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
 149
 150 returnInstrs :: [I386Instr] -> UniqSM (CodeBlock I386Instr)
 151 returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
 152
 153 returnSeq :: (CodeBlock I386Instr) -> [I386Instr] -> UniqSM (CodeBlock I386Instr)
 154 returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
 155
 156 mkSeqInstr :: I386Instr -> (CodeBlock I386Instr)
 157 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
 158
 159 mkSeqInstrs :: [I386Instr] -> (CodeBlock I386Instr)
 160 mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
 161
 162 \end{code}
 163
 164 Top level i386 code generator for a chunk of stix code.
 165
 166 \begin{code}
 167
 168 genI386Code :: [StixTree] -> UniqSM (I386Code)
 169
 170 genI386Code trees =
 171     mapUs getCode trees                 `thenUs` \ blocks ->
 172     returnUs (foldr (.) id blocks asmVoid)
 173
 174 \end{code}
 175
 176 Code extractor for an entire stix tree---stix statement level.
 177
 178 \begin{code}
 179
 180 getCode
 181     :: StixTree     -- a stix statement
 182     -> UniqSM (CodeBlock I386Instr)
 183
 184 getCode (StSegment seg) = returnInstr (SEGMENT seg)
 185
 186 getCode (StAssign pk dst src)
 187   | isFloatingRep pk = assignFltCode pk dst src
 188   | otherwise = assignIntCode pk dst src
 189
 190 getCode (StLabel lab) = returnInstr (LABEL lab)
 191
 192 getCode (StFunBegin lab) = returnInstr (LABEL lab)
 193
 194 getCode (StFunEnd lab) = returnUs id
 195
 196 getCode (StJump arg) = genJump arg
 197
 198 getCode (StFallThrough lbl) = returnUs id
 199
 200 getCode (StCondJump lbl arg) = genCondJump lbl arg
 201
 202 getCode (StData kind args) =
 203     mapAndUnzipUs getData args              `thenUs` \ (codes, imms) ->
 204     returnUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
 205                                 (foldr1 (.) codes xs))
 206   where
 207     getData :: StixTree -> UniqSM (CodeBlock I386Instr, Imm)
 208     getData (StInt i) = returnUs (id, ImmInteger i)
 209     getData (StDouble d) = returnUs (id, strImmLit ('0' : 'd' : ppShow 80 (ppRational d)))
 210     getData (StLitLbl s) = returnUs (id, ImmLit (uppBeside (uppChar '_') s))
 211     getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
 212     getData (StString s) =
 213         getUniqLabelNCG                     `thenUs` \ lbl ->
 214         returnUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
 215     getData (StCLbl l)   = returnUs (id, ImmCLbl l)
 216
 217 getCode (StCall fn VoidRep args) = genCCall fn VoidRep args
 218
 219 getCode (StComment s) = returnInstr (COMMENT s)
 220
 221 \end{code}
 222
 223 Generate code to get a subtree into a register.
 224
 225 \begin{code}
 226
 227 getReg :: StixTree -> UniqSM Register
 228
 229 getReg (StReg (StixMagicId stgreg)) =
 230     case stgRegMap stgreg of
 231         Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id)
 232         -- cannot be Nothing
 233
 234 getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id)
 235
 236 getReg (StDouble 0.0)
 237   = let
 238         code dst = mkSeqInstrs [FLDZ]
 239     in
 240         returnUs (Any DoubleRep code)
 241
 242 getReg (StDouble 1.0)
 243   = let
 244         code dst = mkSeqInstrs [FLD1]
 245     in
 246         returnUs (Any DoubleRep code)
 247
 248 getReg (StDouble d) =
 249     getUniqLabelNCG                 `thenUs` \ lbl ->
 250     --getNewRegNCG PtrRep           `thenUs` \ tmp ->
 251     let code dst = mkSeqInstrs [
 252             SEGMENT DataSegment,
 253             LABEL lbl,
 254             DATA D [strImmLit ('0' : 'd' :ppShow 80 (ppRational d))],
 255             SEGMENT TextSegment,
 256             FLD D (OpImm (ImmCLbl lbl))
 257             ]
 258     in
 259         returnUs (Any DoubleRep code)
 260
 261 getReg (StString s) =
 262     getUniqLabelNCG                 `thenUs` \ lbl ->
 263     let code dst = mkSeqInstrs [
 264             SEGMENT DataSegment,
 265             LABEL lbl,
 266             ASCII True (_UNPK_ s),
 267             SEGMENT TextSegment,
 268             MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)]
 269     in
 270         returnUs (Any PtrRep code)
 271
 272 getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
 273     getUniqLabelNCG                 `thenUs` \ lbl ->
 274     let code dst = mkSeqInstrs [
 275             SEGMENT DataSegment,
 276             LABEL lbl,
 277             ASCII False (init xs),
 278             SEGMENT TextSegment,
 279             MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)]
 280     in
 281         returnUs (Any PtrRep code)
 282   where
 283     xs = _UNPK_ (_TAIL_ s)
 284
 285
 286 getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
 287
 288 getReg (StCall fn kind args) =
 289     genCCall fn kind args           `thenUs` \ call ->
 290     returnUs (Fixed reg kind call)
 291   where
 292     reg = if isFloatingRep kind then st0 else eax
 293
 294 getReg (StPrim primop args) =
 295     case primop of
 296
 297         CharGtOp -> condIntReg GT args
 298         CharGeOp -> condIntReg GE args
 299         CharEqOp -> condIntReg EQ args
 300         CharNeOp -> condIntReg NE args
 301         CharLtOp -> condIntReg LT args
 302         CharLeOp -> condIntReg LE args
 303
 304         IntAddOp -> -- this should be optimised by the generic Opts,
 305                     -- I don't know why it is not (sometimes)!
 306                     case args of
 307                       [x, StInt 0] -> getReg x
 308                       _ -> addCode L args
 309
 310         IntSubOp -> subCode L args
 311         IntMulOp -> trivialCode (IMUL L) args True
 312         IntQuotOp -> divCode L args True -- division
 313         IntRemOp -> divCode L args False -- remainder
 314         IntNegOp -> trivialUCode (NEGI L) args
 315         IntAbsOp -> absIntCode args
 316
 317         AndOp -> trivialCode (AND L) args True
 318         OrOp  -> trivialCode (OR L) args True
 319         NotOp -> trivialUCode (NOT L) args
 320         SllOp -> trivialCode (SHL L) args False
 321         SraOp -> trivialCode (SAR L) args False
 322         SrlOp -> trivialCode (SHR L) args False
 323         ISllOp -> panic "I386Gen:isll"
 324         ISraOp -> panic "I386Gen:isra"
 325         ISrlOp -> panic "I386Gen:isrl"
 326
 327         IntGtOp -> condIntReg GT args
 328         IntGeOp -> condIntReg GE args
 329         IntEqOp -> condIntReg EQ args
 330         IntNeOp -> condIntReg NE args
 331         IntLtOp -> condIntReg LT args
 332         IntLeOp -> condIntReg LE args
 333
 334         WordGtOp -> condIntReg GU args
 335         WordGeOp -> condIntReg GEU args
 336         WordEqOp -> condIntReg EQ args
 337         WordNeOp -> condIntReg NE args
 338         WordLtOp -> condIntReg LU args
 339         WordLeOp -> condIntReg LEU args
 340
 341         AddrGtOp -> condIntReg GU args
 342         AddrGeOp -> condIntReg GEU args
 343         AddrEqOp -> condIntReg EQ args
 344         AddrNeOp -> condIntReg NE args
 345         AddrLtOp -> condIntReg LU args
 346         AddrLeOp -> condIntReg LEU args
 347
 348         FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP args
 349         FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP args
 350         FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP args
 351         FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP args
 352         FloatNegOp -> trivialUFCode FloatRep FCHS args
 353
 354         FloatGtOp -> condFltReg GT args
 355         FloatGeOp -> condFltReg GE args
 356         FloatEqOp -> condFltReg EQ args
 357         FloatNeOp -> condFltReg NE args
 358         FloatLtOp -> condFltReg LT args
 359         FloatLeOp -> condFltReg LE args
 360
 361         FloatExpOp -> promoteAndCall SLIT("exp") DoubleRep
 362         FloatLogOp -> promoteAndCall SLIT("log") DoubleRep
 363         FloatSqrtOp -> trivialUFCode FloatRep FSQRT args
 364
 365         FloatSinOp -> promoteAndCall SLIT("sin") DoubleRep
 366                       --trivialUFCode FloatRep FSIN args
 367         FloatCosOp -> promoteAndCall SLIT("cos") DoubleRep
 368                       --trivialUFCode FloatRep FCOS args
 369         FloatTanOp -> promoteAndCall SLIT("tan") DoubleRep
 370
 371         FloatAsinOp -> promoteAndCall SLIT("asin") DoubleRep
 372         FloatAcosOp -> promoteAndCall SLIT("acos") DoubleRep
 373         FloatAtanOp -> promoteAndCall SLIT("atan") DoubleRep
 374
 375         FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleRep
 376         FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleRep
 377         FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleRep
 378
 379         FloatPowerOp -> promoteAndCall SLIT("pow") DoubleRep
 380
 381         DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP args
 382         DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP args
 383         DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP args
 384         DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP args
 385         DoubleNegOp -> trivialUFCode DoubleRep FCHS args
 386
 387         DoubleGtOp -> condFltReg GT args
 388         DoubleGeOp -> condFltReg GE args
 389         DoubleEqOp -> condFltReg EQ args
 390         DoubleNeOp -> condFltReg NE args
 391         DoubleLtOp -> condFltReg LT args
 392         DoubleLeOp -> condFltReg LE args
 393
 394         DoubleExpOp -> call SLIT("exp") DoubleRep
 395         DoubleLogOp -> call SLIT("log") DoubleRep
 396         DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT args
 397
 398         DoubleSinOp -> call SLIT("sin") DoubleRep
 399                        --trivialUFCode DoubleRep FSIN args
 400         DoubleCosOp -> call SLIT("cos") DoubleRep
 401                        --trivialUFCode DoubleRep FCOS args
 402         DoubleTanOp -> call SLIT("tan") DoubleRep
 403
 404         DoubleAsinOp -> call SLIT("asin") DoubleRep
 405         DoubleAcosOp -> call SLIT("acos") DoubleRep
 406         DoubleAtanOp -> call SLIT("atan") DoubleRep
 407
 408         DoubleSinhOp -> call SLIT("sinh") DoubleRep
 409         DoubleCoshOp -> call SLIT("cosh") DoubleRep
 410         DoubleTanhOp -> call SLIT("tanh") DoubleRep
 411
 412         DoublePowerOp -> call SLIT("pow") DoubleRep
 413
 414         OrdOp -> coerceIntCode IntRep args
 415         ChrOp -> chrCode args
 416
 417         Float2IntOp -> coerceFP2Int args
 418         Int2FloatOp -> coerceInt2FP FloatRep args
 419         Double2IntOp -> coerceFP2Int args
 420         Int2DoubleOp -> coerceInt2FP DoubleRep args
 421
 422         Double2FloatOp -> coerceFltCode args
 423         Float2DoubleOp -> coerceFltCode args
 424
 425   where
 426     call fn pk = getReg (StCall fn pk args)
 427     promoteAndCall fn pk = getReg (StCall fn pk (map promote args))
 428       where
 429         promote x = StPrim Float2DoubleOp [x]
 430
 431 getReg (StInd pk mem) =
 432     getAmode mem                    `thenUs` \ amode ->
 433     let
 434         code = amodeCode amode
 435         src   = amodeAddr amode
 436         size = kindToSize pk
 437         code__2 dst = code .
 438                       if pk == DoubleRep || pk == FloatRep
 439                       then mkSeqInstr (FLD {-D-} size (OpAddr src))
 440                       else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
 441     in
 442         returnUs (Any pk code__2)
 443
 444
 445 getReg (StInt i)
 446   = let
 447         src = ImmInt (fromInteger i)
 448         code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
 449     in
 450         returnUs (Any IntRep code)
 451
 452 getReg leaf
 453   | maybeToBool imm =
 454     let
 455         code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
 456     in
 457         returnUs (Any PtrRep code)
 458   where
 459     imm = maybeImm leaf
 460     imm__2 = case imm of Just x -> x
 461
 462 \end{code}
 463
 464 Now, given a tree (the argument to an StInd) that references memory,
 465 produce a suitable addressing mode.
 466
 467 \begin{code}
 468
 469 getAmode :: StixTree -> UniqSM Amode
 470
 471 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
 472
 473 getAmode (StPrim IntSubOp [x, StInt i])
 474   =
 475     getNewRegNCG PtrRep             `thenUs` \ tmp ->
 476     getReg x                        `thenUs` \ register ->
 477     let
 478         code = registerCode register tmp
 479         reg  = registerName register tmp
 480         off  = ImmInt (-(fromInteger i))
 481     in
 482         returnUs (Amode (Addr (Just reg) Nothing off) code)
 483
 484 getAmode (StPrim IntAddOp [x, StInt i])
 485   | maybeToBool imm
 486   = let
 487         code = mkSeqInstrs []
 488     in
 489         returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
 490   where
 491     imm = maybeImm x
 492     imm__2 = case imm of Just x -> x
 493
 494 getAmode (StPrim IntAddOp [x, StInt i])
 495   =
 496     getNewRegNCG PtrRep             `thenUs` \ tmp ->
 497     getReg x                        `thenUs` \ register ->
 498     let
 499         code = registerCode register tmp
 500         reg  = registerName register tmp
 501         off  = ImmInt (fromInteger i)
 502     in
 503         returnUs (Amode (Addr (Just reg) Nothing off) code)
 504
 505 getAmode (StPrim IntAddOp [x, y]) =
 506     getNewRegNCG PtrRep             `thenUs` \ tmp1 ->
 507     getNewRegNCG IntRep             `thenUs` \ tmp2 ->
 508     getReg x                        `thenUs` \ register1 ->
 509     getReg y                        `thenUs` \ register2 ->
 510     let
 511         code1 = registerCode register1 tmp1 asmVoid
 512         reg1  = registerName register1 tmp1
 513         code2 = registerCode register2 tmp2 asmVoid
 514         reg2  = registerName register2 tmp2
 515         code__2 = asmParThen [code1, code2]
 516     in
 517         returnUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
 518
 519 getAmode leaf
 520   | maybeToBool imm =
 521     let code = mkSeqInstrs []
 522     in
 523         returnUs (Amode (ImmAddr imm__2 0) code)
 524   where
 525     imm = maybeImm leaf
 526     imm__2 = case imm of Just x -> x
 527
 528 getAmode other =
 529     getNewRegNCG PtrRep             `thenUs` \ tmp ->
 530     getReg other                    `thenUs` \ register ->
 531     let
 532         code = registerCode register tmp
 533         reg  = registerName register tmp
 534         off  = Nothing
 535     in
 536         returnUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code)
 537
 538 \end{code}
 539
 540 \begin{code}
 541 getOp
 542     :: StixTree
 543     -> UniqSM (CodeBlock I386Instr,Operand, Size)       -- code, operator, size
 544 getOp (StInt i)
 545   = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
 546
 547 getOp (StInd pk mem)
 548   = getAmode mem                    `thenUs` \ amode ->
 549     let
 550         code = amodeCode amode --asmVoid
 551         addr  = amodeAddr amode
 552         sz = kindToSize pk
 553     in returnUs (code, OpAddr addr, sz)
 554
 555 getOp op
 556   = getReg op                       `thenUs` \ register ->
 557     getNewRegNCG (registerKind register)
 558                                     `thenUs` \ tmp ->
 559     let
 560         code = registerCode register tmp
 561         reg = registerName register tmp
 562         pk = registerKind register
 563         sz = kindToSize pk
 564     in
 565         returnUs (code, OpReg reg, sz)
 566
 567 getOpRI
 568     :: StixTree
 569     -> UniqSM (CodeBlock I386Instr,Operand, Size)       -- code, operator, size
 570 getOpRI op
 571   | maybeToBool imm
 572   = returnUs (asmParThen [], OpImm imm_op, L)
 573   where
 574     imm = maybeImm op
 575     imm_op = case imm of Just x -> x
 576
 577 getOpRI op
 578   = getReg op                       `thenUs` \ register ->
 579     getNewRegNCG (registerKind register)
 580                                     `thenUs` \ tmp ->
 581     let
 582         code = registerCode register tmp
 583         reg = registerName register tmp
 584         pk = registerKind register
 585         sz = kindToSize pk
 586     in
 587         returnUs (code, OpReg reg, sz)
 588
 589 \end{code}
 590
 591 Set up a condition code for a conditional branch.
 592
 593 \begin{code}
 594
 595 getCondition :: StixTree -> UniqSM Condition
 596
 597 getCondition (StPrim primop args) =
 598     case primop of
 599
 600         CharGtOp -> condIntCode GT args
 601         CharGeOp -> condIntCode GE args
 602         CharEqOp -> condIntCode EQ args
 603         CharNeOp -> condIntCode NE args
 604         CharLtOp -> condIntCode LT args
 605         CharLeOp -> condIntCode LE args
 606
 607         IntGtOp -> condIntCode GT args
 608         IntGeOp -> condIntCode GE args
 609         IntEqOp -> condIntCode EQ args
 610         IntNeOp -> condIntCode NE args
 611         IntLtOp -> condIntCode LT args
 612         IntLeOp -> condIntCode LE args
 613
 614         WordGtOp -> condIntCode GU args
 615         WordGeOp -> condIntCode GEU args
 616         WordEqOp -> condIntCode EQ args
 617         WordNeOp -> condIntCode NE args
 618         WordLtOp -> condIntCode LU args
 619         WordLeOp -> condIntCode LEU args
 620
 621         AddrGtOp -> condIntCode GU args
 622         AddrGeOp -> condIntCode GEU args
 623         AddrEqOp -> condIntCode EQ args
 624         AddrNeOp -> condIntCode NE args
 625         AddrLtOp -> condIntCode LU args
 626         AddrLeOp -> condIntCode LEU args
 627
 628         FloatGtOp -> condFltCode GT args
 629         FloatGeOp -> condFltCode GE args
 630         FloatEqOp -> condFltCode EQ args
 631         FloatNeOp -> condFltCode NE args
 632         FloatLtOp -> condFltCode LT args
 633         FloatLeOp -> condFltCode LE args
 634
 635         DoubleGtOp -> condFltCode GT args
 636         DoubleGeOp -> condFltCode GE args
 637         DoubleEqOp -> condFltCode EQ args
 638         DoubleNeOp -> condFltCode NE args
 639         DoubleLtOp -> condFltCode LT args
 640         DoubleLeOp -> condFltCode LE args
 641
 642 \end{code}
 643
 644 Turn a boolean expression into a condition, to be passed
 645 back up the tree.
 646
 647 \begin{code}
 648
 649 condIntCode, condFltCode :: Cond -> [StixTree] -> UniqSM Condition
 650 condIntCode cond [StInd _ x, y]
 651   | maybeToBool imm
 652   = getAmode x                      `thenUs` \ amode ->
 653     let
 654         code1 = amodeCode amode asmVoid
 655         y__2  = amodeAddr amode
 656         code__2 = asmParThen [code1] .
 657                   mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
 658     in
 659         returnUs (Condition False cond code__2)
 660   where
 661     imm = maybeImm y
 662     imm__2 = case imm of Just x -> x
 663
 664 condIntCode cond [x, StInt 0]
 665   = getReg x                        `thenUs` \ register1 ->
 666     getNewRegNCG IntRep             `thenUs` \ tmp1 ->
 667     let
 668         code1 = registerCode register1 tmp1 asmVoid
 669         src1  = registerName register1 tmp1
 670         code__2 = asmParThen [code1] .
 671                 mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
 672     in
 673         returnUs (Condition False cond code__2)
 674
 675 condIntCode cond [x, y]
 676   | maybeToBool imm
 677   = getReg x                        `thenUs` \ register1 ->
 678     getNewRegNCG IntRep             `thenUs` \ tmp1 ->
 679     let
 680         code1 = registerCode register1 tmp1 asmVoid
 681         src1  = registerName register1 tmp1
 682         code__2 = asmParThen [code1] .
 683                 mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
 684     in
 685         returnUs (Condition False cond code__2)
 686   where
 687     imm = maybeImm y
 688     imm__2 = case imm of Just x -> x
 689
 690 condIntCode cond [StInd _ x, y]
 691   = getAmode x                      `thenUs` \ amode ->
 692     getReg y                        `thenUs` \ register2 ->
 693     getNewRegNCG IntRep             `thenUs` \ tmp2 ->
 694     let
 695         code1 = amodeCode amode asmVoid
 696         src1  = amodeAddr amode
 697         code2 = registerCode register2 tmp2 asmVoid
 698         src2  = registerName register2 tmp2
 699         code__2 = asmParThen [code1, code2] .
 700                   mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
 701     in
 702         returnUs (Condition False cond code__2)
 703
 704 condIntCode cond [y, StInd _ x]
 705   = getAmode x                      `thenUs` \ amode ->
 706     getReg y                        `thenUs` \ register2 ->
 707     getNewRegNCG IntRep             `thenUs` \ tmp2 ->
 708     let
 709         code1 = amodeCode amode asmVoid
 710         src1  = amodeAddr amode
 711         code2 = registerCode register2 tmp2 asmVoid
 712         src2  = registerName register2 tmp2
 713         code__2 = asmParThen [code1, code2] .
 714                   mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
 715     in
 716         returnUs (Condition False cond code__2)
 717
 718 condIntCode cond [x, y] =
 719     getReg x                        `thenUs` \ register1 ->
 720     getReg y                        `thenUs` \ register2 ->
 721     getNewRegNCG IntRep             `thenUs` \ tmp1 ->
 722     getNewRegNCG IntRep             `thenUs` \ tmp2 ->
 723     let
 724         code1 = registerCode register1 tmp1 asmVoid
 725         src1  = registerName register1 tmp1
 726         code2 = registerCode register2 tmp2 asmVoid
 727         src2  = registerName register2 tmp2
 728         code__2 = asmParThen [code1, code2] .
 729                 mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
 730     in
 731         returnUs (Condition False cond code__2)
 732
 733 condFltCode cond [x, StDouble 0.0] =
 734     getReg x                        `thenUs` \ register1 ->
 735     getNewRegNCG (registerKind register1)
 736                                     `thenUs` \ tmp1 ->
 737     let
 738         pk1   = registerKind register1
 739         code1 = registerCode register1 tmp1
 740         src1  = registerName register1 tmp1
 741
 742         code__2 = asmParThen [code1 asmVoid] .
 743                   mkSeqInstrs [FTST, FSTP D (OpReg st0), -- or FLDZ, FUCOMPP ?
 744                                FNSTSW,
 745                                --AND HB (OpImm (ImmInt 68)) (OpReg eax),
 746                                --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
 747                                SAHF
 748                               ]
 749     in
 750         returnUs (Condition True (fixFPCond cond) code__2)
 751
 752 condFltCode cond [x, y] =
 753     getReg x                        `thenUs` \ register1 ->
 754     getReg y                        `thenUs` \ register2 ->
 755     getNewRegNCG (registerKind register1)
 756                                     `thenUs` \ tmp1 ->
 757     getNewRegNCG (registerKind register2)
 758                                     `thenUs` \ tmp2 ->
 759     let
 760         pk1   = registerKind register1
 761         code1 = registerCode register1 tmp1
 762         src1  = registerName register1 tmp1
 763
 764         code2 = registerCode register2 tmp2
 765         src2  = registerName register2 tmp2
 766
 767         code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
 768                   mkSeqInstrs [FUCOMPP,
 769                                FNSTSW,
 770                                --AND HB (OpImm (ImmInt 68)) (OpReg eax),
 771                                --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
 772                                SAHF
 773                               ]
 774     in
 775         returnUs (Condition True (fixFPCond cond) code__2)
 776
 777 \end{code}
 778
 779 Turn those condition codes into integers now (when they appear on
 780 the right hand side of an assignment).
 781
 782 \begin{code}
 783
 784 condIntReg :: Cond -> [StixTree] -> UniqSM Register
 785 condIntReg cond args =
 786     condIntCode cond args           `thenUs` \ condition ->
 787     getNewRegNCG IntRep             `thenUs` \ tmp ->
 788     --getReg dst                            `thenUs` \ register ->
 789     let
 790         --code2 = registerCode register tmp asmVoid
 791         --dst__2  = registerName register tmp
 792         code = condCode condition
 793         cond = condName condition
 794 -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
 795         code__2 dst = code . mkSeqInstrs [
 796             SETCC cond (OpReg tmp),
 797             AND L (OpImm (ImmInt 1)) (OpReg tmp),
 798             MOV L (OpReg tmp) (OpReg dst)]
 799     in
 800         returnUs (Any IntRep code__2)
 801
 802 condFltReg :: Cond -> [StixTree] -> UniqSM Register
 803
 804 condFltReg cond args =
 805     getUniqLabelNCG                 `thenUs` \ lbl1 ->
 806     getUniqLabelNCG                 `thenUs` \ lbl2 ->
 807     condFltCode cond args           `thenUs` \ condition ->
 808     let
 809         code = condCode condition
 810         cond = condName condition
 811         code__2 dst = code . mkSeqInstrs [
 812             JXX cond lbl1,
 813             MOV L (OpImm (ImmInt 0)) (OpReg dst),
 814             JXX ALWAYS lbl2,
 815             LABEL lbl1,
 816             MOV L (OpImm (ImmInt 1)) (OpReg dst),
 817             LABEL lbl2]
 818     in
 819         returnUs (Any IntRep code__2)
 820
 821 \end{code}
 822
 823 Assignments are really at the heart of the whole code generation business.
 824 Almost all top-level nodes of any real importance are assignments, which
 825 correspond to loads, stores, or register transfers.  If we're really lucky,
 826 some of the register transfers will go away, because we can use the destination
 827 register to complete the code generation for the right hand side.  This only
 828 fails when the right hand side is forced into a fixed register (e.g. the result
 829 of a call).
 830
 831 \begin{code}
 832
 833 assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock I386Instr)
 834 assignIntCode pk (StInd _ dst) src
 835   = getAmode dst                    `thenUs` \ amode ->
 836     getOpRI src                     `thenUs` \ (codesrc, opsrc, sz) ->
 837     let
 838         code1 = amodeCode amode asmVoid
 839         dst__2  = amodeAddr amode
 840         code__2 = asmParThen [code1, codesrc asmVoid] .
 841                   mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
 842     in
 843         returnUs code__2
 844
 845 assignIntCode pk dst (StInd _ src) =
 846     getNewRegNCG IntRep             `thenUs` \ tmp ->
 847     getAmode src                    `thenUs` \ amode ->
 848     getReg dst                      `thenUs` \ register ->
 849     let
 850         code1 = amodeCode amode asmVoid
 851         src__2  = amodeAddr amode
 852         code2 = registerCode register tmp asmVoid
 853         dst__2  = registerName register tmp
 854         sz    = kindToSize pk
 855         code__2 = asmParThen [code1, code2] .
 856                   mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
 857     in
 858         returnUs code__2
 859
 860 assignIntCode pk dst src =
 861     getReg dst                      `thenUs` \ register1 ->
 862     getReg src                      `thenUs` \ register2 ->
 863     getNewRegNCG IntRep             `thenUs` \ tmp ->
 864     let
 865         dst__2 = registerName register1 tmp
 866         code = registerCode register2 dst__2
 867         src__2 = registerName register2 dst__2
 868         code__2 = if isFixed register2 && dst__2 /= src__2
 869                   then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
 870                   else
 871                        code
 872     in
 873         returnUs code__2
 874
 875 assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock I386Instr)
 876 assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
 877   = getNewRegNCG IntRep             `thenUs` \ tmp ->
 878     getAmode src                    `thenUs` \ amodesrc ->
 879     getAmode dst                    `thenUs` \ amodedst ->
 880     --getReg src                            `thenUs` \ register ->
 881     let
 882         codesrc1 = amodeCode amodesrc asmVoid
 883         addrsrc1 = amodeAddr amodesrc
 884         codedst1 = amodeCode amodedst asmVoid
 885         addrdst1 = amodeAddr amodedst
 886         addrsrc2 = case (offset addrsrc1 4) of Just x -> x
 887         addrdst2 = case (offset addrdst1 4) of Just x -> x
 888
 889         code__2 = asmParThen [codesrc1, codedst1] .
 890                   mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
 891                                 MOV L (OpReg tmp) (OpAddr addrdst1)]
 892                                ++
 893                                if pk == DoubleRep
 894                                then [MOV L (OpAddr addrsrc2) (OpReg tmp),
 895                                      MOV L (OpReg tmp) (OpAddr addrdst2)]
 896                                else [])
 897     in
 898         returnUs code__2
 899
 900 assignFltCode pk (StInd _ dst) src =
 901     --getNewRegNCG pk               `thenUs` \ tmp ->
 902     getAmode dst                    `thenUs` \ amode ->
 903     getReg src                      `thenUs` \ register ->
 904     let
 905         sz    = kindToSize pk
 906         dst__2  = amodeAddr amode
 907
 908         code1 = amodeCode amode asmVoid
 909         code2 = registerCode register {-tmp-}st0 asmVoid
 910
 911         --src__2  = registerName register tmp
 912         pk__2  = registerKind register
 913         sz__2 = kindToSize pk__2
 914
 915         code__2 = asmParThen [code1, code2] .
 916                   mkSeqInstr (FSTP sz (OpAddr dst__2))
 917     in
 918         returnUs code__2
 919
 920 assignFltCode pk dst src =
 921     getReg dst                      `thenUs` \ register1 ->
 922     getReg src                      `thenUs` \ register2 ->
 923     --getNewRegNCG (registerKind register2)
 924     --                              `thenUs` \ tmp ->
 925     let
 926         sz = kindToSize pk
 927         dst__2 = registerName register1 st0 --tmp
 928
 929         code = registerCode register2 dst__2
 930         src__2 = registerName register2 dst__2
 931
 932         code__2 = code
 933     in
 934         returnUs code__2
 935
 936 \end{code}
 937
 938 Generating an unconditional branch.  We accept two types of targets:
 939 an immediate CLabel or a tree that gets evaluated into a register.
 940 Any CLabels which are AsmTemporaries are assumed to be in the local
 941 block of code, close enough for a branch instruction.  Other CLabels
 942 are assumed to be far away, so we use call.
 943
 944 Do not fill the delay slots here; you will confuse the register allocator.
 945
 946 \begin{code}
 947
 948 genJump
 949     :: StixTree     -- the branch target
 950     -> UniqSM (CodeBlock I386Instr)
 951
 952 {-
 953 genJump (StCLbl lbl)
 954   | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
 955   | otherwise     = returnInstrs [JMP (OpImm target)]
 956   where
 957     target = ImmCLbl lbl
 958 -}
 959
 960 genJump (StInd pk mem) =
 961     getAmode mem                    `thenUs` \ amode ->
 962     let
 963         code = amodeCode amode
 964         target  = amodeAddr amode
 965     in
 966         returnSeq code [JMP (OpAddr target)]
 967
 968 genJump tree
 969   | maybeToBool imm
 970   = returnInstr (JMP (OpImm target))
 971   where
 972     imm = maybeImm tree
 973     target = case imm of Just x -> x
 974
 975
 976 genJump tree =
 977     getReg tree                     `thenUs` \ register ->
 978     getNewRegNCG PtrRep             `thenUs` \ tmp ->
 979     let
 980         code = registerCode register tmp
 981         target = registerName register tmp
 982     in
 983         returnSeq code [JMP (OpReg target)]
 984
 985 \end{code}
 986
 987 Conditional jumps are always to local labels, so we can use
 988 branch instructions.  First, we have to ensure that the condition
 989 codes are set according to the supplied comparison operation.
 990
 991 \begin{code}
 992
 993 genCondJump
 994     :: CLabel       -- the branch target
 995     -> StixTree     -- the condition on which to branch
 996     -> UniqSM (CodeBlock I386Instr)
 997
 998 genCondJump lbl bool =
 999     getCondition bool               `thenUs` \ condition ->
1000     let
1001         code = condCode condition
1002         cond = condName condition
1003         target = ImmCLbl lbl
1004     in
1005         returnSeq code [JXX cond lbl]
1006
1007 \end{code}
1008
1009 \begin{code}
1010
1011 genCCall
1012     :: FAST_STRING  -- function to call
1013     -> PrimRep      -- type of the result
1014     -> [StixTree]   -- arguments (of mixed type)
1015     -> UniqSM (CodeBlock I386Instr)
1016
1017 genCCall fn kind [StInt i]
1018   | fn == SLIT ("PerformGC_wrapper")
1019   = getUniqLabelNCG                 `thenUs` \ lbl ->
1020     let
1021         call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
1022                 MOV L (OpImm (ImmCLbl lbl))
1023                       -- this is hardwired
1024                       (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
1025                 JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))),
1026                 LABEL lbl]
1027     in
1028         returnInstrs call
1029
1030 genCCall fn kind args =
1031     mapUs getCallArg args `thenUs` \ argCode ->
1032     let
1033         nargs = length args
1034         code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))),
1035                         MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
1036                                    ]
1037                            ]
1038         code2 = asmParThen (map ($ asmVoid) (reverse argCode))
1039         call = [CALL (ImmLit fn__2) -- ,
1040                 -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
1041                 -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
1042                 ]
1043     in
1044         returnSeq (code1 . code2) call
1045   where
1046     -- function names that begin with '.' are assumed to be special internally
1047     -- generated names like '.mul,' which don't get an underscore prefix
1048     fn__2 = case (_HEAD_ fn) of
1049               '.' -> uppPStr fn
1050               _   -> uppBeside (uppChar '_') (uppPStr fn)
1051
1052     getCallArg
1053         :: StixTree                             -- Current argument
1054         -> UniqSM (CodeBlock I386Instr) -- code
1055     getCallArg arg =
1056         getOp arg                           `thenUs` \ (code, op, sz) ->
1057         returnUs (code . mkSeqInstr (PUSH sz op))
1058 \end{code}
1059
1060 Trivial (dyadic) instructions.  Only look for constants on the right hand
1061 side, because that's where the generic optimizer will have put them.
1062
1063 \begin{code}
1064
1065 trivialCode
1066     :: (Operand -> Operand -> I386Instr)
1067     -> [StixTree]
1068     -> Bool     -- is the instr commutative?
1069     -> UniqSM Register
1070
1071 trivialCode instr [x, y] _
1072   | maybeToBool imm
1073   = getReg x                        `thenUs` \ register1 ->
1074     --getNewRegNCG IntRep           `thenUs` \ tmp1 ->
1075     let
1076         fixedname  = registerName register1 eax
1077         code__2 dst = let code1 = registerCode register1 dst
1078                           src1  = registerName register1 dst
1079                       in code1 .
1080                          if isFixed register1 && src1 /= dst
1081                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
1082                                            instr (OpImm imm__2) (OpReg dst)]
1083                          else
1084                                 mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
1085     in
1086         returnUs (Any IntRep code__2)
1087   where
1088     imm = maybeImm y
1089     imm__2 = case imm of Just x -> x
1090
1091 trivialCode instr [x, y] _
1092   | maybeToBool imm
1093   = getReg y                        `thenUs` \ register1 ->
1094     --getNewRegNCG IntRep           `thenUs` \ tmp1 ->
1095     let
1096         fixedname  = registerName register1 eax
1097         code__2 dst = let code1 = registerCode register1 dst
1098                           src1  = registerName register1 dst
1099                       in code1 .
1100                          if isFixed register1 && src1 /= dst
1101                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
1102                                            instr (OpImm imm__2) (OpReg dst)]
1103                          else
1104                                 mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
1105     in
1106         returnUs (Any IntRep code__2)
1107   where
1108     imm = maybeImm x
1109     imm__2 = case imm of Just x -> x
1110
1111 trivialCode instr [x, StInd pk mem] _
1112   = getReg x                        `thenUs` \ register ->
1113     --getNewRegNCG IntRep           `thenUs` \ tmp ->
1114     getAmode mem                    `thenUs` \ amode ->
1115     let
1116         fixedname  = registerName register eax
1117         code2 = amodeCode amode asmVoid
1118         src2  = amodeAddr amode
1119         code__2 dst = let code1 = registerCode register dst asmVoid
1120                           src1  = registerName register dst
1121                       in asmParThen [code1, code2] .
1122                          if isFixed register && src1 /= dst
1123                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
1124                                            instr (OpAddr src2)  (OpReg dst)]
1125                          else
1126                                 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
1127     in
1128         returnUs (Any pk code__2)
1129
1130 trivialCode instr [StInd pk mem, y] _
1131   = getReg y                        `thenUs` \ register ->
1132     --getNewRegNCG IntRep           `thenUs` \ tmp ->
1133     getAmode mem                    `thenUs` \ amode ->
1134     let
1135         fixedname  = registerName register eax
1136         code2 = amodeCode amode asmVoid
1137         src2  = amodeAddr amode
1138         code__2 dst = let
1139                           code1 = registerCode register dst asmVoid
1140                           src1  = registerName register dst
1141                       in asmParThen [code1, code2] .
1142                          if isFixed register && src1 /= dst
1143                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
1144                                            instr (OpAddr src2)  (OpReg dst)]
1145                          else
1146                                 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
1147     in
1148         returnUs (Any pk code__2)
1149
1150 trivialCode instr [x, y] is_comm_op
1151   = getReg x                        `thenUs` \ register1 ->
1152     getReg y                        `thenUs` \ register2 ->
1153     --getNewRegNCG IntRep           `thenUs` \ tmp1 ->
1154     getNewRegNCG IntRep             `thenUs` \ tmp2 ->
1155     let
1156         fixedname  = registerName register1 eax
1157         code2 = registerCode register2 tmp2 asmVoid
1158         src2  = registerName register2 tmp2
1159         code__2 dst = let
1160                           code1 = registerCode register1 dst asmVoid
1161                           src1  = registerName register1 dst
1162                       in asmParThen [code1, code2] .
1163                          if isFixed register1 && src1 /= dst
1164                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
1165                                            instr (OpReg src2)  (OpReg dst)]
1166                          else
1167                                 mkSeqInstr (instr (OpReg src2) (OpReg src1))
1168     in
1169         returnUs (Any IntRep code__2)
1170
1171 addCode
1172     :: Size
1173     -> [StixTree]
1174     -> UniqSM Register
1175 addCode sz [x, StInt y]
1176   =
1177     getReg x                        `thenUs` \ register ->
1178     getNewRegNCG IntRep             `thenUs` \ tmp ->
1179     let
1180         code = registerCode register tmp
1181         src1 = registerName register tmp
1182         src2 = ImmInt (fromInteger y)
1183         code__2 dst = code .
1184                       mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
1185     in
1186         returnUs (Any IntRep code__2)
1187
1188 addCode sz [x, StInd _ mem]
1189   = getReg x                        `thenUs` \ register1 ->
1190     --getNewRegNCG (registerKind register1)
1191     --                                      `thenUs` \ tmp1 ->
1192     getAmode mem                    `thenUs` \ amode ->
1193     let
1194         code2 = amodeCode amode
1195         src2  = amodeAddr amode
1196
1197         fixedname  = registerName register1 eax
1198         code__2 dst = let code1 = registerCode register1 dst
1199                           src1  = registerName register1 dst
1200                       in asmParThen [code2 asmVoid,code1 asmVoid] .
1201                          if isFixed register1 && src1 /= dst
1202                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
1203                                            ADD sz (OpAddr src2)  (OpReg dst)]
1204                          else
1205                                 mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
1206     in
1207         returnUs (Any IntRep code__2)
1208
1209 addCode sz [StInd _ mem, y]
1210   = getReg y                        `thenUs` \ register2 ->
1211     --getNewRegNCG (registerKind register2)
1212     --                                      `thenUs` \ tmp2 ->
1213     getAmode mem                    `thenUs` \ amode ->
1214     let
1215         code1 = amodeCode amode
1216         src1  = amodeAddr amode
1217
1218         fixedname  = registerName register2 eax
1219         code__2 dst = let code2 = registerCode register2 dst
1220                           src2  = registerName register2 dst
1221                       in asmParThen [code1 asmVoid,code2 asmVoid] .
1222                          if isFixed register2 && src2 /= dst
1223                          then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
1224                                            ADD sz (OpAddr src1)  (OpReg dst)]
1225                          else
1226                                 mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
1227     in
1228         returnUs (Any IntRep code__2)
1229
1230 addCode sz [x, y] =
1231     getReg x                        `thenUs` \ register1 ->
1232     getReg y                        `thenUs` \ register2 ->
1233     getNewRegNCG IntRep             `thenUs` \ tmp1 ->
1234     getNewRegNCG IntRep             `thenUs` \ tmp2 ->
1235     let
1236         code1 = registerCode register1 tmp1 asmVoid
1237         src1  = registerName register1 tmp1
1238         code2 = registerCode register2 tmp2 asmVoid
1239         src2  = registerName register2 tmp2
1240         code__2 dst = asmParThen [code1, code2] .
1241                       mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
1242     in
1243         returnUs (Any IntRep code__2)
1244
1245 subCode
1246     :: Size
1247     -> [StixTree]
1248     -> UniqSM Register
1249 subCode sz [x, StInt y]
1250   = getReg x                        `thenUs` \ register ->
1251     getNewRegNCG IntRep             `thenUs` \ tmp ->
1252     let
1253         code = registerCode register tmp
1254         src1 = registerName register tmp
1255         src2 = ImmInt (-(fromInteger y))
1256         code__2 dst = code .
1257                       mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
1258     in
1259         returnUs (Any IntRep code__2)
1260
1261 subCode sz args = trivialCode (SUB sz) args False
1262
1263 divCode
1264     :: Size
1265     -> [StixTree]
1266     -> Bool -- True => division, False => remainder operation
1267     -> UniqSM Register
1268
1269 -- x must go into eax, edx must be a sign-extension of eax,
1270 -- and y should go in some other register (or memory),
1271 -- so that we get edx:eax / reg -> eax (remainder in edx)
1272 -- Currently we chose to put y in memory (if it is not there already)
1273 divCode sz [x, StInd pk mem] is_division
1274   = getReg x                        `thenUs` \ register1 ->
1275     getNewRegNCG IntRep             `thenUs` \ tmp1 ->
1276     getAmode mem                    `thenUs` \ amode ->
1277     let
1278         code1 = registerCode register1 tmp1 asmVoid
1279         src1 = registerName register1 tmp1
1280         code2 = amodeCode amode asmVoid
1281         src2  = amodeAddr amode
1282         code__2 = asmParThen [code1, code2] .
1283                   mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
1284                                CLTD,
1285                                IDIV sz (OpAddr src2)]
1286     in
1287         returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
1288
1289 divCode sz [x, StInt i] is_division
1290   = getReg x                        `thenUs` \ register1 ->
1291     getNewRegNCG IntRep             `thenUs` \ tmp1 ->
1292     let
1293         code1 = registerCode register1 tmp1 asmVoid
1294         src1 = registerName register1 tmp1
1295         src2 = ImmInt (fromInteger i)
1296         code__2 = asmParThen [code1] .
1297                   mkSeqInstrs [-- we put src2 in (ebx)
1298                                MOV L (OpImm src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
1299                                MOV L (OpReg src1) (OpReg eax),
1300                                CLTD,
1301                                IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
1302     in
1303         returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
1304
1305 divCode sz [x, y] is_division
1306   = getReg x                        `thenUs` \ register1 ->
1307     getNewRegNCG IntRep             `thenUs` \ tmp1 ->
1308     getReg y                        `thenUs` \ register2 ->
1309     getNewRegNCG IntRep             `thenUs` \ tmp2 ->
1310     let
1311         code1 = registerCode register1 tmp1 asmVoid
1312         src1 = registerName register1 tmp1
1313         code2 = registerCode register2 tmp2 asmVoid
1314         src2 = registerName register2 tmp2
1315         code__2 = asmParThen [code1, code2] .
1316                   if src2 == ecx || src2 == esi
1317                   then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
1318                                      CLTD,
1319                                      IDIV sz (OpReg src2)]
1320                   else mkSeqInstrs [ -- we put src2 in (ebx)
1321                                      MOV L (OpReg src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
1322                                      MOV L (OpReg src1) (OpReg eax),
1323                                      CLTD,
1324                                      IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
1325     in
1326         returnUs (Fixed (if is_division then eax else edx) IntRep code__2)
1327
1328 trivialFCode
1329     :: PrimRep
1330     -> (Size -> Operand -> I386Instr)
1331     -> (Size -> Operand -> I386Instr) -- reversed instr
1332     -> I386Instr -- pop
1333     -> I386Instr -- reversed instr, pop
1334     -> [StixTree]
1335     -> UniqSM Register
1336 trivialFCode pk _ instrr _ _ [StInd pk' mem, y]
1337   = getReg y                        `thenUs` \ register2 ->
1338     --getNewRegNCG (registerKind register2)
1339     --                                      `thenUs` \ tmp2 ->
1340     getAmode mem                    `thenUs` \ amode ->
1341     let
1342         code1 = amodeCode amode
1343         src1  = amodeAddr amode
1344
1345         code__2 dst = let
1346                           code2 = registerCode register2 dst
1347                           src2  = registerName register2 dst
1348                       in asmParThen [code1 asmVoid,code2 asmVoid] .
1349                          mkSeqInstrs [instrr (kindToSize pk) (OpAddr src1)]
1350     in
1351         returnUs (Any pk code__2)
1352
1353 trivialFCode pk instr _ _ _ [x, StInd pk' mem]
1354   = getReg x                        `thenUs` \ register1 ->
1355     --getNewRegNCG (registerKind register1)
1356     --                                      `thenUs` \ tmp1 ->
1357     getAmode mem                    `thenUs` \ amode ->
1358     let
1359         code2 = amodeCode amode
1360         src2  = amodeAddr amode
1361
1362         code__2 dst = let
1363                           code1 = registerCode register1 dst
1364                           src1  = registerName register1 dst
1365                       in asmParThen [code2 asmVoid,code1 asmVoid] .
1366                          mkSeqInstrs [instr (kindToSize pk) (OpAddr src2)]
1367     in
1368         returnUs (Any pk code__2)
1369
1370 trivialFCode pk _ _ _ instrpr [x, y] =
1371     getReg x                        `thenUs` \ register1 ->
1372     getReg y                        `thenUs` \ register2 ->
1373     --getNewRegNCG (registerKind register1)
1374     --                                      `thenUs` \ tmp1 ->
1375     --getNewRegNCG (registerKind register2)
1376     --                              `thenUs` \ tmp2 ->
1377     getNewRegNCG DoubleRep          `thenUs` \ tmp ->
1378     let
1379         pk1   = registerKind register1
1380         code1 = registerCode register1 st0 --tmp1
1381         src1  = registerName register1 st0 --tmp1
1382
1383         pk2   = registerKind register2
1384
1385         code__2 dst = let
1386                           code2 = registerCode register2 dst
1387                           src2  = registerName register2 dst
1388                       in asmParThen [code1 asmVoid, code2 asmVoid] .
1389                          mkSeqInstr instrpr
1390     in
1391         returnUs (Any pk1 code__2)
1392
1393 \end{code}
1394
1395 Trivial unary instructions.  Note that we don't have to worry about
1396 matching an StInt as the argument, because genericOpt will already
1397 have handled the constant-folding.
1398
1399 \begin{code}
1400
1401 trivialUCode
1402     :: (Operand -> I386Instr)
1403     -> [StixTree]
1404     -> UniqSM Register
1405
1406 trivialUCode instr [x] =
1407     getReg x                        `thenUs` \ register ->
1408 --    getNewRegNCG IntRep           `thenUs` \ tmp ->
1409     let
1410 --      fixedname = registerName register eax
1411         code__2 dst = let
1412                           code = registerCode register dst
1413                           src  = registerName register dst
1414                       in code . if isFixed register && dst /= src
1415                                 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
1416                                                   instr (OpReg dst)]
1417                                 else mkSeqInstr (instr (OpReg src))
1418     in
1419         returnUs (Any IntRep code__2)
1420
1421 trivialUFCode
1422     :: PrimRep
1423     -> I386Instr
1424     -> [StixTree]
1425     -> UniqSM Register
1426
1427 trivialUFCode pk instr [StInd pk' mem] =
1428     getAmode mem                    `thenUs` \ amode ->
1429     let
1430         code = amodeCode amode
1431         src  = amodeAddr amode
1432         code__2 dst = code . mkSeqInstrs [FLD (kindToSize pk) (OpAddr src),
1433                                           instr]
1434     in
1435         returnUs (Any pk code__2)
1436
1437 trivialUFCode pk instr [x] =
1438     getReg x                        `thenUs` \ register ->
1439     --getNewRegNCG pk               `thenUs` \ tmp ->
1440     let
1441         code__2 dst = let
1442                           code = registerCode register dst
1443                           src  = registerName register dst
1444                       in code . mkSeqInstrs [instr]
1445     in
1446         returnUs (Any pk code__2)
1447 \end{code}
1448
1449 Absolute value on integers, mostly for gmp size check macros.  Again,
1450 the argument cannot be an StInt, because genericOpt already folded
1451 constants.
1452
1453 \begin{code}
1454
1455 absIntCode :: [StixTree] -> UniqSM Register
1456 absIntCode [x] =
1457     getReg x                        `thenUs` \ register ->
1458     --getNewRegNCG IntRep           `thenUs` \ reg ->
1459     getUniqLabelNCG                 `thenUs` \ lbl ->
1460     let
1461         code__2 dst = let code = registerCode register dst
1462                           src  = registerName register dst
1463                       in code . if isFixed register && dst /= src
1464                                 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
1465                                                   TEST L (OpReg dst) (OpReg dst),
1466                                                   JXX GE lbl,
1467                                                   NEGI L (OpReg dst),
1468                                                   LABEL lbl]
1469                                 else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
1470                                                   JXX GE lbl,
1471                                                   NEGI L (OpReg src),
1472                                                   LABEL lbl]
1473     in
1474         returnUs (Any IntRep code__2)
1475
1476 \end{code}
1477
1478 Simple integer coercions that don't require any code to be generated.
1479 Here we just change the type on the register passed on up
1480
1481 \begin{code}
1482
1483 coerceIntCode :: PrimRep -> [StixTree] -> UniqSM Register
1484 coerceIntCode pk [x] =
1485     getReg x                        `thenUs` \ register ->
1486     case register of
1487         Fixed reg _ code -> returnUs (Fixed reg pk code)
1488         Any _ code       -> returnUs (Any pk code)
1489
1490 coerceFltCode :: [StixTree] -> UniqSM Register
1491 coerceFltCode [x] =
1492     getReg x                        `thenUs` \ register ->
1493     case register of
1494         Fixed reg _ code -> returnUs (Fixed reg DoubleRep code)
1495         Any _ code       -> returnUs (Any DoubleRep code)
1496
1497 \end{code}
1498
1499 Integer to character conversion.  We try to do this in one step if
1500 the original object is in memory.
1501
1502 \begin{code}
1503 chrCode :: [StixTree] -> UniqSM Register
1504 {-
1505 chrCode [StInd pk mem] =
1506     getAmode mem                    `thenUs` \ amode ->
1507     let
1508         code = amodeCode amode
1509         src  = amodeAddr amode
1510         code__2 dst = code . mkSeqInstr (MOVZX L (OpAddr src) (OpReg dst))
1511     in
1512         returnUs (Any pk code__2)
1513 -}
1514 chrCode [x] =
1515     getReg x                        `thenUs` \ register ->
1516     --getNewRegNCG IntRep           `thenUs` \ reg ->
1517     let
1518         fixedname = registerName register eax
1519         code__2 dst = let
1520                           code = registerCode register dst
1521                           src  = registerName register dst
1522                       in code .
1523                          if isFixed register && src /= dst
1524                          then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
1525                                            AND L (OpImm (ImmInt 255)) (OpReg dst)]
1526                          else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
1527     in
1528         returnUs (Any IntRep code__2)
1529
1530 \end{code}
1531
1532 More complicated integer/float conversions.  Here we have to store
1533 temporaries in memory to move between the integer and the floating
1534 point register sets.
1535
1536 \begin{code}
1537 coerceInt2FP :: PrimRep -> [StixTree] -> UniqSM Register
1538 coerceInt2FP pk [x] =
1539     getReg x                        `thenUs` \ register ->
1540     getNewRegNCG IntRep             `thenUs` \ reg ->
1541     let
1542         code = registerCode register reg
1543         src  = registerName register reg
1544
1545         code__2 dst = code . mkSeqInstrs [
1546         -- to fix: should spill instead of using R1
1547                       MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
1548                       FILD (kindToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
1549     in
1550         returnUs (Any pk code__2)
1551
1552 coerceFP2Int :: [StixTree] -> UniqSM Register
1553 coerceFP2Int [x] =
1554     getReg x                        `thenUs` \ register ->
1555     getNewRegNCG DoubleRep          `thenUs` \ tmp ->
1556     let
1557         code = registerCode register tmp
1558         src  = registerName register tmp
1559         pk   = registerKind register
1560
1561         code__2 dst = let
1562                       in code . mkSeqInstrs [
1563                                 FRNDINT,
1564                                 FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)),
1565                                 MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
1566     in
1567         returnUs (Any IntRep code__2)
1568 \end{code}
1569
1570 Some random little helpers.
1571
1572 \begin{code}
1573
1574 maybeImm :: StixTree -> Maybe Imm
1575 maybeImm (StInt i)
1576   | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
1577   | otherwise = Just (ImmInteger i)
1578 maybeImm (StLitLbl s)  = Just (ImmLit (uppBeside (uppChar '_') s))
1579 maybeImm (StLitLit s)  = Just (strImmLit (cvtLitLit (_UNPK_ s)))
1580 maybeImm (StCLbl l) = Just (ImmCLbl l)
1581 maybeImm _          = Nothing
1582
1583 mangleIndexTree :: StixTree -> StixTree
1584
1585 mangleIndexTree (StIndex pk base (StInt i)) =
1586     StPrim IntAddOp [base, off]
1587   where
1588     off = StInt (i * size pk)
1589     size :: PrimRep -> Integer
1590     size pk = case kindToSize pk of
1591         {B -> 1; S -> 2; L -> 4; F -> 4; D -> 8 }
1592
1593 mangleIndexTree (StIndex pk base off) =
1594     case pk of
1595         CharRep -> StPrim IntAddOp [base, off]
1596         _        -> StPrim IntAddOp [base, off__2]
1597   where
1598     off__2 = StPrim SllOp [off, StInt (shift pk)]
1599     shift :: PrimRep -> Integer
1600     shift DoubleRep     = 3
1601     shift _             = 2
1602
1603 cvtLitLit :: String -> String
1604 cvtLitLit "stdin"  = "_IO_stdin_"
1605 cvtLitLit "stdout" = "_IO_stdout_"
1606 cvtLitLit "stderr" = "_IO_stderr_"
1607 cvtLitLit s
1608   | isHex s = s
1609   | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
1610   where
1611     isHex ('0':'x':xs) = all isHexDigit xs
1612     isHex _ = False
1613     -- Now, where have I seen this before?
1614     isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'
1615
1616
1617 \end{code}
1618
1619 \begin{code}
1620
1621 stackArgLoc = 23 :: Int -- where to stack call arguments
1622
1623 \end{code}
1624
1625 \begin{code}
1626
1627 getNewRegNCG :: PrimRep -> UniqSM Reg
1628 getNewRegNCG pk =
1629       getUnique          `thenUs` \ u ->
1630       returnUs (mkReg u pk)
1631
1632 fixFPCond :: Cond -> Cond
1633 -- on the 486 the flags set by FP compare are the unsigned ones!
1634 fixFPCond GE  = GEU
1635 fixFPCond GT  = GU
1636 fixFPCond LT  = LU
1637 fixFPCond LE  = LEU
1638 fixFPCond any = any
1639 \end{code}