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