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