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