ghc/compiler/nativeGen/MachCode.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996
   3 %
   4 \section[MachCode]{Generating machine code}
   5
   6 This is a big module, but, if you pay attention to
   7 (a) the sectioning, (b) the type signatures, and
   8 (c) the \tr{#if blah_TARGET_ARCH} things, the
   9 structure should not be too overwhelming.
  10
  11 \begin{code}
  12 #include "HsVersions.h"
  13 #include "nativeGen/NCG.h"
  14
  15 module MachCode ( stmt2Instrs, asmVoid, SYN_IE(InstrList) ) where
  16
  17 IMP_Ubiq(){-uitious-}
  18
  19 import MachMisc         -- may differ per-platform
  20 import MachRegs
  21
  22 import AbsCSyn          ( MagicId )
  23 import AbsCUtils        ( magicIdPrimRep )
  24 import CLabel           ( isAsmTemp, CLabel )
  25 import Maybes           ( maybeToBool, expectJust )
  26 import OrdList          -- quite a bit of it
  27 import Outputable       ( PprStyle(..) )
  28 import Pretty           ( ptext, rational )
  29 import PrimRep          ( isFloatingRep, PrimRep(..) )
  30 import PrimOp           ( PrimOp(..), showPrimOp )
  31 import Stix             ( getUniqLabelNCG, StixTree(..),
  32                           StixReg(..), CodeSegment(..)
  33                         )
  34 import UniqSupply       ( returnUs, thenUs, mapUs, mapAndUnzipUs,
  35                           mapAccumLUs, SYN_IE(UniqSM)
  36                         )
  37 import Util             ( panic, assertPanic )
  38 \end{code}
  39
  40 Code extractor for an entire stix tree---stix statement level.
  41
  42 \begin{code}
  43 stmt2Instrs :: StixTree {- a stix statement -} -> UniqSM InstrBlock
  44
  45 stmt2Instrs stmt = case stmt of
  46     StComment s    -> returnInstr (COMMENT s)
  47     StSegment seg  -> returnInstr (SEGMENT seg)
  48     StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab))
  49     StFunEnd lab   -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id)
  50     StLabel lab    -> returnInstr (LABEL lab)
  51
  52     StJump arg             -> genJump arg
  53     StCondJump lab arg     -> genCondJump lab arg
  54     StCall fn VoidRep args -> genCCall fn VoidRep args
  55
  56     StAssign pk dst src
  57       | isFloatingRep pk -> assignFltCode pk dst src
  58       | otherwise        -> assignIntCode pk dst src
  59
  60     StFallThrough lbl
  61         -- When falling through on the Alpha, we still have to load pv
  62         -- with the address of the next routine, so that it can load gp.
  63       -> IF_ARCH_alpha(returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
  64         ,returnUs id)
  65
  66     StData kind args
  67       -> mapAndUnzipUs getData args     `thenUs` \ (codes, imms) ->
  68          returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms))
  69                                     (foldr1 (.) codes xs))
  70       where
  71         getData :: StixTree -> UniqSM (InstrBlock, Imm)
  72
  73         getData (StInt i)    = returnUs (id, ImmInteger i)
  74         getData (StDouble d) = returnUs (id, dblImmLit d)
  75         getData (StLitLbl s) = returnUs (id, ImmLab s)
  76         getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
  77         getData (StCLbl l)   = returnUs (id, ImmCLbl l)
  78         getData (StString s) =
  79             getUniqLabelNCG                 `thenUs` \ lbl ->
  80             returnUs (mkSeqInstrs [LABEL lbl,
  81                                    ASCII True (_UNPK_ s)],
  82                                    ImmCLbl lbl)
  83 \end{code}
  84
  85 %************************************************************************
  86 %*                                                                      *
  87 \subsection{General things for putting together code sequences}
  88 %*                                                                      *
  89 %************************************************************************
  90
  91 \begin{code}
  92 type InstrList  = OrdList Instr
  93 type InstrBlock = InstrList -> InstrList
  94
  95 asmVoid :: InstrList
  96 asmVoid = mkEmptyList
  97
  98 asmInstr :: Instr -> InstrList
  99 asmInstr i = mkUnitList i
 100
 101 asmSeq :: [Instr] -> InstrList
 102 asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
 103
 104 asmParThen :: [InstrList] -> InstrBlock
 105 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
 106
 107 returnInstr :: Instr -> UniqSM InstrBlock
 108 returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
 109
 110 returnInstrs :: [Instr] -> UniqSM InstrBlock
 111 returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
 112
 113 returnSeq :: InstrBlock -> [Instr] -> UniqSM InstrBlock
 114 returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
 115
 116 mkSeqInstr :: Instr -> InstrBlock
 117 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
 118
 119 mkSeqInstrs :: [Instr] -> InstrBlock
 120 mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
 121 \end{code}
 122
 123 \begin{code}
 124 mangleIndexTree :: StixTree -> StixTree
 125
 126 mangleIndexTree (StIndex pk base (StInt i))
 127   = StPrim IntAddOp [base, off]
 128   where
 129     off = StInt (i * sizeOf pk)
 130
 131 #ifndef i386_TARGET_ARCH
 132 mangleIndexTree (StIndex pk base off)
 133   = StPrim IntAddOp [base,
 134       case pk of
 135         CharRep -> off
 136         _       -> let
 137                         s = shift pk
 138                    in
 139                    ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
 140                    StPrim SllOp [off, StInt s]
 141     ]
 142   where
 143     shift DoubleRep     = 3::Integer
 144     shift _             = IF_ARCH_alpha(3,2)
 145 #else
 146 -- Hmm..this is an attempt at fixing Adress amodes (i.e., *[disp](base,index,<n>),
 147 -- that do include the size of the primitive kind we're addressing. When StIndex
 148 -- is expanded to actual code, the index (in units) is by the above code approp.
 149 -- shifted to get the no. of bytes. Since Address amodes do contain size info
 150 -- explicitly, we disable the shifting for x86s.
 151 mangleIndexTree (StIndex pk base off) = StPrim IntAddOp [base, off]
 152 #endif
 153
 154 \end{code}
 155
 156 \begin{code}
 157 maybeImm :: StixTree -> Maybe Imm
 158
 159 maybeImm (StLitLbl s) = Just (ImmLab s)
 160 maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
 161 maybeImm (StCLbl   l) = Just (ImmCLbl l)
 162
 163 maybeImm (StInt i)
 164   | i >= toInteger minInt && i <= toInteger maxInt
 165   = Just (ImmInt (fromInteger i))
 166   | otherwise
 167   = Just (ImmInteger i)
 168
 169 maybeImm _ = Nothing
 170 \end{code}
 171
 172 %************************************************************************
 173 %*                                                                      *
 174 \subsection{The @Register@ type}
 175 %*                                                                      *
 176 %************************************************************************
 177
 178 @Register@s passed up the tree.  If the stix code forces the register
 179 to live in a pre-decided machine register, it comes out as @Fixed@;
 180 otherwise, it comes out as @Any@, and the parent can decide which
 181 register to put it in.
 182
 183 \begin{code}
 184 data Register
 185   = Fixed   PrimRep Reg InstrBlock
 186   | Any     PrimRep (Reg -> InstrBlock)
 187
 188 registerCode :: Register -> Reg -> InstrBlock
 189 registerCode (Fixed _ _ code) reg = code
 190 registerCode (Any _ code) reg = code reg
 191
 192 registerName :: Register -> Reg -> Reg
 193 registerName (Fixed _ reg _) _ = reg
 194 registerName (Any   _ _)   reg = reg
 195
 196 registerRep :: Register -> PrimRep
 197 registerRep (Fixed pk _ _) = pk
 198 registerRep (Any   pk _) = pk
 199
 200 isFixed :: Register -> Bool
 201 isFixed (Fixed _ _ _) = True
 202 isFixed (Any _ _)     = False
 203 \end{code}
 204
 205 Generate code to get a subtree into a @Register@:
 206 \begin{code}
 207 getRegister :: StixTree -> UniqSM Register
 208
 209 getRegister (StReg (StixMagicId stgreg))
 210   = case (magicIdRegMaybe stgreg) of
 211       Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id)
 212       -- cannae be Nothing
 213
 214 getRegister (StReg (StixTemp u pk))
 215   = returnUs (Fixed pk (UnmappedReg u pk) id)
 216
 217 getRegister tree@(StIndex _ _ _) = getRegister (mangleIndexTree tree)
 218
 219 getRegister (StCall fn kind args)
 220   = genCCall fn kind args           `thenUs` \ call ->
 221     returnUs (Fixed kind reg call)
 222   where
 223     reg = if isFloatingRep kind
 224           then IF_ARCH_alpha( f0, IF_ARCH_i386( st0, IF_ARCH_sparc( f0,)))
 225           else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
 226
 227 getRegister (StString s)
 228   = getUniqLabelNCG                 `thenUs` \ lbl ->
 229     let
 230         imm_lbl = ImmCLbl lbl
 231
 232         code dst = mkSeqInstrs [
 233             SEGMENT DataSegment,
 234             LABEL lbl,
 235             ASCII True (_UNPK_ s),
 236             SEGMENT TextSegment,
 237 #if alpha_TARGET_ARCH
 238             LDA dst (AddrImm imm_lbl)
 239 #endif
 240 #if i386_TARGET_ARCH
 241             MOV L (OpImm imm_lbl) (OpReg dst)
 242 #endif
 243 #if sparc_TARGET_ARCH
 244             SETHI (HI imm_lbl) dst,
 245             OR False dst (RIImm (LO imm_lbl)) dst
 246 #endif
 247             ]
 248     in
 249     returnUs (Any PtrRep code)
 250
 251 getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"'
 252   = getUniqLabelNCG                 `thenUs` \ lbl ->
 253     let
 254         imm_lbl = ImmCLbl lbl
 255
 256         code dst = mkSeqInstrs [
 257             SEGMENT DataSegment,
 258             LABEL lbl,
 259             ASCII False (init xs),
 260             SEGMENT TextSegment,
 261 #if alpha_TARGET_ARCH
 262             LDA dst (AddrImm imm_lbl)
 263 #endif
 264 #if i386_TARGET_ARCH
 265             MOV L (OpImm imm_lbl) (OpReg dst)
 266 #endif
 267 #if sparc_TARGET_ARCH
 268             SETHI (HI imm_lbl) dst,
 269             OR False dst (RIImm (LO imm_lbl)) dst
 270 #endif
 271             ]
 272     in
 273     returnUs (Any PtrRep code)
 274   where
 275     xs = _UNPK_ (_TAIL_ s)
 276
 277 -- end of machine-"independent" bit; here we go on the rest...
 278
 279 #if alpha_TARGET_ARCH
 280
 281 getRegister (StDouble d)
 282   = getUniqLabelNCG                 `thenUs` \ lbl ->
 283     getNewRegNCG PtrRep             `thenUs` \ tmp ->
 284     let code dst = mkSeqInstrs [
 285             SEGMENT DataSegment,
 286             LABEL lbl,
 287             DATA TF [ImmLab (rational d)],
 288             SEGMENT TextSegment,
 289             LDA tmp (AddrImm (ImmCLbl lbl)),
 290             LD TF dst (AddrReg tmp)]
 291     in
 292         returnUs (Any DoubleRep code)
 293
 294 getRegister (StPrim primop [x]) -- unary PrimOps
 295   = case primop of
 296       IntNegOp -> trivialUCode (NEG Q False) x
 297       IntAbsOp -> trivialUCode (ABS Q) x
 298
 299       NotOp    -> trivialUCode NOT x
 300
 301       FloatNegOp  -> trivialUFCode FloatRep  (FNEG TF) x
 302       DoubleNegOp -> trivialUFCode DoubleRep (FNEG TF) x
 303
 304       OrdOp -> coerceIntCode IntRep x
 305       ChrOp -> chrCode x
 306
 307       Float2IntOp  -> coerceFP2Int    x
 308       Int2FloatOp  -> coerceInt2FP pr x
 309       Double2IntOp -> coerceFP2Int    x
 310       Int2DoubleOp -> coerceInt2FP pr x
 311
 312       Double2FloatOp -> coerceFltCode x
 313       Float2DoubleOp -> coerceFltCode x
 314
 315       other_op -> getRegister (StCall fn DoubleRep [x])
 316         where
 317           fn = case other_op of
 318                  FloatExpOp    -> SLIT("exp")
 319                  FloatLogOp    -> SLIT("log")
 320                  FloatSqrtOp   -> SLIT("sqrt")
 321                  FloatSinOp    -> SLIT("sin")
 322                  FloatCosOp    -> SLIT("cos")
 323                  FloatTanOp    -> SLIT("tan")
 324                  FloatAsinOp   -> SLIT("asin")
 325                  FloatAcosOp   -> SLIT("acos")
 326                  FloatAtanOp   -> SLIT("atan")
 327                  FloatSinhOp   -> SLIT("sinh")
 328                  FloatCoshOp   -> SLIT("cosh")
 329                  FloatTanhOp   -> SLIT("tanh")
 330                  DoubleExpOp   -> SLIT("exp")
 331                  DoubleLogOp   -> SLIT("log")
 332                  DoubleSqrtOp  -> SLIT("sqrt")
 333                  DoubleSinOp   -> SLIT("sin")
 334                  DoubleCosOp   -> SLIT("cos")
 335                  DoubleTanOp   -> SLIT("tan")
 336                  DoubleAsinOp  -> SLIT("asin")
 337                  DoubleAcosOp  -> SLIT("acos")
 338                  DoubleAtanOp  -> SLIT("atan")
 339                  DoubleSinhOp  -> SLIT("sinh")
 340                  DoubleCoshOp  -> SLIT("cosh")
 341                  DoubleTanhOp  -> SLIT("tanh")
 342   where
 343     pr = panic "MachCode.getRegister: no primrep needed for Alpha"
 344
 345 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
 346   = case primop of
 347       CharGtOp -> trivialCode (CMP LTT) y x
 348       CharGeOp -> trivialCode (CMP LE) y x
 349       CharEqOp -> trivialCode (CMP EQQ) x y
 350       CharNeOp -> int_NE_code x y
 351       CharLtOp -> trivialCode (CMP LTT) x y
 352       CharLeOp -> trivialCode (CMP LE) x y
 353
 354       IntGtOp  -> trivialCode (CMP LTT) y x
 355       IntGeOp  -> trivialCode (CMP LE) y x
 356       IntEqOp  -> trivialCode (CMP EQQ) x y
 357       IntNeOp  -> int_NE_code x y
 358       IntLtOp  -> trivialCode (CMP LTT) x y
 359       IntLeOp  -> trivialCode (CMP LE) x y
 360
 361       WordGtOp -> trivialCode (CMP ULT) y x
 362       WordGeOp -> trivialCode (CMP ULE) x y
 363       WordEqOp -> trivialCode (CMP EQQ)  x y
 364       WordNeOp -> int_NE_code x y
 365       WordLtOp -> trivialCode (CMP ULT) x y
 366       WordLeOp -> trivialCode (CMP ULE) x y
 367
 368       AddrGtOp -> trivialCode (CMP ULT) y x
 369       AddrGeOp -> trivialCode (CMP ULE) y x
 370       AddrEqOp -> trivialCode (CMP EQQ)  x y
 371       AddrNeOp -> int_NE_code x y
 372       AddrLtOp -> trivialCode (CMP ULT) x y
 373       AddrLeOp -> trivialCode (CMP ULE) x y
 374
 375       FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
 376       FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
 377       FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
 378       FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
 379       FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
 380       FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
 381
 382       DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
 383       DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
 384       DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
 385       DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
 386       DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
 387       DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
 388
 389       IntAddOp  -> trivialCode (ADD Q False) x y
 390       IntSubOp  -> trivialCode (SUB Q False) x y
 391       IntMulOp  -> trivialCode (MUL Q False) x y
 392       IntQuotOp -> trivialCode (DIV Q False) x y
 393       IntRemOp  -> trivialCode (REM Q False) x y
 394
 395       WordQuotOp -> trivialCode (DIV Q True) x y
 396       WordRemOp  -> trivialCode (REM Q True) x y
 397
 398       FloatAddOp -> trivialFCode  FloatRep (FADD TF) x y
 399       FloatSubOp -> trivialFCode  FloatRep (FSUB TF) x y
 400       FloatMulOp -> trivialFCode  FloatRep (FMUL TF) x y
 401       FloatDivOp -> trivialFCode  FloatRep (FDIV TF) x y
 402
 403       DoubleAddOp -> trivialFCode  DoubleRep (FADD TF) x y
 404       DoubleSubOp -> trivialFCode  DoubleRep (FSUB TF) x y
 405       DoubleMulOp -> trivialFCode  DoubleRep (FMUL TF) x y
 406       DoubleDivOp -> trivialFCode  DoubleRep (FDIV TF) x y
 407
 408       AndOp  -> trivialCode AND x y
 409       OrOp   -> trivialCode OR  x y
 410       XorOp  -> trivialCode XOR x y
 411       SllOp  -> trivialCode SLL x y
 412       SraOp  -> trivialCode SRA x y
 413       SrlOp  -> trivialCode SRL x y
 414
 415       ISllOp -> panic "AlphaGen:isll"
 416       ISraOp -> panic "AlphaGen:isra"
 417       ISrlOp -> panic "AlphaGen:isrl"
 418
 419       FloatPowerOp  -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
 420       DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x,y])
 421   where
 422     {- ------------------------------------------------------------
 423         Some bizarre special code for getting condition codes into
 424         registers.  Integer non-equality is a test for equality
 425         followed by an XOR with 1.  (Integer comparisons always set
 426         the result register to 0 or 1.)  Floating point comparisons of
 427         any kind leave the result in a floating point register, so we
 428         need to wrangle an integer register out of things.
 429     -}
 430     int_NE_code :: StixTree -> StixTree -> UniqSM Register
 431
 432     int_NE_code x y
 433       = trivialCode (CMP EQQ) x y       `thenUs` \ register ->
 434         getNewRegNCG IntRep             `thenUs` \ tmp ->
 435         let
 436             code = registerCode register tmp
 437             src  = registerName register tmp
 438             code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
 439         in
 440         returnUs (Any IntRep code__2)
 441
 442     {- ------------------------------------------------------------
 443         Comments for int_NE_code also apply to cmpF_code
 444     -}
 445     cmpF_code
 446         :: (Reg -> Reg -> Reg -> Instr)
 447         -> Cond
 448         -> StixTree -> StixTree
 449         -> UniqSM Register
 450
 451     cmpF_code instr cond x y
 452       = trivialFCode pr instr x y       `thenUs` \ register ->
 453         getNewRegNCG DoubleRep          `thenUs` \ tmp ->
 454         getUniqLabelNCG                 `thenUs` \ lbl ->
 455         let
 456             code = registerCode register tmp
 457             result  = registerName register tmp
 458
 459             code__2 dst = code . mkSeqInstrs [
 460                 OR zeroh (RIImm (ImmInt 1)) dst,
 461                 BF cond  result (ImmCLbl lbl),
 462                 OR zeroh (RIReg zeroh) dst,
 463                 LABEL lbl]
 464         in
 465         returnUs (Any IntRep code__2)
 466       where
 467         pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
 468       ------------------------------------------------------------
 469
 470 getRegister (StInd pk mem)
 471   = getAmode mem                    `thenUs` \ amode ->
 472     let
 473         code = amodeCode amode
 474         src   = amodeAddr amode
 475         size = primRepToSize pk
 476         code__2 dst = code . mkSeqInstr (LD size dst src)
 477     in
 478     returnUs (Any pk code__2)
 479
 480 getRegister (StInt i)
 481   | fits8Bits i
 482   = let
 483         code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
 484     in
 485     returnUs (Any IntRep code)
 486   | otherwise
 487   = let
 488         code dst = mkSeqInstr (LDI Q dst src)
 489     in
 490     returnUs (Any IntRep code)
 491   where
 492     src = ImmInt (fromInteger i)
 493
 494 getRegister leaf
 495   | maybeToBool imm
 496   = let
 497         code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
 498     in
 499     returnUs (Any PtrRep code)
 500   where
 501     imm = maybeImm leaf
 502     imm__2 = case imm of Just x -> x
 503
 504 #endif {- alpha_TARGET_ARCH -}
 505 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 506 #if i386_TARGET_ARCH
 507
 508 getRegister (StReg (StixTemp u pk)) = returnUs (Fixed pk (UnmappedReg u pk) id)
 509
 510 getRegister (StDouble 0.0)
 511   = let
 512         code dst = mkSeqInstrs [FLDZ]
 513     in
 514     returnUs (Any DoubleRep code)
 515
 516 getRegister (StDouble 1.0)
 517   = let
 518         code dst = mkSeqInstrs [FLD1]
 519     in
 520     returnUs (Any DoubleRep code)
 521
 522 getRegister (StDouble d)
 523   = getUniqLabelNCG                 `thenUs` \ lbl ->
 524     --getNewRegNCG PtrRep           `thenUs` \ tmp ->
 525     let code dst = mkSeqInstrs [
 526             SEGMENT DataSegment,
 527             LABEL lbl,
 528             DATA DF [dblImmLit d],
 529             SEGMENT TextSegment,
 530             FLD DF (OpImm (ImmCLbl lbl))
 531             ]
 532     in
 533     returnUs (Any DoubleRep code)
 534
 535 getRegister (StPrim primop [x]) -- unary PrimOps
 536   = case primop of
 537       IntNegOp  -> trivialUCode (NEGI L) x
 538       IntAbsOp  -> absIntCode x
 539
 540       NotOp     -> trivialUCode (NOT L) x
 541
 542       FloatNegOp  -> trivialUFCode FloatRep FCHS x
 543       FloatSqrtOp -> trivialUFCode FloatRep FSQRT x
 544       DoubleNegOp -> trivialUFCode DoubleRep FCHS x
 545
 546       DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x
 547
 548       OrdOp -> coerceIntCode IntRep x
 549       ChrOp -> chrCode x
 550
 551       Float2IntOp  -> coerceFP2Int x
 552       Int2FloatOp  -> coerceInt2FP FloatRep x
 553       Double2IntOp -> coerceFP2Int x
 554       Int2DoubleOp -> coerceInt2FP DoubleRep x
 555
 556       Double2FloatOp -> coerceFltCode x
 557       Float2DoubleOp -> coerceFltCode x
 558
 559       other_op ->
 560         let
 561             fixed_x = if is_float_op  -- promote to double
 562                           then StPrim Float2DoubleOp [x]
 563                           else x
 564         in
 565         getRegister (StCall fn DoubleRep [x])
 566        where
 567         (is_float_op, fn)
 568           = case primop of
 569               FloatExpOp    -> (True,  SLIT("exp"))
 570               FloatLogOp    -> (True,  SLIT("log"))
 571
 572               FloatSinOp    -> (True,  SLIT("sin"))
 573               FloatCosOp    -> (True,  SLIT("cos"))
 574               FloatTanOp    -> (True,  SLIT("tan"))
 575
 576               FloatAsinOp   -> (True,  SLIT("asin"))
 577               FloatAcosOp   -> (True,  SLIT("acos"))
 578               FloatAtanOp   -> (True,  SLIT("atan"))
 579
 580               FloatSinhOp   -> (True,  SLIT("sinh"))
 581               FloatCoshOp   -> (True,  SLIT("cosh"))
 582               FloatTanhOp   -> (True,  SLIT("tanh"))
 583
 584               DoubleExpOp   -> (False, SLIT("exp"))
 585               DoubleLogOp   -> (False, SLIT("log"))
 586
 587               DoubleSinOp   -> (False, SLIT("sin"))
 588               DoubleCosOp   -> (False, SLIT("cos"))
 589               DoubleTanOp   -> (False, SLIT("tan"))
 590
 591               DoubleAsinOp  -> (False, SLIT("asin"))
 592               DoubleAcosOp  -> (False, SLIT("acos"))
 593               DoubleAtanOp  -> (False, SLIT("atan"))
 594
 595               DoubleSinhOp  -> (False, SLIT("sinh"))
 596               DoubleCoshOp  -> (False, SLIT("cosh"))
 597               DoubleTanhOp  -> (False, SLIT("tanh"))
 598
 599 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
 600   = case primop of
 601       CharGtOp -> condIntReg GTT x y
 602       CharGeOp -> condIntReg GE x y
 603       CharEqOp -> condIntReg EQQ x y
 604       CharNeOp -> condIntReg NE x y
 605       CharLtOp -> condIntReg LTT x y
 606       CharLeOp -> condIntReg LE x y
 607
 608       IntGtOp  -> condIntReg GTT x y
 609       IntGeOp  -> condIntReg GE x y
 610       IntEqOp  -> condIntReg EQQ x y
 611       IntNeOp  -> condIntReg NE x y
 612       IntLtOp  -> condIntReg LTT x y
 613       IntLeOp  -> condIntReg LE x y
 614
 615       WordGtOp -> condIntReg GU  x y
 616       WordGeOp -> condIntReg GEU x y
 617       WordEqOp -> condIntReg EQQ  x y
 618       WordNeOp -> condIntReg NE  x y
 619       WordLtOp -> condIntReg LU  x y
 620       WordLeOp -> condIntReg LEU x y
 621
 622       AddrGtOp -> condIntReg GU  x y
 623       AddrGeOp -> condIntReg GEU x y
 624       AddrEqOp -> condIntReg EQQ  x y
 625       AddrNeOp -> condIntReg NE  x y
 626       AddrLtOp -> condIntReg LU  x y
 627       AddrLeOp -> condIntReg LEU x y
 628
 629       FloatGtOp -> condFltReg GTT x y
 630       FloatGeOp -> condFltReg GE x y
 631       FloatEqOp -> condFltReg EQQ x y
 632       FloatNeOp -> condFltReg NE x y
 633       FloatLtOp -> condFltReg LTT x y
 634       FloatLeOp -> condFltReg LE x y
 635
 636       DoubleGtOp -> condFltReg GTT x y
 637       DoubleGeOp -> condFltReg GE x y
 638       DoubleEqOp -> condFltReg EQQ x y
 639       DoubleNeOp -> condFltReg NE x y
 640       DoubleLtOp -> condFltReg LTT x y
 641       DoubleLeOp -> condFltReg LE x y
 642
 643       IntAddOp  -> {- ToDo: fix this, whatever it is (WDP 96/04)...
 644                    -- this should be optimised by the generic Opts,
 645                    -- I don't know why it is not (sometimes)!
 646                    case args of
 647                     [x, StInt 0] -> getRegister x
 648                     _ -> add_code L x y
 649                    -}
 650                    add_code  L x y
 651
 652       IntSubOp  -> sub_code  L x y
 653       IntQuotOp -> quot_code L x y True{-division-}
 654       IntRemOp  -> quot_code L x y False{-remainder-}
 655       IntMulOp  -> trivialCode (IMUL L) x y {-True-}
 656
 657       FloatAddOp -> trivialFCode  FloatRep  FADD FADD  FADDP FADDP  x y
 658       FloatSubOp -> trivialFCode  FloatRep  FSUB FSUBR FSUBP FSUBRP x y
 659       FloatMulOp -> trivialFCode  FloatRep  FMUL FMUL  FMULP FMULP  x y
 660       FloatDivOp -> trivialFCode  FloatRep  FDIV FDIVR FDIVP FDIVRP x y
 661
 662       DoubleAddOp -> trivialFCode DoubleRep FADD FADD  FADDP FADDP  x y
 663       DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y
 664       DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL  FMULP FMULP  x y
 665       DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y
 666
 667       AndOp -> trivialCode (AND L) x y {-True-}
 668       OrOp  -> trivialCode (OR L)  x y {-True-}
 669       XorOp -> trivialCode (XOR L) x y {-True-}
 670
 671         {- Shift ops on x86s have constraints on their source, it
 672            either has to be Imm, CL or 1
 673             => trivialCode's is not restrictive enough (sigh.)
 674         -}
 675
 676       SllOp -> shift_code (SHL L) x y {-False-}
 677       SraOp -> shift_code (SAR L) x y {-False-}
 678       SrlOp -> shift_code (SHR L) x y {-False-}
 679
 680       {- ToDo: nuke? -}
 681       ISllOp -> panic "I386Gen:isll"
 682       ISraOp -> panic "I386Gen:isra"
 683       ISrlOp -> panic "I386Gen:isrl"
 684
 685       FloatPowerOp  -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
 686                        where promote x = StPrim Float2DoubleOp [x]
 687       DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
 688   where
 689     shift_code :: (Operand -> Operand -> Instr)
 690                -> StixTree
 691                -> StixTree
 692                -> UniqSM Register
 693       {- Case1: shift length as immediate -}
 694       -- Code is the same as the first eq. for trivialCode -- sigh.
 695     shift_code instr x y{-amount-}
 696       | maybeToBool imm
 697       = getRegister x           `thenUs` \ register ->
 698         let
 699             op_imm = OpImm imm__2
 700             code__2 dst =
 701                 let
 702                  code  = registerCode  register dst
 703                  src   = registerName  register dst
 704                 in
 705                 mkSeqInstr (COMMENT SLIT("shift_code")) .
 706                 code .
 707                 if isFixed register && src /= dst
 708                 then
 709                    mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
 710                                 instr op_imm  (OpReg dst)]
 711                 else
 712                    mkSeqInstr (instr op_imm (OpReg src))
 713         in
 714         returnUs (Any IntRep code__2)
 715       where
 716        imm = maybeImm y
 717        imm__2 = case imm of Just x -> x
 718
 719       {- Case2: shift length is complex (non-immediate) -}
 720     shift_code instr x y{-amount-}
 721      = getRegister y            `thenUs` \ register1 ->
 722        getRegister x            `thenUs` \ register2 ->
 723 --       getNewRegNCG IntRep    `thenUs` \ dst ->
 724        let
 725         -- Note: we force the shift length to be loaded
 726         -- into ECX, so that we can use CL when shifting.
 727         -- (only register location we are allowed
 728         -- to put shift amounts.)
 729         --
 730         -- The shift instruction is fed ECX as src reg,
 731         -- but we coerce this into CL when printing out.
 732         src1    = registerName register1 ecx
 733         code1   = if src1 /= ecx then -- if it is not in ecx already, force it!
 734                     registerCode register1 ecx .
 735                     mkSeqInstr (MOV L (OpReg src1) (OpReg ecx))
 736                   else
 737                     registerCode register1 ecx
 738         code__2 =
 739                       let
 740                        code2 = registerCode register2 eax
 741                        src2  = registerName register2 eax
 742                       in
 743                       code1 . code2 .
 744                       mkSeqInstr (instr (OpReg ecx) (OpReg eax))
 745        in
 746        returnUs (Fixed IntRep eax code__2)
 747
 748     add_code :: Size -> StixTree -> StixTree -> UniqSM Register
 749
 750     add_code sz x (StInt y)
 751       = getRegister x           `thenUs` \ register ->
 752         getNewRegNCG IntRep     `thenUs` \ tmp ->
 753         let
 754             code = registerCode register tmp
 755             src1 = registerName register tmp
 756             src2 = ImmInt (fromInteger y)
 757             code__2 dst = code .
 758                           mkSeqInstr (LEA sz (OpAddr (Address (Just src1) Nothing src2)) (OpReg dst))
 759         in
 760         returnUs (Any IntRep code__2)
 761
 762     add_code sz x (StInd _ mem)
 763       = getRegister x           `thenUs` \ register1 ->
 764         --getNewRegNCG (registerRep register1)
 765         --                      `thenUs` \ tmp1 ->
 766         getAmode mem            `thenUs` \ amode ->
 767         let
 768             code2 = amodeCode amode
 769             src2  = amodeAddr amode
 770
 771 --          fixedname  = registerName register1 eax
 772             code__2 dst = let code1 = registerCode register1 dst
 773                               src1  = registerName register1 dst
 774                           in asmParThen [code2 asmVoid,code1 asmVoid] .
 775                              if isFixed register1 && src1 /= dst
 776                              then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
 777                                                ADD sz (OpAddr src2)  (OpReg dst)]
 778                              else
 779                                     mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
 780         in
 781         returnUs (Any IntRep code__2)
 782
 783     add_code sz (StInd _ mem) y
 784       = getRegister y           `thenUs` \ register2 ->
 785         --getNewRegNCG (registerRep register2)
 786         --                      `thenUs` \ tmp2 ->
 787         getAmode mem            `thenUs` \ amode ->
 788         let
 789             code1 = amodeCode amode
 790             src1  = amodeAddr amode
 791
 792 --          fixedname  = registerName register2 eax
 793             code__2 dst = let code2 = registerCode register2 dst
 794                               src2  = registerName register2 dst
 795                           in asmParThen [code1 asmVoid,code2 asmVoid] .
 796                              if isFixed register2 && src2 /= dst
 797                              then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
 798                                                ADD sz (OpAddr src1)  (OpReg dst)]
 799                              else
 800                                     mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
 801         in
 802         returnUs (Any IntRep code__2)
 803
 804     add_code sz x y
 805       = getRegister x           `thenUs` \ register1 ->
 806         getRegister y           `thenUs` \ register2 ->
 807         getNewRegNCG IntRep     `thenUs` \ tmp1 ->
 808         getNewRegNCG IntRep     `thenUs` \ tmp2 ->
 809         let
 810             code1 = registerCode register1 tmp1 asmVoid
 811             src1  = registerName register1 tmp1
 812             code2 = registerCode register2 tmp2 asmVoid
 813             src2  = registerName register2 tmp2
 814             code__2 dst = asmParThen [code1, code2] .
 815                           mkSeqInstr (LEA sz (OpAddr (Address (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
 816         in
 817         returnUs (Any IntRep code__2)
 818
 819     --------------------
 820     sub_code :: Size -> StixTree -> StixTree -> UniqSM Register
 821
 822     sub_code sz x (StInt y)
 823       = getRegister x           `thenUs` \ register ->
 824         getNewRegNCG IntRep     `thenUs` \ tmp ->
 825         let
 826             code = registerCode register tmp
 827             src1 = registerName register tmp
 828             src2 = ImmInt (-(fromInteger y))
 829             code__2 dst = code .
 830                           mkSeqInstr (LEA sz (OpAddr (Address (Just src1) Nothing src2)) (OpReg dst))
 831         in
 832         returnUs (Any IntRep code__2)
 833
 834     sub_code sz x y = trivialCode (SUB sz) x y {-False-}
 835
 836     --------------------
 837     quot_code
 838         :: Size
 839         -> StixTree -> StixTree
 840         -> Bool -- True => division, False => remainder operation
 841         -> UniqSM Register
 842
 843     -- x must go into eax, edx must be a sign-extension of eax, and y
 844     -- should go in some other register (or memory), so that we get
 845     -- edx:eax / reg -> eax (remainder in edx) Currently we chose to
 846     -- put y in memory (if it is not there already)
 847
 848     quot_code sz x (StInd pk mem) is_division
 849       = getRegister x           `thenUs` \ register1 ->
 850         getNewRegNCG IntRep     `thenUs` \ tmp1 ->
 851         getAmode mem            `thenUs` \ amode ->
 852         let
 853             code1   = registerCode register1 tmp1 asmVoid
 854             src1    = registerName register1 tmp1
 855             code2   = amodeCode amode asmVoid
 856             src2    = amodeAddr amode
 857             code__2 = asmParThen [code1, code2] .
 858                       mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
 859                                    CLTD,
 860                                    IDIV sz (OpAddr src2)]
 861         in
 862         returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
 863
 864     quot_code sz x (StInt i) is_division
 865       = getRegister x           `thenUs` \ register1 ->
 866         getNewRegNCG IntRep     `thenUs` \ tmp1 ->
 867         let
 868             code1   = registerCode register1 tmp1 asmVoid
 869             src1    = registerName register1 tmp1
 870             src2    = ImmInt (fromInteger i)
 871             code__2 = asmParThen [code1] .
 872                       mkSeqInstrs [-- we put src2 in (ebx)
 873                                    MOV L (OpImm src2) (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1))),
 874                                    MOV L (OpReg src1) (OpReg eax),
 875                                    CLTD,
 876                                    IDIV sz (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1)))]
 877         in
 878         returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
 879
 880     quot_code sz x y is_division
 881       = getRegister x           `thenUs` \ register1 ->
 882         getNewRegNCG IntRep     `thenUs` \ tmp1 ->
 883         getRegister y           `thenUs` \ register2 ->
 884         getNewRegNCG IntRep     `thenUs` \ tmp2 ->
 885         let
 886             code1   = registerCode register1 tmp1 asmVoid
 887             src1    = registerName register1 tmp1
 888             code2   = registerCode register2 tmp2 asmVoid
 889             src2    = registerName register2 tmp2
 890             code__2 = asmParThen [code1, code2] .
 891                       if src2 == ecx || src2 == esi
 892                       then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
 893                                          CLTD,
 894                                          IDIV sz (OpReg src2)]
 895                       else mkSeqInstrs [ -- we put src2 in (ebx)
 896                                          MOV L (OpReg src2) (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1))),
 897                                          MOV L (OpReg src1) (OpReg eax),
 898                                          CLTD,
 899                                          IDIV sz (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1)))]
 900         in
 901         returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
 902         -----------------------
 903
 904 getRegister (StInd pk mem)
 905   = getAmode mem                    `thenUs` \ amode ->
 906     let
 907         code = amodeCode amode
 908         src   = amodeAddr amode
 909         size = primRepToSize pk
 910         code__2 dst = code .
 911                       if pk == DoubleRep || pk == FloatRep
 912                       then mkSeqInstr (FLD {-DF-} size (OpAddr src))
 913                       else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
 914     in
 915         returnUs (Any pk code__2)
 916
 917
 918 getRegister (StInt i)
 919   = let
 920         src = ImmInt (fromInteger i)
 921         code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
 922     in
 923         returnUs (Any IntRep code)
 924
 925 getRegister leaf
 926   | maybeToBool imm
 927   = let
 928         code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
 929     in
 930         returnUs (Any PtrRep code)
 931   where
 932     imm = maybeImm leaf
 933     imm__2 = case imm of Just x -> x
 934
 935 #endif {- i386_TARGET_ARCH -}
 936 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 937 #if sparc_TARGET_ARCH
 938
 939 getRegister (StDouble d)
 940   = getUniqLabelNCG                 `thenUs` \ lbl ->
 941     getNewRegNCG PtrRep             `thenUs` \ tmp ->
 942     let code dst = mkSeqInstrs [
 943             SEGMENT DataSegment,
 944             LABEL lbl,
 945             DATA DF [dblImmLit d],
 946             SEGMENT TextSegment,
 947             SETHI (HI (ImmCLbl lbl)) tmp,
 948             LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
 949     in
 950         returnUs (Any DoubleRep code)
 951
 952 getRegister (StPrim primop [x]) -- unary PrimOps
 953   = case primop of
 954       IntNegOp -> trivialUCode (SUB False False g0) x
 955       IntAbsOp -> absIntCode x
 956       NotOp    -> trivialUCode (XNOR False g0) x
 957
 958       FloatNegOp  -> trivialUFCode FloatRep (FNEG F) x
 959
 960       DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
 961
 962       Double2FloatOp -> trivialUFCode FloatRep  (FxTOy DF F) x
 963       Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
 964
 965       OrdOp -> coerceIntCode IntRep x
 966       ChrOp -> chrCode x
 967
 968       Float2IntOp  -> coerceFP2Int x
 969       Int2FloatOp  -> coerceInt2FP FloatRep x
 970       Double2IntOp -> coerceFP2Int x
 971       Int2DoubleOp -> coerceInt2FP DoubleRep x
 972
 973       other_op ->
 974         let
 975             fixed_x = if is_float_op  -- promote to double
 976                           then StPrim Float2DoubleOp [x]
 977                           else x
 978         in
 979         getRegister (StCall fn DoubleRep [x])
 980        where
 981         (is_float_op, fn)
 982           = case primop of
 983               FloatExpOp    -> (True,  SLIT("exp"))
 984               FloatLogOp    -> (True,  SLIT("log"))
 985               FloatSqrtOp   -> (True,  SLIT("sqrt"))
 986
 987               FloatSinOp    -> (True,  SLIT("sin"))
 988               FloatCosOp    -> (True,  SLIT("cos"))
 989               FloatTanOp    -> (True,  SLIT("tan"))
 990
 991               FloatAsinOp   -> (True,  SLIT("asin"))
 992               FloatAcosOp   -> (True,  SLIT("acos"))
 993               FloatAtanOp   -> (True,  SLIT("atan"))
 994
 995               FloatSinhOp   -> (True,  SLIT("sinh"))
 996               FloatCoshOp   -> (True,  SLIT("cosh"))
 997               FloatTanhOp   -> (True,  SLIT("tanh"))
 998
 999               DoubleExpOp   -> (False, SLIT("exp"))
1000               DoubleLogOp   -> (False, SLIT("log"))
1001               DoubleSqrtOp  -> (True,  SLIT("sqrt"))
1002
1003               DoubleSinOp   -> (False, SLIT("sin"))
1004               DoubleCosOp   -> (False, SLIT("cos"))
1005               DoubleTanOp   -> (False, SLIT("tan"))
1006
1007               DoubleAsinOp  -> (False, SLIT("asin"))
1008               DoubleAcosOp  -> (False, SLIT("acos"))
1009               DoubleAtanOp  -> (False, SLIT("atan"))
1010
1011               DoubleSinhOp  -> (False, SLIT("sinh"))
1012               DoubleCoshOp  -> (False, SLIT("cosh"))
1013               DoubleTanhOp  -> (False, SLIT("tanh"))
1014               _             -> panic ("Monadic PrimOp not handled: " ++ showPrimOp PprDebug primop)
1015
1016 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
1017   = case primop of
1018       CharGtOp -> condIntReg GTT x y
1019       CharGeOp -> condIntReg GE x y
1020       CharEqOp -> condIntReg EQQ x y
1021       CharNeOp -> condIntReg NE x y
1022       CharLtOp -> condIntReg LTT x y
1023       CharLeOp -> condIntReg LE x y
1024
1025       IntGtOp  -> condIntReg GTT x y
1026       IntGeOp  -> condIntReg GE x y
1027       IntEqOp  -> condIntReg EQQ x y
1028       IntNeOp  -> condIntReg NE x y
1029       IntLtOp  -> condIntReg LTT x y
1030       IntLeOp  -> condIntReg LE x y
1031
1032       WordGtOp -> condIntReg GU  x y
1033       WordGeOp -> condIntReg GEU x y
1034       WordEqOp -> condIntReg EQQ  x y
1035       WordNeOp -> condIntReg NE  x y
1036       WordLtOp -> condIntReg LU  x y
1037       WordLeOp -> condIntReg LEU x y
1038
1039       AddrGtOp -> condIntReg GU  x y
1040       AddrGeOp -> condIntReg GEU x y
1041       AddrEqOp -> condIntReg EQQ  x y
1042       AddrNeOp -> condIntReg NE  x y
1043       AddrLtOp -> condIntReg LU  x y
1044       AddrLeOp -> condIntReg LEU x y
1045
1046       FloatGtOp -> condFltReg GTT x y
1047       FloatGeOp -> condFltReg GE x y
1048       FloatEqOp -> condFltReg EQQ x y
1049       FloatNeOp -> condFltReg NE x y
1050       FloatLtOp -> condFltReg LTT x y
1051       FloatLeOp -> condFltReg LE x y
1052
1053       DoubleGtOp -> condFltReg GTT x y
1054       DoubleGeOp -> condFltReg GE x y
1055       DoubleEqOp -> condFltReg EQQ x y
1056       DoubleNeOp -> condFltReg NE x y
1057       DoubleLtOp -> condFltReg LTT x y
1058       DoubleLeOp -> condFltReg LE x y
1059
1060       IntAddOp -> trivialCode (ADD False False) x y
1061       IntSubOp -> trivialCode (SUB False False) x y
1062
1063         -- ToDo: teach about V8+ SPARC mul/div instructions
1064       IntMulOp    -> imul_div SLIT(".umul") x y
1065       IntQuotOp   -> imul_div SLIT(".div")  x y
1066       IntRemOp    -> imul_div SLIT(".rem")  x y
1067
1068       FloatAddOp  -> trivialFCode FloatRep  FADD x y
1069       FloatSubOp  -> trivialFCode FloatRep  FSUB x y
1070       FloatMulOp  -> trivialFCode FloatRep  FMUL x y
1071       FloatDivOp  -> trivialFCode FloatRep  FDIV x y
1072
1073       DoubleAddOp -> trivialFCode DoubleRep FADD x y
1074       DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1075       DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1076       DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1077
1078       AndOp -> trivialCode (AND False) x y
1079       OrOp  -> trivialCode (OR  False) x y
1080       XorOp -> trivialCode (XOR False) x y
1081       SllOp -> trivialCode SLL x y
1082       SraOp -> trivialCode SRA x y
1083       SrlOp -> trivialCode SRL x y
1084
1085       ISllOp -> panic "SparcGen:isll"
1086       ISraOp -> panic "SparcGen:isra"
1087       ISrlOp -> panic "SparcGen:isrl"
1088
1089       FloatPowerOp  -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y])
1090                        where promote x = StPrim Float2DoubleOp [x]
1091       DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y])
1092   where
1093     imul_div fn x y = getRegister (StCall fn IntRep [x, y])
1094
1095 getRegister (StInd pk mem)
1096   = getAmode mem                    `thenUs` \ amode ->
1097     let
1098         code = amodeCode amode
1099         src   = amodeAddr amode
1100         size = primRepToSize pk
1101         code__2 dst = code . mkSeqInstr (LD size src dst)
1102     in
1103         returnUs (Any pk code__2)
1104
1105 getRegister (StInt i)
1106   | fits13Bits i
1107   = let
1108         src = ImmInt (fromInteger i)
1109         code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
1110     in
1111         returnUs (Any IntRep code)
1112
1113 getRegister leaf
1114   | maybeToBool imm
1115   = let
1116         code dst = mkSeqInstrs [
1117             SETHI (HI imm__2) dst,
1118             OR False dst (RIImm (LO imm__2)) dst]
1119     in
1120         returnUs (Any PtrRep code)
1121   where
1122     imm = maybeImm leaf
1123     imm__2 = case imm of Just x -> x
1124
1125 #endif {- sparc_TARGET_ARCH -}
1126 \end{code}
1127
1128 %************************************************************************
1129 %*                                                                      *
1130 \subsection{The @Amode@ type}
1131 %*                                                                      *
1132 %************************************************************************
1133
1134 @Amode@s: Memory addressing modes passed up the tree.
1135 \begin{code}
1136 data Amode = Amode Address InstrBlock
1137
1138 amodeAddr (Amode addr _) = addr
1139 amodeCode (Amode _ code) = code
1140 \end{code}
1141
1142 Now, given a tree (the argument to an StInd) that references memory,
1143 produce a suitable addressing mode.
1144
1145 \begin{code}
1146 getAmode :: StixTree -> UniqSM Amode
1147
1148 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1149
1150 #if alpha_TARGET_ARCH
1151
1152 getAmode (StPrim IntSubOp [x, StInt i])
1153   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1154     getRegister x               `thenUs` \ register ->
1155     let
1156         code = registerCode register tmp
1157         reg  = registerName register tmp
1158         off  = ImmInt (-(fromInteger i))
1159     in
1160     returnUs (Amode (AddrRegImm reg off) code)
1161
1162 getAmode (StPrim IntAddOp [x, StInt i])
1163   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1164     getRegister x               `thenUs` \ register ->
1165     let
1166         code = registerCode register tmp
1167         reg  = registerName register tmp
1168         off  = ImmInt (fromInteger i)
1169     in
1170     returnUs (Amode (AddrRegImm reg off) code)
1171
1172 getAmode leaf
1173   | maybeToBool imm
1174   = returnUs (Amode (AddrImm imm__2) id)
1175   where
1176     imm = maybeImm leaf
1177     imm__2 = case imm of Just x -> x
1178
1179 getAmode other
1180   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1181     getRegister other           `thenUs` \ register ->
1182     let
1183         code = registerCode register tmp
1184         reg  = registerName register tmp
1185     in
1186     returnUs (Amode (AddrReg reg) code)
1187
1188 #endif {- alpha_TARGET_ARCH -}
1189 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1190 #if i386_TARGET_ARCH
1191
1192 getAmode (StPrim IntSubOp [x, StInt i])
1193   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1194     getRegister x               `thenUs` \ register ->
1195     let
1196         code = registerCode register tmp
1197         reg  = registerName register tmp
1198         off  = ImmInt (-(fromInteger i))
1199     in
1200     returnUs (Amode (Address (Just reg) Nothing off) code)
1201
1202 getAmode (StPrim IntAddOp [x, StInt i])
1203   | maybeToBool imm
1204   = let
1205         code = mkSeqInstrs []
1206     in
1207     returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
1208   where
1209     imm    = maybeImm x
1210     imm__2 = case imm of Just x -> x
1211
1212 getAmode (StPrim IntAddOp [x, StInt i])
1213   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1214     getRegister x               `thenUs` \ register ->
1215     let
1216         code = registerCode register tmp
1217         reg  = registerName register tmp
1218         off  = ImmInt (fromInteger i)
1219     in
1220     returnUs (Amode (Address (Just reg) Nothing off) code)
1221
1222 getAmode (StPrim IntAddOp [x, y])
1223   = getNewRegNCG PtrRep         `thenUs` \ tmp1 ->
1224     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1225     getRegister x               `thenUs` \ register1 ->
1226     getRegister y               `thenUs` \ register2 ->
1227     let
1228         code1 = registerCode register1 tmp1 asmVoid
1229         reg1  = registerName register1 tmp1
1230         code2 = registerCode register2 tmp2 asmVoid
1231         reg2  = registerName register2 tmp2
1232         code__2 = asmParThen [code1, code2]
1233     in
1234     returnUs (Amode (Address (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
1235
1236 getAmode leaf
1237   | maybeToBool imm
1238   = let
1239         code = mkSeqInstrs []
1240     in
1241     returnUs (Amode (ImmAddr imm__2 0) code)
1242   where
1243     imm    = maybeImm leaf
1244     imm__2 = case imm of Just x -> x
1245
1246 getAmode other
1247   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1248     getRegister other           `thenUs` \ register ->
1249     let
1250         code = registerCode register tmp
1251         reg  = registerName register tmp
1252         off  = Nothing
1253     in
1254     returnUs (Amode (Address (Just reg) Nothing (ImmInt 0)) code)
1255
1256 #endif {- i386_TARGET_ARCH -}
1257 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1258 #if sparc_TARGET_ARCH
1259
1260 getAmode (StPrim IntSubOp [x, StInt i])
1261   | fits13Bits (-i)
1262   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1263     getRegister x               `thenUs` \ register ->
1264     let
1265         code = registerCode register tmp
1266         reg  = registerName register tmp
1267         off  = ImmInt (-(fromInteger i))
1268     in
1269     returnUs (Amode (AddrRegImm reg off) code)
1270
1271
1272 getAmode (StPrim IntAddOp [x, StInt i])
1273   | fits13Bits i
1274   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1275     getRegister x               `thenUs` \ register ->
1276     let
1277         code = registerCode register tmp
1278         reg  = registerName register tmp
1279         off  = ImmInt (fromInteger i)
1280     in
1281     returnUs (Amode (AddrRegImm reg off) code)
1282
1283 getAmode (StPrim IntAddOp [x, y])
1284   = getNewRegNCG PtrRep         `thenUs` \ tmp1 ->
1285     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1286     getRegister x               `thenUs` \ register1 ->
1287     getRegister y               `thenUs` \ register2 ->
1288     let
1289         code1 = registerCode register1 tmp1 asmVoid
1290         reg1  = registerName register1 tmp1
1291         code2 = registerCode register2 tmp2 asmVoid
1292         reg2  = registerName register2 tmp2
1293         code__2 = asmParThen [code1, code2]
1294     in
1295     returnUs (Amode (AddrRegReg reg1 reg2) code__2)
1296
1297 getAmode leaf
1298   | maybeToBool imm
1299   = getNewRegNCG PtrRep             `thenUs` \ tmp ->
1300     let
1301         code = mkSeqInstr (SETHI (HI imm__2) tmp)
1302     in
1303     returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
1304   where
1305     imm    = maybeImm leaf
1306     imm__2 = case imm of Just x -> x
1307
1308 getAmode other
1309   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1310     getRegister other           `thenUs` \ register ->
1311     let
1312         code = registerCode register tmp
1313         reg  = registerName register tmp
1314         off  = ImmInt 0
1315     in
1316     returnUs (Amode (AddrRegImm reg off) code)
1317
1318 #endif {- sparc_TARGET_ARCH -}
1319 \end{code}
1320
1321 %************************************************************************
1322 %*                                                                      *
1323 \subsection{The @CondCode@ type}
1324 %*                                                                      *
1325 %************************************************************************
1326
1327 Condition codes passed up the tree.
1328 \begin{code}
1329 data CondCode = CondCode Bool Cond InstrBlock
1330
1331 condName  (CondCode _ cond _)      = cond
1332 condFloat (CondCode is_float _ _) = is_float
1333 condCode  (CondCode _ _ code)      = code
1334 \end{code}
1335
1336 Set up a condition code for a conditional branch.
1337
1338 \begin{code}
1339 getCondCode :: StixTree -> UniqSM CondCode
1340
1341 #if alpha_TARGET_ARCH
1342 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1343 #endif {- alpha_TARGET_ARCH -}
1344 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1345
1346 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1347 -- yes, they really do seem to want exactly the same!
1348
1349 getCondCode (StPrim primop [x, y])
1350   = case primop of
1351       CharGtOp -> condIntCode GTT  x y
1352       CharGeOp -> condIntCode GE  x y
1353       CharEqOp -> condIntCode EQQ  x y
1354       CharNeOp -> condIntCode NE  x y
1355       CharLtOp -> condIntCode LTT  x y
1356       CharLeOp -> condIntCode LE  x y
1357
1358       IntGtOp  -> condIntCode GTT  x y
1359       IntGeOp  -> condIntCode GE  x y
1360       IntEqOp  -> condIntCode EQQ  x y
1361       IntNeOp  -> condIntCode NE  x y
1362       IntLtOp  -> condIntCode LTT  x y
1363       IntLeOp  -> condIntCode LE  x y
1364
1365       WordGtOp -> condIntCode GU  x y
1366       WordGeOp -> condIntCode GEU x y
1367       WordEqOp -> condIntCode EQQ  x y
1368       WordNeOp -> condIntCode NE  x y
1369       WordLtOp -> condIntCode LU  x y
1370       WordLeOp -> condIntCode LEU x y
1371
1372       AddrGtOp -> condIntCode GU  x y
1373       AddrGeOp -> condIntCode GEU x y
1374       AddrEqOp -> condIntCode EQQ  x y
1375       AddrNeOp -> condIntCode NE  x y
1376       AddrLtOp -> condIntCode LU  x y
1377       AddrLeOp -> condIntCode LEU x y
1378
1379       FloatGtOp -> condFltCode GTT x y
1380       FloatGeOp -> condFltCode GE x y
1381       FloatEqOp -> condFltCode EQQ x y
1382       FloatNeOp -> condFltCode NE x y
1383       FloatLtOp -> condFltCode LTT x y
1384       FloatLeOp -> condFltCode LE x y
1385
1386       DoubleGtOp -> condFltCode GTT x y
1387       DoubleGeOp -> condFltCode GE x y
1388       DoubleEqOp -> condFltCode EQQ x y
1389       DoubleNeOp -> condFltCode NE x y
1390       DoubleLtOp -> condFltCode LTT x y
1391       DoubleLeOp -> condFltCode LE x y
1392
1393 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1394 \end{code}
1395
1396 % -----------------
1397
1398 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1399 passed back up the tree.
1400
1401 \begin{code}
1402 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode
1403
1404 #if alpha_TARGET_ARCH
1405 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1406 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1407 #endif {- alpha_TARGET_ARCH -}
1408
1409 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1410 #if i386_TARGET_ARCH
1411
1412 condIntCode cond (StInd _ x) y
1413   | maybeToBool imm
1414   = getAmode x                  `thenUs` \ amode ->
1415     let
1416         code1 = amodeCode amode asmVoid
1417         y__2  = amodeAddr amode
1418         code__2 = asmParThen [code1] .
1419                   mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
1420     in
1421     returnUs (CondCode False cond code__2)
1422   where
1423     imm    = maybeImm y
1424     imm__2 = case imm of Just x -> x
1425
1426 condIntCode cond x (StInt 0)
1427   = getRegister x               `thenUs` \ register1 ->
1428     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
1429     let
1430         code1 = registerCode register1 tmp1 asmVoid
1431         src1  = registerName register1 tmp1
1432         code__2 = asmParThen [code1] .
1433                 mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
1434     in
1435     returnUs (CondCode False cond code__2)
1436
1437 condIntCode cond x y
1438   | maybeToBool imm
1439   = getRegister x               `thenUs` \ register1 ->
1440     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
1441     let
1442         code1 = registerCode register1 tmp1 asmVoid
1443         src1  = registerName register1 tmp1
1444         code__2 = asmParThen [code1] .
1445                 mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
1446     in
1447     returnUs (CondCode False cond code__2)
1448   where
1449     imm    = maybeImm y
1450     imm__2 = case imm of Just x -> x
1451
1452 condIntCode cond (StInd _ x) y
1453   = getAmode x                  `thenUs` \ amode ->
1454     getRegister y               `thenUs` \ register2 ->
1455     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1456     let
1457         code1 = amodeCode amode asmVoid
1458         src1  = amodeAddr amode
1459         code2 = registerCode register2 tmp2 asmVoid
1460         src2  = registerName register2 tmp2
1461         code__2 = asmParThen [code1, code2] .
1462                   mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
1463     in
1464     returnUs (CondCode False cond code__2)
1465
1466 condIntCode cond y (StInd _ x)
1467   = getAmode x                  `thenUs` \ amode ->
1468     getRegister y               `thenUs` \ register2 ->
1469     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1470     let
1471         code1 = amodeCode amode asmVoid
1472         src1  = amodeAddr amode
1473         code2 = registerCode register2 tmp2 asmVoid
1474         src2  = registerName register2 tmp2
1475         code__2 = asmParThen [code1, code2] .
1476                   mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
1477     in
1478     returnUs (CondCode False cond code__2)
1479
1480 condIntCode cond x y
1481   = getRegister x               `thenUs` \ register1 ->
1482     getRegister y               `thenUs` \ register2 ->
1483     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
1484     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1485     let
1486         code1 = registerCode register1 tmp1 asmVoid
1487         src1  = registerName register1 tmp1
1488         code2 = registerCode register2 tmp2 asmVoid
1489         src2  = registerName register2 tmp2
1490         code__2 = asmParThen [code1, code2] .
1491                 mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
1492     in
1493     returnUs (CondCode False cond code__2)
1494
1495 -----------
1496
1497 condFltCode cond x (StDouble 0.0)
1498   = getRegister x               `thenUs` \ register1 ->
1499     getNewRegNCG (registerRep register1)
1500                                 `thenUs` \ tmp1 ->
1501     let
1502         pk1   = registerRep register1
1503         code1 = registerCode register1 tmp1
1504         src1  = registerName register1 tmp1
1505
1506         code__2 = asmParThen [code1 asmVoid] .
1507                   mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ?
1508                                FNSTSW,
1509                                --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1510                                --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1511                                SAHF
1512                               ]
1513     in
1514     returnUs (CondCode True (fix_FP_cond cond) code__2)
1515
1516 condFltCode cond x y
1517   = getRegister x               `thenUs` \ register1 ->
1518     getRegister y               `thenUs` \ register2 ->
1519     getNewRegNCG (registerRep register1)
1520                                 `thenUs` \ tmp1 ->
1521     getNewRegNCG (registerRep register2)
1522                                 `thenUs` \ tmp2 ->
1523     let
1524         pk1   = registerRep register1
1525         code1 = registerCode register1 tmp1
1526         src1  = registerName register1 tmp1
1527
1528         code2 = registerCode register2 tmp2
1529         src2  = registerName register2 tmp2
1530
1531         code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
1532                   mkSeqInstrs [FUCOMPP,
1533                                FNSTSW,
1534                                --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1535                                --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1536                                SAHF
1537                               ]
1538     in
1539     returnUs (CondCode True (fix_FP_cond cond) code__2)
1540
1541 {- On the 486, the flags set by FP compare are the unsigned ones!
1542    (This looks like a HACK to me.  WDP 96/03)
1543 -}
1544
1545 fix_FP_cond :: Cond -> Cond
1546
1547 fix_FP_cond GE  = GEU
1548 fix_FP_cond GTT  = GU
1549 fix_FP_cond LTT  = LU
1550 fix_FP_cond LE  = LEU
1551 fix_FP_cond any = any
1552
1553 #endif {- i386_TARGET_ARCH -}
1554 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1555 #if sparc_TARGET_ARCH
1556
1557 condIntCode cond x (StInt y)
1558   | fits13Bits y
1559   = getRegister x               `thenUs` \ register ->
1560     getNewRegNCG IntRep         `thenUs` \ tmp ->
1561     let
1562         code = registerCode register tmp
1563         src1 = registerName register tmp
1564         src2 = ImmInt (fromInteger y)
1565         code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
1566     in
1567     returnUs (CondCode False cond code__2)
1568
1569 condIntCode cond x y
1570   = getRegister x               `thenUs` \ register1 ->
1571     getRegister y               `thenUs` \ register2 ->
1572     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
1573     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1574     let
1575         code1 = registerCode register1 tmp1 asmVoid
1576         src1  = registerName register1 tmp1
1577         code2 = registerCode register2 tmp2 asmVoid
1578         src2  = registerName register2 tmp2
1579         code__2 = asmParThen [code1, code2] .
1580                 mkSeqInstr (SUB False True src1 (RIReg src2) g0)
1581     in
1582     returnUs (CondCode False cond code__2)
1583
1584 -----------
1585 condFltCode cond x y
1586   = getRegister x               `thenUs` \ register1 ->
1587     getRegister y               `thenUs` \ register2 ->
1588     getNewRegNCG (registerRep register1)
1589                                 `thenUs` \ tmp1 ->
1590     getNewRegNCG (registerRep register2)
1591                                 `thenUs` \ tmp2 ->
1592     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
1593     let
1594         promote x = asmInstr (FxTOy F DF x tmp)
1595
1596         pk1   = registerRep register1
1597         code1 = registerCode register1 tmp1
1598         src1  = registerName register1 tmp1
1599
1600         pk2   = registerRep register2
1601         code2 = registerCode register2 tmp2
1602         src2  = registerName register2 tmp2
1603
1604         code__2 =
1605                 if pk1 == pk2 then
1606                     asmParThen [code1 asmVoid, code2 asmVoid] .
1607                     mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
1608                 else if pk1 == FloatRep then
1609                     asmParThen [code1 (promote src1), code2 asmVoid] .
1610                     mkSeqInstr (FCMP True DF tmp src2)
1611                 else
1612                     asmParThen [code1 asmVoid, code2 (promote src2)] .
1613                     mkSeqInstr (FCMP True DF src1 tmp)
1614     in
1615     returnUs (CondCode True cond code__2)
1616
1617 #endif {- sparc_TARGET_ARCH -}
1618 \end{code}
1619
1620 %************************************************************************
1621 %*                                                                      *
1622 \subsection{Generating assignments}
1623 %*                                                                      *
1624 %************************************************************************
1625
1626 Assignments are really at the heart of the whole code generation
1627 business.  Almost all top-level nodes of any real importance are
1628 assignments, which correspond to loads, stores, or register transfers.
1629 If we're really lucky, some of the register transfers will go away,
1630 because we can use the destination register to complete the code
1631 generation for the right hand side.  This only fails when the right
1632 hand side is forced into a fixed register (e.g. the result of a call).
1633
1634 \begin{code}
1635 assignIntCode, assignFltCode
1636         :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock
1637
1638 #if alpha_TARGET_ARCH
1639
1640 assignIntCode pk (StInd _ dst) src
1641   = getNewRegNCG IntRep             `thenUs` \ tmp ->
1642     getAmode dst                    `thenUs` \ amode ->
1643     getRegister src                 `thenUs` \ register ->
1644     let
1645         code1   = amodeCode amode asmVoid
1646         dst__2  = amodeAddr amode
1647         code2   = registerCode register tmp asmVoid
1648         src__2  = registerName register tmp
1649         sz      = primRepToSize pk
1650         code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1651     in
1652     returnUs code__2
1653
1654 assignIntCode pk dst src
1655   = getRegister dst                         `thenUs` \ register1 ->
1656     getRegister src                         `thenUs` \ register2 ->
1657     let
1658         dst__2  = registerName register1 zeroh
1659         code    = registerCode register2 dst__2
1660         src__2  = registerName register2 dst__2
1661         code__2 = if isFixed register2
1662                   then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1663                   else code
1664     in
1665     returnUs code__2
1666
1667 #endif {- alpha_TARGET_ARCH -}
1668 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1669 #if i386_TARGET_ARCH
1670
1671 assignIntCode pk (StInd _ dst) src
1672   = getAmode dst                `thenUs` \ amode ->
1673     get_op_RI src               `thenUs` \ (codesrc, opsrc, sz) ->
1674     let
1675         code1   = amodeCode amode asmVoid
1676         dst__2  = amodeAddr amode
1677         code__2 = asmParThen [code1, codesrc asmVoid] .
1678                   mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
1679     in
1680     returnUs code__2
1681   where
1682     get_op_RI
1683         :: StixTree
1684         -> UniqSM (InstrBlock,Operand, Size)    -- code, operator, size
1685
1686     get_op_RI op
1687       | maybeToBool imm
1688       = returnUs (asmParThen [], OpImm imm_op, L)
1689       where
1690         imm    = maybeImm op
1691         imm_op = case imm of Just x -> x
1692
1693     get_op_RI op
1694       = getRegister op                  `thenUs` \ register ->
1695         getNewRegNCG (registerRep register)
1696                                         `thenUs` \ tmp ->
1697         let
1698             code = registerCode register tmp
1699             reg  = registerName register tmp
1700             pk   = registerRep  register
1701             sz   = primRepToSize pk
1702         in
1703         returnUs (code, OpReg reg, sz)
1704
1705 assignIntCode pk dst (StInd _ src)
1706   = getNewRegNCG IntRep             `thenUs` \ tmp ->
1707     getAmode src                    `thenUs` \ amode ->
1708     getRegister dst                         `thenUs` \ register ->
1709     let
1710         code1   = amodeCode amode asmVoid
1711         src__2  = amodeAddr amode
1712         code2   = registerCode register tmp asmVoid
1713         dst__2  = registerName register tmp
1714         sz      = primRepToSize pk
1715         code__2 = asmParThen [code1, code2] .
1716                   mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
1717     in
1718     returnUs code__2
1719
1720 assignIntCode pk dst src
1721   = getRegister dst                         `thenUs` \ register1 ->
1722     getRegister src                         `thenUs` \ register2 ->
1723     getNewRegNCG IntRep             `thenUs` \ tmp ->
1724     let
1725         dst__2  = registerName register1 tmp
1726         code    = registerCode register2 dst__2
1727         src__2  = registerName register2 dst__2
1728         code__2 = if isFixed register2 && dst__2 /= src__2
1729                   then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
1730                   else code
1731     in
1732     returnUs code__2
1733
1734 #endif {- i386_TARGET_ARCH -}
1735 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1736 #if sparc_TARGET_ARCH
1737
1738 assignIntCode pk (StInd _ dst) src
1739   = getNewRegNCG IntRep             `thenUs` \ tmp ->
1740     getAmode dst                    `thenUs` \ amode ->
1741     getRegister src                         `thenUs` \ register ->
1742     let
1743         code1   = amodeCode amode asmVoid
1744         dst__2  = amodeAddr amode
1745         code2   = registerCode register tmp asmVoid
1746         src__2  = registerName register tmp
1747         sz      = primRepToSize pk
1748         code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1749     in
1750     returnUs code__2
1751
1752 assignIntCode pk dst src
1753   = getRegister dst                         `thenUs` \ register1 ->
1754     getRegister src                         `thenUs` \ register2 ->
1755     let
1756         dst__2  = registerName register1 g0
1757         code    = registerCode register2 dst__2
1758         src__2  = registerName register2 dst__2
1759         code__2 = if isFixed register2
1760                   then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
1761                   else code
1762     in
1763     returnUs code__2
1764
1765 #endif {- sparc_TARGET_ARCH -}
1766 \end{code}
1767
1768 % --------------------------------
1769 Floating-point assignments:
1770 % --------------------------------
1771 \begin{code}
1772 #if alpha_TARGET_ARCH
1773
1774 assignFltCode pk (StInd _ dst) src
1775   = getNewRegNCG pk                 `thenUs` \ tmp ->
1776     getAmode dst                    `thenUs` \ amode ->
1777     getRegister src                         `thenUs` \ register ->
1778     let
1779         code1   = amodeCode amode asmVoid
1780         dst__2  = amodeAddr amode
1781         code2   = registerCode register tmp asmVoid
1782         src__2  = registerName register tmp
1783         sz      = primRepToSize pk
1784         code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1785     in
1786     returnUs code__2
1787
1788 assignFltCode pk dst src
1789   = getRegister dst                         `thenUs` \ register1 ->
1790     getRegister src                         `thenUs` \ register2 ->
1791     let
1792         dst__2  = registerName register1 zeroh
1793         code    = registerCode register2 dst__2
1794         src__2  = registerName register2 dst__2
1795         code__2 = if isFixed register2
1796                   then code . mkSeqInstr (FMOV src__2 dst__2)
1797                   else code
1798     in
1799     returnUs code__2
1800
1801 #endif {- alpha_TARGET_ARCH -}
1802 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1803 #if i386_TARGET_ARCH
1804
1805 assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
1806   = getNewRegNCG IntRep             `thenUs` \ tmp ->
1807     getAmode src                    `thenUs` \ amodesrc ->
1808     getAmode dst                    `thenUs` \ amodedst ->
1809     --getRegister src                       `thenUs` \ register ->
1810     let
1811         codesrc1 = amodeCode amodesrc asmVoid
1812         addrsrc1 = amodeAddr amodesrc
1813         codedst1 = amodeCode amodedst asmVoid
1814         addrdst1 = amodeAddr amodedst
1815         addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x
1816         addrdst2 = case (addrOffset addrdst1 4) of Just x -> x
1817
1818         code__2 = asmParThen [codesrc1, codedst1] .
1819                   mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
1820                                 MOV L (OpReg tmp) (OpAddr addrdst1)]
1821                                ++
1822                                if pk == DoubleRep
1823                                then [MOV L (OpAddr addrsrc2) (OpReg tmp),
1824                                      MOV L (OpReg tmp) (OpAddr addrdst2)]
1825                                else [])
1826     in
1827     returnUs code__2
1828
1829 assignFltCode pk (StInd _ dst) src
1830   = --getNewRegNCG pk               `thenUs` \ tmp ->
1831     getAmode dst                    `thenUs` \ amode ->
1832     getRegister src                         `thenUs` \ register ->
1833     let
1834         sz      = primRepToSize pk
1835         dst__2  = amodeAddr amode
1836
1837         code1   = amodeCode amode asmVoid
1838         code2   = registerCode register {-tmp-}st0 asmVoid
1839
1840         --src__2= registerName register tmp
1841         pk__2   = registerRep register
1842         sz__2   = primRepToSize pk__2
1843
1844         code__2 = asmParThen [code1, code2] .
1845                   mkSeqInstr (FSTP sz (OpAddr dst__2))
1846     in
1847     returnUs code__2
1848
1849 assignFltCode pk dst src
1850   = getRegister dst                         `thenUs` \ register1 ->
1851     getRegister src                         `thenUs` \ register2 ->
1852     --getNewRegNCG (registerRep register2)
1853     --                              `thenUs` \ tmp ->
1854     let
1855         sz      = primRepToSize pk
1856         dst__2  = registerName register1 st0 --tmp
1857
1858         code    = registerCode register2 dst__2
1859         src__2  = registerName register2 dst__2
1860
1861         code__2 = code
1862     in
1863     returnUs code__2
1864
1865 #endif {- i386_TARGET_ARCH -}
1866 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1867 #if sparc_TARGET_ARCH
1868
1869 assignFltCode pk (StInd _ dst) src
1870   = getNewRegNCG pk                 `thenUs` \ tmp1 ->
1871     getAmode dst                    `thenUs` \ amode ->
1872     getRegister src                 `thenUs` \ register ->
1873     let
1874         sz      = primRepToSize pk
1875         dst__2  = amodeAddr amode
1876
1877         code1   = amodeCode amode asmVoid
1878         code2   = registerCode register tmp1 asmVoid
1879
1880         src__2  = registerName register tmp1
1881         pk__2   = registerRep register
1882         sz__2   = primRepToSize pk__2
1883
1884         code__2 = asmParThen [code1, code2] .
1885             if pk == pk__2 then
1886                     mkSeqInstr (ST sz src__2 dst__2)
1887             else
1888                 mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1889     in
1890     returnUs code__2
1891
1892 assignFltCode pk dst src
1893   = getRegister dst                         `thenUs` \ register1 ->
1894     getRegister src                         `thenUs` \ register2 ->
1895     let
1896         pk__2   = registerRep register2
1897         sz__2   = primRepToSize pk__2
1898     in
1899     getNewRegNCG pk__2                      `thenUs` \ tmp ->
1900     let
1901         sz      = primRepToSize pk
1902         dst__2  = registerName register1 g0    -- must be Fixed
1903
1904
1905         reg__2  = if pk /= pk__2 then tmp else dst__2
1906
1907         code    = registerCode register2 reg__2
1908
1909         src__2  = registerName register2 reg__2
1910
1911         code__2 =
1912                 if pk /= pk__2 then
1913                      code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
1914                 else if isFixed register2 then
1915                      code . mkSeqInstr (FMOV sz src__2 dst__2)
1916                 else
1917                      code
1918     in
1919     returnUs code__2
1920
1921 #endif {- sparc_TARGET_ARCH -}
1922 \end{code}
1923
1924 %************************************************************************
1925 %*                                                                      *
1926 \subsection{Generating an unconditional branch}
1927 %*                                                                      *
1928 %************************************************************************
1929
1930 We accept two types of targets: an immediate CLabel or a tree that
1931 gets evaluated into a register.  Any CLabels which are AsmTemporaries
1932 are assumed to be in the local block of code, close enough for a
1933 branch instruction.  Other CLabels are assumed to be far away.
1934
1935 (If applicable) Do not fill the delay slots here; you will confuse the
1936 register allocator.
1937
1938 \begin{code}
1939 genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock
1940
1941 #if alpha_TARGET_ARCH
1942
1943 genJump (StCLbl lbl)
1944   | isAsmTemp lbl = returnInstr (BR target)
1945   | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1946   where
1947     target = ImmCLbl lbl
1948
1949 genJump tree
1950   = getRegister tree                        `thenUs` \ register ->
1951     getNewRegNCG PtrRep             `thenUs` \ tmp ->
1952     let
1953         dst    = registerName register pv
1954         code   = registerCode register pv
1955         target = registerName register pv
1956     in
1957     if isFixed register then
1958         returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1959     else
1960     returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1961
1962 #endif {- alpha_TARGET_ARCH -}
1963 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1964 #if i386_TARGET_ARCH
1965
1966 {-
1967 genJump (StCLbl lbl)
1968   | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
1969   | otherwise     = returnInstrs [JMP (OpImm target)]
1970   where
1971     target = ImmCLbl lbl
1972 -}
1973
1974 genJump (StInd pk mem)
1975   = getAmode mem                    `thenUs` \ amode ->
1976     let
1977         code   = amodeCode amode
1978         target = amodeAddr amode
1979     in
1980     returnSeq code [JMP (OpAddr target)]
1981
1982 genJump tree
1983   | maybeToBool imm
1984   = returnInstr (JMP (OpImm target))
1985
1986   | otherwise
1987   = getRegister tree                        `thenUs` \ register ->
1988     getNewRegNCG PtrRep             `thenUs` \ tmp ->
1989     let
1990         code   = registerCode register tmp
1991         target = registerName register tmp
1992     in
1993     returnSeq code [JMP (OpReg target)]
1994   where
1995     imm    = maybeImm tree
1996     target = case imm of Just x -> x
1997
1998 #endif {- i386_TARGET_ARCH -}
1999 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2000 #if sparc_TARGET_ARCH
2001
2002 genJump (StCLbl lbl)
2003   | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
2004   | otherwise     = returnInstrs [CALL target 0 True, NOP]
2005   where
2006     target = ImmCLbl lbl
2007
2008 genJump tree
2009   = getRegister tree                        `thenUs` \ register ->
2010     getNewRegNCG PtrRep             `thenUs` \ tmp ->
2011     let
2012         code   = registerCode register tmp
2013         target = registerName register tmp
2014     in
2015     returnSeq code [JMP (AddrRegReg target g0), NOP]
2016
2017 #endif {- sparc_TARGET_ARCH -}
2018 \end{code}
2019
2020 %************************************************************************
2021 %*                                                                      *
2022 \subsection{Conditional jumps}
2023 %*                                                                      *
2024 %************************************************************************
2025
2026 Conditional jumps are always to local labels, so we can use branch
2027 instructions.  We peek at the arguments to decide what kind of
2028 comparison to do.
2029
2030 ALPHA: For comparisons with 0, we're laughing, because we can just do
2031 the desired conditional branch.
2032
2033 I386: First, we have to ensure that the condition
2034 codes are set according to the supplied comparison operation.
2035
2036 SPARC: First, we have to ensure that the condition codes are set
2037 according to the supplied comparison operation.  We generate slightly
2038 different code for floating point comparisons, because a floating
2039 point operation cannot directly precede a @BF@.  We assume the worst
2040 and fill that slot with a @NOP@.
2041
2042 SPARC: Do not fill the delay slots here; you will confuse the register
2043 allocator.
2044
2045 \begin{code}
2046 genCondJump
2047     :: CLabel       -- the branch target
2048     -> StixTree     -- the condition on which to branch
2049     -> UniqSM InstrBlock
2050
2051 #if alpha_TARGET_ARCH
2052
2053 genCondJump lbl (StPrim op [x, StInt 0])
2054   = getRegister x                           `thenUs` \ register ->
2055     getNewRegNCG (registerRep register)
2056                                     `thenUs` \ tmp ->
2057     let
2058         code   = registerCode register tmp
2059         value  = registerName register tmp
2060         pk     = registerRep register
2061         target = ImmCLbl lbl
2062     in
2063     returnSeq code [BI (cmpOp op) value target]
2064   where
2065     cmpOp CharGtOp = GTT
2066     cmpOp CharGeOp = GE
2067     cmpOp CharEqOp = EQQ
2068     cmpOp CharNeOp = NE
2069     cmpOp CharLtOp = LTT
2070     cmpOp CharLeOp = LE
2071     cmpOp IntGtOp = GTT
2072     cmpOp IntGeOp = GE
2073     cmpOp IntEqOp = EQQ
2074     cmpOp IntNeOp = NE
2075     cmpOp IntLtOp = LTT
2076     cmpOp IntLeOp = LE
2077     cmpOp WordGtOp = NE
2078     cmpOp WordGeOp = ALWAYS
2079     cmpOp WordEqOp = EQQ
2080     cmpOp WordNeOp = NE
2081     cmpOp WordLtOp = NEVER
2082     cmpOp WordLeOp = EQQ
2083     cmpOp AddrGtOp = NE
2084     cmpOp AddrGeOp = ALWAYS
2085     cmpOp AddrEqOp = EQQ
2086     cmpOp AddrNeOp = NE
2087     cmpOp AddrLtOp = NEVER
2088     cmpOp AddrLeOp = EQQ
2089
2090 genCondJump lbl (StPrim op [x, StDouble 0.0])
2091   = getRegister x                           `thenUs` \ register ->
2092     getNewRegNCG (registerRep register)
2093                                     `thenUs` \ tmp ->
2094     let
2095         code   = registerCode register tmp
2096         value  = registerName register tmp
2097         pk     = registerRep register
2098         target = ImmCLbl lbl
2099     in
2100     returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
2101   where
2102     cmpOp FloatGtOp = GTT
2103     cmpOp FloatGeOp = GE
2104     cmpOp FloatEqOp = EQQ
2105     cmpOp FloatNeOp = NE
2106     cmpOp FloatLtOp = LTT
2107     cmpOp FloatLeOp = LE
2108     cmpOp DoubleGtOp = GTT
2109     cmpOp DoubleGeOp = GE
2110     cmpOp DoubleEqOp = EQQ
2111     cmpOp DoubleNeOp = NE
2112     cmpOp DoubleLtOp = LTT
2113     cmpOp DoubleLeOp = LE
2114
2115 genCondJump lbl (StPrim op [x, y])
2116   | fltCmpOp op
2117   = trivialFCode pr instr x y       `thenUs` \ register ->
2118     getNewRegNCG DoubleRep          `thenUs` \ tmp ->
2119     let
2120         code   = registerCode register tmp
2121         result = registerName register tmp
2122         target = ImmCLbl lbl
2123     in
2124     returnUs (code . mkSeqInstr (BF cond result target))
2125   where
2126     pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2127
2128     fltCmpOp op = case op of
2129         FloatGtOp -> True
2130         FloatGeOp -> True
2131         FloatEqOp -> True
2132         FloatNeOp -> True
2133         FloatLtOp -> True
2134         FloatLeOp -> True
2135         DoubleGtOp -> True
2136         DoubleGeOp -> True
2137         DoubleEqOp -> True
2138         DoubleNeOp -> True
2139         DoubleLtOp -> True
2140         DoubleLeOp -> True
2141         _ -> False
2142     (instr, cond) = case op of
2143         FloatGtOp -> (FCMP TF LE, EQQ)
2144         FloatGeOp -> (FCMP TF LTT, EQQ)
2145         FloatEqOp -> (FCMP TF EQQ, NE)
2146         FloatNeOp -> (FCMP TF EQQ, EQQ)
2147         FloatLtOp -> (FCMP TF LTT, NE)
2148         FloatLeOp -> (FCMP TF LE, NE)
2149         DoubleGtOp -> (FCMP TF LE, EQQ)
2150         DoubleGeOp -> (FCMP TF LTT, EQQ)
2151         DoubleEqOp -> (FCMP TF EQQ, NE)
2152         DoubleNeOp -> (FCMP TF EQQ, EQQ)
2153         DoubleLtOp -> (FCMP TF LTT, NE)
2154         DoubleLeOp -> (FCMP TF LE, NE)
2155
2156 genCondJump lbl (StPrim op [x, y])
2157   = trivialCode instr x y           `thenUs` \ register ->
2158     getNewRegNCG IntRep             `thenUs` \ tmp ->
2159     let
2160         code   = registerCode register tmp
2161         result = registerName register tmp
2162         target = ImmCLbl lbl
2163     in
2164     returnUs (code . mkSeqInstr (BI cond result target))
2165   where
2166     (instr, cond) = case op of
2167         CharGtOp -> (CMP LE, EQQ)
2168         CharGeOp -> (CMP LTT, EQQ)
2169         CharEqOp -> (CMP EQQ, NE)
2170         CharNeOp -> (CMP EQQ, EQQ)
2171         CharLtOp -> (CMP LTT, NE)
2172         CharLeOp -> (CMP LE, NE)
2173         IntGtOp -> (CMP LE, EQQ)
2174         IntGeOp -> (CMP LTT, EQQ)
2175         IntEqOp -> (CMP EQQ, NE)
2176         IntNeOp -> (CMP EQQ, EQQ)
2177         IntLtOp -> (CMP LTT, NE)
2178         IntLeOp -> (CMP LE, NE)
2179         WordGtOp -> (CMP ULE, EQQ)
2180         WordGeOp -> (CMP ULT, EQQ)
2181         WordEqOp -> (CMP EQQ, NE)
2182         WordNeOp -> (CMP EQQ, EQQ)
2183         WordLtOp -> (CMP ULT, NE)
2184         WordLeOp -> (CMP ULE, NE)
2185         AddrGtOp -> (CMP ULE, EQQ)
2186         AddrGeOp -> (CMP ULT, EQQ)
2187         AddrEqOp -> (CMP EQQ, NE)
2188         AddrNeOp -> (CMP EQQ, EQQ)
2189         AddrLtOp -> (CMP ULT, NE)
2190         AddrLeOp -> (CMP ULE, NE)
2191
2192 #endif {- alpha_TARGET_ARCH -}
2193 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2194 #if i386_TARGET_ARCH
2195
2196 genCondJump lbl bool
2197   = getCondCode bool                `thenUs` \ condition ->
2198     let
2199         code   = condCode condition
2200         cond   = condName condition
2201         target = ImmCLbl lbl
2202     in
2203     returnSeq code [JXX cond lbl]
2204
2205 #endif {- i386_TARGET_ARCH -}
2206 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2207 #if sparc_TARGET_ARCH
2208
2209 genCondJump lbl bool
2210   = getCondCode bool                `thenUs` \ condition ->
2211     let
2212         code   = condCode condition
2213         cond   = condName condition
2214         target = ImmCLbl lbl
2215     in
2216     returnSeq code (
2217     if condFloat condition then
2218         [NOP, BF cond False target, NOP]
2219     else
2220         [BI cond False target, NOP]
2221     )
2222
2223 #endif {- sparc_TARGET_ARCH -}
2224 \end{code}
2225
2226 %************************************************************************
2227 %*                                                                      *
2228 \subsection{Generating C calls}
2229 %*                                                                      *
2230 %************************************************************************
2231
2232 Now the biggest nightmare---calls.  Most of the nastiness is buried in
2233 @get_arg@, which moves the arguments to the correct registers/stack
2234 locations.  Apart from that, the code is easy.
2235
2236 (If applicable) Do not fill the delay slots here; you will confuse the
2237 register allocator.
2238
2239 \begin{code}
2240 genCCall
2241     :: FAST_STRING      -- function to call
2242     -> PrimRep          -- type of the result
2243     -> [StixTree]       -- arguments (of mixed type)
2244     -> UniqSM InstrBlock
2245
2246 #if alpha_TARGET_ARCH
2247
2248 genCCall fn kind args
2249   = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2250                                     `thenUs` \ ((unused,_), argCode) ->
2251     let
2252         nRegs = length allArgRegs - length unused
2253         code = asmParThen (map ($ asmVoid) argCode)
2254     in
2255         returnSeq code [
2256             LDA pv (AddrImm (ImmLab (ptext fn))),
2257             JSR ra (AddrReg pv) nRegs,
2258             LDGP gp (AddrReg ra)]
2259   where
2260     ------------------------
2261     {-  Try to get a value into a specific register (or registers) for
2262         a call.  The first 6 arguments go into the appropriate
2263         argument register (separate registers for integer and floating
2264         point arguments, but used in lock-step), and the remaining
2265         arguments are dumped to the stack, beginning at 0(sp).  Our
2266         first argument is a pair of the list of remaining argument
2267         registers to be assigned for this call and the next stack
2268         offset to use for overflowing arguments.  This way,
2269         @get_Arg@ can be applied to all of a call's arguments using
2270         @mapAccumLUs@.
2271     -}
2272     get_arg
2273         :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
2274         -> StixTree             -- Current argument
2275         -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2276
2277     -- We have to use up all of our argument registers first...
2278
2279     get_arg ((iDst,fDst):dsts, offset) arg
2280       = getRegister arg                     `thenUs` \ register ->
2281         let
2282             reg  = if isFloatingRep pk then fDst else iDst
2283             code = registerCode register reg
2284             src  = registerName register reg
2285             pk   = registerRep register
2286         in
2287         returnUs (
2288             if isFloatingRep pk then
2289                 ((dsts, offset), if isFixed register then
2290                     code . mkSeqInstr (FMOV src fDst)
2291                     else code)
2292             else
2293                 ((dsts, offset), if isFixed register then
2294                     code . mkSeqInstr (OR src (RIReg src) iDst)
2295                     else code))
2296
2297     -- Once we have run out of argument registers, we move to the
2298     -- stack...
2299
2300     get_arg ([], offset) arg
2301       = getRegister arg                 `thenUs` \ register ->
2302         getNewRegNCG (registerRep register)
2303                                         `thenUs` \ tmp ->
2304         let
2305             code = registerCode register tmp
2306             src  = registerName register tmp
2307             pk   = registerRep register
2308             sz   = primRepToSize pk
2309         in
2310         returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2311
2312 #endif {- alpha_TARGET_ARCH -}
2313 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2314 #if i386_TARGET_ARCH
2315
2316 genCCall fn kind [StInt i]
2317   | fn == SLIT ("PerformGC_wrapper")
2318   = let
2319      call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2320              CALL (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))]
2321     in
2322     returnInstrs call
2323
2324 {- OLD:
2325   = getUniqLabelNCG                 `thenUs` \ lbl ->
2326     let
2327         call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2328                 MOV L (OpImm (ImmCLbl lbl))
2329                       -- this is hardwired
2330                       (OpAddr (Address (Just ebx) Nothing (ImmInt 104))),
2331                 JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
2332                 LABEL lbl]
2333     in
2334     returnInstrs call
2335 -}
2336
2337 genCCall fn kind args
2338   = mapUs get_call_arg args `thenUs` \ argCode ->
2339     let
2340         nargs = length args
2341 {- OLD: Since there's no attempt at stealing %esp at the moment,
2342    restoring %esp from MainRegTable.rCstkptr is not done.  -- SOF 97/09
2343    (ditto for saving away old-esp in MainRegTable.Hp (!!) )
2344         code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Address (Just ebx) Nothing (ImmInt 80))),
2345                         MOV L (OpAddr (Address (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
2346                                    ]
2347                            ]
2348 -}
2349         code2 = asmParThen (map ($ asmVoid) (reverse argCode))
2350         call = [CALL fn__2 ,
2351                 -- pop args; all args word sized?
2352                 ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp) --,
2353
2354                 -- Don't restore %esp (see above)
2355                 -- MOV L (OpAddr (Address (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
2356                 ]
2357     in
2358     returnSeq (code2) call
2359   where
2360     -- function names that begin with '.' are assumed to be special
2361     -- internally generated names like '.mul,' which don't get an
2362     -- underscore prefix
2363     -- ToDo:needed (WDP 96/03) ???
2364     fn__2 = case (_HEAD_ fn) of
2365               '.' -> ImmLit (ptext fn)
2366               _   -> ImmLab (ptext fn)
2367
2368     ------------
2369     get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock   -- code
2370
2371     get_call_arg arg
2372       = get_op arg              `thenUs` \ (code, op, sz) ->
2373         returnUs (code . mkSeqInstr (PUSH sz op))
2374
2375     ------------
2376     get_op
2377         :: StixTree
2378         -> UniqSM (InstrBlock,Operand, Size)    -- code, operator, size
2379
2380     get_op (StInt i)
2381       = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
2382
2383     get_op (StInd pk mem)
2384       = getAmode mem            `thenUs` \ amode ->
2385         let
2386             code = amodeCode amode --asmVoid
2387             addr = amodeAddr amode
2388             sz   = primRepToSize pk
2389         in
2390         returnUs (code, OpAddr addr, sz)
2391
2392     get_op op
2393       = getRegister op          `thenUs` \ register ->
2394         getNewRegNCG (registerRep register)
2395                                 `thenUs` \ tmp ->
2396         let
2397             code = registerCode register tmp
2398             reg  = registerName register tmp
2399             pk   = registerRep  register
2400             sz   = primRepToSize pk
2401         in
2402         returnUs (code, OpReg reg, sz)
2403
2404 #endif {- i386_TARGET_ARCH -}
2405 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2406 #if sparc_TARGET_ARCH
2407
2408 genCCall fn kind args
2409   = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2410                                     `thenUs` \ ((unused,_), argCode) ->
2411     let
2412         nRegs = length allArgRegs - length unused
2413         call = CALL fn__2 nRegs False
2414         code = asmParThen (map ($ asmVoid) argCode)
2415     in
2416         returnSeq code [call, NOP]
2417   where
2418     -- function names that begin with '.' are assumed to be special
2419     -- internally generated names like '.mul,' which don't get an
2420     -- underscore prefix
2421     -- ToDo:needed (WDP 96/03) ???
2422     fn__2 = case (_HEAD_ fn) of
2423               '.' -> ImmLit (ptext fn)
2424               _   -> ImmLab (ptext fn)
2425
2426     ------------------------------------
2427     {-  Try to get a value into a specific register (or registers) for
2428         a call.  The SPARC calling convention is an absolute
2429         nightmare.  The first 6x32 bits of arguments are mapped into
2430         %o0 through %o5, and the remaining arguments are dumped to the
2431         stack, beginning at [%sp+92].  (Note that %o6 == %sp.)  Our
2432         first argument is a pair of the list of remaining argument
2433         registers to be assigned for this call and the next stack
2434         offset to use for overflowing arguments.  This way,
2435         @get_arg@ can be applied to all of a call's arguments using
2436         @mapAccumL@.
2437     -}
2438     get_arg
2439         :: ([Reg],Int)  -- Argument registers and stack offset (accumulator)
2440         -> StixTree     -- Current argument
2441         -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2442
2443     -- We have to use up all of our argument registers first...
2444
2445     get_arg (dst:dsts, offset) arg
2446       = getRegister arg                 `thenUs` \ register ->
2447         getNewRegNCG (registerRep register)
2448                                         `thenUs` \ tmp ->
2449         let
2450             reg  = if isFloatingRep pk then tmp else dst
2451             code = registerCode register reg
2452             src  = registerName register reg
2453             pk   = registerRep register
2454         in
2455         returnUs (case pk of
2456             DoubleRep ->
2457                 case dsts of
2458                     [] -> (([], offset + 1), code . mkSeqInstrs [
2459                             -- conveniently put the second part in the right stack
2460                             -- location, and load the first part into %o5
2461                             ST DF src (spRel (offset - 1)),
2462                             LD W (spRel (offset - 1)) dst])
2463                     (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
2464                             ST DF src (spRel (-2)),
2465                             LD W (spRel (-2)) dst,
2466                             LD W (spRel (-1)) dst__2])
2467             FloatRep -> ((dsts, offset), code . mkSeqInstrs [
2468                             ST F src (spRel (-2)),
2469                             LD W (spRel (-2)) dst])
2470             _ -> ((dsts, offset), if isFixed register then
2471                                   code . mkSeqInstr (OR False g0 (RIReg src) dst)
2472                                   else code))
2473
2474     -- Once we have run out of argument registers, we move to the
2475     -- stack...
2476
2477     get_arg ([], offset) arg
2478       = getRegister arg                 `thenUs` \ register ->
2479         getNewRegNCG (registerRep register)
2480                                         `thenUs` \ tmp ->
2481         let
2482             code  = registerCode register tmp
2483             src   = registerName register tmp
2484             pk    = registerRep register
2485             sz    = primRepToSize pk
2486             words = if pk == DoubleRep then 2 else 1
2487         in
2488         returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
2489
2490 #endif {- sparc_TARGET_ARCH -}
2491 \end{code}
2492
2493 %************************************************************************
2494 %*                                                                      *
2495 \subsection{Support bits}
2496 %*                                                                      *
2497 %************************************************************************
2498
2499 %************************************************************************
2500 %*                                                                      *
2501 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2502 %*                                                                      *
2503 %************************************************************************
2504
2505 Turn those condition codes into integers now (when they appear on
2506 the right hand side of an assignment).
2507
2508 (If applicable) Do not fill the delay slots here; you will confuse the
2509 register allocator.
2510
2511 \begin{code}
2512 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
2513
2514 #if alpha_TARGET_ARCH
2515 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2516 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2517 #endif {- alpha_TARGET_ARCH -}
2518
2519 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2520 #if i386_TARGET_ARCH
2521
2522 condIntReg cond x y
2523   = condIntCode cond x y        `thenUs` \ condition ->
2524     getNewRegNCG IntRep         `thenUs` \ tmp ->
2525     --getRegister dst           `thenUs` \ register ->
2526     let
2527         --code2 = registerCode register tmp asmVoid
2528         --dst__2  = registerName register tmp
2529         code = condCode condition
2530         cond = condName condition
2531         -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
2532         code__2 dst = code . mkSeqInstrs [
2533             SETCC cond (OpReg tmp),
2534             AND L (OpImm (ImmInt 1)) (OpReg tmp),
2535             MOV L (OpReg tmp) (OpReg dst)]
2536     in
2537     returnUs (Any IntRep code__2)
2538
2539 condFltReg cond x y
2540   = getUniqLabelNCG             `thenUs` \ lbl1 ->
2541     getUniqLabelNCG             `thenUs` \ lbl2 ->
2542     condFltCode cond x y        `thenUs` \ condition ->
2543     let
2544         code = condCode condition
2545         cond = condName condition
2546         code__2 dst = code . mkSeqInstrs [
2547             JXX cond lbl1,
2548             MOV L (OpImm (ImmInt 0)) (OpReg dst),
2549             JXX ALWAYS lbl2,
2550             LABEL lbl1,
2551             MOV L (OpImm (ImmInt 1)) (OpReg dst),
2552             LABEL lbl2]
2553     in
2554     returnUs (Any IntRep code__2)
2555
2556 #endif {- i386_TARGET_ARCH -}
2557 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2558 #if sparc_TARGET_ARCH
2559
2560 condIntReg EQQ x (StInt 0)
2561   = getRegister x               `thenUs` \ register ->
2562     getNewRegNCG IntRep         `thenUs` \ tmp ->
2563     let
2564         code = registerCode register tmp
2565         src  = registerName register tmp
2566         code__2 dst = code . mkSeqInstrs [
2567             SUB False True g0 (RIReg src) g0,
2568             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2569     in
2570     returnUs (Any IntRep code__2)
2571
2572 condIntReg EQQ x y
2573   = getRegister x               `thenUs` \ register1 ->
2574     getRegister y               `thenUs` \ register2 ->
2575     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2576     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2577     let
2578         code1 = registerCode register1 tmp1 asmVoid
2579         src1  = registerName register1 tmp1
2580         code2 = registerCode register2 tmp2 asmVoid
2581         src2  = registerName register2 tmp2
2582         code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2583             XOR False src1 (RIReg src2) dst,
2584             SUB False True g0 (RIReg dst) g0,
2585             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2586     in
2587     returnUs (Any IntRep code__2)
2588
2589 condIntReg NE x (StInt 0)
2590   = getRegister x               `thenUs` \ register ->
2591     getNewRegNCG IntRep         `thenUs` \ tmp ->
2592     let
2593         code = registerCode register tmp
2594         src  = registerName register tmp
2595         code__2 dst = code . mkSeqInstrs [
2596             SUB False True g0 (RIReg src) g0,
2597             ADD True False g0 (RIImm (ImmInt 0)) dst]
2598     in
2599     returnUs (Any IntRep code__2)
2600
2601 condIntReg NE x y
2602   = getRegister x               `thenUs` \ register1 ->
2603     getRegister y               `thenUs` \ register2 ->
2604     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2605     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2606     let
2607         code1 = registerCode register1 tmp1 asmVoid
2608         src1  = registerName register1 tmp1
2609         code2 = registerCode register2 tmp2 asmVoid
2610         src2  = registerName register2 tmp2
2611         code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2612             XOR False src1 (RIReg src2) dst,
2613             SUB False True g0 (RIReg dst) g0,
2614             ADD True False g0 (RIImm (ImmInt 0)) dst]
2615     in
2616     returnUs (Any IntRep code__2)
2617
2618 condIntReg cond x y
2619   = getUniqLabelNCG             `thenUs` \ lbl1 ->
2620     getUniqLabelNCG             `thenUs` \ lbl2 ->
2621     condIntCode cond x y        `thenUs` \ condition ->
2622     let
2623         code = condCode condition
2624         cond = condName condition
2625         code__2 dst = code . mkSeqInstrs [
2626             BI cond False (ImmCLbl lbl1), NOP,
2627             OR False g0 (RIImm (ImmInt 0)) dst,
2628             BI ALWAYS False (ImmCLbl lbl2), NOP,
2629             LABEL lbl1,
2630             OR False g0 (RIImm (ImmInt 1)) dst,
2631             LABEL lbl2]
2632     in
2633     returnUs (Any IntRep code__2)
2634
2635 condFltReg cond x y
2636   = getUniqLabelNCG             `thenUs` \ lbl1 ->
2637     getUniqLabelNCG             `thenUs` \ lbl2 ->
2638     condFltCode cond x y        `thenUs` \ condition ->
2639     let
2640         code = condCode condition
2641         cond = condName condition
2642         code__2 dst = code . mkSeqInstrs [
2643             NOP,
2644             BF cond False (ImmCLbl lbl1), NOP,
2645             OR False g0 (RIImm (ImmInt 0)) dst,
2646             BI ALWAYS False (ImmCLbl lbl2), NOP,
2647             LABEL lbl1,
2648             OR False g0 (RIImm (ImmInt 1)) dst,
2649             LABEL lbl2]
2650     in
2651     returnUs (Any IntRep code__2)
2652
2653 #endif {- sparc_TARGET_ARCH -}
2654 \end{code}
2655
2656 %************************************************************************
2657 %*                                                                      *
2658 \subsubsection{@trivial*Code@: deal with trivial instructions}
2659 %*                                                                      *
2660 %************************************************************************
2661
2662 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2663 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions.  Only look
2664 for constants on the right hand side, because that's where the generic
2665 optimizer will have put them.
2666
2667 Similarly, for unary instructions, we don't have to worry about
2668 matching an StInt as the argument, because genericOpt will already
2669 have handled the constant-folding.
2670
2671 \begin{code}
2672 trivialCode
2673     :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2674       ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2675       ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2676       ,)))
2677     -> StixTree -> StixTree -- the two arguments
2678     -> UniqSM Register
2679
2680 trivialFCode
2681     :: PrimRep
2682     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2683       ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2684       ,IF_ARCH_i386 (
2685               {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
2686                (Size -> Operand -> Instr)
2687             -> (Size -> Operand -> Instr) {-reversed instr-}
2688             -> Instr {-pop-}
2689             -> Instr {-reversed instr: pop-}
2690       ,)))
2691     -> StixTree -> StixTree -- the two arguments
2692     -> UniqSM Register
2693
2694 trivialUCode
2695     :: IF_ARCH_alpha((RI -> Reg -> Instr)
2696       ,IF_ARCH_i386 ((Operand -> Instr)
2697       ,IF_ARCH_sparc((RI -> Reg -> Instr)
2698       ,)))
2699     -> StixTree -- the one argument
2700     -> UniqSM Register
2701
2702 trivialUFCode
2703     :: PrimRep
2704     -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2705       ,IF_ARCH_i386 (Instr
2706       ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2707       ,)))
2708     -> StixTree -- the one argument
2709     -> UniqSM Register
2710
2711 #if alpha_TARGET_ARCH
2712
2713 trivialCode instr x (StInt y)
2714   | fits8Bits y
2715   = getRegister x               `thenUs` \ register ->
2716     getNewRegNCG IntRep         `thenUs` \ tmp ->
2717     let
2718         code = registerCode register tmp
2719         src1 = registerName register tmp
2720         src2 = ImmInt (fromInteger y)
2721         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2722     in
2723     returnUs (Any IntRep code__2)
2724
2725 trivialCode instr x y
2726   = getRegister x               `thenUs` \ register1 ->
2727     getRegister y               `thenUs` \ register2 ->
2728     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2729     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2730     let
2731         code1 = registerCode register1 tmp1 asmVoid
2732         src1  = registerName register1 tmp1
2733         code2 = registerCode register2 tmp2 asmVoid
2734         src2  = registerName register2 tmp2
2735         code__2 dst = asmParThen [code1, code2] .
2736                      mkSeqInstr (instr src1 (RIReg src2) dst)
2737     in
2738     returnUs (Any IntRep code__2)
2739
2740 ------------
2741 trivialUCode instr x
2742   = getRegister x               `thenUs` \ register ->
2743     getNewRegNCG IntRep         `thenUs` \ tmp ->
2744     let
2745         code = registerCode register tmp
2746         src  = registerName register tmp
2747         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2748     in
2749     returnUs (Any IntRep code__2)
2750
2751 ------------
2752 trivialFCode _ instr x y
2753   = getRegister x               `thenUs` \ register1 ->
2754     getRegister y               `thenUs` \ register2 ->
2755     getNewRegNCG DoubleRep      `thenUs` \ tmp1 ->
2756     getNewRegNCG DoubleRep      `thenUs` \ tmp2 ->
2757     let
2758         code1 = registerCode register1 tmp1
2759         src1  = registerName register1 tmp1
2760
2761         code2 = registerCode register2 tmp2
2762         src2  = registerName register2 tmp2
2763
2764         code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2765                       mkSeqInstr (instr src1 src2 dst)
2766     in
2767     returnUs (Any DoubleRep code__2)
2768
2769 trivialUFCode _ instr x
2770   = getRegister x               `thenUs` \ register ->
2771     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
2772     let
2773         code = registerCode register tmp
2774         src  = registerName register tmp
2775         code__2 dst = code . mkSeqInstr (instr src dst)
2776     in
2777     returnUs (Any DoubleRep code__2)
2778
2779 #endif {- alpha_TARGET_ARCH -}
2780 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2781 #if i386_TARGET_ARCH
2782
2783 trivialCode instr x y
2784   | maybeToBool imm
2785   = getRegister x               `thenUs` \ register1 ->
2786     --getNewRegNCG IntRep       `thenUs` \ tmp1 ->
2787     let
2788 --      fixedname  = registerName register1 eax
2789         code__2 dst = let code1 = registerCode register1 dst
2790                           src1  = registerName register1 dst
2791                       in code1 .
2792                          if isFixed register1 && src1 /= dst
2793                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2794                                            instr (OpImm imm__2) (OpReg dst)]
2795                          else
2796                                 mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
2797     in
2798     returnUs (Any IntRep code__2)
2799   where
2800     imm = maybeImm y
2801     imm__2 = case imm of Just x -> x
2802
2803 trivialCode instr x y
2804   | maybeToBool imm
2805   = getRegister y               `thenUs` \ register1 ->
2806     --getNewRegNCG IntRep       `thenUs` \ tmp1 ->
2807     let
2808 --      fixedname  = registerName register1 eax
2809         code__2 dst = let code1 = registerCode register1 dst
2810                           src1  = registerName register1 dst
2811                       in code1 .
2812                          if isFixed register1 && src1 /= dst
2813                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2814                                            instr (OpImm imm__2) (OpReg dst)]
2815                          else
2816                                 mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
2817     in
2818     returnUs (Any IntRep code__2)
2819   where
2820     imm = maybeImm x
2821     imm__2 = case imm of Just x -> x
2822
2823 trivialCode instr x (StInd pk mem)
2824   = getRegister x               `thenUs` \ register ->
2825     --getNewRegNCG IntRep       `thenUs` \ tmp ->
2826     getAmode mem                `thenUs` \ amode ->
2827     let
2828 --      fixedname  = registerName register eax
2829         code2 = amodeCode amode asmVoid
2830         src2  = amodeAddr amode
2831         code__2 dst = let code1 = registerCode register dst asmVoid
2832                           src1  = registerName register dst
2833                       in asmParThen [code1, code2] .
2834                          if isFixed register && src1 /= dst
2835                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2836                                            instr (OpAddr src2)  (OpReg dst)]
2837                          else
2838                                 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2839     in
2840     returnUs (Any pk code__2)
2841
2842 trivialCode instr (StInd pk mem) y
2843   = getRegister y               `thenUs` \ register ->
2844     --getNewRegNCG IntRep       `thenUs` \ tmp ->
2845     getAmode mem                `thenUs` \ amode ->
2846     let
2847 --      fixedname  = registerName register eax
2848         code2 = amodeCode amode asmVoid
2849         src2  = amodeAddr amode
2850         code__2 dst = let
2851                           code1 = registerCode register dst asmVoid
2852                           src1  = registerName register dst
2853                       in asmParThen [code1, code2] .
2854                          if isFixed register && src1 /= dst
2855                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2856                                            instr (OpAddr src2)  (OpReg dst)]
2857                          else
2858                                 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2859     in
2860     returnUs (Any pk code__2)
2861
2862 trivialCode instr x y
2863   = getRegister x               `thenUs` \ register1 ->
2864     getRegister y               `thenUs` \ register2 ->
2865     --getNewRegNCG IntRep       `thenUs` \ tmp1 ->
2866     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2867     let
2868 --      fixedname  = registerName register1 eax
2869         code2 = registerCode register2 tmp2 asmVoid
2870         src2  = registerName register2 tmp2
2871         code__2 dst = let
2872                           code1 = registerCode register1 dst asmVoid
2873                           src1  = registerName register1 dst
2874                       in asmParThen [code1, code2] .
2875                          if isFixed register1 && src1 /= dst
2876                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2877                                            instr (OpReg src2)  (OpReg dst)]
2878                          else
2879                                 mkSeqInstr (instr (OpReg src2) (OpReg src1))
2880     in
2881     returnUs (Any IntRep code__2)
2882
2883 -----------
2884 trivialUCode instr x
2885   = getRegister x               `thenUs` \ register ->
2886 --    getNewRegNCG IntRep       `thenUs` \ tmp ->
2887     let
2888 --      fixedname = registerName register eax
2889         code__2 dst = let
2890                           code = registerCode register dst
2891                           src  = registerName register dst
2892                       in code . if isFixed register && dst /= src
2893                                 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
2894                                                   instr (OpReg dst)]
2895                                 else mkSeqInstr (instr (OpReg src))
2896     in
2897     returnUs (Any IntRep code__2)
2898
2899 -----------
2900 trivialFCode pk _ instrr _ _ (StInd pk' mem) y
2901   = getRegister y               `thenUs` \ register2 ->
2902     --getNewRegNCG (registerRep register2)
2903     --                          `thenUs` \ tmp2 ->
2904     getAmode mem                `thenUs` \ amode ->
2905     let
2906         code1 = amodeCode amode
2907         src1  = amodeAddr amode
2908
2909         code__2 dst = let
2910                           code2 = registerCode register2 dst
2911                           src2  = registerName register2 dst
2912                       in asmParThen [code1 asmVoid,code2 asmVoid] .
2913                          mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
2914     in
2915     returnUs (Any pk code__2)
2916
2917 trivialFCode pk instr _ _ _ x (StInd pk' mem)
2918   = getRegister x               `thenUs` \ register1 ->
2919     --getNewRegNCG (registerRep register1)
2920     --                          `thenUs` \ tmp1 ->
2921     getAmode mem                `thenUs` \ amode ->
2922     let
2923         code2 = amodeCode amode
2924         src2  = amodeAddr amode
2925
2926         code__2 dst = let
2927                           code1 = registerCode register1 dst
2928                           src1  = registerName register1 dst
2929                       in asmParThen [code2 asmVoid,code1 asmVoid] .
2930                          mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
2931     in
2932     returnUs (Any pk code__2)
2933
2934 trivialFCode pk _ _ _ instrpr x y
2935   = getRegister x               `thenUs` \ register1 ->
2936     getRegister y               `thenUs` \ register2 ->
2937     --getNewRegNCG (registerRep register1)
2938     --                          `thenUs` \ tmp1 ->
2939     --getNewRegNCG (registerRep register2)
2940     --                          `thenUs` \ tmp2 ->
2941     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
2942     let
2943         pk1   = registerRep register1
2944         code1 = registerCode register1 st0 --tmp1
2945         src1  = registerName register1 st0 --tmp1
2946
2947         pk2   = registerRep register2
2948
2949         code__2 dst = let
2950                           code2 = registerCode register2 dst
2951                           src2  = registerName register2 dst
2952                       in asmParThen [code1 asmVoid, code2 asmVoid] .
2953                          mkSeqInstr instrpr
2954     in
2955     returnUs (Any pk1 code__2)
2956
2957 -------------
2958 trivialUFCode pk instr (StInd pk' mem)
2959   = getAmode mem                `thenUs` \ amode ->
2960     let
2961         code = amodeCode amode
2962         src  = amodeAddr amode
2963         code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
2964                                           instr]
2965     in
2966     returnUs (Any pk code__2)
2967
2968 trivialUFCode pk instr x
2969   = getRegister x               `thenUs` \ register ->
2970     --getNewRegNCG pk           `thenUs` \ tmp ->
2971     let
2972         code__2 dst = let
2973                           code = registerCode register dst
2974                           src  = registerName register dst
2975                       in code . mkSeqInstrs [instr]
2976     in
2977     returnUs (Any pk code__2)
2978
2979 #endif {- i386_TARGET_ARCH -}
2980 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2981 #if sparc_TARGET_ARCH
2982
2983 trivialCode instr x (StInt y)
2984   | fits13Bits y
2985   = getRegister x               `thenUs` \ register ->
2986     getNewRegNCG IntRep         `thenUs` \ tmp ->
2987     let
2988         code = registerCode register tmp
2989         src1 = registerName register tmp
2990         src2 = ImmInt (fromInteger y)
2991         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2992     in
2993     returnUs (Any IntRep code__2)
2994
2995 trivialCode instr x y
2996   = getRegister x               `thenUs` \ register1 ->
2997     getRegister y               `thenUs` \ register2 ->
2998     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2999     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
3000     let
3001         code1 = registerCode register1 tmp1 asmVoid
3002         src1  = registerName register1 tmp1
3003         code2 = registerCode register2 tmp2 asmVoid
3004         src2  = registerName register2 tmp2
3005         code__2 dst = asmParThen [code1, code2] .
3006                      mkSeqInstr (instr src1 (RIReg src2) dst)
3007     in
3008     returnUs (Any IntRep code__2)
3009
3010 ------------
3011 trivialFCode pk instr x y
3012   = getRegister x               `thenUs` \ register1 ->
3013     getRegister y               `thenUs` \ register2 ->
3014     getNewRegNCG (registerRep register1)
3015                                 `thenUs` \ tmp1 ->
3016     getNewRegNCG (registerRep register2)
3017                                 `thenUs` \ tmp2 ->
3018     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
3019     let
3020         promote x = asmInstr (FxTOy F DF x tmp)
3021
3022         pk1   = registerRep register1
3023         code1 = registerCode register1 tmp1
3024         src1  = registerName register1 tmp1
3025
3026         pk2   = registerRep register2
3027         code2 = registerCode register2 tmp2
3028         src2  = registerName register2 tmp2
3029
3030         code__2 dst =
3031                 if pk1 == pk2 then
3032                     asmParThen [code1 asmVoid, code2 asmVoid] .
3033                     mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
3034                 else if pk1 == FloatRep then
3035                     asmParThen [code1 (promote src1), code2 asmVoid] .
3036                     mkSeqInstr (instr DF tmp src2 dst)
3037                 else
3038                     asmParThen [code1 asmVoid, code2 (promote src2)] .
3039                     mkSeqInstr (instr DF src1 tmp dst)
3040     in
3041     returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3042
3043 ------------
3044 trivialUCode instr x
3045   = getRegister x               `thenUs` \ register ->
3046     getNewRegNCG IntRep         `thenUs` \ tmp ->
3047     let
3048         code = registerCode register tmp
3049         src  = registerName register tmp
3050         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3051     in
3052     returnUs (Any IntRep code__2)
3053
3054 -------------
3055 trivialUFCode pk instr x
3056   = getRegister x               `thenUs` \ register ->
3057     getNewRegNCG pk             `thenUs` \ tmp ->
3058     let
3059         code = registerCode register tmp
3060         src  = registerName register tmp
3061         code__2 dst = code . mkSeqInstr (instr src dst)
3062     in
3063     returnUs (Any pk code__2)
3064
3065 #endif {- sparc_TARGET_ARCH -}
3066 \end{code}
3067
3068 %************************************************************************
3069 %*                                                                      *
3070 \subsubsection{Coercing to/from integer/floating-point...}
3071 %*                                                                      *
3072 %************************************************************************
3073
3074 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3075 to be generated.  Here we just change the type on the Register passed
3076 on up.  The code is machine-independent.
3077
3078 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3079 conversions.  We have to store temporaries in memory to move
3080 between the integer and the floating point register sets.
3081
3082 \begin{code}
3083 coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
3084 coerceFltCode ::            StixTree -> UniqSM Register
3085
3086 coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
3087 coerceFP2Int ::            StixTree -> UniqSM Register
3088
3089 coerceIntCode pk x
3090   = getRegister x               `thenUs` \ register ->
3091     returnUs (
3092     case register of
3093         Fixed _ reg code -> Fixed pk reg code
3094         Any   _ code     -> Any   pk code
3095     )
3096
3097 -------------
3098 coerceFltCode x
3099   = getRegister x               `thenUs` \ register ->
3100     returnUs (
3101     case register of
3102         Fixed _ reg code -> Fixed DoubleRep reg code
3103         Any   _ code     -> Any   DoubleRep code
3104     )
3105 \end{code}
3106
3107 \begin{code}
3108 #if alpha_TARGET_ARCH
3109
3110 coerceInt2FP _ x
3111   = getRegister x               `thenUs` \ register ->
3112     getNewRegNCG IntRep         `thenUs` \ reg ->
3113     let
3114         code = registerCode register reg
3115         src  = registerName register reg
3116
3117         code__2 dst = code . mkSeqInstrs [
3118             ST Q src (spRel 0),
3119             LD TF dst (spRel 0),
3120             CVTxy Q TF dst dst]
3121     in
3122     returnUs (Any DoubleRep code__2)
3123
3124 -------------
3125 coerceFP2Int x
3126   = getRegister x               `thenUs` \ register ->
3127     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
3128     let
3129         code = registerCode register tmp
3130         src  = registerName register tmp
3131
3132         code__2 dst = code . mkSeqInstrs [
3133             CVTxy TF Q src tmp,
3134             ST TF tmp (spRel 0),
3135             LD Q dst (spRel 0)]
3136     in
3137     returnUs (Any IntRep code__2)
3138
3139 #endif {- alpha_TARGET_ARCH -}
3140 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3141 #if i386_TARGET_ARCH
3142
3143 coerceInt2FP pk x
3144   = getRegister x               `thenUs` \ register ->
3145     getNewRegNCG IntRep         `thenUs` \ reg ->
3146     let
3147         code = registerCode register reg
3148         src  = registerName register reg
3149
3150         code__2 dst = code . mkSeqInstrs [
3151         -- to fix: should spill instead of using R1
3152                       MOV L (OpReg src) (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1))),
3153                       FILD (primRepToSize pk) (Address (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
3154     in
3155     returnUs (Any pk code__2)
3156
3157 ------------
3158 coerceFP2Int x
3159   = getRegister x               `thenUs` \ register ->
3160     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
3161     let
3162         code = registerCode register tmp
3163         src  = registerName register tmp
3164         pk   = registerRep register
3165
3166         code__2 dst = let
3167                       in code . mkSeqInstrs [
3168                                 FRNDINT,
3169                                 FIST L (Address (Just ebx) Nothing (ImmInt OFFSET_R1)),
3170                                 MOV L (OpAddr (Address (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
3171     in
3172     returnUs (Any IntRep code__2)
3173
3174 #endif {- i386_TARGET_ARCH -}
3175 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3176 #if sparc_TARGET_ARCH
3177
3178 coerceInt2FP pk x
3179   = getRegister x               `thenUs` \ register ->
3180     getNewRegNCG IntRep         `thenUs` \ reg ->
3181     let
3182         code = registerCode register reg
3183         src  = registerName register reg
3184
3185         code__2 dst = code . mkSeqInstrs [
3186             ST W src (spRel (-2)),
3187             LD W (spRel (-2)) dst,
3188             FxTOy W (primRepToSize pk) dst dst]
3189     in
3190     returnUs (Any pk code__2)
3191
3192 ------------
3193 coerceFP2Int x
3194   = getRegister x               `thenUs` \ register ->
3195     getNewRegNCG IntRep         `thenUs` \ reg ->
3196     getNewRegNCG FloatRep       `thenUs` \ tmp ->
3197     let
3198         code = registerCode register reg
3199         src  = registerName register reg
3200         pk   = registerRep  register
3201
3202         code__2 dst = code . mkSeqInstrs [
3203             FxTOy (primRepToSize pk) W src tmp,
3204             ST W tmp (spRel (-2)),
3205             LD W (spRel (-2)) dst]
3206     in
3207     returnUs (Any IntRep code__2)
3208
3209 #endif {- sparc_TARGET_ARCH -}
3210 \end{code}
3211
3212 %************************************************************************
3213 %*                                                                      *
3214 \subsubsection{Coercing integer to @Char@...}
3215 %*                                                                      *
3216 %************************************************************************
3217
3218 Integer to character conversion.  Where applicable, we try to do this
3219 in one step if the original object is in memory.
3220
3221 \begin{code}
3222 chrCode :: StixTree -> UniqSM Register
3223
3224 #if alpha_TARGET_ARCH
3225
3226 chrCode x
3227   = getRegister x               `thenUs` \ register ->
3228     getNewRegNCG IntRep         `thenUs` \ reg ->
3229     let
3230         code = registerCode register reg
3231         src  = registerName register reg
3232         code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3233     in
3234     returnUs (Any IntRep code__2)
3235
3236 #endif {- alpha_TARGET_ARCH -}
3237 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3238 #if i386_TARGET_ARCH
3239
3240 chrCode x
3241   = getRegister x               `thenUs` \ register ->
3242     --getNewRegNCG IntRep       `thenUs` \ reg ->
3243     let
3244 --      fixedname = registerName register eax
3245         code__2 dst = let
3246                           code = registerCode register dst
3247                           src  = registerName register dst
3248                       in code .
3249                          if isFixed register && src /= dst
3250                          then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3251                                            AND L (OpImm (ImmInt 255)) (OpReg dst)]
3252                          else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
3253     in
3254     returnUs (Any IntRep code__2)
3255
3256 #endif {- i386_TARGET_ARCH -}
3257 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3258 #if sparc_TARGET_ARCH
3259
3260 chrCode (StInd pk mem)
3261   = getAmode mem                `thenUs` \ amode ->
3262     let
3263         code    = amodeCode amode
3264         src     = amodeAddr amode
3265         src_off = addrOffset src 3
3266         src__2  = case src_off of Just x -> x
3267         code__2 dst = if maybeToBool src_off then
3268                         code . mkSeqInstr (LD BU src__2 dst)
3269                     else
3270                         code . mkSeqInstrs [
3271                             LD (primRepToSize pk) src dst,
3272                             AND False dst (RIImm (ImmInt 255)) dst]
3273     in
3274     returnUs (Any pk code__2)
3275
3276 chrCode x
3277   = getRegister x               `thenUs` \ register ->
3278     getNewRegNCG IntRep         `thenUs` \ reg ->
3279     let
3280         code = registerCode register reg
3281         src  = registerName register reg
3282         code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
3283     in
3284     returnUs (Any IntRep code__2)
3285
3286 #endif {- sparc_TARGET_ARCH -}
3287 \end{code}
3288
3289 %************************************************************************
3290 %*                                                                      *
3291 \subsubsection{Absolute value on integers}
3292 %*                                                                      *
3293 %************************************************************************
3294
3295 Absolute value on integers, mostly for gmp size check macros.  Again,
3296 the argument cannot be an StInt, because genericOpt already folded
3297 constants.
3298
3299 If applicable, do not fill the delay slots here; you will confuse the
3300 register allocator.
3301
3302 \begin{code}
3303 absIntCode :: StixTree -> UniqSM Register
3304
3305 #if alpha_TARGET_ARCH
3306 absIntCode = panic "MachCode.absIntCode: not on Alphas"
3307 #endif {- alpha_TARGET_ARCH -}
3308
3309 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3310 #if i386_TARGET_ARCH
3311
3312 absIntCode x
3313   = getRegister x               `thenUs` \ register ->
3314     --getNewRegNCG IntRep       `thenUs` \ reg ->
3315     getUniqLabelNCG             `thenUs` \ lbl ->
3316     let
3317         code__2 dst = let code = registerCode register dst
3318                           src  = registerName register dst
3319                       in code . if isFixed register && dst /= src
3320                                 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3321                                                   TEST L (OpReg dst) (OpReg dst),
3322                                                   JXX GE lbl,
3323                                                   NEGI L (OpReg dst),
3324                                                   LABEL lbl]
3325                                 else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
3326                                                   JXX GE lbl,
3327                                                   NEGI L (OpReg src),
3328                                                   LABEL lbl]
3329     in
3330     returnUs (Any IntRep code__2)
3331
3332 #endif {- i386_TARGET_ARCH -}
3333 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3334 #if sparc_TARGET_ARCH
3335
3336 absIntCode x
3337   = getRegister x               `thenUs` \ register ->
3338     getNewRegNCG IntRep         `thenUs` \ reg ->
3339     getUniqLabelNCG             `thenUs` \ lbl ->
3340     let
3341         code = registerCode register reg
3342         src  = registerName register reg
3343         code__2 dst = code . mkSeqInstrs [
3344             SUB False True g0 (RIReg src) dst,
3345             BI GE False (ImmCLbl lbl), NOP,
3346             OR False g0 (RIReg src) dst,
3347             LABEL lbl]
3348     in
3349     returnUs (Any IntRep code__2)
3350
3351 #endif {- sparc_TARGET_ARCH -}
3352 \end{code}
3353