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