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