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