ghc/compiler/nativeGen/MachCode.lhs

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