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