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