ghc/compiler/nativeGen/MachCode.lhs

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