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