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