ghc/compiler/nativeGen/MachCode.lhs

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