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