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