ghc/compiler/nativeGen/MachCode.lhs

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