ghc/compiler/nativeGen/MachCode.lhs

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