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