ghc/compiler/nativeGen/MachCode.lhs

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