ghc/compiler/nativeGen/MachCode.lhs

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