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