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