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 -- Implement this!  It should be im MachRegs.lhs, not here.
2399 allArgRegs :: [Reg]
2400 allArgRegs = error "nativeGen(sparc): allArgRegs"
2401
2402 genCCall fn cconv kind args
2403   = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2404                           `thenNat` \ ((unused,_), argCode) ->
2405     let
2406
2407         nRegs = length allArgRegs - length unused
2408         call = CALL fn__2 nRegs False
2409         code = concatOL argCode
2410     in
2411         returnNat (code `snocOL` call `snocOL` NOP)
2412   where
2413     -- function names that begin with '.' are assumed to be special
2414     -- internally generated names like '.mul,' which don't get an
2415     -- underscore prefix
2416     -- ToDo:needed (WDP 96/03) ???
2417     fn__2 = case (_HEAD_ fn) of
2418               '.' -> ImmLit (ptext fn)
2419               _   -> ImmLab False (ptext fn)
2420
2421     ------------------------------------
2422     {-  Try to get a value into a specific register (or registers) for
2423         a call.  The SPARC calling convention is an absolute
2424         nightmare.  The first 6x32 bits of arguments are mapped into
2425         %o0 through %o5, and the remaining arguments are dumped to the
2426         stack, beginning at [%sp+92].  (Note that %o6 == %sp.)  Our
2427         first argument is a pair of the list of remaining argument
2428         registers to be assigned for this call and the next stack
2429         offset to use for overflowing arguments.  This way,
2430         @get_arg@ can be applied to all of a call's arguments using
2431         @mapAccumL@.
2432     -}
2433     get_arg
2434         :: ([Reg],Int)  -- Argument registers and stack offset (accumulator)
2435         -> StixTree     -- Current argument
2436         -> NatM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2437
2438     -- We have to use up all of our argument registers first...
2439
2440     get_arg (dst:dsts, offset) arg
2441       = getRegister arg                 `thenNat` \ register ->
2442         getNewRegNCG (registerRep register)
2443                                         `thenNat` \ tmp ->
2444         let
2445             reg  = if isFloatingRep pk then tmp else dst
2446             code = registerCode register reg
2447             src  = registerName register reg
2448             pk   = registerRep register
2449         in
2450         returnNat (
2451          case pk of
2452             DoubleRep ->
2453                 case dsts of
2454                    [] -> ( ([], offset + 1),
2455                             code `snocOL`
2456                             -- conveniently put the second part in the right stack
2457                             -- location, and load the first part into %o5
2458                             ST DF src (spRel (offset - 1)) `snocOL`
2459                             LD W (spRel (offset - 1)) dst
2460                          )
2461                    (dst__2:dsts__2)
2462                        -> ( (dsts__2, offset),
2463                             code `snocOL`
2464                             ST DF src (spRel (-2)) `snocOL`
2465                             LD W (spRel (-2)) dst `snocOL`
2466                             LD W (spRel (-1)) dst__2
2467                           )
2468             FloatRep
2469                -> ( (dsts, offset),
2470                     code `snocOL`
2471                     ST F src (spRel (-2)) `snocOL`
2472                     LD W (spRel (-2)) dst
2473                   )
2474             _  -> ( (dsts, offset),
2475                     if   isFixed register
2476                     then code `snocOL` OR False g0 (RIReg src) dst
2477                     else code
2478                   )
2479         )
2480     -- Once we have run out of argument registers, we move to the
2481     -- stack...
2482
2483     get_arg ([], offset) arg
2484       = getRegister arg                 `thenNat` \ register ->
2485         getNewRegNCG (registerRep register)
2486                                         `thenNat` \ tmp ->
2487         let
2488             code  = registerCode register tmp
2489             src   = registerName register tmp
2490             pk    = registerRep register
2491             sz    = primRepToSize pk
2492             words = if pk == DoubleRep then 2 else 1
2493         in
2494         returnNat ( ([], offset + words),
2495                     code `snocOL` ST sz src (spRel offset) )
2496
2497 #endif {- sparc_TARGET_ARCH -}
2498 \end{code}
2499
2500 %************************************************************************
2501 %*                                                                      *
2502 \subsection{Support bits}
2503 %*                                                                      *
2504 %************************************************************************
2505
2506 %************************************************************************
2507 %*                                                                      *
2508 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2509 %*                                                                      *
2510 %************************************************************************
2511
2512 Turn those condition codes into integers now (when they appear on
2513 the right hand side of an assignment).
2514
2515 (If applicable) Do not fill the delay slots here; you will confuse the
2516 register allocator.
2517
2518 \begin{code}
2519 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2520
2521 #if alpha_TARGET_ARCH
2522 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2523 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2524 #endif {- alpha_TARGET_ARCH -}
2525
2526 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2527 #if i386_TARGET_ARCH
2528
2529 condIntReg cond x y
2530   = condIntCode cond x y        `thenNat` \ condition ->
2531     getNewRegNCG IntRep         `thenNat` \ tmp ->
2532     let
2533         code = condCode condition
2534         cond = condName condition
2535         code__2 dst = code `appOL` toOL [
2536             SETCC cond (OpReg tmp),
2537             AND L (OpImm (ImmInt 1)) (OpReg tmp),
2538             MOV L (OpReg tmp) (OpReg dst)]
2539     in
2540     returnNat (Any IntRep code__2)
2541
2542 condFltReg cond x y
2543   = getNatLabelNCG              `thenNat` \ lbl1 ->
2544     getNatLabelNCG              `thenNat` \ lbl2 ->
2545     condFltCode cond x y        `thenNat` \ condition ->
2546     let
2547         code = condCode condition
2548         cond = condName condition
2549         code__2 dst = code `appOL` toOL [
2550             JXX cond lbl1,
2551             MOV L (OpImm (ImmInt 0)) (OpReg dst),
2552             JXX ALWAYS lbl2,
2553             LABEL lbl1,
2554             MOV L (OpImm (ImmInt 1)) (OpReg dst),
2555             LABEL lbl2]
2556     in
2557     returnNat (Any IntRep code__2)
2558
2559 #endif {- i386_TARGET_ARCH -}
2560 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2561 #if sparc_TARGET_ARCH
2562
2563 condIntReg EQQ x (StInt 0)
2564   = getRegister x               `thenNat` \ register ->
2565     getNewRegNCG IntRep         `thenNat` \ tmp ->
2566     let
2567         code = registerCode register tmp
2568         src  = registerName register tmp
2569         code__2 dst = code `appOL` toOL [
2570             SUB False True g0 (RIReg src) g0,
2571             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2572     in
2573     returnNat (Any IntRep code__2)
2574
2575 condIntReg EQQ x y
2576   = getRegister x               `thenNat` \ register1 ->
2577     getRegister y               `thenNat` \ register2 ->
2578     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2579     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
2580     let
2581         code1 = registerCode register1 tmp1
2582         src1  = registerName register1 tmp1
2583         code2 = registerCode register2 tmp2
2584         src2  = registerName register2 tmp2
2585         code__2 dst = code1 `appOL` code2 `appOL` toOL [
2586             XOR False src1 (RIReg src2) dst,
2587             SUB False True g0 (RIReg dst) g0,
2588             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2589     in
2590     returnNat (Any IntRep code__2)
2591
2592 condIntReg NE x (StInt 0)
2593   = getRegister x               `thenNat` \ register ->
2594     getNewRegNCG IntRep         `thenNat` \ tmp ->
2595     let
2596         code = registerCode register tmp
2597         src  = registerName register tmp
2598         code__2 dst = code `appOL` toOL [
2599             SUB False True g0 (RIReg src) g0,
2600             ADD True False g0 (RIImm (ImmInt 0)) dst]
2601     in
2602     returnNat (Any IntRep code__2)
2603
2604 condIntReg NE x y
2605   = getRegister x               `thenNat` \ register1 ->
2606     getRegister y               `thenNat` \ register2 ->
2607     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2608     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
2609     let
2610         code1 = registerCode register1 tmp1
2611         src1  = registerName register1 tmp1
2612         code2 = registerCode register2 tmp2
2613         src2  = registerName register2 tmp2
2614         code__2 dst = code1 `appOL` code2 `appOL` toOL [
2615             XOR False src1 (RIReg src2) dst,
2616             SUB False True g0 (RIReg dst) g0,
2617             ADD True False g0 (RIImm (ImmInt 0)) dst]
2618     in
2619     returnNat (Any IntRep code__2)
2620
2621 condIntReg cond x y
2622   = getNatLabelNCG              `thenNat` \ lbl1 ->
2623     getNatLabelNCG              `thenNat` \ lbl2 ->
2624     condIntCode cond x y        `thenNat` \ condition ->
2625     let
2626         code = condCode condition
2627         cond = condName condition
2628         code__2 dst = code `appOL` toOL [
2629             BI cond False (ImmCLbl lbl1), NOP,
2630             OR False g0 (RIImm (ImmInt 0)) dst,
2631             BI ALWAYS False (ImmCLbl lbl2), NOP,
2632             LABEL lbl1,
2633             OR False g0 (RIImm (ImmInt 1)) dst,
2634             LABEL lbl2]
2635     in
2636     returnNat (Any IntRep code__2)
2637
2638 condFltReg cond x y
2639   = getNatLabelNCG              `thenNat` \ lbl1 ->
2640     getNatLabelNCG              `thenNat` \ lbl2 ->
2641     condFltCode cond x y        `thenNat` \ condition ->
2642     let
2643         code = condCode condition
2644         cond = condName condition
2645         code__2 dst = code `appOL` toOL [
2646             NOP,
2647             BF cond False (ImmCLbl lbl1), NOP,
2648             OR False g0 (RIImm (ImmInt 0)) dst,
2649             BI ALWAYS False (ImmCLbl lbl2), NOP,
2650             LABEL lbl1,
2651             OR False g0 (RIImm (ImmInt 1)) dst,
2652             LABEL lbl2]
2653     in
2654     returnNat (Any IntRep code__2)
2655
2656 #endif {- sparc_TARGET_ARCH -}
2657 \end{code}
2658
2659 %************************************************************************
2660 %*                                                                      *
2661 \subsubsection{@trivial*Code@: deal with trivial instructions}
2662 %*                                                                      *
2663 %************************************************************************
2664
2665 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2666 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions.  Only look
2667 for constants on the right hand side, because that's where the generic
2668 optimizer will have put them.
2669
2670 Similarly, for unary instructions, we don't have to worry about
2671 matching an StInt as the argument, because genericOpt will already
2672 have handled the constant-folding.
2673
2674 \begin{code}
2675 trivialCode
2676     :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2677       ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2678                      -> Maybe (Operand -> Operand -> Instr)
2679       ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2680       ,)))
2681     -> StixTree -> StixTree -- the two arguments
2682     -> NatM Register
2683
2684 trivialFCode
2685     :: PrimRep
2686     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2687       ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2688       ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2689       ,)))
2690     -> StixTree -> StixTree -- the two arguments
2691     -> NatM Register
2692
2693 trivialUCode
2694     :: IF_ARCH_alpha((RI -> Reg -> Instr)
2695       ,IF_ARCH_i386 ((Operand -> Instr)
2696       ,IF_ARCH_sparc((RI -> Reg -> Instr)
2697       ,)))
2698     -> StixTree -- the one argument
2699     -> NatM Register
2700
2701 trivialUFCode
2702     :: PrimRep
2703     -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2704       ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2705       ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2706       ,)))
2707     -> StixTree -- the one argument
2708     -> NatM Register
2709
2710 #if alpha_TARGET_ARCH
2711
2712 trivialCode instr x (StInt y)
2713   | fits8Bits y
2714   = getRegister x               `thenNat` \ register ->
2715     getNewRegNCG IntRep         `thenNat` \ tmp ->
2716     let
2717         code = registerCode register tmp
2718         src1 = registerName register tmp
2719         src2 = ImmInt (fromInteger y)
2720         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2721     in
2722     returnNat (Any IntRep code__2)
2723
2724 trivialCode instr x y
2725   = getRegister x               `thenNat` \ register1 ->
2726     getRegister y               `thenNat` \ register2 ->
2727     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2728     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
2729     let
2730         code1 = registerCode register1 tmp1 []
2731         src1  = registerName register1 tmp1
2732         code2 = registerCode register2 tmp2 []
2733         src2  = registerName register2 tmp2
2734         code__2 dst = asmSeqThen [code1, code2] .
2735                      mkSeqInstr (instr src1 (RIReg src2) dst)
2736     in
2737     returnNat (Any IntRep code__2)
2738
2739 ------------
2740 trivialUCode instr x
2741   = getRegister x               `thenNat` \ register ->
2742     getNewRegNCG IntRep         `thenNat` \ tmp ->
2743     let
2744         code = registerCode register tmp
2745         src  = registerName register tmp
2746         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2747     in
2748     returnNat (Any IntRep code__2)
2749
2750 ------------
2751 trivialFCode _ instr x y
2752   = getRegister x               `thenNat` \ register1 ->
2753     getRegister y               `thenNat` \ register2 ->
2754     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
2755     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
2756     let
2757         code1 = registerCode register1 tmp1
2758         src1  = registerName register1 tmp1
2759
2760         code2 = registerCode register2 tmp2
2761         src2  = registerName register2 tmp2
2762
2763         code__2 dst = asmSeqThen [code1 [], code2 []] .
2764                       mkSeqInstr (instr src1 src2 dst)
2765     in
2766     returnNat (Any DoubleRep code__2)
2767
2768 trivialUFCode _ instr x
2769   = getRegister x               `thenNat` \ register ->
2770     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
2771     let
2772         code = registerCode register tmp
2773         src  = registerName register tmp
2774         code__2 dst = code . mkSeqInstr (instr src dst)
2775     in
2776     returnNat (Any DoubleRep code__2)
2777
2778 #endif {- alpha_TARGET_ARCH -}
2779 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2780 #if i386_TARGET_ARCH
2781 \end{code}
2782 The Rules of the Game are:
2783
2784 * You cannot assume anything about the destination register dst;
2785   it may be anything, including a fixed reg.
2786
2787 * You may compute an operand into a fixed reg, but you may not
2788   subsequently change the contents of that fixed reg.  If you
2789   want to do so, first copy the value either to a temporary
2790   or into dst.  You are free to modify dst even if it happens
2791   to be a fixed reg -- that's not your problem.
2792
2793 * You cannot assume that a fixed reg will stay live over an
2794   arbitrary computation.  The same applies to the dst reg.
2795
2796 * Temporary regs obtained from getNewRegNCG are distinct from
2797   each other and from all other regs, and stay live over
2798   arbitrary computations.
2799
2800 \begin{code}
2801
2802 trivialCode instr maybe_revinstr a b
2803
2804   | is_imm_b
2805   = getRegister a                         `thenNat` \ rega ->
2806     let mkcode dst
2807           = if   isAny rega
2808             then registerCode rega dst      `bind` \ code_a ->
2809                  code_a `snocOL`
2810                  instr (OpImm imm_b) (OpReg dst)
2811             else registerCodeF rega         `bind` \ code_a ->
2812                  registerNameF rega         `bind` \ r_a ->
2813                  code_a `snocOL`
2814                  MOV L (OpReg r_a) (OpReg dst) `snocOL`
2815                  instr (OpImm imm_b) (OpReg dst)
2816     in
2817     returnNat (Any IntRep mkcode)
2818
2819   | is_imm_a
2820   = getRegister b                         `thenNat` \ regb ->
2821     getNewRegNCG IntRep                   `thenNat` \ tmp ->
2822     let revinstr_avail = maybeToBool maybe_revinstr
2823         revinstr       = case maybe_revinstr of Just ri -> ri
2824         mkcode dst
2825           | revinstr_avail
2826           = if   isAny regb
2827             then registerCode regb dst      `bind` \ code_b ->
2828                  code_b `snocOL`
2829                  revinstr (OpImm imm_a) (OpReg dst)
2830             else registerCodeF regb         `bind` \ code_b ->
2831                  registerNameF regb         `bind` \ r_b ->
2832                  code_b `snocOL`
2833                  MOV L (OpReg r_b) (OpReg dst) `snocOL`
2834                  revinstr (OpImm imm_a) (OpReg dst)
2835
2836           | otherwise
2837           = if   isAny regb
2838             then registerCode regb tmp      `bind` \ code_b ->
2839                  code_b `snocOL`
2840                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2841                  instr (OpReg tmp) (OpReg dst)
2842             else registerCodeF regb         `bind` \ code_b ->
2843                  registerNameF regb         `bind` \ r_b ->
2844                  code_b `snocOL`
2845                  MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2846                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2847                  instr (OpReg tmp) (OpReg dst)
2848     in
2849     returnNat (Any IntRep mkcode)
2850
2851   | otherwise
2852   = getRegister a                         `thenNat` \ rega ->
2853     getRegister b                         `thenNat` \ regb ->
2854     getNewRegNCG IntRep                   `thenNat` \ tmp ->
2855     let mkcode dst
2856           = case (isAny rega, isAny regb) of
2857               (True, True)
2858                  -> registerCode regb tmp   `bind` \ code_b ->
2859                     registerCode rega dst   `bind` \ code_a ->
2860                     code_b `appOL`
2861                     code_a `snocOL`
2862                     instr (OpReg tmp) (OpReg dst)
2863               (True, False)
2864                  -> registerCode  rega tmp  `bind` \ code_a ->
2865                     registerCodeF regb      `bind` \ code_b ->
2866                     registerNameF regb      `bind` \ r_b ->
2867                     code_a `appOL`
2868                     code_b `snocOL`
2869                     instr (OpReg r_b) (OpReg tmp) `snocOL`
2870                     MOV L (OpReg tmp) (OpReg dst)
2871               (False, True)
2872                  -> registerCode  regb tmp  `bind` \ code_b ->
2873                     registerCodeF rega      `bind` \ code_a ->
2874                     registerNameF rega      `bind` \ r_a ->
2875                     code_b `appOL`
2876                     code_a `snocOL`
2877                     MOV L (OpReg r_a) (OpReg dst) `snocOL`
2878                     instr (OpReg tmp) (OpReg dst)
2879               (False, False)
2880                  -> registerCodeF  rega     `bind` \ code_a ->
2881                     registerNameF  rega     `bind` \ r_a ->
2882                     registerCodeF  regb     `bind` \ code_b ->
2883                     registerNameF  regb     `bind` \ r_b ->
2884                     code_a `snocOL`
2885                     MOV L (OpReg r_a) (OpReg tmp) `appOL`
2886                     code_b `snocOL`
2887                     instr (OpReg r_b) (OpReg tmp) `snocOL`
2888                     MOV L (OpReg tmp) (OpReg dst)
2889     in
2890     returnNat (Any IntRep mkcode)
2891
2892     where
2893        maybe_imm_a = maybeImm a
2894        is_imm_a    = maybeToBool maybe_imm_a
2895        imm_a       = case maybe_imm_a of Just imm -> imm
2896
2897        maybe_imm_b = maybeImm b
2898        is_imm_b    = maybeToBool maybe_imm_b
2899        imm_b       = case maybe_imm_b of Just imm -> imm
2900
2901
2902 -----------
2903 trivialUCode instr x
2904   = getRegister x               `thenNat` \ register ->
2905     let
2906         code__2 dst = let code = registerCode register dst
2907                           src  = registerName register dst
2908                       in code `appOL`
2909                          if   isFixed register && dst /= src
2910                          then toOL [MOV L (OpReg src) (OpReg dst),
2911                                     instr (OpReg dst)]
2912                          else unitOL (instr (OpReg src))
2913     in
2914     returnNat (Any IntRep code__2)
2915
2916 -----------
2917 trivialFCode pk instr x y
2918   = getRegister x               `thenNat` \ register1 ->
2919     getRegister y               `thenNat` \ register2 ->
2920     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
2921     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
2922     let
2923         code1 = registerCode register1 tmp1
2924         src1  = registerName register1 tmp1
2925
2926         code2 = registerCode register2 tmp2
2927         src2  = registerName register2 tmp2
2928
2929         code__2 dst
2930            -- treat the common case specially: both operands in
2931            -- non-fixed regs.
2932            | isAny register1 && isAny register2
2933            = code1 `appOL`
2934              code2 `snocOL`
2935              instr (primRepToSize pk) src1 src2 dst
2936
2937            -- be paranoid (and inefficient)
2938            | otherwise
2939            = code1 `snocOL` GMOV src1 tmp1  `appOL`
2940              code2 `snocOL`
2941              instr (primRepToSize pk) tmp1 src2 dst
2942     in
2943     returnNat (Any DoubleRep code__2)
2944
2945
2946 -------------
2947 trivialUFCode pk instr x
2948   = getRegister x               `thenNat` \ register ->
2949     getNewRegNCG pk             `thenNat` \ tmp ->
2950     let
2951         code = registerCode register tmp
2952         src  = registerName register tmp
2953         code__2 dst = code `snocOL` instr src dst
2954     in
2955     returnNat (Any pk code__2)
2956
2957 #endif {- i386_TARGET_ARCH -}
2958 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2959 #if sparc_TARGET_ARCH
2960
2961 trivialCode instr x (StInt y)
2962   | fits13Bits y
2963   = getRegister x               `thenNat` \ register ->
2964     getNewRegNCG IntRep         `thenNat` \ tmp ->
2965     let
2966         code = registerCode register tmp
2967         src1 = registerName register tmp
2968         src2 = ImmInt (fromInteger y)
2969         code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
2970     in
2971     returnNat (Any IntRep code__2)
2972
2973 trivialCode instr x y
2974   = getRegister x               `thenNat` \ register1 ->
2975     getRegister y               `thenNat` \ register2 ->
2976     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2977     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
2978     let
2979         code1 = registerCode register1 tmp1
2980         src1  = registerName register1 tmp1
2981         code2 = registerCode register2 tmp2
2982         src2  = registerName register2 tmp2
2983         code__2 dst = code1 `appOL` code2 `snocOL`
2984                       instr src1 (RIReg src2) dst
2985     in
2986     returnNat (Any IntRep code__2)
2987
2988 ------------
2989 trivialFCode pk instr x y
2990   = getRegister x               `thenNat` \ register1 ->
2991     getRegister y               `thenNat` \ register2 ->
2992     getNewRegNCG (registerRep register1)
2993                                 `thenNat` \ tmp1 ->
2994     getNewRegNCG (registerRep register2)
2995                                 `thenNat` \ tmp2 ->
2996     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
2997     let
2998         promote x = FxTOy F DF x tmp
2999
3000         pk1   = registerRep register1
3001         code1 = registerCode register1 tmp1
3002         src1  = registerName register1 tmp1
3003
3004         pk2   = registerRep register2
3005         code2 = registerCode register2 tmp2
3006         src2  = registerName register2 tmp2
3007
3008         code__2 dst =
3009                 if pk1 == pk2 then
3010                     code1 `appOL` code2 `snocOL`
3011                     instr (primRepToSize pk) src1 src2 dst
3012                 else if pk1 == FloatRep then
3013                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3014                     instr DF tmp src2 dst
3015                 else
3016                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3017                     instr DF src1 tmp dst
3018     in
3019     returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3020
3021 ------------
3022 trivialUCode instr x
3023   = getRegister x               `thenNat` \ register ->
3024     getNewRegNCG IntRep         `thenNat` \ tmp ->
3025     let
3026         code = registerCode register tmp
3027         src  = registerName register tmp
3028         code__2 dst = code `snocOL` instr (RIReg src) dst
3029     in
3030     returnNat (Any IntRep code__2)
3031
3032 -------------
3033 trivialUFCode pk instr x
3034   = getRegister x               `thenNat` \ register ->
3035     getNewRegNCG pk             `thenNat` \ tmp ->
3036     let
3037         code = registerCode register tmp
3038         src  = registerName register tmp
3039         code__2 dst = code `snocOL` instr src dst
3040     in
3041     returnNat (Any pk code__2)
3042
3043 #endif {- sparc_TARGET_ARCH -}
3044 \end{code}
3045
3046 %************************************************************************
3047 %*                                                                      *
3048 \subsubsection{Coercing to/from integer/floating-point...}
3049 %*                                                                      *
3050 %************************************************************************
3051
3052 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3053 to be generated.  Here we just change the type on the Register passed
3054 on up.  The code is machine-independent.
3055
3056 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3057 conversions.  We have to store temporaries in memory to move
3058 between the integer and the floating point register sets.
3059
3060 \begin{code}
3061 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3062 coerceFltCode ::            StixTree -> NatM Register
3063
3064 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3065 coerceFP2Int ::            StixTree -> NatM Register
3066
3067 coerceIntCode pk x
3068   = getRegister x               `thenNat` \ register ->
3069     returnNat (
3070     case register of
3071         Fixed _ reg code -> Fixed pk reg code
3072         Any   _ code     -> Any   pk code
3073     )
3074
3075 -------------
3076 coerceFltCode x
3077   = getRegister x               `thenNat` \ register ->
3078     returnNat (
3079     case register of
3080         Fixed _ reg code -> Fixed DoubleRep reg code
3081         Any   _ code     -> Any   DoubleRep code
3082     )
3083 \end{code}
3084
3085 \begin{code}
3086 #if alpha_TARGET_ARCH
3087
3088 coerceInt2FP _ x
3089   = getRegister x               `thenNat` \ register ->
3090     getNewRegNCG IntRep         `thenNat` \ reg ->
3091     let
3092         code = registerCode register reg
3093         src  = registerName register reg
3094
3095         code__2 dst = code . mkSeqInstrs [
3096             ST Q src (spRel 0),
3097             LD TF dst (spRel 0),
3098             CVTxy Q TF dst dst]
3099     in
3100     returnNat (Any DoubleRep code__2)
3101
3102 -------------
3103 coerceFP2Int x
3104   = getRegister x               `thenNat` \ register ->
3105     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3106     let
3107         code = registerCode register tmp
3108         src  = registerName register tmp
3109
3110         code__2 dst = code . mkSeqInstrs [
3111             CVTxy TF Q src tmp,
3112             ST TF tmp (spRel 0),
3113             LD Q dst (spRel 0)]
3114     in
3115     returnNat (Any IntRep code__2)
3116
3117 #endif {- alpha_TARGET_ARCH -}
3118 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3119 #if i386_TARGET_ARCH
3120
3121 coerceInt2FP pk x
3122   = getRegister x               `thenNat` \ register ->
3123     getNewRegNCG IntRep         `thenNat` \ reg ->
3124     let
3125         code = registerCode register reg
3126         src  = registerName register reg
3127         opc  = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3128         code__2 dst = code `snocOL` opc src dst
3129     in
3130     returnNat (Any pk code__2)
3131
3132 ------------
3133 coerceFP2Int x
3134   = getRegister x               `thenNat` \ register ->
3135     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3136     let
3137         code = registerCode register tmp
3138         src  = registerName register tmp
3139         pk   = registerRep register
3140
3141         opc  = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3142         code__2 dst = code `snocOL` opc src dst
3143     in
3144     returnNat (Any IntRep code__2)
3145
3146 #endif {- i386_TARGET_ARCH -}
3147 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3148 #if sparc_TARGET_ARCH
3149
3150 coerceInt2FP pk x
3151   = getRegister x               `thenNat` \ register ->
3152     getNewRegNCG IntRep         `thenNat` \ reg ->
3153     let
3154         code = registerCode register reg
3155         src  = registerName register reg
3156
3157         code__2 dst = code `appOL` toOL [
3158             ST W src (spRel (-2)),
3159             LD W (spRel (-2)) dst,
3160             FxTOy W (primRepToSize pk) dst dst]
3161     in
3162     returnNat (Any pk code__2)
3163
3164 ------------
3165 coerceFP2Int x
3166   = getRegister x               `thenNat` \ register ->
3167     getNewRegNCG IntRep         `thenNat` \ reg ->
3168     getNewRegNCG FloatRep       `thenNat` \ tmp ->
3169     let
3170         code = registerCode register reg
3171         src  = registerName register reg
3172         pk   = registerRep  register
3173
3174         code__2 dst = code `appOL` toOL [
3175             FxTOy (primRepToSize pk) W src tmp,
3176             ST W tmp (spRel (-2)),
3177             LD W (spRel (-2)) dst]
3178     in
3179     returnNat (Any IntRep code__2)
3180
3181 #endif {- sparc_TARGET_ARCH -}
3182 \end{code}
3183
3184 %************************************************************************
3185 %*                                                                      *
3186 \subsubsection{Coercing integer to @Char@...}
3187 %*                                                                      *
3188 %************************************************************************
3189
3190 Integer to character conversion.  Where applicable, we try to do this
3191 in one step if the original object is in memory.
3192
3193 \begin{code}
3194 chrCode :: StixTree -> NatM Register
3195
3196 #if alpha_TARGET_ARCH
3197
3198 chrCode x
3199   = getRegister x               `thenNat` \ register ->
3200     getNewRegNCG IntRep         `thenNat` \ reg ->
3201     let
3202         code = registerCode register reg
3203         src  = registerName register reg
3204         code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3205     in
3206     returnNat (Any IntRep code__2)
3207
3208 #endif {- alpha_TARGET_ARCH -}
3209 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3210 #if i386_TARGET_ARCH
3211
3212 chrCode x
3213   = getRegister x               `thenNat` \ register ->
3214     let
3215         code__2 dst = let
3216                           code = registerCode register dst
3217                           src  = registerName register dst
3218                       in code `appOL`
3219                          if   isFixed register && src /= dst
3220                          then toOL [MOV L (OpReg src) (OpReg dst),
3221                                     AND L (OpImm (ImmInt 255)) (OpReg dst)]
3222                          else unitOL (AND L (OpImm (ImmInt 255)) (OpReg src))
3223     in
3224     returnNat (Any IntRep code__2)
3225
3226 #endif {- i386_TARGET_ARCH -}
3227 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3228 #if sparc_TARGET_ARCH
3229
3230 chrCode (StInd pk mem)
3231   = getAmode mem                `thenNat` \ amode ->
3232     let
3233         code    = amodeCode amode
3234         src     = amodeAddr amode
3235         src_off = addrOffset src 3
3236         src__2  = case src_off of Just x -> x
3237         code__2 dst = if maybeToBool src_off then
3238                         code `snocOL` LD BU src__2 dst
3239                     else
3240                         code `snocOL`
3241                         LD (primRepToSize pk) src dst  `snocOL`
3242                         AND False dst (RIImm (ImmInt 255)) dst
3243     in
3244     returnNat (Any pk code__2)
3245
3246 chrCode x
3247   = getRegister x               `thenNat` \ register ->
3248     getNewRegNCG IntRep         `thenNat` \ reg ->
3249     let
3250         code = registerCode register reg
3251         src  = registerName register reg
3252         code__2 dst = code `snocOL` AND False src (RIImm (ImmInt 255)) dst
3253     in
3254     returnNat (Any IntRep code__2)
3255
3256 #endif {- sparc_TARGET_ARCH -}
3257 \end{code}