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 )
  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 DataSegment,
 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       DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
 922
 923       Double2FloatOp -> trivialUFCode FloatRep  (FxTOy DF F) x
 924       Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
 925
 926       OrdOp          -> coerceIntCode IntRep x
 927       ChrOp          -> chrCode x
 928
 929       Float2IntOp    -> coerceFP2Int x
 930       Int2FloatOp    -> coerceInt2FP FloatRep x
 931       Double2IntOp   -> coerceFP2Int x
 932       Int2DoubleOp   -> coerceInt2FP DoubleRep x
 933
 934       other_op ->
 935         let
 936            fixed_x = if   is_float_op  -- promote to double
 937                      then StPrim Float2DoubleOp [x]
 938                      else x
 939         in
 940         getRegister (StCall fn cCallConv DoubleRep [fixed_x])
 941        where
 942         (is_float_op, fn)
 943           = case primop of
 944               FloatExpOp    -> (True,  SLIT("exp"))
 945               FloatLogOp    -> (True,  SLIT("log"))
 946               FloatSqrtOp   -> (True,  SLIT("sqrt"))
 947
 948               FloatSinOp    -> (True,  SLIT("sin"))
 949               FloatCosOp    -> (True,  SLIT("cos"))
 950               FloatTanOp    -> (True,  SLIT("tan"))
 951
 952               FloatAsinOp   -> (True,  SLIT("asin"))
 953               FloatAcosOp   -> (True,  SLIT("acos"))
 954               FloatAtanOp   -> (True,  SLIT("atan"))
 955
 956               FloatSinhOp   -> (True,  SLIT("sinh"))
 957               FloatCoshOp   -> (True,  SLIT("cosh"))
 958               FloatTanhOp   -> (True,  SLIT("tanh"))
 959
 960               DoubleExpOp   -> (False, SLIT("exp"))
 961               DoubleLogOp   -> (False, SLIT("log"))
 962               DoubleSqrtOp  -> (False, SLIT("sqrt"))
 963
 964               DoubleSinOp   -> (False, SLIT("sin"))
 965               DoubleCosOp   -> (False, SLIT("cos"))
 966               DoubleTanOp   -> (False, SLIT("tan"))
 967
 968               DoubleAsinOp  -> (False, SLIT("asin"))
 969               DoubleAcosOp  -> (False, SLIT("acos"))
 970               DoubleAtanOp  -> (False, SLIT("atan"))
 971
 972               DoubleSinhOp  -> (False, SLIT("sinh"))
 973               DoubleCoshOp  -> (False, SLIT("cosh"))
 974               DoubleTanhOp  -> (False, SLIT("tanh"))
 975
 976               other
 977                  -> pprPanic "getRegister(sparc,monadicprimop)"
 978                              (pprStixTree (StPrim primop [x]))
 979
 980 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
 981   = case primop of
 982       CharGtOp -> condIntReg GTT x y
 983       CharGeOp -> condIntReg GE x y
 984       CharEqOp -> condIntReg EQQ x y
 985       CharNeOp -> condIntReg NE x y
 986       CharLtOp -> condIntReg LTT x y
 987       CharLeOp -> condIntReg LE x y
 988
 989       IntGtOp  -> condIntReg GTT x y
 990       IntGeOp  -> condIntReg GE x y
 991       IntEqOp  -> condIntReg EQQ x y
 992       IntNeOp  -> condIntReg NE x y
 993       IntLtOp  -> condIntReg LTT x y
 994       IntLeOp  -> condIntReg LE x y
 995
 996       WordGtOp -> condIntReg GU  x y
 997       WordGeOp -> condIntReg GEU x y
 998       WordEqOp -> condIntReg EQQ  x y
 999       WordNeOp -> condIntReg NE  x y
1000       WordLtOp -> condIntReg LU  x y
1001       WordLeOp -> condIntReg LEU x y
1002
1003       AddrGtOp -> condIntReg GU  x y
1004       AddrGeOp -> condIntReg GEU x y
1005       AddrEqOp -> condIntReg EQQ  x y
1006       AddrNeOp -> condIntReg NE  x y
1007       AddrLtOp -> condIntReg LU  x y
1008       AddrLeOp -> condIntReg LEU x y
1009
1010       FloatGtOp -> condFltReg GTT x y
1011       FloatGeOp -> condFltReg GE x y
1012       FloatEqOp -> condFltReg EQQ x y
1013       FloatNeOp -> condFltReg NE x y
1014       FloatLtOp -> condFltReg LTT x y
1015       FloatLeOp -> condFltReg LE x y
1016
1017       DoubleGtOp -> condFltReg GTT x y
1018       DoubleGeOp -> condFltReg GE x y
1019       DoubleEqOp -> condFltReg EQQ x y
1020       DoubleNeOp -> condFltReg NE x y
1021       DoubleLtOp -> condFltReg LTT x y
1022       DoubleLeOp -> condFltReg LE x y
1023
1024       IntAddOp -> trivialCode (ADD False False) x y
1025       IntSubOp -> trivialCode (SUB False False) x y
1026
1027         -- ToDo: teach about V8+ SPARC mul/div instructions
1028       IntMulOp    -> imul_div SLIT(".umul") x y
1029       IntQuotOp   -> imul_div SLIT(".div")  x y
1030       IntRemOp    -> imul_div SLIT(".rem")  x y
1031
1032       FloatAddOp  -> trivialFCode FloatRep  FADD x y
1033       FloatSubOp  -> trivialFCode FloatRep  FSUB x y
1034       FloatMulOp  -> trivialFCode FloatRep  FMUL x y
1035       FloatDivOp  -> trivialFCode FloatRep  FDIV x y
1036
1037       DoubleAddOp -> trivialFCode DoubleRep FADD x y
1038       DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1039       DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1040       DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1041
1042       AndOp -> trivialCode (AND False) x y
1043       OrOp  -> trivialCode (OR  False) x y
1044       XorOp -> trivialCode (XOR False) x y
1045       SllOp -> trivialCode SLL x y
1046       SrlOp -> trivialCode SRL x y
1047
1048       ISllOp -> trivialCode SLL x y  --was: panic "SparcGen:isll"
1049       ISraOp -> trivialCode SRA x y  --was: panic "SparcGen:isra"
1050       ISrlOp -> trivialCode SRL x y  --was: panic "SparcGen:isrl"
1051
1052       FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1053                                            [promote x, promote y])
1054                        where promote x = StPrim Float2DoubleOp [x]
1055       DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
1056                                            [x, y])
1057
1058       other
1059          -> pprPanic "getRegister(sparc,dyadic primop)"
1060                      (pprStixTree (StPrim primop [x, y]))
1061
1062   where
1063     imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1064
1065 getRegister (StInd pk mem)
1066   = getAmode mem                    `thenNat` \ amode ->
1067     let
1068         code = amodeCode amode
1069         src   = amodeAddr amode
1070         size = primRepToSize pk
1071         code__2 dst = code `snocOL` LD size src dst
1072     in
1073         returnNat (Any pk code__2)
1074
1075 getRegister (StInt i)
1076   | fits13Bits i
1077   = let
1078         src = ImmInt (fromInteger i)
1079         code dst = unitOL (OR False g0 (RIImm src) dst)
1080     in
1081         returnNat (Any IntRep code)
1082
1083 getRegister leaf
1084   | maybeToBool imm
1085   = let
1086         code dst = toOL [
1087             SETHI (HI imm__2) dst,
1088             OR False dst (RIImm (LO imm__2)) dst]
1089     in
1090         returnNat (Any PtrRep code)
1091   | otherwise
1092   = pprPanic "getRegister(sparc)" (pprStixTree leaf)
1093   where
1094     imm = maybeImm leaf
1095     imm__2 = case imm of Just x -> x
1096
1097 #endif {- sparc_TARGET_ARCH -}
1098 \end{code}
1099
1100 %************************************************************************
1101 %*                                                                      *
1102 \subsection{The @Amode@ type}
1103 %*                                                                      *
1104 %************************************************************************
1105
1106 @Amode@s: Memory addressing modes passed up the tree.
1107 \begin{code}
1108 data Amode = Amode MachRegsAddr InstrBlock
1109
1110 amodeAddr (Amode addr _) = addr
1111 amodeCode (Amode _ code) = code
1112 \end{code}
1113
1114 Now, given a tree (the argument to an StInd) that references memory,
1115 produce a suitable addressing mode.
1116
1117 A Rule of the Game (tm) for Amodes: use of the addr bit must
1118 immediately follow use of the code part, since the code part puts
1119 values in registers which the addr then refers to.  So you can't put
1120 anything in between, lest it overwrite some of those registers.  If
1121 you need to do some other computation between the code part and use of
1122 the addr bit, first store the effective address from the amode in a
1123 temporary, then do the other computation, and then use the temporary:
1124
1125     code
1126     LEA amode, tmp
1127     ... other computation ...
1128     ... (tmp) ...
1129
1130 \begin{code}
1131 getAmode :: StixTree -> NatM Amode
1132
1133 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1134
1135 #if alpha_TARGET_ARCH
1136
1137 getAmode (StPrim IntSubOp [x, StInt i])
1138   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1139     getRegister x               `thenNat` \ register ->
1140     let
1141         code = registerCode register tmp
1142         reg  = registerName register tmp
1143         off  = ImmInt (-(fromInteger i))
1144     in
1145     returnNat (Amode (AddrRegImm reg off) code)
1146
1147 getAmode (StPrim IntAddOp [x, StInt i])
1148   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1149     getRegister x               `thenNat` \ register ->
1150     let
1151         code = registerCode register tmp
1152         reg  = registerName register tmp
1153         off  = ImmInt (fromInteger i)
1154     in
1155     returnNat (Amode (AddrRegImm reg off) code)
1156
1157 getAmode leaf
1158   | maybeToBool imm
1159   = returnNat (Amode (AddrImm imm__2) id)
1160   where
1161     imm = maybeImm leaf
1162     imm__2 = case imm of Just x -> x
1163
1164 getAmode other
1165   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1166     getRegister other           `thenNat` \ register ->
1167     let
1168         code = registerCode register tmp
1169         reg  = registerName register tmp
1170     in
1171     returnNat (Amode (AddrReg reg) code)
1172
1173 #endif {- alpha_TARGET_ARCH -}
1174 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1175 #if i386_TARGET_ARCH
1176
1177 getAmode (StPrim IntSubOp [x, StInt i])
1178   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1179     getRegister x               `thenNat` \ register ->
1180     let
1181         code = registerCode register tmp
1182         reg  = registerName register tmp
1183         off  = ImmInt (-(fromInteger i))
1184     in
1185     returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1186
1187 getAmode (StPrim IntAddOp [x, StInt i])
1188   | maybeToBool imm
1189   = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1190   where
1191     imm    = maybeImm x
1192     imm__2 = case imm of Just x -> x
1193
1194 getAmode (StPrim IntAddOp [x, StInt i])
1195   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1196     getRegister x               `thenNat` \ register ->
1197     let
1198         code = registerCode register tmp
1199         reg  = registerName register tmp
1200         off  = ImmInt (fromInteger i)
1201     in
1202     returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1203
1204 getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
1205   | shift == 0 || shift == 1 || shift == 2 || shift == 3
1206   = getNewRegNCG PtrRep         `thenNat` \ tmp1 ->
1207     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1208     getRegister x               `thenNat` \ register1 ->
1209     getRegister y               `thenNat` \ register2 ->
1210     let
1211         code1 = registerCode register1 tmp1
1212         reg1  = registerName register1 tmp1
1213         code2 = registerCode register2 tmp2
1214         reg2  = registerName register2 tmp2
1215         code__2 = code1 `appOL` code2
1216         base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1217     in
1218     returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1219                code__2)
1220
1221 getAmode leaf
1222   | maybeToBool imm
1223   = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1224   where
1225     imm    = maybeImm leaf
1226     imm__2 = case imm of Just x -> x
1227
1228 getAmode other
1229   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1230     getRegister other           `thenNat` \ register ->
1231     let
1232         code = registerCode register tmp
1233         reg  = registerName register tmp
1234     in
1235     returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1236
1237 #endif {- i386_TARGET_ARCH -}
1238 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1239 #if sparc_TARGET_ARCH
1240
1241 getAmode (StPrim IntSubOp [x, StInt i])
1242   | fits13Bits (-i)
1243   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1244     getRegister x               `thenNat` \ register ->
1245     let
1246         code = registerCode register tmp
1247         reg  = registerName register tmp
1248         off  = ImmInt (-(fromInteger i))
1249     in
1250     returnNat (Amode (AddrRegImm reg off) code)
1251
1252
1253 getAmode (StPrim IntAddOp [x, StInt i])
1254   | fits13Bits i
1255   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1256     getRegister x               `thenNat` \ register ->
1257     let
1258         code = registerCode register tmp
1259         reg  = registerName register tmp
1260         off  = ImmInt (fromInteger i)
1261     in
1262     returnNat (Amode (AddrRegImm reg off) code)
1263
1264 getAmode (StPrim IntAddOp [x, y])
1265   = getNewRegNCG PtrRep         `thenNat` \ tmp1 ->
1266     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1267     getRegister x               `thenNat` \ register1 ->
1268     getRegister y               `thenNat` \ register2 ->
1269     let
1270         code1 = registerCode register1 tmp1
1271         reg1  = registerName register1 tmp1
1272         code2 = registerCode register2 tmp2
1273         reg2  = registerName register2 tmp2
1274         code__2 = code1 `appOL` code2
1275     in
1276     returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1277
1278 getAmode leaf
1279   | maybeToBool imm
1280   = getNewRegNCG PtrRep             `thenNat` \ tmp ->
1281     let
1282         code = unitOL (SETHI (HI imm__2) tmp)
1283     in
1284     returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1285   where
1286     imm    = maybeImm leaf
1287     imm__2 = case imm of Just x -> x
1288
1289 getAmode other
1290   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1291     getRegister other           `thenNat` \ register ->
1292     let
1293         code = registerCode register tmp
1294         reg  = registerName register tmp
1295         off  = ImmInt 0
1296     in
1297     returnNat (Amode (AddrRegImm reg off) code)
1298
1299 #endif {- sparc_TARGET_ARCH -}
1300 \end{code}
1301
1302 %************************************************************************
1303 %*                                                                      *
1304 \subsection{The @CondCode@ type}
1305 %*                                                                      *
1306 %************************************************************************
1307
1308 Condition codes passed up the tree.
1309 \begin{code}
1310 data CondCode = CondCode Bool Cond InstrBlock
1311
1312 condName  (CondCode _ cond _)      = cond
1313 condFloat (CondCode is_float _ _) = is_float
1314 condCode  (CondCode _ _ code)      = code
1315 \end{code}
1316
1317 Set up a condition code for a conditional branch.
1318
1319 \begin{code}
1320 getCondCode :: StixTree -> NatM CondCode
1321
1322 #if alpha_TARGET_ARCH
1323 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1324 #endif {- alpha_TARGET_ARCH -}
1325 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1326
1327 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1328 -- yes, they really do seem to want exactly the same!
1329
1330 getCondCode (StPrim primop [x, y])
1331   = case primop of
1332       CharGtOp -> condIntCode GTT  x y
1333       CharGeOp -> condIntCode GE   x y
1334       CharEqOp -> condIntCode EQQ  x y
1335       CharNeOp -> condIntCode NE   x y
1336       CharLtOp -> condIntCode LTT  x y
1337       CharLeOp -> condIntCode LE   x y
1338
1339       IntGtOp  -> condIntCode GTT  x y
1340       IntGeOp  -> condIntCode GE   x y
1341       IntEqOp  -> condIntCode EQQ  x y
1342       IntNeOp  -> condIntCode NE   x y
1343       IntLtOp  -> condIntCode LTT  x y
1344       IntLeOp  -> condIntCode LE   x y
1345
1346       WordGtOp -> condIntCode GU   x y
1347       WordGeOp -> condIntCode GEU  x y
1348       WordEqOp -> condIntCode EQQ  x y
1349       WordNeOp -> condIntCode NE   x y
1350       WordLtOp -> condIntCode LU   x y
1351       WordLeOp -> condIntCode LEU  x y
1352
1353       AddrGtOp -> condIntCode GU   x y
1354       AddrGeOp -> condIntCode GEU  x y
1355       AddrEqOp -> condIntCode EQQ  x y
1356       AddrNeOp -> condIntCode NE   x y
1357       AddrLtOp -> condIntCode LU   x y
1358       AddrLeOp -> condIntCode LEU  x y
1359
1360       FloatGtOp -> condFltCode GTT x y
1361       FloatGeOp -> condFltCode GE  x y
1362       FloatEqOp -> condFltCode EQQ x y
1363       FloatNeOp -> condFltCode NE  x y
1364       FloatLtOp -> condFltCode LTT x y
1365       FloatLeOp -> condFltCode LE  x y
1366
1367       DoubleGtOp -> condFltCode GTT x y
1368       DoubleGeOp -> condFltCode GE  x y
1369       DoubleEqOp -> condFltCode EQQ x y
1370       DoubleNeOp -> condFltCode NE  x y
1371       DoubleLtOp -> condFltCode LTT x y
1372       DoubleLeOp -> condFltCode LE  x y
1373
1374 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1375 \end{code}
1376
1377 % -----------------
1378
1379 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1380 passed back up the tree.
1381
1382 \begin{code}
1383 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> NatM CondCode
1384
1385 #if alpha_TARGET_ARCH
1386 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1387 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1388 #endif {- alpha_TARGET_ARCH -}
1389
1390 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1391 #if i386_TARGET_ARCH
1392
1393 -- memory vs immediate
1394 condIntCode cond (StInd pk x) y
1395   | maybeToBool imm
1396   = getAmode x                  `thenNat` \ amode ->
1397     let
1398         code1 = amodeCode amode
1399         x__2  = amodeAddr amode
1400         sz    = primRepToSize pk
1401         code__2 = code1 `snocOL`
1402                   CMP sz (OpImm imm__2) (OpAddr x__2)
1403     in
1404     returnNat (CondCode False cond code__2)
1405   where
1406     imm    = maybeImm y
1407     imm__2 = case imm of Just x -> x
1408
1409 -- anything vs zero
1410 condIntCode cond x (StInt 0)
1411   = getRegister x               `thenNat` \ register1 ->
1412     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
1413     let
1414         code1 = registerCode register1 tmp1
1415         src1  = registerName register1 tmp1
1416         code__2 = code1 `snocOL`
1417                   TEST L (OpReg src1) (OpReg src1)
1418     in
1419     returnNat (CondCode False cond code__2)
1420
1421 -- anything vs immediate
1422 condIntCode cond x y
1423   | maybeToBool imm
1424   = getRegister x               `thenNat` \ register1 ->
1425     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
1426     let
1427         code1 = registerCode register1 tmp1
1428         src1  = registerName register1 tmp1
1429         code__2 = code1 `snocOL`
1430                   CMP L (OpImm imm__2) (OpReg src1)
1431     in
1432     returnNat (CondCode False cond code__2)
1433   where
1434     imm    = maybeImm y
1435     imm__2 = case imm of Just x -> x
1436
1437 -- memory vs anything
1438 condIntCode cond (StInd pk x) y
1439   = getAmode x                  `thenNat` \ amode_x ->
1440     getRegister y               `thenNat` \ reg_y ->
1441     getNewRegNCG IntRep         `thenNat` \ tmp ->
1442     let
1443         c_x   = amodeCode amode_x
1444         am_x  = amodeAddr amode_x
1445         c_y   = registerCode reg_y tmp
1446         r_y   = registerName reg_y tmp
1447         sz    = primRepToSize pk
1448
1449         -- optimisation: if there's no code for x, just an amode,
1450         -- use whatever reg y winds up in.  Assumes that c_y doesn't
1451         -- clobber any regs in the amode am_x, which I'm not sure is
1452         -- justified.  The otherwise clause makes the same assumption.
1453         code__2 | isNilOL c_x
1454                 = c_y `snocOL`
1455                   CMP sz (OpReg r_y) (OpAddr am_x)
1456
1457                 | otherwise
1458                 = c_y `snocOL`
1459                   MOV L (OpReg r_y) (OpReg tmp) `appOL`
1460                   c_x `snocOL`
1461                   CMP sz (OpReg tmp) (OpAddr am_x)
1462     in
1463     returnNat (CondCode False cond code__2)
1464
1465 -- anything vs memory
1466 --
1467 condIntCode cond y (StInd pk x)
1468   = getAmode x                  `thenNat` \ amode_x ->
1469     getRegister y               `thenNat` \ reg_y ->
1470     getNewRegNCG IntRep         `thenNat` \ tmp ->
1471     let
1472         c_x   = amodeCode amode_x
1473         am_x  = amodeAddr amode_x
1474         c_y   = registerCode reg_y tmp
1475         r_y   = registerName reg_y tmp
1476         sz    = primRepToSize pk
1477         -- same optimisation and nagging doubts as previous clause
1478         code__2 | isNilOL c_x
1479                 = c_y `snocOL`
1480                   CMP sz (OpAddr am_x) (OpReg r_y)
1481
1482                 | otherwise
1483                 = c_y `snocOL`
1484                   MOV L (OpReg r_y) (OpReg tmp) `appOL`
1485                   c_x `snocOL`
1486                   CMP sz (OpAddr am_x) (OpReg tmp)
1487     in
1488     returnNat (CondCode False cond code__2)
1489
1490 -- anything vs anything
1491 condIntCode cond x y
1492   = getRegister x               `thenNat` \ register1 ->
1493     getRegister y               `thenNat` \ register2 ->
1494     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
1495     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1496     let
1497         code1 = registerCode register1 tmp1
1498         src1  = registerName register1 tmp1
1499         code2 = registerCode register2 tmp2
1500         src2  = registerName register2 tmp2
1501         code__2 = code1 `snocOL`
1502                   MOV L (OpReg src1) (OpReg tmp1) `appOL`
1503                   code2 `snocOL`
1504                   CMP L (OpReg src2) (OpReg tmp1)
1505     in
1506     returnNat (CondCode False cond code__2)
1507
1508 -----------
1509 condFltCode cond x y
1510   = getRegister x               `thenNat` \ register1 ->
1511     getRegister y               `thenNat` \ register2 ->
1512     getNewRegNCG (registerRep register1)
1513                                 `thenNat` \ tmp1 ->
1514     getNewRegNCG (registerRep register2)
1515                                 `thenNat` \ tmp2 ->
1516     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
1517     let
1518         pk1   = registerRep register1
1519         code1 = registerCode register1 tmp1
1520         src1  = registerName register1 tmp1
1521
1522         code2 = registerCode register2 tmp2
1523         src2  = registerName register2 tmp2
1524
1525         code__2 | isAny register1
1526                 = code1 `appOL`   -- result in tmp1
1527                   code2 `snocOL`
1528                   GCMP (primRepToSize pk1) tmp1 src2
1529
1530                 | otherwise
1531                 = code1 `snocOL`
1532                   GMOV src1 tmp1 `appOL`
1533                   code2 `snocOL`
1534                   GCMP (primRepToSize pk1) tmp1 src2
1535
1536         {- On the 486, the flags set by FP compare are the unsigned ones!
1537            (This looks like a HACK to me.  WDP 96/03)
1538         -}
1539         fix_FP_cond :: Cond -> Cond
1540
1541         fix_FP_cond GE   = GEU
1542         fix_FP_cond GTT  = GU
1543         fix_FP_cond LTT  = LU
1544         fix_FP_cond LE   = LEU
1545         fix_FP_cond any  = any
1546     in
1547     returnNat (CondCode True (fix_FP_cond cond) code__2)
1548
1549
1550
1551 #endif {- i386_TARGET_ARCH -}
1552 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1553 #if sparc_TARGET_ARCH
1554
1555 condIntCode cond x (StInt y)
1556   | fits13Bits y
1557   = getRegister x               `thenNat` \ register ->
1558     getNewRegNCG IntRep         `thenNat` \ tmp ->
1559     let
1560         code = registerCode register tmp
1561         src1 = registerName register tmp
1562         src2 = ImmInt (fromInteger y)
1563         code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1564     in
1565     returnNat (CondCode False cond code__2)
1566
1567 condIntCode cond x y
1568   = getRegister x               `thenNat` \ register1 ->
1569     getRegister y               `thenNat` \ register2 ->
1570     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
1571     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1572     let
1573         code1 = registerCode register1 tmp1
1574         src1  = registerName register1 tmp1
1575         code2 = registerCode register2 tmp2
1576         src2  = registerName register2 tmp2
1577         code__2 = code1 `appOL` code2 `snocOL`
1578                   SUB False True src1 (RIReg src2) g0
1579     in
1580     returnNat (CondCode False cond code__2)
1581
1582 -----------
1583 condFltCode cond x y
1584   = getRegister x               `thenNat` \ register1 ->
1585     getRegister y               `thenNat` \ register2 ->
1586     getNewRegNCG (registerRep register1)
1587                                 `thenNat` \ tmp1 ->
1588     getNewRegNCG (registerRep register2)
1589                                 `thenNat` \ tmp2 ->
1590     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
1591     let
1592         promote x = FxTOy F DF x tmp
1593
1594         pk1   = registerRep register1
1595         code1 = registerCode register1 tmp1
1596         src1  = registerName register1 tmp1
1597
1598         pk2   = registerRep register2
1599         code2 = registerCode register2 tmp2
1600         src2  = registerName register2 tmp2
1601
1602         code__2 =
1603                 if pk1 == pk2 then
1604                     code1 `appOL` code2 `snocOL`
1605                     FCMP True (primRepToSize pk1) src1 src2
1606                 else if pk1 == FloatRep then
1607                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1608                     FCMP True DF tmp src2
1609                 else
1610                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1611                     FCMP True DF src1 tmp
1612     in
1613     returnNat (CondCode True cond code__2)
1614
1615 #endif {- sparc_TARGET_ARCH -}
1616 \end{code}
1617
1618 %************************************************************************
1619 %*                                                                      *
1620 \subsection{Generating assignments}
1621 %*                                                                      *
1622 %************************************************************************
1623
1624 Assignments are really at the heart of the whole code generation
1625 business.  Almost all top-level nodes of any real importance are
1626 assignments, which correspond to loads, stores, or register transfers.
1627 If we're really lucky, some of the register transfers will go away,
1628 because we can use the destination register to complete the code
1629 generation for the right hand side.  This only fails when the right
1630 hand side is forced into a fixed register (e.g. the result of a call).
1631
1632 \begin{code}
1633 assignIntCode, assignFltCode
1634         :: PrimRep -> StixTree -> StixTree -> NatM InstrBlock
1635
1636 #if alpha_TARGET_ARCH
1637
1638 assignIntCode pk (StInd _ dst) src
1639   = getNewRegNCG IntRep             `thenNat` \ tmp ->
1640     getAmode dst                    `thenNat` \ amode ->
1641     getRegister src                 `thenNat` \ register ->
1642     let
1643         code1   = amodeCode amode []
1644         dst__2  = amodeAddr amode
1645         code2   = registerCode register tmp []
1646         src__2  = registerName register tmp
1647         sz      = primRepToSize pk
1648         code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1649     in
1650     returnNat code__2
1651
1652 assignIntCode pk dst src
1653   = getRegister dst                         `thenNat` \ register1 ->
1654     getRegister src                         `thenNat` \ register2 ->
1655     let
1656         dst__2  = registerName register1 zeroh
1657         code    = registerCode register2 dst__2
1658         src__2  = registerName register2 dst__2
1659         code__2 = if isFixed register2
1660                   then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1661                   else code
1662     in
1663     returnNat code__2
1664
1665 #endif {- alpha_TARGET_ARCH -}
1666 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1667 #if i386_TARGET_ARCH
1668
1669 -- Destination of an assignment can only be reg or mem.
1670 -- This is the mem case.
1671 assignIntCode pk (StInd _ dst) src
1672   = getAmode dst                `thenNat` \ amode ->
1673     get_op_RI src               `thenNat` \ (codesrc, opsrc) ->
1674     getNewRegNCG PtrRep         `thenNat` \ tmp ->
1675     let
1676         -- In general, if the address computation for dst may require
1677         -- some insns preceding the addressing mode itself.  So there's
1678         -- no guarantee that the code for dst and the code for src won't
1679         -- write the same register.  This means either the address or
1680         -- the value needs to be copied into a temporary.  We detect the
1681         -- common case where the amode has no code, and elide the copy.
1682         codea   = amodeCode amode
1683         dst__a  = amodeAddr amode
1684
1685         code    | isNilOL codea
1686                 = codesrc `snocOL`
1687                   MOV (primRepToSize pk) opsrc (OpAddr dst__a)
1688                 | otherwise
1689
1690                 = codea `snocOL`
1691                   LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
1692                   codesrc `snocOL`
1693                   MOV (primRepToSize pk) opsrc
1694                       (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
1695     in
1696     returnNat code
1697   where
1698     get_op_RI
1699         :: StixTree
1700         -> NatM (InstrBlock,Operand)    -- code, operator
1701
1702     get_op_RI op
1703       | maybeToBool imm
1704       = returnNat (nilOL, OpImm imm_op)
1705       where
1706         imm    = maybeImm op
1707         imm_op = case imm of Just x -> x
1708
1709     get_op_RI op
1710       = getRegister op                  `thenNat` \ register ->
1711         getNewRegNCG (registerRep register)
1712                                         `thenNat` \ tmp ->
1713         let code = registerCode register tmp
1714             reg  = registerName register tmp
1715         in
1716         returnNat (code, OpReg reg)
1717
1718 -- Assign; dst is a reg, rhs is mem
1719 assignIntCode pk dst (StInd pks src)
1720   = getNewRegNCG PtrRep             `thenNat` \ tmp ->
1721     getAmode src                    `thenNat` \ amode ->
1722     getRegister dst                 `thenNat` \ reg_dst ->
1723     let
1724         c_addr  = amodeCode amode
1725         am_addr = amodeAddr amode
1726
1727         c_dst = registerCode reg_dst tmp  -- should be empty
1728         r_dst = registerName reg_dst tmp
1729         szs   = primRepToSize pks
1730         opc   = case szs of L -> MOV L ; B -> MOVZxL B
1731
1732         code  | isNilOL c_dst
1733               = c_addr `snocOL`
1734                 opc (OpAddr am_addr) (OpReg r_dst)
1735               | otherwise
1736               = pprPanic "assignIntCode(x86): bad dst(2)" empty
1737     in
1738     returnNat code
1739
1740 -- dst is a reg, but src could be anything
1741 assignIntCode pk dst src
1742   = getRegister dst                 `thenNat` \ registerd ->
1743     getRegister src                 `thenNat` \ registers ->
1744     getNewRegNCG IntRep             `thenNat` \ tmp ->
1745     let
1746         r_dst = registerName registerd tmp
1747         c_dst = registerCode registerd tmp -- should be empty
1748         r_src = registerName registers r_dst
1749         c_src = registerCode registers r_dst
1750
1751         code | isNilOL c_dst
1752              = c_src `snocOL`
1753                MOV L (OpReg r_src) (OpReg r_dst)
1754              | otherwise
1755              = pprPanic "assignIntCode(x86): bad dst(3)" empty
1756     in
1757     returnNat code
1758
1759 #endif {- i386_TARGET_ARCH -}
1760 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1761 #if sparc_TARGET_ARCH
1762
1763 assignIntCode pk (StInd _ dst) src
1764   = getNewRegNCG IntRep             `thenNat` \ tmp ->
1765     getAmode dst                    `thenNat` \ amode ->
1766     getRegister src                         `thenNat` \ register ->
1767     let
1768         code1   = amodeCode amode
1769         dst__2  = amodeAddr amode
1770         code2   = registerCode register tmp
1771         src__2  = registerName register tmp
1772         sz      = primRepToSize pk
1773         code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
1774     in
1775     returnNat code__2
1776
1777 assignIntCode pk dst src
1778   = getRegister dst                         `thenNat` \ register1 ->
1779     getRegister src                         `thenNat` \ register2 ->
1780     let
1781         dst__2  = registerName register1 g0
1782         code    = registerCode register2 dst__2
1783         src__2  = registerName register2 dst__2
1784         code__2 = if isFixed register2
1785                   then code `snocOL` OR False g0 (RIReg src__2) dst__2
1786                   else code
1787     in
1788     returnNat code__2
1789
1790 #endif {- sparc_TARGET_ARCH -}
1791 \end{code}
1792
1793 % --------------------------------
1794 Floating-point assignments:
1795 % --------------------------------
1796 \begin{code}
1797 #if alpha_TARGET_ARCH
1798
1799 assignFltCode pk (StInd _ dst) src
1800   = getNewRegNCG pk                 `thenNat` \ tmp ->
1801     getAmode dst                    `thenNat` \ amode ->
1802     getRegister src                         `thenNat` \ register ->
1803     let
1804         code1   = amodeCode amode []
1805         dst__2  = amodeAddr amode
1806         code2   = registerCode register tmp []
1807         src__2  = registerName register tmp
1808         sz      = primRepToSize pk
1809         code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1810     in
1811     returnNat code__2
1812
1813 assignFltCode pk dst src
1814   = getRegister dst                         `thenNat` \ register1 ->
1815     getRegister src                         `thenNat` \ register2 ->
1816     let
1817         dst__2  = registerName register1 zeroh
1818         code    = registerCode register2 dst__2
1819         src__2  = registerName register2 dst__2
1820         code__2 = if isFixed register2
1821                   then code . mkSeqInstr (FMOV src__2 dst__2)
1822                   else code
1823     in
1824     returnNat code__2
1825
1826 #endif {- alpha_TARGET_ARCH -}
1827 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1828 #if i386_TARGET_ARCH
1829
1830 -- dst is memory
1831 assignFltCode pk (StInd pk_dst addr) src
1832    | pk /= pk_dst
1833    = pprPanic "assignFltCode(x86): src/ind sz mismatch" empty
1834    | otherwise
1835    = getRegister src      `thenNat`  \ reg_src  ->
1836      getRegister addr     `thenNat`  \ reg_addr ->
1837      getNewRegNCG pk      `thenNat`  \ tmp_src  ->
1838      getNewRegNCG PtrRep  `thenNat`  \ tmp_addr ->
1839      let r_src  = registerName reg_src tmp_src
1840          c_src  = registerCode reg_src tmp_src
1841          r_addr = registerName reg_addr tmp_addr
1842          c_addr = registerCode reg_addr tmp_addr
1843          sz     = primRepToSize pk
1844
1845          code = c_src  `appOL`
1846                 -- no need to preserve r_src across the addr computation,
1847                 -- since r_src must be a float reg
1848                 -- whilst r_addr is an int reg
1849                 c_addr `snocOL`
1850                 GST sz r_src
1851                        (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
1852      in
1853      returnNat code
1854
1855 -- dst must be a (FP) register
1856 assignFltCode pk dst src
1857   = getRegister dst                 `thenNat` \ reg_dst ->
1858     getRegister src                 `thenNat` \ reg_src ->
1859     getNewRegNCG pk                 `thenNat` \ tmp ->
1860     let
1861         r_dst = registerName reg_dst tmp
1862         c_dst = registerCode reg_dst tmp -- should be empty
1863
1864         r_src = registerName reg_src r_dst
1865         c_src = registerCode reg_src r_dst
1866
1867         code | isNilOL c_dst
1868              = if   isFixed reg_src
1869                then c_src `snocOL` GMOV r_src r_dst
1870                else c_src
1871              | otherwise
1872              = pprPanic "assignFltCode(x86): lhs is not mem or reg"
1873                         empty
1874     in
1875     returnNat code
1876
1877
1878 #endif {- i386_TARGET_ARCH -}
1879 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1880 #if sparc_TARGET_ARCH
1881
1882 assignFltCode pk (StInd _ dst) src
1883   = getNewRegNCG pk                 `thenNat` \ tmp1 ->
1884     getAmode dst                    `thenNat` \ amode ->
1885     getRegister src                 `thenNat` \ register ->
1886     let
1887         sz      = primRepToSize pk
1888         dst__2  = amodeAddr amode
1889
1890         code1   = amodeCode amode
1891         code2   = registerCode register tmp1
1892
1893         src__2  = registerName register tmp1
1894         pk__2   = registerRep register
1895         sz__2   = primRepToSize pk__2
1896
1897         code__2 = code1 `appOL` code2 `appOL`
1898             if   pk == pk__2
1899             then unitOL (ST sz src__2 dst__2)
1900             else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1901     in
1902     returnNat code__2
1903
1904 assignFltCode pk dst src
1905   = getRegister dst                         `thenNat` \ register1 ->
1906     getRegister src                         `thenNat` \ register2 ->
1907     let
1908         pk__2   = registerRep register2
1909         sz__2   = primRepToSize pk__2
1910     in
1911     getNewRegNCG pk__2                      `thenNat` \ tmp ->
1912     let
1913         sz      = primRepToSize pk
1914         dst__2  = registerName register1 g0    -- must be Fixed
1915
1916
1917         reg__2  = if pk /= pk__2 then tmp else dst__2
1918
1919         code    = registerCode register2 reg__2
1920
1921         src__2  = registerName register2 reg__2
1922
1923         code__2 =
1924                 if pk /= pk__2 then
1925                      code `snocOL` FxTOy sz__2 sz src__2 dst__2
1926                 else if isFixed register2 then
1927                      code `snocOL` FMOV sz src__2 dst__2
1928                 else
1929                      code
1930     in
1931     returnNat code__2
1932
1933 #endif {- sparc_TARGET_ARCH -}
1934 \end{code}
1935
1936 %************************************************************************
1937 %*                                                                      *
1938 \subsection{Generating an unconditional branch}
1939 %*                                                                      *
1940 %************************************************************************
1941
1942 We accept two types of targets: an immediate CLabel or a tree that
1943 gets evaluated into a register.  Any CLabels which are AsmTemporaries
1944 are assumed to be in the local block of code, close enough for a
1945 branch instruction.  Other CLabels are assumed to be far away.
1946
1947 (If applicable) Do not fill the delay slots here; you will confuse the
1948 register allocator.
1949
1950 \begin{code}
1951 genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock
1952
1953 #if alpha_TARGET_ARCH
1954
1955 genJump (StCLbl lbl)
1956   | isAsmTemp lbl = returnInstr (BR target)
1957   | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1958   where
1959     target = ImmCLbl lbl
1960
1961 genJump tree
1962   = getRegister tree                `thenNat` \ register ->
1963     getNewRegNCG PtrRep             `thenNat` \ tmp ->
1964     let
1965         dst    = registerName register pv
1966         code   = registerCode register pv
1967         target = registerName register pv
1968     in
1969     if isFixed register then
1970         returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1971     else
1972     returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1973
1974 #endif {- alpha_TARGET_ARCH -}
1975 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1976 #if i386_TARGET_ARCH
1977
1978 genJump dsts (StInd pk mem)
1979   = getAmode mem                    `thenNat` \ amode ->
1980     let
1981         code   = amodeCode amode
1982         target = amodeAddr amode
1983     in
1984     returnNat (code `snocOL` JMP dsts (OpAddr target))
1985
1986 genJump dsts tree
1987   | maybeToBool imm
1988   = returnNat (unitOL (JMP dsts (OpImm target)))
1989
1990   | otherwise
1991   = getRegister tree                `thenNat` \ register ->
1992     getNewRegNCG PtrRep             `thenNat` \ tmp ->
1993     let
1994         code   = registerCode register tmp
1995         target = registerName register tmp
1996     in
1997     returnNat (code `snocOL` JMP dsts (OpReg target))
1998   where
1999     imm    = maybeImm tree
2000     target = case imm of Just x -> x
2001
2002 #endif {- i386_TARGET_ARCH -}
2003 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2004 #if sparc_TARGET_ARCH
2005
2006 genJump dsts (StCLbl lbl)
2007   | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2008   | isAsmTemp lbl    = returnNat (toOL [BI ALWAYS False target, NOP])
2009   | otherwise        = returnNat (toOL [CALL target 0 True, NOP])
2010   where
2011     target = ImmCLbl lbl
2012
2013 genJump dsts tree
2014   = getRegister tree                        `thenNat` \ register ->
2015     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2016     let
2017         code   = registerCode register tmp
2018         target = registerName register tmp
2019     in
2020     returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2021
2022 #endif {- sparc_TARGET_ARCH -}
2023 \end{code}
2024
2025 %************************************************************************
2026 %*                                                                      *
2027 \subsection{Conditional jumps}
2028 %*                                                                      *
2029 %************************************************************************
2030
2031 Conditional jumps are always to local labels, so we can use branch
2032 instructions.  We peek at the arguments to decide what kind of
2033 comparison to do.
2034
2035 ALPHA: For comparisons with 0, we're laughing, because we can just do
2036 the desired conditional branch.
2037
2038 I386: First, we have to ensure that the condition
2039 codes are set according to the supplied comparison operation.
2040
2041 SPARC: First, we have to ensure that the condition codes are set
2042 according to the supplied comparison operation.  We generate slightly
2043 different code for floating point comparisons, because a floating
2044 point operation cannot directly precede a @BF@.  We assume the worst
2045 and fill that slot with a @NOP@.
2046
2047 SPARC: Do not fill the delay slots here; you will confuse the register
2048 allocator.
2049
2050 \begin{code}
2051 genCondJump
2052     :: CLabel       -- the branch target
2053     -> StixTree     -- the condition on which to branch
2054     -> NatM InstrBlock
2055
2056 #if alpha_TARGET_ARCH
2057
2058 genCondJump lbl (StPrim op [x, StInt 0])
2059   = getRegister x                           `thenNat` \ register ->
2060     getNewRegNCG (registerRep register)
2061                                     `thenNat` \ tmp ->
2062     let
2063         code   = registerCode register tmp
2064         value  = registerName register tmp
2065         pk     = registerRep register
2066         target = ImmCLbl lbl
2067     in
2068     returnSeq code [BI (cmpOp op) value target]
2069   where
2070     cmpOp CharGtOp = GTT
2071     cmpOp CharGeOp = GE
2072     cmpOp CharEqOp = EQQ
2073     cmpOp CharNeOp = NE
2074     cmpOp CharLtOp = LTT
2075     cmpOp CharLeOp = LE
2076     cmpOp IntGtOp = GTT
2077     cmpOp IntGeOp = GE
2078     cmpOp IntEqOp = EQQ
2079     cmpOp IntNeOp = NE
2080     cmpOp IntLtOp = LTT
2081     cmpOp IntLeOp = LE
2082     cmpOp WordGtOp = NE
2083     cmpOp WordGeOp = ALWAYS
2084     cmpOp WordEqOp = EQQ
2085     cmpOp WordNeOp = NE
2086     cmpOp WordLtOp = NEVER
2087     cmpOp WordLeOp = EQQ
2088     cmpOp AddrGtOp = NE
2089     cmpOp AddrGeOp = ALWAYS
2090     cmpOp AddrEqOp = EQQ
2091     cmpOp AddrNeOp = NE
2092     cmpOp AddrLtOp = NEVER
2093     cmpOp AddrLeOp = EQQ
2094
2095 genCondJump lbl (StPrim op [x, StDouble 0.0])
2096   = getRegister x                           `thenNat` \ register ->
2097     getNewRegNCG (registerRep register)
2098                                     `thenNat` \ tmp ->
2099     let
2100         code   = registerCode register tmp
2101         value  = registerName register tmp
2102         pk     = registerRep register
2103         target = ImmCLbl lbl
2104     in
2105     returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2106   where
2107     cmpOp FloatGtOp = GTT
2108     cmpOp FloatGeOp = GE
2109     cmpOp FloatEqOp = EQQ
2110     cmpOp FloatNeOp = NE
2111     cmpOp FloatLtOp = LTT
2112     cmpOp FloatLeOp = LE
2113     cmpOp DoubleGtOp = GTT
2114     cmpOp DoubleGeOp = GE
2115     cmpOp DoubleEqOp = EQQ
2116     cmpOp DoubleNeOp = NE
2117     cmpOp DoubleLtOp = LTT
2118     cmpOp DoubleLeOp = LE
2119
2120 genCondJump lbl (StPrim op [x, y])
2121   | fltCmpOp op
2122   = trivialFCode pr instr x y       `thenNat` \ register ->
2123     getNewRegNCG DoubleRep          `thenNat` \ tmp ->
2124     let
2125         code   = registerCode register tmp
2126         result = registerName register tmp
2127         target = ImmCLbl lbl
2128     in
2129     returnNat (code . mkSeqInstr (BF cond result target))
2130   where
2131     pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2132
2133     fltCmpOp op = case op of
2134         FloatGtOp -> True
2135         FloatGeOp -> True
2136         FloatEqOp -> True
2137         FloatNeOp -> True
2138         FloatLtOp -> True
2139         FloatLeOp -> True
2140         DoubleGtOp -> True
2141         DoubleGeOp -> True
2142         DoubleEqOp -> True
2143         DoubleNeOp -> True
2144         DoubleLtOp -> True
2145         DoubleLeOp -> True
2146         _ -> False
2147     (instr, cond) = case op of
2148         FloatGtOp -> (FCMP TF LE, EQQ)
2149         FloatGeOp -> (FCMP TF LTT, EQQ)
2150         FloatEqOp -> (FCMP TF EQQ, NE)
2151         FloatNeOp -> (FCMP TF EQQ, EQQ)
2152         FloatLtOp -> (FCMP TF LTT, NE)
2153         FloatLeOp -> (FCMP TF LE, NE)
2154         DoubleGtOp -> (FCMP TF LE, EQQ)
2155         DoubleGeOp -> (FCMP TF LTT, EQQ)
2156         DoubleEqOp -> (FCMP TF EQQ, NE)
2157         DoubleNeOp -> (FCMP TF EQQ, EQQ)
2158         DoubleLtOp -> (FCMP TF LTT, NE)
2159         DoubleLeOp -> (FCMP TF LE, NE)
2160
2161 genCondJump lbl (StPrim op [x, y])
2162   = trivialCode instr x y           `thenNat` \ register ->
2163     getNewRegNCG IntRep             `thenNat` \ tmp ->
2164     let
2165         code   = registerCode register tmp
2166         result = registerName register tmp
2167         target = ImmCLbl lbl
2168     in
2169     returnNat (code . mkSeqInstr (BI cond result target))
2170   where
2171     (instr, cond) = case op of
2172         CharGtOp -> (CMP LE, EQQ)
2173         CharGeOp -> (CMP LTT, EQQ)
2174         CharEqOp -> (CMP EQQ, NE)
2175         CharNeOp -> (CMP EQQ, EQQ)
2176         CharLtOp -> (CMP LTT, NE)
2177         CharLeOp -> (CMP LE, NE)
2178         IntGtOp -> (CMP LE, EQQ)
2179         IntGeOp -> (CMP LTT, EQQ)
2180         IntEqOp -> (CMP EQQ, NE)
2181         IntNeOp -> (CMP EQQ, EQQ)
2182         IntLtOp -> (CMP LTT, NE)
2183         IntLeOp -> (CMP LE, NE)
2184         WordGtOp -> (CMP ULE, EQQ)
2185         WordGeOp -> (CMP ULT, EQQ)
2186         WordEqOp -> (CMP EQQ, NE)
2187         WordNeOp -> (CMP EQQ, EQQ)
2188         WordLtOp -> (CMP ULT, NE)
2189         WordLeOp -> (CMP ULE, NE)
2190         AddrGtOp -> (CMP ULE, EQQ)
2191         AddrGeOp -> (CMP ULT, EQQ)
2192         AddrEqOp -> (CMP EQQ, NE)
2193         AddrNeOp -> (CMP EQQ, EQQ)
2194         AddrLtOp -> (CMP ULT, NE)
2195         AddrLeOp -> (CMP ULE, NE)
2196
2197 #endif {- alpha_TARGET_ARCH -}
2198 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2199 #if i386_TARGET_ARCH
2200
2201 genCondJump lbl bool
2202   = getCondCode bool                `thenNat` \ condition ->
2203     let
2204         code   = condCode condition
2205         cond   = condName condition
2206     in
2207     returnNat (code `snocOL` JXX cond lbl)
2208
2209 #endif {- i386_TARGET_ARCH -}
2210 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2211 #if sparc_TARGET_ARCH
2212
2213 genCondJump lbl bool
2214   = getCondCode bool                `thenNat` \ condition ->
2215     let
2216         code   = condCode condition
2217         cond   = condName condition
2218         target = ImmCLbl lbl
2219     in
2220     returnNat (
2221        code `appOL`
2222        toOL (
2223          if   condFloat condition
2224          then [NOP, BF cond False target, NOP]
2225          else [BI cond False target, NOP]
2226        )
2227     )
2228
2229 #endif {- sparc_TARGET_ARCH -}
2230 \end{code}
2231
2232 %************************************************************************
2233 %*                                                                      *
2234 \subsection{Generating C calls}
2235 %*                                                                      *
2236 %************************************************************************
2237
2238 Now the biggest nightmare---calls.  Most of the nastiness is buried in
2239 @get_arg@, which moves the arguments to the correct registers/stack
2240 locations.  Apart from that, the code is easy.
2241
2242 (If applicable) Do not fill the delay slots here; you will confuse the
2243 register allocator.
2244
2245 \begin{code}
2246 genCCall
2247     :: FAST_STRING      -- function to call
2248     -> CallConv
2249     -> PrimRep          -- type of the result
2250     -> [StixTree]       -- arguments (of mixed type)
2251     -> NatM InstrBlock
2252
2253 #if alpha_TARGET_ARCH
2254
2255 genCCall fn cconv kind args
2256   = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2257                           `thenNat` \ ((unused,_), argCode) ->
2258     let
2259         nRegs = length allArgRegs - length unused
2260         code = asmSeqThen (map ($ []) argCode)
2261     in
2262         returnSeq code [
2263             LDA pv (AddrImm (ImmLab (ptext fn))),
2264             JSR ra (AddrReg pv) nRegs,
2265             LDGP gp (AddrReg ra)]
2266   where
2267     ------------------------
2268     {-  Try to get a value into a specific register (or registers) for
2269         a call.  The first 6 arguments go into the appropriate
2270         argument register (separate registers for integer and floating
2271         point arguments, but used in lock-step), and the remaining
2272         arguments are dumped to the stack, beginning at 0(sp).  Our
2273         first argument is a pair of the list of remaining argument
2274         registers to be assigned for this call and the next stack
2275         offset to use for overflowing arguments.  This way,
2276         @get_Arg@ can be applied to all of a call's arguments using
2277         @mapAccumLNat@.
2278     -}
2279     get_arg
2280         :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
2281         -> StixTree             -- Current argument
2282         -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2283
2284     -- We have to use up all of our argument registers first...
2285
2286     get_arg ((iDst,fDst):dsts, offset) arg
2287       = getRegister arg                     `thenNat` \ register ->
2288         let
2289             reg  = if isFloatingRep pk then fDst else iDst
2290             code = registerCode register reg
2291             src  = registerName register reg
2292             pk   = registerRep register
2293         in
2294         returnNat (
2295             if isFloatingRep pk then
2296                 ((dsts, offset), if isFixed register then
2297                     code . mkSeqInstr (FMOV src fDst)
2298                     else code)
2299             else
2300                 ((dsts, offset), if isFixed register then
2301                     code . mkSeqInstr (OR src (RIReg src) iDst)
2302                     else code))
2303
2304     -- Once we have run out of argument registers, we move to the
2305     -- stack...
2306
2307     get_arg ([], offset) arg
2308       = getRegister arg                 `thenNat` \ register ->
2309         getNewRegNCG (registerRep register)
2310                                         `thenNat` \ tmp ->
2311         let
2312             code = registerCode register tmp
2313             src  = registerName register tmp
2314             pk   = registerRep register
2315             sz   = primRepToSize pk
2316         in
2317         returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2318
2319 #endif {- alpha_TARGET_ARCH -}
2320 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2321 #if i386_TARGET_ARCH
2322
2323 genCCall fn cconv kind [StInt i]
2324   | fn == SLIT ("PerformGC_wrapper")
2325   = let call = toOL [
2326                   MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2327                   CALL (ImmLit (ptext (if   underscorePrefix
2328                                        then (SLIT ("_PerformGC_wrapper"))
2329                                        else (SLIT ("PerformGC_wrapper")))))
2330                ]
2331     in
2332     returnNat call
2333
2334
2335 genCCall fn cconv kind args
2336   = mapNat get_call_arg
2337            (reverse args)  `thenNat` \ sizes_n_codes ->
2338     getDeltaNat            `thenNat` \ delta ->
2339     let (sizes, codes) = unzip sizes_n_codes
2340         tot_arg_size   = sum sizes
2341         code2          = concatOL codes
2342         call = toOL [
2343                   CALL fn__2,
2344                   ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp),
2345                   DELTA (delta + tot_arg_size)
2346                ]
2347     in
2348     setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2349     returnNat (code2 `appOL` call)
2350
2351   where
2352     -- function names that begin with '.' are assumed to be special
2353     -- internally generated names like '.mul,' which don't get an
2354     -- underscore prefix
2355     -- ToDo:needed (WDP 96/03) ???
2356     fn__2 = case (_HEAD_ fn) of
2357               '.' -> ImmLit (ptext fn)
2358               _   -> ImmLab False (ptext fn)
2359
2360     arg_size DF = 8
2361     arg_size F  = 4
2362     arg_size _  = 4
2363
2364     ------------
2365     get_call_arg :: StixTree{-current argument-}
2366                     -> NatM (Int, InstrBlock)  -- argsz, code
2367
2368     get_call_arg arg
2369       = get_op arg                `thenNat` \ (code, reg, sz) ->
2370         getDeltaNat               `thenNat` \ delta ->
2371         arg_size sz               `bind`    \ size ->
2372         setDeltaNat (delta-size)  `thenNat` \ _ ->
2373         if   (case sz of DF -> True; F -> True; _ -> False)
2374         then returnNat (size,
2375                         code `appOL`
2376                         toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2377                               DELTA (delta-size),
2378                               GST sz reg (AddrBaseIndex (Just esp)
2379                                                         Nothing
2380                                                         (ImmInt 0))]
2381                        )
2382         else returnNat (size,
2383                         code `snocOL`
2384                         PUSH L (OpReg reg) `snocOL`
2385                         DELTA (delta-size)
2386                        )
2387     ------------
2388     get_op
2389         :: StixTree
2390         -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2391
2392     get_op op
2393       = getRegister op          `thenNat` \ register ->
2394         getNewRegNCG (registerRep register)
2395                                 `thenNat` \ tmp ->
2396         let
2397             code = registerCode register tmp
2398             reg  = registerName register tmp
2399             pk   = registerRep  register
2400             sz   = primRepToSize pk
2401         in
2402         returnNat (code, reg, sz)
2403
2404 #endif {- i386_TARGET_ARCH -}
2405 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2406 #if sparc_TARGET_ARCH
2407 {-
2408    The SPARC calling convention is an absolute
2409    nightmare.  The first 6x32 bits of arguments are mapped into
2410    %o0 through %o5, and the remaining arguments are dumped to the
2411    stack, beginning at [%sp+92].  (Note that %o6 == %sp.)
2412
2413    If we have to put args on the stack, move %o6==%sp down by
2414    the number of words to go on the stack, to ensure there's enough space.
2415
2416    According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2417    16 words above the stack pointer is a word for the address of
2418    a structure return value.  I use this as a temporary location
2419    for moving values from float to int regs.  Certainly it isn't
2420    safe to put anything in the 16 words starting at %sp, since
2421    this area can get trashed at any time due to window overflows
2422    caused by signal handlers.
2423
2424    A final complication (if the above isn't enough) is that
2425    we can't blithely calculate the arguments one by one into
2426    %o0 .. %o5.  Consider the following nested calls:
2427
2428        fff a (fff b c)
2429
2430    Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately
2431    the inner call will itself use %o0, which trashes the value put there
2432    in preparation for the outer call.  Upshot: we need to calculate the
2433    args into temporary regs, and move those to arg regs or onto the
2434    stack only immediately prior to the call proper.  Sigh.
2435 -}
2436
2437 genCCall fn cconv kind args
2438   = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2439     let (argcodes, vregss) = unzip argcode_and_vregs
2440         argcode            = concatOL argcodes
2441         vregs              = concat vregss
2442         n_argRegs          = length allArgRegs
2443         n_argRegs_used     = min (length vregs) n_argRegs
2444         (move_sp_down, move_sp_up)
2445            = let nn = length vregs - n_argRegs
2446                                    + 1 -- (for the road)
2447              in  if   nn <= 0
2448                  then (nilOL, nilOL)
2449                  else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2450         transfer_code
2451            = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2452         call
2453            = unitOL (CALL fn__2 n_argRegs_used False)
2454     in
2455         returnNat (argcode       `appOL`
2456                    move_sp_down  `appOL`
2457                    transfer_code `appOL`
2458                    call          `appOL`
2459                    unitOL NOP    `appOL`
2460                    move_sp_up)
2461   where
2462      -- function names that begin with '.' are assumed to be special
2463      -- internally generated names like '.mul,' which don't get an
2464      -- underscore prefix
2465      -- ToDo:needed (WDP 96/03) ???
2466      fn__2 = case (_HEAD_ fn) of
2467                 '.' -> ImmLit (ptext fn)
2468                 _   -> ImmLab False (ptext fn)
2469
2470      -- move args from the integer vregs into which they have been
2471      -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2472      move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2473
2474      move_final [] _ offset          -- all args done
2475         = []
2476
2477      move_final (v:vs) [] offset     -- out of aregs; move to stack
2478         = ST W v (spRel offset)
2479           : move_final vs [] (offset+1)
2480
2481      move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2482         = OR False g0 (RIReg v) a
2483           : move_final vs az offset
2484
2485      -- generate code to calculate an argument, and move it into one
2486      -- or two integer vregs.
2487      arg_to_int_vregs :: StixTree -> NatM (OrdList Instr, [Reg])
2488      arg_to_int_vregs arg
2489         = getRegister arg                     `thenNat` \ register ->
2490           getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2491           let code = registerCode register tmp
2492               src  = registerName register tmp
2493               pk   = registerRep register
2494           in
2495           -- the value is in src.  Get it into 1 or 2 int vregs.
2496           case pk of
2497              DoubleRep ->
2498                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2499                 getNewRegNCG WordRep  `thenNat` \ v2 ->
2500                 returnNat (
2501                    code                          `snocOL`
2502                    FMOV DF src f0                `snocOL`
2503                    ST   F  f0 (spRel 16)         `snocOL`
2504                    LD   W  (spRel 16) v1         `snocOL`
2505                    ST   F  (fPair f0) (spRel 16) `snocOL`
2506                    LD   W  (spRel 16) v2
2507                    ,
2508                    [v1,v2]
2509                 )
2510              FloatRep ->
2511                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2512                 returnNat (
2513                    code                    `snocOL`
2514                    ST   F  src (spRel 16)  `snocOL`
2515                    LD   W  (spRel 16) v1
2516                    ,
2517                    [v1]
2518                 )
2519              other ->
2520                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2521                 returnNat (
2522                    code `snocOL` OR False g0 (RIReg src) v1
2523                    ,
2524                    [v1]
2525                 )
2526 #endif {- sparc_TARGET_ARCH -}
2527 \end{code}
2528
2529 %************************************************************************
2530 %*                                                                      *
2531 \subsection{Support bits}
2532 %*                                                                      *
2533 %************************************************************************
2534
2535 %************************************************************************
2536 %*                                                                      *
2537 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2538 %*                                                                      *
2539 %************************************************************************
2540
2541 Turn those condition codes into integers now (when they appear on
2542 the right hand side of an assignment).
2543
2544 (If applicable) Do not fill the delay slots here; you will confuse the
2545 register allocator.
2546
2547 \begin{code}
2548 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2549
2550 #if alpha_TARGET_ARCH
2551 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2552 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2553 #endif {- alpha_TARGET_ARCH -}
2554
2555 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2556 #if i386_TARGET_ARCH
2557
2558 condIntReg cond x y
2559   = condIntCode cond x y        `thenNat` \ condition ->
2560     getNewRegNCG IntRep         `thenNat` \ tmp ->
2561     let
2562         code = condCode condition
2563         cond = condName condition
2564         code__2 dst = code `appOL` toOL [
2565             SETCC cond (OpReg tmp),
2566             AND L (OpImm (ImmInt 1)) (OpReg tmp),
2567             MOV L (OpReg tmp) (OpReg dst)]
2568     in
2569     returnNat (Any IntRep code__2)
2570
2571 condFltReg cond x y
2572   = getNatLabelNCG              `thenNat` \ lbl1 ->
2573     getNatLabelNCG              `thenNat` \ lbl2 ->
2574     condFltCode cond x y        `thenNat` \ condition ->
2575     let
2576         code = condCode condition
2577         cond = condName condition
2578         code__2 dst = code `appOL` toOL [
2579             JXX cond lbl1,
2580             MOV L (OpImm (ImmInt 0)) (OpReg dst),
2581             JXX ALWAYS lbl2,
2582             LABEL lbl1,
2583             MOV L (OpImm (ImmInt 1)) (OpReg dst),
2584             LABEL lbl2]
2585     in
2586     returnNat (Any IntRep code__2)
2587
2588 #endif {- i386_TARGET_ARCH -}
2589 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2590 #if sparc_TARGET_ARCH
2591
2592 condIntReg EQQ x (StInt 0)
2593   = getRegister x               `thenNat` \ register ->
2594     getNewRegNCG IntRep         `thenNat` \ tmp ->
2595     let
2596         code = registerCode register tmp
2597         src  = registerName register tmp
2598         code__2 dst = code `appOL` toOL [
2599             SUB False True g0 (RIReg src) g0,
2600             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2601     in
2602     returnNat (Any IntRep code__2)
2603
2604 condIntReg EQQ x y
2605   = getRegister x               `thenNat` \ register1 ->
2606     getRegister y               `thenNat` \ register2 ->
2607     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2608     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
2609     let
2610         code1 = registerCode register1 tmp1
2611         src1  = registerName register1 tmp1
2612         code2 = registerCode register2 tmp2
2613         src2  = registerName register2 tmp2
2614         code__2 dst = code1 `appOL` code2 `appOL` toOL [
2615             XOR False src1 (RIReg src2) dst,
2616             SUB False True g0 (RIReg dst) g0,
2617             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2618     in
2619     returnNat (Any IntRep code__2)
2620
2621 condIntReg NE x (StInt 0)
2622   = getRegister x               `thenNat` \ register ->
2623     getNewRegNCG IntRep         `thenNat` \ tmp ->
2624     let
2625         code = registerCode register tmp
2626         src  = registerName register tmp
2627         code__2 dst = code `appOL` toOL [
2628             SUB False True g0 (RIReg src) g0,
2629             ADD True False g0 (RIImm (ImmInt 0)) dst]
2630     in
2631     returnNat (Any IntRep code__2)
2632
2633 condIntReg NE x y
2634   = getRegister x               `thenNat` \ register1 ->
2635     getRegister y               `thenNat` \ register2 ->
2636     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2637     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
2638     let
2639         code1 = registerCode register1 tmp1
2640         src1  = registerName register1 tmp1
2641         code2 = registerCode register2 tmp2
2642         src2  = registerName register2 tmp2
2643         code__2 dst = code1 `appOL` code2 `appOL` toOL [
2644             XOR False src1 (RIReg src2) dst,
2645             SUB False True g0 (RIReg dst) g0,
2646             ADD True False g0 (RIImm (ImmInt 0)) dst]
2647     in
2648     returnNat (Any IntRep code__2)
2649
2650 condIntReg cond x y
2651   = getNatLabelNCG              `thenNat` \ lbl1 ->
2652     getNatLabelNCG              `thenNat` \ lbl2 ->
2653     condIntCode cond x y        `thenNat` \ condition ->
2654     let
2655         code = condCode condition
2656         cond = condName condition
2657         code__2 dst = code `appOL` toOL [
2658             BI cond False (ImmCLbl lbl1), NOP,
2659             OR False g0 (RIImm (ImmInt 0)) dst,
2660             BI ALWAYS False (ImmCLbl lbl2), NOP,
2661             LABEL lbl1,
2662             OR False g0 (RIImm (ImmInt 1)) dst,
2663             LABEL lbl2]
2664     in
2665     returnNat (Any IntRep code__2)
2666
2667 condFltReg cond x y
2668   = getNatLabelNCG              `thenNat` \ lbl1 ->
2669     getNatLabelNCG              `thenNat` \ lbl2 ->
2670     condFltCode cond x y        `thenNat` \ condition ->
2671     let
2672         code = condCode condition
2673         cond = condName condition
2674         code__2 dst = code `appOL` toOL [
2675             NOP,
2676             BF cond False (ImmCLbl lbl1), NOP,
2677             OR False g0 (RIImm (ImmInt 0)) dst,
2678             BI ALWAYS False (ImmCLbl lbl2), NOP,
2679             LABEL lbl1,
2680             OR False g0 (RIImm (ImmInt 1)) dst,
2681             LABEL lbl2]
2682     in
2683     returnNat (Any IntRep code__2)
2684
2685 #endif {- sparc_TARGET_ARCH -}
2686 \end{code}
2687
2688 %************************************************************************
2689 %*                                                                      *
2690 \subsubsection{@trivial*Code@: deal with trivial instructions}
2691 %*                                                                      *
2692 %************************************************************************
2693
2694 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2695 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions.  Only look
2696 for constants on the right hand side, because that's where the generic
2697 optimizer will have put them.
2698
2699 Similarly, for unary instructions, we don't have to worry about
2700 matching an StInt as the argument, because genericOpt will already
2701 have handled the constant-folding.
2702
2703 \begin{code}
2704 trivialCode
2705     :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2706       ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2707                      -> Maybe (Operand -> Operand -> Instr)
2708       ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2709       ,)))
2710     -> StixTree -> StixTree -- the two arguments
2711     -> NatM Register
2712
2713 trivialFCode
2714     :: PrimRep
2715     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2716       ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2717       ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2718       ,)))
2719     -> StixTree -> StixTree -- the two arguments
2720     -> NatM Register
2721
2722 trivialUCode
2723     :: IF_ARCH_alpha((RI -> Reg -> Instr)
2724       ,IF_ARCH_i386 ((Operand -> Instr)
2725       ,IF_ARCH_sparc((RI -> Reg -> Instr)
2726       ,)))
2727     -> StixTree -- the one argument
2728     -> NatM Register
2729
2730 trivialUFCode
2731     :: PrimRep
2732     -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2733       ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2734       ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2735       ,)))
2736     -> StixTree -- the one argument
2737     -> NatM Register
2738
2739 #if alpha_TARGET_ARCH
2740
2741 trivialCode instr x (StInt y)
2742   | fits8Bits y
2743   = getRegister x               `thenNat` \ register ->
2744     getNewRegNCG IntRep         `thenNat` \ tmp ->
2745     let
2746         code = registerCode register tmp
2747         src1 = registerName register tmp
2748         src2 = ImmInt (fromInteger y)
2749         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2750     in
2751     returnNat (Any IntRep code__2)
2752
2753 trivialCode instr x y
2754   = getRegister x               `thenNat` \ register1 ->
2755     getRegister y               `thenNat` \ register2 ->
2756     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2757     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
2758     let
2759         code1 = registerCode register1 tmp1 []
2760         src1  = registerName register1 tmp1
2761         code2 = registerCode register2 tmp2 []
2762         src2  = registerName register2 tmp2
2763         code__2 dst = asmSeqThen [code1, code2] .
2764                      mkSeqInstr (instr src1 (RIReg src2) dst)
2765     in
2766     returnNat (Any IntRep code__2)
2767
2768 ------------
2769 trivialUCode instr x
2770   = getRegister x               `thenNat` \ register ->
2771     getNewRegNCG IntRep         `thenNat` \ tmp ->
2772     let
2773         code = registerCode register tmp
2774         src  = registerName register tmp
2775         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2776     in
2777     returnNat (Any IntRep code__2)
2778
2779 ------------
2780 trivialFCode _ instr x y
2781   = getRegister x               `thenNat` \ register1 ->
2782     getRegister y               `thenNat` \ register2 ->
2783     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
2784     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
2785     let
2786         code1 = registerCode register1 tmp1
2787         src1  = registerName register1 tmp1
2788
2789         code2 = registerCode register2 tmp2
2790         src2  = registerName register2 tmp2
2791
2792         code__2 dst = asmSeqThen [code1 [], code2 []] .
2793                       mkSeqInstr (instr src1 src2 dst)
2794     in
2795     returnNat (Any DoubleRep code__2)
2796
2797 trivialUFCode _ instr x
2798   = getRegister x               `thenNat` \ register ->
2799     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
2800     let
2801         code = registerCode register tmp
2802         src  = registerName register tmp
2803         code__2 dst = code . mkSeqInstr (instr src dst)
2804     in
2805     returnNat (Any DoubleRep code__2)
2806
2807 #endif {- alpha_TARGET_ARCH -}
2808 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2809 #if i386_TARGET_ARCH
2810 \end{code}
2811 The Rules of the Game are:
2812
2813 * You cannot assume anything about the destination register dst;
2814   it may be anything, including a fixed reg.
2815
2816 * You may compute an operand into a fixed reg, but you may not
2817   subsequently change the contents of that fixed reg.  If you
2818   want to do so, first copy the value either to a temporary
2819   or into dst.  You are free to modify dst even if it happens
2820   to be a fixed reg -- that's not your problem.
2821
2822 * You cannot assume that a fixed reg will stay live over an
2823   arbitrary computation.  The same applies to the dst reg.
2824
2825 * Temporary regs obtained from getNewRegNCG are distinct from
2826   each other and from all other regs, and stay live over
2827   arbitrary computations.
2828
2829 \begin{code}
2830
2831 trivialCode instr maybe_revinstr a b
2832
2833   | is_imm_b
2834   = getRegister a                         `thenNat` \ rega ->
2835     let mkcode dst
2836           = if   isAny rega
2837             then registerCode rega dst      `bind` \ code_a ->
2838                  code_a `snocOL`
2839                  instr (OpImm imm_b) (OpReg dst)
2840             else registerCodeF rega         `bind` \ code_a ->
2841                  registerNameF rega         `bind` \ r_a ->
2842                  code_a `snocOL`
2843                  MOV L (OpReg r_a) (OpReg dst) `snocOL`
2844                  instr (OpImm imm_b) (OpReg dst)
2845     in
2846     returnNat (Any IntRep mkcode)
2847
2848   | is_imm_a
2849   = getRegister b                         `thenNat` \ regb ->
2850     getNewRegNCG IntRep                   `thenNat` \ tmp ->
2851     let revinstr_avail = maybeToBool maybe_revinstr
2852         revinstr       = case maybe_revinstr of Just ri -> ri
2853         mkcode dst
2854           | revinstr_avail
2855           = if   isAny regb
2856             then registerCode regb dst      `bind` \ code_b ->
2857                  code_b `snocOL`
2858                  revinstr (OpImm imm_a) (OpReg dst)
2859             else registerCodeF regb         `bind` \ code_b ->
2860                  registerNameF regb         `bind` \ r_b ->
2861                  code_b `snocOL`
2862                  MOV L (OpReg r_b) (OpReg dst) `snocOL`
2863                  revinstr (OpImm imm_a) (OpReg dst)
2864
2865           | otherwise
2866           = if   isAny regb
2867             then registerCode regb tmp      `bind` \ code_b ->
2868                  code_b `snocOL`
2869                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2870                  instr (OpReg tmp) (OpReg dst)
2871             else registerCodeF regb         `bind` \ code_b ->
2872                  registerNameF regb         `bind` \ r_b ->
2873                  code_b `snocOL`
2874                  MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2875                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2876                  instr (OpReg tmp) (OpReg dst)
2877     in
2878     returnNat (Any IntRep mkcode)
2879
2880   | otherwise
2881   = getRegister a                         `thenNat` \ rega ->
2882     getRegister b                         `thenNat` \ regb ->
2883     getNewRegNCG IntRep                   `thenNat` \ tmp ->
2884     let mkcode dst
2885           = case (isAny rega, isAny regb) of
2886               (True, True)
2887                  -> registerCode regb tmp   `bind` \ code_b ->
2888                     registerCode rega dst   `bind` \ code_a ->
2889                     code_b `appOL`
2890                     code_a `snocOL`
2891                     instr (OpReg tmp) (OpReg dst)
2892               (True, False)
2893                  -> registerCode  rega tmp  `bind` \ code_a ->
2894                     registerCodeF regb      `bind` \ code_b ->
2895                     registerNameF regb      `bind` \ r_b ->
2896                     code_a `appOL`
2897                     code_b `snocOL`
2898                     instr (OpReg r_b) (OpReg tmp) `snocOL`
2899                     MOV L (OpReg tmp) (OpReg dst)
2900               (False, True)
2901                  -> registerCode  regb tmp  `bind` \ code_b ->
2902                     registerCodeF rega      `bind` \ code_a ->
2903                     registerNameF rega      `bind` \ r_a ->
2904                     code_b `appOL`
2905                     code_a `snocOL`
2906                     MOV L (OpReg r_a) (OpReg dst) `snocOL`
2907                     instr (OpReg tmp) (OpReg dst)
2908               (False, False)
2909                  -> registerCodeF  rega     `bind` \ code_a ->
2910                     registerNameF  rega     `bind` \ r_a ->
2911                     registerCodeF  regb     `bind` \ code_b ->
2912                     registerNameF  regb     `bind` \ r_b ->
2913                     code_a `snocOL`
2914                     MOV L (OpReg r_a) (OpReg tmp) `appOL`
2915                     code_b `snocOL`
2916                     instr (OpReg r_b) (OpReg tmp) `snocOL`
2917                     MOV L (OpReg tmp) (OpReg dst)
2918     in
2919     returnNat (Any IntRep mkcode)
2920
2921     where
2922        maybe_imm_a = maybeImm a
2923        is_imm_a    = maybeToBool maybe_imm_a
2924        imm_a       = case maybe_imm_a of Just imm -> imm
2925
2926        maybe_imm_b = maybeImm b
2927        is_imm_b    = maybeToBool maybe_imm_b
2928        imm_b       = case maybe_imm_b of Just imm -> imm
2929
2930
2931 -----------
2932 trivialUCode instr x
2933   = getRegister x               `thenNat` \ register ->
2934     let
2935         code__2 dst = let code = registerCode register dst
2936                           src  = registerName register dst
2937                       in code `appOL`
2938                          if   isFixed register && dst /= src
2939                          then toOL [MOV L (OpReg src) (OpReg dst),
2940                                     instr (OpReg dst)]
2941                          else unitOL (instr (OpReg src))
2942     in
2943     returnNat (Any IntRep code__2)
2944
2945 -----------
2946 trivialFCode pk instr x y
2947   = getRegister x               `thenNat` \ register1 ->
2948     getRegister y               `thenNat` \ register2 ->
2949     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
2950     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
2951     let
2952         code1 = registerCode register1 tmp1
2953         src1  = registerName register1 tmp1
2954
2955         code2 = registerCode register2 tmp2
2956         src2  = registerName register2 tmp2
2957
2958         code__2 dst
2959            -- treat the common case specially: both operands in
2960            -- non-fixed regs.
2961            | isAny register1 && isAny register2
2962            = code1 `appOL`
2963              code2 `snocOL`
2964              instr (primRepToSize pk) src1 src2 dst
2965
2966            -- be paranoid (and inefficient)
2967            | otherwise
2968            = code1 `snocOL` GMOV src1 tmp1  `appOL`
2969              code2 `snocOL`
2970              instr (primRepToSize pk) tmp1 src2 dst
2971     in
2972     returnNat (Any pk code__2)
2973
2974
2975 -------------
2976 trivialUFCode pk instr x
2977   = getRegister x               `thenNat` \ register ->
2978     getNewRegNCG pk             `thenNat` \ tmp ->
2979     let
2980         code = registerCode register tmp
2981         src  = registerName register tmp
2982         code__2 dst = code `snocOL` instr src dst
2983     in
2984     returnNat (Any pk code__2)
2985
2986 #endif {- i386_TARGET_ARCH -}
2987 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2988 #if sparc_TARGET_ARCH
2989
2990 trivialCode instr x (StInt y)
2991   | fits13Bits y
2992   = getRegister x               `thenNat` \ register ->
2993     getNewRegNCG IntRep         `thenNat` \ tmp ->
2994     let
2995         code = registerCode register tmp
2996         src1 = registerName register tmp
2997         src2 = ImmInt (fromInteger y)
2998         code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
2999     in
3000     returnNat (Any IntRep code__2)
3001
3002 trivialCode instr x y
3003   = getRegister x               `thenNat` \ register1 ->
3004     getRegister y               `thenNat` \ register2 ->
3005     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3006     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3007     let
3008         code1 = registerCode register1 tmp1
3009         src1  = registerName register1 tmp1
3010         code2 = registerCode register2 tmp2
3011         src2  = registerName register2 tmp2
3012         code__2 dst = code1 `appOL` code2 `snocOL`
3013                       instr src1 (RIReg src2) dst
3014     in
3015     returnNat (Any IntRep code__2)
3016
3017 ------------
3018 trivialFCode pk instr x y
3019   = getRegister x               `thenNat` \ register1 ->
3020     getRegister y               `thenNat` \ register2 ->
3021     getNewRegNCG (registerRep register1)
3022                                 `thenNat` \ tmp1 ->
3023     getNewRegNCG (registerRep register2)
3024                                 `thenNat` \ tmp2 ->
3025     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3026     let
3027         promote x = FxTOy F DF x tmp
3028
3029         pk1   = registerRep register1
3030         code1 = registerCode register1 tmp1
3031         src1  = registerName register1 tmp1
3032
3033         pk2   = registerRep register2
3034         code2 = registerCode register2 tmp2
3035         src2  = registerName register2 tmp2
3036
3037         code__2 dst =
3038                 if pk1 == pk2 then
3039                     code1 `appOL` code2 `snocOL`
3040                     instr (primRepToSize pk) src1 src2 dst
3041                 else if pk1 == FloatRep then
3042                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3043                     instr DF tmp src2 dst
3044                 else
3045                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3046                     instr DF src1 tmp dst
3047     in
3048     returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3049
3050 ------------
3051 trivialUCode instr x
3052   = getRegister x               `thenNat` \ register ->
3053     getNewRegNCG IntRep         `thenNat` \ tmp ->
3054     let
3055         code = registerCode register tmp
3056         src  = registerName register tmp
3057         code__2 dst = code `snocOL` instr (RIReg src) dst
3058     in
3059     returnNat (Any IntRep code__2)
3060
3061 -------------
3062 trivialUFCode pk instr x
3063   = getRegister x               `thenNat` \ register ->
3064     getNewRegNCG pk             `thenNat` \ tmp ->
3065     let
3066         code = registerCode register tmp
3067         src  = registerName register tmp
3068         code__2 dst = code `snocOL` instr src dst
3069     in
3070     returnNat (Any pk code__2)
3071
3072 #endif {- sparc_TARGET_ARCH -}
3073 \end{code}
3074
3075 %************************************************************************
3076 %*                                                                      *
3077 \subsubsection{Coercing to/from integer/floating-point...}
3078 %*                                                                      *
3079 %************************************************************************
3080
3081 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3082 to be generated.  Here we just change the type on the Register passed
3083 on up.  The code is machine-independent.
3084
3085 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3086 conversions.  We have to store temporaries in memory to move
3087 between the integer and the floating point register sets.
3088
3089 \begin{code}
3090 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3091 coerceFltCode ::            StixTree -> NatM Register
3092
3093 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3094 coerceFP2Int ::            StixTree -> NatM Register
3095
3096 coerceIntCode pk x
3097   = getRegister x               `thenNat` \ register ->
3098     returnNat (
3099     case register of
3100         Fixed _ reg code -> Fixed pk reg code
3101         Any   _ code     -> Any   pk code
3102     )
3103
3104 -------------
3105 coerceFltCode x
3106   = getRegister x               `thenNat` \ register ->
3107     returnNat (
3108     case register of
3109         Fixed _ reg code -> Fixed DoubleRep reg code
3110         Any   _ code     -> Any   DoubleRep code
3111     )
3112 \end{code}
3113
3114 \begin{code}
3115 #if alpha_TARGET_ARCH
3116
3117 coerceInt2FP _ x
3118   = getRegister x               `thenNat` \ register ->
3119     getNewRegNCG IntRep         `thenNat` \ reg ->
3120     let
3121         code = registerCode register reg
3122         src  = registerName register reg
3123
3124         code__2 dst = code . mkSeqInstrs [
3125             ST Q src (spRel 0),
3126             LD TF dst (spRel 0),
3127             CVTxy Q TF dst dst]
3128     in
3129     returnNat (Any DoubleRep code__2)
3130
3131 -------------
3132 coerceFP2Int x
3133   = getRegister x               `thenNat` \ register ->
3134     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3135     let
3136         code = registerCode register tmp
3137         src  = registerName register tmp
3138
3139         code__2 dst = code . mkSeqInstrs [
3140             CVTxy TF Q src tmp,
3141             ST TF tmp (spRel 0),
3142             LD Q dst (spRel 0)]
3143     in
3144     returnNat (Any IntRep code__2)
3145
3146 #endif {- alpha_TARGET_ARCH -}
3147 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3148 #if i386_TARGET_ARCH
3149
3150 coerceInt2FP pk x
3151   = getRegister x               `thenNat` \ register ->
3152     getNewRegNCG IntRep         `thenNat` \ reg ->
3153     let
3154         code = registerCode register reg
3155         src  = registerName register reg
3156         opc  = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3157         code__2 dst = code `snocOL` opc src dst
3158     in
3159     returnNat (Any pk code__2)
3160
3161 ------------
3162 coerceFP2Int x
3163   = getRegister x               `thenNat` \ register ->
3164     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3165     let
3166         code = registerCode register tmp
3167         src  = registerName register tmp
3168         pk   = registerRep register
3169
3170         opc  = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3171         code__2 dst = code `snocOL` opc src dst
3172     in
3173     returnNat (Any IntRep code__2)
3174
3175 #endif {- i386_TARGET_ARCH -}
3176 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3177 #if sparc_TARGET_ARCH
3178
3179 coerceInt2FP pk x
3180   = getRegister x               `thenNat` \ register ->
3181     getNewRegNCG IntRep         `thenNat` \ reg ->
3182     let
3183         code = registerCode register reg
3184         src  = registerName register reg
3185
3186         code__2 dst = code `appOL` toOL [
3187             ST W src (spRel (-2)),
3188             LD W (spRel (-2)) dst,
3189             FxTOy W (primRepToSize pk) dst dst]
3190     in
3191     returnNat (Any pk code__2)
3192
3193 ------------
3194 coerceFP2Int x
3195   = getRegister x               `thenNat` \ register ->
3196     getNewRegNCG IntRep         `thenNat` \ reg ->
3197     getNewRegNCG FloatRep       `thenNat` \ tmp ->
3198     let
3199         code = registerCode register reg
3200         src  = registerName register reg
3201         pk   = registerRep  register
3202
3203         code__2 dst = code `appOL` toOL [
3204             FxTOy (primRepToSize pk) W src tmp,
3205             ST W tmp (spRel (-2)),
3206             LD W (spRel (-2)) dst]
3207     in
3208     returnNat (Any IntRep code__2)
3209
3210 #endif {- sparc_TARGET_ARCH -}
3211 \end{code}
3212
3213 %************************************************************************
3214 %*                                                                      *
3215 \subsubsection{Coercing integer to @Char@...}
3216 %*                                                                      *
3217 %************************************************************************
3218
3219 Integer to character conversion.
3220
3221 \begin{code}
3222 chrCode :: StixTree -> NatM Register
3223
3224 #if alpha_TARGET_ARCH
3225
3226 -- TODO: This is probably wrong, but I don't know Alpha assembler.
3227 -- It should coerce a 64-bit value to a 32-bit value.
3228
3229 chrCode x
3230   = getRegister x               `thenNat` \ register ->
3231     getNewRegNCG IntRep         `thenNat` \ reg ->
3232     let
3233         code = registerCode register reg
3234         src  = registerName register reg
3235         code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3236     in
3237     returnNat (Any IntRep code__2)
3238
3239 #endif {- alpha_TARGET_ARCH -}
3240 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3241 #if i386_TARGET_ARCH
3242
3243 chrCode x
3244   = getRegister x               `thenNat` \ register ->
3245     returnNat (
3246     case register of
3247         Fixed _ reg code -> Fixed IntRep reg code
3248         Any   _ code     -> Any   IntRep code
3249     )
3250
3251 #endif {- i386_TARGET_ARCH -}
3252 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3253 #if sparc_TARGET_ARCH
3254
3255 chrCode x
3256   = getRegister x               `thenNat` \ register ->
3257     returnNat (
3258     case register of
3259         Fixed _ reg code -> Fixed IntRep reg code
3260         Any   _ code     -> Any   IntRep code
3261     )
3262
3263 #endif {- sparc_TARGET_ARCH -}
3264 \end{code}