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, labelDynamic )
  24 import Maybes           ( maybeToBool, expectJust )
  25 import PrimRep          ( isFloatingRep, PrimRep(..) )
  26 import PrimOp           ( PrimOp(..) )
  27 import CallConv         ( cCallConv, stdCallConv )
  28 import Stix             ( getNatLabelNCG, StixTree(..),
  29                           StixReg(..), CodeSegment(..),
  30                           DestInfo, hasDestInfo,
  31                           pprStixTree,
  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 RoDataSegment,
 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     in
2207     returnNat (code `snocOL` JXX cond lbl)
2208
2209 #endif {- i386_TARGET_ARCH -}
2210 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2211 #if sparc_TARGET_ARCH
2212
2213 genCondJump lbl bool
2214   = getCondCode bool                `thenNat` \ condition ->
2215     let
2216         code   = condCode condition
2217         cond   = condName condition
2218         target = ImmCLbl lbl
2219     in
2220     returnNat (
2221        code `appOL`
2222        toOL (
2223          if   condFloat condition
2224          then [NOP, BF cond False target, NOP]
2225          else [BI cond False target, NOP]
2226        )
2227     )
2228
2229 #endif {- sparc_TARGET_ARCH -}
2230 \end{code}
2231
2232 %************************************************************************
2233 %*                                                                      *
2234 \subsection{Generating C calls}
2235 %*                                                                      *
2236 %************************************************************************
2237
2238 Now the biggest nightmare---calls.  Most of the nastiness is buried in
2239 @get_arg@, which moves the arguments to the correct registers/stack
2240 locations.  Apart from that, the code is easy.
2241
2242 (If applicable) Do not fill the delay slots here; you will confuse the
2243 register allocator.
2244
2245 \begin{code}
2246 genCCall
2247     :: FAST_STRING      -- function to call
2248     -> CallConv
2249     -> PrimRep          -- type of the result
2250     -> [StixTree]       -- arguments (of mixed type)
2251     -> NatM InstrBlock
2252
2253 #if alpha_TARGET_ARCH
2254
2255 genCCall fn cconv kind args
2256   = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2257                           `thenNat` \ ((unused,_), argCode) ->
2258     let
2259         nRegs = length allArgRegs - length unused
2260         code = asmSeqThen (map ($ []) argCode)
2261     in
2262         returnSeq code [
2263             LDA pv (AddrImm (ImmLab (ptext fn))),
2264             JSR ra (AddrReg pv) nRegs,
2265             LDGP gp (AddrReg ra)]
2266   where
2267     ------------------------
2268     {-  Try to get a value into a specific register (or registers) for
2269         a call.  The first 6 arguments go into the appropriate
2270         argument register (separate registers for integer and floating
2271         point arguments, but used in lock-step), and the remaining
2272         arguments are dumped to the stack, beginning at 0(sp).  Our
2273         first argument is a pair of the list of remaining argument
2274         registers to be assigned for this call and the next stack
2275         offset to use for overflowing arguments.  This way,
2276         @get_Arg@ can be applied to all of a call's arguments using
2277         @mapAccumLNat@.
2278     -}
2279     get_arg
2280         :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
2281         -> StixTree             -- Current argument
2282         -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2283
2284     -- We have to use up all of our argument registers first...
2285
2286     get_arg ((iDst,fDst):dsts, offset) arg
2287       = getRegister arg                     `thenNat` \ register ->
2288         let
2289             reg  = if isFloatingRep pk then fDst else iDst
2290             code = registerCode register reg
2291             src  = registerName register reg
2292             pk   = registerRep register
2293         in
2294         returnNat (
2295             if isFloatingRep pk then
2296                 ((dsts, offset), if isFixed register then
2297                     code . mkSeqInstr (FMOV src fDst)
2298                     else code)
2299             else
2300                 ((dsts, offset), if isFixed register then
2301                     code . mkSeqInstr (OR src (RIReg src) iDst)
2302                     else code))
2303
2304     -- Once we have run out of argument registers, we move to the
2305     -- stack...
2306
2307     get_arg ([], offset) arg
2308       = getRegister arg                 `thenNat` \ register ->
2309         getNewRegNCG (registerRep register)
2310                                         `thenNat` \ tmp ->
2311         let
2312             code = registerCode register tmp
2313             src  = registerName register tmp
2314             pk   = registerRep register
2315             sz   = primRepToSize pk
2316         in
2317         returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2318
2319 #endif {- alpha_TARGET_ARCH -}
2320 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2321 #if i386_TARGET_ARCH
2322
2323 genCCall fn cconv kind [StInt i]
2324   | fn == SLIT ("PerformGC_wrapper")
2325   = let call = toOL [
2326                   MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2327                   CALL (ImmLit (ptext (if   underscorePrefix
2328                                        then (SLIT ("_PerformGC_wrapper"))
2329                                        else (SLIT ("PerformGC_wrapper")))))
2330                ]
2331     in
2332     returnNat call
2333
2334
2335 genCCall fn cconv kind args
2336   = mapNat get_call_arg
2337            (reverse args)  `thenNat` \ sizes_n_codes ->
2338     getDeltaNat            `thenNat` \ delta ->
2339     let (sizes, codes) = unzip sizes_n_codes
2340         tot_arg_size   = sum sizes
2341         code2          = concatOL codes
2342         call = toOL (
2343                   [CALL (fn__2 tot_arg_size)]
2344                   ++
2345                   (if cconv == stdCallConv then [] else
2346                    [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2347                   ++
2348                   [DELTA (delta + tot_arg_size)]
2349                )
2350     in
2351     setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2352     returnNat (code2 `appOL` call)
2353
2354   where
2355     -- function names that begin with '.' are assumed to be special
2356     -- internally generated names like '.mul,' which don't get an
2357     -- underscore prefix
2358     -- ToDo:needed (WDP 96/03) ???
2359     fn_u  = _UNPK_ fn
2360     fn__2 tot_arg_size
2361        | head fn_u == '.'
2362        = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2363        | otherwise
2364        = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2365
2366     stdcallsize tot_arg_size
2367        | cconv == stdCallConv = '@':show tot_arg_size
2368        | otherwise            = ""
2369
2370     arg_size DF = 8
2371     arg_size F  = 4
2372     arg_size _  = 4
2373
2374     ------------
2375     get_call_arg :: StixTree{-current argument-}
2376                     -> NatM (Int, InstrBlock)  -- argsz, code
2377
2378     get_call_arg arg
2379       = get_op arg                `thenNat` \ (code, reg, sz) ->
2380         getDeltaNat               `thenNat` \ delta ->
2381         arg_size sz               `bind`    \ size ->
2382         setDeltaNat (delta-size)  `thenNat` \ _ ->
2383         if   (case sz of DF -> True; F -> True; _ -> False)
2384         then returnNat (size,
2385                         code `appOL`
2386                         toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2387                               DELTA (delta-size),
2388                               GST sz reg (AddrBaseIndex (Just esp)
2389                                                         Nothing
2390                                                         (ImmInt 0))]
2391                        )
2392         else returnNat (size,
2393                         code `snocOL`
2394                         PUSH L (OpReg reg) `snocOL`
2395                         DELTA (delta-size)
2396                        )
2397     ------------
2398     get_op
2399         :: StixTree
2400         -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2401
2402     get_op op
2403       = getRegister op          `thenNat` \ register ->
2404         getNewRegNCG (registerRep register)
2405                                 `thenNat` \ tmp ->
2406         let
2407             code = registerCode register tmp
2408             reg  = registerName register tmp
2409             pk   = registerRep  register
2410             sz   = primRepToSize pk
2411         in
2412         returnNat (code, reg, sz)
2413
2414 #endif {- i386_TARGET_ARCH -}
2415 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2416 #if sparc_TARGET_ARCH
2417 {-
2418    The SPARC calling convention is an absolute
2419    nightmare.  The first 6x32 bits of arguments are mapped into
2420    %o0 through %o5, and the remaining arguments are dumped to the
2421    stack, beginning at [%sp+92].  (Note that %o6 == %sp.)
2422
2423    If we have to put args on the stack, move %o6==%sp down by
2424    the number of words to go on the stack, to ensure there's enough space.
2425
2426    According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2427    16 words above the stack pointer is a word for the address of
2428    a structure return value.  I use this as a temporary location
2429    for moving values from float to int regs.  Certainly it isn't
2430    safe to put anything in the 16 words starting at %sp, since
2431    this area can get trashed at any time due to window overflows
2432    caused by signal handlers.
2433
2434    A final complication (if the above isn't enough) is that
2435    we can't blithely calculate the arguments one by one into
2436    %o0 .. %o5.  Consider the following nested calls:
2437
2438        fff a (fff b c)
2439
2440    Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately
2441    the inner call will itself use %o0, which trashes the value put there
2442    in preparation for the outer call.  Upshot: we need to calculate the
2443    args into temporary regs, and move those to arg regs or onto the
2444    stack only immediately prior to the call proper.  Sigh.
2445 -}
2446
2447 genCCall fn cconv kind args
2448   = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2449     let (argcodes, vregss) = unzip argcode_and_vregs
2450         argcode            = concatOL argcodes
2451         vregs              = concat vregss
2452         n_argRegs          = length allArgRegs
2453         n_argRegs_used     = min (length vregs) n_argRegs
2454         (move_sp_down, move_sp_up)
2455            = let nn = length vregs - n_argRegs
2456                                    + 1 -- (for the road)
2457              in  if   nn <= 0
2458                  then (nilOL, nilOL)
2459                  else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2460         transfer_code
2461            = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2462         call
2463            = unitOL (CALL fn__2 n_argRegs_used False)
2464     in
2465         returnNat (argcode       `appOL`
2466                    move_sp_down  `appOL`
2467                    transfer_code `appOL`
2468                    call          `appOL`
2469                    unitOL NOP    `appOL`
2470                    move_sp_up)
2471   where
2472      -- function names that begin with '.' are assumed to be special
2473      -- internally generated names like '.mul,' which don't get an
2474      -- underscore prefix
2475      -- ToDo:needed (WDP 96/03) ???
2476      fn__2 = case (_HEAD_ fn) of
2477                 '.' -> ImmLit (ptext fn)
2478                 _   -> ImmLab False (ptext fn)
2479
2480      -- move args from the integer vregs into which they have been
2481      -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2482      move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2483
2484      move_final [] _ offset          -- all args done
2485         = []
2486
2487      move_final (v:vs) [] offset     -- out of aregs; move to stack
2488         = ST W v (spRel offset)
2489           : move_final vs [] (offset+1)
2490
2491      move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2492         = OR False g0 (RIReg v) a
2493           : move_final vs az offset
2494
2495      -- generate code to calculate an argument, and move it into one
2496      -- or two integer vregs.
2497      arg_to_int_vregs :: StixTree -> NatM (OrdList Instr, [Reg])
2498      arg_to_int_vregs arg
2499         = getRegister arg                     `thenNat` \ register ->
2500           getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2501           let code = registerCode register tmp
2502               src  = registerName register tmp
2503               pk   = registerRep register
2504           in
2505           -- the value is in src.  Get it into 1 or 2 int vregs.
2506           case pk of
2507              DoubleRep ->
2508                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2509                 getNewRegNCG WordRep  `thenNat` \ v2 ->
2510                 returnNat (
2511                    code                          `snocOL`
2512                    FMOV DF src f0                `snocOL`
2513                    ST   F  f0 (spRel 16)         `snocOL`
2514                    LD   W  (spRel 16) v1         `snocOL`
2515                    ST   F  (fPair f0) (spRel 16) `snocOL`
2516                    LD   W  (spRel 16) v2
2517                    ,
2518                    [v1,v2]
2519                 )
2520              FloatRep ->
2521                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2522                 returnNat (
2523                    code                    `snocOL`
2524                    ST   F  src (spRel 16)  `snocOL`
2525                    LD   W  (spRel 16) v1
2526                    ,
2527                    [v1]
2528                 )
2529              other ->
2530                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2531                 returnNat (
2532                    code `snocOL` OR False g0 (RIReg src) v1
2533                    ,
2534                    [v1]
2535                 )
2536 #endif {- sparc_TARGET_ARCH -}
2537 \end{code}
2538
2539 %************************************************************************
2540 %*                                                                      *
2541 \subsection{Support bits}
2542 %*                                                                      *
2543 %************************************************************************
2544
2545 %************************************************************************
2546 %*                                                                      *
2547 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2548 %*                                                                      *
2549 %************************************************************************
2550
2551 Turn those condition codes into integers now (when they appear on
2552 the right hand side of an assignment).
2553
2554 (If applicable) Do not fill the delay slots here; you will confuse the
2555 register allocator.
2556
2557 \begin{code}
2558 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> NatM Register
2559
2560 #if alpha_TARGET_ARCH
2561 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2562 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2563 #endif {- alpha_TARGET_ARCH -}
2564
2565 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2566 #if i386_TARGET_ARCH
2567
2568 condIntReg cond x y
2569   = condIntCode cond x y        `thenNat` \ condition ->
2570     getNewRegNCG IntRep         `thenNat` \ tmp ->
2571     let
2572         code = condCode condition
2573         cond = condName condition
2574         code__2 dst = code `appOL` toOL [
2575             SETCC cond (OpReg tmp),
2576             AND L (OpImm (ImmInt 1)) (OpReg tmp),
2577             MOV L (OpReg tmp) (OpReg dst)]
2578     in
2579     returnNat (Any IntRep code__2)
2580
2581 condFltReg cond x y
2582   = getNatLabelNCG              `thenNat` \ lbl1 ->
2583     getNatLabelNCG              `thenNat` \ lbl2 ->
2584     condFltCode cond x y        `thenNat` \ condition ->
2585     let
2586         code = condCode condition
2587         cond = condName condition
2588         code__2 dst = code `appOL` toOL [
2589             JXX cond lbl1,
2590             MOV L (OpImm (ImmInt 0)) (OpReg dst),
2591             JXX ALWAYS lbl2,
2592             LABEL lbl1,
2593             MOV L (OpImm (ImmInt 1)) (OpReg dst),
2594             LABEL lbl2]
2595     in
2596     returnNat (Any IntRep code__2)
2597
2598 #endif {- i386_TARGET_ARCH -}
2599 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2600 #if sparc_TARGET_ARCH
2601
2602 condIntReg EQQ x (StInt 0)
2603   = getRegister x               `thenNat` \ register ->
2604     getNewRegNCG IntRep         `thenNat` \ tmp ->
2605     let
2606         code = registerCode register tmp
2607         src  = registerName register tmp
2608         code__2 dst = code `appOL` toOL [
2609             SUB False True g0 (RIReg src) g0,
2610             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2611     in
2612     returnNat (Any IntRep code__2)
2613
2614 condIntReg EQQ x y
2615   = getRegister x               `thenNat` \ register1 ->
2616     getRegister y               `thenNat` \ register2 ->
2617     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2618     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
2619     let
2620         code1 = registerCode register1 tmp1
2621         src1  = registerName register1 tmp1
2622         code2 = registerCode register2 tmp2
2623         src2  = registerName register2 tmp2
2624         code__2 dst = code1 `appOL` code2 `appOL` toOL [
2625             XOR False src1 (RIReg src2) dst,
2626             SUB False True g0 (RIReg dst) g0,
2627             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2628     in
2629     returnNat (Any IntRep code__2)
2630
2631 condIntReg NE x (StInt 0)
2632   = getRegister x               `thenNat` \ register ->
2633     getNewRegNCG IntRep         `thenNat` \ tmp ->
2634     let
2635         code = registerCode register tmp
2636         src  = registerName register tmp
2637         code__2 dst = code `appOL` toOL [
2638             SUB False True g0 (RIReg src) g0,
2639             ADD True False g0 (RIImm (ImmInt 0)) dst]
2640     in
2641     returnNat (Any IntRep code__2)
2642
2643 condIntReg NE x y
2644   = getRegister x               `thenNat` \ register1 ->
2645     getRegister y               `thenNat` \ register2 ->
2646     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2647     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
2648     let
2649         code1 = registerCode register1 tmp1
2650         src1  = registerName register1 tmp1
2651         code2 = registerCode register2 tmp2
2652         src2  = registerName register2 tmp2
2653         code__2 dst = code1 `appOL` code2 `appOL` toOL [
2654             XOR False src1 (RIReg src2) dst,
2655             SUB False True g0 (RIReg dst) g0,
2656             ADD True False g0 (RIImm (ImmInt 0)) dst]
2657     in
2658     returnNat (Any IntRep code__2)
2659
2660 condIntReg cond x y
2661   = getNatLabelNCG              `thenNat` \ lbl1 ->
2662     getNatLabelNCG              `thenNat` \ lbl2 ->
2663     condIntCode cond x y        `thenNat` \ condition ->
2664     let
2665         code = condCode condition
2666         cond = condName condition
2667         code__2 dst = code `appOL` toOL [
2668             BI cond False (ImmCLbl lbl1), NOP,
2669             OR False g0 (RIImm (ImmInt 0)) dst,
2670             BI ALWAYS False (ImmCLbl lbl2), NOP,
2671             LABEL lbl1,
2672             OR False g0 (RIImm (ImmInt 1)) dst,
2673             LABEL lbl2]
2674     in
2675     returnNat (Any IntRep code__2)
2676
2677 condFltReg cond x y
2678   = getNatLabelNCG              `thenNat` \ lbl1 ->
2679     getNatLabelNCG              `thenNat` \ lbl2 ->
2680     condFltCode cond x y        `thenNat` \ condition ->
2681     let
2682         code = condCode condition
2683         cond = condName condition
2684         code__2 dst = code `appOL` toOL [
2685             NOP,
2686             BF cond False (ImmCLbl lbl1), NOP,
2687             OR False g0 (RIImm (ImmInt 0)) dst,
2688             BI ALWAYS False (ImmCLbl lbl2), NOP,
2689             LABEL lbl1,
2690             OR False g0 (RIImm (ImmInt 1)) dst,
2691             LABEL lbl2]
2692     in
2693     returnNat (Any IntRep code__2)
2694
2695 #endif {- sparc_TARGET_ARCH -}
2696 \end{code}
2697
2698 %************************************************************************
2699 %*                                                                      *
2700 \subsubsection{@trivial*Code@: deal with trivial instructions}
2701 %*                                                                      *
2702 %************************************************************************
2703
2704 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2705 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions.  Only look
2706 for constants on the right hand side, because that's where the generic
2707 optimizer will have put them.
2708
2709 Similarly, for unary instructions, we don't have to worry about
2710 matching an StInt as the argument, because genericOpt will already
2711 have handled the constant-folding.
2712
2713 \begin{code}
2714 trivialCode
2715     :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2716       ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2717                      -> Maybe (Operand -> Operand -> Instr)
2718       ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2719       ,)))
2720     -> StixTree -> StixTree -- the two arguments
2721     -> NatM Register
2722
2723 trivialFCode
2724     :: PrimRep
2725     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2726       ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2727       ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2728       ,)))
2729     -> StixTree -> StixTree -- the two arguments
2730     -> NatM Register
2731
2732 trivialUCode
2733     :: IF_ARCH_alpha((RI -> Reg -> Instr)
2734       ,IF_ARCH_i386 ((Operand -> Instr)
2735       ,IF_ARCH_sparc((RI -> Reg -> Instr)
2736       ,)))
2737     -> StixTree -- the one argument
2738     -> NatM Register
2739
2740 trivialUFCode
2741     :: PrimRep
2742     -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2743       ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2744       ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2745       ,)))
2746     -> StixTree -- the one argument
2747     -> NatM Register
2748
2749 #if alpha_TARGET_ARCH
2750
2751 trivialCode instr x (StInt y)
2752   | fits8Bits y
2753   = getRegister x               `thenNat` \ register ->
2754     getNewRegNCG IntRep         `thenNat` \ tmp ->
2755     let
2756         code = registerCode register tmp
2757         src1 = registerName register tmp
2758         src2 = ImmInt (fromInteger y)
2759         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2760     in
2761     returnNat (Any IntRep code__2)
2762
2763 trivialCode instr x y
2764   = getRegister x               `thenNat` \ register1 ->
2765     getRegister y               `thenNat` \ register2 ->
2766     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2767     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
2768     let
2769         code1 = registerCode register1 tmp1 []
2770         src1  = registerName register1 tmp1
2771         code2 = registerCode register2 tmp2 []
2772         src2  = registerName register2 tmp2
2773         code__2 dst = asmSeqThen [code1, code2] .
2774                      mkSeqInstr (instr src1 (RIReg src2) dst)
2775     in
2776     returnNat (Any IntRep code__2)
2777
2778 ------------
2779 trivialUCode instr x
2780   = getRegister x               `thenNat` \ register ->
2781     getNewRegNCG IntRep         `thenNat` \ tmp ->
2782     let
2783         code = registerCode register tmp
2784         src  = registerName register tmp
2785         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2786     in
2787     returnNat (Any IntRep code__2)
2788
2789 ------------
2790 trivialFCode _ instr x y
2791   = getRegister x               `thenNat` \ register1 ->
2792     getRegister y               `thenNat` \ register2 ->
2793     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
2794     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
2795     let
2796         code1 = registerCode register1 tmp1
2797         src1  = registerName register1 tmp1
2798
2799         code2 = registerCode register2 tmp2
2800         src2  = registerName register2 tmp2
2801
2802         code__2 dst = asmSeqThen [code1 [], code2 []] .
2803                       mkSeqInstr (instr src1 src2 dst)
2804     in
2805     returnNat (Any DoubleRep code__2)
2806
2807 trivialUFCode _ instr x
2808   = getRegister x               `thenNat` \ register ->
2809     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
2810     let
2811         code = registerCode register tmp
2812         src  = registerName register tmp
2813         code__2 dst = code . mkSeqInstr (instr src dst)
2814     in
2815     returnNat (Any DoubleRep code__2)
2816
2817 #endif {- alpha_TARGET_ARCH -}
2818 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2819 #if i386_TARGET_ARCH
2820 \end{code}
2821 The Rules of the Game are:
2822
2823 * You cannot assume anything about the destination register dst;
2824   it may be anything, including a fixed reg.
2825
2826 * You may compute an operand into a fixed reg, but you may not
2827   subsequently change the contents of that fixed reg.  If you
2828   want to do so, first copy the value either to a temporary
2829   or into dst.  You are free to modify dst even if it happens
2830   to be a fixed reg -- that's not your problem.
2831
2832 * You cannot assume that a fixed reg will stay live over an
2833   arbitrary computation.  The same applies to the dst reg.
2834
2835 * Temporary regs obtained from getNewRegNCG are distinct from
2836   each other and from all other regs, and stay live over
2837   arbitrary computations.
2838
2839 \begin{code}
2840
2841 trivialCode instr maybe_revinstr a b
2842
2843   | is_imm_b
2844   = getRegister a                         `thenNat` \ rega ->
2845     let mkcode dst
2846           = if   isAny rega
2847             then registerCode rega dst      `bind` \ code_a ->
2848                  code_a `snocOL`
2849                  instr (OpImm imm_b) (OpReg dst)
2850             else registerCodeF rega         `bind` \ code_a ->
2851                  registerNameF rega         `bind` \ r_a ->
2852                  code_a `snocOL`
2853                  MOV L (OpReg r_a) (OpReg dst) `snocOL`
2854                  instr (OpImm imm_b) (OpReg dst)
2855     in
2856     returnNat (Any IntRep mkcode)
2857
2858   | is_imm_a
2859   = getRegister b                         `thenNat` \ regb ->
2860     getNewRegNCG IntRep                   `thenNat` \ tmp ->
2861     let revinstr_avail = maybeToBool maybe_revinstr
2862         revinstr       = case maybe_revinstr of Just ri -> ri
2863         mkcode dst
2864           | revinstr_avail
2865           = if   isAny regb
2866             then registerCode regb dst      `bind` \ code_b ->
2867                  code_b `snocOL`
2868                  revinstr (OpImm imm_a) (OpReg dst)
2869             else registerCodeF regb         `bind` \ code_b ->
2870                  registerNameF regb         `bind` \ r_b ->
2871                  code_b `snocOL`
2872                  MOV L (OpReg r_b) (OpReg dst) `snocOL`
2873                  revinstr (OpImm imm_a) (OpReg dst)
2874
2875           | otherwise
2876           = if   isAny regb
2877             then registerCode regb tmp      `bind` \ code_b ->
2878                  code_b `snocOL`
2879                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2880                  instr (OpReg tmp) (OpReg dst)
2881             else registerCodeF regb         `bind` \ code_b ->
2882                  registerNameF regb         `bind` \ r_b ->
2883                  code_b `snocOL`
2884                  MOV L (OpReg r_b) (OpReg tmp) `snocOL`
2885                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
2886                  instr (OpReg tmp) (OpReg dst)
2887     in
2888     returnNat (Any IntRep mkcode)
2889
2890   | otherwise
2891   = getRegister a                         `thenNat` \ rega ->
2892     getRegister b                         `thenNat` \ regb ->
2893     getNewRegNCG IntRep                   `thenNat` \ tmp ->
2894     let mkcode dst
2895           = case (isAny rega, isAny regb) of
2896               (True, True)
2897                  -> registerCode regb tmp   `bind` \ code_b ->
2898                     registerCode rega dst   `bind` \ code_a ->
2899                     code_b `appOL`
2900                     code_a `snocOL`
2901                     instr (OpReg tmp) (OpReg dst)
2902               (True, False)
2903                  -> registerCode  rega tmp  `bind` \ code_a ->
2904                     registerCodeF regb      `bind` \ code_b ->
2905                     registerNameF regb      `bind` \ r_b ->
2906                     code_a `appOL`
2907                     code_b `snocOL`
2908                     instr (OpReg r_b) (OpReg tmp) `snocOL`
2909                     MOV L (OpReg tmp) (OpReg dst)
2910               (False, True)
2911                  -> registerCode  regb tmp  `bind` \ code_b ->
2912                     registerCodeF rega      `bind` \ code_a ->
2913                     registerNameF rega      `bind` \ r_a ->
2914                     code_b `appOL`
2915                     code_a `snocOL`
2916                     MOV L (OpReg r_a) (OpReg dst) `snocOL`
2917                     instr (OpReg tmp) (OpReg dst)
2918               (False, False)
2919                  -> registerCodeF  rega     `bind` \ code_a ->
2920                     registerNameF  rega     `bind` \ r_a ->
2921                     registerCodeF  regb     `bind` \ code_b ->
2922                     registerNameF  regb     `bind` \ r_b ->
2923                     code_a `snocOL`
2924                     MOV L (OpReg r_a) (OpReg tmp) `appOL`
2925                     code_b `snocOL`
2926                     instr (OpReg r_b) (OpReg tmp) `snocOL`
2927                     MOV L (OpReg tmp) (OpReg dst)
2928     in
2929     returnNat (Any IntRep mkcode)
2930
2931     where
2932        maybe_imm_a = maybeImm a
2933        is_imm_a    = maybeToBool maybe_imm_a
2934        imm_a       = case maybe_imm_a of Just imm -> imm
2935
2936        maybe_imm_b = maybeImm b
2937        is_imm_b    = maybeToBool maybe_imm_b
2938        imm_b       = case maybe_imm_b of Just imm -> imm
2939
2940
2941 -----------
2942 trivialUCode instr x
2943   = getRegister x               `thenNat` \ register ->
2944     let
2945         code__2 dst = let code = registerCode register dst
2946                           src  = registerName register dst
2947                       in code `appOL`
2948                          if   isFixed register && dst /= src
2949                          then toOL [MOV L (OpReg src) (OpReg dst),
2950                                     instr (OpReg dst)]
2951                          else unitOL (instr (OpReg src))
2952     in
2953     returnNat (Any IntRep code__2)
2954
2955 -----------
2956 trivialFCode pk instr x y
2957   = getRegister x               `thenNat` \ register1 ->
2958     getRegister y               `thenNat` \ register2 ->
2959     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
2960     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
2961     let
2962         code1 = registerCode register1 tmp1
2963         src1  = registerName register1 tmp1
2964
2965         code2 = registerCode register2 tmp2
2966         src2  = registerName register2 tmp2
2967
2968         code__2 dst
2969            -- treat the common case specially: both operands in
2970            -- non-fixed regs.
2971            | isAny register1 && isAny register2
2972            = code1 `appOL`
2973              code2 `snocOL`
2974              instr (primRepToSize pk) src1 src2 dst
2975
2976            -- be paranoid (and inefficient)
2977            | otherwise
2978            = code1 `snocOL` GMOV src1 tmp1  `appOL`
2979              code2 `snocOL`
2980              instr (primRepToSize pk) tmp1 src2 dst
2981     in
2982     returnNat (Any pk code__2)
2983
2984
2985 -------------
2986 trivialUFCode pk instr x
2987   = getRegister x               `thenNat` \ register ->
2988     getNewRegNCG pk             `thenNat` \ tmp ->
2989     let
2990         code = registerCode register tmp
2991         src  = registerName register tmp
2992         code__2 dst = code `snocOL` instr src dst
2993     in
2994     returnNat (Any pk code__2)
2995
2996 #endif {- i386_TARGET_ARCH -}
2997 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2998 #if sparc_TARGET_ARCH
2999
3000 trivialCode instr x (StInt y)
3001   | fits13Bits y
3002   = getRegister x               `thenNat` \ register ->
3003     getNewRegNCG IntRep         `thenNat` \ tmp ->
3004     let
3005         code = registerCode register tmp
3006         src1 = registerName register tmp
3007         src2 = ImmInt (fromInteger y)
3008         code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3009     in
3010     returnNat (Any IntRep code__2)
3011
3012 trivialCode instr x y
3013   = getRegister x               `thenNat` \ register1 ->
3014     getRegister y               `thenNat` \ register2 ->
3015     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3016     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3017     let
3018         code1 = registerCode register1 tmp1
3019         src1  = registerName register1 tmp1
3020         code2 = registerCode register2 tmp2
3021         src2  = registerName register2 tmp2
3022         code__2 dst = code1 `appOL` code2 `snocOL`
3023                       instr src1 (RIReg src2) dst
3024     in
3025     returnNat (Any IntRep code__2)
3026
3027 ------------
3028 trivialFCode pk instr x y
3029   = getRegister x               `thenNat` \ register1 ->
3030     getRegister y               `thenNat` \ register2 ->
3031     getNewRegNCG (registerRep register1)
3032                                 `thenNat` \ tmp1 ->
3033     getNewRegNCG (registerRep register2)
3034                                 `thenNat` \ tmp2 ->
3035     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3036     let
3037         promote x = FxTOy F DF x tmp
3038
3039         pk1   = registerRep register1
3040         code1 = registerCode register1 tmp1
3041         src1  = registerName register1 tmp1
3042
3043         pk2   = registerRep register2
3044         code2 = registerCode register2 tmp2
3045         src2  = registerName register2 tmp2
3046
3047         code__2 dst =
3048                 if pk1 == pk2 then
3049                     code1 `appOL` code2 `snocOL`
3050                     instr (primRepToSize pk) src1 src2 dst
3051                 else if pk1 == FloatRep then
3052                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3053                     instr DF tmp src2 dst
3054                 else
3055                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3056                     instr DF src1 tmp dst
3057     in
3058     returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3059
3060 ------------
3061 trivialUCode instr x
3062   = getRegister x               `thenNat` \ register ->
3063     getNewRegNCG IntRep         `thenNat` \ tmp ->
3064     let
3065         code = registerCode register tmp
3066         src  = registerName register tmp
3067         code__2 dst = code `snocOL` instr (RIReg src) dst
3068     in
3069     returnNat (Any IntRep code__2)
3070
3071 -------------
3072 trivialUFCode pk instr x
3073   = getRegister x               `thenNat` \ register ->
3074     getNewRegNCG pk             `thenNat` \ tmp ->
3075     let
3076         code = registerCode register tmp
3077         src  = registerName register tmp
3078         code__2 dst = code `snocOL` instr src dst
3079     in
3080     returnNat (Any pk code__2)
3081
3082 #endif {- sparc_TARGET_ARCH -}
3083 \end{code}
3084
3085 %************************************************************************
3086 %*                                                                      *
3087 \subsubsection{Coercing to/from integer/floating-point...}
3088 %*                                                                      *
3089 %************************************************************************
3090
3091 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3092 to be generated.  Here we just change the type on the Register passed
3093 on up.  The code is machine-independent.
3094
3095 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3096 conversions.  We have to store temporaries in memory to move
3097 between the integer and the floating point register sets.
3098
3099 \begin{code}
3100 coerceIntCode :: PrimRep -> StixTree -> NatM Register
3101 coerceFltCode ::            StixTree -> NatM Register
3102
3103 coerceInt2FP :: PrimRep -> StixTree -> NatM Register
3104 coerceFP2Int ::            StixTree -> NatM Register
3105
3106 coerceIntCode pk x
3107   = getRegister x               `thenNat` \ register ->
3108     returnNat (
3109     case register of
3110         Fixed _ reg code -> Fixed pk reg code
3111         Any   _ code     -> Any   pk code
3112     )
3113
3114 -------------
3115 coerceFltCode x
3116   = getRegister x               `thenNat` \ register ->
3117     returnNat (
3118     case register of
3119         Fixed _ reg code -> Fixed DoubleRep reg code
3120         Any   _ code     -> Any   DoubleRep code
3121     )
3122 \end{code}
3123
3124 \begin{code}
3125 #if alpha_TARGET_ARCH
3126
3127 coerceInt2FP _ x
3128   = getRegister x               `thenNat` \ register ->
3129     getNewRegNCG IntRep         `thenNat` \ reg ->
3130     let
3131         code = registerCode register reg
3132         src  = registerName register reg
3133
3134         code__2 dst = code . mkSeqInstrs [
3135             ST Q src (spRel 0),
3136             LD TF dst (spRel 0),
3137             CVTxy Q TF dst dst]
3138     in
3139     returnNat (Any DoubleRep code__2)
3140
3141 -------------
3142 coerceFP2Int x
3143   = getRegister x               `thenNat` \ register ->
3144     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3145     let
3146         code = registerCode register tmp
3147         src  = registerName register tmp
3148
3149         code__2 dst = code . mkSeqInstrs [
3150             CVTxy TF Q src tmp,
3151             ST TF tmp (spRel 0),
3152             LD Q dst (spRel 0)]
3153     in
3154     returnNat (Any IntRep code__2)
3155
3156 #endif {- alpha_TARGET_ARCH -}
3157 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3158 #if i386_TARGET_ARCH
3159
3160 coerceInt2FP pk x
3161   = getRegister x               `thenNat` \ register ->
3162     getNewRegNCG IntRep         `thenNat` \ reg ->
3163     let
3164         code = registerCode register reg
3165         src  = registerName register reg
3166         opc  = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3167         code__2 dst = code `snocOL` opc src dst
3168     in
3169     returnNat (Any pk code__2)
3170
3171 ------------
3172 coerceFP2Int x
3173   = getRegister x               `thenNat` \ register ->
3174     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3175     let
3176         code = registerCode register tmp
3177         src  = registerName register tmp
3178         pk   = registerRep register
3179
3180         opc  = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3181         code__2 dst = code `snocOL` opc src dst
3182     in
3183     returnNat (Any IntRep code__2)
3184
3185 #endif {- i386_TARGET_ARCH -}
3186 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3187 #if sparc_TARGET_ARCH
3188
3189 coerceInt2FP pk x
3190   = getRegister x               `thenNat` \ register ->
3191     getNewRegNCG IntRep         `thenNat` \ reg ->
3192     let
3193         code = registerCode register reg
3194         src  = registerName register reg
3195
3196         code__2 dst = code `appOL` toOL [
3197             ST W src (spRel (-2)),
3198             LD W (spRel (-2)) dst,
3199             FxTOy W (primRepToSize pk) dst dst]
3200     in
3201     returnNat (Any pk code__2)
3202
3203 ------------
3204 coerceFP2Int x
3205   = getRegister x               `thenNat` \ register ->
3206     getNewRegNCG IntRep         `thenNat` \ reg ->
3207     getNewRegNCG FloatRep       `thenNat` \ tmp ->
3208     let
3209         code = registerCode register reg
3210         src  = registerName register reg
3211         pk   = registerRep  register
3212
3213         code__2 dst = code `appOL` toOL [
3214             FxTOy (primRepToSize pk) W src tmp,
3215             ST W tmp (spRel (-2)),
3216             LD W (spRel (-2)) dst]
3217     in
3218     returnNat (Any IntRep code__2)
3219
3220 #endif {- sparc_TARGET_ARCH -}
3221 \end{code}
3222
3223 %************************************************************************
3224 %*                                                                      *
3225 \subsubsection{Coercing integer to @Char@...}
3226 %*                                                                      *
3227 %************************************************************************
3228
3229 Integer to character conversion.
3230
3231 \begin{code}
3232 chrCode :: StixTree -> NatM Register
3233
3234 #if alpha_TARGET_ARCH
3235
3236 -- TODO: This is probably wrong, but I don't know Alpha assembler.
3237 -- It should coerce a 64-bit value to a 32-bit value.
3238
3239 chrCode x
3240   = getRegister x               `thenNat` \ register ->
3241     getNewRegNCG IntRep         `thenNat` \ reg ->
3242     let
3243         code = registerCode register reg
3244         src  = registerName register reg
3245         code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3246     in
3247     returnNat (Any IntRep code__2)
3248
3249 #endif {- alpha_TARGET_ARCH -}
3250 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3251 #if i386_TARGET_ARCH
3252
3253 chrCode x
3254   = getRegister x               `thenNat` \ register ->
3255     returnNat (
3256     case register of
3257         Fixed _ reg code -> Fixed IntRep reg code
3258         Any   _ code     -> Any   IntRep code
3259     )
3260
3261 #endif {- i386_TARGET_ARCH -}
3262 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3263 #if sparc_TARGET_ARCH
3264
3265 chrCode x
3266   = getRegister x               `thenNat` \ register ->
3267     returnNat (
3268     case register of
3269         Fixed _ reg code -> Fixed IntRep reg code
3270         Any   _ code     -> Any   IntRep code
3271     )
3272
3273 #endif {- sparc_TARGET_ARCH -}
3274 \end{code}