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