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