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