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