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