ghc/compiler/nativeGen/MachCode.lhs

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