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