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