ghc/compiler/nativeGen/MachCode.lhs

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