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_NatU   -> integerExtend False 24 x
1269       MO_8S_to_NatS   -> integerExtend True  24 x
1270       MO_16U_to_NatU  -> integerExtend False 16 x
1271       MO_16S_to_NatS  -> integerExtend True  16 x
1272
1273       other_op ->
1274         let fixed_x = if   is_float_op  -- promote to double
1275                       then StMachOp MO_Flt_to_Dbl [x]
1276                       else x
1277         in
1278         getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x])
1279     where
1280         integerExtend signed nBits x
1281            = getRegister (
1282                 StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
1283                          [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
1284              )
1285         conversionNop new_rep expr
1286             = getRegister expr          `thenNat` \ e_code ->
1287               returnNat (swizzleRegisterRep e_code new_rep)
1288
1289         (is_float_op, fn)
1290           = case mop of
1291               MO_Flt_Exp    -> (True,  SLIT("exp"))
1292               MO_Flt_Log    -> (True,  SLIT("log"))
1293               MO_Flt_Sqrt   -> (True,  SLIT("sqrt"))
1294
1295               MO_Flt_Sin    -> (True,  SLIT("sin"))
1296               MO_Flt_Cos    -> (True,  SLIT("cos"))
1297               MO_Flt_Tan    -> (True,  SLIT("tan"))
1298
1299               MO_Flt_Asin   -> (True,  SLIT("asin"))
1300               MO_Flt_Acos   -> (True,  SLIT("acos"))
1301               MO_Flt_Atan   -> (True,  SLIT("atan"))
1302
1303               MO_Flt_Sinh   -> (True,  SLIT("sinh"))
1304               MO_Flt_Cosh   -> (True,  SLIT("cosh"))
1305               MO_Flt_Tanh   -> (True,  SLIT("tanh"))
1306
1307               MO_Dbl_Exp    -> (False, SLIT("exp"))
1308               MO_Dbl_Log    -> (False, SLIT("log"))
1309               MO_Dbl_Sqrt   -> (False, SLIT("sqrt"))
1310
1311               MO_Dbl_Sin    -> (False, SLIT("sin"))
1312               MO_Dbl_Cos    -> (False, SLIT("cos"))
1313               MO_Dbl_Tan    -> (False, SLIT("tan"))
1314
1315               MO_Dbl_Asin   -> (False, SLIT("asin"))
1316               MO_Dbl_Acos   -> (False, SLIT("acos"))
1317               MO_Dbl_Atan   -> (False, SLIT("atan"))
1318
1319               MO_Dbl_Sinh   -> (False, SLIT("sinh"))
1320               MO_Dbl_Cosh   -> (False, SLIT("cosh"))
1321               MO_Dbl_Tanh   -> (False, SLIT("tanh"))
1322
1323               other -> pprPanic "getRegister(sparc) - binary StMachOp (2)"
1324                                 (pprMachOp mop)
1325
1326
1327 getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
1328   = case mop of
1329       MO_32U_Gt  -> condIntReg GTT x y
1330       MO_32U_Ge  -> condIntReg GE x y
1331       MO_32U_Eq  -> condIntReg EQQ x y
1332       MO_32U_Ne  -> condIntReg NE x y
1333       MO_32U_Lt  -> condIntReg LTT x y
1334       MO_32U_Le  -> condIntReg LE x y
1335
1336       MO_Nat_Eq   -> condIntReg EQQ x y
1337       MO_Nat_Ne   -> condIntReg NE x y
1338
1339       MO_NatS_Gt  -> condIntReg GTT x y
1340       MO_NatS_Ge  -> condIntReg GE x y
1341       MO_NatS_Lt  -> condIntReg LTT x y
1342       MO_NatS_Le  -> condIntReg LE x y
1343
1344       MO_NatU_Gt  -> condIntReg GU  x y
1345       MO_NatU_Ge  -> condIntReg GEU x y
1346       MO_NatU_Lt  -> condIntReg LU  x y
1347       MO_NatU_Le  -> condIntReg LEU x y
1348
1349       MO_Flt_Gt -> condFltReg GTT x y
1350       MO_Flt_Ge -> condFltReg GE x y
1351       MO_Flt_Eq -> condFltReg EQQ x y
1352       MO_Flt_Ne -> condFltReg NE x y
1353       MO_Flt_Lt -> condFltReg LTT x y
1354       MO_Flt_Le -> condFltReg LE x y
1355
1356       MO_Dbl_Gt -> condFltReg GTT x y
1357       MO_Dbl_Ge -> condFltReg GE x y
1358       MO_Dbl_Eq -> condFltReg EQQ x y
1359       MO_Dbl_Ne -> condFltReg NE x y
1360       MO_Dbl_Lt -> condFltReg LTT x y
1361       MO_Dbl_Le -> condFltReg LE x y
1362
1363       MO_Nat_Add -> trivialCode (ADD False False) x y
1364       MO_Nat_Sub -> trivialCode (SUB False False) x y
1365
1366       MO_NatS_Mul  -> trivialCode (SMUL False) x y
1367       MO_NatU_Mul  -> trivialCode (UMUL False) x y
1368       MO_NatS_MulMayOflo -> imulMayOflo x y
1369
1370       -- ToDo: teach about V8+ SPARC div instructions
1371       MO_NatS_Quot -> idiv SLIT(".div")  x y
1372       MO_NatS_Rem  -> idiv SLIT(".rem")  x y
1373       MO_NatU_Quot -> idiv SLIT(".udiv")  x y
1374       MO_NatU_Rem  -> idiv SLIT(".urem")  x y
1375
1376       MO_Flt_Add   -> trivialFCode FloatRep  FADD x y
1377       MO_Flt_Sub   -> trivialFCode FloatRep  FSUB x y
1378       MO_Flt_Mul   -> trivialFCode FloatRep  FMUL x y
1379       MO_Flt_Div   -> trivialFCode FloatRep  FDIV x y
1380
1381       MO_Dbl_Add   -> trivialFCode DoubleRep FADD x y
1382       MO_Dbl_Sub   -> trivialFCode DoubleRep FSUB x y
1383       MO_Dbl_Mul   -> trivialFCode DoubleRep FMUL x y
1384       MO_Dbl_Div   -> trivialFCode DoubleRep FDIV x y
1385
1386       MO_Nat_And   -> trivialCode (AND False) x y
1387       MO_Nat_Or    -> trivialCode (OR  False) x y
1388       MO_Nat_Xor   -> trivialCode (XOR False) x y
1389
1390       MO_Nat_Shl   -> trivialCode SLL x y
1391       MO_Nat_Shr   -> trivialCode SRL x y
1392       MO_Nat_Sar   -> trivialCode SRA x y
1393
1394       MO_Flt_Pwr  -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep
1395                                          [promote x, promote y])
1396                        where promote x = StMachOp MO_Flt_to_Dbl [x]
1397       MO_Dbl_Pwr -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep
1398                                         [x, y])
1399
1400       other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop)
1401   where
1402     idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y])
1403
1404     --------------------
1405     imulMayOflo :: StixExpr -> StixExpr -> NatM Register
1406     imulMayOflo a1 a2
1407        = getNewRegNCG IntRep            `thenNat` \ t1 ->
1408          getNewRegNCG IntRep            `thenNat` \ t2 ->
1409          getNewRegNCG IntRep            `thenNat` \ res_lo ->
1410          getNewRegNCG IntRep            `thenNat` \ res_hi ->
1411          getRegister a1                 `thenNat` \ reg1 ->
1412          getRegister a2                 `thenNat` \ reg2 ->
1413          let code1 = registerCode reg1 t1
1414              code2 = registerCode reg2 t2
1415              src1  = registerName reg1 t1
1416              src2  = registerName reg2 t2
1417              code dst = code1 `appOL` code2 `appOL`
1418                         toOL [
1419                            SMUL False src1 (RIReg src2) res_lo,
1420                            RDY res_hi,
1421                            SRA res_lo (RIImm (ImmInt 31)) res_lo,
1422                            SUB False False res_lo (RIReg res_hi) dst
1423                         ]
1424          in
1425             returnNat (Any IntRep code)
1426
1427 getRegister (StInd pk mem)
1428   = getAmode mem                    `thenNat` \ amode ->
1429     let
1430         code = amodeCode amode
1431         src   = amodeAddr amode
1432         size = primRepToSize pk
1433         code__2 dst = code `snocOL` LD size src dst
1434     in
1435         returnNat (Any pk code__2)
1436
1437 getRegister (StInt i)
1438   | fits13Bits i
1439   = let
1440         src = ImmInt (fromInteger i)
1441         code dst = unitOL (OR False g0 (RIImm src) dst)
1442     in
1443         returnNat (Any IntRep code)
1444
1445 getRegister leaf
1446   | maybeToBool imm
1447   = let
1448         code dst = toOL [
1449             SETHI (HI imm__2) dst,
1450             OR False dst (RIImm (LO imm__2)) dst]
1451     in
1452         returnNat (Any PtrRep code)
1453   | otherwise
1454   = ncgPrimopMoan "getRegister(sparc)" (pprStixExpr leaf)
1455   where
1456     imm = maybeImm leaf
1457     imm__2 = case imm of Just x -> x
1458
1459 #endif {- sparc_TARGET_ARCH -}
1460
1461 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1462
1463 \end{code}
1464
1465 %************************************************************************
1466 %*                                                                      *
1467 \subsection{The @Amode@ type}
1468 %*                                                                      *
1469 %************************************************************************
1470
1471 @Amode@s: Memory addressing modes passed up the tree.
1472 \begin{code}
1473 data Amode = Amode MachRegsAddr InstrBlock
1474
1475 amodeAddr (Amode addr _) = addr
1476 amodeCode (Amode _ code) = code
1477 \end{code}
1478
1479 Now, given a tree (the argument to an StInd) that references memory,
1480 produce a suitable addressing mode.
1481
1482 A Rule of the Game (tm) for Amodes: use of the addr bit must
1483 immediately follow use of the code part, since the code part puts
1484 values in registers which the addr then refers to.  So you can't put
1485 anything in between, lest it overwrite some of those registers.  If
1486 you need to do some other computation between the code part and use of
1487 the addr bit, first store the effective address from the amode in a
1488 temporary, then do the other computation, and then use the temporary:
1489
1490     code
1491     LEA amode, tmp
1492     ... other computation ...
1493     ... (tmp) ...
1494
1495 \begin{code}
1496 getAmode :: StixExpr -> NatM Amode
1497
1498 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1499
1500 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1501
1502 #if alpha_TARGET_ARCH
1503
1504 getAmode (StPrim IntSubOp [x, StInt i])
1505   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1506     getRegister x               `thenNat` \ register ->
1507     let
1508         code = registerCode register tmp
1509         reg  = registerName register tmp
1510         off  = ImmInt (-(fromInteger i))
1511     in
1512     returnNat (Amode (AddrRegImm reg off) code)
1513
1514 getAmode (StPrim IntAddOp [x, StInt i])
1515   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1516     getRegister x               `thenNat` \ register ->
1517     let
1518         code = registerCode register tmp
1519         reg  = registerName register tmp
1520         off  = ImmInt (fromInteger i)
1521     in
1522     returnNat (Amode (AddrRegImm reg off) code)
1523
1524 getAmode leaf
1525   | maybeToBool imm
1526   = returnNat (Amode (AddrImm imm__2) id)
1527   where
1528     imm = maybeImm leaf
1529     imm__2 = case imm of Just x -> x
1530
1531 getAmode other
1532   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1533     getRegister other           `thenNat` \ register ->
1534     let
1535         code = registerCode register tmp
1536         reg  = registerName register tmp
1537     in
1538     returnNat (Amode (AddrReg reg) code)
1539
1540 #endif {- alpha_TARGET_ARCH -}
1541
1542 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1543
1544 #if i386_TARGET_ARCH
1545
1546 -- This is all just ridiculous, since it carefully undoes
1547 -- what mangleIndexTree has just done.
1548 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1549   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1550     getRegister x               `thenNat` \ register ->
1551     let
1552         code = registerCode register tmp
1553         reg  = registerName register tmp
1554         off  = ImmInt (-(fromInteger i))
1555     in
1556     returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1557
1558 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1559   | maybeToBool imm
1560   = returnNat (Amode (ImmAddr imm__2 (fromInteger i)) nilOL)
1561   where
1562     imm    = maybeImm x
1563     imm__2 = case imm of Just x -> x
1564
1565 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1566   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1567     getRegister x               `thenNat` \ register ->
1568     let
1569         code = registerCode register tmp
1570         reg  = registerName register tmp
1571         off  = ImmInt (fromInteger i)
1572     in
1573     returnNat (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1574
1575 getAmode (StMachOp MO_Nat_Add [x, StMachOp MO_Nat_Shl [y, StInt shift]])
1576   | shift == 0 || shift == 1 || shift == 2 || shift == 3
1577   = getNewRegNCG PtrRep         `thenNat` \ tmp1 ->
1578     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1579     getRegister x               `thenNat` \ register1 ->
1580     getRegister y               `thenNat` \ register2 ->
1581     let
1582         code1 = registerCode register1 tmp1
1583         reg1  = registerName register1 tmp1
1584         code2 = registerCode register2 tmp2
1585         reg2  = registerName register2 tmp2
1586         code__2 = code1 `appOL` code2
1587         base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
1588     in
1589     returnNat (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
1590                code__2)
1591
1592 getAmode leaf
1593   | maybeToBool imm
1594   = returnNat (Amode (ImmAddr imm__2 0) nilOL)
1595   where
1596     imm    = maybeImm leaf
1597     imm__2 = case imm of Just x -> x
1598
1599 getAmode other
1600   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1601     getRegister other           `thenNat` \ register ->
1602     let
1603         code = registerCode register tmp
1604         reg  = registerName register tmp
1605     in
1606     returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1607
1608 #endif {- i386_TARGET_ARCH -}
1609
1610 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1611
1612 #if sparc_TARGET_ARCH
1613
1614 getAmode (StMachOp MO_Nat_Sub [x, StInt i])
1615   | fits13Bits (-i)
1616   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1617     getRegister x               `thenNat` \ register ->
1618     let
1619         code = registerCode register tmp
1620         reg  = registerName register tmp
1621         off  = ImmInt (-(fromInteger i))
1622     in
1623     returnNat (Amode (AddrRegImm reg off) code)
1624
1625
1626 getAmode (StMachOp MO_Nat_Add [x, StInt i])
1627   | fits13Bits i
1628   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1629     getRegister x               `thenNat` \ register ->
1630     let
1631         code = registerCode register tmp
1632         reg  = registerName register tmp
1633         off  = ImmInt (fromInteger i)
1634     in
1635     returnNat (Amode (AddrRegImm reg off) code)
1636
1637 getAmode (StMachOp MO_Nat_Add [x, y])
1638   = getNewRegNCG PtrRep         `thenNat` \ tmp1 ->
1639     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1640     getRegister x               `thenNat` \ register1 ->
1641     getRegister y               `thenNat` \ register2 ->
1642     let
1643         code1 = registerCode register1 tmp1
1644         reg1  = registerName register1 tmp1
1645         code2 = registerCode register2 tmp2
1646         reg2  = registerName register2 tmp2
1647         code__2 = code1 `appOL` code2
1648     in
1649     returnNat (Amode (AddrRegReg reg1 reg2) code__2)
1650
1651 getAmode leaf
1652   | maybeToBool imm
1653   = getNewRegNCG PtrRep             `thenNat` \ tmp ->
1654     let
1655         code = unitOL (SETHI (HI imm__2) tmp)
1656     in
1657     returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
1658   where
1659     imm    = maybeImm leaf
1660     imm__2 = case imm of Just x -> x
1661
1662 getAmode other
1663   = getNewRegNCG PtrRep         `thenNat` \ tmp ->
1664     getRegister other           `thenNat` \ register ->
1665     let
1666         code = registerCode register tmp
1667         reg  = registerName register tmp
1668         off  = ImmInt 0
1669     in
1670     returnNat (Amode (AddrRegImm reg off) code)
1671
1672 #endif {- sparc_TARGET_ARCH -}
1673
1674 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1675 \end{code}
1676
1677 %************************************************************************
1678 %*                                                                      *
1679 \subsection{The @CondCode@ type}
1680 %*                                                                      *
1681 %************************************************************************
1682
1683 Condition codes passed up the tree.
1684 \begin{code}
1685 data CondCode = CondCode Bool Cond InstrBlock
1686
1687 condName  (CondCode _ cond _)     = cond
1688 condFloat (CondCode is_float _ _) = is_float
1689 condCode  (CondCode _ _ code)     = code
1690 \end{code}
1691
1692 Set up a condition code for a conditional branch.
1693
1694 \begin{code}
1695 getCondCode :: StixExpr -> NatM CondCode
1696
1697 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1698
1699 #if alpha_TARGET_ARCH
1700 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1701 #endif {- alpha_TARGET_ARCH -}
1702
1703 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1704
1705 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1706 -- yes, they really do seem to want exactly the same!
1707
1708 getCondCode (StMachOp mop [x, y])
1709   = case mop of
1710       MO_32U_Gt -> condIntCode GTT  x y
1711       MO_32U_Ge -> condIntCode GE   x y
1712       MO_32U_Eq -> condIntCode EQQ  x y
1713       MO_32U_Ne -> condIntCode NE   x y
1714       MO_32U_Lt -> condIntCode LTT  x y
1715       MO_32U_Le -> condIntCode LE   x y
1716
1717       MO_Nat_Eq  -> condIntCode EQQ  x y
1718       MO_Nat_Ne  -> condIntCode NE   x y
1719
1720       MO_NatS_Gt -> condIntCode GTT  x y
1721       MO_NatS_Ge -> condIntCode GE   x y
1722       MO_NatS_Lt -> condIntCode LTT  x y
1723       MO_NatS_Le -> condIntCode LE   x y
1724
1725       MO_NatU_Gt -> condIntCode GU   x y
1726       MO_NatU_Ge -> condIntCode GEU  x y
1727       MO_NatU_Lt -> condIntCode LU   x y
1728       MO_NatU_Le -> condIntCode LEU  x y
1729
1730       MO_Flt_Gt -> condFltCode GTT x y
1731       MO_Flt_Ge -> condFltCode GE  x y
1732       MO_Flt_Eq -> condFltCode EQQ x y
1733       MO_Flt_Ne -> condFltCode NE  x y
1734       MO_Flt_Lt -> condFltCode LTT x y
1735       MO_Flt_Le -> condFltCode LE  x y
1736
1737       MO_Dbl_Gt -> condFltCode GTT x y
1738       MO_Dbl_Ge -> condFltCode GE  x y
1739       MO_Dbl_Eq -> condFltCode EQQ x y
1740       MO_Dbl_Ne -> condFltCode NE  x y
1741       MO_Dbl_Lt -> condFltCode LTT x y
1742       MO_Dbl_Le -> condFltCode LE  x y
1743
1744       other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop)
1745
1746 getCondCode other =  pprPanic "getCondCode(2)(x86,sparc)" (pprStixExpr other)
1747
1748 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1749
1750 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1751 \end{code}
1752
1753 % -----------------
1754
1755 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1756 passed back up the tree.
1757
1758 \begin{code}
1759 condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode
1760
1761 #if alpha_TARGET_ARCH
1762 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1763 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1764 #endif {- alpha_TARGET_ARCH -}
1765
1766 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1767 #if i386_TARGET_ARCH
1768
1769 -- memory vs immediate
1770 condIntCode cond (StInd pk x) y
1771   | Just i <- maybeImm y
1772   = getAmode x                  `thenNat` \ amode ->
1773     let
1774         code1 = amodeCode amode
1775         x__2  = amodeAddr amode
1776         sz    = primRepToSize pk
1777         code__2 = code1 `snocOL`
1778                   CMP sz (OpImm i) (OpAddr x__2)
1779     in
1780     returnNat (CondCode False cond code__2)
1781
1782 -- anything vs zero
1783 condIntCode cond x (StInt 0)
1784   = getRegister x               `thenNat` \ register1 ->
1785     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
1786     let
1787         code1 = registerCode register1 tmp1
1788         src1  = registerName register1 tmp1
1789         code__2 = code1 `snocOL`
1790                   TEST L (OpReg src1) (OpReg src1)
1791     in
1792     returnNat (CondCode False cond code__2)
1793
1794 -- anything vs immediate
1795 condIntCode cond x y
1796   | Just i <- maybeImm y
1797   = getRegister x               `thenNat` \ register1 ->
1798     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
1799     let
1800         code1 = registerCode register1 tmp1
1801         src1  = registerName register1 tmp1
1802         code__2 = code1 `snocOL`
1803                   CMP L (OpImm i) (OpReg src1)
1804     in
1805     returnNat (CondCode False cond code__2)
1806
1807 -- memory vs anything
1808 condIntCode cond (StInd pk x) y
1809   = getAmode x                  `thenNat` \ amode_x ->
1810     getRegister y               `thenNat` \ reg_y ->
1811     getNewRegNCG IntRep         `thenNat` \ tmp ->
1812     let
1813         c_x   = amodeCode amode_x
1814         am_x  = amodeAddr amode_x
1815         c_y   = registerCode reg_y tmp
1816         r_y   = registerName reg_y tmp
1817         sz    = primRepToSize pk
1818
1819         -- optimisation: if there's no code for x, just an amode,
1820         -- use whatever reg y winds up in.  Assumes that c_y doesn't
1821         -- clobber any regs in the amode am_x, which I'm not sure is
1822         -- justified.  The otherwise clause makes the same assumption.
1823         code__2 | isNilOL c_x
1824                 = c_y `snocOL`
1825                   CMP sz (OpReg r_y) (OpAddr am_x)
1826
1827                 | otherwise
1828                 = c_y `snocOL`
1829                   MOV L (OpReg r_y) (OpReg tmp) `appOL`
1830                   c_x `snocOL`
1831                   CMP sz (OpReg tmp) (OpAddr am_x)
1832     in
1833     returnNat (CondCode False cond code__2)
1834
1835 -- anything vs memory
1836 --
1837 condIntCode cond y (StInd pk x)
1838   = getAmode x                  `thenNat` \ amode_x ->
1839     getRegister y               `thenNat` \ reg_y ->
1840     getNewRegNCG IntRep         `thenNat` \ tmp ->
1841     let
1842         c_x   = amodeCode amode_x
1843         am_x  = amodeAddr amode_x
1844         c_y   = registerCode reg_y tmp
1845         r_y   = registerName reg_y tmp
1846         sz    = primRepToSize pk
1847         -- same optimisation and nagging doubts as previous clause
1848         code__2 | isNilOL c_x
1849                 = c_y `snocOL`
1850                   CMP sz (OpAddr am_x) (OpReg r_y)
1851
1852                 | otherwise
1853                 = c_y `snocOL`
1854                   MOV L (OpReg r_y) (OpReg tmp) `appOL`
1855                   c_x `snocOL`
1856                   CMP sz (OpAddr am_x) (OpReg tmp)
1857     in
1858     returnNat (CondCode False cond code__2)
1859
1860 -- anything vs anything
1861 condIntCode cond x y
1862   = getRegister x               `thenNat` \ register1 ->
1863     getRegister y               `thenNat` \ register2 ->
1864     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
1865     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1866     let
1867         code1 = registerCode register1 tmp1
1868         src1  = registerName register1 tmp1
1869         code2 = registerCode register2 tmp2
1870         src2  = registerName register2 tmp2
1871         code__2 = code1 `snocOL`
1872                   MOV L (OpReg src1) (OpReg tmp1) `appOL`
1873                   code2 `snocOL`
1874                   CMP L (OpReg src2) (OpReg tmp1)
1875     in
1876     returnNat (CondCode False cond code__2)
1877
1878 -----------
1879 condFltCode cond x y
1880   = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT]))
1881     getRegister x               `thenNat` \ register1 ->
1882     getRegister y               `thenNat` \ register2 ->
1883     getNewRegNCG (registerRep register1)
1884                                 `thenNat` \ tmp1 ->
1885     getNewRegNCG (registerRep register2)
1886                                 `thenNat` \ tmp2 ->
1887     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
1888     let
1889         code1 = registerCode register1 tmp1
1890         src1  = registerName register1 tmp1
1891
1892         code2 = registerCode register2 tmp2
1893         src2  = registerName register2 tmp2
1894
1895         code__2 | isAny register1
1896                 = code1 `appOL`   -- result in tmp1
1897                   code2 `snocOL`
1898                   GCMP cond tmp1 src2
1899
1900                 | otherwise
1901                 = code1 `snocOL`
1902                   GMOV src1 tmp1 `appOL`
1903                   code2 `snocOL`
1904                   GCMP cond tmp1 src2
1905     in
1906     -- The GCMP insn does the test and sets the zero flag if comparable
1907     -- and true.  Hence we always supply EQQ as the condition to test.
1908     returnNat (CondCode True EQQ code__2)
1909
1910 #endif {- i386_TARGET_ARCH -}
1911
1912 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1913
1914 #if sparc_TARGET_ARCH
1915
1916 condIntCode cond x (StInt y)
1917   | fits13Bits y
1918   = getRegister x               `thenNat` \ register ->
1919     getNewRegNCG IntRep         `thenNat` \ tmp ->
1920     let
1921         code = registerCode register tmp
1922         src1 = registerName register tmp
1923         src2 = ImmInt (fromInteger y)
1924         code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0
1925     in
1926     returnNat (CondCode False cond code__2)
1927
1928 condIntCode cond x y
1929   = getRegister x               `thenNat` \ register1 ->
1930     getRegister y               `thenNat` \ register2 ->
1931     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
1932     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
1933     let
1934         code1 = registerCode register1 tmp1
1935         src1  = registerName register1 tmp1
1936         code2 = registerCode register2 tmp2
1937         src2  = registerName register2 tmp2
1938         code__2 = code1 `appOL` code2 `snocOL`
1939                   SUB False True src1 (RIReg src2) g0
1940     in
1941     returnNat (CondCode False cond code__2)
1942
1943 -----------
1944 condFltCode cond x y
1945   = getRegister x               `thenNat` \ register1 ->
1946     getRegister y               `thenNat` \ register2 ->
1947     getNewRegNCG (registerRep register1)
1948                                 `thenNat` \ tmp1 ->
1949     getNewRegNCG (registerRep register2)
1950                                 `thenNat` \ tmp2 ->
1951     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
1952     let
1953         promote x = FxTOy F DF x tmp
1954
1955         pk1   = registerRep register1
1956         code1 = registerCode register1 tmp1
1957         src1  = registerName register1 tmp1
1958
1959         pk2   = registerRep register2
1960         code2 = registerCode register2 tmp2
1961         src2  = registerName register2 tmp2
1962
1963         code__2 =
1964                 if pk1 == pk2 then
1965                     code1 `appOL` code2 `snocOL`
1966                     FCMP True (primRepToSize pk1) src1 src2
1967                 else if pk1 == FloatRep then
1968                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
1969                     FCMP True DF tmp src2
1970                 else
1971                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
1972                     FCMP True DF src1 tmp
1973     in
1974     returnNat (CondCode True cond code__2)
1975
1976 #endif {- sparc_TARGET_ARCH -}
1977
1978 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1979 \end{code}
1980
1981 %************************************************************************
1982 %*                                                                      *
1983 \subsection{Generating assignments}
1984 %*                                                                      *
1985 %************************************************************************
1986
1987 Assignments are really at the heart of the whole code generation
1988 business.  Almost all top-level nodes of any real importance are
1989 assignments, which correspond to loads, stores, or register transfers.
1990 If we're really lucky, some of the register transfers will go away,
1991 because we can use the destination register to complete the code
1992 generation for the right hand side.  This only fails when the right
1993 hand side is forced into a fixed register (e.g. the result of a call).
1994
1995 \begin{code}
1996 assignMem_IntCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
1997 assignReg_IntCode :: PrimRep -> StixReg  -> StixExpr -> NatM InstrBlock
1998
1999 assignMem_FltCode :: PrimRep -> StixExpr -> StixExpr -> NatM InstrBlock
2000 assignReg_FltCode :: PrimRep -> StixReg  -> StixExpr -> NatM InstrBlock
2001
2002 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2003
2004 #if alpha_TARGET_ARCH
2005
2006 assignIntCode pk (StInd _ dst) src
2007   = getNewRegNCG IntRep             `thenNat` \ tmp ->
2008     getAmode dst                    `thenNat` \ amode ->
2009     getRegister src                 `thenNat` \ register ->
2010     let
2011         code1   = amodeCode amode []
2012         dst__2  = amodeAddr amode
2013         code2   = registerCode register tmp []
2014         src__2  = registerName register tmp
2015         sz      = primRepToSize pk
2016         code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2017     in
2018     returnNat code__2
2019
2020 assignIntCode pk dst src
2021   = getRegister dst                         `thenNat` \ register1 ->
2022     getRegister src                         `thenNat` \ register2 ->
2023     let
2024         dst__2  = registerName register1 zeroh
2025         code    = registerCode register2 dst__2
2026         src__2  = registerName register2 dst__2
2027         code__2 = if isFixed register2
2028                   then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
2029                   else code
2030     in
2031     returnNat code__2
2032
2033 #endif {- alpha_TARGET_ARCH -}
2034
2035 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2036
2037 #if i386_TARGET_ARCH
2038
2039 -- non-FP assignment to memory
2040 assignMem_IntCode pk addr src
2041   = getAmode addr               `thenNat` \ amode ->
2042     get_op_RI src               `thenNat` \ (codesrc, opsrc) ->
2043     getNewRegNCG PtrRep         `thenNat` \ tmp ->
2044     let
2045         -- In general, if the address computation for dst may require
2046         -- some insns preceding the addressing mode itself.  So there's
2047         -- no guarantee that the code for dst and the code for src won't
2048         -- write the same register.  This means either the address or
2049         -- the value needs to be copied into a temporary.  We detect the
2050         -- common case where the amode has no code, and elide the copy.
2051         codea   = amodeCode amode
2052         dst__a  = amodeAddr amode
2053
2054         code    | isNilOL codea
2055                 = codesrc `snocOL`
2056                   MOV (primRepToSize pk) opsrc (OpAddr dst__a)
2057                 | otherwise
2058                 = codea `snocOL`
2059                   LEA L (OpAddr dst__a) (OpReg tmp) `appOL`
2060                   codesrc `snocOL`
2061                   MOV (primRepToSize pk) opsrc
2062                       (OpAddr (AddrBaseIndex (Just tmp) Nothing (ImmInt 0)))
2063     in
2064     returnNat code
2065   where
2066     get_op_RI
2067         :: StixExpr
2068         -> NatM (InstrBlock,Operand)    -- code, operator
2069
2070     get_op_RI op
2071       | Just x <- maybeImm op
2072       = returnNat (nilOL, OpImm x)
2073
2074     get_op_RI op
2075       = getRegister op                  `thenNat` \ register ->
2076         getNewRegNCG (registerRep register)
2077                                         `thenNat` \ tmp ->
2078         let code = registerCode register tmp
2079             reg  = registerName register tmp
2080         in
2081         returnNat (code, OpReg reg)
2082
2083 -- Assign; dst is a reg, rhs is mem
2084 assignReg_IntCode pk reg (StInd pks src)
2085   = getNewRegNCG PtrRep             `thenNat` \ tmp ->
2086     getAmode src                    `thenNat` \ amode ->
2087     getRegisterReg reg              `thenNat` \ reg_dst ->
2088     let
2089         c_addr  = amodeCode amode
2090         am_addr = amodeAddr amode
2091         r_dst = registerName reg_dst tmp
2092         szs   = primRepToSize pks
2093         opc   = case szs of
2094             B  -> MOVSxL B
2095             Bu -> MOVZxL Bu
2096             W  -> MOVSxL W
2097             Wu -> MOVZxL Wu
2098             L  -> MOV L
2099             Lu -> MOV L
2100
2101         code  = c_addr `snocOL`
2102                 opc (OpAddr am_addr) (OpReg r_dst)
2103     in
2104     returnNat code
2105
2106 -- dst is a reg, but src could be anything
2107 assignReg_IntCode pk reg src
2108   = getRegisterReg reg              `thenNat` \ registerd ->
2109     getRegister src                 `thenNat` \ registers ->
2110     getNewRegNCG IntRep             `thenNat` \ tmp ->
2111     let
2112         r_dst = registerName registerd tmp
2113         r_src = registerName registers r_dst
2114         c_src = registerCode registers r_dst
2115
2116         code = c_src `snocOL`
2117                MOV L (OpReg r_src) (OpReg r_dst)
2118     in
2119     returnNat code
2120
2121 #endif {- i386_TARGET_ARCH -}
2122
2123 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2124
2125 #if sparc_TARGET_ARCH
2126
2127 assignMem_IntCode pk addr src
2128   = getNewRegNCG IntRep                     `thenNat` \ tmp ->
2129     getAmode addr                           `thenNat` \ amode ->
2130     getRegister src                         `thenNat` \ register ->
2131     let
2132         code1   = amodeCode amode
2133         dst__2  = amodeAddr amode
2134         code2   = registerCode register tmp
2135         src__2  = registerName register tmp
2136         sz      = primRepToSize pk
2137         code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
2138     in
2139     returnNat code__2
2140
2141 assignReg_IntCode pk reg src
2142   = getRegister src                         `thenNat` \ register2 ->
2143     getRegisterReg reg                      `thenNat` \ register1 ->
2144     let
2145         dst__2  = registerName register1 g0
2146         code    = registerCode register2 dst__2
2147         src__2  = registerName register2 dst__2
2148         code__2 = if isFixed register2
2149                   then code `snocOL` OR False g0 (RIReg src__2) dst__2
2150                   else code
2151     in
2152     returnNat code__2
2153
2154 #endif {- sparc_TARGET_ARCH -}
2155
2156 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2157 \end{code}
2158
2159 % --------------------------------
2160 Floating-point assignments:
2161 % --------------------------------
2162
2163 \begin{code}
2164 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2165 #if alpha_TARGET_ARCH
2166
2167 assignFltCode pk (StInd _ dst) src
2168   = getNewRegNCG pk                 `thenNat` \ tmp ->
2169     getAmode dst                    `thenNat` \ amode ->
2170     getRegister src                         `thenNat` \ register ->
2171     let
2172         code1   = amodeCode amode []
2173         dst__2  = amodeAddr amode
2174         code2   = registerCode register tmp []
2175         src__2  = registerName register tmp
2176         sz      = primRepToSize pk
2177         code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
2178     in
2179     returnNat code__2
2180
2181 assignFltCode pk dst src
2182   = getRegister dst                         `thenNat` \ register1 ->
2183     getRegister src                         `thenNat` \ register2 ->
2184     let
2185         dst__2  = registerName register1 zeroh
2186         code    = registerCode register2 dst__2
2187         src__2  = registerName register2 dst__2
2188         code__2 = if isFixed register2
2189                   then code . mkSeqInstr (FMOV src__2 dst__2)
2190                   else code
2191     in
2192     returnNat code__2
2193
2194 #endif {- alpha_TARGET_ARCH -}
2195
2196 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2197
2198 #if i386_TARGET_ARCH
2199
2200 -- Floating point assignment to memory
2201 assignMem_FltCode pk addr src
2202    = getRegister src      `thenNat`  \ reg_src  ->
2203      getRegister addr     `thenNat`  \ reg_addr ->
2204      getNewRegNCG pk      `thenNat`  \ tmp_src  ->
2205      getNewRegNCG PtrRep  `thenNat`  \ tmp_addr ->
2206      let r_src  = registerName reg_src tmp_src
2207          c_src  = registerCode reg_src tmp_src
2208          r_addr = registerName reg_addr tmp_addr
2209          c_addr = registerCode reg_addr tmp_addr
2210          sz     = primRepToSize pk
2211
2212          code = c_src  `appOL`
2213                 -- no need to preserve r_src across the addr computation,
2214                 -- since r_src must be a float reg
2215                 -- whilst r_addr is an int reg
2216                 c_addr `snocOL`
2217                 GST sz r_src
2218                        (AddrBaseIndex (Just r_addr) Nothing (ImmInt 0))
2219      in
2220      returnNat code
2221
2222 -- Floating point assignment to a register/temporary
2223 assignReg_FltCode pk reg src
2224   = getRegisterReg reg              `thenNat` \ reg_dst ->
2225     getRegister src                 `thenNat` \ reg_src ->
2226     getNewRegNCG pk                 `thenNat` \ tmp ->
2227     let
2228         r_dst = registerName reg_dst tmp
2229         r_src = registerName reg_src r_dst
2230         c_src = registerCode reg_src r_dst
2231
2232         code = if   isFixed reg_src
2233                then c_src `snocOL` GMOV r_src r_dst
2234                else c_src
2235     in
2236     returnNat code
2237
2238
2239 #endif {- i386_TARGET_ARCH -}
2240
2241 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2242
2243 #if sparc_TARGET_ARCH
2244
2245 -- Floating point assignment to memory
2246 assignMem_FltCode pk addr src
2247   = getNewRegNCG pk                 `thenNat` \ tmp1 ->
2248     getAmode addr                   `thenNat` \ amode ->
2249     getRegister src                 `thenNat` \ register ->
2250     let
2251         sz      = primRepToSize pk
2252         dst__2  = amodeAddr amode
2253
2254         code1   = amodeCode amode
2255         code2   = registerCode register tmp1
2256
2257         src__2  = registerName register tmp1
2258         pk__2   = registerRep register
2259         sz__2   = primRepToSize pk__2
2260
2261         code__2 = code1 `appOL` code2 `appOL`
2262             if   pk == pk__2
2263             then unitOL (ST sz src__2 dst__2)
2264             else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
2265     in
2266     returnNat code__2
2267
2268 -- Floating point assignment to a register/temporary
2269 -- Why is this so bizarrely ugly?
2270 assignReg_FltCode pk reg src
2271   = getRegisterReg reg                      `thenNat` \ register1 ->
2272     getRegister src                         `thenNat` \ register2 ->
2273     let
2274         pk__2   = registerRep register2
2275         sz__2   = primRepToSize pk__2
2276     in
2277     getNewRegNCG pk__2                      `thenNat` \ tmp ->
2278     let
2279         sz      = primRepToSize pk
2280         dst__2  = registerName register1 g0    -- must be Fixed
2281         reg__2  = if pk /= pk__2 then tmp else dst__2
2282         code    = registerCode register2 reg__2
2283         src__2  = registerName register2 reg__2
2284         code__2 =
2285                 if pk /= pk__2 then
2286                      code `snocOL` FxTOy sz__2 sz src__2 dst__2
2287                 else if isFixed register2 then
2288                      code `snocOL` FMOV sz src__2 dst__2
2289                 else
2290                      code
2291     in
2292     returnNat code__2
2293
2294 #endif {- sparc_TARGET_ARCH -}
2295
2296 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2297 \end{code}
2298
2299 %************************************************************************
2300 %*                                                                      *
2301 \subsection{Generating an unconditional branch}
2302 %*                                                                      *
2303 %************************************************************************
2304
2305 We accept two types of targets: an immediate CLabel or a tree that
2306 gets evaluated into a register.  Any CLabels which are AsmTemporaries
2307 are assumed to be in the local block of code, close enough for a
2308 branch instruction.  Other CLabels are assumed to be far away.
2309
2310 (If applicable) Do not fill the delay slots here; you will confuse the
2311 register allocator.
2312
2313 \begin{code}
2314 genJump :: DestInfo -> StixExpr{-the branch target-} -> NatM InstrBlock
2315
2316 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2317
2318 #if alpha_TARGET_ARCH
2319
2320 genJump (StCLbl lbl)
2321   | isAsmTemp lbl = returnInstr (BR target)
2322   | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
2323   where
2324     target = ImmCLbl lbl
2325
2326 genJump tree
2327   = getRegister tree                `thenNat` \ register ->
2328     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2329     let
2330         dst    = registerName register pv
2331         code   = registerCode register pv
2332         target = registerName register pv
2333     in
2334     if isFixed register then
2335         returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
2336     else
2337     returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
2338
2339 #endif {- alpha_TARGET_ARCH -}
2340
2341 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2342
2343 #if i386_TARGET_ARCH
2344
2345 genJump dsts (StInd pk mem)
2346   = getAmode mem                    `thenNat` \ amode ->
2347     let
2348         code   = amodeCode amode
2349         target = amodeAddr amode
2350     in
2351     returnNat (code `snocOL` JMP dsts (OpAddr target))
2352
2353 genJump dsts tree
2354   | maybeToBool imm
2355   = returnNat (unitOL (JMP dsts (OpImm target)))
2356
2357   | otherwise
2358   = getRegister tree                `thenNat` \ register ->
2359     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2360     let
2361         code   = registerCode register tmp
2362         target = registerName register tmp
2363     in
2364     returnNat (code `snocOL` JMP dsts (OpReg target))
2365   where
2366     imm    = maybeImm tree
2367     target = case imm of Just x -> x
2368
2369 #endif {- i386_TARGET_ARCH -}
2370
2371 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2372
2373 #if sparc_TARGET_ARCH
2374
2375 genJump dsts (StCLbl lbl)
2376   | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts"
2377   | isAsmTemp lbl    = returnNat (toOL [BI ALWAYS False target, NOP])
2378   | otherwise        = returnNat (toOL [CALL (Left target) 0 True, NOP])
2379   where
2380     target = ImmCLbl lbl
2381
2382 genJump dsts tree
2383   = getRegister tree                        `thenNat` \ register ->
2384     getNewRegNCG PtrRep             `thenNat` \ tmp ->
2385     let
2386         code   = registerCode register tmp
2387         target = registerName register tmp
2388     in
2389     returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
2390
2391 #endif {- sparc_TARGET_ARCH -}
2392
2393 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2394 \end{code}
2395
2396 %************************************************************************
2397 %*                                                                      *
2398 \subsection{Conditional jumps}
2399 %*                                                                      *
2400 %************************************************************************
2401
2402 Conditional jumps are always to local labels, so we can use branch
2403 instructions.  We peek at the arguments to decide what kind of
2404 comparison to do.
2405
2406 ALPHA: For comparisons with 0, we're laughing, because we can just do
2407 the desired conditional branch.
2408
2409 I386: First, we have to ensure that the condition
2410 codes are set according to the supplied comparison operation.
2411
2412 SPARC: First, we have to ensure that the condition codes are set
2413 according to the supplied comparison operation.  We generate slightly
2414 different code for floating point comparisons, because a floating
2415 point operation cannot directly precede a @BF@.  We assume the worst
2416 and fill that slot with a @NOP@.
2417
2418 SPARC: Do not fill the delay slots here; you will confuse the register
2419 allocator.
2420
2421 \begin{code}
2422 genCondJump
2423     :: CLabel       -- the branch target
2424     -> StixExpr     -- the condition on which to branch
2425     -> NatM InstrBlock
2426
2427 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2428
2429 #if alpha_TARGET_ARCH
2430
2431 genCondJump lbl (StPrim op [x, StInt 0])
2432   = getRegister x                           `thenNat` \ register ->
2433     getNewRegNCG (registerRep register)
2434                                     `thenNat` \ tmp ->
2435     let
2436         code   = registerCode register tmp
2437         value  = registerName register tmp
2438         pk     = registerRep register
2439         target = ImmCLbl lbl
2440     in
2441     returnSeq code [BI (cmpOp op) value target]
2442   where
2443     cmpOp CharGtOp = GTT
2444     cmpOp CharGeOp = GE
2445     cmpOp CharEqOp = EQQ
2446     cmpOp CharNeOp = NE
2447     cmpOp CharLtOp = LTT
2448     cmpOp CharLeOp = LE
2449     cmpOp IntGtOp = GTT
2450     cmpOp IntGeOp = GE
2451     cmpOp IntEqOp = EQQ
2452     cmpOp IntNeOp = NE
2453     cmpOp IntLtOp = LTT
2454     cmpOp IntLeOp = LE
2455     cmpOp WordGtOp = NE
2456     cmpOp WordGeOp = ALWAYS
2457     cmpOp WordEqOp = EQQ
2458     cmpOp WordNeOp = NE
2459     cmpOp WordLtOp = NEVER
2460     cmpOp WordLeOp = EQQ
2461     cmpOp AddrGtOp = NE
2462     cmpOp AddrGeOp = ALWAYS
2463     cmpOp AddrEqOp = EQQ
2464     cmpOp AddrNeOp = NE
2465     cmpOp AddrLtOp = NEVER
2466     cmpOp AddrLeOp = EQQ
2467
2468 genCondJump lbl (StPrim op [x, StDouble 0.0])
2469   = getRegister x                           `thenNat` \ register ->
2470     getNewRegNCG (registerRep register)
2471                                     `thenNat` \ tmp ->
2472     let
2473         code   = registerCode register tmp
2474         value  = registerName register tmp
2475         pk     = registerRep register
2476         target = ImmCLbl lbl
2477     in
2478     returnNat (code . mkSeqInstr (BF (cmpOp op) value target))
2479   where
2480     cmpOp FloatGtOp = GTT
2481     cmpOp FloatGeOp = GE
2482     cmpOp FloatEqOp = EQQ
2483     cmpOp FloatNeOp = NE
2484     cmpOp FloatLtOp = LTT
2485     cmpOp FloatLeOp = LE
2486     cmpOp DoubleGtOp = GTT
2487     cmpOp DoubleGeOp = GE
2488     cmpOp DoubleEqOp = EQQ
2489     cmpOp DoubleNeOp = NE
2490     cmpOp DoubleLtOp = LTT
2491     cmpOp DoubleLeOp = LE
2492
2493 genCondJump lbl (StPrim op [x, y])
2494   | fltCmpOp op
2495   = trivialFCode pr instr x y       `thenNat` \ register ->
2496     getNewRegNCG DoubleRep          `thenNat` \ tmp ->
2497     let
2498         code   = registerCode register tmp
2499         result = registerName register tmp
2500         target = ImmCLbl lbl
2501     in
2502     returnNat (code . mkSeqInstr (BF cond result target))
2503   where
2504     pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2505
2506     fltCmpOp op = case op of
2507         FloatGtOp -> True
2508         FloatGeOp -> True
2509         FloatEqOp -> True
2510         FloatNeOp -> True
2511         FloatLtOp -> True
2512         FloatLeOp -> True
2513         DoubleGtOp -> True
2514         DoubleGeOp -> True
2515         DoubleEqOp -> True
2516         DoubleNeOp -> True
2517         DoubleLtOp -> True
2518         DoubleLeOp -> True
2519         _ -> False
2520     (instr, cond) = case op of
2521         FloatGtOp -> (FCMP TF LE, EQQ)
2522         FloatGeOp -> (FCMP TF LTT, EQQ)
2523         FloatEqOp -> (FCMP TF EQQ, NE)
2524         FloatNeOp -> (FCMP TF EQQ, EQQ)
2525         FloatLtOp -> (FCMP TF LTT, NE)
2526         FloatLeOp -> (FCMP TF LE, NE)
2527         DoubleGtOp -> (FCMP TF LE, EQQ)
2528         DoubleGeOp -> (FCMP TF LTT, EQQ)
2529         DoubleEqOp -> (FCMP TF EQQ, NE)
2530         DoubleNeOp -> (FCMP TF EQQ, EQQ)
2531         DoubleLtOp -> (FCMP TF LTT, NE)
2532         DoubleLeOp -> (FCMP TF LE, NE)
2533
2534 genCondJump lbl (StPrim op [x, y])
2535   = trivialCode instr x y           `thenNat` \ register ->
2536     getNewRegNCG IntRep             `thenNat` \ tmp ->
2537     let
2538         code   = registerCode register tmp
2539         result = registerName register tmp
2540         target = ImmCLbl lbl
2541     in
2542     returnNat (code . mkSeqInstr (BI cond result target))
2543   where
2544     (instr, cond) = case op of
2545         CharGtOp -> (CMP LE, EQQ)
2546         CharGeOp -> (CMP LTT, EQQ)
2547         CharEqOp -> (CMP EQQ, NE)
2548         CharNeOp -> (CMP EQQ, EQQ)
2549         CharLtOp -> (CMP LTT, NE)
2550         CharLeOp -> (CMP LE, NE)
2551         IntGtOp -> (CMP LE, EQQ)
2552         IntGeOp -> (CMP LTT, EQQ)
2553         IntEqOp -> (CMP EQQ, NE)
2554         IntNeOp -> (CMP EQQ, EQQ)
2555         IntLtOp -> (CMP LTT, NE)
2556         IntLeOp -> (CMP LE, NE)
2557         WordGtOp -> (CMP ULE, EQQ)
2558         WordGeOp -> (CMP ULT, EQQ)
2559         WordEqOp -> (CMP EQQ, NE)
2560         WordNeOp -> (CMP EQQ, EQQ)
2561         WordLtOp -> (CMP ULT, NE)
2562         WordLeOp -> (CMP ULE, NE)
2563         AddrGtOp -> (CMP ULE, EQQ)
2564         AddrGeOp -> (CMP ULT, EQQ)
2565         AddrEqOp -> (CMP EQQ, NE)
2566         AddrNeOp -> (CMP EQQ, EQQ)
2567         AddrLtOp -> (CMP ULT, NE)
2568         AddrLeOp -> (CMP ULE, NE)
2569
2570 #endif {- alpha_TARGET_ARCH -}
2571
2572 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2573
2574 #if i386_TARGET_ARCH
2575
2576 genCondJump lbl bool
2577   = getCondCode bool                `thenNat` \ condition ->
2578     let
2579         code   = condCode condition
2580         cond   = condName condition
2581     in
2582     returnNat (code `snocOL` JXX cond lbl)
2583
2584 #endif {- i386_TARGET_ARCH -}
2585
2586 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2587
2588 #if sparc_TARGET_ARCH
2589
2590 genCondJump lbl bool
2591   = getCondCode bool                `thenNat` \ condition ->
2592     let
2593         code   = condCode condition
2594         cond   = condName condition
2595         target = ImmCLbl lbl
2596     in
2597     returnNat (
2598        code `appOL`
2599        toOL (
2600          if   condFloat condition
2601          then [NOP, BF cond False target, NOP]
2602          else [BI cond False target, NOP]
2603        )
2604     )
2605
2606 #endif {- sparc_TARGET_ARCH -}
2607
2608 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2609 \end{code}
2610
2611 %************************************************************************
2612 %*                                                                      *
2613 \subsection{Generating C calls}
2614 %*                                                                      *
2615 %************************************************************************
2616
2617 Now the biggest nightmare---calls.  Most of the nastiness is buried in
2618 @get_arg@, which moves the arguments to the correct registers/stack
2619 locations.  Apart from that, the code is easy.
2620
2621 (If applicable) Do not fill the delay slots here; you will confuse the
2622 register allocator.
2623
2624 \begin{code}
2625 genCCall
2626     :: (Either FAST_STRING StixExpr)    -- function to call
2627     -> CCallConv
2628     -> PrimRep          -- type of the result
2629     -> [StixExpr]       -- arguments (of mixed type)
2630     -> NatM InstrBlock
2631
2632 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2633
2634 #if alpha_TARGET_ARCH
2635
2636 genCCall fn cconv kind args
2637   = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2638                           `thenNat` \ ((unused,_), argCode) ->
2639     let
2640         nRegs = length allArgRegs - length unused
2641         code = asmSeqThen (map ($ []) argCode)
2642     in
2643         returnSeq code [
2644             LDA pv (AddrImm (ImmLab (ptext fn))),
2645             JSR ra (AddrReg pv) nRegs,
2646             LDGP gp (AddrReg ra)]
2647   where
2648     ------------------------
2649     {-  Try to get a value into a specific register (or registers) for
2650         a call.  The first 6 arguments go into the appropriate
2651         argument register (separate registers for integer and floating
2652         point arguments, but used in lock-step), and the remaining
2653         arguments are dumped to the stack, beginning at 0(sp).  Our
2654         first argument is a pair of the list of remaining argument
2655         registers to be assigned for this call and the next stack
2656         offset to use for overflowing arguments.  This way,
2657         @get_Arg@ can be applied to all of a call's arguments using
2658         @mapAccumLNat@.
2659     -}
2660     get_arg
2661         :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
2662         -> StixTree             -- Current argument
2663         -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2664
2665     -- We have to use up all of our argument registers first...
2666
2667     get_arg ((iDst,fDst):dsts, offset) arg
2668       = getRegister arg                     `thenNat` \ register ->
2669         let
2670             reg  = if isFloatingRep pk then fDst else iDst
2671             code = registerCode register reg
2672             src  = registerName register reg
2673             pk   = registerRep register
2674         in
2675         returnNat (
2676             if isFloatingRep pk then
2677                 ((dsts, offset), if isFixed register then
2678                     code . mkSeqInstr (FMOV src fDst)
2679                     else code)
2680             else
2681                 ((dsts, offset), if isFixed register then
2682                     code . mkSeqInstr (OR src (RIReg src) iDst)
2683                     else code))
2684
2685     -- Once we have run out of argument registers, we move to the
2686     -- stack...
2687
2688     get_arg ([], offset) arg
2689       = getRegister arg                 `thenNat` \ register ->
2690         getNewRegNCG (registerRep register)
2691                                         `thenNat` \ tmp ->
2692         let
2693             code = registerCode register tmp
2694             src  = registerName register tmp
2695             pk   = registerRep register
2696             sz   = primRepToSize pk
2697         in
2698         returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2699
2700 #endif {- alpha_TARGET_ARCH -}
2701
2702 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2703
2704 #if i386_TARGET_ARCH
2705
2706 genCCall fn cconv ret_rep args
2707   = mapNat push_arg
2708            (reverse args)       `thenNat` \ sizes_n_codes ->
2709     getDeltaNat                 `thenNat` \ delta ->
2710     let (sizes, push_codes) = unzip sizes_n_codes
2711         tot_arg_size        = sum sizes
2712     in
2713     -- deal with static vs dynamic call targets
2714     (case fn of
2715         Left t_static
2716            -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size))))
2717         Right dyn
2718            -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) ->
2719               ASSERT(case dyn_rep of { L -> True; _ -> False})
2720               returnNat (dyn_c `snocOL` CALL (Right dyn_r))
2721     )
2722                                 `thenNat` \ callinsns ->
2723     let push_code = concatOL push_codes
2724         call = callinsns `appOL`
2725                toOL (
2726                         -- Deallocate parameters after call for ccall;
2727                         -- but not for stdcall (callee does it)
2728                   (if cconv == StdCallConv then [] else
2729                    [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
2730                   ++
2731                   [DELTA (delta + tot_arg_size)]
2732                )
2733     in
2734     setDeltaNat (delta + tot_arg_size) `thenNat` \ _ ->
2735     returnNat (push_code `appOL` call)
2736
2737   where
2738     -- function names that begin with '.' are assumed to be special
2739     -- internally generated names like '.mul,' which don't get an
2740     -- underscore prefix
2741     -- ToDo:needed (WDP 96/03) ???
2742     fn_u  = _UNPK_ (unLeft fn)
2743     fn__2 tot_arg_size
2744        | head fn_u == '.'
2745        = ImmLit (text (fn_u ++ stdcallsize tot_arg_size))
2746        | otherwise      -- General case
2747        = ImmLab False (text (fn_u ++ stdcallsize tot_arg_size))
2748
2749     stdcallsize tot_arg_size
2750        | cconv == StdCallConv = '@':show tot_arg_size
2751        | otherwise            = ""
2752
2753     arg_size DF = 8
2754     arg_size F  = 4
2755     arg_size _  = 4
2756
2757     ------------
2758     push_arg :: StixExpr{-current argument-}
2759                     -> NatM (Int, InstrBlock)  -- argsz, code
2760
2761     push_arg arg
2762       | is64BitRep arg_rep
2763       = iselExpr64 arg                  `thenNat` \ (ChildCode64 code vr_lo) ->
2764         getDeltaNat                     `thenNat` \ delta ->
2765         setDeltaNat (delta - 8)         `thenNat` \ _ ->
2766         let r_lo = VirtualRegI vr_lo
2767             r_hi = getHiVRegFromLo r_lo
2768         in  returnNat (8,
2769                        code `appOL`
2770                        toOL [PUSH L (OpReg r_hi), DELTA (delta - 4),
2771                              PUSH L (OpReg r_lo), DELTA (delta - 8)]
2772             )
2773       | otherwise
2774       = get_op arg                      `thenNat` \ (code, reg, sz) ->
2775         getDeltaNat                     `thenNat` \ delta ->
2776         arg_size sz                     `bind`    \ size ->
2777         setDeltaNat (delta-size)        `thenNat` \ _ ->
2778         if   (case sz of DF -> True; F -> True; _ -> False)
2779         then returnNat (size,
2780                         code `appOL`
2781                         toOL [SUB L (OpImm (ImmInt size)) (OpReg esp),
2782                               DELTA (delta-size),
2783                               GST sz reg (AddrBaseIndex (Just esp)
2784                                                         Nothing
2785                                                         (ImmInt 0))]
2786                        )
2787         else returnNat (size,
2788                         code `snocOL`
2789                         PUSH L (OpReg reg) `snocOL`
2790                         DELTA (delta-size)
2791                        )
2792       where
2793          arg_rep = repOfStixExpr arg
2794
2795     ------------
2796     get_op
2797         :: StixExpr
2798         -> NatM (InstrBlock, Reg, Size) -- code, reg, size
2799
2800     get_op op
2801       = getRegister op          `thenNat` \ register ->
2802         getNewRegNCG (registerRep register)
2803                                 `thenNat` \ tmp ->
2804         let
2805             code = registerCode register tmp
2806             reg  = registerName register tmp
2807             pk   = registerRep  register
2808             sz   = primRepToSize pk
2809         in
2810         returnNat (code, reg, sz)
2811
2812 #endif {- i386_TARGET_ARCH -}
2813
2814 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2815
2816 #if sparc_TARGET_ARCH
2817 {-
2818    The SPARC calling convention is an absolute
2819    nightmare.  The first 6x32 bits of arguments are mapped into
2820    %o0 through %o5, and the remaining arguments are dumped to the
2821    stack, beginning at [%sp+92].  (Note that %o6 == %sp.)
2822
2823    If we have to put args on the stack, move %o6==%sp down by
2824    the number of words to go on the stack, to ensure there's enough space.
2825
2826    According to Fraser and Hanson's lcc book, page 478, fig 17.2,
2827    16 words above the stack pointer is a word for the address of
2828    a structure return value.  I use this as a temporary location
2829    for moving values from float to int regs.  Certainly it isn't
2830    safe to put anything in the 16 words starting at %sp, since
2831    this area can get trashed at any time due to window overflows
2832    caused by signal handlers.
2833
2834    A final complication (if the above isn't enough) is that
2835    we can't blithely calculate the arguments one by one into
2836    %o0 .. %o5.  Consider the following nested calls:
2837
2838        fff a (fff b c)
2839
2840    Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately
2841    the inner call will itself use %o0, which trashes the value put there
2842    in preparation for the outer call.  Upshot: we need to calculate the
2843    args into temporary regs, and move those to arg regs or onto the
2844    stack only immediately prior to the call proper.  Sigh.
2845 -}
2846
2847 genCCall fn cconv kind args
2848   = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs ->
2849     let
2850         (argcodes, vregss) = unzip argcode_and_vregs
2851         n_argRegs          = length allArgRegs
2852         n_argRegs_used     = min (length vregs) n_argRegs
2853         vregs              = concat vregss
2854     in
2855     -- deal with static vs dynamic call targets
2856     (case fn of
2857         Left t_static
2858            -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False))
2859         Right dyn
2860            -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) ->
2861               returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
2862     )
2863                                 `thenNat` \ callinsns ->
2864     let
2865         argcode = concatOL argcodes
2866         (move_sp_down, move_sp_up)
2867            = let nn = length vregs - n_argRegs
2868                                    + 1 -- (for the road)
2869              in  if   nn <= 0
2870                  then (nilOL, nilOL)
2871                  else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
2872         transfer_code
2873            = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE)
2874     in
2875         returnNat (argcode       `appOL`
2876                    move_sp_down  `appOL`
2877                    transfer_code `appOL`
2878                    callinsns     `appOL`
2879                    unitOL NOP    `appOL`
2880                    move_sp_up)
2881   where
2882      -- function names that begin with '.' are assumed to be special
2883      -- internally generated names like '.mul,' which don't get an
2884      -- underscore prefix
2885      -- ToDo:needed (WDP 96/03) ???
2886      fn_static = unLeft fn
2887      fn__2 = case (_HEAD_ fn_static) of
2888                 '.' -> ImmLit (ptext fn_static)
2889                 _   -> ImmLab False (ptext fn_static)
2890
2891      -- move args from the integer vregs into which they have been
2892      -- marshalled, into %o0 .. %o5, and the rest onto the stack.
2893      move_final :: [Reg] -> [Reg] -> Int -> [Instr]
2894
2895      move_final [] _ offset          -- all args done
2896         = []
2897
2898      move_final (v:vs) [] offset     -- out of aregs; move to stack
2899         = ST W v (spRel offset)
2900           : move_final vs [] (offset+1)
2901
2902      move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg
2903         = OR False g0 (RIReg v) a
2904           : move_final vs az offset
2905
2906      -- generate code to calculate an argument, and move it into one
2907      -- or two integer vregs.
2908      arg_to_int_vregs :: StixExpr -> NatM (OrdList Instr, [Reg])
2909      arg_to_int_vregs arg
2910         | is64BitRep (repOfStixExpr arg)
2911         = iselExpr64 arg                `thenNat` \ (ChildCode64 code vr_lo) ->
2912           let r_lo = VirtualRegI vr_lo
2913               r_hi = getHiVRegFromLo r_lo
2914           in  returnNat (code, [r_hi, r_lo])
2915         | otherwise
2916         = getRegister arg                     `thenNat` \ register ->
2917           getNewRegNCG (registerRep register) `thenNat` \ tmp ->
2918           let code = registerCode register tmp
2919               src  = registerName register tmp
2920               pk   = registerRep register
2921           in
2922           -- the value is in src.  Get it into 1 or 2 int vregs.
2923           case pk of
2924              DoubleRep ->
2925                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2926                 getNewRegNCG WordRep  `thenNat` \ v2 ->
2927                 returnNat (
2928                    code                          `snocOL`
2929                    FMOV DF src f0                `snocOL`
2930                    ST   F  f0 (spRel 16)         `snocOL`
2931                    LD   W  (spRel 16) v1         `snocOL`
2932                    ST   F  (fPair f0) (spRel 16) `snocOL`
2933                    LD   W  (spRel 16) v2
2934                    ,
2935                    [v1,v2]
2936                 )
2937              FloatRep ->
2938                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2939                 returnNat (
2940                    code                    `snocOL`
2941                    ST   F  src (spRel 16)  `snocOL`
2942                    LD   W  (spRel 16) v1
2943                    ,
2944                    [v1]
2945                 )
2946              other ->
2947                 getNewRegNCG WordRep  `thenNat` \ v1 ->
2948                 returnNat (
2949                    code `snocOL` OR False g0 (RIReg src) v1
2950                    ,
2951                    [v1]
2952                 )
2953 #endif {- sparc_TARGET_ARCH -}
2954
2955 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2956 \end{code}
2957
2958 %************************************************************************
2959 %*                                                                      *
2960 \subsection{Support bits}
2961 %*                                                                      *
2962 %************************************************************************
2963
2964 %************************************************************************
2965 %*                                                                      *
2966 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2967 %*                                                                      *
2968 %************************************************************************
2969
2970 Turn those condition codes into integers now (when they appear on
2971 the right hand side of an assignment).
2972
2973 (If applicable) Do not fill the delay slots here; you will confuse the
2974 register allocator.
2975
2976 \begin{code}
2977 condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register
2978
2979 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2980
2981 #if alpha_TARGET_ARCH
2982 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2983 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2984 #endif {- alpha_TARGET_ARCH -}
2985
2986 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2987
2988 #if i386_TARGET_ARCH
2989
2990 condIntReg cond x y
2991   = condIntCode cond x y        `thenNat` \ condition ->
2992     getNewRegNCG IntRep         `thenNat` \ tmp ->
2993     let
2994         code = condCode condition
2995         cond = condName condition
2996         code__2 dst = code `appOL` toOL [
2997             SETCC cond (OpReg tmp),
2998             AND L (OpImm (ImmInt 1)) (OpReg tmp),
2999             MOV L (OpReg tmp) (OpReg dst)]
3000     in
3001     returnNat (Any IntRep code__2)
3002
3003 condFltReg cond x y
3004   = getNatLabelNCG              `thenNat` \ lbl1 ->
3005     getNatLabelNCG              `thenNat` \ lbl2 ->
3006     condFltCode cond x y        `thenNat` \ condition ->
3007     let
3008         code = condCode condition
3009         cond = condName condition
3010         code__2 dst = code `appOL` toOL [
3011             JXX cond lbl1,
3012             MOV L (OpImm (ImmInt 0)) (OpReg dst),
3013             JXX ALWAYS lbl2,
3014             LABEL lbl1,
3015             MOV L (OpImm (ImmInt 1)) (OpReg dst),
3016             LABEL lbl2]
3017     in
3018     returnNat (Any IntRep code__2)
3019
3020 #endif {- i386_TARGET_ARCH -}
3021
3022 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3023
3024 #if sparc_TARGET_ARCH
3025
3026 condIntReg EQQ x (StInt 0)
3027   = getRegister x               `thenNat` \ register ->
3028     getNewRegNCG IntRep         `thenNat` \ tmp ->
3029     let
3030         code = registerCode register tmp
3031         src  = registerName register tmp
3032         code__2 dst = code `appOL` toOL [
3033             SUB False True g0 (RIReg src) g0,
3034             SUB True False g0 (RIImm (ImmInt (-1))) dst]
3035     in
3036     returnNat (Any IntRep code__2)
3037
3038 condIntReg EQQ x y
3039   = getRegister x               `thenNat` \ register1 ->
3040     getRegister y               `thenNat` \ register2 ->
3041     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3042     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3043     let
3044         code1 = registerCode register1 tmp1
3045         src1  = registerName register1 tmp1
3046         code2 = registerCode register2 tmp2
3047         src2  = registerName register2 tmp2
3048         code__2 dst = code1 `appOL` code2 `appOL` toOL [
3049             XOR False src1 (RIReg src2) dst,
3050             SUB False True g0 (RIReg dst) g0,
3051             SUB True False g0 (RIImm (ImmInt (-1))) dst]
3052     in
3053     returnNat (Any IntRep code__2)
3054
3055 condIntReg NE x (StInt 0)
3056   = getRegister x               `thenNat` \ register ->
3057     getNewRegNCG IntRep         `thenNat` \ tmp ->
3058     let
3059         code = registerCode register tmp
3060         src  = registerName register tmp
3061         code__2 dst = code `appOL` toOL [
3062             SUB False True g0 (RIReg src) g0,
3063             ADD True False g0 (RIImm (ImmInt 0)) dst]
3064     in
3065     returnNat (Any IntRep code__2)
3066
3067 condIntReg NE x y
3068   = getRegister x               `thenNat` \ register1 ->
3069     getRegister y               `thenNat` \ register2 ->
3070     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3071     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3072     let
3073         code1 = registerCode register1 tmp1
3074         src1  = registerName register1 tmp1
3075         code2 = registerCode register2 tmp2
3076         src2  = registerName register2 tmp2
3077         code__2 dst = code1 `appOL` code2 `appOL` toOL [
3078             XOR False src1 (RIReg src2) dst,
3079             SUB False True g0 (RIReg dst) g0,
3080             ADD True False g0 (RIImm (ImmInt 0)) dst]
3081     in
3082     returnNat (Any IntRep code__2)
3083
3084 condIntReg cond x y
3085   = getNatLabelNCG              `thenNat` \ lbl1 ->
3086     getNatLabelNCG              `thenNat` \ lbl2 ->
3087     condIntCode cond x y        `thenNat` \ condition ->
3088     let
3089         code = condCode condition
3090         cond = condName condition
3091         code__2 dst = code `appOL` toOL [
3092             BI cond False (ImmCLbl lbl1), NOP,
3093             OR False g0 (RIImm (ImmInt 0)) dst,
3094             BI ALWAYS False (ImmCLbl lbl2), NOP,
3095             LABEL lbl1,
3096             OR False g0 (RIImm (ImmInt 1)) dst,
3097             LABEL lbl2]
3098     in
3099     returnNat (Any IntRep code__2)
3100
3101 condFltReg cond x y
3102   = getNatLabelNCG              `thenNat` \ lbl1 ->
3103     getNatLabelNCG              `thenNat` \ lbl2 ->
3104     condFltCode cond x y        `thenNat` \ condition ->
3105     let
3106         code = condCode condition
3107         cond = condName condition
3108         code__2 dst = code `appOL` toOL [
3109             NOP,
3110             BF cond False (ImmCLbl lbl1), NOP,
3111             OR False g0 (RIImm (ImmInt 0)) dst,
3112             BI ALWAYS False (ImmCLbl lbl2), NOP,
3113             LABEL lbl1,
3114             OR False g0 (RIImm (ImmInt 1)) dst,
3115             LABEL lbl2]
3116     in
3117     returnNat (Any IntRep code__2)
3118
3119 #endif {- sparc_TARGET_ARCH -}
3120
3121 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3122 \end{code}
3123
3124 %************************************************************************
3125 %*                                                                      *
3126 \subsubsection{@trivial*Code@: deal with trivial instructions}
3127 %*                                                                      *
3128 %************************************************************************
3129
3130 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
3131 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions.  Only look
3132 for constants on the right hand side, because that's where the generic
3133 optimizer will have put them.
3134
3135 Similarly, for unary instructions, we don't have to worry about
3136 matching an StInt as the argument, because genericOpt will already
3137 have handled the constant-folding.
3138
3139 \begin{code}
3140 trivialCode
3141     :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
3142       ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
3143                      -> Maybe (Operand -> Operand -> Instr)
3144       ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
3145       ,)))
3146     -> StixExpr -> StixExpr -- the two arguments
3147     -> NatM Register
3148
3149 trivialFCode
3150     :: PrimRep
3151     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
3152       ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
3153       ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
3154       ,)))
3155     -> StixExpr -> StixExpr -- the two arguments
3156     -> NatM Register
3157
3158 trivialUCode
3159     :: IF_ARCH_alpha((RI -> Reg -> Instr)
3160       ,IF_ARCH_i386 ((Operand -> Instr)
3161       ,IF_ARCH_sparc((RI -> Reg -> Instr)
3162       ,)))
3163     -> StixExpr -- the one argument
3164     -> NatM Register
3165
3166 trivialUFCode
3167     :: PrimRep
3168     -> IF_ARCH_alpha((Reg -> Reg -> Instr)
3169       ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
3170       ,IF_ARCH_sparc((Reg -> Reg -> Instr)
3171       ,)))
3172     -> StixExpr -- the one argument
3173     -> NatM Register
3174
3175 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3176
3177 #if alpha_TARGET_ARCH
3178
3179 trivialCode instr x (StInt y)
3180   | fits8Bits y
3181   = getRegister x               `thenNat` \ register ->
3182     getNewRegNCG IntRep         `thenNat` \ tmp ->
3183     let
3184         code = registerCode register tmp
3185         src1 = registerName register tmp
3186         src2 = ImmInt (fromInteger y)
3187         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
3188     in
3189     returnNat (Any IntRep code__2)
3190
3191 trivialCode instr x y
3192   = getRegister x               `thenNat` \ register1 ->
3193     getRegister y               `thenNat` \ register2 ->
3194     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3195     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3196     let
3197         code1 = registerCode register1 tmp1 []
3198         src1  = registerName register1 tmp1
3199         code2 = registerCode register2 tmp2 []
3200         src2  = registerName register2 tmp2
3201         code__2 dst = asmSeqThen [code1, code2] .
3202                      mkSeqInstr (instr src1 (RIReg src2) dst)
3203     in
3204     returnNat (Any IntRep code__2)
3205
3206 ------------
3207 trivialUCode instr x
3208   = getRegister x               `thenNat` \ register ->
3209     getNewRegNCG IntRep         `thenNat` \ tmp ->
3210     let
3211         code = registerCode register tmp
3212         src  = registerName register tmp
3213         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3214     in
3215     returnNat (Any IntRep code__2)
3216
3217 ------------
3218 trivialFCode _ instr x y
3219   = getRegister x               `thenNat` \ register1 ->
3220     getRegister y               `thenNat` \ register2 ->
3221     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
3222     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
3223     let
3224         code1 = registerCode register1 tmp1
3225         src1  = registerName register1 tmp1
3226
3227         code2 = registerCode register2 tmp2
3228         src2  = registerName register2 tmp2
3229
3230         code__2 dst = asmSeqThen [code1 [], code2 []] .
3231                       mkSeqInstr (instr src1 src2 dst)
3232     in
3233     returnNat (Any DoubleRep code__2)
3234
3235 trivialUFCode _ instr x
3236   = getRegister x               `thenNat` \ register ->
3237     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3238     let
3239         code = registerCode register tmp
3240         src  = registerName register tmp
3241         code__2 dst = code . mkSeqInstr (instr src dst)
3242     in
3243     returnNat (Any DoubleRep code__2)
3244
3245 #endif {- alpha_TARGET_ARCH -}
3246
3247 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3248
3249 #if i386_TARGET_ARCH
3250 \end{code}
3251 The Rules of the Game are:
3252
3253 * You cannot assume anything about the destination register dst;
3254   it may be anything, including a fixed reg.
3255
3256 * You may compute an operand into a fixed reg, but you may not
3257   subsequently change the contents of that fixed reg.  If you
3258   want to do so, first copy the value either to a temporary
3259   or into dst.  You are free to modify dst even if it happens
3260   to be a fixed reg -- that's not your problem.
3261
3262 * You cannot assume that a fixed reg will stay live over an
3263   arbitrary computation.  The same applies to the dst reg.
3264
3265 * Temporary regs obtained from getNewRegNCG are distinct from
3266   each other and from all other regs, and stay live over
3267   arbitrary computations.
3268
3269 \begin{code}
3270
3271 trivialCode instr maybe_revinstr a b
3272
3273   | is_imm_b
3274   = getRegister a                         `thenNat` \ rega ->
3275     let mkcode dst
3276           = if   isAny rega
3277             then registerCode rega dst      `bind` \ code_a ->
3278                  code_a `snocOL`
3279                  instr (OpImm imm_b) (OpReg dst)
3280             else registerCodeF rega         `bind` \ code_a ->
3281                  registerNameF rega         `bind` \ r_a ->
3282                  code_a `snocOL`
3283                  MOV L (OpReg r_a) (OpReg dst) `snocOL`
3284                  instr (OpImm imm_b) (OpReg dst)
3285     in
3286     returnNat (Any IntRep mkcode)
3287
3288   | is_imm_a
3289   = getRegister b                         `thenNat` \ regb ->
3290     getNewRegNCG IntRep                   `thenNat` \ tmp ->
3291     let revinstr_avail = maybeToBool maybe_revinstr
3292         revinstr       = case maybe_revinstr of Just ri -> ri
3293         mkcode dst
3294           | revinstr_avail
3295           = if   isAny regb
3296             then registerCode regb dst      `bind` \ code_b ->
3297                  code_b `snocOL`
3298                  revinstr (OpImm imm_a) (OpReg dst)
3299             else registerCodeF regb         `bind` \ code_b ->
3300                  registerNameF regb         `bind` \ r_b ->
3301                  code_b `snocOL`
3302                  MOV L (OpReg r_b) (OpReg dst) `snocOL`
3303                  revinstr (OpImm imm_a) (OpReg dst)
3304
3305           | otherwise
3306           = if   isAny regb
3307             then registerCode regb tmp      `bind` \ code_b ->
3308                  code_b `snocOL`
3309                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3310                  instr (OpReg tmp) (OpReg dst)
3311             else registerCodeF regb         `bind` \ code_b ->
3312                  registerNameF regb         `bind` \ r_b ->
3313                  code_b `snocOL`
3314                  MOV L (OpReg r_b) (OpReg tmp) `snocOL`
3315                  MOV L (OpImm imm_a) (OpReg dst) `snocOL`
3316                  instr (OpReg tmp) (OpReg dst)
3317     in
3318     returnNat (Any IntRep mkcode)
3319
3320   | otherwise
3321   = getRegister a                         `thenNat` \ rega ->
3322     getRegister b                         `thenNat` \ regb ->
3323     getNewRegNCG IntRep                   `thenNat` \ tmp ->
3324     let mkcode dst
3325           = case (isAny rega, isAny regb) of
3326               (True, True)
3327                  -> registerCode regb tmp   `bind` \ code_b ->
3328                     registerCode rega dst   `bind` \ code_a ->
3329                     code_b `appOL`
3330                     code_a `snocOL`
3331                     instr (OpReg tmp) (OpReg dst)
3332               (True, False)
3333                  -> registerCode  rega tmp  `bind` \ code_a ->
3334                     registerCodeF regb      `bind` \ code_b ->
3335                     registerNameF regb      `bind` \ r_b ->
3336                     code_a `appOL`
3337                     code_b `snocOL`
3338                     instr (OpReg r_b) (OpReg tmp) `snocOL`
3339                     MOV L (OpReg tmp) (OpReg dst)
3340               (False, True)
3341                  -> registerCode  regb tmp  `bind` \ code_b ->
3342                     registerCodeF rega      `bind` \ code_a ->
3343                     registerNameF rega      `bind` \ r_a ->
3344                     code_b `appOL`
3345                     code_a `snocOL`
3346                     MOV L (OpReg r_a) (OpReg dst) `snocOL`
3347                     instr (OpReg tmp) (OpReg dst)
3348               (False, False)
3349                  -> registerCodeF  rega     `bind` \ code_a ->
3350                     registerNameF  rega     `bind` \ r_a ->
3351                     registerCodeF  regb     `bind` \ code_b ->
3352                     registerNameF  regb     `bind` \ r_b ->
3353                     code_a `snocOL`
3354                     MOV L (OpReg r_a) (OpReg tmp) `appOL`
3355                     code_b `snocOL`
3356                     instr (OpReg r_b) (OpReg tmp) `snocOL`
3357                     MOV L (OpReg tmp) (OpReg dst)
3358     in
3359     returnNat (Any IntRep mkcode)
3360
3361     where
3362        maybe_imm_a = maybeImm a
3363        is_imm_a    = maybeToBool maybe_imm_a
3364        imm_a       = case maybe_imm_a of Just imm -> imm
3365
3366        maybe_imm_b = maybeImm b
3367        is_imm_b    = maybeToBool maybe_imm_b
3368        imm_b       = case maybe_imm_b of Just imm -> imm
3369
3370
3371 -----------
3372 trivialUCode instr x
3373   = getRegister x               `thenNat` \ register ->
3374     let
3375         code__2 dst = let code = registerCode register dst
3376                           src  = registerName register dst
3377                       in code `appOL`
3378                          if   isFixed register && dst /= src
3379                          then toOL [MOV L (OpReg src) (OpReg dst),
3380                                     instr (OpReg dst)]
3381                          else unitOL (instr (OpReg src))
3382     in
3383     returnNat (Any IntRep code__2)
3384
3385 -----------
3386 trivialFCode pk instr x y
3387   = getRegister x               `thenNat` \ register1 ->
3388     getRegister y               `thenNat` \ register2 ->
3389     getNewRegNCG DoubleRep      `thenNat` \ tmp1 ->
3390     getNewRegNCG DoubleRep      `thenNat` \ tmp2 ->
3391     let
3392         code1 = registerCode register1 tmp1
3393         src1  = registerName register1 tmp1
3394
3395         code2 = registerCode register2 tmp2
3396         src2  = registerName register2 tmp2
3397
3398         code__2 dst
3399            -- treat the common case specially: both operands in
3400            -- non-fixed regs.
3401            | isAny register1 && isAny register2
3402            = code1 `appOL`
3403              code2 `snocOL`
3404              instr (primRepToSize pk) src1 src2 dst
3405
3406            -- be paranoid (and inefficient)
3407            | otherwise
3408            = code1 `snocOL` GMOV src1 tmp1  `appOL`
3409              code2 `snocOL`
3410              instr (primRepToSize pk) tmp1 src2 dst
3411     in
3412     returnNat (Any pk code__2)
3413
3414
3415 -------------
3416 trivialUFCode pk instr x
3417   = getRegister x               `thenNat` \ register ->
3418     getNewRegNCG pk             `thenNat` \ tmp ->
3419     let
3420         code = registerCode register tmp
3421         src  = registerName register tmp
3422         code__2 dst = code `snocOL` instr src dst
3423     in
3424     returnNat (Any pk code__2)
3425
3426 #endif {- i386_TARGET_ARCH -}
3427
3428 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3429
3430 #if sparc_TARGET_ARCH
3431
3432 trivialCode instr x (StInt y)
3433   | fits13Bits y
3434   = getRegister x               `thenNat` \ register ->
3435     getNewRegNCG IntRep         `thenNat` \ tmp ->
3436     let
3437         code = registerCode register tmp
3438         src1 = registerName register tmp
3439         src2 = ImmInt (fromInteger y)
3440         code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
3441     in
3442     returnNat (Any IntRep code__2)
3443
3444 trivialCode instr x y
3445   = getRegister x               `thenNat` \ register1 ->
3446     getRegister y               `thenNat` \ register2 ->
3447     getNewRegNCG IntRep         `thenNat` \ tmp1 ->
3448     getNewRegNCG IntRep         `thenNat` \ tmp2 ->
3449     let
3450         code1 = registerCode register1 tmp1
3451         src1  = registerName register1 tmp1
3452         code2 = registerCode register2 tmp2
3453         src2  = registerName register2 tmp2
3454         code__2 dst = code1 `appOL` code2 `snocOL`
3455                       instr src1 (RIReg src2) dst
3456     in
3457     returnNat (Any IntRep code__2)
3458
3459 ------------
3460 trivialFCode pk instr x y
3461   = getRegister x               `thenNat` \ register1 ->
3462     getRegister y               `thenNat` \ register2 ->
3463     getNewRegNCG (registerRep register1)
3464                                 `thenNat` \ tmp1 ->
3465     getNewRegNCG (registerRep register2)
3466                                 `thenNat` \ tmp2 ->
3467     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3468     let
3469         promote x = FxTOy F DF x tmp
3470
3471         pk1   = registerRep register1
3472         code1 = registerCode register1 tmp1
3473         src1  = registerName register1 tmp1
3474
3475         pk2   = registerRep register2
3476         code2 = registerCode register2 tmp2
3477         src2  = registerName register2 tmp2
3478
3479         code__2 dst =
3480                 if pk1 == pk2 then
3481                     code1 `appOL` code2 `snocOL`
3482                     instr (primRepToSize pk) src1 src2 dst
3483                 else if pk1 == FloatRep then
3484                     code1 `snocOL` promote src1 `appOL` code2 `snocOL`
3485                     instr DF tmp src2 dst
3486                 else
3487                     code1 `appOL` code2 `snocOL` promote src2 `snocOL`
3488                     instr DF src1 tmp dst
3489     in
3490     returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3491
3492 ------------
3493 trivialUCode instr x
3494   = getRegister x               `thenNat` \ register ->
3495     getNewRegNCG IntRep         `thenNat` \ tmp ->
3496     let
3497         code = registerCode register tmp
3498         src  = registerName register tmp
3499         code__2 dst = code `snocOL` instr (RIReg src) dst
3500     in
3501     returnNat (Any IntRep code__2)
3502
3503 -------------
3504 trivialUFCode pk instr x
3505   = getRegister x               `thenNat` \ register ->
3506     getNewRegNCG pk             `thenNat` \ tmp ->
3507     let
3508         code = registerCode register tmp
3509         src  = registerName register tmp
3510         code__2 dst = code `snocOL` instr src dst
3511     in
3512     returnNat (Any pk code__2)
3513
3514 #endif {- sparc_TARGET_ARCH -}
3515
3516 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3517 \end{code}
3518
3519 %************************************************************************
3520 %*                                                                      *
3521 \subsubsection{Coercing to/from integer/floating-point...}
3522 %*                                                                      *
3523 %************************************************************************
3524
3525 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3526 conversions.  We have to store temporaries in memory to move
3527 between the integer and the floating point register sets.
3528
3529 @coerceDbl2Flt@ and @coerceFlt2Dbl@ are done this way because we
3530 pretend, on sparc at least, that double and float regs are seperate
3531 kinds, so the value has to be computed into one kind before being
3532 explicitly "converted" to live in the other kind.
3533
3534 \begin{code}
3535 coerceInt2FP :: PrimRep -> StixExpr -> NatM Register
3536 coerceFP2Int :: PrimRep -> StixExpr -> NatM Register
3537
3538 coerceDbl2Flt :: StixExpr -> NatM Register
3539 coerceFlt2Dbl :: StixExpr -> NatM Register
3540 \end{code}
3541
3542 \begin{code}
3543 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3544
3545 #if alpha_TARGET_ARCH
3546
3547 coerceInt2FP _ x
3548   = getRegister x               `thenNat` \ register ->
3549     getNewRegNCG IntRep         `thenNat` \ reg ->
3550     let
3551         code = registerCode register reg
3552         src  = registerName register reg
3553
3554         code__2 dst = code . mkSeqInstrs [
3555             ST Q src (spRel 0),
3556             LD TF dst (spRel 0),
3557             CVTxy Q TF dst dst]
3558     in
3559     returnNat (Any DoubleRep code__2)
3560
3561 -------------
3562 coerceFP2Int x
3563   = getRegister x               `thenNat` \ register ->
3564     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3565     let
3566         code = registerCode register tmp
3567         src  = registerName register tmp
3568
3569         code__2 dst = code . mkSeqInstrs [
3570             CVTxy TF Q src tmp,
3571             ST TF tmp (spRel 0),
3572             LD Q dst (spRel 0)]
3573     in
3574     returnNat (Any IntRep code__2)
3575
3576 #endif {- alpha_TARGET_ARCH -}
3577
3578 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3579
3580 #if i386_TARGET_ARCH
3581
3582 coerceInt2FP pk x
3583   = getRegister x               `thenNat` \ register ->
3584     getNewRegNCG IntRep         `thenNat` \ reg ->
3585     let
3586         code = registerCode register reg
3587         src  = registerName register reg
3588         opc  = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
3589         code__2 dst = code `snocOL` opc src dst
3590     in
3591     returnNat (Any pk code__2)
3592
3593 ------------
3594 coerceFP2Int fprep x
3595   = getRegister x               `thenNat` \ register ->
3596     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3597     let
3598         code = registerCode register tmp
3599         src  = registerName register tmp
3600         pk   = registerRep register
3601
3602         opc  = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3603         code__2 dst = code `snocOL` opc src dst
3604     in
3605     returnNat (Any IntRep code__2)
3606
3607 ------------
3608 coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
3609 coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
3610
3611 #endif {- i386_TARGET_ARCH -}
3612
3613 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3614
3615 #if sparc_TARGET_ARCH
3616
3617 coerceInt2FP pk x
3618   = getRegister x               `thenNat` \ register ->
3619     getNewRegNCG IntRep         `thenNat` \ reg ->
3620     let
3621         code = registerCode register reg
3622         src  = registerName register reg
3623
3624         code__2 dst = code `appOL` toOL [
3625             ST W src (spRel (-2)),
3626             LD W (spRel (-2)) dst,
3627             FxTOy W (primRepToSize pk) dst dst]
3628     in
3629     returnNat (Any pk code__2)
3630
3631 ------------
3632 coerceFP2Int fprep x
3633   = ASSERT(fprep == DoubleRep || fprep == FloatRep)
3634     getRegister x               `thenNat` \ register ->
3635     getNewRegNCG fprep          `thenNat` \ reg ->
3636     getNewRegNCG FloatRep       `thenNat` \ tmp ->
3637     let
3638         code = registerCode register reg
3639         src  = registerName register reg
3640         code__2 dst = code `appOL` toOL [
3641             FxTOy (primRepToSize fprep) W src tmp,
3642             ST W tmp (spRel (-2)),
3643             LD W (spRel (-2)) dst]
3644     in
3645     returnNat (Any IntRep code__2)
3646
3647 ------------
3648 coerceDbl2Flt x
3649   = getRegister x               `thenNat` \ register ->
3650     getNewRegNCG DoubleRep      `thenNat` \ tmp ->
3651     let code = registerCode register tmp
3652         src  = registerName register tmp
3653     in
3654         returnNat (Any FloatRep
3655                        (\dst -> code `snocOL` FxTOy DF F src dst))
3656
3657 ------------
3658 coerceFlt2Dbl x
3659   = getRegister x               `thenNat` \ register ->
3660     getNewRegNCG FloatRep       `thenNat` \ tmp ->
3661     let code = registerCode register tmp
3662         src  = registerName register tmp
3663     in
3664         returnNat (Any DoubleRep
3665                        (\dst -> code `snocOL` FxTOy F DF src dst))
3666
3667 #endif {- sparc_TARGET_ARCH -}
3668
3669 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3670 \end{code}