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