ghc/compiler/nativeGen/MachCode.lhs

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