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