ghc/compiler/nativeGen/MachCode.lhs

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