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