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