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     -> CallConv
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                   (if cconv == StdCallConv then [] else
2445                    [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2446                   ++
2447                   [DELTA (delta + tot_arg_size)]
2448                )
2449     in
2450     setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2451     returnNat (code2 `appOL` call)
2452
2453   where
2454     -- function names that begin with '.' are assumed to be special
2455     -- internally generated names like '.mul,' which don't get an
2456     -- underscore prefix
2457     -- ToDo:needed (WDP 96/03) ???
2458     fn_u  = _UNPK_ fn
2459     fn__2 tot_arg_size
2460        | head fn_u == '.'
2461        = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2462        | otherwise
2463        = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2464
2465     stdcallsize tot_arg_size
2466        | cconv == StdCallConv = '@':show tot_arg_size
2467        | otherwise            = ""
2468
2469     arg_size DF = 8
2470     arg_size F  = 4
2471     arg_size _  = 4
2472
2473     ------------
2474     get_call_arg :: StixTree{-current argument-}
2475                     -> NatM (Int, InstrBlock)  -- argsz, code
2476
2477     get_call_arg arg
2478       = get_op arg                `thenNat` \ (code, reg, sz) ->
2479         getDeltaNat               `thenNat` \ delta ->
2480         arg_size sz               `bind`    \ size ->
2481         setDeltaNat (delta-size)  `thenNat` \ _ ->
2482         if   (case sz of DF -> True; F -> True; _ -> False)
2483         then returnNat (size,
2484                         code `appOL`
2485                         toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2486                               DELTA (delta-size),
2487                               GST sz reg (AddrBaseIndex (Just esp)
2488                                                         Nothing
2489                                                         (ImmInt 0))]
2490                        )
2491         else returnNat (size,
2492                         code `snocOL`
2493                         PUSH L (OpReg reg) `snocOL`
2494                         DELTA (delta-size)
2495                        )
2496     ------------
2497     get_op
2498         :: StixTree
2499         -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2500
2501     get_op op
2502       = getRegister op          `thenNat` \ register ->
2503         getNewRegNCG (registerRep register)
2504                                 `thenNat` \ tmp ->
2505         let
2506             code = registerCode register tmp
2507             reg  = registerName register tmp
2508             pk   = registerRep  register
2509             sz   = primRepToSize pk
2510         in
2511         returnNat (code, reg, sz)
2512
2513 #endif {- i386_TARGET_ARCH -}
2514 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2515 #if sparc_TARGET_ARCH
2516 {-
2517    The SPARC calling convention is an absolute
2518    nightmare.  The first 6x32 bits of arguments are mapped into
2519    %o0 through %o5, and the remaining arguments are dumped to the
2520    stack, beginning at [%sp+92].  (Note that %o6 == %sp.)
2521
2522    If we have to put args on the stack, move %o6==%sp down by
2523    the number of words to go on the stack, to ensure there's enough space.
2524
2525    According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2526    16 words above the stack pointer is a word for the address of
2527    a structure return value.  I use this as a temporary location
2528    for moving values from float to int regs.  Certainly it isn't
2529    safe to put anything in the 16 words starting at %sp, since
2530    this area can get trashed at any time due to window overflows
2531    caused by signal handlers.
2532
2533    A final complication (if the above isn't enough) is that
2534    we can't blithely calculate the arguments one by one into
2535    %o0 .. %o5.  Consider the following nested calls:
2536
2537        fff a (fff b c)
2538
2539    Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately
2540    the inner call will itself use %o0, which trashes the value put there
2541    in preparation for the outer call.  Upshot: we need to calculate the
2542    args into temporary regs, and move those to arg regs or onto the
2543    stack only immediately prior to the call proper.  Sigh.
2544 -}
2545
2546 genCCall fn cconv kind args
2547   = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2548     let (argcodes, vregss) = unzip argcode_and_vregs
2549         argcode            = concatOL argcodes
2550         vregs              = concat vregss
2551         n_argRegs          = length allArgRegs
2552         n_argRegs_used     = min (length vregs) n_argRegs
2553         (move_sp_down, move_sp_up)
2554            = let nn = length vregs - n_argRegs
2555                                    + 1 -- (for the road)
2556              in  if   nn <= 0
2557                  then (nilOL, nilOL)
2558                  else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2559         transfer_code
2560            = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2561         call
2562            = unitOL (CALL fn__2 n_argRegs_used False)
2563     in
2564         returnNat (argcode       `appOL`
2565                    move_sp_down  `appOL`
2566                    transfer_code `appOL`
2567                    call          `appOL`
2568                    unitOL NOP    `appOL`
2569                    move_sp_up)
2570   where
2571      -- function names that begin with '.' are assumed to be special
2572      -- internally generated names like '.mul,' which don't get an
2573      -- underscore prefix
2574      -- ToDo:needed (WDP 96/03) ???
2575      fn__2 = case (_HEAD_ fn) of
2576                 '.' -> ImmLit (ptext fn)
2577                 _   -> ImmLab False (ptext fn)
2578
2579      -- move args from the integer vregs into which they have been
2580      -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2581      move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2582
2583      move_final [] _ offset          -- all args done
2584         = []
2585
2586      move_final (v:vs) [] offset     -- out of aregs; move to stack
2587         = ST W v (spRel offset)
2588           : move_final vs [] (offset+1)
2589
2590      move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2591         = OR False g0 (RIReg v) a
2592           : move_final vs az offset
2593
2594      -- generate code to calculate an argument, and move it into one
2595      -- or two integer vregs.
2596      arg_to_int_vregs :: StixTree -> NatM (OrdList Instr, [Reg])
2597      arg_to_int_vregs arg
2598         = getRegister arg                     `thenNat` \ register ->
2599           getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2600           let code = registerCode register tmp
2601               src  = registerName register tmp
2602               pk   = registerRep register
2603           in
2604           -- the value is in src.  Get it into 1 or 2 int vregs.
2605           case pk of
2606              DoubleRep ->
2607                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2608                 getNewRegNCG WordRep  `thenNat` \ v2 ->
2609                 returnNat (
2610                    code                          `snocOL`
2611                    FMOV DF src f0                `snocOL`
2612                    ST   F  f0 (spRel 16)         `snocOL`
2613                    LD   W  (spRel 16) v1         `snocOL`
2614                    ST   F  (fPair f0) (spRel 16) `snocOL`
2615                    LD   W  (spRel 16) v2
2616                    ,
2617                    [v1,v2]
2618                 )
2619              FloatRep ->
2620                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2621                 returnNat (
2622                    code                    `snocOL`
2623                    ST   F  src (spRel 16)  `snocOL`
2624                    LD   W  (spRel 16) v1
2625                    ,
2626                    [v1]
2627                 )
2628              other ->
2629                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2630                 returnNat (
2631                    code `snocOL` OR False g0 (RIReg src) v1
2632                    ,
2633                    [v1]
2634                 )
2635 #endif {- sparc_TARGET_ARCH -}
2636 \end{code}
2637
2638 %************************************************************************
2639 %*                                                                      *
2640 \subsection{Support bits}
2641 %*                                                                      *
2642 %************************************************************************
2643
2644 %************************************************************************
2645 %*                                                                      *
2646 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2647 %*                                                                      *
2648 %************************************************************************
2649
2650 Turn those condition codes into integers now (when they appear on
2651 the right hand side of an assignment).
2652
2653 (If applicable) Do not fill the delay slots here; you will confuse the
2654 register allocator.
2655
2656 \begin{code}
2657 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2658
2659 #if alpha_TARGET_ARCH
2660 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2661 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2662 #endif {- alpha_TARGET_ARCH -}
2663
2664 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2665 #if i386_TARGET_ARCH
2666
2667 condIntReg cond x y
2668   = condIntCode cond x y        `thenNat` \ condition ->
2669     getNewRegNCG IntRep         `thenNat` \ tmp ->
2670     let
2671         code = condCode condition
2672         cond = condName condition
2673         code__2 dst = code `appOL` toOL [
2674             SETCC cond (OpReg tmp),
2675             AND L (OpImm (ImmInt 1)) (OpReg tmp),
2676             MOV L (OpReg tmp) (OpReg dst)]
2677     in
2678     returnNat (Any IntRep code__2)
2679
2680 condFltReg cond x y
2681   = getNatLabelNCG              `thenNat` \ lbl1 ->
2682     getNatLabelNCG              `thenNat` \ lbl2 ->
2683     condFltCode cond x y        `thenNat` \ condition ->
2684     let
2685         code = condCode condition
2686         cond = condName condition
2687         code__2 dst = code `appOL` toOL [
2688             JXX cond lbl1,
2689             MOV L (OpImm (ImmInt 0)) (OpReg dst),
2690             JXX ALWAYS lbl2,
2691             LABEL lbl1,
2692             MOV L (OpImm (ImmInt 1)) (OpReg dst),
2693             LABEL lbl2]
2694     in
2695     returnNat (Any IntRep code__2)
2696
2697 #endif {- i386_TARGET_ARCH -}
2698 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2699 #if sparc_TARGET_ARCH
2700
2701 condIntReg EQQ x (StInt 0)
2702   = getRegister x               `thenNat` \ register ->
2703     getNewRegNCG IntRep         `thenNat` \ tmp ->
2704     let
2705         code = registerCode register tmp
2706         src  = registerName register tmp
2707         code__2 dst = code `appOL` toOL [
2708             SUB False True g0 (RIReg src) g0,
2709             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2710     in
2711     returnNat (Any IntRep code__2)
2712
2713 condIntReg EQQ x y
2714   = getRegister x               `thenNat` \ register1 ->
2715     getRegister y               `thenNat` \ register2 ->
2716     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2717     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
2718     let
2719         code1 = registerCode register1 tmp1
2720         src1  = registerName register1 tmp1
2721         code2 = registerCode register2 tmp2
2722         src2  = registerName register2 tmp2
2723         code__2 dst = code1 `appOL` code2 `appOL` toOL [
2724             XOR False src1 (RIReg src2) dst,
2725             SUB False True g0 (RIReg dst) g0,
2726             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2727     in
2728     returnNat (Any IntRep code__2)
2729
2730 condIntReg NE x (StInt 0)
2731   = getRegister x               `thenNat` \ register ->
2732     getNewRegNCG IntRep         `thenNat` \ tmp ->
2733     let
2734         code = registerCode register tmp
2735         src  = registerName register tmp
2736         code__2 dst = code `appOL` toOL [
2737             SUB False True g0 (RIReg src) g0,
2738             ADD True False g0 (RIImm (ImmInt 0)) dst]
2739     in
2740     returnNat (Any IntRep code__2)
2741
2742 condIntReg NE x y
2743   = getRegister x               `thenNat` \ register1 ->
2744     getRegister y               `thenNat` \ register2 ->
2745     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2746     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
2747     let
2748         code1 = registerCode register1 tmp1
2749         src1  = registerName register1 tmp1
2750         code2 = registerCode register2 tmp2
2751         src2  = registerName register2 tmp2
2752         code__2 dst = code1 `appOL` code2 `appOL` toOL [
2753             XOR False src1 (RIReg src2) dst,
2754             SUB False True g0 (RIReg dst) g0,
2755             ADD True False g0 (RIImm (ImmInt 0)) dst]
2756     in
2757     returnNat (Any IntRep code__2)
2758
2759 condIntReg cond x y
2760   = getNatLabelNCG              `thenNat` \ lbl1 ->
2761     getNatLabelNCG              `thenNat` \ lbl2 ->
2762     condIntCode cond x y        `thenNat` \ condition ->
2763     let
2764         code = condCode condition
2765         cond = condName condition
2766         code__2 dst = code `appOL` toOL [
2767             BI cond False (ImmCLbl lbl1), NOP,
2768             OR False g0 (RIImm (ImmInt 0)) dst,
2769             BI ALWAYS False (ImmCLbl lbl2), NOP,
2770             LABEL lbl1,
2771             OR False g0 (RIImm (ImmInt 1)) dst,
2772             LABEL lbl2]
2773     in
2774     returnNat (Any IntRep code__2)
2775
2776 condFltReg cond x y
2777   = getNatLabelNCG              `thenNat` \ lbl1 ->
2778     getNatLabelNCG              `thenNat` \ lbl2 ->
2779     condFltCode cond x y        `thenNat` \ condition ->
2780     let
2781         code = condCode condition
2782         cond = condName condition
2783         code__2 dst = code `appOL` toOL [
2784             NOP,
2785             BF cond False (ImmCLbl lbl1), NOP,
2786             OR False g0 (RIImm (ImmInt 0)) dst,
2787             BI ALWAYS False (ImmCLbl lbl2), NOP,
2788             LABEL lbl1,
2789             OR False g0 (RIImm (ImmInt 1)) dst,
2790             LABEL lbl2]
2791     in
2792     returnNat (Any IntRep code__2)
2793
2794 #endif {- sparc_TARGET_ARCH -}
2795 \end{code}
2796
2797 %************************************************************************
2798 %*                                                                      *
2799 \subsubsection{@trivial*Code@: deal with trivial instructions}
2800 %*                                                                      *
2801 %************************************************************************
2802
2803 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2804 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions.  Only look
2805 for constants on the right hand side, because that's where the generic
2806 optimizer will have put them.
2807
2808 Similarly, for unary instructions, we don't have to worry about
2809 matching an StInt as the argument, because genericOpt will already
2810 have handled the constant-folding.
2811
2812 \begin{code}
2813 trivialCode
2814     :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2815       ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2816                      -> Maybe (Operand -> Operand -> Instr)
2817       ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2818       ,)))
2819     -> StixTree -> StixTree -- the two arguments
2820     -> NatM Register
2821
2822 trivialFCode
2823     :: PrimRep
2824     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2825       ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2826       ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2827       ,)))
2828     -> StixTree -> StixTree -- the two arguments
2829     -> NatM Register
2830
2831 trivialUCode
2832     :: IF_ARCH_alpha((RI -> Reg -> Instr)
2833       ,IF_ARCH_i386 ((Operand -> Instr)
2834       ,IF_ARCH_sparc((RI -> Reg -> Instr)
2835       ,)))
2836     -> StixTree -- the one argument
2837     -> NatM Register
2838
2839 trivialUFCode
2840     :: PrimRep
2841     -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2842       ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2843       ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2844       ,)))
2845     -> StixTree -- the one argument
2846     -> NatM Register
2847
2848 #if alpha_TARGET_ARCH
2849
2850 trivialCode instr x (StInt y)
2851   | fits8Bits y
2852   = getRegister x               `thenNat` \ register ->
2853     getNewRegNCG IntRep         `thenNat` \ tmp ->
2854     let
2855         code = registerCode register tmp
2856         src1 = registerName register tmp
2857         src2 = ImmInt (fromInteger y)
2858         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2859     in
2860     returnNat (Any IntRep code__2)
2861
2862 trivialCode instr x y
2863   = getRegister x               `thenNat` \ register1 ->
2864     getRegister y               `thenNat` \ register2 ->
2865     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2866     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
2867     let
2868         code1 = registerCode register1 tmp1 []
2869         src1  = registerName register1 tmp1
2870         code2 = registerCode register2 tmp2 []
2871         src2  = registerName register2 tmp2
2872         code__2 dst = asmSeqThen [code1, code2] .
2873                      mkSeqInstr (instr src1 (RIReg src2) dst)
2874     in
2875     returnNat (Any IntRep code__2)
2876
2877 ------------
2878 trivialUCode instr x
2879   = getRegister x               `thenNat` \ register ->
2880     getNewRegNCG IntRep         `thenNat` \ tmp ->
2881     let
2882         code = registerCode register tmp
2883         src  = registerName register tmp
2884         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2885     in
2886     returnNat (Any IntRep code__2)
2887
2888 ------------
2889 trivialFCode _ instr x y
2890   = getRegister x               `thenNat` \ register1 ->
2891     getRegister y               `thenNat` \ register2 ->
2892     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
2893     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
2894     let
2895         code1 = registerCode register1 tmp1
2896         src1  = registerName register1 tmp1
2897
2898         code2 = registerCode register2 tmp2
2899         src2  = registerName register2 tmp2
2900
2901         code__2 dst = asmSeqThen [code1 [], code2 []] .
2902                       mkSeqInstr (instr src1 src2 dst)
2903     in
2904     returnNat (Any DoubleRep code__2)
2905
2906 trivialUFCode _ instr x
2907   = getRegister x               `thenNat` \ register ->
2908     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
2909     let
2910         code = registerCode register tmp
2911         src  = registerName register tmp
2912         code__2 dst = code . mkSeqInstr (instr src dst)
2913     in
2914     returnNat (Any DoubleRep code__2)
2915
2916 #endif {- alpha_TARGET_ARCH -}
2917 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2918 #if i386_TARGET_ARCH
2919 \end{code}
2920 The Rules of the Game are:
2921
2922 * You cannot assume anything about the destination register dst;
2923   it may be anything, including a fixed reg.
2924
2925 * You may compute an operand into a fixed reg, but you may not
2926   subsequently change the contents of that fixed reg.  If you
2927   want to do so, first copy the value either to a temporary
2928   or into dst.  You are free to modify dst even if it happens
2929   to be a fixed reg -- that's not your problem.
2930
2931 * You cannot assume that a fixed reg will stay live over an
2932   arbitrary computation.  The same applies to the dst reg.
2933
2934 * Temporary regs obtained from getNewRegNCG are distinct from
2935   each other and from all other regs, and stay live over
2936   arbitrary computations.
2937
2938 \begin{code}
2939
2940 trivialCode instr maybe_revinstr a b
2941
2942   | is_imm_b
2943   = getRegister a                         `thenNat` \ rega ->
2944     let mkcode dst
2945           = if   isAny rega
2946             then registerCode rega dst      `bind` \ code_a ->
2947                  code_a `snocOL`
2948                  instr (OpImm imm_b) (OpReg dst)
2949             else registerCodeF rega         `bind` \ code_a ->
2950                  registerNameF rega         `bind` \ r_a ->
2951                  code_a `snocOL`
2952                  MOV L (OpReg r_a) (OpReg dst) `snocOL`
2953                  instr (OpImm imm_b) (OpReg dst)
2954     in
2955     returnNat (Any IntRep mkcode)
2956
2957   | is_imm_a
2958   = getRegister b                         `thenNat` \ regb ->
2959     getNewRegNCG IntRep                   `thenNat` \ tmp ->
2960     let revinstr_avail = maybeToBool maybe_revinstr
2961         revinstr       = case maybe_revinstr of Just ri -> ri
2962         mkcode dst
2963           | revinstr_avail
2964           = if   isAny regb
2965             then registerCode regb dst      `bind` \ code_b ->
2966                  code_b `snocOL`
2967                  revinstr (OpImm imm_a) (OpReg dst)
2968             else registerCodeF regb         `bind` \ code_b ->
2969                  registerNameF regb         `bind` \ r_b ->
2970                  code_b `snocOL`
2971                  MOV L (OpReg r_b) (OpReg dst) `snocOL`
2972                  revinstr (OpImm imm_a) (OpReg dst)
2973
2974           | otherwise
2975           = if   isAny regb
2976             then registerCode regb tmp      `bind` \ code_b ->
2977                  code_b `snocOL`
2978                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2979                  instr (OpReg tmp) (OpReg dst)
2980             else registerCodeF regb         `bind` \ code_b ->
2981                  registerNameF regb         `bind` \ r_b ->
2982                  code_b `snocOL`
2983                  MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2984                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2985                  instr (OpReg tmp) (OpReg dst)
2986     in
2987     returnNat (Any IntRep mkcode)
2988
2989   | otherwise
2990   = getRegister a                         `thenNat` \ rega ->
2991     getRegister b                         `thenNat` \ regb ->
2992     getNewRegNCG IntRep                   `thenNat` \ tmp ->
2993     let mkcode dst
2994           = case (isAny rega, isAny regb) of
2995               (True, True)
2996                  -> registerCode regb tmp   `bind` \ code_b ->
2997                     registerCode rega dst   `bind` \ code_a ->
2998                     code_b `appOL`
2999                     code_a `snocOL`
3000                     instr (OpReg tmp) (OpReg dst)
3001               (True, False)
3002                  -> registerCode  rega tmp  `bind` \ code_a ->
3003                     registerCodeF regb      `bind` \ code_b ->
3004                     registerNameF regb      `bind` \ r_b ->
3005                     code_a `appOL`
3006                     code_b `snocOL`
3007                     instr (OpReg r_b) (OpReg tmp) `snocOL`
3008                     MOV L (OpReg tmp) (OpReg dst)
3009               (False, True)
3010                  -> registerCode  regb tmp  `bind` \ code_b ->
3011                     registerCodeF rega      `bind` \ code_a ->
3012                     registerNameF rega      `bind` \ r_a ->
3013                     code_b `appOL`
3014                     code_a `snocOL`
3015                     MOV L (OpReg r_a) (OpReg dst) `snocOL`
3016                     instr (OpReg tmp) (OpReg dst)
3017               (False, False)
3018                  -> registerCodeF  rega     `bind` \ code_a ->
3019                     registerNameF  rega     `bind` \ r_a ->
3020                     registerCodeF  regb     `bind` \ code_b ->
3021                     registerNameF  regb     `bind` \ r_b ->
3022                     code_a `snocOL`
3023                     MOV L (OpReg r_a) (OpReg tmp) `appOL`
3024                     code_b `snocOL`
3025                     instr (OpReg r_b) (OpReg tmp) `snocOL`
3026                     MOV L (OpReg tmp) (OpReg dst)
3027     in
3028     returnNat (Any IntRep mkcode)
3029
3030     where
3031        maybe_imm_a = maybeImm a
3032        is_imm_a    = maybeToBool maybe_imm_a
3033        imm_a       = case maybe_imm_a of Just imm -> imm
3034
3035        maybe_imm_b = maybeImm b
3036        is_imm_b    = maybeToBool maybe_imm_b
3037        imm_b       = case maybe_imm_b of Just imm -> imm
3038
3039
3040 -----------
3041 trivialUCode instr x
3042   = getRegister x               `thenNat` \ register ->
3043     let
3044         code__2 dst = let code = registerCode register dst
3045                           src  = registerName register dst
3046                       in code `appOL`
3047                          if   isFixed register && dst /= src
3048                          then toOL [MOV L (OpReg src) (OpReg dst),
3049                                     instr (OpReg dst)]
3050                          else unitOL (instr (OpReg src))
3051     in
3052     returnNat (Any IntRep code__2)
3053
3054 -----------
3055 trivialFCode pk instr x y
3056   = getRegister x               `thenNat` \ register1 ->
3057     getRegister y               `thenNat` \ register2 ->
3058     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
3059     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
3060     let
3061         code1 = registerCode register1 tmp1
3062         src1  = registerName register1 tmp1
3063
3064         code2 = registerCode register2 tmp2
3065         src2  = registerName register2 tmp2
3066
3067         code__2 dst
3068            -- treat the common case specially: both operands in
3069            -- non-fixed regs.
3070            | isAny register1 && isAny register2
3071            = code1 `appOL`
3072              code2 `snocOL`
3073              instr (primRepToSize pk) src1 src2 dst
3074
3075            -- be paranoid (and inefficient)
3076            | otherwise
3077            = code1 `snocOL` GMOV src1 tmp1  `appOL`
3078              code2 `snocOL`
3079              instr (primRepToSize pk) tmp1 src2 dst
3080     in
3081     returnNat (Any pk code__2)
3082
3083
3084 -------------
3085 trivialUFCode pk instr x
3086   = getRegister x               `thenNat` \ register ->
3087     getNewRegNCG pk             `thenNat` \ tmp ->
3088     let
3089         code = registerCode register tmp
3090         src  = registerName register tmp
3091         code__2 dst = code `snocOL` instr src dst
3092     in
3093     returnNat (Any pk code__2)
3094
3095 #endif {- i386_TARGET_ARCH -}
3096 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3097 #if sparc_TARGET_ARCH
3098
3099 trivialCode instr x (StInt y)
3100   | fits13Bits y
3101   = getRegister x               `thenNat` \ register ->
3102     getNewRegNCG IntRep         `thenNat` \ tmp ->
3103     let
3104         code = registerCode register tmp
3105         src1 = registerName register tmp
3106         src2 = ImmInt (fromInteger y)
3107         code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3108     in
3109     returnNat (Any IntRep code__2)
3110
3111 trivialCode instr x y
3112   = getRegister x               `thenNat` \ register1 ->
3113     getRegister y               `thenNat` \ register2 ->
3114     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3115     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3116     let
3117         code1 = registerCode register1 tmp1
3118         src1  = registerName register1 tmp1
3119         code2 = registerCode register2 tmp2
3120         src2  = registerName register2 tmp2
3121         code__2 dst = code1 `appOL` code2 `snocOL`
3122                       instr src1 (RIReg src2) dst
3123     in
3124     returnNat (Any IntRep code__2)
3125
3126 ------------
3127 trivialFCode pk instr x y
3128   = getRegister x               `thenNat` \ register1 ->
3129     getRegister y               `thenNat` \ register2 ->
3130     getNewRegNCG (registerRep register1)
3131                                 `thenNat` \ tmp1 ->
3132     getNewRegNCG (registerRep register2)
3133                                 `thenNat` \ tmp2 ->
3134     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3135     let
3136         promote x = FxTOy F DF x tmp
3137
3138         pk1   = registerRep register1
3139         code1 = registerCode register1 tmp1
3140         src1  = registerName register1 tmp1
3141
3142         pk2   = registerRep register2
3143         code2 = registerCode register2 tmp2
3144         src2  = registerName register2 tmp2
3145
3146         code__2 dst =
3147                 if pk1 == pk2 then
3148                     code1 `appOL` code2 `snocOL`
3149                     instr (primRepToSize pk) src1 src2 dst
3150                 else if pk1 == FloatRep then
3151                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3152                     instr DF tmp src2 dst
3153                 else
3154                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3155                     instr DF src1 tmp dst
3156     in
3157     returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3158
3159 ------------
3160 trivialUCode instr x
3161   = getRegister x               `thenNat` \ register ->
3162     getNewRegNCG IntRep         `thenNat` \ tmp ->
3163     let
3164         code = registerCode register tmp
3165         src  = registerName register tmp
3166         code__2 dst = code `snocOL` instr (RIReg src) dst
3167     in
3168     returnNat (Any IntRep code__2)
3169
3170 -------------
3171 trivialUFCode pk instr x
3172   = getRegister x               `thenNat` \ register ->
3173     getNewRegNCG pk             `thenNat` \ tmp ->
3174     let
3175         code = registerCode register tmp
3176         src  = registerName register tmp
3177         code__2 dst = code `snocOL` instr src dst
3178     in
3179     returnNat (Any pk code__2)
3180
3181 #endif {- sparc_TARGET_ARCH -}
3182 \end{code}
3183
3184 %************************************************************************
3185 %*                                                                      *
3186 \subsubsection{Coercing to/from integer/floating-point...}
3187 %*                                                                      *
3188 %************************************************************************
3189
3190 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3191 to be generated.  Here we just change the type on the Register passed
3192 on up.  The code is machine-independent.
3193
3194 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3195 conversions.  We have to store temporaries in memory to move
3196 between the integer and the floating point register sets.
3197
3198 \begin{code}
3199 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3200 coerceFltCode ::            StixTree -> NatM Register
3201
3202 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3203 coerceFP2Int ::            StixTree -> NatM Register
3204
3205 coerceIntCode pk x
3206   = getRegister x               `thenNat` \ register ->
3207     returnNat (
3208     case register of
3209         Fixed _ reg code -> Fixed pk reg code
3210         Any   _ code     -> Any   pk code
3211     )
3212
3213 -------------
3214 coerceFltCode x
3215   = getRegister x               `thenNat` \ register ->
3216     returnNat (
3217     case register of
3218         Fixed _ reg code -> Fixed DoubleRep reg code
3219         Any   _ code     -> Any   DoubleRep code
3220     )
3221 \end{code}
3222
3223 \begin{code}
3224 #if alpha_TARGET_ARCH
3225
3226 coerceInt2FP _ x
3227   = getRegister x               `thenNat` \ register ->
3228     getNewRegNCG IntRep         `thenNat` \ reg ->
3229     let
3230         code = registerCode register reg
3231         src  = registerName register reg
3232
3233         code__2 dst = code . mkSeqInstrs [
3234             ST Q src (spRel 0),
3235             LD TF dst (spRel 0),
3236             CVTxy Q TF dst dst]
3237     in
3238     returnNat (Any DoubleRep code__2)
3239
3240 -------------
3241 coerceFP2Int x
3242   = getRegister x               `thenNat` \ register ->
3243     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3244     let
3245         code = registerCode register tmp
3246         src  = registerName register tmp
3247
3248         code__2 dst = code . mkSeqInstrs [
3249             CVTxy TF Q src tmp,
3250             ST TF tmp (spRel 0),
3251             LD Q dst (spRel 0)]
3252     in
3253     returnNat (Any IntRep code__2)
3254
3255 #endif {- alpha_TARGET_ARCH -}
3256 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3257 #if i386_TARGET_ARCH
3258
3259 coerceInt2FP pk x
3260   = getRegister x               `thenNat` \ register ->
3261     getNewRegNCG IntRep         `thenNat` \ reg ->
3262     let
3263         code = registerCode register reg
3264         src  = registerName register reg
3265         opc  = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3266         code__2 dst = code `snocOL` opc src dst
3267     in
3268     returnNat (Any pk code__2)
3269
3270 ------------
3271 coerceFP2Int x
3272   = getRegister x               `thenNat` \ register ->
3273     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3274     let
3275         code = registerCode register tmp
3276         src  = registerName register tmp
3277         pk   = registerRep register
3278
3279         opc  = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3280         code__2 dst = code `snocOL` opc src dst
3281     in
3282     returnNat (Any IntRep code__2)
3283
3284 #endif {- i386_TARGET_ARCH -}
3285 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3286 #if sparc_TARGET_ARCH
3287
3288 coerceInt2FP pk x
3289   = getRegister x               `thenNat` \ register ->
3290     getNewRegNCG IntRep         `thenNat` \ reg ->
3291     let
3292         code = registerCode register reg
3293         src  = registerName register reg
3294
3295         code__2 dst = code `appOL` toOL [
3296             ST W src (spRel (-2)),
3297             LD W (spRel (-2)) dst,
3298             FxTOy W (primRepToSize pk) dst dst]
3299     in
3300     returnNat (Any pk code__2)
3301
3302 ------------
3303 coerceFP2Int x
3304   = getRegister x               `thenNat` \ register ->
3305     getNewRegNCG IntRep         `thenNat` \ reg ->
3306     getNewRegNCG FloatRep       `thenNat` \ tmp ->
3307     let
3308         code = registerCode register reg
3309         src  = registerName register reg
3310         pk   = registerRep  register
3311
3312         code__2 dst = code `appOL` toOL [
3313             FxTOy (primRepToSize pk) W src tmp,
3314             ST W tmp (spRel (-2)),
3315             LD W (spRel (-2)) dst]
3316     in
3317     returnNat (Any IntRep code__2)
3318
3319 #endif {- sparc_TARGET_ARCH -}
3320 \end{code}
3321
3322 %************************************************************************
3323 %*                                                                      *
3324 \subsubsection{Coercing integer to @Char@...}
3325 %*                                                                      *
3326 %************************************************************************
3327
3328 Integer to character conversion.
3329
3330 \begin{code}
3331 chrCode :: StixTree -> NatM Register
3332
3333 #if alpha_TARGET_ARCH
3334
3335 -- TODO: This is probably wrong, but I don't know Alpha assembler.
3336 -- It should coerce a 64-bit value to a 32-bit value.
3337
3338 chrCode x
3339   = getRegister x               `thenNat` \ register ->
3340     getNewRegNCG IntRep         `thenNat` \ reg ->
3341     let
3342         code = registerCode register reg
3343         src  = registerName register reg
3344         code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3345     in
3346     returnNat (Any IntRep code__2)
3347
3348 #endif {- alpha_TARGET_ARCH -}
3349 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3350 #if i386_TARGET_ARCH
3351
3352 chrCode x
3353   = getRegister x               `thenNat` \ register ->
3354     returnNat (
3355     case register of
3356         Fixed _ reg code -> Fixed IntRep reg code
3357         Any   _ code     -> Any   IntRep code
3358     )
3359
3360 #endif {- i386_TARGET_ARCH -}
3361 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3362 #if sparc_TARGET_ARCH
3363
3364 chrCode x
3365   = getRegister x               `thenNat` \ register ->
3366     returnNat (
3367     case register of
3368         Fixed _ reg code -> Fixed IntRep reg code
3369         Any   _ code     -> Any   IntRep code
3370     )
3371
3372 #endif {- sparc_TARGET_ARCH -}
3373 \end{code}