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