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