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