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                           getPrimRepSizeInBytes )
  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 * getPrimRepSizeInBytes 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 (getPrimRepSizeInBytes 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 getPrimRepSizeInBytes 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 * getPrimRepSizeInBytes 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       MO_32U_to_NatU  -> conversionNop WordRep   x
 868
 869       MO_NatU_to_NatS -> conversionNop IntRep    x
 870       MO_NatS_to_NatU -> conversionNop WordRep   x
 871       MO_NatP_to_NatU -> conversionNop WordRep   x
 872       MO_NatU_to_NatP -> conversionNop PtrRep    x
 873       MO_NatS_to_NatP -> conversionNop PtrRep    x
 874       MO_NatP_to_NatS -> conversionNop IntRep    x
 875
 876       MO_Dbl_to_Flt   -> conversionNop FloatRep  x
 877       MO_Flt_to_Dbl   -> conversionNop DoubleRep x
 878
 879       -- sign-extending widenings
 880       MO_8U_to_NatU   -> integerExtend False 24 x
 881       MO_8S_to_NatS   -> integerExtend True  24 x
 882       MO_16U_to_NatU  -> integerExtend False 16 x
 883       MO_16S_to_NatS  -> integerExtend True  16 x
 884       MO_8U_to_32U    -> integerExtend False 24 x
 885
 886       other_op
 887          -> getRegister (
 888                (if is_float_op then demote else id)
 889                (StCall (Left fn) CCallConv DoubleRep
 890                        [(if is_float_op then promote else id) x])
 891             )
 892       where
 893         integerExtend signed nBits x
 894            = getRegister (
 895                 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
 896                          [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
 897              )
 898
 899         conversionNop new_rep expr
 900             = getRegister expr          `thenNat` \ e_code ->
 901               returnNat (swizzleRegisterRep e_code new_rep)
 902
 903         promote x = StMachOp MO_Flt_to_Dbl [x]
 904         demote  x = StMachOp MO_Dbl_to_Flt [x]
 905         (is_float_op, fn)
 906           = case mop of
 907               MO_Flt_Exp   -> (True,  FSLIT("exp"))
 908               MO_Flt_Log   -> (True,  FSLIT("log"))
 909
 910               MO_Flt_Asin  -> (True,  FSLIT("asin"))
 911               MO_Flt_Acos  -> (True,  FSLIT("acos"))
 912               MO_Flt_Atan  -> (True,  FSLIT("atan"))
 913
 914               MO_Flt_Sinh  -> (True,  FSLIT("sinh"))
 915               MO_Flt_Cosh  -> (True,  FSLIT("cosh"))
 916               MO_Flt_Tanh  -> (True,  FSLIT("tanh"))
 917
 918               MO_Dbl_Exp   -> (False, FSLIT("exp"))
 919               MO_Dbl_Log   -> (False, FSLIT("log"))
 920
 921               MO_Dbl_Asin  -> (False, FSLIT("asin"))
 922               MO_Dbl_Acos  -> (False, FSLIT("acos"))
 923               MO_Dbl_Atan  -> (False, FSLIT("atan"))
 924
 925               MO_Dbl_Sinh  -> (False, FSLIT("sinh"))
 926               MO_Dbl_Cosh  -> (False, FSLIT("cosh"))
 927               MO_Dbl_Tanh  -> (False, FSLIT("tanh"))
 928
 929               other -> pprPanic "getRegister(x86) - binary StMachOp (2)"
 930                                 (pprMachOp mop)
 931
 932
 933 getRegister (StMachOp mop [x, y]) -- dyadic MachOps
 934   = case mop of
 935       MO_32U_Gt  -> condIntReg GTT x y
 936       MO_32U_Ge  -> condIntReg GE x y
 937       MO_32U_Eq  -> condIntReg EQQ x y
 938       MO_32U_Ne  -> condIntReg NE x y
 939       MO_32U_Lt  -> condIntReg LTT x y
 940       MO_32U_Le  -> condIntReg LE x y
 941
 942       MO_Nat_Eq   -> condIntReg EQQ x y
 943       MO_Nat_Ne   -> condIntReg NE x y
 944
 945       MO_NatS_Gt  -> condIntReg GTT x y
 946       MO_NatS_Ge  -> condIntReg GE x y
 947       MO_NatS_Lt  -> condIntReg LTT x y
 948       MO_NatS_Le  -> condIntReg LE x y
 949
 950       MO_NatU_Gt  -> condIntReg GU  x y
 951       MO_NatU_Ge  -> condIntReg GEU x y
 952       MO_NatU_Lt  -> condIntReg LU  x y
 953       MO_NatU_Le  -> condIntReg LEU x y
 954
 955       MO_Flt_Gt -> condFltReg GTT x y
 956       MO_Flt_Ge -> condFltReg GE x y
 957       MO_Flt_Eq -> condFltReg EQQ x y
 958       MO_Flt_Ne -> condFltReg NE x y
 959       MO_Flt_Lt -> condFltReg LTT x y
 960       MO_Flt_Le -> condFltReg LE x y
 961
 962       MO_Dbl_Gt -> condFltReg GTT x y
 963       MO_Dbl_Ge -> condFltReg GE x y
 964       MO_Dbl_Eq -> condFltReg EQQ x y
 965       MO_Dbl_Ne -> condFltReg NE x y
 966       MO_Dbl_Lt -> condFltReg LTT x y
 967       MO_Dbl_Le -> condFltReg LE x y
 968
 969       MO_Nat_Add   -> add_code L x y
 970       MO_Nat_Sub   -> sub_code L x y
 971       MO_NatS_Quot -> trivialCode (IQUOT L) Nothing x y
 972       MO_NatS_Rem  -> trivialCode (IREM L) Nothing x y
 973       MO_NatU_Quot -> trivialCode (QUOT L) Nothing x y
 974       MO_NatU_Rem  -> trivialCode (REM L) Nothing x y
 975       MO_NatS_Mul  -> let op = IMUL L in trivialCode op (Just op) x y
 976       MO_NatU_Mul  -> let op = MUL L in trivialCode op (Just op) x y
 977       MO_NatS_MulMayOflo -> imulMayOflo x y
 978
 979       MO_Flt_Add -> trivialFCode  FloatRep  GADD x y
 980       MO_Flt_Sub -> trivialFCode  FloatRep  GSUB x y
 981       MO_Flt_Mul -> trivialFCode  FloatRep  GMUL x y
 982       MO_Flt_Div -> trivialFCode  FloatRep  GDIV x y
 983
 984       MO_Dbl_Add -> trivialFCode DoubleRep GADD x y
 985       MO_Dbl_Sub -> trivialFCode DoubleRep GSUB x y
 986       MO_Dbl_Mul -> trivialFCode DoubleRep GMUL x y
 987       MO_Dbl_Div -> trivialFCode DoubleRep GDIV x y
 988
 989       MO_Nat_And -> let op = AND L in trivialCode op (Just op) x y
 990       MO_Nat_Or  -> let op = OR  L in trivialCode op (Just op) x y
 991       MO_Nat_Xor -> let op = XOR L in trivialCode op (Just op) x y
 992
 993         {- Shift ops on x86s have constraints on their source, it
 994            either has to be Imm, CL or 1
 995             => trivialCode's is not restrictive enough (sigh.)
 996         -}
 997       MO_Nat_Shl  -> shift_code (SHL L) x y {-False-}
 998       MO_Nat_Shr  -> shift_code (SHR L) x y {-False-}
 999       MO_Nat_Sar  -> shift_code (SAR L) x y {-False-}
1000
1001       MO_Flt_Pwr  -> getRegister (demote
1002                                  (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1003                                          [promote x, promote y])
1004                                  )
1005       MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1006                                         [x, y])
1007       other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop)
1008   where
1009     promote x = StMachOp MO_Flt_to_Dbl [x]
1010     demote x  = StMachOp MO_Dbl_to_Flt [x]
1011
1012     --------------------
1013     imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1014     imulMayOflo a1 a2
1015        = getNewRegNCG IntRep            `thenNat` \ t1 ->
1016          getNewRegNCG IntRep            `thenNat` \ t2 ->
1017          getNewRegNCG IntRep            `thenNat` \ res_lo ->
1018          getNewRegNCG IntRep            `thenNat` \ res_hi ->
1019          getRegister a1                 `thenNat` \ reg1 ->
1020          getRegister a2                 `thenNat` \ reg2 ->
1021          let code1 = registerCode reg1 t1
1022              code2 = registerCode reg2 t2
1023              src1  = registerName reg1 t1
1024              src2  = registerName reg2 t2
1025              code dst = code1 `appOL` code2 `appOL`
1026                         toOL [
1027                            MOV L (OpReg src1) (OpReg res_hi),
1028                            MOV L (OpReg src2) (OpReg res_lo),
1029                            IMUL64 res_hi res_lo,                -- result in res_hi:res_lo
1030                            SAR L (ImmInt 31) (OpReg res_lo),    -- sign extend lower part
1031                            SUB L (OpReg res_hi) (OpReg res_lo), -- compare against upper
1032                            MOV L (OpReg res_lo) (OpReg dst)
1033                            -- dst==0 if high part == sign extended low part
1034                         ]
1035          in
1036             returnNat (Any IntRep code)
1037
1038     --------------------
1039     shift_code :: (Imm -> Operand -> Instr)
1040                -> StixExpr
1041                -> StixExpr
1042                -> NatM Register
1043
1044       {- Case1: shift length as immediate -}
1045       -- Code is the same as the first eq. for trivialCode -- sigh.
1046     shift_code instr x y{-amount-}
1047       | maybeToBool imm
1048       = getRegister x                      `thenNat` \ regx ->
1049         let mkcode dst
1050               = if   isAny regx
1051                 then registerCodeA regx dst  `bind` \ code_x ->
1052                      code_x `snocOL`
1053                      instr imm__2 (OpReg dst)
1054                 else registerCodeF regx      `bind` \ code_x ->
1055                      registerNameF regx      `bind` \ r_x ->
1056                      code_x `snocOL`
1057                      MOV L (OpReg r_x) (OpReg dst) `snocOL`
1058                      instr imm__2 (OpReg dst)
1059         in
1060         returnNat (Any IntRep mkcode)
1061       where
1062        imm = maybeImm y
1063        imm__2 = case imm of Just x -> x
1064
1065       {- Case2: shift length is complex (non-immediate) -}
1066       -- Since ECX is always used as a spill temporary, we can't
1067       -- use it here to do non-immediate shifts.  No big deal --
1068       -- they are only very rare, and we can use an equivalent
1069       -- test-and-jump sequence which doesn't use ECX.
1070       -- DO NOT REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
1071       -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
1072     shift_code instr x y{-amount-}
1073      = getRegister x   `thenNat` \ register1 ->
1074        getRegister y   `thenNat` \ register2 ->
1075        getNatLabelNCG  `thenNat` \ lbl_test3 ->
1076        getNatLabelNCG  `thenNat` \ lbl_test2 ->
1077        getNatLabelNCG  `thenNat` \ lbl_test1 ->
1078        getNatLabelNCG  `thenNat` \ lbl_test0 ->
1079        getNatLabelNCG  `thenNat` \ lbl_after ->
1080        getNewRegNCG IntRep   `thenNat` \ tmp ->
1081        let code__2 dst
1082               = let src_val  = registerName register1 dst
1083                     code_val = registerCode register1 dst
1084                     src_amt  = registerName register2 tmp
1085                     code_amt = registerCode register2 tmp
1086                     r_dst    = OpReg dst
1087                     r_tmp    = OpReg tmp
1088                 in
1089                     code_amt `snocOL`
1090                     MOV L (OpReg src_amt) r_tmp `appOL`
1091                     code_val `snocOL`
1092                     MOV L (OpReg src_val) r_dst `appOL`
1093                     toOL [
1094                        COMMENT (mkFastString "begin shift sequence"),
1095                        MOV L (OpReg src_val) r_dst,
1096                        MOV L (OpReg src_amt) r_tmp,
1097
1098                        BT L (ImmInt 4) r_tmp,
1099                        JXX GEU lbl_test3,
1100                        instr (ImmInt 16) r_dst,
1101
1102                        LABEL lbl_test3,
1103                        BT L (ImmInt 3) r_tmp,
1104                        JXX GEU lbl_test2,
1105                        instr (ImmInt 8) r_dst,
1106
1107                        LABEL lbl_test2,
1108                        BT L (ImmInt 2) r_tmp,
1109                        JXX GEU lbl_test1,
1110                        instr (ImmInt 4) r_dst,
1111
1112                        LABEL lbl_test1,
1113                        BT L (ImmInt 1) r_tmp,
1114                        JXX GEU lbl_test0,
1115                        instr (ImmInt 2) r_dst,
1116
1117                        LABEL lbl_test0,
1118                        BT L (ImmInt 0) r_tmp,
1119                        JXX GEU lbl_after,
1120                        instr (ImmInt 1) r_dst,
1121                        LABEL lbl_after,
1122
1123                        COMMENT (mkFastString "end shift sequence")
1124                     ]
1125        in
1126        returnNat (Any IntRep code__2)
1127
1128     --------------------
1129     add_code :: Size -> StixExpr -> StixExpr -> NatM Register
1130
1131     add_code sz x (StInt y)
1132       = getRegister x           `thenNat` \ register ->
1133         getNewRegNCG IntRep     `thenNat` \ tmp ->
1134         let
1135             code = registerCode register tmp
1136             src1 = registerName register tmp
1137             src2 = ImmInt (fromInteger y)
1138             code__2 dst
1139                = code `snocOL`
1140                  LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1141                         (OpReg dst)
1142         in
1143         returnNat (Any IntRep code__2)
1144
1145     add_code sz x y = trivialCode (ADD sz) (Just (ADD sz)) x y
1146
1147     --------------------
1148     sub_code :: Size -> StixExpr -> StixExpr -> NatM Register
1149
1150     sub_code sz x (StInt y)
1151       = getRegister x           `thenNat` \ register ->
1152         getNewRegNCG IntRep     `thenNat` \ tmp ->
1153         let
1154             code = registerCode register tmp
1155             src1 = registerName register tmp
1156             src2 = ImmInt (-(fromInteger y))
1157             code__2 dst
1158                = code `snocOL`
1159                  LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
1160                         (OpReg dst)
1161         in
1162         returnNat (Any IntRep code__2)
1163
1164     sub_code sz x y = trivialCode (SUB sz) Nothing x y
1165
1166 getRegister (StInd pk mem)
1167   | not (is64BitRep pk)
1168   = getAmode mem                    `thenNat` \ amode ->
1169     let
1170         code = amodeCode amode
1171         src  = amodeAddr amode
1172         size = primRepToSize pk
1173         code__2 dst = code `snocOL`
1174                       if   pk == DoubleRep || pk == FloatRep
1175                       then GLD size src dst
1176                       else (case size of
1177                                B  -> MOVSxL B
1178                                Bu -> MOVZxL Bu
1179                                W  -> MOVSxL W
1180                                Wu -> MOVZxL Wu
1181                                L  -> MOV L
1182                                Lu -> MOV L)
1183                                (OpAddr src) (OpReg dst)
1184     in
1185         returnNat (Any pk code__2)
1186
1187 getRegister (StInt i)
1188   = let
1189         src = ImmInt (fromInteger i)
1190         code dst
1191            | i == 0
1192            = unitOL (XOR L (OpReg dst) (OpReg dst))
1193            | otherwise
1194            = unitOL (MOV L (OpImm src) (OpReg dst))
1195     in
1196         returnNat (Any IntRep code)
1197
1198 getRegister leaf
1199   | maybeToBool imm
1200   = let code dst = unitOL (MOV L (OpImm imm__2) (OpReg dst))
1201     in
1202         returnNat (Any PtrRep code)
1203   | otherwise
1204   = ncgPrimopMoan "getRegister(x86)" (pprStixExpr leaf)
1205   where
1206     imm = maybeImm leaf
1207     imm__2 = case imm of Just x -> x
1208
1209 #endif {- i386_TARGET_ARCH -}
1210
1211 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1212
1213 #if sparc_TARGET_ARCH
1214
1215 getRegister (StFloat d)
1216   = getNatLabelNCG                  `thenNat` \ lbl ->
1217     getNewRegNCG PtrRep             `thenNat` \ tmp ->
1218     let code dst = toOL [
1219             SEGMENT DataSegment,
1220             LABEL lbl,
1221             DATA F [ImmFloat d],
1222             SEGMENT TextSegment,
1223             SETHI (HI (ImmCLbl lbl)) tmp,
1224             LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1225     in
1226         returnNat (Any FloatRep code)
1227
1228 getRegister (StDouble d)
1229   = getNatLabelNCG                  `thenNat` \ lbl ->
1230     getNewRegNCG PtrRep             `thenNat` \ tmp ->
1231     let code dst = toOL [
1232             SEGMENT DataSegment,
1233             LABEL lbl,
1234             DATA DF [ImmDouble d],
1235             SEGMENT TextSegment,
1236             SETHI (HI (ImmCLbl lbl)) tmp,
1237             LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
1238     in
1239         returnNat (Any DoubleRep code)
1240
1241
1242 getRegister (StMachOp mop [x]) -- unary PrimOps
1243   = case mop of
1244       MO_NatS_Neg      -> trivialUCode (SUB False False g0) x
1245       MO_Nat_Not       -> trivialUCode (XNOR False g0) x
1246       MO_32U_to_8U     -> trivialCode (AND False) x (StInt 255)
1247
1248       MO_Flt_Neg       -> trivialUFCode FloatRep (FNEG F) x
1249       MO_Dbl_Neg       -> trivialUFCode DoubleRep (FNEG DF) x
1250
1251       MO_Dbl_to_Flt    -> coerceDbl2Flt x
1252       MO_Flt_to_Dbl    -> coerceFlt2Dbl x
1253
1254       MO_Flt_to_NatS   -> coerceFP2Int FloatRep x
1255       MO_NatS_to_Flt   -> coerceInt2FP FloatRep x
1256       MO_Dbl_to_NatS   -> coerceFP2Int DoubleRep x
1257       MO_NatS_to_Dbl   -> coerceInt2FP DoubleRep x
1258
1259       -- Conversions which are a nop on sparc
1260       MO_32U_to_NatS   -> conversionNop IntRep   x
1261       MO_NatS_to_32U   -> conversionNop WordRep  x
1262       MO_32U_to_NatU   -> conversionNop WordRep  x
1263
1264       MO_NatU_to_NatS -> conversionNop IntRep    x
1265       MO_NatS_to_NatU -> conversionNop WordRep   x
1266       MO_NatP_to_NatU -> conversionNop WordRep   x
1267       MO_NatU_to_NatP -> conversionNop PtrRep    x
1268       MO_NatS_to_NatP -> conversionNop PtrRep    x
1269       MO_NatP_to_NatS -> conversionNop IntRep    x
1270
1271       -- sign-extending widenings
1272       MO_8U_to_32U    -> integerExtend False 24 x
1273       MO_8U_to_NatU   -> integerExtend False 24 x
1274       MO_8S_to_NatS   -> integerExtend True  24 x
1275       MO_16U_to_NatU  -> integerExtend False 16 x
1276       MO_16S_to_NatS  -> integerExtend True  16 x
1277
1278       other_op ->
1279         let fixed_x = if   is_float_op  -- promote to double
1280                       then StMachOp MO_Flt_to_Dbl [x]
1281                       else x
1282         in
1283         getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x])
1284     where
1285         integerExtend signed nBits x
1286            = getRegister (
1287                 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1288                          [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1289              )
1290         conversionNop new_rep expr
1291             = getRegister expr          `thenNat` \ e_code ->
1292               returnNat (swizzleRegisterRep e_code new_rep)
1293
1294         (is_float_op, fn)
1295           = case mop of
1296               MO_Flt_Exp    -> (True,  FSLIT("exp"))
1297               MO_Flt_Log    -> (True,  FSLIT("log"))
1298               MO_Flt_Sqrt   -> (True,  FSLIT("sqrt"))
1299
1300               MO_Flt_Sin    -> (True,  FSLIT("sin"))
1301               MO_Flt_Cos    -> (True,  FSLIT("cos"))
1302               MO_Flt_Tan    -> (True,  FSLIT("tan"))
1303
1304               MO_Flt_Asin   -> (True,  FSLIT("asin"))
1305               MO_Flt_Acos   -> (True,  FSLIT("acos"))
1306               MO_Flt_Atan   -> (True,  FSLIT("atan"))
1307
1308               MO_Flt_Sinh   -> (True,  FSLIT("sinh"))
1309               MO_Flt_Cosh   -> (True,  FSLIT("cosh"))
1310               MO_Flt_Tanh   -> (True,  FSLIT("tanh"))
1311
1312               MO_Dbl_Exp    -> (False, FSLIT("exp"))
1313               MO_Dbl_Log    -> (False, FSLIT("log"))
1314               MO_Dbl_Sqrt   -> (False, FSLIT("sqrt"))
1315
1316               MO_Dbl_Sin    -> (False, FSLIT("sin"))
1317               MO_Dbl_Cos    -> (False, FSLIT("cos"))
1318               MO_Dbl_Tan    -> (False, FSLIT("tan"))
1319
1320               MO_Dbl_Asin   -> (False, FSLIT("asin"))
1321               MO_Dbl_Acos   -> (False, FSLIT("acos"))
1322               MO_Dbl_Atan   -> (False, FSLIT("atan"))
1323
1324               MO_Dbl_Sinh   -> (False, FSLIT("sinh"))
1325               MO_Dbl_Cosh   -> (False, FSLIT("cosh"))
1326               MO_Dbl_Tanh   -> (False, FSLIT("tanh"))
1327
1328               other -> pprPanic "getRegister(sparc) - binary StMachOp (2)"
1329                                 (pprMachOp mop)
1330
1331
1332 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1333   = case mop of
1334       MO_32U_Gt  -> condIntReg GTT x y
1335       MO_32U_Ge  -> condIntReg GE x y
1336       MO_32U_Eq  -> condIntReg EQQ x y
1337       MO_32U_Ne  -> condIntReg NE x y
1338       MO_32U_Lt  -> condIntReg LTT x y
1339       MO_32U_Le  -> condIntReg LE x y
1340
1341       MO_Nat_Eq   -> condIntReg EQQ x y
1342       MO_Nat_Ne   -> condIntReg NE x y
1343
1344       MO_NatS_Gt  -> condIntReg GTT x y
1345       MO_NatS_Ge  -> condIntReg GE x y
1346       MO_NatS_Lt  -> condIntReg LTT x y
1347       MO_NatS_Le  -> condIntReg LE x y
1348
1349       MO_NatU_Gt  -> condIntReg GU  x y
1350       MO_NatU_Ge  -> condIntReg GEU x y
1351       MO_NatU_Lt  -> condIntReg LU  x y
1352       MO_NatU_Le  -> condIntReg LEU x y
1353
1354       MO_Flt_Gt -> condFltReg GTT x y
1355       MO_Flt_Ge -> condFltReg GE x y
1356       MO_Flt_Eq -> condFltReg EQQ x y
1357       MO_Flt_Ne -> condFltReg NE x y
1358       MO_Flt_Lt -> condFltReg LTT x y
1359       MO_Flt_Le -> condFltReg LE x y
1360
1361       MO_Dbl_Gt -> condFltReg GTT x y
1362       MO_Dbl_Ge -> condFltReg GE x y
1363       MO_Dbl_Eq -> condFltReg EQQ x y
1364       MO_Dbl_Ne -> condFltReg NE x y
1365       MO_Dbl_Lt -> condFltReg LTT x y
1366       MO_Dbl_Le -> condFltReg LE x y
1367
1368       MO_Nat_Add -> trivialCode (ADD False False) x y
1369       MO_Nat_Sub -> trivialCode (SUB False False) x y
1370
1371       MO_NatS_Mul  -> trivialCode (SMUL False) x y
1372       MO_NatU_Mul  -> trivialCode (UMUL False) x y
1373       MO_NatS_MulMayOflo -> imulMayOflo x y
1374
1375       -- ToDo: teach about V8+ SPARC div instructions
1376       MO_NatS_Quot -> idiv FSLIT(".div")  x y
1377       MO_NatS_Rem  -> idiv FSLIT(".rem")  x y
1378       MO_NatU_Quot -> idiv FSLIT(".udiv")  x y
1379       MO_NatU_Rem  -> idiv FSLIT(".urem")  x y
1380
1381       MO_Flt_Add   -> trivialFCode FloatRep  FADD x y
1382       MO_Flt_Sub   -> trivialFCode FloatRep  FSUB x y
1383       MO_Flt_Mul   -> trivialFCode FloatRep  FMUL x y
1384       MO_Flt_Div   -> trivialFCode FloatRep  FDIV x y
1385
1386       MO_Dbl_Add   -> trivialFCode DoubleRep FADD x y
1387       MO_Dbl_Sub   -> trivialFCode DoubleRep FSUB x y
1388       MO_Dbl_Mul   -> trivialFCode DoubleRep FMUL x y
1389       MO_Dbl_Div   -> trivialFCode DoubleRep FDIV x y
1390
1391       MO_Nat_And   -> trivialCode (AND False) x y
1392       MO_Nat_Or    -> trivialCode (OR  False) x y
1393       MO_Nat_Xor   -> trivialCode (XOR False) x y
1394
1395       MO_Nat_Shl   -> trivialCode SLL x y
1396       MO_Nat_Shr   -> trivialCode SRL x y
1397       MO_Nat_Sar   -> trivialCode SRA x y
1398
1399       MO_Flt_Pwr  -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1400                                          [promote x, promote y])
1401                        where promote x = StMachOp MO_Flt_to_Dbl [x]
1402       MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1403                                         [x, y])
1404
1405       other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
1406   where
1407     idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y])
1408
1409     --------------------
1410     imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1411     imulMayOflo a1 a2
1412        = getNewRegNCG IntRep            `thenNat` \ t1 ->
1413          getNewRegNCG IntRep            `thenNat` \ t2 ->
1414          getNewRegNCG IntRep            `thenNat` \ res_lo ->
1415          getNewRegNCG IntRep            `thenNat` \ res_hi ->
1416          getRegister a1                 `thenNat` \ reg1 ->
1417          getRegister a2                 `thenNat` \ reg2 ->
1418          let code1 = registerCode reg1 t1
1419              code2 = registerCode reg2 t2
1420              src1  = registerName reg1 t1
1421              src2  = registerName reg2 t2
1422              code dst = code1 `appOL` code2 `appOL`
1423                         toOL [
1424                            SMUL False src1 (RIReg src2) res_lo,
1425                            RDY res_hi,
1426                            SRA res_lo (RIImm (ImmInt 31)) res_lo,
1427                            SUB False False res_lo (RIReg res_hi) dst
1428                         ]
1429          in
1430             returnNat (Any IntRep code)
1431
1432 getRegister (StInd pk mem)
1433   = getAmode mem                    `thenNat` \ amode ->
1434     let
1435         code = amodeCode amode
1436         src   = amodeAddr amode
1437         size = primRepToSize pk
1438         code__2 dst = code `snocOL` LD size src dst
1439     in
1440         returnNat (Any pk code__2)
1441
1442 getRegister (StInt i)
1443   | fits13Bits i
1444   = let
1445         src = ImmInt (fromInteger i)
1446         code dst = unitOL (OR False g0 (RIImm src) dst)
1447     in
1448         returnNat (Any IntRep code)
1449
1450 getRegister leaf
1451   | maybeToBool imm
1452   = let
1453         code dst = toOL [
1454             SETHI (HI imm__2) dst,
1455             OR False dst (RIImm (LO imm__2)) dst]
1456     in
1457         returnNat (Any PtrRep code)
1458   | otherwise
1459   = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
1460   where
1461     imm = maybeImm leaf
1462     imm__2 = case imm of Just x -> x
1463
1464 #endif {- sparc_TARGET_ARCH -}
1465
1466 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1467
1468 \end{code}
1469
1470 %************************************************************************
1471 %*                                                                      *
1472 \subsection{The @Amode@ type}
1473 %*                                                                      *
1474 %************************************************************************
1475
1476 @Amode@s: Memory addressing modes passed up the tree.
1477 \begin{code}
1478 data Amode = Amode MachRegsAddr InstrBlock
1479
1480 amodeAddr (Amode addr _) = addr
1481 amodeCode (Amode _ code) = code
1482 \end{code}
1483
1484 Now, given a tree (the argument to an StInd) that references memory,
1485 produce a suitable addressing mode.
1486
1487 A Rule of the Game (tm) for Amodes: use of the addr bit must
1488 immediately follow use of the code part, since the code part puts
1489 values in registers which the addr then refers to.  So you can't put
1490 anything in between, lest it overwrite some of those registers.  If
1491 you need to do some other computation between the code part and use of
1492 the addr bit, first store the effective address from the amode in a
1493 temporary, then do the other computation, and then use the temporary:
1494
1495     code
1496     LEA amode, tmp
1497     ... other computation ...
1498     ... (tmp) ...
1499
1500 \begin{code}
1501 getAmode :: StixExpr -> NatM Amode
1502
1503 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1504
1505 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1506
1507 #if alpha_TARGET_ARCH
1508
1509 getAmode (StPrim IntSubOp [x, StInt i])
1510   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1511     getRegister x               `thenNat` \ register ->
1512     let
1513         code = registerCode register tmp
1514         reg  = registerName register tmp
1515         off  = ImmInt (-(fromInteger i))
1516     in
1517     returnNat (Amode (AddrRegImm reg off) code)
1518
1519 getAmode (StPrim IntAddOp [x, StInt i])
1520   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1521     getRegister x               `thenNat` \ register ->
1522     let
1523         code = registerCode register tmp
1524         reg  = registerName register tmp
1525         off  = ImmInt (fromInteger i)
1526     in
1527     returnNat (Amode (AddrRegImm reg off) code)
1528
1529 getAmode leaf
1530   | maybeToBool imm
1531   = returnNat (Amode (AddrImm imm__2) id)
1532   where
1533     imm = maybeImm leaf
1534     imm__2 = case imm of Just x -> x
1535
1536 getAmode other
1537   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1538     getRegister other           `thenNat` \ register ->
1539     let
1540         code = registerCode register tmp
1541         reg  = registerName register tmp
1542     in
1543     returnNat (Amode (AddrReg reg) code)
1544
1545 #endif {- alpha_TARGET_ARCH -}
1546
1547 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1548
1549 #if i386_TARGET_ARCH
1550
1551 -- This is all just ridiculous, since it carefully undoes
1552 -- what mangleIndexTree has just done.
1553 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1554   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1555     getRegister x               `thenNat` \ register ->
1556     let
1557         code = registerCode register tmp
1558         reg  = registerName register tmp
1559         off  = ImmInt (-(fromInteger i))
1560     in
1561     returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1562
1563 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1564   | maybeToBool imm
1565   = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1566   where
1567     imm    = maybeImm x
1568     imm__2 = case imm of Just x -> x
1569
1570 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1571   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1572     getRegister x               `thenNat` \ register ->
1573     let
1574         code = registerCode register tmp
1575         reg  = registerName register tmp
1576         off  = ImmInt (fromInteger i)
1577     in
1578     returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1579
1580 getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
1581   | shift == 0 || shift == 1 || shift == 2 || shift == 3
1582   = getNewRegNCG PtrRep         `thenNat` \ tmp1 ->
1583     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1584     getRegister x               `thenNat` \ register1 ->
1585     getRegister y               `thenNat` \ register2 ->
1586     let
1587         code1 = registerCode register1 tmp1
1588         reg1  = registerName register1 tmp1
1589         code2 = registerCode register2 tmp2
1590         reg2  = registerName register2 tmp2
1591         code__2 = code1 `appOL` code2
1592         base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1593     in
1594     returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1595                code__2)
1596
1597 getAmode leaf
1598   | maybeToBool imm
1599   = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1600   where
1601     imm    = maybeImm leaf
1602     imm__2 = case imm of Just x -> x
1603
1604 getAmode other
1605   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1606     getRegister other           `thenNat` \ register ->
1607     let
1608         code = registerCode register tmp
1609         reg  = registerName register tmp
1610     in
1611     returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1612
1613 #endif {- i386_TARGET_ARCH -}
1614
1615 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1616
1617 #if sparc_TARGET_ARCH
1618
1619 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1620   | fits13Bits (-i)
1621   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1622     getRegister x               `thenNat` \ register ->
1623     let
1624         code = registerCode register tmp
1625         reg  = registerName register tmp
1626         off  = ImmInt (-(fromInteger i))
1627     in
1628     returnNat (Amode (AddrRegImm reg off) code)
1629
1630
1631 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1632   | fits13Bits i
1633   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1634     getRegister x               `thenNat` \ register ->
1635     let
1636         code = registerCode register tmp
1637         reg  = registerName register tmp
1638         off  = ImmInt (fromInteger i)
1639     in
1640     returnNat (Amode (AddrRegImm reg off) code)
1641
1642 getAmode (StMachOp MO_Nat_Add [x, y])
1643   = getNewRegNCG PtrRep         `thenNat` \ tmp1 ->
1644     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1645     getRegister x               `thenNat` \ register1 ->
1646     getRegister y               `thenNat` \ register2 ->
1647     let
1648         code1 = registerCode register1 tmp1
1649         reg1  = registerName register1 tmp1
1650         code2 = registerCode register2 tmp2
1651         reg2  = registerName register2 tmp2
1652         code__2 = code1 `appOL` code2
1653     in
1654     returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1655
1656 getAmode leaf
1657   | maybeToBool imm
1658   = getNewRegNCG PtrRep             `thenNat` \ tmp ->
1659     let
1660         code = unitOL (SETHI (HI imm__2) tmp)
1661     in
1662     returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1663   where
1664     imm    = maybeImm leaf
1665     imm__2 = case imm of Just x -> x
1666
1667 getAmode other
1668   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1669     getRegister other           `thenNat` \ register ->
1670     let
1671         code = registerCode register tmp
1672         reg  = registerName register tmp
1673         off  = ImmInt 0
1674     in
1675     returnNat (Amode (AddrRegImm reg off) code)
1676
1677 #endif {- sparc_TARGET_ARCH -}
1678
1679 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1680 \end{code}
1681
1682 %************************************************************************
1683 %*                                                                      *
1684 \subsection{The @CondCode@ type}
1685 %*                                                                      *
1686 %************************************************************************
1687
1688 Condition codes passed up the tree.
1689 \begin{code}
1690 data CondCode = CondCode Bool Cond InstrBlock
1691
1692 condName  (CondCode _ cond _)     = cond
1693 condFloat (CondCode is_float _ _) = is_float
1694 condCode  (CondCode _ _ code)     = code
1695 \end{code}
1696
1697 Set up a condition code for a conditional branch.
1698
1699 \begin{code}
1700 getCondCode :: StixExpr -> NatM CondCode
1701
1702 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1703
1704 #if alpha_TARGET_ARCH
1705 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1706 #endif {- alpha_TARGET_ARCH -}
1707
1708 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1709
1710 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1711 -- yes, they really do seem to want exactly the same!
1712
1713 getCondCode (StMachOp mop [x, y])
1714   = case mop of
1715       MO_32U_Gt -> condIntCode GTT  x y
1716       MO_32U_Ge -> condIntCode GE   x y
1717       MO_32U_Eq -> condIntCode EQQ  x y
1718       MO_32U_Ne -> condIntCode NE   x y
1719       MO_32U_Lt -> condIntCode LTT  x y
1720       MO_32U_Le -> condIntCode LE   x y
1721
1722       MO_Nat_Eq  -> condIntCode EQQ  x y
1723       MO_Nat_Ne  -> condIntCode NE   x y
1724
1725       MO_NatS_Gt -> condIntCode GTT  x y
1726       MO_NatS_Ge -> condIntCode GE   x y
1727       MO_NatS_Lt -> condIntCode LTT  x y
1728       MO_NatS_Le -> condIntCode LE   x y
1729
1730       MO_NatU_Gt -> condIntCode GU   x y
1731       MO_NatU_Ge -> condIntCode GEU  x y
1732       MO_NatU_Lt -> condIntCode LU   x y
1733       MO_NatU_Le -> condIntCode LEU  x y
1734
1735       MO_Flt_Gt -> condFltCode GTT x y
1736       MO_Flt_Ge -> condFltCode GE  x y
1737       MO_Flt_Eq -> condFltCode EQQ x y
1738       MO_Flt_Ne -> condFltCode NE  x y
1739       MO_Flt_Lt -> condFltCode LTT x y
1740       MO_Flt_Le -> condFltCode LE  x y
1741
1742       MO_Dbl_Gt -> condFltCode GTT x y
1743       MO_Dbl_Ge -> condFltCode GE  x y
1744       MO_Dbl_Eq -> condFltCode EQQ x y
1745       MO_Dbl_Ne -> condFltCode NE  x y
1746       MO_Dbl_Lt -> condFltCode LTT x y
1747       MO_Dbl_Le -> condFltCode LE  x y
1748
1749       other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop)
1750
1751 getCondCode other =  pprPanic "getCondCode(2)(x86,sparc)" (pprStixExpr other)
1752
1753 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1754
1755 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1756 \end{code}
1757
1758 % -----------------
1759
1760 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1761 passed back up the tree.
1762
1763 \begin{code}
1764 condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
1765
1766 #if alpha_TARGET_ARCH
1767 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1768 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1769 #endif {- alpha_TARGET_ARCH -}
1770
1771 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1772 #if i386_TARGET_ARCH
1773
1774 -- memory vs immediate
1775 condIntCode cond (StInd pk x) y
1776   | Just i <- maybeImm y
1777   = getAmode x                  `thenNat` \ amode ->
1778     let
1779         code1 = amodeCode amode
1780         x__2  = amodeAddr amode
1781         sz    = primRepToSize pk
1782         code__2 = code1 `snocOL`
1783                   CMP sz (OpImm i) (OpAddr x__2)
1784     in
1785     returnNat (CondCode False cond code__2)
1786
1787 -- anything vs zero
1788 condIntCode cond x (StInt 0)
1789   = getRegister x               `thenNat` \ register1 ->
1790     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
1791     let
1792         code1 = registerCode register1 tmp1
1793         src1  = registerName register1 tmp1
1794         code__2 = code1 `snocOL`
1795                   TEST L (OpReg src1) (OpReg src1)
1796     in
1797     returnNat (CondCode False cond code__2)
1798
1799 -- anything vs immediate
1800 condIntCode cond x y
1801   | Just i <- maybeImm y
1802   = getRegister x               `thenNat` \ register1 ->
1803     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
1804     let
1805         code1 = registerCode register1 tmp1
1806         src1  = registerName register1 tmp1
1807         code__2 = code1 `snocOL`
1808                   CMP L (OpImm i) (OpReg src1)
1809     in
1810     returnNat (CondCode False cond code__2)
1811
1812 -- memory vs anything
1813 condIntCode cond (StInd pk x) y
1814   = getAmode x                  `thenNat` \ amode_x ->
1815     getRegister y               `thenNat` \ reg_y ->
1816     getNewRegNCG IntRep         `thenNat` \ tmp ->
1817     let
1818         c_x   = amodeCode amode_x
1819         am_x  = amodeAddr amode_x
1820         c_y   = registerCode reg_y tmp
1821         r_y   = registerName reg_y tmp
1822         sz    = primRepToSize pk
1823
1824         -- optimisation: if there's no code for x, just an amode,
1825         -- use whatever reg y winds up in.  Assumes that c_y doesn't
1826         -- clobber any regs in the amode am_x, which I'm not sure is
1827         -- justified.  The otherwise clause makes the same assumption.
1828         code__2 | isNilOL c_x
1829                 = c_y `snocOL`
1830                   CMP sz (OpReg r_y) (OpAddr am_x)
1831
1832                 | otherwise
1833                 = c_y `snocOL`
1834                   MOV L (OpReg r_y) (OpReg tmp) `appOL`
1835                   c_x `snocOL`
1836                   CMP sz (OpReg tmp) (OpAddr am_x)
1837     in
1838     returnNat (CondCode False cond code__2)
1839
1840 -- anything vs memory
1841 --
1842 condIntCode cond y (StInd pk x)
1843   = getAmode x                  `thenNat` \ amode_x ->
1844     getRegister y               `thenNat` \ reg_y ->
1845     getNewRegNCG IntRep         `thenNat` \ tmp ->
1846     let
1847         c_x   = amodeCode amode_x
1848         am_x  = amodeAddr amode_x
1849         c_y   = registerCode reg_y tmp
1850         r_y   = registerName reg_y tmp
1851         sz    = primRepToSize pk
1852         -- same optimisation and nagging doubts as previous clause
1853         code__2 | isNilOL c_x
1854                 = c_y `snocOL`
1855                   CMP sz (OpAddr am_x) (OpReg r_y)
1856
1857                 | otherwise
1858                 = c_y `snocOL`
1859                   MOV L (OpReg r_y) (OpReg tmp) `appOL`
1860                   c_x `snocOL`
1861                   CMP sz (OpAddr am_x) (OpReg tmp)
1862     in
1863     returnNat (CondCode False cond code__2)
1864
1865 -- anything vs anything
1866 condIntCode cond x y
1867   = getRegister x               `thenNat` \ register1 ->
1868     getRegister y               `thenNat` \ register2 ->
1869     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
1870     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1871     let
1872         code1 = registerCode register1 tmp1
1873         src1  = registerName register1 tmp1
1874         code2 = registerCode register2 tmp2
1875         src2  = registerName register2 tmp2
1876         code__2 = code1 `snocOL`
1877                   MOV L (OpReg src1) (OpReg tmp1) `appOL`
1878                   code2 `snocOL`
1879                   CMP L (OpReg src2) (OpReg tmp1)
1880     in
1881     returnNat (CondCode False cond code__2)
1882
1883 -----------
1884 condFltCode cond x y
1885   = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
1886     getRegister x               `thenNat` \ register1 ->
1887     getRegister y               `thenNat` \ register2 ->
1888     getNewRegNCG (registerRep register1)
1889                                 `thenNat` \ tmp1 ->
1890     getNewRegNCG (registerRep register2)
1891                                 `thenNat` \ tmp2 ->
1892     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
1893     let
1894         code1 = registerCode register1 tmp1
1895         src1  = registerName register1 tmp1
1896
1897         code2 = registerCode register2 tmp2
1898         src2  = registerName register2 tmp2
1899
1900         code__2 | isAny register1
1901                 = code1 `appOL`   -- result in tmp1
1902                   code2 `snocOL`
1903                   GCMP cond tmp1 src2
1904
1905                 | otherwise
1906                 = code1 `snocOL`
1907                   GMOV src1 tmp1 `appOL`
1908                   code2 `snocOL`
1909                   GCMP cond tmp1 src2
1910     in
1911     -- The GCMP insn does the test and sets the zero flag if comparable
1912     -- and true.  Hence we always supply EQQ as the condition to test.
1913     returnNat (CondCode True EQQ code__2)
1914
1915 #endif {- i386_TARGET_ARCH -}
1916
1917 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1918
1919 #if sparc_TARGET_ARCH
1920
1921 condIntCode cond x (StInt y)
1922   | fits13Bits y
1923   = getRegister x               `thenNat` \ register ->
1924     getNewRegNCG IntRep         `thenNat` \ tmp ->
1925     let
1926         code = registerCode register tmp
1927         src1 = registerName register tmp
1928         src2 = ImmInt (fromInteger y)
1929         code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1930     in
1931     returnNat (CondCode False cond code__2)
1932
1933 condIntCode cond x y
1934   = getRegister x               `thenNat` \ register1 ->
1935     getRegister y               `thenNat` \ register2 ->
1936     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
1937     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1938     let
1939         code1 = registerCode register1 tmp1
1940         src1  = registerName register1 tmp1
1941         code2 = registerCode register2 tmp2
1942         src2  = registerName register2 tmp2
1943         code__2 = code1 `appOL` code2 `snocOL`
1944                   SUB False True src1 (RIReg src2) g0
1945     in
1946     returnNat (CondCode False cond code__2)
1947
1948 -----------
1949 condFltCode cond x y
1950   = getRegister x               `thenNat` \ register1 ->
1951     getRegister y               `thenNat` \ register2 ->
1952     getNewRegNCG (registerRep register1)
1953                                 `thenNat` \ tmp1 ->
1954     getNewRegNCG (registerRep register2)
1955                                 `thenNat` \ tmp2 ->
1956     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
1957     let
1958         promote x = FxTOy F DF x tmp
1959
1960         pk1   = registerRep register1
1961         code1 = registerCode register1 tmp1
1962         src1  = registerName register1 tmp1
1963
1964         pk2   = registerRep register2
1965         code2 = registerCode register2 tmp2
1966         src2  = registerName register2 tmp2
1967
1968         code__2 =
1969                 if pk1 == pk2 then
1970                     code1 `appOL` code2 `snocOL`
1971                     FCMP True (primRepToSize pk1) src1 src2
1972                 else if pk1 == FloatRep then
1973                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1974                     FCMP True DF tmp src2
1975                 else
1976                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1977                     FCMP True DF src1 tmp
1978     in
1979     returnNat (CondCode True cond code__2)
1980
1981 #endif {- sparc_TARGET_ARCH -}
1982
1983 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1984 \end{code}
1985
1986 %************************************************************************
1987 %*                                                                      *
1988 \subsection{Generating assignments}
1989 %*                                                                      *
1990 %************************************************************************
1991
1992 Assignments are really at the heart of the whole code generation
1993 business.  Almost all top-level nodes of any real importance are
1994 assignments, which correspond to loads, stores, or register transfers.
1995 If we're really lucky, some of the register transfers will go away,
1996 because we can use the destination register to complete the code
1997 generation for the right hand side.  This only fails when the right
1998 hand side is forced into a fixed register (e.g. the result of a call).
1999
2000 \begin{code}
2001 assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2002 assignReg_IntCode :: PrimRep -> StixReg  -> StixExpr -> NatM InstrBlock
2003
2004 assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2005 assignReg_FltCode :: PrimRep -> StixReg  -> StixExpr -> NatM InstrBlock
2006
2007 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2008
2009 #if alpha_TARGET_ARCH
2010
2011 assignIntCode pk (StInd _ dst) src
2012   = getNewRegNCG IntRep             `thenNat` \ tmp ->
2013     getAmode dst                    `thenNat` \ amode ->
2014     getRegister src                 `thenNat` \ register ->
2015     let
2016         code1   = amodeCode amode []
2017         dst__2  = amodeAddr amode
2018         code2   = registerCode register tmp []
2019         src__2  = registerName register tmp
2020         sz      = primRepToSize pk
2021         code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2022     in
2023     returnNat code__2
2024
2025 assignIntCode pk dst src
2026   = getRegister dst                         `thenNat` \ register1 ->
2027     getRegister src                         `thenNat` \ register2 ->
2028     let
2029         dst__2  = registerName register1 zeroh
2030         code    = registerCode register2 dst__2
2031         src__2  = registerName register2 dst__2
2032         code__2 = if isFixed register2
2033                   then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2034                   else code
2035     in
2036     returnNat code__2
2037
2038 #endif {- alpha_TARGET_ARCH -}
2039
2040 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2041
2042 #if i386_TARGET_ARCH
2043
2044 -- non-FP assignment to memory
2045 assignMem_IntCode pk addr src
2046   = getAmode addr               `thenNat` \ amode ->
2047     get_op_RI src               `thenNat` \ (codesrc, opsrc) ->
2048     getNewRegNCG PtrRep         `thenNat` \ tmp ->
2049     let
2050         -- In general, if the address computation for dst may require
2051         -- some insns preceding the addressing mode itself.  So there's
2052         -- no guarantee that the code for dst and the code for src won't
2053         -- write the same register.  This means either the address or
2054         -- the value needs to be copied into a temporary.  We detect the
2055         -- common case where the amode has no code, and elide the copy.
2056         codea   = amodeCode amode
2057         dst__a  = amodeAddr amode
2058
2059         code    | isNilOL codea
2060                 = codesrc `snocOL`
2061                   MOV (primRepToSize pk) opsrc (OpAddr dst__a)
2062                 | otherwise
2063                 = codea `snocOL`
2064                   LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
2065                   codesrc `snocOL`
2066                   MOV (primRepToSize pk) opsrc
2067                       (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
2068     in
2069     returnNat code
2070   where
2071     get_op_RI
2072         :: StixExpr
2073         -> NatM (InstrBlock,Operand)    -- code, operator
2074
2075     get_op_RI op
2076       | Just x <- maybeImm op
2077       = returnNat (nilOL, OpImm x)
2078
2079     get_op_RI op
2080       = getRegister op                  `thenNat` \ register ->
2081         getNewRegNCG (registerRep register)
2082                                         `thenNat` \ tmp ->
2083         let code = registerCode register tmp
2084             reg  = registerName register tmp
2085         in
2086         returnNat (code, OpReg reg)
2087
2088 -- Assign; dst is a reg, rhs is mem
2089 assignReg_IntCode pk reg (StInd pks src)
2090   = getNewRegNCG PtrRep             `thenNat` \ tmp ->
2091     getAmode src                    `thenNat` \ amode ->
2092     getRegisterReg reg              `thenNat` \ reg_dst ->
2093     let
2094         c_addr  = amodeCode amode
2095         am_addr = amodeAddr amode
2096         r_dst = registerName reg_dst tmp
2097         szs   = primRepToSize pks
2098         opc   = case szs of
2099             B  -> MOVSxL B
2100             Bu -> MOVZxL Bu
2101             W  -> MOVSxL W
2102             Wu -> MOVZxL Wu
2103             L  -> MOV L
2104             Lu -> MOV L
2105
2106         code  = c_addr `snocOL`
2107                 opc (OpAddr am_addr) (OpReg r_dst)
2108     in
2109     returnNat code
2110
2111 -- dst is a reg, but src could be anything
2112 assignReg_IntCode pk reg src
2113   = getRegisterReg reg              `thenNat` \ registerd ->
2114     getRegister src                 `thenNat` \ registers ->
2115     getNewRegNCG IntRep             `thenNat` \ tmp ->
2116     let
2117         r_dst = registerName registerd tmp
2118         r_src = registerName registers r_dst
2119         c_src = registerCode registers r_dst
2120
2121         code = c_src `snocOL`
2122                MOV L (OpReg r_src) (OpReg r_dst)
2123     in
2124     returnNat code
2125
2126 #endif {- i386_TARGET_ARCH -}
2127
2128 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2129
2130 #if sparc_TARGET_ARCH
2131
2132 assignMem_IntCode pk addr src
2133   = getNewRegNCG IntRep                     `thenNat` \ tmp ->
2134     getAmode addr                           `thenNat` \ amode ->
2135     getRegister src                         `thenNat` \ register ->
2136     let
2137         code1   = amodeCode amode
2138         dst__2  = amodeAddr amode
2139         code2   = registerCode register tmp
2140         src__2  = registerName register tmp
2141         sz      = primRepToSize pk
2142         code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2143     in
2144     returnNat code__2
2145
2146 assignReg_IntCode pk reg src
2147   = getRegister src                         `thenNat` \ register2 ->
2148     getRegisterReg reg                      `thenNat` \ register1 ->
2149     let
2150         dst__2  = registerName register1 g0
2151         code    = registerCode register2 dst__2
2152         src__2  = registerName register2 dst__2
2153         code__2 = if isFixed register2
2154                   then code `snocOL` OR False g0 (RIReg src__2) dst__2
2155                   else code
2156     in
2157     returnNat code__2
2158
2159 #endif {- sparc_TARGET_ARCH -}
2160
2161 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2162 \end{code}
2163
2164 % --------------------------------
2165 Floating-point assignments:
2166 % --------------------------------
2167
2168 \begin{code}
2169 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2170 #if alpha_TARGET_ARCH
2171
2172 assignFltCode pk (StInd _ dst) src
2173   = getNewRegNCG pk                 `thenNat` \ tmp ->
2174     getAmode dst                    `thenNat` \ amode ->
2175     getRegister src                         `thenNat` \ register ->
2176     let
2177         code1   = amodeCode amode []
2178         dst__2  = amodeAddr amode
2179         code2   = registerCode register tmp []
2180         src__2  = registerName register tmp
2181         sz      = primRepToSize pk
2182         code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2183     in
2184     returnNat code__2
2185
2186 assignFltCode pk dst src
2187   = getRegister dst                         `thenNat` \ register1 ->
2188     getRegister src                         `thenNat` \ register2 ->
2189     let
2190         dst__2  = registerName register1 zeroh
2191         code    = registerCode register2 dst__2
2192         src__2  = registerName register2 dst__2
2193         code__2 = if isFixed register2
2194                   then code . mkSeqInstr (FMOV src__2 dst__2)
2195                   else code
2196     in
2197     returnNat code__2
2198
2199 #endif {- alpha_TARGET_ARCH -}
2200
2201 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2202
2203 #if i386_TARGET_ARCH
2204
2205 -- Floating point assignment to memory
2206 assignMem_FltCode pk addr src
2207    = getRegister src      `thenNat`  \ reg_src  ->
2208      getRegister addr     `thenNat`  \ reg_addr ->
2209      getNewRegNCG pk      `thenNat`  \ tmp_src  ->
2210      getNewRegNCG PtrRep  `thenNat`  \ tmp_addr ->
2211      let r_src  = registerName reg_src tmp_src
2212          c_src  = registerCode reg_src tmp_src
2213          r_addr = registerName reg_addr tmp_addr
2214          c_addr = registerCode reg_addr tmp_addr
2215          sz     = primRepToSize pk
2216
2217          code = c_src  `appOL`
2218                 -- no need to preserve r_src across the addr computation,
2219                 -- since r_src must be a float reg
2220                 -- whilst r_addr is an int reg
2221                 c_addr `snocOL`
2222                 GST sz r_src
2223                        (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2224      in
2225      returnNat code
2226
2227 -- Floating point assignment to a register/temporary
2228 assignReg_FltCode pk reg src
2229   = getRegisterReg reg              `thenNat` \ reg_dst ->
2230     getRegister src                 `thenNat` \ reg_src ->
2231     getNewRegNCG pk                 `thenNat` \ tmp ->
2232     let
2233         r_dst = registerName reg_dst tmp
2234         r_src = registerName reg_src r_dst
2235         c_src = registerCode reg_src r_dst
2236
2237         code = if   isFixed reg_src
2238                then c_src `snocOL` GMOV r_src r_dst
2239                else c_src
2240     in
2241     returnNat code
2242
2243
2244 #endif {- i386_TARGET_ARCH -}
2245
2246 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2247
2248 #if sparc_TARGET_ARCH
2249
2250 -- Floating point assignment to memory
2251 assignMem_FltCode pk addr src
2252   = getNewRegNCG pk                 `thenNat` \ tmp1 ->
2253     getAmode addr                   `thenNat` \ amode ->
2254     getRegister src                 `thenNat` \ register ->
2255     let
2256         sz      = primRepToSize pk
2257         dst__2  = amodeAddr amode
2258
2259         code1   = amodeCode amode
2260         code2   = registerCode register tmp1
2261
2262         src__2  = registerName register tmp1
2263         pk__2   = registerRep register
2264         sz__2   = primRepToSize pk__2
2265
2266         code__2 = code1 `appOL` code2 `appOL`
2267             if   pk == pk__2
2268             then unitOL (ST sz src__2 dst__2)
2269             else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2270     in
2271     returnNat code__2
2272
2273 -- Floating point assignment to a register/temporary
2274 -- Why is this so bizarrely ugly?
2275 assignReg_FltCode pk reg src
2276   = getRegisterReg reg                      `thenNat` \ register1 ->
2277     getRegister src                         `thenNat` \ register2 ->
2278     let
2279         pk__2   = registerRep register2
2280         sz__2   = primRepToSize pk__2
2281     in
2282     getNewRegNCG pk__2                      `thenNat` \ tmp ->
2283     let
2284         sz      = primRepToSize pk
2285         dst__2  = registerName register1 g0    -- must be Fixed
2286         reg__2  = if pk /= pk__2 then tmp else dst__2
2287         code    = registerCode register2 reg__2
2288         src__2  = registerName register2 reg__2
2289         code__2 =
2290                 if pk /= pk__2 then
2291                      code `snocOL` FxTOy sz__2 sz src__2 dst__2
2292                 else if isFixed register2 then
2293                      code `snocOL` FMOV sz src__2 dst__2
2294                 else
2295                      code
2296     in
2297     returnNat code__2
2298
2299 #endif {- sparc_TARGET_ARCH -}
2300
2301 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2302 \end{code}
2303
2304 %************************************************************************
2305 %*                                                                      *
2306 \subsection{Generating an unconditional branch}
2307 %*                                                                      *
2308 %************************************************************************
2309
2310 We accept two types of targets: an immediate CLabel or a tree that
2311 gets evaluated into a register.  Any CLabels which are AsmTemporaries
2312 are assumed to be in the local block of code, close enough for a
2313 branch instruction.  Other CLabels are assumed to be far away.
2314
2315 (If applicable) Do not fill the delay slots here; you will confuse the
2316 register allocator.
2317
2318 \begin{code}
2319 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2320
2321 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2322
2323 #if alpha_TARGET_ARCH
2324
2325 genJump (StCLbl lbl)
2326   | isAsmTemp lbl = returnInstr (BR target)
2327   | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2328   where
2329     target = ImmCLbl lbl
2330
2331 genJump tree
2332   = getRegister tree                `thenNat` \ register ->
2333     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2334     let
2335         dst    = registerName register pv
2336         code   = registerCode register pv
2337         target = registerName register pv
2338     in
2339     if isFixed register then
2340         returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2341     else
2342     returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2343
2344 #endif {- alpha_TARGET_ARCH -}
2345
2346 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2347
2348 #if i386_TARGET_ARCH
2349
2350 genJump dsts (StInd pk mem)
2351   = getAmode mem                    `thenNat` \ amode ->
2352     let
2353         code   = amodeCode amode
2354         target = amodeAddr amode
2355     in
2356     returnNat (code `snocOL` JMP dsts (OpAddr target))
2357
2358 genJump dsts tree
2359   | maybeToBool imm
2360   = returnNat (unitOL (JMP dsts (OpImm target)))
2361
2362   | otherwise
2363   = getRegister tree                `thenNat` \ register ->
2364     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2365     let
2366         code   = registerCode register tmp
2367         target = registerName register tmp
2368     in
2369     returnNat (code `snocOL` JMP dsts (OpReg target))
2370   where
2371     imm    = maybeImm tree
2372     target = case imm of Just x -> x
2373
2374 #endif {- i386_TARGET_ARCH -}
2375
2376 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2377
2378 #if sparc_TARGET_ARCH
2379
2380 genJump dsts (StCLbl lbl)
2381   | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2382   | isAsmTemp lbl    = returnNat (toOL [BI ALWAYS False target, NOP])
2383   | otherwise        = returnNat (toOL [CALL (Left target) 0 True, NOP])
2384   where
2385     target = ImmCLbl lbl
2386
2387 genJump dsts tree
2388   = getRegister tree                        `thenNat` \ register ->
2389     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2390     let
2391         code   = registerCode register tmp
2392         target = registerName register tmp
2393     in
2394     returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2395
2396 #endif {- sparc_TARGET_ARCH -}
2397
2398 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2399 \end{code}
2400
2401 %************************************************************************
2402 %*                                                                      *
2403 \subsection{Conditional jumps}
2404 %*                                                                      *
2405 %************************************************************************
2406
2407 Conditional jumps are always to local labels, so we can use branch
2408 instructions.  We peek at the arguments to decide what kind of
2409 comparison to do.
2410
2411 ALPHA: For comparisons with 0, we're laughing, because we can just do
2412 the desired conditional branch.
2413
2414 I386: First, we have to ensure that the condition
2415 codes are set according to the supplied comparison operation.
2416
2417 SPARC: First, we have to ensure that the condition codes are set
2418 according to the supplied comparison operation.  We generate slightly
2419 different code for floating point comparisons, because a floating
2420 point operation cannot directly precede a @BF@.  We assume the worst
2421 and fill that slot with a @NOP@.
2422
2423 SPARC: Do not fill the delay slots here; you will confuse the register
2424 allocator.
2425
2426 \begin{code}
2427 genCondJump
2428     :: CLabel       -- the branch target
2429     -> StixExpr     -- the condition on which to branch
2430     -> NatM InstrBlock
2431
2432 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2433
2434 #if alpha_TARGET_ARCH
2435
2436 genCondJump lbl (StPrim op [x, StInt 0])
2437   = getRegister x                           `thenNat` \ register ->
2438     getNewRegNCG (registerRep register)
2439                                     `thenNat` \ tmp ->
2440     let
2441         code   = registerCode register tmp
2442         value  = registerName register tmp
2443         pk     = registerRep register
2444         target = ImmCLbl lbl
2445     in
2446     returnSeq code [BI (cmpOp op) value target]
2447   where
2448     cmpOp CharGtOp = GTT
2449     cmpOp CharGeOp = GE
2450     cmpOp CharEqOp = EQQ
2451     cmpOp CharNeOp = NE
2452     cmpOp CharLtOp = LTT
2453     cmpOp CharLeOp = LE
2454     cmpOp IntGtOp = GTT
2455     cmpOp IntGeOp = GE
2456     cmpOp IntEqOp = EQQ
2457     cmpOp IntNeOp = NE
2458     cmpOp IntLtOp = LTT
2459     cmpOp IntLeOp = LE
2460     cmpOp WordGtOp = NE
2461     cmpOp WordGeOp = ALWAYS
2462     cmpOp WordEqOp = EQQ
2463     cmpOp WordNeOp = NE
2464     cmpOp WordLtOp = NEVER
2465     cmpOp WordLeOp = EQQ
2466     cmpOp AddrGtOp = NE
2467     cmpOp AddrGeOp = ALWAYS
2468     cmpOp AddrEqOp = EQQ
2469     cmpOp AddrNeOp = NE
2470     cmpOp AddrLtOp = NEVER
2471     cmpOp AddrLeOp = EQQ
2472
2473 genCondJump lbl (StPrim op [x, StDouble 0.0])
2474   = getRegister x                           `thenNat` \ register ->
2475     getNewRegNCG (registerRep register)
2476                                     `thenNat` \ tmp ->
2477     let
2478         code   = registerCode register tmp
2479         value  = registerName register tmp
2480         pk     = registerRep register
2481         target = ImmCLbl lbl
2482     in
2483     returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2484   where
2485     cmpOp FloatGtOp = GTT
2486     cmpOp FloatGeOp = GE
2487     cmpOp FloatEqOp = EQQ
2488     cmpOp FloatNeOp = NE
2489     cmpOp FloatLtOp = LTT
2490     cmpOp FloatLeOp = LE
2491     cmpOp DoubleGtOp = GTT
2492     cmpOp DoubleGeOp = GE
2493     cmpOp DoubleEqOp = EQQ
2494     cmpOp DoubleNeOp = NE
2495     cmpOp DoubleLtOp = LTT
2496     cmpOp DoubleLeOp = LE
2497
2498 genCondJump lbl (StPrim op [x, y])
2499   | fltCmpOp op
2500   = trivialFCode pr instr x y       `thenNat` \ register ->
2501     getNewRegNCG DoubleRep          `thenNat` \ tmp ->
2502     let
2503         code   = registerCode register tmp
2504         result = registerName register tmp
2505         target = ImmCLbl lbl
2506     in
2507     returnNat (code . mkSeqInstr (BF cond result target))
2508   where
2509     pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2510
2511     fltCmpOp op = case op of
2512         FloatGtOp -> True
2513         FloatGeOp -> True
2514         FloatEqOp -> True
2515         FloatNeOp -> True
2516         FloatLtOp -> True
2517         FloatLeOp -> True
2518         DoubleGtOp -> True
2519         DoubleGeOp -> True
2520         DoubleEqOp -> True
2521         DoubleNeOp -> True
2522         DoubleLtOp -> True
2523         DoubleLeOp -> True
2524         _ -> False
2525     (instr, cond) = case op of
2526         FloatGtOp -> (FCMP TF LE, EQQ)
2527         FloatGeOp -> (FCMP TF LTT, EQQ)
2528         FloatEqOp -> (FCMP TF EQQ, NE)
2529         FloatNeOp -> (FCMP TF EQQ, EQQ)
2530         FloatLtOp -> (FCMP TF LTT, NE)
2531         FloatLeOp -> (FCMP TF LE, NE)
2532         DoubleGtOp -> (FCMP TF LE, EQQ)
2533         DoubleGeOp -> (FCMP TF LTT, EQQ)
2534         DoubleEqOp -> (FCMP TF EQQ, NE)
2535         DoubleNeOp -> (FCMP TF EQQ, EQQ)
2536         DoubleLtOp -> (FCMP TF LTT, NE)
2537         DoubleLeOp -> (FCMP TF LE, NE)
2538
2539 genCondJump lbl (StPrim op [x, y])
2540   = trivialCode instr x y           `thenNat` \ register ->
2541     getNewRegNCG IntRep             `thenNat` \ tmp ->
2542     let
2543         code   = registerCode register tmp
2544         result = registerName register tmp
2545         target = ImmCLbl lbl
2546     in
2547     returnNat (code . mkSeqInstr (BI cond result target))
2548   where
2549     (instr, cond) = case op of
2550         CharGtOp -> (CMP LE, EQQ)
2551         CharGeOp -> (CMP LTT, EQQ)
2552         CharEqOp -> (CMP EQQ, NE)
2553         CharNeOp -> (CMP EQQ, EQQ)
2554         CharLtOp -> (CMP LTT, NE)
2555         CharLeOp -> (CMP LE, NE)
2556         IntGtOp -> (CMP LE, EQQ)
2557         IntGeOp -> (CMP LTT, EQQ)
2558         IntEqOp -> (CMP EQQ, NE)
2559         IntNeOp -> (CMP EQQ, EQQ)
2560         IntLtOp -> (CMP LTT, NE)
2561         IntLeOp -> (CMP LE, NE)
2562         WordGtOp -> (CMP ULE, EQQ)
2563         WordGeOp -> (CMP ULT, EQQ)
2564         WordEqOp -> (CMP EQQ, NE)
2565         WordNeOp -> (CMP EQQ, EQQ)
2566         WordLtOp -> (CMP ULT, NE)
2567         WordLeOp -> (CMP ULE, NE)
2568         AddrGtOp -> (CMP ULE, EQQ)
2569         AddrGeOp -> (CMP ULT, EQQ)
2570         AddrEqOp -> (CMP EQQ, NE)
2571         AddrNeOp -> (CMP EQQ, EQQ)
2572         AddrLtOp -> (CMP ULT, NE)
2573         AddrLeOp -> (CMP ULE, NE)
2574
2575 #endif {- alpha_TARGET_ARCH -}
2576
2577 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2578
2579 #if i386_TARGET_ARCH
2580
2581 genCondJump lbl bool
2582   = getCondCode bool                `thenNat` \ condition ->
2583     let
2584         code   = condCode condition
2585         cond   = condName condition
2586     in
2587     returnNat (code `snocOL` JXX cond lbl)
2588
2589 #endif {- i386_TARGET_ARCH -}
2590
2591 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2592
2593 #if sparc_TARGET_ARCH
2594
2595 genCondJump lbl bool
2596   = getCondCode bool                `thenNat` \ condition ->
2597     let
2598         code   = condCode condition
2599         cond   = condName condition
2600         target = ImmCLbl lbl
2601     in
2602     returnNat (
2603        code `appOL`
2604        toOL (
2605          if   condFloat condition
2606          then [NOP, BF cond False target, NOP]
2607          else [BI cond False target, NOP]
2608        )
2609     )
2610
2611 #endif {- sparc_TARGET_ARCH -}
2612
2613 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2614 \end{code}
2615
2616 %************************************************************************
2617 %*                                                                      *
2618 \subsection{Generating C calls}
2619 %*                                                                      *
2620 %************************************************************************
2621
2622 Now the biggest nightmare---calls.  Most of the nastiness is buried in
2623 @get_arg@, which moves the arguments to the correct registers/stack
2624 locations.  Apart from that, the code is easy.
2625
2626 (If applicable) Do not fill the delay slots here; you will confuse the
2627 register allocator.
2628
2629 \begin{code}
2630 genCCall
2631     :: (Either FastString StixExpr)     -- function to call
2632     -> CCallConv
2633     -> PrimRep          -- type of the result
2634     -> [StixExpr]       -- arguments (of mixed type)
2635     -> NatM InstrBlock
2636
2637 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2638
2639 #if alpha_TARGET_ARCH
2640
2641 genCCall fn cconv kind args
2642   = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2643                           `thenNat` \ ((unused,_), argCode) ->
2644     let
2645         nRegs = length allArgRegs - length unused
2646         code = asmSeqThen (map ($ []) argCode)
2647     in
2648         returnSeq code [
2649             LDA pv (AddrImm (ImmLab (ptext fn))),
2650             JSR ra (AddrReg pv) nRegs,
2651             LDGP gp (AddrReg ra)]
2652   where
2653     ------------------------
2654     {-  Try to get a value into a specific register (or registers) for
2655         a call.  The first 6 arguments go into the appropriate
2656         argument register (separate registers for integer and floating
2657         point arguments, but used in lock-step), and the remaining
2658         arguments are dumped to the stack, beginning at 0(sp).  Our
2659         first argument is a pair of the list of remaining argument
2660         registers to be assigned for this call and the next stack
2661         offset to use for overflowing arguments.  This way,
2662         @get_Arg@ can be applied to all of a call's arguments using
2663         @mapAccumLNat@.
2664     -}
2665     get_arg
2666         :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
2667         -> StixTree             -- Current argument
2668         -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2669
2670     -- We have to use up all of our argument registers first...
2671
2672     get_arg ((iDst,fDst):dsts, offset) arg
2673       = getRegister arg                     `thenNat` \ register ->
2674         let
2675             reg  = if isFloatingRep pk then fDst else iDst
2676             code = registerCode register reg
2677             src  = registerName register reg
2678             pk   = registerRep register
2679         in
2680         returnNat (
2681             if isFloatingRep pk then
2682                 ((dsts, offset), if isFixed register then
2683                     code . mkSeqInstr (FMOV src fDst)
2684                     else code)
2685             else
2686                 ((dsts, offset), if isFixed register then
2687                     code . mkSeqInstr (OR src (RIReg src) iDst)
2688                     else code))
2689
2690     -- Once we have run out of argument registers, we move to the
2691     -- stack...
2692
2693     get_arg ([], offset) arg
2694       = getRegister arg                 `thenNat` \ register ->
2695         getNewRegNCG (registerRep register)
2696                                         `thenNat` \ tmp ->
2697         let
2698             code = registerCode register tmp
2699             src  = registerName register tmp
2700             pk   = registerRep register
2701             sz   = primRepToSize pk
2702         in
2703         returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2704
2705 #endif {- alpha_TARGET_ARCH -}
2706
2707 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2708
2709 #if i386_TARGET_ARCH
2710
2711 genCCall fn cconv ret_rep args
2712   = mapNat push_arg
2713            (reverse args)       `thenNat` \ sizes_n_codes ->
2714     getDeltaNat                 `thenNat` \ delta ->
2715     let (sizes, push_codes) = unzip sizes_n_codes
2716         tot_arg_size        = sum sizes
2717     in
2718     -- deal with static vs dynamic call targets
2719     (case fn of
2720         Left t_static
2721            -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
2722         Right dyn
2723            -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
2724               ASSERT(case dyn_rep of { L -> True; _ -> False})
2725               returnNat (dyn_c `snocOL` CALL (Right dyn_r))
2726     )
2727                                 `thenNat` \ callinsns ->
2728     let push_code = concatOL push_codes
2729         call = callinsns `appOL`
2730                toOL (
2731                         -- Deallocate parameters after call for ccall;
2732                         -- but not for stdcall (callee does it)
2733                   (if cconv == StdCallConv then [] else
2734                    [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2735                   ++
2736                   [DELTA (delta + tot_arg_size)]
2737                )
2738     in
2739     setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2740     returnNat (push_code `appOL` call)
2741
2742   where
2743     -- function names that begin with '.' are assumed to be special
2744     -- internally generated names like '.mul,' which don't get an
2745     -- underscore prefix
2746     -- ToDo:needed (WDP 96/03) ???
2747     fn_u  = unpackFS (unLeft fn)
2748     fn__2 tot_arg_size
2749        | head fn_u == '.'
2750        = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2751        | otherwise      -- General case
2752        = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2753
2754     stdcallsize tot_arg_size
2755        | cconv == StdCallConv = '@':show tot_arg_size
2756        | otherwise            = ""
2757
2758     arg_size DF = 8
2759     arg_size F  = 4
2760     arg_size _  = 4
2761
2762     ------------
2763     push_arg :: StixExpr{-current argument-}
2764                     -> NatM (Int, InstrBlock)  -- argsz, code
2765
2766     push_arg arg
2767       | is64BitRep arg_rep
2768       = iselExpr64 arg                  `thenNat` \ (ChildCode64 code vr_lo) ->
2769         getDeltaNat                     `thenNat` \ delta ->
2770         setDeltaNat (delta - 8)         `thenNat` \ _ ->
2771         let r_lo = VirtualRegI vr_lo
2772             r_hi = getHiVRegFromLo r_lo
2773         in  returnNat (8,
2774                        code `appOL`
2775                        toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
2776                              PUSH L (OpReg r_lo), DELTA (delta - 8)]
2777             )
2778       | otherwise
2779       = get_op arg                      `thenNat` \ (code, reg, sz) ->
2780         getDeltaNat                     `thenNat` \ delta ->
2781         arg_size sz                     `bind`    \ size ->
2782         setDeltaNat (delta-size)        `thenNat` \ _ ->
2783         if   (case sz of DF -> True; F -> True; _ -> False)
2784         then returnNat (size,
2785                         code `appOL`
2786                         toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2787                               DELTA (delta-size),
2788                               GST sz reg (AddrBaseIndex (Just esp)
2789                                                         Nothing
2790                                                         (ImmInt 0))]
2791                        )
2792         else returnNat (size,
2793                         code `snocOL`
2794                         PUSH L (OpReg reg) `snocOL`
2795                         DELTA (delta-size)
2796                        )
2797       where
2798          arg_rep = repOfStixExpr arg
2799
2800     ------------
2801     get_op
2802         :: StixExpr
2803         -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2804
2805     get_op op
2806       = getRegister op          `thenNat` \ register ->
2807         getNewRegNCG (registerRep register)
2808                                 `thenNat` \ tmp ->
2809         let
2810             code = registerCode register tmp
2811             reg  = registerName register tmp
2812             pk   = registerRep  register
2813             sz   = primRepToSize pk
2814         in
2815         returnNat (code, reg, sz)
2816
2817 #endif {- i386_TARGET_ARCH -}
2818
2819 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2820
2821 #if sparc_TARGET_ARCH
2822 {-
2823    The SPARC calling convention is an absolute
2824    nightmare.  The first 6x32 bits of arguments are mapped into
2825    %o0 through %o5, and the remaining arguments are dumped to the
2826    stack, beginning at [%sp+92].  (Note that %o6 == %sp.)
2827
2828    If we have to put args on the stack, move %o6==%sp down by
2829    the number of words to go on the stack, to ensure there's enough space.
2830
2831    According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2832    16 words above the stack pointer is a word for the address of
2833    a structure return value.  I use this as a temporary location
2834    for moving values from float to int regs.  Certainly it isn't
2835    safe to put anything in the 16 words starting at %sp, since
2836    this area can get trashed at any time due to window overflows
2837    caused by signal handlers.
2838
2839    A final complication (if the above isn't enough) is that
2840    we can't blithely calculate the arguments one by one into
2841    %o0 .. %o5.  Consider the following nested calls:
2842
2843        fff a (fff b c)
2844
2845    Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately
2846    the inner call will itself use %o0, which trashes the value put there
2847    in preparation for the outer call.  Upshot: we need to calculate the
2848    args into temporary regs, and move those to arg regs or onto the
2849    stack only immediately prior to the call proper.  Sigh.
2850 -}
2851
2852 genCCall fn cconv kind args
2853   = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2854     let
2855         (argcodes, vregss) = unzip argcode_and_vregs
2856         n_argRegs          = length allArgRegs
2857         n_argRegs_used     = min (length vregs) n_argRegs
2858         vregs              = concat vregss
2859     in
2860     -- deal with static vs dynamic call targets
2861     (case fn of
2862         Left t_static
2863            -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
2864         Right dyn
2865            -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
2866               returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
2867     )
2868                                 `thenNat` \ callinsns ->
2869     let
2870         argcode = concatOL argcodes
2871         (move_sp_down, move_sp_up)
2872            = let diff = length vregs - n_argRegs
2873                  nn   = if odd diff then diff + 1 else diff -- keep 8-byte alignment
2874              in  if   nn <= 0
2875                  then (nilOL, nilOL)
2876                  else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2877         transfer_code
2878            = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2879     in
2880         returnNat (argcode       `appOL`
2881                    move_sp_down  `appOL`
2882                    transfer_code `appOL`
2883                    callinsns     `appOL`
2884                    unitOL NOP    `appOL`
2885                    move_sp_up)
2886   where
2887      -- function names that begin with '.' are assumed to be special
2888      -- internally generated names like '.mul,' which don't get an
2889      -- underscore prefix
2890      -- ToDo:needed (WDP 96/03) ???
2891      fn_static = unLeft fn
2892      fn__2 = case (headFS fn_static) of
2893                 '.' -> ImmLit (ftext fn_static)
2894                 _   -> ImmLab False (ftext fn_static)
2895
2896      -- move args from the integer vregs into which they have been
2897      -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2898      move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2899
2900      move_final [] _ offset          -- all args done
2901         = []
2902
2903      move_final (v:vs) [] offset     -- out of aregs; move to stack
2904         = ST W v (spRel offset)
2905           : move_final vs [] (offset+1)
2906
2907      move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2908         = OR False g0 (RIReg v) a
2909           : move_final vs az offset
2910
2911      -- generate code to calculate an argument, and move it into one
2912      -- or two integer vregs.
2913      arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
2914      arg_to_int_vregs arg
2915         | is64BitRep (repOfStixExpr arg)
2916         = iselExpr64 arg                `thenNat` \ (ChildCode64 code vr_lo) ->
2917           let r_lo = VirtualRegI vr_lo
2918               r_hi = getHiVRegFromLo r_lo
2919           in  returnNat (code, [r_hi, r_lo])
2920         | otherwise
2921         = getRegister arg                     `thenNat` \ register ->
2922           getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2923           let code = registerCode register tmp
2924               src  = registerName register tmp
2925               pk   = registerRep register
2926           in
2927           -- the value is in src.  Get it into 1 or 2 int vregs.
2928           case pk of
2929              DoubleRep ->
2930                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2931                 getNewRegNCG WordRep  `thenNat` \ v2 ->
2932                 returnNat (
2933                    code                          `snocOL`
2934                    FMOV DF src f0                `snocOL`
2935                    ST   F  f0 (spRel 16)         `snocOL`
2936                    LD   W  (spRel 16) v1         `snocOL`
2937                    ST   F  (fPair f0) (spRel 16) `snocOL`
2938                    LD   W  (spRel 16) v2
2939                    ,
2940                    [v1,v2]
2941                 )
2942              FloatRep ->
2943                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2944                 returnNat (
2945                    code                    `snocOL`
2946                    ST   F  src (spRel 16)  `snocOL`
2947                    LD   W  (spRel 16) v1
2948                    ,
2949                    [v1]
2950                 )
2951              other ->
2952                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2953                 returnNat (
2954                    code `snocOL` OR False g0 (RIReg src) v1
2955                    ,
2956                    [v1]
2957                 )
2958 #endif {- sparc_TARGET_ARCH -}
2959
2960 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2961 \end{code}
2962
2963 %************************************************************************
2964 %*                                                                      *
2965 \subsection{Support bits}
2966 %*                                                                      *
2967 %************************************************************************
2968
2969 %************************************************************************
2970 %*                                                                      *
2971 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2972 %*                                                                      *
2973 %************************************************************************
2974
2975 Turn those condition codes into integers now (when they appear on
2976 the right hand side of an assignment).
2977
2978 (If applicable) Do not fill the delay slots here; you will confuse the
2979 register allocator.
2980
2981 \begin{code}
2982 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
2983
2984 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2985
2986 #if alpha_TARGET_ARCH
2987 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2988 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2989 #endif {- alpha_TARGET_ARCH -}
2990
2991 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2992
2993 #if i386_TARGET_ARCH
2994
2995 condIntReg cond x y
2996   = condIntCode cond x y        `thenNat` \ condition ->
2997     getNewRegNCG IntRep         `thenNat` \ tmp ->
2998     let
2999         code = condCode condition
3000         cond = condName condition
3001         code__2 dst = code `appOL` toOL [
3002             SETCC cond (OpReg tmp),
3003             AND L (OpImm (ImmInt 1)) (OpReg tmp),
3004             MOV L (OpReg tmp) (OpReg dst)]
3005     in
3006     returnNat (Any IntRep code__2)
3007
3008 condFltReg cond x y
3009   = getNatLabelNCG              `thenNat` \ lbl1 ->
3010     getNatLabelNCG              `thenNat` \ lbl2 ->
3011     condFltCode cond x y        `thenNat` \ condition ->
3012     let
3013         code = condCode condition
3014         cond = condName condition
3015         code__2 dst = code `appOL` toOL [
3016             JXX cond lbl1,
3017             MOV L (OpImm (ImmInt 0)) (OpReg dst),
3018             JXX ALWAYS lbl2,
3019             LABEL lbl1,
3020             MOV L (OpImm (ImmInt 1)) (OpReg dst),
3021             LABEL lbl2]
3022     in
3023     returnNat (Any IntRep code__2)
3024
3025 #endif {- i386_TARGET_ARCH -}
3026
3027 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3028
3029 #if sparc_TARGET_ARCH
3030
3031 condIntReg EQQ x (StInt 0)
3032   = getRegister x               `thenNat` \ register ->
3033     getNewRegNCG IntRep         `thenNat` \ tmp ->
3034     let
3035         code = registerCode register tmp
3036         src  = registerName register tmp
3037         code__2 dst = code `appOL` toOL [
3038             SUB False True g0 (RIReg src) g0,
3039             SUB True False g0 (RIImm (ImmInt (-1))) dst]
3040     in
3041     returnNat (Any IntRep code__2)
3042
3043 condIntReg EQQ x y
3044   = getRegister x               `thenNat` \ register1 ->
3045     getRegister y               `thenNat` \ register2 ->
3046     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3047     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3048     let
3049         code1 = registerCode register1 tmp1
3050         src1  = registerName register1 tmp1
3051         code2 = registerCode register2 tmp2
3052         src2  = registerName register2 tmp2
3053         code__2 dst = code1 `appOL` code2 `appOL` toOL [
3054             XOR False src1 (RIReg src2) dst,
3055             SUB False True g0 (RIReg dst) g0,
3056             SUB True False g0 (RIImm (ImmInt (-1))) dst]
3057     in
3058     returnNat (Any IntRep code__2)
3059
3060 condIntReg NE x (StInt 0)
3061   = getRegister x               `thenNat` \ register ->
3062     getNewRegNCG IntRep         `thenNat` \ tmp ->
3063     let
3064         code = registerCode register tmp
3065         src  = registerName register tmp
3066         code__2 dst = code `appOL` toOL [
3067             SUB False True g0 (RIReg src) g0,
3068             ADD True False g0 (RIImm (ImmInt 0)) dst]
3069     in
3070     returnNat (Any IntRep code__2)
3071
3072 condIntReg NE x y
3073   = getRegister x               `thenNat` \ register1 ->
3074     getRegister y               `thenNat` \ register2 ->
3075     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3076     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3077     let
3078         code1 = registerCode register1 tmp1
3079         src1  = registerName register1 tmp1
3080         code2 = registerCode register2 tmp2
3081         src2  = registerName register2 tmp2
3082         code__2 dst = code1 `appOL` code2 `appOL` toOL [
3083             XOR False src1 (RIReg src2) dst,
3084             SUB False True g0 (RIReg dst) g0,
3085             ADD True False g0 (RIImm (ImmInt 0)) dst]
3086     in
3087     returnNat (Any IntRep code__2)
3088
3089 condIntReg cond x y
3090   = getNatLabelNCG              `thenNat` \ lbl1 ->
3091     getNatLabelNCG              `thenNat` \ lbl2 ->
3092     condIntCode cond x y        `thenNat` \ condition ->
3093     let
3094         code = condCode condition
3095         cond = condName condition
3096         code__2 dst = code `appOL` toOL [
3097             BI cond False (ImmCLbl lbl1), NOP,
3098             OR False g0 (RIImm (ImmInt 0)) dst,
3099             BI ALWAYS False (ImmCLbl lbl2), NOP,
3100             LABEL lbl1,
3101             OR False g0 (RIImm (ImmInt 1)) dst,
3102             LABEL lbl2]
3103     in
3104     returnNat (Any IntRep code__2)
3105
3106 condFltReg cond x y
3107   = getNatLabelNCG              `thenNat` \ lbl1 ->
3108     getNatLabelNCG              `thenNat` \ lbl2 ->
3109     condFltCode cond x y        `thenNat` \ condition ->
3110     let
3111         code = condCode condition
3112         cond = condName condition
3113         code__2 dst = code `appOL` toOL [
3114             NOP,
3115             BF cond False (ImmCLbl lbl1), NOP,
3116             OR False g0 (RIImm (ImmInt 0)) dst,
3117             BI ALWAYS False (ImmCLbl lbl2), NOP,
3118             LABEL lbl1,
3119             OR False g0 (RIImm (ImmInt 1)) dst,
3120             LABEL lbl2]
3121     in
3122     returnNat (Any IntRep code__2)
3123
3124 #endif {- sparc_TARGET_ARCH -}
3125
3126 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3127 \end{code}
3128
3129 %************************************************************************
3130 %*                                                                      *
3131 \subsubsection{@trivial*Code@: deal with trivial instructions}
3132 %*                                                                      *
3133 %************************************************************************
3134
3135 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3136 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions.  Only look
3137 for constants on the right hand side, because that's where the generic
3138 optimizer will have put them.
3139
3140 Similarly, for unary instructions, we don't have to worry about
3141 matching an StInt as the argument, because genericOpt will already
3142 have handled the constant-folding.
3143
3144 \begin{code}
3145 trivialCode
3146     :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3147       ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3148                      -> Maybe (Operand -> Operand -> Instr)
3149       ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3150       ,)))
3151     -> StixExpr -> StixExpr -- the two arguments
3152     -> NatM Register
3153
3154 trivialFCode
3155     :: PrimRep
3156     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3157       ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3158       ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3159       ,)))
3160     -> StixExpr -> StixExpr -- the two arguments
3161     -> NatM Register
3162
3163 trivialUCode
3164     :: IF_ARCH_alpha((RI -> Reg -> Instr)
3165       ,IF_ARCH_i386 ((Operand -> Instr)
3166       ,IF_ARCH_sparc((RI -> Reg -> Instr)
3167       ,)))
3168     -> StixExpr -- the one argument
3169     -> NatM Register
3170
3171 trivialUFCode
3172     :: PrimRep
3173     -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3174       ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3175       ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3176       ,)))
3177     -> StixExpr -- the one argument
3178     -> NatM Register
3179
3180 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3181
3182 #if alpha_TARGET_ARCH
3183
3184 trivialCode instr x (StInt y)
3185   | fits8Bits y
3186   = getRegister x               `thenNat` \ register ->
3187     getNewRegNCG IntRep         `thenNat` \ tmp ->
3188     let
3189         code = registerCode register tmp
3190         src1 = registerName register tmp
3191         src2 = ImmInt (fromInteger y)
3192         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3193     in
3194     returnNat (Any IntRep code__2)
3195
3196 trivialCode instr x y
3197   = getRegister x               `thenNat` \ register1 ->
3198     getRegister y               `thenNat` \ register2 ->
3199     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3200     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3201     let
3202         code1 = registerCode register1 tmp1 []
3203         src1  = registerName register1 tmp1
3204         code2 = registerCode register2 tmp2 []
3205         src2  = registerName register2 tmp2
3206         code__2 dst = asmSeqThen [code1, code2] .
3207                      mkSeqInstr (instr src1 (RIReg src2) dst)
3208     in
3209     returnNat (Any IntRep code__2)
3210
3211 ------------
3212 trivialUCode instr x
3213   = getRegister x               `thenNat` \ register ->
3214     getNewRegNCG IntRep         `thenNat` \ tmp ->
3215     let
3216         code = registerCode register tmp
3217         src  = registerName register tmp
3218         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3219     in
3220     returnNat (Any IntRep code__2)
3221
3222 ------------
3223 trivialFCode _ instr x y
3224   = getRegister x               `thenNat` \ register1 ->
3225     getRegister y               `thenNat` \ register2 ->
3226     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
3227     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
3228     let
3229         code1 = registerCode register1 tmp1
3230         src1  = registerName register1 tmp1
3231
3232         code2 = registerCode register2 tmp2
3233         src2  = registerName register2 tmp2
3234
3235         code__2 dst = asmSeqThen [code1 [], code2 []] .
3236                       mkSeqInstr (instr src1 src2 dst)
3237     in
3238     returnNat (Any DoubleRep code__2)
3239
3240 trivialUFCode _ instr x
3241   = getRegister x               `thenNat` \ register ->
3242     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3243     let
3244         code = registerCode register tmp
3245         src  = registerName register tmp
3246         code__2 dst = code . mkSeqInstr (instr src dst)
3247     in
3248     returnNat (Any DoubleRep code__2)
3249
3250 #endif {- alpha_TARGET_ARCH -}
3251
3252 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3253
3254 #if i386_TARGET_ARCH
3255 \end{code}
3256 The Rules of the Game are:
3257
3258 * You cannot assume anything about the destination register dst;
3259   it may be anything, including a fixed reg.
3260
3261 * You may compute an operand into a fixed reg, but you may not
3262   subsequently change the contents of that fixed reg.  If you
3263   want to do so, first copy the value either to a temporary
3264   or into dst.  You are free to modify dst even if it happens
3265   to be a fixed reg -- that's not your problem.
3266
3267 * You cannot assume that a fixed reg will stay live over an
3268   arbitrary computation.  The same applies to the dst reg.
3269
3270 * Temporary regs obtained from getNewRegNCG are distinct from
3271   each other and from all other regs, and stay live over
3272   arbitrary computations.
3273
3274 \begin{code}
3275
3276 trivialCode instr maybe_revinstr a b
3277
3278   | is_imm_b
3279   = getRegister a                         `thenNat` \ rega ->
3280     let mkcode dst
3281           = if   isAny rega
3282             then registerCode rega dst      `bind` \ code_a ->
3283                  code_a `snocOL`
3284                  instr (OpImm imm_b) (OpReg dst)
3285             else registerCodeF rega         `bind` \ code_a ->
3286                  registerNameF rega         `bind` \ r_a ->
3287                  code_a `snocOL`
3288                  MOV L (OpReg r_a) (OpReg dst) `snocOL`
3289                  instr (OpImm imm_b) (OpReg dst)
3290     in
3291     returnNat (Any IntRep mkcode)
3292
3293   | is_imm_a
3294   = getRegister b                         `thenNat` \ regb ->
3295     getNewRegNCG IntRep                   `thenNat` \ tmp ->
3296     let revinstr_avail = maybeToBool maybe_revinstr
3297         revinstr       = case maybe_revinstr of Just ri -> ri
3298         mkcode dst
3299           | revinstr_avail
3300           = if   isAny regb
3301             then registerCode regb dst      `bind` \ code_b ->
3302                  code_b `snocOL`
3303                  revinstr (OpImm imm_a) (OpReg dst)
3304             else registerCodeF regb         `bind` \ code_b ->
3305                  registerNameF regb         `bind` \ r_b ->
3306                  code_b `snocOL`
3307                  MOV L (OpReg r_b) (OpReg dst) `snocOL`
3308                  revinstr (OpImm imm_a) (OpReg dst)
3309
3310           | otherwise
3311           = if   isAny regb
3312             then registerCode regb tmp      `bind` \ code_b ->
3313                  code_b `snocOL`
3314                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3315                  instr (OpReg tmp) (OpReg dst)
3316             else registerCodeF regb         `bind` \ code_b ->
3317                  registerNameF regb         `bind` \ r_b ->
3318                  code_b `snocOL`
3319                  MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3320                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3321                  instr (OpReg tmp) (OpReg dst)
3322     in
3323     returnNat (Any IntRep mkcode)
3324
3325   | otherwise
3326   = getRegister a                         `thenNat` \ rega ->
3327     getRegister b                         `thenNat` \ regb ->
3328     getNewRegNCG IntRep                   `thenNat` \ tmp ->
3329     let mkcode dst
3330           = case (isAny rega, isAny regb) of
3331               (True, True)
3332                  -> registerCode regb tmp   `bind` \ code_b ->
3333                     registerCode rega dst   `bind` \ code_a ->
3334                     code_b `appOL`
3335                     code_a `snocOL`
3336                     instr (OpReg tmp) (OpReg dst)
3337               (True, False)
3338                  -> registerCode  rega tmp  `bind` \ code_a ->
3339                     registerCodeF regb      `bind` \ code_b ->
3340                     registerNameF regb      `bind` \ r_b ->
3341                     code_a `appOL`
3342                     code_b `snocOL`
3343                     instr (OpReg r_b) (OpReg tmp) `snocOL`
3344                     MOV L (OpReg tmp) (OpReg dst)
3345               (False, True)
3346                  -> registerCode  regb tmp  `bind` \ code_b ->
3347                     registerCodeF rega      `bind` \ code_a ->
3348                     registerNameF rega      `bind` \ r_a ->
3349                     code_b `appOL`
3350                     code_a `snocOL`
3351                     MOV L (OpReg r_a) (OpReg dst) `snocOL`
3352                     instr (OpReg tmp) (OpReg dst)
3353               (False, False)
3354                  -> registerCodeF  rega     `bind` \ code_a ->
3355                     registerNameF  rega     `bind` \ r_a ->
3356                     registerCodeF  regb     `bind` \ code_b ->
3357                     registerNameF  regb     `bind` \ r_b ->
3358                     code_a `snocOL`
3359                     MOV L (OpReg r_a) (OpReg tmp) `appOL`
3360                     code_b `snocOL`
3361                     instr (OpReg r_b) (OpReg tmp) `snocOL`
3362                     MOV L (OpReg tmp) (OpReg dst)
3363     in
3364     returnNat (Any IntRep mkcode)
3365
3366     where
3367        maybe_imm_a = maybeImm a
3368        is_imm_a    = maybeToBool maybe_imm_a
3369        imm_a       = case maybe_imm_a of Just imm -> imm
3370
3371        maybe_imm_b = maybeImm b
3372        is_imm_b    = maybeToBool maybe_imm_b
3373        imm_b       = case maybe_imm_b of Just imm -> imm
3374
3375
3376 -----------
3377 trivialUCode instr x
3378   = getRegister x               `thenNat` \ register ->
3379     let
3380         code__2 dst = let code = registerCode register dst
3381                           src  = registerName register dst
3382                       in code `appOL`
3383                          if   isFixed register && dst /= src
3384                          then toOL [MOV L (OpReg src) (OpReg dst),
3385                                     instr (OpReg dst)]
3386                          else unitOL (instr (OpReg src))
3387     in
3388     returnNat (Any IntRep code__2)
3389
3390 -----------
3391 trivialFCode pk instr x y
3392   = getRegister x               `thenNat` \ register1 ->
3393     getRegister y               `thenNat` \ register2 ->
3394     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
3395     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
3396     let
3397         code1 = registerCode register1 tmp1
3398         src1  = registerName register1 tmp1
3399
3400         code2 = registerCode register2 tmp2
3401         src2  = registerName register2 tmp2
3402
3403         code__2 dst
3404            -- treat the common case specially: both operands in
3405            -- non-fixed regs.
3406            | isAny register1 && isAny register2
3407            = code1 `appOL`
3408              code2 `snocOL`
3409              instr (primRepToSize pk) src1 src2 dst
3410
3411            -- be paranoid (and inefficient)
3412            | otherwise
3413            = code1 `snocOL` GMOV src1 tmp1  `appOL`
3414              code2 `snocOL`
3415              instr (primRepToSize pk) tmp1 src2 dst
3416     in
3417     returnNat (Any pk code__2)
3418
3419
3420 -------------
3421 trivialUFCode pk instr x
3422   = getRegister x               `thenNat` \ register ->
3423     getNewRegNCG pk             `thenNat` \ tmp ->
3424     let
3425         code = registerCode register tmp
3426         src  = registerName register tmp
3427         code__2 dst = code `snocOL` instr src dst
3428     in
3429     returnNat (Any pk code__2)
3430
3431 #endif {- i386_TARGET_ARCH -}
3432
3433 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3434
3435 #if sparc_TARGET_ARCH
3436
3437 trivialCode instr x (StInt y)
3438   | fits13Bits y
3439   = getRegister x               `thenNat` \ register ->
3440     getNewRegNCG IntRep         `thenNat` \ tmp ->
3441     let
3442         code = registerCode register tmp
3443         src1 = registerName register tmp
3444         src2 = ImmInt (fromInteger y)
3445         code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3446     in
3447     returnNat (Any IntRep code__2)
3448
3449 trivialCode instr x y
3450   = getRegister x               `thenNat` \ register1 ->
3451     getRegister y               `thenNat` \ register2 ->
3452     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3453     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3454     let
3455         code1 = registerCode register1 tmp1
3456         src1  = registerName register1 tmp1
3457         code2 = registerCode register2 tmp2
3458         src2  = registerName register2 tmp2
3459         code__2 dst = code1 `appOL` code2 `snocOL`
3460                       instr src1 (RIReg src2) dst
3461     in
3462     returnNat (Any IntRep code__2)
3463
3464 ------------
3465 trivialFCode pk instr x y
3466   = getRegister x               `thenNat` \ register1 ->
3467     getRegister y               `thenNat` \ register2 ->
3468     getNewRegNCG (registerRep register1)
3469                                 `thenNat` \ tmp1 ->
3470     getNewRegNCG (registerRep register2)
3471                                 `thenNat` \ tmp2 ->
3472     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3473     let
3474         promote x = FxTOy F DF x tmp
3475
3476         pk1   = registerRep register1
3477         code1 = registerCode register1 tmp1
3478         src1  = registerName register1 tmp1
3479
3480         pk2   = registerRep register2
3481         code2 = registerCode register2 tmp2
3482         src2  = registerName register2 tmp2
3483
3484         code__2 dst =
3485                 if pk1 == pk2 then
3486                     code1 `appOL` code2 `snocOL`
3487                     instr (primRepToSize pk) src1 src2 dst
3488                 else if pk1 == FloatRep then
3489                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3490                     instr DF tmp src2 dst
3491                 else
3492                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3493                     instr DF src1 tmp dst
3494     in
3495     returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3496
3497 ------------
3498 trivialUCode instr x
3499   = getRegister x               `thenNat` \ register ->
3500     getNewRegNCG IntRep         `thenNat` \ tmp ->
3501     let
3502         code = registerCode register tmp
3503         src  = registerName register tmp
3504         code__2 dst = code `snocOL` instr (RIReg src) dst
3505     in
3506     returnNat (Any IntRep code__2)
3507
3508 -------------
3509 trivialUFCode pk instr x
3510   = getRegister x               `thenNat` \ register ->
3511     getNewRegNCG pk             `thenNat` \ tmp ->
3512     let
3513         code = registerCode register tmp
3514         src  = registerName register tmp
3515         code__2 dst = code `snocOL` instr src dst
3516     in
3517     returnNat (Any pk code__2)
3518
3519 #endif {- sparc_TARGET_ARCH -}
3520
3521 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3522 \end{code}
3523
3524 %************************************************************************
3525 %*                                                                      *
3526 \subsubsection{Coercing to/from integer/floating-point...}
3527 %*                                                                      *
3528 %************************************************************************
3529
3530 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3531 conversions.  We have to store temporaries in memory to move
3532 between the integer and the floating point register sets.
3533
3534 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
3535 pretend, on sparc at least, that double and float regs are seperate
3536 kinds, so the value has to be computed into one kind before being
3537 explicitly "converted" to live in the other kind.
3538
3539 \begin{code}
3540 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
3541 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
3542
3543 coerceDbl2Flt :: StixExpr -> NatM Register
3544 coerceFlt2Dbl :: StixExpr -> NatM Register
3545 \end{code}
3546
3547 \begin{code}
3548 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3549
3550 #if alpha_TARGET_ARCH
3551
3552 coerceInt2FP _ x
3553   = getRegister x               `thenNat` \ register ->
3554     getNewRegNCG IntRep         `thenNat` \ reg ->
3555     let
3556         code = registerCode register reg
3557         src  = registerName register reg
3558
3559         code__2 dst = code . mkSeqInstrs [
3560             ST Q src (spRel 0),
3561             LD TF dst (spRel 0),
3562             CVTxy Q TF dst dst]
3563     in
3564     returnNat (Any DoubleRep code__2)
3565
3566 -------------
3567 coerceFP2Int x
3568   = getRegister x               `thenNat` \ register ->
3569     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3570     let
3571         code = registerCode register tmp
3572         src  = registerName register tmp
3573
3574         code__2 dst = code . mkSeqInstrs [
3575             CVTxy TF Q src tmp,
3576             ST TF tmp (spRel 0),
3577             LD Q dst (spRel 0)]
3578     in
3579     returnNat (Any IntRep code__2)
3580
3581 #endif {- alpha_TARGET_ARCH -}
3582
3583 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3584
3585 #if i386_TARGET_ARCH
3586
3587 coerceInt2FP pk x
3588   = getRegister x               `thenNat` \ register ->
3589     getNewRegNCG IntRep         `thenNat` \ reg ->
3590     let
3591         code = registerCode register reg
3592         src  = registerName register reg
3593         opc  = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3594         code__2 dst = code `snocOL` opc src dst
3595     in
3596     returnNat (Any pk code__2)
3597
3598 ------------
3599 coerceFP2Int fprep x
3600   = getRegister x               `thenNat` \ register ->
3601     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3602     let
3603         code = registerCode register tmp
3604         src  = registerName register tmp
3605         pk   = registerRep register
3606
3607         opc  = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3608         code__2 dst = code `snocOL` opc src dst
3609     in
3610     returnNat (Any IntRep code__2)
3611
3612 ------------
3613 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
3614 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
3615
3616 #endif {- i386_TARGET_ARCH -}
3617
3618 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3619
3620 #if sparc_TARGET_ARCH
3621
3622 coerceInt2FP pk x
3623   = getRegister x               `thenNat` \ register ->
3624     getNewRegNCG IntRep         `thenNat` \ reg ->
3625     let
3626         code = registerCode register reg
3627         src  = registerName register reg
3628
3629         code__2 dst = code `appOL` toOL [
3630             ST W src (spRel (-2)),
3631             LD W (spRel (-2)) dst,
3632             FxTOy W (primRepToSize pk) dst dst]
3633     in
3634     returnNat (Any pk code__2)
3635
3636 ------------
3637 coerceFP2Int fprep x
3638   = ASSERT(fprep == DoubleRep || fprep == FloatRep)
3639     getRegister x               `thenNat` \ register ->
3640     getNewRegNCG fprep          `thenNat` \ reg ->
3641     getNewRegNCG FloatRep       `thenNat` \ tmp ->
3642     let
3643         code = registerCode register reg
3644         src  = registerName register reg
3645         code__2 dst = code `appOL` toOL [
3646             FxTOy (primRepToSize fprep) W src tmp,
3647             ST W tmp (spRel (-2)),
3648             LD W (spRel (-2)) dst]
3649     in
3650     returnNat (Any IntRep code__2)
3651
3652 ------------
3653 coerceDbl2Flt x
3654   = getRegister x               `thenNat` \ register ->
3655     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3656     let code = registerCode register tmp
3657         src  = registerName register tmp
3658     in
3659         returnNat (Any FloatRep
3660                        (\dst -> code `snocOL` FxTOy DF F src dst))
3661
3662 ------------
3663 coerceFlt2Dbl x
3664   = getRegister x               `thenNat` \ register ->
3665     getNewRegNCG FloatRep       `thenNat` \ tmp ->
3666     let code = registerCode register tmp
3667         src  = registerName register tmp
3668     in
3669         returnNat (Any DoubleRep
3670                        (\dst -> code `snocOL` FxTOy F DF src dst))
3671
3672 #endif {- sparc_TARGET_ARCH -}
3673
3674 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3675 \end{code}