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