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 MachMisc         -- may differ per-platform
  18 import MachRegs
  19 import OrdList          ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
  20                           snocOL, consOL, concatOL )
  21 import MachOp           ( MachOp(..), pprMachOp )
  22 import AbsCUtils        ( magicIdPrimRep )
  23 import PprAbsC          ( pprMagicId )
  24 import ForeignCall      ( CCallConv(..) )
  25 import CLabel           ( CLabel, labelDynamic )
  26 #if sparc_TARGET_ARCH || alpha_TARGET_ARCH
  27 import CLabel           ( isAsmTemp )
  28 #endif
  29 import Maybes           ( maybeToBool )
  30 import PrimRep          ( isFloatingRep, is64BitRep, PrimRep(..),
  31 #if powerpc_TARGET_ARCH
  32                           getPrimRepSize,
  33 #endif
  34                           getPrimRepSizeInBytes )
  35 import Stix             ( getNatLabelNCG, StixStmt(..), StixExpr(..),
  36                           StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..),
  37                           DestInfo, hasDestInfo,
  38                           pprStixExpr, repOfStixExpr,
  39                           NatM, thenNat, returnNat, mapNat,
  40                           mapAndUnzipNat, mapAccumLNat,
  41                           getDeltaNat, setDeltaNat,
  42                           IF_ARCH_powerpc(addImportNat COMMA,)
  43                           ncgPrimopMoan,
  44                           ncg_target_is_32bit
  45                         )
  46 import Pretty
  47 import Outputable       ( panic, pprPanic, showSDoc )
  48 import qualified Outputable
  49 import CmdLineOpts      ( opt_Static )
  50 import Stix             ( pprStixStmt )
  51
  52 import Maybe            ( fromMaybe )
  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 -> fromMaybe (trivialCode2 SUBF y x) $
1688         case y of    -- subfi ('substract from' with immediate) doesn't exist
1689           StInt imm -> if fits16Bits imm && imm /= (-32768)
1690             then Just $ trivialCode ADD x (StInt (-imm))
1691             else Nothing
1692           _ -> Nothing
1693
1694       MO_NatS_Mul -> trivialCode MULLW x y
1695       MO_NatU_Mul -> trivialCode MULLW x y
1696       -- MO_NatS_MulMayOflo ->
1697
1698       MO_NatS_Quot -> trivialCode2 DIVW x y
1699       MO_NatU_Quot -> trivialCode2 DIVWU x y
1700
1701       MO_NatS_Rem  -> remainderCode DIVW x y
1702       MO_NatU_Rem  -> remainderCode DIVWU x y
1703
1704       MO_Nat_And   -> trivialCode AND x y
1705       MO_Nat_Or    -> trivialCode OR x y
1706       MO_Nat_Xor   -> trivialCode XOR x y
1707
1708       MO_Nat_Shl   -> trivialCode SLW x y
1709       MO_Nat_Shr   -> trivialCode SRW x y
1710       MO_Nat_Sar   -> trivialCode SRAW x y
1711
1712       MO_Flt_Add   -> trivialFCode FloatRep  FADD x y
1713       MO_Flt_Sub   -> trivialFCode FloatRep  FSUB x y
1714       MO_Flt_Mul   -> trivialFCode FloatRep  FMUL x y
1715       MO_Flt_Div   -> trivialFCode FloatRep  FDIV x y
1716
1717       MO_Dbl_Add   -> trivialFCode DoubleRep FADD x y
1718       MO_Dbl_Sub   -> trivialFCode DoubleRep FSUB x y
1719       MO_Dbl_Mul   -> trivialFCode DoubleRep FMUL x y
1720       MO_Dbl_Div   -> trivialFCode DoubleRep FDIV x y
1721
1722       MO_Flt_Pwr  -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1723                                          [x, y])
1724       MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
1725                                         [x, y])
1726
1727       other -> pprPanic "getRegister(powerpc) - binary StMachOp (1)" (pprMachOp mop)
1728
1729 getRegister (StInd pk mem)
1730   = getAmode mem                    `thenNat` \ amode ->
1731     let
1732         code = amodeCode amode
1733         src   = amodeAddr amode
1734         size = primRepToSize pk
1735         code__2 dst = code `snocOL` LD size dst src
1736     in
1737         returnNat (Any pk code__2)
1738
1739 getRegister (StInt i)
1740   | fits16Bits i
1741   = let
1742         src = ImmInt (fromInteger i)
1743         code dst = unitOL (LI dst src)
1744     in
1745         returnNat (Any IntRep code)
1746
1747 getRegister (StFloat d)
1748   = getNatLabelNCG                  `thenNat` \ lbl ->
1749     getNewRegNCG PtrRep             `thenNat` \ tmp ->
1750     let code dst = toOL [
1751             SEGMENT RoDataSegment,
1752             LABEL lbl,
1753             DATA F [ImmFloat d],
1754             SEGMENT TextSegment,
1755             LIS tmp (HA (ImmCLbl lbl)),
1756             LD F dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
1757     in
1758         returnNat (Any FloatRep code)
1759
1760 getRegister (StDouble d)
1761   = getNatLabelNCG                  `thenNat` \ lbl ->
1762     getNewRegNCG PtrRep             `thenNat` \ tmp ->
1763     let code dst = toOL [
1764             SEGMENT RoDataSegment,
1765             LABEL lbl,
1766             DATA DF [ImmDouble d],
1767             SEGMENT TextSegment,
1768             LIS tmp (HA (ImmCLbl lbl)),
1769             LD DF dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
1770     in
1771         returnNat (Any DoubleRep code)
1772
1773 getRegister leaf
1774   | maybeToBool imm
1775   = let
1776         code dst = toOL [
1777             LIS dst (HI imm__2),
1778             OR dst dst (RIImm (LO imm__2))]
1779     in
1780         returnNat (Any PtrRep code)
1781   | otherwise
1782   = ncgPrimopMoan "getRegister(powerpc)" (pprStixExpr leaf)
1783   where
1784     imm = maybeImm leaf
1785     imm__2 = case imm of Just x -> x
1786 #endif /* powerpc_TARGET_ARCH */
1787
1788 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1789
1790 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1791
1792 \end{code}
1793
1794 %************************************************************************
1795 %*                                                                      *
1796 \subsection{The @Amode@ type}
1797 %*                                                                      *
1798 %************************************************************************
1799
1800 @Amode@s: Memory addressing modes passed up the tree.
1801 \begin{code}
1802 data Amode = Amode MachRegsAddr InstrBlock
1803
1804 amodeAddr (Amode addr _) = addr
1805 amodeCode (Amode _ code) = code
1806 \end{code}
1807
1808 Now, given a tree (the argument to an StInd) that references memory,
1809 produce a suitable addressing mode.
1810
1811 A Rule of the Game (tm) for Amodes: use of the addr bit must
1812 immediately follow use of the code part, since the code part puts
1813 values in registers which the addr then refers to.  So you can't put
1814 anything in between, lest it overwrite some of those registers.  If
1815 you need to do some other computation between the code part and use of
1816 the addr bit, first store the effective address from the amode in a
1817 temporary, then do the other computation, and then use the temporary:
1818
1819     code
1820     LEA amode, tmp
1821     ... other computation ...
1822     ... (tmp) ...
1823
1824 \begin{code}
1825 getAmode :: StixExpr -> NatM Amode
1826
1827 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1828
1829 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1830
1831 #if alpha_TARGET_ARCH
1832
1833 getAmode (StPrim IntSubOp [x, StInt i])
1834   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1835     getRegister x               `thenNat` \ register ->
1836     let
1837         code = registerCode register tmp
1838         reg  = registerName register tmp
1839         off  = ImmInt (-(fromInteger i))
1840     in
1841     returnNat (Amode (AddrRegImm reg off) code)
1842
1843 getAmode (StPrim IntAddOp [x, StInt i])
1844   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1845     getRegister x               `thenNat` \ register ->
1846     let
1847         code = registerCode register tmp
1848         reg  = registerName register tmp
1849         off  = ImmInt (fromInteger i)
1850     in
1851     returnNat (Amode (AddrRegImm reg off) code)
1852
1853 getAmode leaf
1854   | maybeToBool imm
1855   = returnNat (Amode (AddrImm imm__2) id)
1856   where
1857     imm = maybeImm leaf
1858     imm__2 = case imm of Just x -> x
1859
1860 getAmode other
1861   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1862     getRegister other           `thenNat` \ register ->
1863     let
1864         code = registerCode register tmp
1865         reg  = registerName register tmp
1866     in
1867     returnNat (Amode (AddrReg reg) code)
1868
1869 #endif /* alpha_TARGET_ARCH */
1870
1871 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1872
1873 #if i386_TARGET_ARCH
1874
1875 -- This is all just ridiculous, since it carefully undoes
1876 -- what mangleIndexTree has just done.
1877 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1878   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1879     getRegister x               `thenNat` \ register ->
1880     let
1881         code = registerCode register tmp
1882         reg  = registerName register tmp
1883         off  = ImmInt (-(fromInteger i))
1884     in
1885     returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1886
1887 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1888   | maybeToBool imm
1889   = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1890   where
1891     imm    = maybeImm x
1892     imm__2 = case imm of Just x -> x
1893
1894 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1895   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1896     getRegister x               `thenNat` \ register ->
1897     let
1898         code = registerCode register tmp
1899         reg  = registerName register tmp
1900         off  = ImmInt (fromInteger i)
1901     in
1902     returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1903
1904 getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
1905   | shift == 0 || shift == 1 || shift == 2 || shift == 3
1906   = getNewRegNCG PtrRep         `thenNat` \ tmp1 ->
1907     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1908     getRegister x               `thenNat` \ register1 ->
1909     getRegister y               `thenNat` \ register2 ->
1910     let
1911         code1 = registerCode register1 tmp1
1912         reg1  = registerName register1 tmp1
1913         code2 = registerCode register2 tmp2
1914         reg2  = registerName register2 tmp2
1915         code__2 = code1 `appOL` code2
1916         base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1917     in
1918     returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1919                code__2)
1920
1921 getAmode leaf
1922   | maybeToBool imm
1923   = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1924   where
1925     imm    = maybeImm leaf
1926     imm__2 = case imm of Just x -> x
1927
1928 getAmode other
1929   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1930     getRegister other           `thenNat` \ register ->
1931     let
1932         code = registerCode register tmp
1933         reg  = registerName register tmp
1934     in
1935     returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1936
1937 #endif /* i386_TARGET_ARCH */
1938
1939 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1940
1941 #if sparc_TARGET_ARCH
1942
1943 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1944   | fits13Bits (-i)
1945   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1946     getRegister x               `thenNat` \ register ->
1947     let
1948         code = registerCode register tmp
1949         reg  = registerName register tmp
1950         off  = ImmInt (-(fromInteger i))
1951     in
1952     returnNat (Amode (AddrRegImm reg off) code)
1953
1954
1955 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1956   | fits13Bits i
1957   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1958     getRegister x               `thenNat` \ register ->
1959     let
1960         code = registerCode register tmp
1961         reg  = registerName register tmp
1962         off  = ImmInt (fromInteger i)
1963     in
1964     returnNat (Amode (AddrRegImm reg off) code)
1965
1966 getAmode (StMachOp MO_Nat_Add [x, y])
1967   = getNewRegNCG PtrRep         `thenNat` \ tmp1 ->
1968     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1969     getRegister x               `thenNat` \ register1 ->
1970     getRegister y               `thenNat` \ register2 ->
1971     let
1972         code1 = registerCode register1 tmp1
1973         reg1  = registerName register1 tmp1
1974         code2 = registerCode register2 tmp2
1975         reg2  = registerName register2 tmp2
1976         code__2 = code1 `appOL` code2
1977     in
1978     returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1979
1980 getAmode leaf
1981   | maybeToBool imm
1982   = getNewRegNCG PtrRep             `thenNat` \ tmp ->
1983     let
1984         code = unitOL (SETHI (HI imm__2) tmp)
1985     in
1986     returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1987   where
1988     imm    = maybeImm leaf
1989     imm__2 = case imm of Just x -> x
1990
1991 getAmode other
1992   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1993     getRegister other           `thenNat` \ register ->
1994     let
1995         code = registerCode register tmp
1996         reg  = registerName register tmp
1997         off  = ImmInt 0
1998     in
1999     returnNat (Amode (AddrRegImm reg off) code)
2000
2001 #endif /* sparc_TARGET_ARCH */
2002
2003 #ifdef powerpc_TARGET_ARCH
2004 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
2005   | fits16Bits (-i)
2006   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
2007     getRegister x               `thenNat` \ register ->
2008     let
2009         code = registerCode register tmp
2010         reg  = registerName register tmp
2011         off  = ImmInt (-(fromInteger i))
2012     in
2013     returnNat (Amode (AddrRegImm reg off) code)
2014
2015
2016 getAmode (StMachOp MO_Nat_Add [x, StInt i])
2017   | fits16Bits i
2018   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
2019     getRegister x               `thenNat` \ register ->
2020     let
2021         code = registerCode register tmp
2022         reg  = registerName register tmp
2023         off  = ImmInt (fromInteger i)
2024     in
2025     returnNat (Amode (AddrRegImm reg off) code)
2026
2027 getAmode leaf
2028   | maybeToBool imm
2029   = getNewRegNCG PtrRep             `thenNat` \ tmp ->
2030     let
2031         code = unitOL (LIS tmp (HA imm__2))
2032     in
2033     returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
2034   where
2035     imm    = maybeImm leaf
2036     imm__2 = case imm of Just x -> x
2037
2038 getAmode other
2039   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
2040     getRegister other           `thenNat` \ register ->
2041     let
2042         code = registerCode register tmp
2043         reg  = registerName register tmp
2044         off  = ImmInt 0
2045     in
2046     returnNat (Amode (AddrRegImm reg off) code)
2047 #endif /* powerpc_TARGET_ARCH */
2048
2049 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2050 \end{code}
2051
2052 %************************************************************************
2053 %*                                                                      *
2054 \subsection{The @CondCode@ type}
2055 %*                                                                      *
2056 %************************************************************************
2057
2058 Condition codes passed up the tree.
2059 \begin{code}
2060 data CondCode = CondCode Bool Cond InstrBlock
2061
2062 condName  (CondCode _ cond _)     = cond
2063 condFloat (CondCode is_float _ _) = is_float
2064 condCode  (CondCode _ _ code)     = code
2065 \end{code}
2066
2067 Set up a condition code for a conditional branch.
2068
2069 \begin{code}
2070 getCondCode :: StixExpr -> NatM CondCode
2071
2072 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2073
2074 #if alpha_TARGET_ARCH
2075 getCondCode = panic "MachCode.getCondCode: not on Alphas"
2076 #endif /* alpha_TARGET_ARCH */
2077
2078 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2079
2080 #if i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH
2081 -- yes, they really do seem to want exactly the same!
2082
2083 getCondCode (StMachOp mop [x, y])
2084   = case mop of
2085       MO_32U_Gt -> condIntCode GTT  x y
2086       MO_32U_Ge -> condIntCode GE   x y
2087       MO_32U_Eq -> condIntCode EQQ  x y
2088       MO_32U_Ne -> condIntCode NE   x y
2089       MO_32U_Lt -> condIntCode LTT  x y
2090       MO_32U_Le -> condIntCode LE   x y
2091
2092       MO_Nat_Eq  -> condIntCode EQQ  x y
2093       MO_Nat_Ne  -> condIntCode NE   x y
2094
2095       MO_NatS_Gt -> condIntCode GTT  x y
2096       MO_NatS_Ge -> condIntCode GE   x y
2097       MO_NatS_Lt -> condIntCode LTT  x y
2098       MO_NatS_Le -> condIntCode LE   x y
2099
2100       MO_NatU_Gt -> condIntCode GU   x y
2101       MO_NatU_Ge -> condIntCode GEU  x y
2102       MO_NatU_Lt -> condIntCode LU   x y
2103       MO_NatU_Le -> condIntCode LEU  x y
2104
2105       MO_Flt_Gt -> condFltCode GTT x y
2106       MO_Flt_Ge -> condFltCode GE  x y
2107       MO_Flt_Eq -> condFltCode EQQ x y
2108       MO_Flt_Ne -> condFltCode NE  x y
2109       MO_Flt_Lt -> condFltCode LTT x y
2110       MO_Flt_Le -> condFltCode LE  x y
2111
2112       MO_Dbl_Gt -> condFltCode GTT x y
2113       MO_Dbl_Ge -> condFltCode GE  x y
2114       MO_Dbl_Eq -> condFltCode EQQ x y
2115       MO_Dbl_Ne -> condFltCode NE  x y
2116       MO_Dbl_Lt -> condFltCode LTT x y
2117       MO_Dbl_Le -> condFltCode LE  x y
2118
2119       other -> pprPanic "getCondCode(x86,sparc,powerpc)" (pprMachOp mop)
2120
2121 getCondCode other =  pprPanic "getCondCode(2)(x86,sparc,powerpc)" (pprStixExpr other)
2122
2123 #endif /* i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH */
2124
2125
2126 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2127 \end{code}
2128
2129 % -----------------
2130
2131 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
2132 passed back up the tree.
2133
2134 \begin{code}
2135 condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
2136
2137 #if alpha_TARGET_ARCH
2138 condIntCode = panic "MachCode.condIntCode: not on Alphas"
2139 condFltCode = panic "MachCode.condFltCode: not on Alphas"
2140 #endif /* alpha_TARGET_ARCH */
2141
2142 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2143 #if i386_TARGET_ARCH
2144
2145 -- memory vs immediate
2146 condIntCode cond (StInd pk x) y
2147   | Just i <- maybeImm y
2148   = getAmode x                  `thenNat` \ amode ->
2149     let
2150         code1 = amodeCode amode
2151         x__2  = amodeAddr amode
2152         sz    = primRepToSize pk
2153         code__2 = code1 `snocOL`
2154                   CMP sz (OpImm i) (OpAddr x__2)
2155     in
2156     returnNat (CondCode False cond code__2)
2157
2158 -- anything vs zero
2159 condIntCode cond x (StInt 0)
2160   = getRegister x               `thenNat` \ register1 ->
2161     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2162     let
2163         code1 = registerCode register1 tmp1
2164         src1  = registerName register1 tmp1
2165         code__2 = code1 `snocOL`
2166                   TEST L (OpReg src1) (OpReg src1)
2167     in
2168     returnNat (CondCode False cond code__2)
2169
2170 -- anything vs immediate
2171 condIntCode cond x y
2172   | Just i <- maybeImm y
2173   = getRegister x               `thenNat` \ register1 ->
2174     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2175     let
2176         code1 = registerCode register1 tmp1
2177         src1  = registerName register1 tmp1
2178         code__2 = code1 `snocOL`
2179                   CMP L (OpImm i) (OpReg src1)
2180     in
2181     returnNat (CondCode False cond code__2)
2182
2183 -- memory vs anything
2184 condIntCode cond (StInd pk x) y
2185   = getAmode x                  `thenNat` \ amode_x ->
2186     getRegister y               `thenNat` \ reg_y ->
2187     getNewRegNCG IntRep         `thenNat` \ tmp ->
2188     let
2189         c_x   = amodeCode amode_x
2190         am_x  = amodeAddr amode_x
2191         c_y   = registerCode reg_y tmp
2192         r_y   = registerName reg_y tmp
2193         sz    = primRepToSize pk
2194
2195         -- optimisation: if there's no code for x, just an amode,
2196         -- use whatever reg y winds up in.  Assumes that c_y doesn't
2197         -- clobber any regs in the amode am_x, which I'm not sure is
2198         -- justified.  The otherwise clause makes the same assumption.
2199         code__2 | isNilOL c_x
2200                 = c_y `snocOL`
2201                   CMP sz (OpReg r_y) (OpAddr am_x)
2202
2203                 | otherwise
2204                 = c_y `snocOL`
2205                   MOV L (OpReg r_y) (OpReg tmp) `appOL`
2206                   c_x `snocOL`
2207                   CMP sz (OpReg tmp) (OpAddr am_x)
2208     in
2209     returnNat (CondCode False cond code__2)
2210
2211 -- anything vs memory
2212 --
2213 condIntCode cond y (StInd pk x)
2214   = getAmode x                  `thenNat` \ amode_x ->
2215     getRegister y               `thenNat` \ reg_y ->
2216     getNewRegNCG IntRep         `thenNat` \ tmp ->
2217     let
2218         c_x   = amodeCode amode_x
2219         am_x  = amodeAddr amode_x
2220         c_y   = registerCode reg_y tmp
2221         r_y   = registerName reg_y tmp
2222         sz    = primRepToSize pk
2223         -- same optimisation and nagging doubts as previous clause
2224         code__2 | isNilOL c_x
2225                 = c_y `snocOL`
2226                   CMP sz (OpAddr am_x) (OpReg r_y)
2227
2228                 | otherwise
2229                 = c_y `snocOL`
2230                   MOV L (OpReg r_y) (OpReg tmp) `appOL`
2231                   c_x `snocOL`
2232                   CMP sz (OpAddr am_x) (OpReg tmp)
2233     in
2234     returnNat (CondCode False cond code__2)
2235
2236 -- anything vs anything
2237 condIntCode cond x y
2238   = getRegister x               `thenNat` \ register1 ->
2239     getRegister y               `thenNat` \ register2 ->
2240     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2241     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
2242     let
2243         code1 = registerCode register1 tmp1
2244         src1  = registerName register1 tmp1
2245         code2 = registerCode register2 tmp2
2246         src2  = registerName register2 tmp2
2247         code__2 = code1 `snocOL`
2248                   MOV L (OpReg src1) (OpReg tmp1) `appOL`
2249                   code2 `snocOL`
2250                   CMP L (OpReg src2) (OpReg tmp1)
2251     in
2252     returnNat (CondCode False cond code__2)
2253
2254 -----------
2255 condFltCode cond x y
2256   = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
2257     getRegister x               `thenNat` \ register1 ->
2258     getRegister y               `thenNat` \ register2 ->
2259     getNewRegNCG (registerRep register1)
2260                                 `thenNat` \ tmp1 ->
2261     getNewRegNCG (registerRep register2)
2262                                 `thenNat` \ tmp2 ->
2263     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
2264     let
2265         code1 = registerCode register1 tmp1
2266         src1  = registerName register1 tmp1
2267
2268         code2 = registerCode register2 tmp2
2269         src2  = registerName register2 tmp2
2270
2271         code__2 | isAny register1
2272                 = code1 `appOL`   -- result in tmp1
2273                   code2 `snocOL`
2274                   GCMP cond tmp1 src2
2275
2276                 | otherwise
2277                 = code1 `snocOL`
2278                   GMOV src1 tmp1 `appOL`
2279                   code2 `snocOL`
2280                   GCMP cond tmp1 src2
2281     in
2282     -- The GCMP insn does the test and sets the zero flag if comparable
2283     -- and true.  Hence we always supply EQQ as the condition to test.
2284     returnNat (CondCode True EQQ code__2)
2285
2286 #endif /* i386_TARGET_ARCH */
2287
2288 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2289
2290 #if sparc_TARGET_ARCH
2291
2292 condIntCode cond x (StInt y)
2293   | fits13Bits y
2294   = getRegister x               `thenNat` \ register ->
2295     getNewRegNCG IntRep         `thenNat` \ tmp ->
2296     let
2297         code = registerCode register tmp
2298         src1 = registerName register tmp
2299         src2 = ImmInt (fromInteger y)
2300         code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
2301     in
2302     returnNat (CondCode False cond code__2)
2303
2304 condIntCode cond x y
2305   = getRegister x               `thenNat` \ register1 ->
2306     getRegister y               `thenNat` \ register2 ->
2307     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2308     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
2309     let
2310         code1 = registerCode register1 tmp1
2311         src1  = registerName register1 tmp1
2312         code2 = registerCode register2 tmp2
2313         src2  = registerName register2 tmp2
2314         code__2 = code1 `appOL` code2 `snocOL`
2315                   SUB False True src1 (RIReg src2) g0
2316     in
2317     returnNat (CondCode False cond code__2)
2318
2319 -----------
2320 condFltCode cond x y
2321   = getRegister x               `thenNat` \ register1 ->
2322     getRegister y               `thenNat` \ register2 ->
2323     getNewRegNCG (registerRep register1)
2324                                 `thenNat` \ tmp1 ->
2325     getNewRegNCG (registerRep register2)
2326                                 `thenNat` \ tmp2 ->
2327     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
2328     let
2329         promote x = FxTOy F DF x tmp
2330
2331         pk1   = registerRep register1
2332         code1 = registerCode register1 tmp1
2333         src1  = registerName register1 tmp1
2334
2335         pk2   = registerRep register2
2336         code2 = registerCode register2 tmp2
2337         src2  = registerName register2 tmp2
2338
2339         code__2 =
2340                 if pk1 == pk2 then
2341                     code1 `appOL` code2 `snocOL`
2342                     FCMP True (primRepToSize pk1) src1 src2
2343                 else if pk1 == FloatRep then
2344                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
2345                     FCMP True DF tmp src2
2346                 else
2347                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
2348                     FCMP True DF src1 tmp
2349     in
2350     returnNat (CondCode True cond code__2)
2351
2352 #endif /* sparc_TARGET_ARCH */
2353
2354 #if powerpc_TARGET_ARCH
2355
2356 condIntCode cond x (StInt y)
2357   | fits16Bits y
2358   = getRegister x               `thenNat` \ register ->
2359     getNewRegNCG IntRep         `thenNat` \ tmp ->
2360     let
2361         code = registerCode register tmp
2362         src1 = registerName register tmp
2363         src2 = ImmInt (fromInteger y)
2364         code__2 = code `snocOL`
2365             (if condUnsigned cond then CMPL else CMP) W src1 (RIImm src2)
2366     in
2367     returnNat (CondCode False cond code__2)
2368
2369 condIntCode cond x y
2370   = getRegister x               `thenNat` \ register1 ->
2371     getRegister y               `thenNat` \ register2 ->
2372     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
2373     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
2374     let
2375         code1 = registerCode register1 tmp1
2376         src1  = registerName register1 tmp1
2377         code2 = registerCode register2 tmp2
2378         src2  = registerName register2 tmp2
2379         code__2 = code1 `appOL` code2 `snocOL`
2380                   (if condUnsigned cond then CMPL else CMP) W src1 (RIReg src2)
2381     in
2382     returnNat (CondCode False cond code__2)
2383
2384 condFltCode cond x y
2385   = getRegister x               `thenNat` \ register1 ->
2386     getRegister y               `thenNat` \ register2 ->
2387     getNewRegNCG (registerRep register1)
2388                                 `thenNat` \ tmp1 ->
2389     getNewRegNCG (registerRep register2)
2390                                 `thenNat` \ tmp2 ->
2391     let
2392         code1 = registerCode register1 tmp1
2393         src1  = registerName register1 tmp1
2394         code2 = registerCode register2 tmp2
2395         src2  = registerName register2 tmp2
2396         code__2 = code1 `appOL` code2 `snocOL`
2397                   FCMP src1 src2
2398     in
2399     returnNat (CondCode False cond code__2)
2400
2401 #endif /* powerpc_TARGET_ARCH */
2402
2403
2404 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2405 \end{code}
2406
2407 %************************************************************************
2408 %*                                                                      *
2409 \subsection{Generating assignments}
2410 %*                                                                      *
2411 %************************************************************************
2412
2413 Assignments are really at the heart of the whole code generation
2414 business.  Almost all top-level nodes of any real importance are
2415 assignments, which correspond to loads, stores, or register transfers.
2416 If we're really lucky, some of the register transfers will go away,
2417 because we can use the destination register to complete the code
2418 generation for the right hand side.  This only fails when the right
2419 hand side is forced into a fixed register (e.g. the result of a call).
2420
2421 \begin{code}
2422 assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2423 assignReg_IntCode :: PrimRep -> StixReg  -> StixExpr -> NatM InstrBlock
2424
2425 assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2426 assignReg_FltCode :: PrimRep -> StixReg  -> StixExpr -> NatM InstrBlock
2427
2428 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2429
2430 #if alpha_TARGET_ARCH
2431
2432 assignIntCode pk (StInd _ dst) src
2433   = getNewRegNCG IntRep             `thenNat` \ tmp ->
2434     getAmode dst                    `thenNat` \ amode ->
2435     getRegister src                 `thenNat` \ register ->
2436     let
2437         code1   = amodeCode amode []
2438         dst__2  = amodeAddr amode
2439         code2   = registerCode register tmp []
2440         src__2  = registerName register tmp
2441         sz      = primRepToSize pk
2442         code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2443     in
2444     returnNat code__2
2445
2446 assignIntCode pk dst src
2447   = getRegister dst                         `thenNat` \ register1 ->
2448     getRegister src                         `thenNat` \ register2 ->
2449     let
2450         dst__2  = registerName register1 zeroh
2451         code    = registerCode register2 dst__2
2452         src__2  = registerName register2 dst__2
2453         code__2 = if isFixed register2
2454                   then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2455                   else code
2456     in
2457     returnNat code__2
2458
2459 #endif /* alpha_TARGET_ARCH */
2460
2461 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2462
2463 #if i386_TARGET_ARCH
2464
2465 -- non-FP assignment to memory
2466 assignMem_IntCode pk addr src
2467   = getAmode addr               `thenNat` \ amode ->
2468     get_op_RI src               `thenNat` \ (codesrc, opsrc) ->
2469     getNewRegNCG PtrRep         `thenNat` \ tmp ->
2470     let
2471         -- In general, if the address computation for dst may require
2472         -- some insns preceding the addressing mode itself.  So there's
2473         -- no guarantee that the code for dst and the code for src won't
2474         -- write the same register.  This means either the address or
2475         -- the value needs to be copied into a temporary.  We detect the
2476         -- common case where the amode has no code, and elide the copy.
2477         codea   = amodeCode amode
2478         dst__a  = amodeAddr amode
2479
2480         code    | isNilOL codea
2481                 = codesrc `snocOL`
2482                   MOV (primRepToSize pk) opsrc (OpAddr dst__a)
2483                 | otherwise
2484                 = codea `snocOL`
2485                   LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
2486                   codesrc `snocOL`
2487                   MOV (primRepToSize pk) opsrc
2488                       (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
2489     in
2490     returnNat code
2491   where
2492     get_op_RI
2493         :: StixExpr
2494         -> NatM (InstrBlock,Operand)    -- code, operator
2495
2496     get_op_RI op
2497       | Just x <- maybeImm op
2498       = returnNat (nilOL, OpImm x)
2499
2500     get_op_RI op
2501       = getRegister op                  `thenNat` \ register ->
2502         getNewRegNCG (registerRep register)
2503                                         `thenNat` \ tmp ->
2504         let code = registerCode register tmp
2505             reg  = registerName register tmp
2506         in
2507         returnNat (code, OpReg reg)
2508
2509 -- Assign; dst is a reg, rhs is mem
2510 assignReg_IntCode pk reg (StInd pks src)
2511   = getNewRegNCG PtrRep             `thenNat` \ tmp ->
2512     getAmode src                    `thenNat` \ amode ->
2513     getRegisterReg reg              `thenNat` \ reg_dst ->
2514     let
2515         c_addr  = amodeCode amode
2516         am_addr = amodeAddr amode
2517         r_dst = registerName reg_dst tmp
2518         szs   = primRepToSize pks
2519         opc   = case szs of
2520             B  -> MOVSxL B
2521             Bu -> MOVZxL Bu
2522             W  -> MOVSxL W
2523             Wu -> MOVZxL Wu
2524             L  -> MOV L
2525             Lu -> MOV L
2526
2527         code  = c_addr `snocOL`
2528                 opc (OpAddr am_addr) (OpReg r_dst)
2529     in
2530     returnNat code
2531
2532 -- dst is a reg, but src could be anything
2533 assignReg_IntCode pk reg src
2534   = getRegisterReg reg              `thenNat` \ registerd ->
2535     getRegister src                 `thenNat` \ registers ->
2536     getNewRegNCG IntRep             `thenNat` \ tmp ->
2537     let
2538         r_dst = registerName registerd tmp
2539         r_src = registerName registers r_dst
2540         c_src = registerCode registers r_dst
2541
2542         code = c_src `snocOL`
2543                MOV L (OpReg r_src) (OpReg r_dst)
2544     in
2545     returnNat code
2546
2547 #endif /* i386_TARGET_ARCH */
2548
2549 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2550
2551 #if sparc_TARGET_ARCH
2552
2553 assignMem_IntCode pk addr src
2554   = getNewRegNCG IntRep                     `thenNat` \ tmp ->
2555     getAmode addr                           `thenNat` \ amode ->
2556     getRegister src                         `thenNat` \ register ->
2557     let
2558         code1   = amodeCode amode
2559         dst__2  = amodeAddr amode
2560         code2   = registerCode register tmp
2561         src__2  = registerName register tmp
2562         sz      = primRepToSize pk
2563         code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2564     in
2565     returnNat code__2
2566
2567 assignReg_IntCode pk reg src
2568   = getRegister src                         `thenNat` \ register2 ->
2569     getRegisterReg reg                      `thenNat` \ register1 ->
2570     getNewRegNCG IntRep                     `thenNat` \ tmp ->
2571     let
2572         dst__2  = registerName register1 tmp
2573         code    = registerCode register2 dst__2
2574         src__2  = registerName register2 dst__2
2575         code__2 = if isFixed register2
2576                   then code `snocOL` OR False g0 (RIReg src__2) dst__2
2577                   else code
2578     in
2579     returnNat code__2
2580
2581 #endif /* sparc_TARGET_ARCH */
2582
2583 #if powerpc_TARGET_ARCH
2584
2585 assignMem_IntCode pk addr src
2586   = getNewRegNCG IntRep                     `thenNat` \ tmp ->
2587     getAmode addr                           `thenNat` \ amode ->
2588     getRegister src                         `thenNat` \ register ->
2589     let
2590         code1   = amodeCode amode
2591         dst__2  = amodeAddr amode
2592         code2   = registerCode register tmp
2593         src__2  = registerName register tmp
2594         sz      = primRepToSize pk
2595         code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2596     in
2597     returnNat code__2
2598
2599 assignReg_IntCode pk reg src
2600   = getRegister src                         `thenNat` \ register2 ->
2601     getRegisterReg reg                      `thenNat` \ register1 ->
2602     let
2603         dst__2  = registerName register1 (panic "###PPC where are we assigning this int???")
2604         code    = registerCode register2 dst__2
2605         src__2  = registerName register2 dst__2
2606         code__2 = if isFixed register2
2607                   then code `snocOL` MR dst__2 src__2
2608                   else code
2609     in
2610     returnNat code__2
2611
2612 #endif /* powerpc_TARGET_ARCH */
2613
2614 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2615 \end{code}
2616
2617 % --------------------------------
2618 Floating-point assignments:
2619 % --------------------------------
2620
2621 \begin{code}
2622 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2623 #if alpha_TARGET_ARCH
2624
2625 assignFltCode pk (StInd _ dst) src
2626   = getNewRegNCG pk                 `thenNat` \ tmp ->
2627     getAmode dst                    `thenNat` \ amode ->
2628     getRegister src                         `thenNat` \ register ->
2629     let
2630         code1   = amodeCode amode []
2631         dst__2  = amodeAddr amode
2632         code2   = registerCode register tmp []
2633         src__2  = registerName register tmp
2634         sz      = primRepToSize pk
2635         code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2636     in
2637     returnNat code__2
2638
2639 assignFltCode pk dst src
2640   = getRegister dst                         `thenNat` \ register1 ->
2641     getRegister src                         `thenNat` \ register2 ->
2642     let
2643         dst__2  = registerName register1 zeroh
2644         code    = registerCode register2 dst__2
2645         src__2  = registerName register2 dst__2
2646         code__2 = if isFixed register2
2647                   then code . mkSeqInstr (FMOV src__2 dst__2)
2648                   else code
2649     in
2650     returnNat code__2
2651
2652 #endif /* alpha_TARGET_ARCH */
2653
2654 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2655
2656 #if i386_TARGET_ARCH
2657
2658 -- Floating point assignment to memory
2659 assignMem_FltCode pk addr src
2660    = getRegister src      `thenNat`  \ reg_src  ->
2661      getRegister addr     `thenNat`  \ reg_addr ->
2662      getNewRegNCG pk      `thenNat`  \ tmp_src  ->
2663      getNewRegNCG PtrRep  `thenNat`  \ tmp_addr ->
2664      let r_src  = registerName reg_src tmp_src
2665          c_src  = registerCode reg_src tmp_src
2666          r_addr = registerName reg_addr tmp_addr
2667          c_addr = registerCode reg_addr tmp_addr
2668          sz     = primRepToSize pk
2669
2670          code = c_src  `appOL`
2671                 -- no need to preserve r_src across the addr computation,
2672                 -- since r_src must be a float reg
2673                 -- whilst r_addr is an int reg
2674                 c_addr `snocOL`
2675                 GST sz r_src
2676                        (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2677      in
2678      returnNat code
2679
2680 -- Floating point assignment to a register/temporary
2681 assignReg_FltCode pk reg src
2682   = getRegisterReg reg              `thenNat` \ reg_dst ->
2683     getRegister src                 `thenNat` \ reg_src ->
2684     getNewRegNCG pk                 `thenNat` \ tmp ->
2685     let
2686         r_dst = registerName reg_dst tmp
2687         r_src = registerName reg_src r_dst
2688         c_src = registerCode reg_src r_dst
2689
2690         code = if   isFixed reg_src
2691                then c_src `snocOL` GMOV r_src r_dst
2692                else c_src
2693     in
2694     returnNat code
2695
2696
2697 #endif /* i386_TARGET_ARCH */
2698
2699 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2700
2701 #if sparc_TARGET_ARCH
2702
2703 -- Floating point assignment to memory
2704 assignMem_FltCode pk addr src
2705   = getNewRegNCG pk                 `thenNat` \ tmp1 ->
2706     getAmode addr                   `thenNat` \ amode ->
2707     getRegister src                 `thenNat` \ register ->
2708     let
2709         sz      = primRepToSize pk
2710         dst__2  = amodeAddr amode
2711
2712         code1   = amodeCode amode
2713         code2   = registerCode register tmp1
2714
2715         src__2  = registerName register tmp1
2716         pk__2   = registerRep register
2717         sz__2   = primRepToSize pk__2
2718
2719         code__2 = code1 `appOL` code2 `appOL`
2720             if   pk == pk__2
2721             then unitOL (ST sz src__2 dst__2)
2722             else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2723     in
2724     returnNat code__2
2725
2726 -- Floating point assignment to a register/temporary
2727 -- Why is this so bizarrely ugly?
2728 assignReg_FltCode pk reg src
2729   = getRegisterReg reg                      `thenNat` \ register1 ->
2730     getRegister src                         `thenNat` \ register2 ->
2731     let
2732         pk__2   = registerRep register2
2733         sz__2   = primRepToSize pk__2
2734     in
2735     getNewRegNCG pk__2                      `thenNat` \ tmp ->
2736     let
2737         sz      = primRepToSize pk
2738         dst__2  = registerName register1 g0    -- must be Fixed
2739         reg__2  = if pk /= pk__2 then tmp else dst__2
2740         code    = registerCode register2 reg__2
2741         src__2  = registerName register2 reg__2
2742         code__2 =
2743                 if pk /= pk__2 then
2744                      code `snocOL` FxTOy sz__2 sz src__2 dst__2
2745                 else if isFixed register2 then
2746                      code `snocOL` FMOV sz src__2 dst__2
2747                 else
2748                      code
2749     in
2750     returnNat code__2
2751
2752 #endif /* sparc_TARGET_ARCH */
2753
2754 #if powerpc_TARGET_ARCH
2755
2756 -- Floating point assignment to memory
2757 assignMem_FltCode pk addr src
2758   = getNewRegNCG pk                 `thenNat` \ tmp1 ->
2759     getAmode addr                   `thenNat` \ amode ->
2760     getRegister src                 `thenNat` \ register ->
2761     let
2762         sz      = primRepToSize pk
2763         dst__2  = amodeAddr amode
2764
2765         code1   = amodeCode amode
2766         code2   = registerCode register tmp1
2767
2768         src__2  = registerName register tmp1
2769         pk__2   = registerRep register
2770
2771         code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2772     in
2773     returnNat code__2
2774
2775 -- Floating point assignment to a register/temporary
2776 assignReg_FltCode pk reg src
2777   = getRegisterReg reg              `thenNat` \ reg_dst ->
2778     getRegister src                 `thenNat` \ reg_src ->
2779     getNewRegNCG pk                 `thenNat` \ tmp ->
2780     let
2781         r_dst = registerName reg_dst tmp
2782         r_src = registerName reg_src r_dst
2783         c_src = registerCode reg_src r_dst
2784
2785         code = if   isFixed reg_src
2786                then c_src `snocOL` MR r_dst r_src
2787                else c_src
2788     in
2789     returnNat code
2790 #endif /* powerpc_TARGET_ARCH */
2791
2792 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2793 \end{code}
2794
2795 %************************************************************************
2796 %*                                                                      *
2797 \subsection{Generating an unconditional branch}
2798 %*                                                                      *
2799 %************************************************************************
2800
2801 We accept two types of targets: an immediate CLabel or a tree that
2802 gets evaluated into a register.  Any CLabels which are AsmTemporaries
2803 are assumed to be in the local block of code, close enough for a
2804 branch instruction.  Other CLabels are assumed to be far away.
2805
2806 (If applicable) Do not fill the delay slots here; you will confuse the
2807 register allocator.
2808
2809 \begin{code}
2810 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2811
2812 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2813
2814 #if alpha_TARGET_ARCH
2815
2816 genJump (StCLbl lbl)
2817   | isAsmTemp lbl = returnInstr (BR target)
2818   | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2819   where
2820     target = ImmCLbl lbl
2821
2822 genJump tree
2823   = getRegister tree                `thenNat` \ register ->
2824     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2825     let
2826         dst    = registerName register pv
2827         code   = registerCode register pv
2828         target = registerName register pv
2829     in
2830     if isFixed register then
2831         returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2832     else
2833     returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2834
2835 #endif /* alpha_TARGET_ARCH */
2836
2837 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2838
2839 #if i386_TARGET_ARCH
2840
2841 genJump dsts (StInd pk mem)
2842   = getAmode mem                    `thenNat` \ amode ->
2843     let
2844         code   = amodeCode amode
2845         target = amodeAddr amode
2846     in
2847     returnNat (code `snocOL` JMP dsts (OpAddr target))
2848
2849 genJump dsts tree
2850   | maybeToBool imm
2851   = returnNat (unitOL (JMP dsts (OpImm target)))
2852
2853   | otherwise
2854   = getRegister tree                `thenNat` \ register ->
2855     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2856     let
2857         code   = registerCode register tmp
2858         target = registerName register tmp
2859     in
2860     returnNat (code `snocOL` JMP dsts (OpReg target))
2861   where
2862     imm    = maybeImm tree
2863     target = case imm of Just x -> x
2864
2865 #endif /* i386_TARGET_ARCH */
2866
2867 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2868
2869 #if sparc_TARGET_ARCH
2870
2871 genJump dsts (StCLbl lbl)
2872   | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2873   | isAsmTemp lbl    = returnNat (toOL [BI ALWAYS False target, NOP])
2874   | otherwise        = returnNat (toOL [CALL (Left target) 0 True, NOP])
2875   where
2876     target = ImmCLbl lbl
2877
2878 genJump dsts tree
2879   = getRegister tree                        `thenNat` \ register ->
2880     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2881     let
2882         code   = registerCode register tmp
2883         target = registerName register tmp
2884     in
2885     returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2886
2887 #endif /* sparc_TARGET_ARCH */
2888
2889 #if powerpc_TARGET_ARCH
2890 genJump dsts (StCLbl lbl)
2891   | hasDestInfo dsts = panic "genJump(powerpc): CLbl and dsts"
2892   | otherwise        = returnNat (toOL [BCC ALWAYS lbl])
2893
2894 genJump dsts tree
2895   = getRegister tree                        `thenNat` \ register ->
2896     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2897     let
2898         code   = registerCode register tmp
2899         target = registerName register tmp
2900     in
2901     returnNat (code `snocOL` MTCTR target `snocOL` BCTR dsts)
2902 #endif /* sparc_TARGET_ARCH */
2903
2904 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2905
2906 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2907 \end{code}
2908
2909 %************************************************************************
2910 %*                                                                      *
2911 \subsection{Conditional jumps}
2912 %*                                                                      *
2913 %************************************************************************
2914
2915 Conditional jumps are always to local labels, so we can use branch
2916 instructions.  We peek at the arguments to decide what kind of
2917 comparison to do.
2918
2919 ALPHA: For comparisons with 0, we're laughing, because we can just do
2920 the desired conditional branch.
2921
2922 I386: First, we have to ensure that the condition
2923 codes are set according to the supplied comparison operation.
2924
2925 SPARC: First, we have to ensure that the condition codes are set
2926 according to the supplied comparison operation.  We generate slightly
2927 different code for floating point comparisons, because a floating
2928 point operation cannot directly precede a @BF@.  We assume the worst
2929 and fill that slot with a @NOP@.
2930
2931 SPARC: Do not fill the delay slots here; you will confuse the register
2932 allocator.
2933
2934 \begin{code}
2935 genCondJump
2936     :: CLabel       -- the branch target
2937     -> StixExpr     -- the condition on which to branch
2938     -> NatM InstrBlock
2939
2940 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2941
2942 #if alpha_TARGET_ARCH
2943
2944 genCondJump lbl (StPrim op [x, StInt 0])
2945   = getRegister x                           `thenNat` \ register ->
2946     getNewRegNCG (registerRep register)
2947                                     `thenNat` \ tmp ->
2948     let
2949         code   = registerCode register tmp
2950         value  = registerName register tmp
2951         pk     = registerRep register
2952         target = ImmCLbl lbl
2953     in
2954     returnSeq code [BI (cmpOp op) value target]
2955   where
2956     cmpOp CharGtOp = GTT
2957     cmpOp CharGeOp = GE
2958     cmpOp CharEqOp = EQQ
2959     cmpOp CharNeOp = NE
2960     cmpOp CharLtOp = LTT
2961     cmpOp CharLeOp = LE
2962     cmpOp IntGtOp = GTT
2963     cmpOp IntGeOp = GE
2964     cmpOp IntEqOp = EQQ
2965     cmpOp IntNeOp = NE
2966     cmpOp IntLtOp = LTT
2967     cmpOp IntLeOp = LE
2968     cmpOp WordGtOp = NE
2969     cmpOp WordGeOp = ALWAYS
2970     cmpOp WordEqOp = EQQ
2971     cmpOp WordNeOp = NE
2972     cmpOp WordLtOp = NEVER
2973     cmpOp WordLeOp = EQQ
2974     cmpOp AddrGtOp = NE
2975     cmpOp AddrGeOp = ALWAYS
2976     cmpOp AddrEqOp = EQQ
2977     cmpOp AddrNeOp = NE
2978     cmpOp AddrLtOp = NEVER
2979     cmpOp AddrLeOp = EQQ
2980
2981 genCondJump lbl (StPrim op [x, StDouble 0.0])
2982   = getRegister x                           `thenNat` \ register ->
2983     getNewRegNCG (registerRep register)
2984                                     `thenNat` \ tmp ->
2985     let
2986         code   = registerCode register tmp
2987         value  = registerName register tmp
2988         pk     = registerRep register
2989         target = ImmCLbl lbl
2990     in
2991     returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2992   where
2993     cmpOp FloatGtOp = GTT
2994     cmpOp FloatGeOp = GE
2995     cmpOp FloatEqOp = EQQ
2996     cmpOp FloatNeOp = NE
2997     cmpOp FloatLtOp = LTT
2998     cmpOp FloatLeOp = LE
2999     cmpOp DoubleGtOp = GTT
3000     cmpOp DoubleGeOp = GE
3001     cmpOp DoubleEqOp = EQQ
3002     cmpOp DoubleNeOp = NE
3003     cmpOp DoubleLtOp = LTT
3004     cmpOp DoubleLeOp = LE
3005
3006 genCondJump lbl (StPrim op [x, y])
3007   | fltCmpOp op
3008   = trivialFCode pr instr x y       `thenNat` \ register ->
3009     getNewRegNCG DoubleRep          `thenNat` \ tmp ->
3010     let
3011         code   = registerCode register tmp
3012         result = registerName register tmp
3013         target = ImmCLbl lbl
3014     in
3015     returnNat (code . mkSeqInstr (BF cond result target))
3016   where
3017     pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
3018
3019     fltCmpOp op = case op of
3020         FloatGtOp -> True
3021         FloatGeOp -> True
3022         FloatEqOp -> True
3023         FloatNeOp -> True
3024         FloatLtOp -> True
3025         FloatLeOp -> True
3026         DoubleGtOp -> True
3027         DoubleGeOp -> True
3028         DoubleEqOp -> True
3029         DoubleNeOp -> True
3030         DoubleLtOp -> True
3031         DoubleLeOp -> True
3032         _ -> False
3033     (instr, cond) = case op of
3034         FloatGtOp -> (FCMP TF LE, EQQ)
3035         FloatGeOp -> (FCMP TF LTT, EQQ)
3036         FloatEqOp -> (FCMP TF EQQ, NE)
3037         FloatNeOp -> (FCMP TF EQQ, EQQ)
3038         FloatLtOp -> (FCMP TF LTT, NE)
3039         FloatLeOp -> (FCMP TF LE, NE)
3040         DoubleGtOp -> (FCMP TF LE, EQQ)
3041         DoubleGeOp -> (FCMP TF LTT, EQQ)
3042         DoubleEqOp -> (FCMP TF EQQ, NE)
3043         DoubleNeOp -> (FCMP TF EQQ, EQQ)
3044         DoubleLtOp -> (FCMP TF LTT, NE)
3045         DoubleLeOp -> (FCMP TF LE, NE)
3046
3047 genCondJump lbl (StPrim op [x, y])
3048   = trivialCode instr x y           `thenNat` \ register ->
3049     getNewRegNCG IntRep             `thenNat` \ tmp ->
3050     let
3051         code   = registerCode register tmp
3052         result = registerName register tmp
3053         target = ImmCLbl lbl
3054     in
3055     returnNat (code . mkSeqInstr (BI cond result target))
3056   where
3057     (instr, cond) = case op of
3058         CharGtOp -> (CMP LE, EQQ)
3059         CharGeOp -> (CMP LTT, EQQ)
3060         CharEqOp -> (CMP EQQ, NE)
3061         CharNeOp -> (CMP EQQ, EQQ)
3062         CharLtOp -> (CMP LTT, NE)
3063         CharLeOp -> (CMP LE, NE)
3064         IntGtOp -> (CMP LE, EQQ)
3065         IntGeOp -> (CMP LTT, EQQ)
3066         IntEqOp -> (CMP EQQ, NE)
3067         IntNeOp -> (CMP EQQ, EQQ)
3068         IntLtOp -> (CMP LTT, NE)
3069         IntLeOp -> (CMP LE, NE)
3070         WordGtOp -> (CMP ULE, EQQ)
3071         WordGeOp -> (CMP ULT, EQQ)
3072         WordEqOp -> (CMP EQQ, NE)
3073         WordNeOp -> (CMP EQQ, EQQ)
3074         WordLtOp -> (CMP ULT, NE)
3075         WordLeOp -> (CMP ULE, NE)
3076         AddrGtOp -> (CMP ULE, EQQ)
3077         AddrGeOp -> (CMP ULT, EQQ)
3078         AddrEqOp -> (CMP EQQ, NE)
3079         AddrNeOp -> (CMP EQQ, EQQ)
3080         AddrLtOp -> (CMP ULT, NE)
3081         AddrLeOp -> (CMP ULE, NE)
3082
3083 #endif /* alpha_TARGET_ARCH */
3084
3085 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3086
3087 #if i386_TARGET_ARCH
3088
3089 genCondJump lbl bool
3090   = getCondCode bool                `thenNat` \ condition ->
3091     let
3092         code   = condCode condition
3093         cond   = condName condition
3094     in
3095     returnNat (code `snocOL` JXX cond lbl)
3096
3097 #endif /* i386_TARGET_ARCH */
3098
3099 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3100
3101 #if sparc_TARGET_ARCH
3102
3103 genCondJump lbl bool
3104   = getCondCode bool                `thenNat` \ condition ->
3105     let
3106         code   = condCode condition
3107         cond   = condName condition
3108         target = ImmCLbl lbl
3109     in
3110     returnNat (
3111        code `appOL`
3112        toOL (
3113          if   condFloat condition
3114          then [NOP, BF cond False target, NOP]
3115          else [BI cond False target, NOP]
3116        )
3117     )
3118
3119 #endif /* sparc_TARGET_ARCH */
3120
3121 #if powerpc_TARGET_ARCH
3122
3123 genCondJump lbl bool
3124   = getCondCode bool                `thenNat` \ condition ->
3125     let
3126         code   = condCode condition
3127         cond   = condName condition
3128         target = ImmCLbl lbl
3129     in
3130     returnNat (
3131        code `snocOL` BCC cond lbl    )
3132
3133 #endif /* powerpc_TARGET_ARCH */
3134
3135 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3136
3137 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3138 \end{code}
3139
3140 %************************************************************************
3141 %*                                                                      *
3142 \subsection{Generating C calls}
3143 %*                                                                      *
3144 %************************************************************************
3145
3146 Now the biggest nightmare---calls.  Most of the nastiness is buried in
3147 @get_arg@, which moves the arguments to the correct registers/stack
3148 locations.  Apart from that, the code is easy.
3149
3150 (If applicable) Do not fill the delay slots here; you will confuse the
3151 register allocator.
3152
3153 \begin{code}
3154 genCCall
3155     :: (Either FastString StixExpr)     -- function to call
3156     -> CCallConv
3157     -> PrimRep          -- type of the result
3158     -> [StixExpr]       -- arguments (of mixed type)
3159     -> NatM InstrBlock
3160
3161 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3162
3163 #if alpha_TARGET_ARCH
3164
3165 genCCall fn cconv kind args
3166   = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
3167                           `thenNat` \ ((unused,_), argCode) ->
3168     let
3169         nRegs = length allArgRegs - length unused
3170         code = asmSeqThen (map ($ []) argCode)
3171     in
3172         returnSeq code [
3173             LDA pv (AddrImm (ImmLab (ptext fn))),
3174             JSR ra (AddrReg pv) nRegs,
3175             LDGP gp (AddrReg ra)]
3176   where
3177     ------------------------
3178     {-  Try to get a value into a specific register (or registers) for
3179         a call.  The first 6 arguments go into the appropriate
3180         argument register (separate registers for integer and floating
3181         point arguments, but used in lock-step), and the remaining
3182         arguments are dumped to the stack, beginning at 0(sp).  Our
3183         first argument is a pair of the list of remaining argument
3184         registers to be assigned for this call and the next stack
3185         offset to use for overflowing arguments.  This way,
3186         @get_Arg@ can be applied to all of a call's arguments using
3187         @mapAccumLNat@.
3188     -}
3189     get_arg
3190         :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
3191         -> StixTree             -- Current argument
3192         -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
3193
3194     -- We have to use up all of our argument registers first...
3195
3196     get_arg ((iDst,fDst):dsts, offset) arg
3197       = getRegister arg                     `thenNat` \ register ->
3198         let
3199             reg  = if isFloatingRep pk then fDst else iDst
3200             code = registerCode register reg
3201             src  = registerName register reg
3202             pk   = registerRep register
3203         in
3204         returnNat (
3205             if isFloatingRep pk then
3206                 ((dsts, offset), if isFixed register then
3207                     code . mkSeqInstr (FMOV src fDst)
3208                     else code)
3209             else
3210                 ((dsts, offset), if isFixed register then
3211                     code . mkSeqInstr (OR src (RIReg src) iDst)
3212                     else code))
3213
3214     -- Once we have run out of argument registers, we move to the
3215     -- stack...
3216
3217     get_arg ([], offset) arg
3218       = getRegister arg                 `thenNat` \ register ->
3219         getNewRegNCG (registerRep register)
3220                                         `thenNat` \ tmp ->
3221         let
3222             code = registerCode register tmp
3223             src  = registerName register tmp
3224             pk   = registerRep register
3225             sz   = primRepToSize pk
3226         in
3227         returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
3228
3229 #endif /* alpha_TARGET_ARCH */
3230
3231 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3232
3233 #if i386_TARGET_ARCH
3234
3235 genCCall fn cconv ret_rep args
3236   = mapNat push_arg
3237            (reverse args)       `thenNat` \ sizes_n_codes ->
3238     getDeltaNat                 `thenNat` \ delta ->
3239     let (sizes, push_codes) = unzip sizes_n_codes
3240         tot_arg_size        = sum sizes
3241     in
3242     -- deal with static vs dynamic call targets
3243     (case fn of
3244         Left t_static
3245            -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
3246         Right dyn
3247            -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
3248               ASSERT(case dyn_rep of { L -> True; _ -> False})
3249               returnNat (dyn_c `snocOL` CALL (Right dyn_r))
3250     )
3251                                 `thenNat` \ callinsns ->
3252     let push_code = concatOL push_codes
3253         call = callinsns `appOL`
3254                toOL (
3255                         -- Deallocate parameters after call for ccall;
3256                         -- but not for stdcall (callee does it)
3257                   (if cconv == StdCallConv then [] else
3258                    [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
3259                   ++
3260                   [DELTA (delta + tot_arg_size)]
3261                )
3262     in
3263     setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
3264     returnNat (push_code `appOL` call)
3265
3266   where
3267     -- function names that begin with '.' are assumed to be special
3268     -- internally generated names like '.mul,' which don't get an
3269     -- underscore prefix
3270     -- ToDo:needed (WDP 96/03) ???
3271     fn_u  = unpackFS (unLeft fn)
3272     fn__2 tot_arg_size
3273        | head fn_u == '.'
3274        = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
3275        | otherwise      -- General case
3276        = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
3277
3278     stdcallsize tot_arg_size
3279        | cconv == StdCallConv = '@':show tot_arg_size
3280        | otherwise            = ""
3281
3282     arg_size DF = 8
3283     arg_size F  = 4
3284     arg_size _  = 4
3285
3286     ------------
3287     push_arg :: StixExpr{-current argument-}
3288                     -> NatM (Int, InstrBlock)  -- argsz, code
3289
3290     push_arg arg
3291       | is64BitRep arg_rep
3292       = iselExpr64 arg                  `thenNat` \ (ChildCode64 code vr_lo) ->
3293         getDeltaNat                     `thenNat` \ delta ->
3294         setDeltaNat (delta - 8)         `thenNat` \ _ ->
3295         let r_lo = VirtualRegI vr_lo
3296             r_hi = getHiVRegFromLo r_lo
3297         in  returnNat (8,
3298                        code `appOL`
3299                        toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
3300                              PUSH L (OpReg r_lo), DELTA (delta - 8)]
3301             )
3302       | otherwise
3303       = get_op arg                      `thenNat` \ (code, reg, sz) ->
3304         getDeltaNat                     `thenNat` \ delta ->
3305         arg_size sz                     `bind`    \ size ->
3306         setDeltaNat (delta-size)        `thenNat` \ _ ->
3307         if   (case sz of DF -> True; F -> True; _ -> False)
3308         then returnNat (size,
3309                         code `appOL`
3310                         toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
3311                               DELTA (delta-size),
3312                               GST sz reg (AddrBaseIndex (Just esp)
3313                                                         Nothing
3314                                                         (ImmInt 0))]
3315                        )
3316         else returnNat (size,
3317                         code `snocOL`
3318                         PUSH L (OpReg reg) `snocOL`
3319                         DELTA (delta-size)
3320                        )
3321       where
3322          arg_rep = repOfStixExpr arg
3323
3324     ------------
3325     get_op
3326         :: StixExpr
3327         -> NatM (InstrBlock, Reg, Size) -- code, reg, size
3328
3329     get_op op
3330       = getRegister op          `thenNat` \ register ->
3331         getNewRegNCG (registerRep register)
3332                                 `thenNat` \ tmp ->
3333         let
3334             code = registerCode register tmp
3335             reg  = registerName register tmp
3336             pk   = registerRep  register
3337             sz   = primRepToSize pk
3338         in
3339         returnNat (code, reg, sz)
3340
3341 #endif /* i386_TARGET_ARCH */
3342
3343 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3344
3345 #if sparc_TARGET_ARCH
3346 {-
3347    The SPARC calling convention is an absolute
3348    nightmare.  The first 6x32 bits of arguments are mapped into
3349    %o0 through %o5, and the remaining arguments are dumped to the
3350    stack, beginning at [%sp+92].  (Note that %o6 == %sp.)
3351
3352    If we have to put args on the stack, move %o6==%sp down by
3353    the number of words to go on the stack, to ensure there's enough space.
3354
3355    According to Fraser and Hanson's lcc book, page 478, fig 17.2,
3356    16 words above the stack pointer is a word for the address of
3357    a structure return value.  I use this as a temporary location
3358    for moving values from float to int regs.  Certainly it isn't
3359    safe to put anything in the 16 words starting at %sp, since
3360    this area can get trashed at any time due to window overflows
3361    caused by signal handlers.
3362
3363    A final complication (if the above isn't enough) is that
3364    we can't blithely calculate the arguments one by one into
3365    %o0 .. %o5.  Consider the following nested calls:
3366
3367        fff a (fff b c)
3368
3369    Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately
3370    the inner call will itself use %o0, which trashes the value put there
3371    in preparation for the outer call.  Upshot: we need to calculate the
3372    args into temporary regs, and move those to arg regs or onto the
3373    stack only immediately prior to the call proper.  Sigh.
3374 -}
3375
3376 genCCall fn cconv kind args
3377   = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
3378     let
3379         (argcodes, vregss) = unzip argcode_and_vregs
3380         n_argRegs          = length allArgRegs
3381         n_argRegs_used     = min (length vregs) n_argRegs
3382         vregs              = concat vregss
3383     in
3384     -- deal with static vs dynamic call targets
3385     (case fn of
3386         Left t_static
3387            -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
3388         Right dyn
3389            -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
3390               returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
3391     )
3392                                 `thenNat` \ callinsns ->
3393     let
3394         argcode = concatOL argcodes
3395         (move_sp_down, move_sp_up)
3396            = let diff = length vregs - n_argRegs
3397                  nn   = if odd diff then diff + 1 else diff -- keep 8-byte alignment
3398              in  if   nn <= 0
3399                  then (nilOL, nilOL)
3400                  else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
3401         transfer_code
3402            = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
3403     in
3404         returnNat (argcode       `appOL`
3405                    move_sp_down  `appOL`
3406                    transfer_code `appOL`
3407                    callinsns     `appOL`
3408                    unitOL NOP    `appOL`
3409                    move_sp_up)
3410   where
3411      -- function names that begin with '.' are assumed to be special
3412      -- internally generated names like '.mul,' which don't get an
3413      -- underscore prefix
3414      -- ToDo:needed (WDP 96/03) ???
3415      fn_static = unLeft fn
3416      fn__2 = case (headFS fn_static) of
3417                 '.' -> ImmLit (ftext fn_static)
3418                 _   -> ImmLab False (ftext fn_static)
3419
3420      -- move args from the integer vregs into which they have been
3421      -- marshalled, into %o0 .. %o5, and the rest onto the stack.
3422      move_final :: [Reg] -> [Reg] -> Int -> [Instr]
3423
3424      move_final [] _ offset          -- all args done
3425         = []
3426
3427      move_final (v:vs) [] offset     -- out of aregs; move to stack
3428         = ST W v (spRel offset)
3429           : move_final vs [] (offset+1)
3430
3431      move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
3432         = OR False g0 (RIReg v) a
3433           : move_final vs az offset
3434
3435      -- generate code to calculate an argument, and move it into one
3436      -- or two integer vregs.
3437      arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
3438      arg_to_int_vregs arg
3439         | is64BitRep (repOfStixExpr arg)
3440         = iselExpr64 arg                `thenNat` \ (ChildCode64 code vr_lo) ->
3441           let r_lo = VirtualRegI vr_lo
3442               r_hi = getHiVRegFromLo r_lo
3443           in  returnNat (code, [r_hi, r_lo])
3444         | otherwise
3445         = getRegister arg                     `thenNat` \ register ->
3446           getNewRegNCG (registerRep register) `thenNat` \ tmp ->
3447           let code = registerCode register tmp
3448               src  = registerName register tmp
3449               pk   = registerRep register
3450           in
3451           -- the value is in src.  Get it into 1 or 2 int vregs.
3452           case pk of
3453              DoubleRep ->
3454                 getNewRegNCG WordRep  `thenNat` \ v1 ->
3455                 getNewRegNCG WordRep  `thenNat` \ v2 ->
3456                 returnNat (
3457                    code                          `snocOL`
3458                    FMOV DF src f0                `snocOL`
3459                    ST   F  f0 (spRel 16)         `snocOL`
3460                    LD   W  (spRel 16) v1         `snocOL`
3461                    ST   F  (fPair f0) (spRel 16) `snocOL`
3462                    LD   W  (spRel 16) v2
3463                    ,
3464                    [v1,v2]
3465                 )
3466              FloatRep ->
3467                 getNewRegNCG WordRep  `thenNat` \ v1 ->
3468                 returnNat (
3469                    code                    `snocOL`
3470                    ST   F  src (spRel 16)  `snocOL`
3471                    LD   W  (spRel 16) v1
3472                    ,
3473                    [v1]
3474                 )
3475              other ->
3476                 getNewRegNCG WordRep  `thenNat` \ v1 ->
3477                 returnNat (
3478                    code `snocOL` OR False g0 (RIReg src) v1
3479                    ,
3480                    [v1]
3481                 )
3482 #endif /* sparc_TARGET_ARCH */
3483
3484 #if powerpc_TARGET_ARCH
3485
3486 #if darwin_TARGET_OS
3487 {-
3488     The PowerPC calling convention for Darwin/Mac OS X
3489     is described in Apple's document
3490     "Inside Mac OS X - Mach-O Runtime Architecture".
3491     Parameters may be passed in general-purpose registers, in
3492     floating point registers, or on the stack. Stack space is
3493     always reserved for parameters, even if they are passed in registers.
3494     The called routine may choose to save parameters from registers
3495     to the corresponding space on the stack.
3496     The parameter area should be part of the caller's stack frame,
3497     allocated in the caller's prologue code (large enough to hold
3498     the parameter lists for all called routines). The NCG already
3499     uses the space that we should use as a parameter area for register
3500     spilling, so we allocate a new stack frame just before ccalling.
3501     That way we don't need to decide beforehand how much space to
3502     reserve for parameters.
3503 -}
3504
3505 genCCall fn cconv kind args
3506   = mapNat prepArg args `thenNat` \ preppedArgs ->
3507     let
3508         (argReps,argCodes,vregs) = unzip3 preppedArgs
3509
3510             -- size of linkage area + size of arguments, in bytes
3511         stackDelta = roundTo16 $ (24 +) $ max 32 $ (4 *) $ sum $ map getPrimRepSize argReps
3512         roundTo16 x | x `mod` 16 == 0 = x
3513                     | otherwise = x + 16 - (x `mod` 16)
3514
3515         move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
3516         move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
3517
3518         (moveFinalCode,usedRegs) = move_final
3519                                         (zip vregs argReps)
3520                                         allArgRegs allFPArgRegs
3521                                         eXTRA_STK_ARGS_HERE
3522                                         (toOL []) []
3523
3524         passArguments = concatOL argCodes
3525             `appOL` move_sp_down
3526             `appOL` moveFinalCode
3527     in
3528         case fn of
3529             Left lbl ->
3530                 addImportNat lbl                        `thenNat` \ _ ->
3531                 returnNat (passArguments
3532                             `snocOL`    BL (ImmLit $ ftext
3533                                              (FSLIT("L_")
3534                                              `appendFS` lbl
3535                                              `appendFS` FSLIT("$stub")))
3536                                            usedRegs
3537                             `appOL`     move_sp_up)
3538             Right dyn ->
3539                 getRegister dyn                         `thenNat` \ dynReg ->
3540                 getNewRegNCG (registerRep dynReg)       `thenNat` \ tmp ->
3541                 returnNat (registerCode dynReg tmp
3542                             `appOL`     passArguments
3543                             `snocOL`    MTCTR (registerName dynReg tmp)
3544                             `snocOL`    BCTRL usedRegs
3545                             `appOL`     move_sp_up)
3546     where
3547     prepArg arg
3548         | is64BitRep (repOfStixExpr arg)
3549         = iselExpr64 arg                `thenNat` \ (ChildCode64 code vr_lo) ->
3550           let r_lo = VirtualRegI vr_lo
3551               r_hi = getHiVRegFromLo r_lo
3552           in  returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
3553         | otherwise
3554         = getRegister arg                       `thenNat` \ register ->
3555           getNewRegNCG (registerRep register)   `thenNat` \ tmp ->
3556           returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
3557     move_final [] _ _ _ accumCode accumUsed = (accumCode, accumUsed)
3558     move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
3559         | not (is64BitRep rep) =
3560         case rep of
3561             FloatRep ->
3562                 move_final vregs (drop 1 gprs) (drop 1 fprs) (stackOffset+4)
3563                     (accumCode `snocOL`
3564                         (case fprs of
3565                             fpr : fprs -> MR fpr vr
3566                             [] -> ST F vr (AddrRegImm sp (ImmInt stackOffset))))
3567                     ((take 1 fprs) ++ accumUsed)
3568             DoubleRep ->
3569                 move_final vregs (drop 2 gprs) (drop 1 fprs) (stackOffset+8)
3570                     (accumCode `snocOL`
3571                         (case fprs of
3572                             fpr : fprs -> MR fpr vr
3573                             [] -> ST DF vr (AddrRegImm sp (ImmInt stackOffset))))
3574                     ((take 1 fprs) ++ accumUsed)
3575             VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
3576             _ ->
3577                 move_final vregs (drop 1 gprs) fprs (stackOffset+4)
3578                     (accumCode `snocOL`
3579                         (case gprs of
3580                             gpr : gprs -> MR gpr vr
3581                             [] -> ST W vr (AddrRegImm sp (ImmInt stackOffset))))
3582                     ((take 1 gprs) ++ accumUsed)
3583
3584     move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
3585         | is64BitRep rep =
3586         let
3587             storeWord vr (gpr:_) offset = MR gpr vr
3588             storeWord vr [] offset = ST W vr (AddrRegImm sp (ImmInt offset))
3589         in
3590             move_final vregs (drop 2 gprs) fprs (stackOffset+8)
3591                 (accumCode
3592                     `snocOL` storeWord vr_hi gprs stackOffset
3593                     `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
3594                 ((take 2 gprs) ++ accumUsed)
3595 #else
3596
3597 {-
3598     PowerPC Linux uses the System V Release 4 Calling Convention
3599     for PowerPC. It is described in the
3600     "System V Application Binary Interface PowerPC Processor Supplement".
3601
3602     Like the Darwin/Mac OS X code above, this allocates a new stack frame
3603     so that the parameter area doesn't conflict with the spill slots.
3604 -}
3605
3606 genCCall fn cconv kind args
3607   = mapNat prepArg args `thenNat` \ preppedArgs ->
3608     let
3609         (argReps,argCodes,vregs) = unzip3 preppedArgs
3610
3611             -- size of linkage area + size of arguments, in bytes
3612         stackDelta = roundTo16 finalStack
3613         roundTo16 x | x `mod` 16 == 0 = x
3614                     | otherwise = x + 16 - (x `mod` 16)
3615
3616         move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
3617         move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
3618
3619         (moveFinalCode,usedRegs,finalStack) =
3620             move_final (zip vregs argReps)
3621                        allArgRegs allFPArgRegs
3622                        eXTRA_STK_ARGS_HERE
3623                        (toOL []) []
3624
3625         passArguments = concatOL argCodes
3626             `appOL` move_sp_down
3627             `appOL` moveFinalCode
3628     in
3629         case fn of
3630             Left lbl ->
3631                 addImportNat lbl                        `thenNat` \ _ ->
3632                 returnNat (passArguments
3633                             `snocOL`    BL (ImmLit $ ftext  lbl)
3634                                            usedRegs
3635                             `appOL`     move_sp_up)
3636             Right dyn ->
3637                 getRegister dyn                         `thenNat` \ dynReg ->
3638                 getNewRegNCG (registerRep dynReg)       `thenNat` \ tmp ->
3639                 returnNat (registerCode dynReg tmp
3640                             `appOL`     passArguments
3641                             `snocOL`    MTCTR (registerName dynReg tmp)
3642                             `snocOL`    BCTRL usedRegs
3643                             `appOL`     move_sp_up)
3644     where
3645     prepArg arg
3646         | is64BitRep (repOfStixExpr arg)
3647         = iselExpr64 arg                `thenNat` \ (ChildCode64 code vr_lo) ->
3648           let r_lo = VirtualRegI vr_lo
3649               r_hi = getHiVRegFromLo r_lo
3650           in  returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
3651         | otherwise
3652         = getRegister arg                       `thenNat` \ register ->
3653           getNewRegNCG (registerRep register)   `thenNat` \ tmp ->
3654           returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
3655     move_final [] _ _ stackOffset accumCode accumUsed = (accumCode, accumUsed, stackOffset)
3656     move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
3657         | not (is64BitRep rep) =
3658         case rep of
3659             FloatRep ->
3660                 case fprs of
3661                     fpr : fprs' -> move_final vregs gprs fprs' stackOffset
3662                                               (accumCode `snocOL` MR fpr vr)
3663                                               (fpr : accumUsed)
3664                     [] -> move_final vregs gprs fprs (stackOffset+4)
3665                                      (accumCode `snocOL`
3666                                         ST F vr (AddrRegImm sp (ImmInt stackOffset)))
3667                                      accumUsed
3668             DoubleRep ->
3669                 case fprs of
3670                     fpr : fprs' -> move_final vregs gprs fprs' stackOffset
3671                                               (accumCode `snocOL` MR fpr vr)
3672                                               (fpr : accumUsed)
3673                     [] -> move_final vregs gprs fprs (stackOffset+8)
3674                                      (accumCode `snocOL`
3675                                         ST DF vr (AddrRegImm sp (ImmInt stackOffset)))
3676                                      accumUsed
3677             VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
3678             _ ->
3679                 case gprs of
3680                     gpr : gprs' -> move_final vregs gprs' fprs stackOffset
3681                                               (accumCode `snocOL` MR gpr vr)
3682                                               (gpr : accumUsed)
3683                     [] -> move_final vregs gprs fprs (stackOffset+4)
3684                                      (accumCode `snocOL`
3685                                         ST W vr (AddrRegImm sp (ImmInt stackOffset)))
3686                                      accumUsed
3687
3688     move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
3689         | is64BitRep rep =
3690             case gprs of
3691                 hireg : loreg : regs | even (length gprs) ->
3692                     move_final vregs regs fprs stackOffset
3693                                (regCode hireg loreg) accumUsed
3694                 _skipped : hireg : loreg : regs ->
3695                     move_final vregs regs fprs stackOffset
3696                                (regCode hireg loreg) accumUsed
3697                 _ -> -- only one or no regs left
3698                     move_final vregs [] fprs (stackOffset+8)
3699                                stackCode accumUsed
3700         where
3701             stackCode =
3702                 accumCode
3703                     `snocOL` ST W vr_hi (AddrRegImm sp (ImmInt stackOffset))
3704                     `snocOL` ST W vr_lo (AddrRegImm sp (ImmInt (stackOffset+4)))
3705             regCode hireg loreg =
3706                 accumCode
3707                     `snocOL` MR hireg vr_hi
3708                     `snocOL` MR loreg vr_lo
3709
3710 #endif
3711
3712 #endif /* powerpc_TARGET_ARCH */
3713
3714 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3715 \end{code}
3716
3717 %************************************************************************
3718 %*                                                                      *
3719 \subsection{Support bits}
3720 %*                                                                      *
3721 %************************************************************************
3722
3723 %************************************************************************
3724 %*                                                                      *
3725 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
3726 %*                                                                      *
3727 %************************************************************************
3728
3729 Turn those condition codes into integers now (when they appear on
3730 the right hand side of an assignment).
3731
3732 (If applicable) Do not fill the delay slots here; you will confuse the
3733 register allocator.
3734
3735 \begin{code}
3736 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
3737
3738 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3739
3740 #if alpha_TARGET_ARCH
3741 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
3742 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
3743 #endif /* alpha_TARGET_ARCH */
3744
3745 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3746
3747 #if i386_TARGET_ARCH
3748
3749 condIntReg cond x y
3750   = condIntCode cond x y        `thenNat` \ condition ->
3751     getNewRegNCG IntRep         `thenNat` \ tmp ->
3752     let
3753         code = condCode condition
3754         cond = condName condition
3755         code__2 dst = code `appOL` toOL [
3756             SETCC cond (OpReg tmp),
3757             AND L (OpImm (ImmInt 1)) (OpReg tmp),
3758             MOV L (OpReg tmp) (OpReg dst)]
3759     in
3760     returnNat (Any IntRep code__2)
3761
3762 condFltReg cond x y
3763   = getNatLabelNCG              `thenNat` \ lbl1 ->
3764     getNatLabelNCG              `thenNat` \ lbl2 ->
3765     condFltCode cond x y        `thenNat` \ condition ->
3766     let
3767         code = condCode condition
3768         cond = condName condition
3769         code__2 dst = code `appOL` toOL [
3770             JXX cond lbl1,
3771             MOV L (OpImm (ImmInt 0)) (OpReg dst),
3772             JXX ALWAYS lbl2,
3773             LABEL lbl1,
3774             MOV L (OpImm (ImmInt 1)) (OpReg dst),
3775             LABEL lbl2]
3776     in
3777     returnNat (Any IntRep code__2)
3778
3779 #endif /* i386_TARGET_ARCH */
3780
3781 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3782
3783 #if sparc_TARGET_ARCH
3784
3785 condIntReg EQQ x (StInt 0)
3786   = getRegister x               `thenNat` \ register ->
3787     getNewRegNCG IntRep         `thenNat` \ tmp ->
3788     let
3789         code = registerCode register tmp
3790         src  = registerName register tmp
3791         code__2 dst = code `appOL` toOL [
3792             SUB False True g0 (RIReg src) g0,
3793             SUB True False g0 (RIImm (ImmInt (-1))) dst]
3794     in
3795     returnNat (Any IntRep code__2)
3796
3797 condIntReg EQQ x y
3798   = getRegister x               `thenNat` \ register1 ->
3799     getRegister y               `thenNat` \ register2 ->
3800     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3801     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3802     let
3803         code1 = registerCode register1 tmp1
3804         src1  = registerName register1 tmp1
3805         code2 = registerCode register2 tmp2
3806         src2  = registerName register2 tmp2
3807         code__2 dst = code1 `appOL` code2 `appOL` toOL [
3808             XOR False src1 (RIReg src2) dst,
3809             SUB False True g0 (RIReg dst) g0,
3810             SUB True False g0 (RIImm (ImmInt (-1))) dst]
3811     in
3812     returnNat (Any IntRep code__2)
3813
3814 condIntReg NE x (StInt 0)
3815   = getRegister x               `thenNat` \ register ->
3816     getNewRegNCG IntRep         `thenNat` \ tmp ->
3817     let
3818         code = registerCode register tmp
3819         src  = registerName register tmp
3820         code__2 dst = code `appOL` toOL [
3821             SUB False True g0 (RIReg src) g0,
3822             ADD True False g0 (RIImm (ImmInt 0)) dst]
3823     in
3824     returnNat (Any IntRep code__2)
3825
3826 condIntReg NE x y
3827   = getRegister x               `thenNat` \ register1 ->
3828     getRegister y               `thenNat` \ register2 ->
3829     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3830     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3831     let
3832         code1 = registerCode register1 tmp1
3833         src1  = registerName register1 tmp1
3834         code2 = registerCode register2 tmp2
3835         src2  = registerName register2 tmp2
3836         code__2 dst = code1 `appOL` code2 `appOL` toOL [
3837             XOR False src1 (RIReg src2) dst,
3838             SUB False True g0 (RIReg dst) g0,
3839             ADD True False g0 (RIImm (ImmInt 0)) dst]
3840     in
3841     returnNat (Any IntRep code__2)
3842
3843 condIntReg cond x y
3844   = getNatLabelNCG              `thenNat` \ lbl1 ->
3845     getNatLabelNCG              `thenNat` \ lbl2 ->
3846     condIntCode cond x y        `thenNat` \ condition ->
3847     let
3848         code = condCode condition
3849         cond = condName condition
3850         code__2 dst = code `appOL` toOL [
3851             BI cond False (ImmCLbl lbl1), NOP,
3852             OR False g0 (RIImm (ImmInt 0)) dst,
3853             BI ALWAYS False (ImmCLbl lbl2), NOP,
3854             LABEL lbl1,
3855             OR False g0 (RIImm (ImmInt 1)) dst,
3856             LABEL lbl2]
3857     in
3858     returnNat (Any IntRep code__2)
3859
3860 condFltReg cond x y
3861   = getNatLabelNCG              `thenNat` \ lbl1 ->
3862     getNatLabelNCG              `thenNat` \ lbl2 ->
3863     condFltCode cond x y        `thenNat` \ condition ->
3864     let
3865         code = condCode condition
3866         cond = condName condition
3867         code__2 dst = code `appOL` toOL [
3868             NOP,
3869             BF cond False (ImmCLbl lbl1), NOP,
3870             OR False g0 (RIImm (ImmInt 0)) dst,
3871             BI ALWAYS False (ImmCLbl lbl2), NOP,
3872             LABEL lbl1,
3873             OR False g0 (RIImm (ImmInt 1)) dst,
3874             LABEL lbl2]
3875     in
3876     returnNat (Any IntRep code__2)
3877
3878 #endif /* sparc_TARGET_ARCH */
3879
3880 #if powerpc_TARGET_ARCH
3881 condIntReg cond x y
3882   = getNatLabelNCG              `thenNat` \ lbl ->
3883     condIntCode cond x y        `thenNat` \ condition ->
3884     let
3885         code = condCode condition
3886         cond = condName condition
3887         code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
3888             BCC cond lbl,
3889             LI dst (ImmInt 0),
3890             LABEL lbl]
3891     in
3892     returnNat (Any IntRep code__2)
3893
3894 condFltReg cond x y
3895   = getNatLabelNCG              `thenNat` \ lbl ->
3896     condFltCode cond x y        `thenNat` \ condition ->
3897     let
3898         code = condCode condition
3899         cond = condName condition
3900         code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
3901             BCC cond lbl,
3902             LI dst (ImmInt 0),
3903             LABEL lbl]
3904     in
3905     returnNat (Any IntRep code__2)
3906 #endif /* powerpc_TARGET_ARCH */
3907
3908 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3909 \end{code}
3910
3911 %************************************************************************
3912 %*                                                                      *
3913 \subsubsection{@trivial*Code@: deal with trivial instructions}
3914 %*                                                                      *
3915 %************************************************************************
3916
3917 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3918 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions.  Only look
3919 for constants on the right hand side, because that's where the generic
3920 optimizer will have put them.
3921
3922 Similarly, for unary instructions, we don't have to worry about
3923 matching an StInt as the argument, because genericOpt will already
3924 have handled the constant-folding.
3925
3926 \begin{code}
3927 trivialCode
3928     :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3929       ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3930                      -> Maybe (Operand -> Operand -> Instr)
3931       ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3932       ,IF_ARCH_powerpc((Reg -> Reg -> RI -> Instr)
3933       ,))))
3934     -> StixExpr -> StixExpr -- the two arguments
3935     -> NatM Register
3936
3937 trivialFCode
3938     :: PrimRep
3939     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3940       ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3941       ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3942       ,IF_ARCH_powerpc((Size -> Reg -> Reg -> Reg -> Instr)
3943       ,))))
3944     -> StixExpr -> StixExpr -- the two arguments
3945     -> NatM Register
3946
3947 trivialUCode
3948     :: IF_ARCH_alpha((RI -> Reg -> Instr)
3949       ,IF_ARCH_i386 ((Operand -> Instr)
3950       ,IF_ARCH_sparc((RI -> Reg -> Instr)
3951       ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
3952       ,))))
3953     -> StixExpr -- the one argument
3954     -> NatM Register
3955
3956 trivialUFCode
3957     :: PrimRep
3958     -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3959       ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3960       ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3961       ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
3962       ,))))
3963     -> StixExpr -- the one argument
3964     -> NatM Register
3965
3966 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3967
3968 #if alpha_TARGET_ARCH
3969
3970 trivialCode instr x (StInt y)
3971   | fits8Bits y
3972   = getRegister x               `thenNat` \ register ->
3973     getNewRegNCG IntRep         `thenNat` \ tmp ->
3974     let
3975         code = registerCode register tmp
3976         src1 = registerName register tmp
3977         src2 = ImmInt (fromInteger y)
3978         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3979     in
3980     returnNat (Any IntRep code__2)
3981
3982 trivialCode instr x y
3983   = getRegister x               `thenNat` \ register1 ->
3984     getRegister y               `thenNat` \ register2 ->
3985     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3986     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3987     let
3988         code1 = registerCode register1 tmp1 []
3989         src1  = registerName register1 tmp1
3990         code2 = registerCode register2 tmp2 []
3991         src2  = registerName register2 tmp2
3992         code__2 dst = asmSeqThen [code1, code2] .
3993                      mkSeqInstr (instr src1 (RIReg src2) dst)
3994     in
3995     returnNat (Any IntRep code__2)
3996
3997 ------------
3998 trivialUCode instr x
3999   = getRegister x               `thenNat` \ register ->
4000     getNewRegNCG IntRep         `thenNat` \ tmp ->
4001     let
4002         code = registerCode register tmp
4003         src  = registerName register tmp
4004         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
4005     in
4006     returnNat (Any IntRep code__2)
4007
4008 ------------
4009 trivialFCode _ instr x y
4010   = getRegister x               `thenNat` \ register1 ->
4011     getRegister y               `thenNat` \ register2 ->
4012     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
4013     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
4014     let
4015         code1 = registerCode register1 tmp1
4016         src1  = registerName register1 tmp1
4017
4018         code2 = registerCode register2 tmp2
4019         src2  = registerName register2 tmp2
4020
4021         code__2 dst = asmSeqThen [code1 [], code2 []] .
4022                       mkSeqInstr (instr src1 src2 dst)
4023     in
4024     returnNat (Any DoubleRep code__2)
4025
4026 trivialUFCode _ instr x
4027   = getRegister x               `thenNat` \ register ->
4028     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
4029     let
4030         code = registerCode register tmp
4031         src  = registerName register tmp
4032         code__2 dst = code . mkSeqInstr (instr src dst)
4033     in
4034     returnNat (Any DoubleRep code__2)
4035
4036 #endif /* alpha_TARGET_ARCH */
4037
4038 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4039
4040 #if i386_TARGET_ARCH
4041 \end{code}
4042 The Rules of the Game are:
4043
4044 * You cannot assume anything about the destination register dst;
4045   it may be anything, including a fixed reg.
4046
4047 * You may compute an operand into a fixed reg, but you may not
4048   subsequently change the contents of that fixed reg.  If you
4049   want to do so, first copy the value either to a temporary
4050   or into dst.  You are free to modify dst even if it happens
4051   to be a fixed reg -- that's not your problem.
4052
4053 * You cannot assume that a fixed reg will stay live over an
4054   arbitrary computation.  The same applies to the dst reg.
4055
4056 * Temporary regs obtained from getNewRegNCG are distinct from
4057   each other and from all other regs, and stay live over
4058   arbitrary computations.
4059
4060 \begin{code}
4061
4062 trivialCode instr maybe_revinstr a b
4063
4064   | is_imm_b
4065   = getRegister a                         `thenNat` \ rega ->
4066     let mkcode dst
4067           = if   isAny rega
4068             then registerCode rega dst      `bind` \ code_a ->
4069                  code_a `snocOL`
4070                  instr (OpImm imm_b) (OpReg dst)
4071             else registerCodeF rega         `bind` \ code_a ->
4072                  registerNameF rega         `bind` \ r_a ->
4073                  code_a `snocOL`
4074                  MOV L (OpReg r_a) (OpReg dst) `snocOL`
4075                  instr (OpImm imm_b) (OpReg dst)
4076     in
4077     returnNat (Any IntRep mkcode)
4078
4079   | is_imm_a
4080   = getRegister b                         `thenNat` \ regb ->
4081     getNewRegNCG IntRep                   `thenNat` \ tmp ->
4082     let revinstr_avail = maybeToBool maybe_revinstr
4083         revinstr       = case maybe_revinstr of Just ri -> ri
4084         mkcode dst
4085           | revinstr_avail
4086           = if   isAny regb
4087             then registerCode regb dst      `bind` \ code_b ->
4088                  code_b `snocOL`
4089                  revinstr (OpImm imm_a) (OpReg dst)
4090             else registerCodeF regb         `bind` \ code_b ->
4091                  registerNameF regb         `bind` \ r_b ->
4092                  code_b `snocOL`
4093                  MOV L (OpReg r_b) (OpReg dst) `snocOL`
4094                  revinstr (OpImm imm_a) (OpReg dst)
4095
4096           | otherwise
4097           = if   isAny regb
4098             then registerCode regb tmp      `bind` \ code_b ->
4099                  code_b `snocOL`
4100                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
4101                  instr (OpReg tmp) (OpReg dst)
4102             else registerCodeF regb         `bind` \ code_b ->
4103                  registerNameF regb         `bind` \ r_b ->
4104                  code_b `snocOL`
4105                  MOV L (OpReg r_b) (OpReg tmp) `snocOL`
4106                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
4107                  instr (OpReg tmp) (OpReg dst)
4108     in
4109     returnNat (Any IntRep mkcode)
4110
4111   | otherwise
4112   = getRegister a                         `thenNat` \ rega ->
4113     getRegister b                         `thenNat` \ regb ->
4114     getNewRegNCG IntRep                   `thenNat` \ tmp ->
4115     let mkcode dst
4116           = case (isAny rega, isAny regb) of
4117               (True, True)
4118                  -> registerCode regb tmp   `bind` \ code_b ->
4119                     registerCode rega dst   `bind` \ code_a ->
4120                     code_b `appOL`
4121                     code_a `snocOL`
4122                     instr (OpReg tmp) (OpReg dst)
4123               (True, False)
4124                  -> registerCode  rega tmp  `bind` \ code_a ->
4125                     registerCodeF regb      `bind` \ code_b ->
4126                     registerNameF regb      `bind` \ r_b ->
4127                     code_a `appOL`
4128                     code_b `snocOL`
4129                     instr (OpReg r_b) (OpReg tmp) `snocOL`
4130                     MOV L (OpReg tmp) (OpReg dst)
4131               (False, True)
4132                  -> registerCode  regb tmp  `bind` \ code_b ->
4133                     registerCodeF rega      `bind` \ code_a ->
4134                     registerNameF rega      `bind` \ r_a ->
4135                     code_b `appOL`
4136                     code_a `snocOL`
4137                     MOV L (OpReg r_a) (OpReg dst) `snocOL`
4138                     instr (OpReg tmp) (OpReg dst)
4139               (False, False)
4140                  -> registerCodeF  rega     `bind` \ code_a ->
4141                     registerNameF  rega     `bind` \ r_a ->
4142                     registerCodeF  regb     `bind` \ code_b ->
4143                     registerNameF  regb     `bind` \ r_b ->
4144                     code_a `snocOL`
4145                     MOV L (OpReg r_a) (OpReg tmp) `appOL`
4146                     code_b `snocOL`
4147                     instr (OpReg r_b) (OpReg tmp) `snocOL`
4148                     MOV L (OpReg tmp) (OpReg dst)
4149     in
4150     returnNat (Any IntRep mkcode)
4151
4152     where
4153        maybe_imm_a = maybeImm a
4154        is_imm_a    = maybeToBool maybe_imm_a
4155        imm_a       = case maybe_imm_a of Just imm -> imm
4156
4157        maybe_imm_b = maybeImm b
4158        is_imm_b    = maybeToBool maybe_imm_b
4159        imm_b       = case maybe_imm_b of Just imm -> imm
4160
4161
4162 -----------
4163 trivialUCode instr x
4164   = getRegister x               `thenNat` \ register ->
4165     let
4166         code__2 dst = let code = registerCode register dst
4167                           src  = registerName register dst
4168                       in code `appOL`
4169                          if   isFixed register && dst /= src
4170                          then toOL [MOV L (OpReg src) (OpReg dst),
4171                                     instr (OpReg dst)]
4172                          else unitOL (instr (OpReg src))
4173     in
4174     returnNat (Any IntRep code__2)
4175
4176 -----------
4177 trivialFCode pk instr x y
4178   = getRegister x               `thenNat` \ register1 ->
4179     getRegister y               `thenNat` \ register2 ->
4180     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
4181     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
4182     let
4183         code1 = registerCode register1 tmp1
4184         src1  = registerName register1 tmp1
4185
4186         code2 = registerCode register2 tmp2
4187         src2  = registerName register2 tmp2
4188
4189         code__2 dst
4190            -- treat the common case specially: both operands in
4191            -- non-fixed regs.
4192            | isAny register1 && isAny register2
4193            = code1 `appOL`
4194              code2 `snocOL`
4195              instr (primRepToSize pk) src1 src2 dst
4196
4197            -- be paranoid (and inefficient)
4198            | otherwise
4199            = code1 `snocOL` GMOV src1 tmp1  `appOL`
4200              code2 `snocOL`
4201              instr (primRepToSize pk) tmp1 src2 dst
4202     in
4203     returnNat (Any pk code__2)
4204
4205
4206 -------------
4207 trivialUFCode pk instr x
4208   = getRegister x               `thenNat` \ register ->
4209     getNewRegNCG pk             `thenNat` \ tmp ->
4210     let
4211         code = registerCode register tmp
4212         src  = registerName register tmp
4213         code__2 dst = code `snocOL` instr src dst
4214     in
4215     returnNat (Any pk code__2)
4216
4217 #endif /* i386_TARGET_ARCH */
4218
4219 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4220
4221 #if sparc_TARGET_ARCH
4222
4223 trivialCode instr x (StInt y)
4224   | fits13Bits y
4225   = getRegister x               `thenNat` \ register ->
4226     getNewRegNCG IntRep         `thenNat` \ tmp ->
4227     let
4228         code = registerCode register tmp
4229         src1 = registerName register tmp
4230         src2 = ImmInt (fromInteger y)
4231         code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
4232     in
4233     returnNat (Any IntRep code__2)
4234
4235 trivialCode instr x y
4236   = getRegister x               `thenNat` \ register1 ->
4237     getRegister y               `thenNat` \ register2 ->
4238     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
4239     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
4240     let
4241         code1 = registerCode register1 tmp1
4242         src1  = registerName register1 tmp1
4243         code2 = registerCode register2 tmp2
4244         src2  = registerName register2 tmp2
4245         code__2 dst = code1 `appOL` code2 `snocOL`
4246                       instr src1 (RIReg src2) dst
4247     in
4248     returnNat (Any IntRep code__2)
4249
4250 ------------
4251 trivialFCode pk instr x y
4252   = getRegister x               `thenNat` \ register1 ->
4253     getRegister y               `thenNat` \ register2 ->
4254     getNewRegNCG (registerRep register1)
4255                                 `thenNat` \ tmp1 ->
4256     getNewRegNCG (registerRep register2)
4257                                 `thenNat` \ tmp2 ->
4258     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
4259     let
4260         promote x = FxTOy F DF x tmp
4261
4262         pk1   = registerRep register1
4263         code1 = registerCode register1 tmp1
4264         src1  = registerName register1 tmp1
4265
4266         pk2   = registerRep register2
4267         code2 = registerCode register2 tmp2
4268         src2  = registerName register2 tmp2
4269
4270         code__2 dst =
4271                 if pk1 == pk2 then
4272                     code1 `appOL` code2 `snocOL`
4273                     instr (primRepToSize pk) src1 src2 dst
4274                 else if pk1 == FloatRep then
4275                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
4276                     instr DF tmp src2 dst
4277                 else
4278                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
4279                     instr DF src1 tmp dst
4280     in
4281     returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
4282
4283 ------------
4284 trivialUCode instr x
4285   = getRegister x               `thenNat` \ register ->
4286     getNewRegNCG IntRep         `thenNat` \ tmp ->
4287     let
4288         code = registerCode register tmp
4289         src  = registerName register tmp
4290         code__2 dst = code `snocOL` instr (RIReg src) dst
4291     in
4292     returnNat (Any IntRep code__2)
4293
4294 -------------
4295 trivialUFCode pk instr x
4296   = getRegister x               `thenNat` \ register ->
4297     getNewRegNCG pk             `thenNat` \ tmp ->
4298     let
4299         code = registerCode register tmp
4300         src  = registerName register tmp
4301         code__2 dst = code `snocOL` instr src dst
4302     in
4303     returnNat (Any pk code__2)
4304
4305 #endif /* sparc_TARGET_ARCH */
4306
4307 #if powerpc_TARGET_ARCH
4308 trivialCode instr x (StInt y)
4309   | fits16Bits y
4310   = getRegister x               `thenNat` \ register ->
4311     getNewRegNCG IntRep         `thenNat` \ tmp ->
4312     let
4313         code = registerCode register tmp
4314         src1 = registerName register tmp
4315         src2 = ImmInt (fromInteger y)
4316         code__2 dst = code `snocOL` instr dst src1 (RIImm src2)
4317     in
4318     returnNat (Any IntRep code__2)
4319
4320 trivialCode instr x y
4321   = getRegister x               `thenNat` \ register1 ->
4322     getRegister y               `thenNat` \ register2 ->
4323     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
4324     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
4325     let
4326         code1 = registerCode register1 tmp1
4327         src1  = registerName register1 tmp1
4328         code2 = registerCode register2 tmp2
4329         src2  = registerName register2 tmp2
4330         code__2 dst = code1 `appOL` code2 `snocOL`
4331                       instr dst src1 (RIReg src2)
4332     in
4333     returnNat (Any IntRep code__2)
4334
4335 trivialCode2 :: (Reg -> Reg -> Reg -> Instr)
4336     -> StixExpr -> StixExpr -> NatM Register
4337 trivialCode2 instr x y
4338   = getRegister x               `thenNat` \ register1 ->
4339     getRegister y               `thenNat` \ register2 ->
4340     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
4341     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
4342     let
4343         code1 = registerCode register1 tmp1
4344         src1  = registerName register1 tmp1
4345         code2 = registerCode register2 tmp2
4346         src2  = registerName register2 tmp2
4347         code__2 dst = code1 `appOL` code2 `snocOL`
4348                       instr dst src1 src2
4349     in
4350     returnNat (Any IntRep code__2)
4351
4352 trivialFCode pk instr x y
4353   = getRegister x               `thenNat` \ register1 ->
4354     getRegister y               `thenNat` \ register2 ->
4355     getNewRegNCG (registerRep register1)
4356                                 `thenNat` \ tmp1 ->
4357     getNewRegNCG (registerRep register2)
4358                                 `thenNat` \ tmp2 ->
4359     -- getNewRegNCG DoubleRep           `thenNat` \ tmp ->
4360     let
4361         -- promote x = FxTOy F DF x tmp
4362
4363         pk1   = registerRep register1
4364         code1 = registerCode register1 tmp1
4365         src1  = registerName register1 tmp1
4366
4367         pk2   = registerRep register2
4368         code2 = registerCode register2 tmp2
4369         src2  = registerName register2 tmp2
4370
4371         dstRep = if pk1 == FloatRep && pk2 == FloatRep then FloatRep else DoubleRep
4372
4373         code__2 dst =
4374                     code1 `appOL` code2 `snocOL`
4375                     instr (primRepToSize dstRep) dst src1 src2
4376     in
4377     returnNat (Any dstRep code__2)
4378
4379 trivialUCode instr x
4380   = getRegister x               `thenNat` \ register ->
4381     getNewRegNCG IntRep         `thenNat` \ tmp ->
4382     let
4383         code = registerCode register tmp
4384         src  = registerName register tmp
4385         code__2 dst = code `snocOL` instr dst src
4386     in
4387     returnNat (Any IntRep code__2)
4388 trivialUFCode pk instr x
4389   = getRegister x               `thenNat` \ register ->
4390     getNewRegNCG (registerRep register)
4391                                 `thenNat` \ tmp ->
4392     let
4393         code = registerCode register tmp
4394         src  = registerName register tmp
4395         code__2 dst = code `snocOL` instr dst src
4396     in
4397     returnNat (Any pk code__2)
4398
4399 -- There is no "remainder" instruction on the PPC, so we have to do
4400 -- it the hard way.
4401 -- The "div" parameter is the division instruction to use (DIVW or DIVWU)
4402
4403 remainderCode :: (Reg -> Reg -> Reg -> Instr)
4404     -> StixExpr -> StixExpr -> NatM Register
4405 remainderCode div x y
4406   = getRegister x               `thenNat` \ register1 ->
4407     getRegister y               `thenNat` \ register2 ->
4408     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
4409     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
4410     let
4411         code1 = registerCode register1 tmp1
4412         src1  = registerName register1 tmp1
4413         code2 = registerCode register2 tmp2
4414         src2  = registerName register2 tmp2
4415         code__2 dst = code1 `appOL` code2 `appOL` toOL [
4416                 div dst src1 src2,
4417                 MULLW dst dst (RIReg src2),
4418                 SUBF dst dst src1
4419             ]
4420     in
4421     returnNat (Any IntRep code__2)
4422
4423 #endif /* powerpc_TARGET_ARCH */
4424
4425 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4426 \end{code}
4427
4428 %************************************************************************
4429 %*                                                                      *
4430 \subsubsection{Coercing to/from integer/floating-point...}
4431 %*                                                                      *
4432 %************************************************************************
4433
4434 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
4435 conversions.  We have to store temporaries in memory to move
4436 between the integer and the floating point register sets.
4437
4438 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
4439 pretend, on sparc at least, that double and float regs are seperate
4440 kinds, so the value has to be computed into one kind before being
4441 explicitly "converted" to live in the other kind.
4442
4443 \begin{code}
4444 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
4445 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
4446
4447 coerceDbl2Flt :: StixExpr -> NatM Register
4448 coerceFlt2Dbl :: StixExpr -> NatM Register
4449 \end{code}
4450
4451 \begin{code}
4452 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4453
4454 #if alpha_TARGET_ARCH
4455
4456 coerceInt2FP _ x
4457   = getRegister x               `thenNat` \ register ->
4458     getNewRegNCG IntRep         `thenNat` \ reg ->
4459     let
4460         code = registerCode register reg
4461         src  = registerName register reg
4462
4463         code__2 dst = code . mkSeqInstrs [
4464             ST Q src (spRel 0),
4465             LD TF dst (spRel 0),
4466             CVTxy Q TF dst dst]
4467     in
4468     returnNat (Any DoubleRep code__2)
4469
4470 -------------
4471 coerceFP2Int x
4472   = getRegister x               `thenNat` \ register ->
4473     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
4474     let
4475         code = registerCode register tmp
4476         src  = registerName register tmp
4477
4478         code__2 dst = code . mkSeqInstrs [
4479             CVTxy TF Q src tmp,
4480             ST TF tmp (spRel 0),
4481             LD Q dst (spRel 0)]
4482     in
4483     returnNat (Any IntRep code__2)
4484
4485 #endif /* alpha_TARGET_ARCH */
4486
4487 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4488
4489 #if i386_TARGET_ARCH
4490
4491 coerceInt2FP pk x
4492   = getRegister x               `thenNat` \ register ->
4493     getNewRegNCG IntRep         `thenNat` \ reg ->
4494     let
4495         code = registerCode register reg
4496         src  = registerName register reg
4497         opc  = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
4498         code__2 dst = code `snocOL` opc src dst
4499     in
4500     returnNat (Any pk code__2)
4501
4502 ------------
4503 coerceFP2Int fprep x
4504   = getRegister x               `thenNat` \ register ->
4505     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
4506     let
4507         code = registerCode register tmp
4508         src  = registerName register tmp
4509         pk   = registerRep register
4510
4511         opc  = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
4512         code__2 dst = code `snocOL` opc src dst
4513     in
4514     returnNat (Any IntRep code__2)
4515
4516 ------------
4517 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
4518 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
4519
4520 #endif /* i386_TARGET_ARCH */
4521
4522 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4523
4524 #if sparc_TARGET_ARCH
4525
4526 coerceInt2FP pk x
4527   = getRegister x               `thenNat` \ register ->
4528     getNewRegNCG IntRep         `thenNat` \ reg ->
4529     let
4530         code = registerCode register reg
4531         src  = registerName register reg
4532
4533         code__2 dst = code `appOL` toOL [
4534             ST W src (spRel (-2)),
4535             LD W (spRel (-2)) dst,
4536             FxTOy W (primRepToSize pk) dst dst]
4537     in
4538     returnNat (Any pk code__2)
4539
4540 ------------
4541 coerceFP2Int fprep x
4542   = ASSERT(fprep == DoubleRep || fprep == FloatRep)
4543     getRegister x               `thenNat` \ register ->
4544     getNewRegNCG fprep          `thenNat` \ reg ->
4545     getNewRegNCG FloatRep       `thenNat` \ tmp ->
4546     let
4547         code = registerCode register reg
4548         src  = registerName register reg
4549         code__2 dst = code `appOL` toOL [
4550             FxTOy (primRepToSize fprep) W src tmp,
4551             ST W tmp (spRel (-2)),
4552             LD W (spRel (-2)) dst]
4553     in
4554     returnNat (Any IntRep code__2)
4555
4556 ------------
4557 coerceDbl2Flt x
4558   = getRegister x               `thenNat` \ register ->
4559     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
4560     let code = registerCode register tmp
4561         src  = registerName register tmp
4562     in
4563         returnNat (Any FloatRep
4564                        (\dst -> code `snocOL` FxTOy DF F src dst))
4565
4566 ------------
4567 coerceFlt2Dbl x
4568   = getRegister x               `thenNat` \ register ->
4569     getNewRegNCG FloatRep       `thenNat` \ tmp ->
4570     let code = registerCode register tmp
4571         src  = registerName register tmp
4572     in
4573         returnNat (Any DoubleRep
4574                        (\dst -> code `snocOL` FxTOy F DF src dst))
4575
4576 #endif /* sparc_TARGET_ARCH */
4577
4578 #if powerpc_TARGET_ARCH
4579 coerceInt2FP pk x
4580   = ASSERT(pk == DoubleRep)
4581     getRegister x                   `thenNat` \ register ->
4582     getNewRegNCG IntRep             `thenNat` \ reg ->
4583     getNatLabelNCG                  `thenNat` \ lbl ->
4584     getNewRegNCG PtrRep             `thenNat` \ itmp ->
4585     getNewRegNCG DoubleRep          `thenNat` \ ftmp ->
4586     let
4587         code = registerCode register reg
4588         src  = registerName register reg
4589         code__2 dst = code `appOL` toOL [
4590                 SEGMENT RoDataSegment,
4591                 LABEL lbl,
4592                 DATA W [ImmInt 0x43300000, ImmInt 0x80000000],
4593                 SEGMENT TextSegment,
4594                 XORIS itmp src (ImmInt 0x8000),
4595                 ST W itmp (spRel (-1)),
4596                 LIS itmp (ImmInt 0x4330),
4597                 ST W itmp (spRel (-2)),
4598                 LD DF ftmp (spRel (-2)),
4599                 LIS itmp (HA (ImmCLbl lbl)),
4600                 LD DF dst (AddrRegImm itmp (LO (ImmCLbl lbl))),
4601                 FSUB DF dst ftmp dst
4602             ]
4603     in
4604         returnNat (Any DoubleRep code__2)
4605
4606 coerceFP2Int fprep x
4607   = ASSERT(fprep == DoubleRep || fprep == FloatRep)
4608     getRegister x               `thenNat` \ register ->
4609     getNewRegNCG fprep          `thenNat` \ reg ->
4610     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
4611     let
4612         code = registerCode register reg
4613         src  = registerName register reg
4614         code__2 dst = code `appOL` toOL [
4615                 -- convert to int in FP reg
4616             FCTIWZ tmp src,
4617                 -- store value (64bit) from FP to stack
4618             ST DF tmp (spRel (-2)),
4619                 -- read low word of value (high word is undefined)
4620             LD W dst (spRel (-1))]
4621     in
4622     returnNat (Any IntRep code__2)
4623 coerceDbl2Flt x         = panic "###PPC MachCode.coerceDbl2Flt"
4624 coerceFlt2Dbl x         = panic "###PPC MachCode.coerceFlt2Dbl"
4625 #endif /* powerpc_TARGET_ARCH */
4626
4627 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4628 \end{code}