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