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