ghc/compiler/nativeGen/MachCode.lhs

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