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         r_dst = registerName registerd tmp
2501         r_src = registerName registers r_dst
2502         c_src = registerCode registers r_dst
2503
2504         code = c_src `snocOL`
2505                MOV L (OpReg r_src) (OpReg r_dst)
2506     in
2507     returnNat code
2508
2509 #endif {- i386_TARGET_ARCH -}
2510
2511 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2512
2513 #if sparc_TARGET_ARCH
2514
2515 assignMem_IntCode pk addr src
2516   = getNewRegNCG IntRep                     `thenNat` \ tmp ->
2517     getAmode addr                           `thenNat` \ amode ->
2518     getRegister src                         `thenNat` \ register ->
2519     let
2520         code1   = amodeCode amode
2521         dst__2  = amodeAddr amode
2522         code2   = registerCode register tmp
2523         src__2  = registerName register tmp
2524         sz      = primRepToSize pk
2525         code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2526     in
2527     returnNat code__2
2528
2529 assignReg_IntCode pk reg src
2530   = getRegister src                         `thenNat` \ register2 ->
2531     getRegisterReg reg                      `thenNat` \ register1 ->
2532     getNewRegNCG IntRep                     `thenNat` \ tmp ->
2533     let
2534         dst__2  = registerName register1 tmp
2535         code    = registerCode register2 dst__2
2536         src__2  = registerName register2 dst__2
2537         code__2 = if isFixed register2
2538                   then code `snocOL` OR False g0 (RIReg src__2) dst__2
2539                   else code
2540     in
2541     returnNat code__2
2542
2543 #endif {- sparc_TARGET_ARCH -}
2544
2545 #if powerpc_TARGET_ARCH
2546
2547 assignMem_IntCode pk addr src
2548   = getNewRegNCG IntRep                     `thenNat` \ tmp ->
2549     getAmode addr                           `thenNat` \ amode ->
2550     getRegister src                         `thenNat` \ register ->
2551     let
2552         code1   = amodeCode amode
2553         dst__2  = amodeAddr amode
2554         code2   = registerCode register tmp
2555         src__2  = registerName register tmp
2556         sz      = primRepToSize pk
2557         code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2558     in
2559     returnNat code__2
2560
2561 assignReg_IntCode pk reg src
2562   = getRegister src                         `thenNat` \ register2 ->
2563     getRegisterReg reg                      `thenNat` \ register1 ->
2564     let
2565         dst__2  = registerName register1 (panic "###PPC where are we assigning this int???")
2566         code    = registerCode register2 dst__2
2567         src__2  = registerName register2 dst__2
2568         code__2 = if isFixed register2
2569                   then code `snocOL` MR dst__2 src__2
2570                   else code
2571     in
2572     returnNat code__2
2573
2574 #endif {- powerpc_TARGET_ARCH -}
2575
2576 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2577 \end{code}
2578
2579 % --------------------------------
2580 Floating-point assignments:
2581 % --------------------------------
2582
2583 \begin{code}
2584 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2585 #if alpha_TARGET_ARCH
2586
2587 assignFltCode pk (StInd _ dst) src
2588   = getNewRegNCG pk                 `thenNat` \ tmp ->
2589     getAmode dst                    `thenNat` \ amode ->
2590     getRegister src                         `thenNat` \ register ->
2591     let
2592         code1   = amodeCode amode []
2593         dst__2  = amodeAddr amode
2594         code2   = registerCode register tmp []
2595         src__2  = registerName register tmp
2596         sz      = primRepToSize pk
2597         code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2598     in
2599     returnNat code__2
2600
2601 assignFltCode pk dst src
2602   = getRegister dst                         `thenNat` \ register1 ->
2603     getRegister src                         `thenNat` \ register2 ->
2604     let
2605         dst__2  = registerName register1 zeroh
2606         code    = registerCode register2 dst__2
2607         src__2  = registerName register2 dst__2
2608         code__2 = if isFixed register2
2609                   then code . mkSeqInstr (FMOV src__2 dst__2)
2610                   else code
2611     in
2612     returnNat code__2
2613
2614 #endif {- alpha_TARGET_ARCH -}
2615
2616 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2617
2618 #if i386_TARGET_ARCH
2619
2620 -- Floating point assignment to memory
2621 assignMem_FltCode pk addr src
2622    = getRegister src      `thenNat`  \ reg_src  ->
2623      getRegister addr     `thenNat`  \ reg_addr ->
2624      getNewRegNCG pk      `thenNat`  \ tmp_src  ->
2625      getNewRegNCG PtrRep  `thenNat`  \ tmp_addr ->
2626      let r_src  = registerName reg_src tmp_src
2627          c_src  = registerCode reg_src tmp_src
2628          r_addr = registerName reg_addr tmp_addr
2629          c_addr = registerCode reg_addr tmp_addr
2630          sz     = primRepToSize pk
2631
2632          code = c_src  `appOL`
2633                 -- no need to preserve r_src across the addr computation,
2634                 -- since r_src must be a float reg
2635                 -- whilst r_addr is an int reg
2636                 c_addr `snocOL`
2637                 GST sz r_src
2638                        (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2639      in
2640      returnNat code
2641
2642 -- Floating point assignment to a register/temporary
2643 assignReg_FltCode pk reg src
2644   = getRegisterReg reg              `thenNat` \ reg_dst ->
2645     getRegister src                 `thenNat` \ reg_src ->
2646     getNewRegNCG pk                 `thenNat` \ tmp ->
2647     let
2648         r_dst = registerName reg_dst tmp
2649         r_src = registerName reg_src r_dst
2650         c_src = registerCode reg_src r_dst
2651
2652         code = if   isFixed reg_src
2653                then c_src `snocOL` GMOV r_src r_dst
2654                else c_src
2655     in
2656     returnNat code
2657
2658
2659 #endif {- i386_TARGET_ARCH -}
2660
2661 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2662
2663 #if sparc_TARGET_ARCH
2664
2665 -- Floating point assignment to memory
2666 assignMem_FltCode pk addr src
2667   = getNewRegNCG pk                 `thenNat` \ tmp1 ->
2668     getAmode addr                   `thenNat` \ amode ->
2669     getRegister src                 `thenNat` \ register ->
2670     let
2671         sz      = primRepToSize pk
2672         dst__2  = amodeAddr amode
2673
2674         code1   = amodeCode amode
2675         code2   = registerCode register tmp1
2676
2677         src__2  = registerName register tmp1
2678         pk__2   = registerRep register
2679         sz__2   = primRepToSize pk__2
2680
2681         code__2 = code1 `appOL` code2 `appOL`
2682             if   pk == pk__2
2683             then unitOL (ST sz src__2 dst__2)
2684             else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2685     in
2686     returnNat code__2
2687
2688 -- Floating point assignment to a register/temporary
2689 -- Why is this so bizarrely ugly?
2690 assignReg_FltCode pk reg src
2691   = getRegisterReg reg                      `thenNat` \ register1 ->
2692     getRegister src                         `thenNat` \ register2 ->
2693     let
2694         pk__2   = registerRep register2
2695         sz__2   = primRepToSize pk__2
2696     in
2697     getNewRegNCG pk__2                      `thenNat` \ tmp ->
2698     let
2699         sz      = primRepToSize pk
2700         dst__2  = registerName register1 g0    -- must be Fixed
2701         reg__2  = if pk /= pk__2 then tmp else dst__2
2702         code    = registerCode register2 reg__2
2703         src__2  = registerName register2 reg__2
2704         code__2 =
2705                 if pk /= pk__2 then
2706                      code `snocOL` FxTOy sz__2 sz src__2 dst__2
2707                 else if isFixed register2 then
2708                      code `snocOL` FMOV sz src__2 dst__2
2709                 else
2710                      code
2711     in
2712     returnNat code__2
2713
2714 #endif {- sparc_TARGET_ARCH -}
2715
2716 #if powerpc_TARGET_ARCH
2717
2718 -- Floating point assignment to memory
2719 assignMem_FltCode pk addr src
2720   = getNewRegNCG pk                 `thenNat` \ tmp1 ->
2721     getAmode addr                   `thenNat` \ amode ->
2722     getRegister src                 `thenNat` \ register ->
2723     let
2724         sz      = primRepToSize pk
2725         dst__2  = amodeAddr amode
2726
2727         code1   = amodeCode amode
2728         code2   = registerCode register tmp1
2729
2730         src__2  = registerName register tmp1
2731         pk__2   = registerRep register
2732         sz__2   = primRepToSize pk__2
2733
2734         code__2 = if pk__2 == DoubleRep || pk == pk__2
2735             then code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2736             else panic "###PPC MachCode.assignMem_FltCode: FloatRep"
2737         {- code__2 = code1 `appOL` code2 `appOL`
2738             if   pk == pk__2
2739             then unitOL (ST sz src__2 dst__2)
2740             else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2] -}
2741     in
2742     returnNat code__2
2743
2744 -- Floating point assignment to a register/temporary
2745 assignReg_FltCode pk reg src
2746   = getRegisterReg reg              `thenNat` \ reg_dst ->
2747     getRegister src                 `thenNat` \ reg_src ->
2748     getNewRegNCG pk                 `thenNat` \ tmp ->
2749     let
2750         r_dst = registerName reg_dst tmp
2751         r_src = registerName reg_src r_dst
2752         c_src = registerCode reg_src r_dst
2753
2754         code = if   isFixed reg_src
2755                then c_src `snocOL` MR r_dst r_src
2756                else c_src
2757     in
2758     returnNat code
2759 #endif {- powerpc_TARGET_ARCH -}
2760
2761 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2762 \end{code}
2763
2764 %************************************************************************
2765 %*                                                                      *
2766 \subsection{Generating an unconditional branch}
2767 %*                                                                      *
2768 %************************************************************************
2769
2770 We accept two types of targets: an immediate CLabel or a tree that
2771 gets evaluated into a register.  Any CLabels which are AsmTemporaries
2772 are assumed to be in the local block of code, close enough for a
2773 branch instruction.  Other CLabels are assumed to be far away.
2774
2775 (If applicable) Do not fill the delay slots here; you will confuse the
2776 register allocator.
2777
2778 \begin{code}
2779 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2780
2781 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2782
2783 #if alpha_TARGET_ARCH
2784
2785 genJump (StCLbl lbl)
2786   | isAsmTemp lbl = returnInstr (BR target)
2787   | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2788   where
2789     target = ImmCLbl lbl
2790
2791 genJump tree
2792   = getRegister tree                `thenNat` \ register ->
2793     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2794     let
2795         dst    = registerName register pv
2796         code   = registerCode register pv
2797         target = registerName register pv
2798     in
2799     if isFixed register then
2800         returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2801     else
2802     returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2803
2804 #endif {- alpha_TARGET_ARCH -}
2805
2806 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2807
2808 #if i386_TARGET_ARCH
2809
2810 genJump dsts (StInd pk mem)
2811   = getAmode mem                    `thenNat` \ amode ->
2812     let
2813         code   = amodeCode amode
2814         target = amodeAddr amode
2815     in
2816     returnNat (code `snocOL` JMP dsts (OpAddr target))
2817
2818 genJump dsts tree
2819   | maybeToBool imm
2820   = returnNat (unitOL (JMP dsts (OpImm target)))
2821
2822   | otherwise
2823   = getRegister tree                `thenNat` \ register ->
2824     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2825     let
2826         code   = registerCode register tmp
2827         target = registerName register tmp
2828     in
2829     returnNat (code `snocOL` JMP dsts (OpReg target))
2830   where
2831     imm    = maybeImm tree
2832     target = case imm of Just x -> x
2833
2834 #endif {- i386_TARGET_ARCH -}
2835
2836 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2837
2838 #if sparc_TARGET_ARCH
2839
2840 genJump dsts (StCLbl lbl)
2841   | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2842   | isAsmTemp lbl    = returnNat (toOL [BI ALWAYS False target, NOP])
2843   | otherwise        = returnNat (toOL [CALL (Left target) 0 True, NOP])
2844   where
2845     target = ImmCLbl lbl
2846
2847 genJump dsts tree
2848   = getRegister tree                        `thenNat` \ register ->
2849     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2850     let
2851         code   = registerCode register tmp
2852         target = registerName register tmp
2853     in
2854     returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2855
2856 #endif {- sparc_TARGET_ARCH -}
2857
2858 #if powerpc_TARGET_ARCH
2859 genJump dsts (StCLbl lbl)
2860     = returnNat (toOL [BCC ALWAYS lbl])
2861
2862 genJump dsts tree
2863   = getRegister tree                        `thenNat` \ register ->
2864     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2865     let
2866         code   = registerCode register tmp
2867         target = registerName register tmp
2868     in
2869     returnNat (code `snocOL` MTCTR target `snocOL` BCTR)
2870 #endif {- sparc_TARGET_ARCH -}
2871
2872 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2873
2874 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2875 \end{code}
2876
2877 %************************************************************************
2878 %*                                                                      *
2879 \subsection{Conditional jumps}
2880 %*                                                                      *
2881 %************************************************************************
2882
2883 Conditional jumps are always to local labels, so we can use branch
2884 instructions.  We peek at the arguments to decide what kind of
2885 comparison to do.
2886
2887 ALPHA: For comparisons with 0, we're laughing, because we can just do
2888 the desired conditional branch.
2889
2890 I386: First, we have to ensure that the condition
2891 codes are set according to the supplied comparison operation.
2892
2893 SPARC: First, we have to ensure that the condition codes are set
2894 according to the supplied comparison operation.  We generate slightly
2895 different code for floating point comparisons, because a floating
2896 point operation cannot directly precede a @BF@.  We assume the worst
2897 and fill that slot with a @NOP@.
2898
2899 SPARC: Do not fill the delay slots here; you will confuse the register
2900 allocator.
2901
2902 \begin{code}
2903 genCondJump
2904     :: CLabel       -- the branch target
2905     -> StixExpr     -- the condition on which to branch
2906     -> NatM InstrBlock
2907
2908 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2909
2910 #if alpha_TARGET_ARCH
2911
2912 genCondJump lbl (StPrim op [x, StInt 0])
2913   = getRegister x                           `thenNat` \ register ->
2914     getNewRegNCG (registerRep register)
2915                                     `thenNat` \ tmp ->
2916     let
2917         code   = registerCode register tmp
2918         value  = registerName register tmp
2919         pk     = registerRep register
2920         target = ImmCLbl lbl
2921     in
2922     returnSeq code [BI (cmpOp op) value target]
2923   where
2924     cmpOp CharGtOp = GTT
2925     cmpOp CharGeOp = GE
2926     cmpOp CharEqOp = EQQ
2927     cmpOp CharNeOp = NE
2928     cmpOp CharLtOp = LTT
2929     cmpOp CharLeOp = LE
2930     cmpOp IntGtOp = GTT
2931     cmpOp IntGeOp = GE
2932     cmpOp IntEqOp = EQQ
2933     cmpOp IntNeOp = NE
2934     cmpOp IntLtOp = LTT
2935     cmpOp IntLeOp = LE
2936     cmpOp WordGtOp = NE
2937     cmpOp WordGeOp = ALWAYS
2938     cmpOp WordEqOp = EQQ
2939     cmpOp WordNeOp = NE
2940     cmpOp WordLtOp = NEVER
2941     cmpOp WordLeOp = EQQ
2942     cmpOp AddrGtOp = NE
2943     cmpOp AddrGeOp = ALWAYS
2944     cmpOp AddrEqOp = EQQ
2945     cmpOp AddrNeOp = NE
2946     cmpOp AddrLtOp = NEVER
2947     cmpOp AddrLeOp = EQQ
2948
2949 genCondJump lbl (StPrim op [x, StDouble 0.0])
2950   = getRegister x                           `thenNat` \ register ->
2951     getNewRegNCG (registerRep register)
2952                                     `thenNat` \ tmp ->
2953     let
2954         code   = registerCode register tmp
2955         value  = registerName register tmp
2956         pk     = registerRep register
2957         target = ImmCLbl lbl
2958     in
2959     returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2960   where
2961     cmpOp FloatGtOp = GTT
2962     cmpOp FloatGeOp = GE
2963     cmpOp FloatEqOp = EQQ
2964     cmpOp FloatNeOp = NE
2965     cmpOp FloatLtOp = LTT
2966     cmpOp FloatLeOp = LE
2967     cmpOp DoubleGtOp = GTT
2968     cmpOp DoubleGeOp = GE
2969     cmpOp DoubleEqOp = EQQ
2970     cmpOp DoubleNeOp = NE
2971     cmpOp DoubleLtOp = LTT
2972     cmpOp DoubleLeOp = LE
2973
2974 genCondJump lbl (StPrim op [x, y])
2975   | fltCmpOp op
2976   = trivialFCode pr instr x y       `thenNat` \ register ->
2977     getNewRegNCG DoubleRep          `thenNat` \ tmp ->
2978     let
2979         code   = registerCode register tmp
2980         result = registerName register tmp
2981         target = ImmCLbl lbl
2982     in
2983     returnNat (code . mkSeqInstr (BF cond result target))
2984   where
2985     pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2986
2987     fltCmpOp op = case op of
2988         FloatGtOp -> True
2989         FloatGeOp -> True
2990         FloatEqOp -> True
2991         FloatNeOp -> True
2992         FloatLtOp -> True
2993         FloatLeOp -> True
2994         DoubleGtOp -> True
2995         DoubleGeOp -> True
2996         DoubleEqOp -> True
2997         DoubleNeOp -> True
2998         DoubleLtOp -> True
2999         DoubleLeOp -> True
3000         _ -> False
3001     (instr, cond) = case op of
3002         FloatGtOp -> (FCMP TF LE, EQQ)
3003         FloatGeOp -> (FCMP TF LTT, EQQ)
3004         FloatEqOp -> (FCMP TF EQQ, NE)
3005         FloatNeOp -> (FCMP TF EQQ, EQQ)
3006         FloatLtOp -> (FCMP TF LTT, NE)
3007         FloatLeOp -> (FCMP TF LE, NE)
3008         DoubleGtOp -> (FCMP TF LE, EQQ)
3009         DoubleGeOp -> (FCMP TF LTT, EQQ)
3010         DoubleEqOp -> (FCMP TF EQQ, NE)
3011         DoubleNeOp -> (FCMP TF EQQ, EQQ)
3012         DoubleLtOp -> (FCMP TF LTT, NE)
3013         DoubleLeOp -> (FCMP TF LE, NE)
3014
3015 genCondJump lbl (StPrim op [x, y])
3016   = trivialCode instr x y           `thenNat` \ register ->
3017     getNewRegNCG IntRep             `thenNat` \ tmp ->
3018     let
3019         code   = registerCode register tmp
3020         result = registerName register tmp
3021         target = ImmCLbl lbl
3022     in
3023     returnNat (code . mkSeqInstr (BI cond result target))
3024   where
3025     (instr, cond) = case op of
3026         CharGtOp -> (CMP LE, EQQ)
3027         CharGeOp -> (CMP LTT, EQQ)
3028         CharEqOp -> (CMP EQQ, NE)
3029         CharNeOp -> (CMP EQQ, EQQ)
3030         CharLtOp -> (CMP LTT, NE)
3031         CharLeOp -> (CMP LE, NE)
3032         IntGtOp -> (CMP LE, EQQ)
3033         IntGeOp -> (CMP LTT, EQQ)
3034         IntEqOp -> (CMP EQQ, NE)
3035         IntNeOp -> (CMP EQQ, EQQ)
3036         IntLtOp -> (CMP LTT, NE)
3037         IntLeOp -> (CMP LE, NE)
3038         WordGtOp -> (CMP ULE, EQQ)
3039         WordGeOp -> (CMP ULT, EQQ)
3040         WordEqOp -> (CMP EQQ, NE)
3041         WordNeOp -> (CMP EQQ, EQQ)
3042         WordLtOp -> (CMP ULT, NE)
3043         WordLeOp -> (CMP ULE, NE)
3044         AddrGtOp -> (CMP ULE, EQQ)
3045         AddrGeOp -> (CMP ULT, EQQ)
3046         AddrEqOp -> (CMP EQQ, NE)
3047         AddrNeOp -> (CMP EQQ, EQQ)
3048         AddrLtOp -> (CMP ULT, NE)
3049         AddrLeOp -> (CMP ULE, NE)
3050
3051 #endif {- alpha_TARGET_ARCH -}
3052
3053 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3054
3055 #if i386_TARGET_ARCH
3056
3057 genCondJump lbl bool
3058   = getCondCode bool                `thenNat` \ condition ->
3059     let
3060         code   = condCode condition
3061         cond   = condName condition
3062     in
3063     returnNat (code `snocOL` JXX cond lbl)
3064
3065 #endif {- i386_TARGET_ARCH -}
3066
3067 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3068
3069 #if sparc_TARGET_ARCH
3070
3071 genCondJump lbl bool
3072   = getCondCode bool                `thenNat` \ condition ->
3073     let
3074         code   = condCode condition
3075         cond   = condName condition
3076         target = ImmCLbl lbl
3077     in
3078     returnNat (
3079        code `appOL`
3080        toOL (
3081          if   condFloat condition
3082          then [NOP, BF cond False target, NOP]
3083          else [BI cond False target, NOP]
3084        )
3085     )
3086
3087 #endif {- sparc_TARGET_ARCH -}
3088
3089 #if powerpc_TARGET_ARCH
3090
3091 genCondJump lbl bool
3092   = getCondCode bool                `thenNat` \ condition ->
3093     let
3094         code   = condCode condition
3095         cond   = condName condition
3096         target = ImmCLbl lbl
3097     in
3098     returnNat (
3099        code `snocOL` BCC cond lbl    )
3100
3101 #endif {- powerpc_TARGET_ARCH -}
3102
3103 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3104
3105 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3106 \end{code}
3107
3108 %************************************************************************
3109 %*                                                                      *
3110 \subsection{Generating C calls}
3111 %*                                                                      *
3112 %************************************************************************
3113
3114 Now the biggest nightmare---calls.  Most of the nastiness is buried in
3115 @get_arg@, which moves the arguments to the correct registers/stack
3116 locations.  Apart from that, the code is easy.
3117
3118 (If applicable) Do not fill the delay slots here; you will confuse the
3119 register allocator.
3120
3121 \begin{code}
3122 genCCall
3123     :: (Either FastString StixExpr)     -- function to call
3124     -> CCallConv
3125     -> PrimRep          -- type of the result
3126     -> [StixExpr]       -- arguments (of mixed type)
3127     -> NatM InstrBlock
3128
3129 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3130
3131 #if alpha_TARGET_ARCH
3132
3133 genCCall fn cconv kind args
3134   = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
3135                           `thenNat` \ ((unused,_), argCode) ->
3136     let
3137         nRegs = length allArgRegs - length unused
3138         code = asmSeqThen (map ($ []) argCode)
3139     in
3140         returnSeq code [
3141             LDA pv (AddrImm (ImmLab (ptext fn))),
3142             JSR ra (AddrReg pv) nRegs,
3143             LDGP gp (AddrReg ra)]
3144   where
3145     ------------------------
3146     {-  Try to get a value into a specific register (or registers) for
3147         a call.  The first 6 arguments go into the appropriate
3148         argument register (separate registers for integer and floating
3149         point arguments, but used in lock-step), and the remaining
3150         arguments are dumped to the stack, beginning at 0(sp).  Our
3151         first argument is a pair of the list of remaining argument
3152         registers to be assigned for this call and the next stack
3153         offset to use for overflowing arguments.  This way,
3154         @get_Arg@ can be applied to all of a call's arguments using
3155         @mapAccumLNat@.
3156     -}
3157     get_arg
3158         :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
3159         -> StixTree             -- Current argument
3160         -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
3161
3162     -- We have to use up all of our argument registers first...
3163
3164     get_arg ((iDst,fDst):dsts, offset) arg
3165       = getRegister arg                     `thenNat` \ register ->
3166         let
3167             reg  = if isFloatingRep pk then fDst else iDst
3168             code = registerCode register reg
3169             src  = registerName register reg
3170             pk   = registerRep register
3171         in
3172         returnNat (
3173             if isFloatingRep pk then
3174                 ((dsts, offset), if isFixed register then
3175                     code . mkSeqInstr (FMOV src fDst)
3176                     else code)
3177             else
3178                 ((dsts, offset), if isFixed register then
3179                     code . mkSeqInstr (OR src (RIReg src) iDst)
3180                     else code))
3181
3182     -- Once we have run out of argument registers, we move to the
3183     -- stack...
3184
3185     get_arg ([], offset) arg
3186       = getRegister arg                 `thenNat` \ register ->
3187         getNewRegNCG (registerRep register)
3188                                         `thenNat` \ tmp ->
3189         let
3190             code = registerCode register tmp
3191             src  = registerName register tmp
3192             pk   = registerRep register
3193             sz   = primRepToSize pk
3194         in
3195         returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
3196
3197 #endif {- alpha_TARGET_ARCH -}
3198
3199 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3200
3201 #if i386_TARGET_ARCH
3202
3203 genCCall fn cconv ret_rep args
3204   = mapNat push_arg
3205            (reverse args)       `thenNat` \ sizes_n_codes ->
3206     getDeltaNat                 `thenNat` \ delta ->
3207     let (sizes, push_codes) = unzip sizes_n_codes
3208         tot_arg_size        = sum sizes
3209     in
3210     -- deal with static vs dynamic call targets
3211     (case fn of
3212         Left t_static
3213            -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
3214         Right dyn
3215            -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
3216               ASSERT(case dyn_rep of { L -> True; _ -> False})
3217               returnNat (dyn_c `snocOL` CALL (Right dyn_r))
3218     )
3219                                 `thenNat` \ callinsns ->
3220     let push_code = concatOL push_codes
3221         call = callinsns `appOL`
3222                toOL (
3223                         -- Deallocate parameters after call for ccall;
3224                         -- but not for stdcall (callee does it)
3225                   (if cconv == StdCallConv then [] else
3226                    [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
3227                   ++
3228                   [DELTA (delta + tot_arg_size)]
3229                )
3230     in
3231     setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
3232     returnNat (push_code `appOL` call)
3233
3234   where
3235     -- function names that begin with '.' are assumed to be special
3236     -- internally generated names like '.mul,' which don't get an
3237     -- underscore prefix
3238     -- ToDo:needed (WDP 96/03) ???
3239     fn_u  = unpackFS (unLeft fn)
3240     fn__2 tot_arg_size
3241        | head fn_u == '.'
3242        = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
3243        | otherwise      -- General case
3244        = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
3245
3246     stdcallsize tot_arg_size
3247        | cconv == StdCallConv = '@':show tot_arg_size
3248        | otherwise            = ""
3249
3250     arg_size DF = 8
3251     arg_size F  = 4
3252     arg_size _  = 4
3253
3254     ------------
3255     push_arg :: StixExpr{-current argument-}
3256                     -> NatM (Int, InstrBlock)  -- argsz, code
3257
3258     push_arg arg
3259       | is64BitRep arg_rep
3260       = iselExpr64 arg                  `thenNat` \ (ChildCode64 code vr_lo) ->
3261         getDeltaNat                     `thenNat` \ delta ->
3262         setDeltaNat (delta - 8)         `thenNat` \ _ ->
3263         let r_lo = VirtualRegI vr_lo
3264             r_hi = getHiVRegFromLo r_lo
3265         in  returnNat (8,
3266                        code `appOL`
3267                        toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
3268                              PUSH L (OpReg r_lo), DELTA (delta - 8)]
3269             )
3270       | otherwise
3271       = get_op arg                      `thenNat` \ (code, reg, sz) ->
3272         getDeltaNat                     `thenNat` \ delta ->
3273         arg_size sz                     `bind`    \ size ->
3274         setDeltaNat (delta-size)        `thenNat` \ _ ->
3275         if   (case sz of DF -> True; F -> True; _ -> False)
3276         then returnNat (size,
3277                         code `appOL`
3278                         toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
3279                               DELTA (delta-size),
3280                               GST sz reg (AddrBaseIndex (Just esp)
3281                                                         Nothing
3282                                                         (ImmInt 0))]
3283                        )
3284         else returnNat (size,
3285                         code `snocOL`
3286                         PUSH L (OpReg reg) `snocOL`
3287                         DELTA (delta-size)
3288                        )
3289       where
3290          arg_rep = repOfStixExpr arg
3291
3292     ------------
3293     get_op
3294         :: StixExpr
3295         -> NatM (InstrBlock, Reg, Size) -- code, reg, size
3296
3297     get_op op
3298       = getRegister op          `thenNat` \ register ->
3299         getNewRegNCG (registerRep register)
3300                                 `thenNat` \ tmp ->
3301         let
3302             code = registerCode register tmp
3303             reg  = registerName register tmp
3304             pk   = registerRep  register
3305             sz   = primRepToSize pk
3306         in
3307         returnNat (code, reg, sz)
3308
3309 #endif {- i386_TARGET_ARCH -}
3310
3311 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3312
3313 #if sparc_TARGET_ARCH
3314 {-
3315    The SPARC calling convention is an absolute
3316    nightmare.  The first 6x32 bits of arguments are mapped into
3317    %o0 through %o5, and the remaining arguments are dumped to the
3318    stack, beginning at [%sp+92].  (Note that %o6 == %sp.)
3319
3320    If we have to put args on the stack, move %o6==%sp down by
3321    the number of words to go on the stack, to ensure there's enough space.
3322
3323    According to Fraser and Hanson's lcc book, page 478, fig 17.2,
3324    16 words above the stack pointer is a word for the address of
3325    a structure return value.  I use this as a temporary location
3326    for moving values from float to int regs.  Certainly it isn't
3327    safe to put anything in the 16 words starting at %sp, since
3328    this area can get trashed at any time due to window overflows
3329    caused by signal handlers.
3330
3331    A final complication (if the above isn't enough) is that
3332    we can't blithely calculate the arguments one by one into
3333    %o0 .. %o5.  Consider the following nested calls:
3334
3335        fff a (fff b c)
3336
3337    Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately
3338    the inner call will itself use %o0, which trashes the value put there
3339    in preparation for the outer call.  Upshot: we need to calculate the
3340    args into temporary regs, and move those to arg regs or onto the
3341    stack only immediately prior to the call proper.  Sigh.
3342 -}
3343
3344 genCCall fn cconv kind args
3345   = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
3346     let
3347         (argcodes, vregss) = unzip argcode_and_vregs
3348         n_argRegs          = length allArgRegs
3349         n_argRegs_used     = min (length vregs) n_argRegs
3350         vregs              = concat vregss
3351     in
3352     -- deal with static vs dynamic call targets
3353     (case fn of
3354         Left t_static
3355            -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
3356         Right dyn
3357            -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
3358               returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
3359     )
3360                                 `thenNat` \ callinsns ->
3361     let
3362         argcode = concatOL argcodes
3363         (move_sp_down, move_sp_up)
3364            = let diff = length vregs - n_argRegs
3365                  nn   = if odd diff then diff + 1 else diff -- keep 8-byte alignment
3366              in  if   nn <= 0
3367                  then (nilOL, nilOL)
3368                  else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
3369         transfer_code
3370            = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
3371     in
3372         returnNat (argcode       `appOL`
3373                    move_sp_down  `appOL`
3374                    transfer_code `appOL`
3375                    callinsns     `appOL`
3376                    unitOL NOP    `appOL`
3377                    move_sp_up)
3378   where
3379      -- function names that begin with '.' are assumed to be special
3380      -- internally generated names like '.mul,' which don't get an
3381      -- underscore prefix
3382      -- ToDo:needed (WDP 96/03) ???
3383      fn_static = unLeft fn
3384      fn__2 = case (headFS fn_static) of
3385                 '.' -> ImmLit (ftext fn_static)
3386                 _   -> ImmLab False (ftext fn_static)
3387
3388      -- move args from the integer vregs into which they have been
3389      -- marshalled, into %o0 .. %o5, and the rest onto the stack.
3390      move_final :: [Reg] -> [Reg] -> Int -> [Instr]
3391
3392      move_final [] _ offset          -- all args done
3393         = []
3394
3395      move_final (v:vs) [] offset     -- out of aregs; move to stack
3396         = ST W v (spRel offset)
3397           : move_final vs [] (offset+1)
3398
3399      move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
3400         = OR False g0 (RIReg v) a
3401           : move_final vs az offset
3402
3403      -- generate code to calculate an argument, and move it into one
3404      -- or two integer vregs.
3405      arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
3406      arg_to_int_vregs arg
3407         | is64BitRep (repOfStixExpr arg)
3408         = iselExpr64 arg                `thenNat` \ (ChildCode64 code vr_lo) ->
3409           let r_lo = VirtualRegI vr_lo
3410               r_hi = getHiVRegFromLo r_lo
3411           in  returnNat (code, [r_hi, r_lo])
3412         | otherwise
3413         = getRegister arg                     `thenNat` \ register ->
3414           getNewRegNCG (registerRep register) `thenNat` \ tmp ->
3415           let code = registerCode register tmp
3416               src  = registerName register tmp
3417               pk   = registerRep register
3418           in
3419           -- the value is in src.  Get it into 1 or 2 int vregs.
3420           case pk of
3421              DoubleRep ->
3422                 getNewRegNCG WordRep  `thenNat` \ v1 ->
3423                 getNewRegNCG WordRep  `thenNat` \ v2 ->
3424                 returnNat (
3425                    code                          `snocOL`
3426                    FMOV DF src f0                `snocOL`
3427                    ST   F  f0 (spRel 16)         `snocOL`
3428                    LD   W  (spRel 16) v1         `snocOL`
3429                    ST   F  (fPair f0) (spRel 16) `snocOL`
3430                    LD   W  (spRel 16) v2
3431                    ,
3432                    [v1,v2]
3433                 )
3434              FloatRep ->
3435                 getNewRegNCG WordRep  `thenNat` \ v1 ->
3436                 returnNat (
3437                    code                    `snocOL`
3438                    ST   F  src (spRel 16)  `snocOL`
3439                    LD   W  (spRel 16) v1
3440                    ,
3441                    [v1]
3442                 )
3443              other ->
3444                 getNewRegNCG WordRep  `thenNat` \ v1 ->
3445                 returnNat (
3446                    code `snocOL` OR False g0 (RIReg src) v1
3447                    ,
3448                    [v1]
3449                 )
3450 #endif {- sparc_TARGET_ARCH -}
3451
3452 #if powerpc_TARGET_ARCH
3453 {-
3454     The PowerPC calling convention (at least for Darwin/Mac OS X)
3455     is described in Apple's document
3456     "Inside Mac OS X - Mach-O Runtime Architecture".
3457     Parameters may be passed in general-purpose registers, in
3458     floating point registers, or on the stack. Stack space is
3459     always reserved for parameters, even if they are passed in registers.
3460     The called routine may choose to save parameters from registers
3461     to the corresponding space on the stack.
3462     The parameter area should be part of the caller's stack frame,
3463     allocated in the caller's prologue code (large enough to hold
3464     the parameter lists for all called routines). The NCG already
3465     uses the space that we should use as a parameter area for register
3466     spilling, so we allocate a new stack frame just before ccalling.
3467     That way we don't need to decide beforehand how much space to
3468     reserve for parameters.
3469 -}
3470
3471 genCCall fn cconv kind args
3472   = mapNat prepArg args `thenNat` \ preppedArgs ->
3473     let
3474         (argReps,argCodes,vregs) = unzip3 preppedArgs
3475
3476             -- size of linkage area + size of arguments, in bytes
3477         stackDelta = roundTo16 $ (24 +) $ (4 *) $ sum $ map getPrimRepSize argReps
3478         roundTo16 x | x `mod` 16 == 0 = x
3479                     | otherwise = x + 16 - (x `mod` 16)
3480
3481         move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
3482         move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
3483
3484         (moveFinalCode,usedRegs) = move_final
3485                                         (zip vregs argReps)
3486                                         allArgRegs allFPArgRegs
3487                                         eXTRA_STK_ARGS_HERE
3488                                         (toOL []) []
3489
3490         passArguments = concatOL argCodes
3491             `appOL` move_sp_down
3492             `appOL` moveFinalCode
3493     in
3494         case fn of
3495             Left lbl -> returnNat (     passArguments
3496                             `snocOL`    BL (ImmLab False (ftext lbl)) usedRegs
3497                             `appOL`     move_sp_up)
3498             Right dyn ->
3499                 getRegister dyn                         `thenNat` \ dynReg ->
3500                 getNewRegNCG (registerRep dynReg)       `thenNat` \ tmp ->
3501                 returnNat (registerCode dynReg tmp
3502                             `appOL`     passArguments
3503                             `snocOL`    MTCTR (registerName dynReg tmp)
3504                             `snocOL`    BCTRL usedRegs
3505                             `appOL`     move_sp_up)
3506     where
3507     prepArg arg
3508         | is64BitRep (repOfStixExpr arg)
3509         = iselExpr64 arg                `thenNat` \ (ChildCode64 code vr_lo) ->
3510           let r_lo = VirtualRegI vr_lo
3511               r_hi = getHiVRegFromLo r_lo
3512           in  returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
3513         | otherwise
3514         = getRegister arg                       `thenNat` \ register ->
3515           getNewRegNCG (registerRep register)   `thenNat` \ tmp ->
3516           returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
3517     move_final [] _ _ _ accumCode accumUsed = (accumCode, accumUsed)
3518     move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
3519         | not (is64BitRep rep) =
3520         case rep of
3521             FloatRep ->
3522                 move_final vregs (drop 1 gprs) (drop 1 fprs) (stackOffset+4)
3523                     (accumCode `snocOL`
3524                         (case fprs of
3525                             fpr : fprs -> MR fpr vr
3526                             [] -> ST F vr (AddrRegImm sp (ImmInt stackOffset))))
3527                     ((take 1 fprs) ++ accumUsed)
3528             DoubleRep ->
3529                 move_final vregs (drop 2 gprs) (drop 1 fprs) (stackOffset+8)
3530                     (accumCode `snocOL`
3531                         (case fprs of
3532                             fpr : fprs -> MR fpr vr
3533                             [] -> ST DF vr (AddrRegImm sp (ImmInt stackOffset))))
3534                     ((take 1 fprs) ++ accumUsed)
3535             VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
3536             _ ->
3537                 move_final vregs (drop 1 gprs) fprs (stackOffset+4)
3538                     (accumCode `snocOL`
3539                         (case gprs of
3540                             gpr : gprs -> MR gpr vr
3541                             [] -> ST W vr (AddrRegImm sp (ImmInt stackOffset))))
3542                     ((take 1 gprs) ++ accumUsed)
3543
3544     move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
3545         | is64BitRep rep =
3546         let
3547             storeWord vr (gpr:_) offset = MR gpr vr
3548             storeWord vr [] offset = ST W vr (AddrRegImm sp (ImmInt offset))
3549         in
3550             move_final vregs (drop 2 gprs) fprs (stackOffset+8)
3551                 (accumCode
3552                     `snocOL` storeWord vr_hi gprs stackOffset
3553                     `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
3554                 ((take 2 gprs) ++ accumUsed)
3555 #endif {- powerpc_TARGET_ARCH -}
3556
3557 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3558 \end{code}
3559
3560 %************************************************************************
3561 %*                                                                      *
3562 \subsection{Support bits}
3563 %*                                                                      *
3564 %************************************************************************
3565
3566 %************************************************************************
3567 %*                                                                      *
3568 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
3569 %*                                                                      *
3570 %************************************************************************
3571
3572 Turn those condition codes into integers now (when they appear on
3573 the right hand side of an assignment).
3574
3575 (If applicable) Do not fill the delay slots here; you will confuse the
3576 register allocator.
3577
3578 \begin{code}
3579 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
3580
3581 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3582
3583 #if alpha_TARGET_ARCH
3584 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
3585 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
3586 #endif {- alpha_TARGET_ARCH -}
3587
3588 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3589
3590 #if i386_TARGET_ARCH
3591
3592 condIntReg cond x y
3593   = condIntCode cond x y        `thenNat` \ condition ->
3594     getNewRegNCG IntRep         `thenNat` \ tmp ->
3595     let
3596         code = condCode condition
3597         cond = condName condition
3598         code__2 dst = code `appOL` toOL [
3599             SETCC cond (OpReg tmp),
3600             AND L (OpImm (ImmInt 1)) (OpReg tmp),
3601             MOV L (OpReg tmp) (OpReg dst)]
3602     in
3603     returnNat (Any IntRep code__2)
3604
3605 condFltReg cond x y
3606   = getNatLabelNCG              `thenNat` \ lbl1 ->
3607     getNatLabelNCG              `thenNat` \ lbl2 ->
3608     condFltCode cond x y        `thenNat` \ condition ->
3609     let
3610         code = condCode condition
3611         cond = condName condition
3612         code__2 dst = code `appOL` toOL [
3613             JXX cond lbl1,
3614             MOV L (OpImm (ImmInt 0)) (OpReg dst),
3615             JXX ALWAYS lbl2,
3616             LABEL lbl1,
3617             MOV L (OpImm (ImmInt 1)) (OpReg dst),
3618             LABEL lbl2]
3619     in
3620     returnNat (Any IntRep code__2)
3621
3622 #endif {- i386_TARGET_ARCH -}
3623
3624 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3625
3626 #if sparc_TARGET_ARCH
3627
3628 condIntReg EQQ x (StInt 0)
3629   = getRegister x               `thenNat` \ register ->
3630     getNewRegNCG IntRep         `thenNat` \ tmp ->
3631     let
3632         code = registerCode register tmp
3633         src  = registerName register tmp
3634         code__2 dst = code `appOL` toOL [
3635             SUB False True g0 (RIReg src) g0,
3636             SUB True False g0 (RIImm (ImmInt (-1))) dst]
3637     in
3638     returnNat (Any IntRep code__2)
3639
3640 condIntReg EQQ x y
3641   = getRegister x               `thenNat` \ register1 ->
3642     getRegister y               `thenNat` \ register2 ->
3643     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3644     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3645     let
3646         code1 = registerCode register1 tmp1
3647         src1  = registerName register1 tmp1
3648         code2 = registerCode register2 tmp2
3649         src2  = registerName register2 tmp2
3650         code__2 dst = code1 `appOL` code2 `appOL` toOL [
3651             XOR False src1 (RIReg src2) dst,
3652             SUB False True g0 (RIReg dst) g0,
3653             SUB True False g0 (RIImm (ImmInt (-1))) dst]
3654     in
3655     returnNat (Any IntRep code__2)
3656
3657 condIntReg NE x (StInt 0)
3658   = getRegister x               `thenNat` \ register ->
3659     getNewRegNCG IntRep         `thenNat` \ tmp ->
3660     let
3661         code = registerCode register tmp
3662         src  = registerName register tmp
3663         code__2 dst = code `appOL` toOL [
3664             SUB False True g0 (RIReg src) g0,
3665             ADD True False g0 (RIImm (ImmInt 0)) dst]
3666     in
3667     returnNat (Any IntRep code__2)
3668
3669 condIntReg NE x y
3670   = getRegister x               `thenNat` \ register1 ->
3671     getRegister y               `thenNat` \ register2 ->
3672     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3673     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3674     let
3675         code1 = registerCode register1 tmp1
3676         src1  = registerName register1 tmp1
3677         code2 = registerCode register2 tmp2
3678         src2  = registerName register2 tmp2
3679         code__2 dst = code1 `appOL` code2 `appOL` toOL [
3680             XOR False src1 (RIReg src2) dst,
3681             SUB False True g0 (RIReg dst) g0,
3682             ADD True False g0 (RIImm (ImmInt 0)) dst]
3683     in
3684     returnNat (Any IntRep code__2)
3685
3686 condIntReg cond x y
3687   = getNatLabelNCG              `thenNat` \ lbl1 ->
3688     getNatLabelNCG              `thenNat` \ lbl2 ->
3689     condIntCode cond x y        `thenNat` \ condition ->
3690     let
3691         code = condCode condition
3692         cond = condName condition
3693         code__2 dst = code `appOL` toOL [
3694             BI cond False (ImmCLbl lbl1), NOP,
3695             OR False g0 (RIImm (ImmInt 0)) dst,
3696             BI ALWAYS False (ImmCLbl lbl2), NOP,
3697             LABEL lbl1,
3698             OR False g0 (RIImm (ImmInt 1)) dst,
3699             LABEL lbl2]
3700     in
3701     returnNat (Any IntRep code__2)
3702
3703 condFltReg cond x y
3704   = getNatLabelNCG              `thenNat` \ lbl1 ->
3705     getNatLabelNCG              `thenNat` \ lbl2 ->
3706     condFltCode cond x y        `thenNat` \ condition ->
3707     let
3708         code = condCode condition
3709         cond = condName condition
3710         code__2 dst = code `appOL` toOL [
3711             NOP,
3712             BF cond False (ImmCLbl lbl1), NOP,
3713             OR False g0 (RIImm (ImmInt 0)) dst,
3714             BI ALWAYS False (ImmCLbl lbl2), NOP,
3715             LABEL lbl1,
3716             OR False g0 (RIImm (ImmInt 1)) dst,
3717             LABEL lbl2]
3718     in
3719     returnNat (Any IntRep code__2)
3720
3721 #endif {- sparc_TARGET_ARCH -}
3722
3723 #if powerpc_TARGET_ARCH
3724 condIntReg cond x y
3725   = getNatLabelNCG              `thenNat` \ lbl ->
3726     condIntCode cond x y        `thenNat` \ condition ->
3727     let
3728         code = condCode condition
3729         cond = condName condition
3730         code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
3731             BCC cond lbl,
3732             LI dst (ImmInt 0),
3733             LABEL lbl]
3734     in
3735     returnNat (Any IntRep code__2)
3736
3737 condFltReg cond x y
3738   = getNatLabelNCG              `thenNat` \ lbl ->
3739     condFltCode cond x y        `thenNat` \ condition ->
3740     let
3741         code = condCode condition
3742         cond = condName condition
3743         code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
3744             BCC cond lbl,
3745             LI dst (ImmInt 0),
3746             LABEL lbl]
3747     in
3748     returnNat (Any IntRep code__2)
3749 #endif {- powerpc_TARGET_ARCH -}
3750
3751 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3752 \end{code}
3753
3754 %************************************************************************
3755 %*                                                                      *
3756 \subsubsection{@trivial*Code@: deal with trivial instructions}
3757 %*                                                                      *
3758 %************************************************************************
3759
3760 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3761 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions.  Only look
3762 for constants on the right hand side, because that's where the generic
3763 optimizer will have put them.
3764
3765 Similarly, for unary instructions, we don't have to worry about
3766 matching an StInt as the argument, because genericOpt will already
3767 have handled the constant-folding.
3768
3769 \begin{code}
3770 trivialCode
3771     :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3772       ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3773                      -> Maybe (Operand -> Operand -> Instr)
3774       ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3775       ,IF_ARCH_powerpc((Reg -> Reg -> RI -> Instr)
3776       ,))))
3777     -> StixExpr -> StixExpr -- the two arguments
3778     -> NatM Register
3779
3780 trivialFCode
3781     :: PrimRep
3782     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3783       ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3784       ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3785       ,IF_ARCH_powerpc((Size -> Reg -> Reg -> Reg -> Instr)
3786       ,))))
3787     -> StixExpr -> StixExpr -- the two arguments
3788     -> NatM Register
3789
3790 trivialUCode
3791     :: IF_ARCH_alpha((RI -> Reg -> Instr)
3792       ,IF_ARCH_i386 ((Operand -> Instr)
3793       ,IF_ARCH_sparc((RI -> Reg -> Instr)
3794       ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
3795       ,))))
3796     -> StixExpr -- the one argument
3797     -> NatM Register
3798
3799 trivialUFCode
3800     :: PrimRep
3801     -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3802       ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3803       ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3804       ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
3805       ,))))
3806     -> StixExpr -- the one argument
3807     -> NatM Register
3808
3809 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3810
3811 #if alpha_TARGET_ARCH
3812
3813 trivialCode instr x (StInt y)
3814   | fits8Bits y
3815   = getRegister x               `thenNat` \ register ->
3816     getNewRegNCG IntRep         `thenNat` \ tmp ->
3817     let
3818         code = registerCode register tmp
3819         src1 = registerName register tmp
3820         src2 = ImmInt (fromInteger y)
3821         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3822     in
3823     returnNat (Any IntRep code__2)
3824
3825 trivialCode instr x y
3826   = getRegister x               `thenNat` \ register1 ->
3827     getRegister y               `thenNat` \ register2 ->
3828     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3829     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3830     let
3831         code1 = registerCode register1 tmp1 []
3832         src1  = registerName register1 tmp1
3833         code2 = registerCode register2 tmp2 []
3834         src2  = registerName register2 tmp2
3835         code__2 dst = asmSeqThen [code1, code2] .
3836                      mkSeqInstr (instr src1 (RIReg src2) dst)
3837     in
3838     returnNat (Any IntRep code__2)
3839
3840 ------------
3841 trivialUCode instr x
3842   = getRegister x               `thenNat` \ register ->
3843     getNewRegNCG IntRep         `thenNat` \ tmp ->
3844     let
3845         code = registerCode register tmp
3846         src  = registerName register tmp
3847         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3848     in
3849     returnNat (Any IntRep code__2)
3850
3851 ------------
3852 trivialFCode _ instr x y
3853   = getRegister x               `thenNat` \ register1 ->
3854     getRegister y               `thenNat` \ register2 ->
3855     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
3856     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
3857     let
3858         code1 = registerCode register1 tmp1
3859         src1  = registerName register1 tmp1
3860
3861         code2 = registerCode register2 tmp2
3862         src2  = registerName register2 tmp2
3863
3864         code__2 dst = asmSeqThen [code1 [], code2 []] .
3865                       mkSeqInstr (instr src1 src2 dst)
3866     in
3867     returnNat (Any DoubleRep code__2)
3868
3869 trivialUFCode _ instr x
3870   = getRegister x               `thenNat` \ register ->
3871     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3872     let
3873         code = registerCode register tmp
3874         src  = registerName register tmp
3875         code__2 dst = code . mkSeqInstr (instr src dst)
3876     in
3877     returnNat (Any DoubleRep code__2)
3878
3879 #endif {- alpha_TARGET_ARCH -}
3880
3881 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3882
3883 #if i386_TARGET_ARCH
3884 \end{code}
3885 The Rules of the Game are:
3886
3887 * You cannot assume anything about the destination register dst;
3888   it may be anything, including a fixed reg.
3889
3890 * You may compute an operand into a fixed reg, but you may not
3891   subsequently change the contents of that fixed reg.  If you
3892   want to do so, first copy the value either to a temporary
3893   or into dst.  You are free to modify dst even if it happens
3894   to be a fixed reg -- that's not your problem.
3895
3896 * You cannot assume that a fixed reg will stay live over an
3897   arbitrary computation.  The same applies to the dst reg.
3898
3899 * Temporary regs obtained from getNewRegNCG are distinct from
3900   each other and from all other regs, and stay live over
3901   arbitrary computations.
3902
3903 \begin{code}
3904
3905 trivialCode instr maybe_revinstr a b
3906
3907   | is_imm_b
3908   = getRegister a                         `thenNat` \ rega ->
3909     let mkcode dst
3910           = if   isAny rega
3911             then registerCode rega dst      `bind` \ code_a ->
3912                  code_a `snocOL`
3913                  instr (OpImm imm_b) (OpReg dst)
3914             else registerCodeF rega         `bind` \ code_a ->
3915                  registerNameF rega         `bind` \ r_a ->
3916                  code_a `snocOL`
3917                  MOV L (OpReg r_a) (OpReg dst) `snocOL`
3918                  instr (OpImm imm_b) (OpReg dst)
3919     in
3920     returnNat (Any IntRep mkcode)
3921
3922   | is_imm_a
3923   = getRegister b                         `thenNat` \ regb ->
3924     getNewRegNCG IntRep                   `thenNat` \ tmp ->
3925     let revinstr_avail = maybeToBool maybe_revinstr
3926         revinstr       = case maybe_revinstr of Just ri -> ri
3927         mkcode dst
3928           | revinstr_avail
3929           = if   isAny regb
3930             then registerCode regb dst      `bind` \ code_b ->
3931                  code_b `snocOL`
3932                  revinstr (OpImm imm_a) (OpReg dst)
3933             else registerCodeF regb         `bind` \ code_b ->
3934                  registerNameF regb         `bind` \ r_b ->
3935                  code_b `snocOL`
3936                  MOV L (OpReg r_b) (OpReg dst) `snocOL`
3937                  revinstr (OpImm imm_a) (OpReg dst)
3938
3939           | otherwise
3940           = if   isAny regb
3941             then registerCode regb tmp      `bind` \ code_b ->
3942                  code_b `snocOL`
3943                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3944                  instr (OpReg tmp) (OpReg dst)
3945             else registerCodeF regb         `bind` \ code_b ->
3946                  registerNameF regb         `bind` \ r_b ->
3947                  code_b `snocOL`
3948                  MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3949                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3950                  instr (OpReg tmp) (OpReg dst)
3951     in
3952     returnNat (Any IntRep mkcode)
3953
3954   | otherwise
3955   = getRegister a                         `thenNat` \ rega ->
3956     getRegister b                         `thenNat` \ regb ->
3957     getNewRegNCG IntRep                   `thenNat` \ tmp ->
3958     let mkcode dst
3959           = case (isAny rega, isAny regb) of
3960               (True, True)
3961                  -> registerCode regb tmp   `bind` \ code_b ->
3962                     registerCode rega dst   `bind` \ code_a ->
3963                     code_b `appOL`
3964                     code_a `snocOL`
3965                     instr (OpReg tmp) (OpReg dst)
3966               (True, False)
3967                  -> registerCode  rega tmp  `bind` \ code_a ->
3968                     registerCodeF regb      `bind` \ code_b ->
3969                     registerNameF regb      `bind` \ r_b ->
3970                     code_a `appOL`
3971                     code_b `snocOL`
3972                     instr (OpReg r_b) (OpReg tmp) `snocOL`
3973                     MOV L (OpReg tmp) (OpReg dst)
3974               (False, True)
3975                  -> registerCode  regb tmp  `bind` \ code_b ->
3976                     registerCodeF rega      `bind` \ code_a ->
3977                     registerNameF rega      `bind` \ r_a ->
3978                     code_b `appOL`
3979                     code_a `snocOL`
3980                     MOV L (OpReg r_a) (OpReg dst) `snocOL`
3981                     instr (OpReg tmp) (OpReg dst)
3982               (False, False)
3983                  -> registerCodeF  rega     `bind` \ code_a ->
3984                     registerNameF  rega     `bind` \ r_a ->
3985                     registerCodeF  regb     `bind` \ code_b ->
3986                     registerNameF  regb     `bind` \ r_b ->
3987                     code_a `snocOL`
3988                     MOV L (OpReg r_a) (OpReg tmp) `appOL`
3989                     code_b `snocOL`
3990                     instr (OpReg r_b) (OpReg tmp) `snocOL`
3991                     MOV L (OpReg tmp) (OpReg dst)
3992     in
3993     returnNat (Any IntRep mkcode)
3994
3995     where
3996        maybe_imm_a = maybeImm a
3997        is_imm_a    = maybeToBool maybe_imm_a
3998        imm_a       = case maybe_imm_a of Just imm -> imm
3999
4000        maybe_imm_b = maybeImm b
4001        is_imm_b    = maybeToBool maybe_imm_b
4002        imm_b       = case maybe_imm_b of Just imm -> imm
4003
4004
4005 -----------
4006 trivialUCode instr x
4007   = getRegister x               `thenNat` \ register ->
4008     let
4009         code__2 dst = let code = registerCode register dst
4010                           src  = registerName register dst
4011                       in code `appOL`
4012                          if   isFixed register && dst /= src
4013                          then toOL [MOV L (OpReg src) (OpReg dst),
4014                                     instr (OpReg dst)]
4015                          else unitOL (instr (OpReg src))
4016     in
4017     returnNat (Any IntRep code__2)
4018
4019 -----------
4020 trivialFCode pk instr x y
4021   = getRegister x               `thenNat` \ register1 ->
4022     getRegister y               `thenNat` \ register2 ->
4023     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
4024     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
4025     let
4026         code1 = registerCode register1 tmp1
4027         src1  = registerName register1 tmp1
4028
4029         code2 = registerCode register2 tmp2
4030         src2  = registerName register2 tmp2
4031
4032         code__2 dst
4033            -- treat the common case specially: both operands in
4034            -- non-fixed regs.
4035            | isAny register1 && isAny register2
4036            = code1 `appOL`
4037              code2 `snocOL`
4038              instr (primRepToSize pk) src1 src2 dst
4039
4040            -- be paranoid (and inefficient)
4041            | otherwise
4042            = code1 `snocOL` GMOV src1 tmp1  `appOL`
4043              code2 `snocOL`
4044              instr (primRepToSize pk) tmp1 src2 dst
4045     in
4046     returnNat (Any pk code__2)
4047
4048
4049 -------------
4050 trivialUFCode pk instr x
4051   = getRegister x               `thenNat` \ register ->
4052     getNewRegNCG pk             `thenNat` \ tmp ->
4053     let
4054         code = registerCode register tmp
4055         src  = registerName register tmp
4056         code__2 dst = code `snocOL` instr src dst
4057     in
4058     returnNat (Any pk code__2)
4059
4060 #endif {- i386_TARGET_ARCH -}
4061
4062 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4063
4064 #if sparc_TARGET_ARCH
4065
4066 trivialCode instr x (StInt y)
4067   | fits13Bits y
4068   = getRegister x               `thenNat` \ register ->
4069     getNewRegNCG IntRep         `thenNat` \ tmp ->
4070     let
4071         code = registerCode register tmp
4072         src1 = registerName register tmp
4073         src2 = ImmInt (fromInteger y)
4074         code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
4075     in
4076     returnNat (Any IntRep code__2)
4077
4078 trivialCode instr x y
4079   = getRegister x               `thenNat` \ register1 ->
4080     getRegister y               `thenNat` \ register2 ->
4081     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
4082     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
4083     let
4084         code1 = registerCode register1 tmp1
4085         src1  = registerName register1 tmp1
4086         code2 = registerCode register2 tmp2
4087         src2  = registerName register2 tmp2
4088         code__2 dst = code1 `appOL` code2 `snocOL`
4089                       instr src1 (RIReg src2) dst
4090     in
4091     returnNat (Any IntRep code__2)
4092
4093 ------------
4094 trivialFCode pk instr x y
4095   = getRegister x               `thenNat` \ register1 ->
4096     getRegister y               `thenNat` \ register2 ->
4097     getNewRegNCG (registerRep register1)
4098                                 `thenNat` \ tmp1 ->
4099     getNewRegNCG (registerRep register2)
4100                                 `thenNat` \ tmp2 ->
4101     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
4102     let
4103         promote x = FxTOy F DF x tmp
4104
4105         pk1   = registerRep register1
4106         code1 = registerCode register1 tmp1
4107         src1  = registerName register1 tmp1
4108
4109         pk2   = registerRep register2
4110         code2 = registerCode register2 tmp2
4111         src2  = registerName register2 tmp2
4112
4113         code__2 dst =
4114                 if pk1 == pk2 then
4115                     code1 `appOL` code2 `snocOL`
4116                     instr (primRepToSize pk) src1 src2 dst
4117                 else if pk1 == FloatRep then
4118                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
4119                     instr DF tmp src2 dst
4120                 else
4121                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
4122                     instr DF src1 tmp dst
4123     in
4124     returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
4125
4126 ------------
4127 trivialUCode instr x
4128   = getRegister x               `thenNat` \ register ->
4129     getNewRegNCG IntRep         `thenNat` \ tmp ->
4130     let
4131         code = registerCode register tmp
4132         src  = registerName register tmp
4133         code__2 dst = code `snocOL` instr (RIReg src) dst
4134     in
4135     returnNat (Any IntRep code__2)
4136
4137 -------------
4138 trivialUFCode pk instr x
4139   = getRegister x               `thenNat` \ register ->
4140     getNewRegNCG pk             `thenNat` \ tmp ->
4141     let
4142         code = registerCode register tmp
4143         src  = registerName register tmp
4144         code__2 dst = code `snocOL` instr src dst
4145     in
4146     returnNat (Any pk code__2)
4147
4148 #endif {- sparc_TARGET_ARCH -}
4149
4150 #if powerpc_TARGET_ARCH
4151 trivialCode instr x (StInt y)
4152   | fits16Bits y
4153   = getRegister x               `thenNat` \ register ->
4154     getNewRegNCG IntRep         `thenNat` \ tmp ->
4155     let
4156         code = registerCode register tmp
4157         src1 = registerName register tmp
4158         src2 = ImmInt (fromInteger y)
4159         code__2 dst = code `snocOL` instr dst src1 (RIImm src2)
4160     in
4161     returnNat (Any IntRep code__2)
4162
4163 trivialCode instr x y
4164   = getRegister x               `thenNat` \ register1 ->
4165     getRegister y               `thenNat` \ register2 ->
4166     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
4167     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
4168     let
4169         code1 = registerCode register1 tmp1
4170         src1  = registerName register1 tmp1
4171         code2 = registerCode register2 tmp2
4172         src2  = registerName register2 tmp2
4173         code__2 dst = code1 `appOL` code2 `snocOL`
4174                       instr dst src1 (RIReg src2)
4175     in
4176     returnNat (Any IntRep code__2)
4177
4178 trivialCode2 :: (Reg -> Reg -> Reg -> Instr)
4179     -> StixExpr -> StixExpr -> NatM Register
4180 trivialCode2 instr x y
4181   = getRegister x               `thenNat` \ register1 ->
4182     getRegister y               `thenNat` \ register2 ->
4183     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
4184     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
4185     let
4186         code1 = registerCode register1 tmp1
4187         src1  = registerName register1 tmp1
4188         code2 = registerCode register2 tmp2
4189         src2  = registerName register2 tmp2
4190         code__2 dst = code1 `appOL` code2 `snocOL`
4191                       instr dst src1 src2
4192     in
4193     returnNat (Any IntRep code__2)
4194
4195 trivialFCode pk instr x y
4196   = getRegister x               `thenNat` \ register1 ->
4197     getRegister y               `thenNat` \ register2 ->
4198     getNewRegNCG (registerRep register1)
4199                                 `thenNat` \ tmp1 ->
4200     getNewRegNCG (registerRep register2)
4201                                 `thenNat` \ tmp2 ->
4202     -- getNewRegNCG DoubleRep           `thenNat` \ tmp ->
4203     let
4204         -- promote x = FxTOy F DF x tmp
4205
4206         pk1   = registerRep register1
4207         code1 = registerCode register1 tmp1
4208         src1  = registerName register1 tmp1
4209
4210         pk2   = registerRep register2
4211         code2 = registerCode register2 tmp2
4212         src2  = registerName register2 tmp2
4213
4214         code__2 dst =
4215                 if pk1 == pk2 then
4216                     code1 `appOL` code2 `snocOL`
4217                     instr (primRepToSize pk) src1 src2 dst
4218                 else panic "###PPC MachCode.trivialFCode: type mismatch"
4219     in
4220     returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
4221
4222 trivialUCode instr x
4223   = getRegister x               `thenNat` \ register ->
4224     getNewRegNCG IntRep         `thenNat` \ tmp ->
4225     let
4226         code = registerCode register tmp
4227         src  = registerName register tmp
4228         code__2 dst = code `snocOL` instr dst src
4229     in
4230     returnNat (Any IntRep code__2)
4231 trivialUFCode pk instr x  = panic "###PPC MachCode.trivialUFCode"
4232 #endif {- powerpc_TARGET_ARCH -}
4233
4234 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4235 \end{code}
4236
4237 %************************************************************************
4238 %*                                                                      *
4239 \subsubsection{Coercing to/from integer/floating-point...}
4240 %*                                                                      *
4241 %************************************************************************
4242
4243 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
4244 conversions.  We have to store temporaries in memory to move
4245 between the integer and the floating point register sets.
4246
4247 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
4248 pretend, on sparc at least, that double and float regs are seperate
4249 kinds, so the value has to be computed into one kind before being
4250 explicitly "converted" to live in the other kind.
4251
4252 \begin{code}
4253 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
4254 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
4255
4256 coerceDbl2Flt :: StixExpr -> NatM Register
4257 coerceFlt2Dbl :: StixExpr -> NatM Register
4258 \end{code}
4259
4260 \begin{code}
4261 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4262
4263 #if alpha_TARGET_ARCH
4264
4265 coerceInt2FP _ x
4266   = getRegister x               `thenNat` \ register ->
4267     getNewRegNCG IntRep         `thenNat` \ reg ->
4268     let
4269         code = registerCode register reg
4270         src  = registerName register reg
4271
4272         code__2 dst = code . mkSeqInstrs [
4273             ST Q src (spRel 0),
4274             LD TF dst (spRel 0),
4275             CVTxy Q TF dst dst]
4276     in
4277     returnNat (Any DoubleRep code__2)
4278
4279 -------------
4280 coerceFP2Int x
4281   = getRegister x               `thenNat` \ register ->
4282     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
4283     let
4284         code = registerCode register tmp
4285         src  = registerName register tmp
4286
4287         code__2 dst = code . mkSeqInstrs [
4288             CVTxy TF Q src tmp,
4289             ST TF tmp (spRel 0),
4290             LD Q dst (spRel 0)]
4291     in
4292     returnNat (Any IntRep code__2)
4293
4294 #endif {- alpha_TARGET_ARCH -}
4295
4296 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4297
4298 #if i386_TARGET_ARCH
4299
4300 coerceInt2FP pk x
4301   = getRegister x               `thenNat` \ register ->
4302     getNewRegNCG IntRep         `thenNat` \ reg ->
4303     let
4304         code = registerCode register reg
4305         src  = registerName register reg
4306         opc  = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
4307         code__2 dst = code `snocOL` opc src dst
4308     in
4309     returnNat (Any pk code__2)
4310
4311 ------------
4312 coerceFP2Int fprep x
4313   = getRegister x               `thenNat` \ register ->
4314     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
4315     let
4316         code = registerCode register tmp
4317         src  = registerName register tmp
4318         pk   = registerRep register
4319
4320         opc  = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
4321         code__2 dst = code `snocOL` opc src dst
4322     in
4323     returnNat (Any IntRep code__2)
4324
4325 ------------
4326 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
4327 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
4328
4329 #endif {- i386_TARGET_ARCH -}
4330
4331 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4332
4333 #if sparc_TARGET_ARCH
4334
4335 coerceInt2FP pk x
4336   = getRegister x               `thenNat` \ register ->
4337     getNewRegNCG IntRep         `thenNat` \ reg ->
4338     let
4339         code = registerCode register reg
4340         src  = registerName register reg
4341
4342         code__2 dst = code `appOL` toOL [
4343             ST W src (spRel (-2)),
4344             LD W (spRel (-2)) dst,
4345             FxTOy W (primRepToSize pk) dst dst]
4346     in
4347     returnNat (Any pk code__2)
4348
4349 ------------
4350 coerceFP2Int fprep x
4351   = ASSERT(fprep == DoubleRep || fprep == FloatRep)
4352     getRegister x               `thenNat` \ register ->
4353     getNewRegNCG fprep          `thenNat` \ reg ->
4354     getNewRegNCG FloatRep       `thenNat` \ tmp ->
4355     let
4356         code = registerCode register reg
4357         src  = registerName register reg
4358         code__2 dst = code `appOL` toOL [
4359             FxTOy (primRepToSize fprep) W src tmp,
4360             ST W tmp (spRel (-2)),
4361             LD W (spRel (-2)) dst]
4362     in
4363     returnNat (Any IntRep code__2)
4364
4365 ------------
4366 coerceDbl2Flt x
4367   = getRegister x               `thenNat` \ register ->
4368     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
4369     let code = registerCode register tmp
4370         src  = registerName register tmp
4371     in
4372         returnNat (Any FloatRep
4373                        (\dst -> code `snocOL` FxTOy DF F src dst))
4374
4375 ------------
4376 coerceFlt2Dbl x
4377   = getRegister x               `thenNat` \ register ->
4378     getNewRegNCG FloatRep       `thenNat` \ tmp ->
4379     let code = registerCode register tmp
4380         src  = registerName register tmp
4381     in
4382         returnNat (Any DoubleRep
4383                        (\dst -> code `snocOL` FxTOy F DF src dst))
4384
4385 #endif {- sparc_TARGET_ARCH -}
4386
4387 #if powerpc_TARGET_ARCH
4388 coerceInt2FP pk x       = panic "###PPC MachCode.coerceInt2FP"
4389 coerceFP2Int fprep x    = panic "###PPC MachCode.coerceFP2Int"
4390 coerceDbl2Flt x         = panic "###PPC MachCode.coerceDbl2Flt"
4391 coerceFlt2Dbl x         = panic "###PPC MachCode.coerceFlt2Dbl"
4392 #endif {- powerpc_TARGET_ARCH -}
4393
4394 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4395 \end{code}