ghc/compiler/nativeGen/MachCode.lhs

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