ghc/compiler/nativeGen/MachCode.lhs

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