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