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   where
1087     imul_div fn x y = getRegister (StCall fn IntRep [x, y])
1088
1089 getRegister (StInd pk mem)
1090   = getAmode mem                    `thenUs` \ amode ->
1091     let
1092         code = amodeCode amode
1093         src   = amodeAddr amode
1094         size = primRepToSize pk
1095         code__2 dst = code . mkSeqInstr (LD size src dst)
1096     in
1097         returnUs (Any pk code__2)
1098
1099 getRegister (StInt i)
1100   | fits13Bits i
1101   = let
1102         src = ImmInt (fromInteger i)
1103         code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
1104     in
1105         returnUs (Any IntRep code)
1106
1107 getRegister leaf
1108   | maybeToBool imm
1109   = let
1110         code dst = mkSeqInstrs [
1111             SETHI (HI imm__2) dst,
1112             OR False dst (RIImm (LO imm__2)) dst]
1113     in
1114         returnUs (Any PtrRep code)
1115   where
1116     imm = maybeImm leaf
1117     imm__2 = case imm of Just x -> x
1118
1119 #endif {- sparc_TARGET_ARCH -}
1120 \end{code}
1121
1122 %************************************************************************
1123 %*                                                                      *
1124 \subsection{The @Amode@ type}
1125 %*                                                                      *
1126 %************************************************************************
1127
1128 @Amode@s: Memory addressing modes passed up the tree.
1129 \begin{code}
1130 data Amode = Amode MachRegsAddr InstrBlock
1131
1132 amodeAddr (Amode addr _) = addr
1133 amodeCode (Amode _ code) = code
1134 \end{code}
1135
1136 Now, given a tree (the argument to an StInd) that references memory,
1137 produce a suitable addressing mode.
1138
1139 \begin{code}
1140 getAmode :: StixTree -> UniqSM Amode
1141
1142 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1143
1144 #if alpha_TARGET_ARCH
1145
1146 getAmode (StPrim IntSubOp [x, StInt i])
1147   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1148     getRegister x               `thenUs` \ register ->
1149     let
1150         code = registerCode register tmp
1151         reg  = registerName register tmp
1152         off  = ImmInt (-(fromInteger i))
1153     in
1154     returnUs (Amode (AddrRegImm reg off) code)
1155
1156 getAmode (StPrim IntAddOp [x, StInt i])
1157   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1158     getRegister x               `thenUs` \ register ->
1159     let
1160         code = registerCode register tmp
1161         reg  = registerName register tmp
1162         off  = ImmInt (fromInteger i)
1163     in
1164     returnUs (Amode (AddrRegImm reg off) code)
1165
1166 getAmode leaf
1167   | maybeToBool imm
1168   = returnUs (Amode (AddrImm imm__2) id)
1169   where
1170     imm = maybeImm leaf
1171     imm__2 = case imm of Just x -> x
1172
1173 getAmode other
1174   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1175     getRegister other           `thenUs` \ register ->
1176     let
1177         code = registerCode register tmp
1178         reg  = registerName register tmp
1179     in
1180     returnUs (Amode (AddrReg reg) code)
1181
1182 #endif {- alpha_TARGET_ARCH -}
1183 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1184 #if i386_TARGET_ARCH
1185
1186 getAmode (StPrim IntSubOp [x, StInt i])
1187   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1188     getRegister x               `thenUs` \ register ->
1189     let
1190         code = registerCode register tmp
1191         reg  = registerName register tmp
1192         off  = ImmInt (-(fromInteger i))
1193     in
1194     returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1195
1196 getAmode (StPrim IntAddOp [x, StInt i])
1197   | maybeToBool imm
1198   = let
1199         code = mkSeqInstrs []
1200     in
1201     returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
1202   where
1203     imm    = maybeImm x
1204     imm__2 = case imm of Just x -> x
1205
1206 getAmode (StPrim IntAddOp [x, StInt i])
1207   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1208     getRegister x               `thenUs` \ register ->
1209     let
1210         code = registerCode register tmp
1211         reg  = registerName register tmp
1212         off  = ImmInt (fromInteger i)
1213     in
1214     returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1215
1216 getAmode (StPrim IntAddOp [x, y])
1217   = getNewRegNCG PtrRep         `thenUs` \ tmp1 ->
1218     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1219     getRegister x               `thenUs` \ register1 ->
1220     getRegister y               `thenUs` \ register2 ->
1221     let
1222         code1 = registerCode register1 tmp1 asmVoid
1223         reg1  = registerName register1 tmp1
1224         code2 = registerCode register2 tmp2 asmVoid
1225         reg2  = registerName register2 tmp2
1226         code__2 = asmParThen [code1, code2]
1227     in
1228     returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
1229
1230 getAmode leaf
1231   | maybeToBool imm
1232   = let
1233         code = mkSeqInstrs []
1234     in
1235     returnUs (Amode (ImmAddr imm__2 0) code)
1236   where
1237     imm    = maybeImm leaf
1238     imm__2 = case imm of Just x -> x
1239
1240 getAmode other
1241   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1242     getRegister other           `thenUs` \ register ->
1243     let
1244         code = registerCode register tmp
1245         reg  = registerName register tmp
1246         off  = Nothing
1247     in
1248     returnUs (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1249
1250 #endif {- i386_TARGET_ARCH -}
1251 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1252 #if sparc_TARGET_ARCH
1253
1254 getAmode (StPrim IntSubOp [x, StInt i])
1255   | fits13Bits (-i)
1256   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1257     getRegister x               `thenUs` \ register ->
1258     let
1259         code = registerCode register tmp
1260         reg  = registerName register tmp
1261         off  = ImmInt (-(fromInteger i))
1262     in
1263     returnUs (Amode (AddrRegImm reg off) code)
1264
1265
1266 getAmode (StPrim IntAddOp [x, StInt i])
1267   | fits13Bits i
1268   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1269     getRegister x               `thenUs` \ register ->
1270     let
1271         code = registerCode register tmp
1272         reg  = registerName register tmp
1273         off  = ImmInt (fromInteger i)
1274     in
1275     returnUs (Amode (AddrRegImm reg off) code)
1276
1277 getAmode (StPrim IntAddOp [x, y])
1278   = getNewRegNCG PtrRep         `thenUs` \ tmp1 ->
1279     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1280     getRegister x               `thenUs` \ register1 ->
1281     getRegister y               `thenUs` \ register2 ->
1282     let
1283         code1 = registerCode register1 tmp1 asmVoid
1284         reg1  = registerName register1 tmp1
1285         code2 = registerCode register2 tmp2 asmVoid
1286         reg2  = registerName register2 tmp2
1287         code__2 = asmParThen [code1, code2]
1288     in
1289     returnUs (Amode (AddrRegReg reg1 reg2) code__2)
1290
1291 getAmode leaf
1292   | maybeToBool imm
1293   = getNewRegNCG PtrRep             `thenUs` \ tmp ->
1294     let
1295         code = mkSeqInstr (SETHI (HI imm__2) tmp)
1296     in
1297     returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
1298   where
1299     imm    = maybeImm leaf
1300     imm__2 = case imm of Just x -> x
1301
1302 getAmode other
1303   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1304     getRegister other           `thenUs` \ register ->
1305     let
1306         code = registerCode register tmp
1307         reg  = registerName register tmp
1308         off  = ImmInt 0
1309     in
1310     returnUs (Amode (AddrRegImm reg off) code)
1311
1312 #endif {- sparc_TARGET_ARCH -}
1313 \end{code}
1314
1315 %************************************************************************
1316 %*                                                                      *
1317 \subsection{The @CondCode@ type}
1318 %*                                                                      *
1319 %************************************************************************
1320
1321 Condition codes passed up the tree.
1322 \begin{code}
1323 data CondCode = CondCode Bool Cond InstrBlock
1324
1325 condName  (CondCode _ cond _)      = cond
1326 condFloat (CondCode is_float _ _) = is_float
1327 condCode  (CondCode _ _ code)      = code
1328 \end{code}
1329
1330 Set up a condition code for a conditional branch.
1331
1332 \begin{code}
1333 getCondCode :: StixTree -> UniqSM CondCode
1334
1335 #if alpha_TARGET_ARCH
1336 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1337 #endif {- alpha_TARGET_ARCH -}
1338 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1339
1340 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1341 -- yes, they really do seem to want exactly the same!
1342
1343 getCondCode (StPrim primop [x, y])
1344   = case primop of
1345       CharGtOp -> condIntCode GTT  x y
1346       CharGeOp -> condIntCode GE  x y
1347       CharEqOp -> condIntCode EQQ  x y
1348       CharNeOp -> condIntCode NE  x y
1349       CharLtOp -> condIntCode LTT  x y
1350       CharLeOp -> condIntCode LE  x y
1351
1352       IntGtOp  -> condIntCode GTT  x y
1353       IntGeOp  -> condIntCode GE  x y
1354       IntEqOp  -> condIntCode EQQ  x y
1355       IntNeOp  -> condIntCode NE  x y
1356       IntLtOp  -> condIntCode LTT  x y
1357       IntLeOp  -> condIntCode LE  x y
1358
1359       WordGtOp -> condIntCode GU  x y
1360       WordGeOp -> condIntCode GEU x y
1361       WordEqOp -> condIntCode EQQ  x y
1362       WordNeOp -> condIntCode NE  x y
1363       WordLtOp -> condIntCode LU  x y
1364       WordLeOp -> condIntCode LEU x y
1365
1366       AddrGtOp -> condIntCode GU  x y
1367       AddrGeOp -> condIntCode GEU x y
1368       AddrEqOp -> condIntCode EQQ  x y
1369       AddrNeOp -> condIntCode NE  x y
1370       AddrLtOp -> condIntCode LU  x y
1371       AddrLeOp -> condIntCode LEU x y
1372
1373       FloatGtOp -> condFltCode GTT x y
1374       FloatGeOp -> condFltCode GE x y
1375       FloatEqOp -> condFltCode EQQ x y
1376       FloatNeOp -> condFltCode NE x y
1377       FloatLtOp -> condFltCode LTT x y
1378       FloatLeOp -> condFltCode LE x y
1379
1380       DoubleGtOp -> condFltCode GTT x y
1381       DoubleGeOp -> condFltCode GE x y
1382       DoubleEqOp -> condFltCode EQQ x y
1383       DoubleNeOp -> condFltCode NE x y
1384       DoubleLtOp -> condFltCode LTT x y
1385       DoubleLeOp -> condFltCode LE x y
1386
1387 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1388 \end{code}
1389
1390 % -----------------
1391
1392 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1393 passed back up the tree.
1394
1395 \begin{code}
1396 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode
1397
1398 #if alpha_TARGET_ARCH
1399 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1400 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1401 #endif {- alpha_TARGET_ARCH -}
1402
1403 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1404 #if i386_TARGET_ARCH
1405
1406 condIntCode cond (StInd _ x) y
1407   | maybeToBool imm
1408   = getAmode x                  `thenUs` \ amode ->
1409     let
1410         code1 = amodeCode amode asmVoid
1411         y__2  = amodeAddr amode
1412         code__2 = asmParThen [code1] .
1413                   mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
1414     in
1415     returnUs (CondCode False cond code__2)
1416   where
1417     imm    = maybeImm y
1418     imm__2 = case imm of Just x -> x
1419
1420 condIntCode cond x (StInt 0)
1421   = getRegister x               `thenUs` \ register1 ->
1422     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
1423     let
1424         code1 = registerCode register1 tmp1 asmVoid
1425         src1  = registerName register1 tmp1
1426         code__2 = asmParThen [code1] .
1427                 mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
1428     in
1429     returnUs (CondCode False cond code__2)
1430
1431 condIntCode cond x y
1432   | maybeToBool imm
1433   = getRegister x               `thenUs` \ register1 ->
1434     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
1435     let
1436         code1 = registerCode register1 tmp1 asmVoid
1437         src1  = registerName register1 tmp1
1438         code__2 = asmParThen [code1] .
1439                 mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
1440     in
1441     returnUs (CondCode False cond code__2)
1442   where
1443     imm    = maybeImm y
1444     imm__2 = case imm of Just x -> x
1445
1446 condIntCode cond (StInd _ x) y
1447   = getAmode x                  `thenUs` \ amode ->
1448     getRegister y               `thenUs` \ register2 ->
1449     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1450     let
1451         code1 = amodeCode amode asmVoid
1452         src1  = amodeAddr amode
1453         code2 = registerCode register2 tmp2 asmVoid
1454         src2  = registerName register2 tmp2
1455         code__2 = asmParThen [code1, code2] .
1456                   mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
1457     in
1458     returnUs (CondCode False cond code__2)
1459
1460 condIntCode cond y (StInd _ x)
1461   = getAmode x                  `thenUs` \ amode ->
1462     getRegister y               `thenUs` \ register2 ->
1463     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1464     let
1465         code1 = amodeCode amode asmVoid
1466         src1  = amodeAddr amode
1467         code2 = registerCode register2 tmp2 asmVoid
1468         src2  = registerName register2 tmp2
1469         code__2 = asmParThen [code1, code2] .
1470                   mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
1471     in
1472     returnUs (CondCode False cond code__2)
1473
1474 condIntCode cond x y
1475   = getRegister x               `thenUs` \ register1 ->
1476     getRegister y               `thenUs` \ register2 ->
1477     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
1478     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1479     let
1480         code1 = registerCode register1 tmp1 asmVoid
1481         src1  = registerName register1 tmp1
1482         code2 = registerCode register2 tmp2 asmVoid
1483         src2  = registerName register2 tmp2
1484         code__2 = asmParThen [code1, code2] .
1485                 mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
1486     in
1487     returnUs (CondCode False cond code__2)
1488
1489 -----------
1490
1491 condFltCode cond x (StDouble 0.0)
1492   = getRegister x               `thenUs` \ register1 ->
1493     getNewRegNCG (registerRep register1)
1494                                 `thenUs` \ tmp1 ->
1495     let
1496         pk1   = registerRep register1
1497         code1 = registerCode register1 tmp1
1498         src1  = registerName register1 tmp1
1499
1500         code__2 = asmParThen [code1 asmVoid] .
1501                   mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ?
1502                                FNSTSW,
1503                                --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1504                                --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1505                                SAHF
1506                               ]
1507     in
1508     returnUs (CondCode True (fix_FP_cond cond) code__2)
1509
1510 condFltCode cond x y
1511   = getRegister x               `thenUs` \ register1 ->
1512     getRegister y               `thenUs` \ register2 ->
1513     getNewRegNCG (registerRep register1)
1514                                 `thenUs` \ tmp1 ->
1515     getNewRegNCG (registerRep register2)
1516                                 `thenUs` \ tmp2 ->
1517     let
1518         pk1   = registerRep register1
1519         code1 = registerCode register1 tmp1
1520         src1  = registerName register1 tmp1
1521
1522         code2 = registerCode register2 tmp2
1523         src2  = registerName register2 tmp2
1524
1525         code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
1526                   mkSeqInstrs [FUCOMPP,
1527                                FNSTSW,
1528                                --AND HB (OpImm (ImmInt 68)) (OpReg eax),
1529                                --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
1530                                SAHF
1531                               ]
1532     in
1533     returnUs (CondCode True (fix_FP_cond cond) code__2)
1534
1535 {- On the 486, the flags set by FP compare are the unsigned ones!
1536    (This looks like a HACK to me.  WDP 96/03)
1537 -}
1538
1539 fix_FP_cond :: Cond -> Cond
1540
1541 fix_FP_cond GE  = GEU
1542 fix_FP_cond GTT  = GU
1543 fix_FP_cond LTT  = LU
1544 fix_FP_cond LE  = LEU
1545 fix_FP_cond any = any
1546
1547 #endif {- i386_TARGET_ARCH -}
1548 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1549 #if sparc_TARGET_ARCH
1550
1551 condIntCode cond x (StInt y)
1552   | fits13Bits y
1553   = getRegister x               `thenUs` \ register ->
1554     getNewRegNCG IntRep         `thenUs` \ tmp ->
1555     let
1556         code = registerCode register tmp
1557         src1 = registerName register tmp
1558         src2 = ImmInt (fromInteger y)
1559         code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
1560     in
1561     returnUs (CondCode False cond code__2)
1562
1563 condIntCode cond x y
1564   = getRegister x               `thenUs` \ register1 ->
1565     getRegister y               `thenUs` \ register2 ->
1566     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
1567     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1568     let
1569         code1 = registerCode register1 tmp1 asmVoid
1570         src1  = registerName register1 tmp1
1571         code2 = registerCode register2 tmp2 asmVoid
1572         src2  = registerName register2 tmp2
1573         code__2 = asmParThen [code1, code2] .
1574                 mkSeqInstr (SUB False True src1 (RIReg src2) g0)
1575     in
1576     returnUs (CondCode False cond code__2)
1577
1578 -----------
1579 condFltCode cond x y
1580   = getRegister x               `thenUs` \ register1 ->
1581     getRegister y               `thenUs` \ register2 ->
1582     getNewRegNCG (registerRep register1)
1583                                 `thenUs` \ tmp1 ->
1584     getNewRegNCG (registerRep register2)
1585                                 `thenUs` \ tmp2 ->
1586     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
1587     let
1588         promote x = asmInstr (FxTOy F DF x tmp)
1589
1590         pk1   = registerRep register1
1591         code1 = registerCode register1 tmp1
1592         src1  = registerName register1 tmp1
1593
1594         pk2   = registerRep register2
1595         code2 = registerCode register2 tmp2
1596         src2  = registerName register2 tmp2
1597
1598         code__2 =
1599                 if pk1 == pk2 then
1600                     asmParThen [code1 asmVoid, code2 asmVoid] .
1601                     mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
1602                 else if pk1 == FloatRep then
1603                     asmParThen [code1 (promote src1), code2 asmVoid] .
1604                     mkSeqInstr (FCMP True DF tmp src2)
1605                 else
1606                     asmParThen [code1 asmVoid, code2 (promote src2)] .
1607                     mkSeqInstr (FCMP True DF src1 tmp)
1608     in
1609     returnUs (CondCode True cond code__2)
1610
1611 #endif {- sparc_TARGET_ARCH -}
1612 \end{code}
1613
1614 %************************************************************************
1615 %*                                                                      *
1616 \subsection{Generating assignments}
1617 %*                                                                      *
1618 %************************************************************************
1619
1620 Assignments are really at the heart of the whole code generation
1621 business.  Almost all top-level nodes of any real importance are
1622 assignments, which correspond to loads, stores, or register transfers.
1623 If we're really lucky, some of the register transfers will go away,
1624 because we can use the destination register to complete the code
1625 generation for the right hand side.  This only fails when the right
1626 hand side is forced into a fixed register (e.g. the result of a call).
1627
1628 \begin{code}
1629 assignIntCode, assignFltCode
1630         :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock
1631
1632 #if alpha_TARGET_ARCH
1633
1634 assignIntCode pk (StInd _ dst) src
1635   = getNewRegNCG IntRep             `thenUs` \ tmp ->
1636     getAmode dst                    `thenUs` \ amode ->
1637     getRegister src                 `thenUs` \ register ->
1638     let
1639         code1   = amodeCode amode asmVoid
1640         dst__2  = amodeAddr amode
1641         code2   = registerCode register tmp asmVoid
1642         src__2  = registerName register tmp
1643         sz      = primRepToSize pk
1644         code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1645     in
1646     returnUs code__2
1647
1648 assignIntCode pk dst src
1649   = getRegister dst                         `thenUs` \ register1 ->
1650     getRegister src                         `thenUs` \ register2 ->
1651     let
1652         dst__2  = registerName register1 zeroh
1653         code    = registerCode register2 dst__2
1654         src__2  = registerName register2 dst__2
1655         code__2 = if isFixed register2
1656                   then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1657                   else code
1658     in
1659     returnUs code__2
1660
1661 #endif {- alpha_TARGET_ARCH -}
1662 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1663 #if i386_TARGET_ARCH
1664
1665 assignIntCode pk (StInd _ dst) src
1666   = getAmode dst                `thenUs` \ amode ->
1667     get_op_RI src               `thenUs` \ (codesrc, opsrc, sz) ->
1668     let
1669         code1   = amodeCode amode asmVoid
1670         dst__2  = amodeAddr amode
1671         code__2 = asmParThen [code1, codesrc asmVoid] .
1672                   mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
1673     in
1674     returnUs code__2
1675   where
1676     get_op_RI
1677         :: StixTree
1678         -> UniqSM (InstrBlock,Operand, Size)    -- code, operator, size
1679
1680     get_op_RI op
1681       | maybeToBool imm
1682       = returnUs (asmParThen [], OpImm imm_op, L)
1683       where
1684         imm    = maybeImm op
1685         imm_op = case imm of Just x -> x
1686
1687     get_op_RI op
1688       = getRegister op                  `thenUs` \ register ->
1689         getNewRegNCG (registerRep register)
1690                                         `thenUs` \ tmp ->
1691         let
1692             code = registerCode register tmp
1693             reg  = registerName register tmp
1694             pk   = registerRep  register
1695             sz   = primRepToSize pk
1696         in
1697         returnUs (code, OpReg reg, sz)
1698
1699 assignIntCode pk dst (StInd _ src)
1700   = getNewRegNCG IntRep             `thenUs` \ tmp ->
1701     getAmode src                    `thenUs` \ amode ->
1702     getRegister dst                         `thenUs` \ register ->
1703     let
1704         code1   = amodeCode amode asmVoid
1705         src__2  = amodeAddr amode
1706         code2   = registerCode register tmp asmVoid
1707         dst__2  = registerName register tmp
1708         sz      = primRepToSize pk
1709         code__2 = asmParThen [code1, code2] .
1710                   mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
1711     in
1712     returnUs code__2
1713
1714 assignIntCode pk dst src
1715   = getRegister dst                         `thenUs` \ register1 ->
1716     getRegister src                         `thenUs` \ register2 ->
1717     getNewRegNCG IntRep             `thenUs` \ tmp ->
1718     let
1719         dst__2  = registerName register1 tmp
1720         code    = registerCode register2 dst__2
1721         src__2  = registerName register2 dst__2
1722         code__2 = if isFixed register2 && dst__2 /= src__2
1723                   then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
1724                   else code
1725     in
1726     returnUs code__2
1727
1728 #endif {- i386_TARGET_ARCH -}
1729 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1730 #if sparc_TARGET_ARCH
1731
1732 assignIntCode pk (StInd _ dst) src
1733   = getNewRegNCG IntRep             `thenUs` \ tmp ->
1734     getAmode dst                    `thenUs` \ amode ->
1735     getRegister src                         `thenUs` \ register ->
1736     let
1737         code1   = amodeCode amode asmVoid
1738         dst__2  = amodeAddr amode
1739         code2   = registerCode register tmp asmVoid
1740         src__2  = registerName register tmp
1741         sz      = primRepToSize pk
1742         code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1743     in
1744     returnUs code__2
1745
1746 assignIntCode pk dst src
1747   = getRegister dst                         `thenUs` \ register1 ->
1748     getRegister src                         `thenUs` \ register2 ->
1749     let
1750         dst__2  = registerName register1 g0
1751         code    = registerCode register2 dst__2
1752         src__2  = registerName register2 dst__2
1753         code__2 = if isFixed register2
1754                   then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
1755                   else code
1756     in
1757     returnUs code__2
1758
1759 #endif {- sparc_TARGET_ARCH -}
1760 \end{code}
1761
1762 % --------------------------------
1763 Floating-point assignments:
1764 % --------------------------------
1765 \begin{code}
1766 #if alpha_TARGET_ARCH
1767
1768 assignFltCode pk (StInd _ dst) src
1769   = getNewRegNCG pk                 `thenUs` \ tmp ->
1770     getAmode dst                    `thenUs` \ amode ->
1771     getRegister src                         `thenUs` \ register ->
1772     let
1773         code1   = amodeCode amode asmVoid
1774         dst__2  = amodeAddr amode
1775         code2   = registerCode register tmp asmVoid
1776         src__2  = registerName register tmp
1777         sz      = primRepToSize pk
1778         code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1779     in
1780     returnUs code__2
1781
1782 assignFltCode pk dst src
1783   = getRegister dst                         `thenUs` \ register1 ->
1784     getRegister src                         `thenUs` \ register2 ->
1785     let
1786         dst__2  = registerName register1 zeroh
1787         code    = registerCode register2 dst__2
1788         src__2  = registerName register2 dst__2
1789         code__2 = if isFixed register2
1790                   then code . mkSeqInstr (FMOV src__2 dst__2)
1791                   else code
1792     in
1793     returnUs code__2
1794
1795 #endif {- alpha_TARGET_ARCH -}
1796 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1797 #if i386_TARGET_ARCH
1798
1799 assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
1800   = getNewRegNCG IntRep             `thenUs` \ tmp ->
1801     getAmode src                    `thenUs` \ amodesrc ->
1802     getAmode dst                    `thenUs` \ amodedst ->
1803     --getRegister src                       `thenUs` \ register ->
1804     let
1805         codesrc1 = amodeCode amodesrc asmVoid
1806         addrsrc1 = amodeAddr amodesrc
1807         codedst1 = amodeCode amodedst asmVoid
1808         addrdst1 = amodeAddr amodedst
1809         addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x
1810         addrdst2 = case (addrOffset addrdst1 4) of Just x -> x
1811
1812         code__2 = asmParThen [codesrc1, codedst1] .
1813                   mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
1814                                 MOV L (OpReg tmp) (OpAddr addrdst1)]
1815                                ++
1816                                if pk == DoubleRep
1817                                then [MOV L (OpAddr addrsrc2) (OpReg tmp),
1818                                      MOV L (OpReg tmp) (OpAddr addrdst2)]
1819                                else [])
1820     in
1821     returnUs code__2
1822
1823 assignFltCode pk (StInd _ dst) src
1824   = --getNewRegNCG pk               `thenUs` \ tmp ->
1825     getAmode dst                    `thenUs` \ amode ->
1826     getRegister src                         `thenUs` \ register ->
1827     let
1828         sz      = primRepToSize pk
1829         dst__2  = amodeAddr amode
1830
1831         code1   = amodeCode amode asmVoid
1832         code2   = registerCode register {-tmp-}st0 asmVoid
1833
1834         --src__2= registerName register tmp
1835         pk__2   = registerRep register
1836         sz__2   = primRepToSize pk__2
1837
1838         code__2 = asmParThen [code1, code2] .
1839                   mkSeqInstr (FSTP sz (OpAddr dst__2))
1840     in
1841     returnUs code__2
1842
1843 assignFltCode pk dst src
1844   = getRegister dst                         `thenUs` \ register1 ->
1845     getRegister src                         `thenUs` \ register2 ->
1846     --getNewRegNCG (registerRep register2)
1847     --                              `thenUs` \ tmp ->
1848     let
1849         sz      = primRepToSize pk
1850         dst__2  = registerName register1 st0 --tmp
1851
1852         code    = registerCode register2 dst__2
1853         src__2  = registerName register2 dst__2
1854
1855         code__2 = code
1856     in
1857     returnUs code__2
1858
1859 #endif {- i386_TARGET_ARCH -}
1860 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1861 #if sparc_TARGET_ARCH
1862
1863 assignFltCode pk (StInd _ dst) src
1864   = getNewRegNCG pk                 `thenUs` \ tmp1 ->
1865     getAmode dst                    `thenUs` \ amode ->
1866     getRegister src                 `thenUs` \ register ->
1867     let
1868         sz      = primRepToSize pk
1869         dst__2  = amodeAddr amode
1870
1871         code1   = amodeCode amode asmVoid
1872         code2   = registerCode register tmp1 asmVoid
1873
1874         src__2  = registerName register tmp1
1875         pk__2   = registerRep register
1876         sz__2   = primRepToSize pk__2
1877
1878         code__2 = asmParThen [code1, code2] .
1879             if pk == pk__2 then
1880                     mkSeqInstr (ST sz src__2 dst__2)
1881             else
1882                 mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1883     in
1884     returnUs code__2
1885
1886 assignFltCode pk dst src
1887   = getRegister dst                         `thenUs` \ register1 ->
1888     getRegister src                         `thenUs` \ register2 ->
1889     let
1890         pk__2   = registerRep register2
1891         sz__2   = primRepToSize pk__2
1892     in
1893     getNewRegNCG pk__2                      `thenUs` \ tmp ->
1894     let
1895         sz      = primRepToSize pk
1896         dst__2  = registerName register1 g0    -- must be Fixed
1897
1898
1899         reg__2  = if pk /= pk__2 then tmp else dst__2
1900
1901         code    = registerCode register2 reg__2
1902
1903         src__2  = registerName register2 reg__2
1904
1905         code__2 =
1906                 if pk /= pk__2 then
1907                      code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
1908                 else if isFixed register2 then
1909                      code . mkSeqInstr (FMOV sz src__2 dst__2)
1910                 else
1911                      code
1912     in
1913     returnUs code__2
1914
1915 #endif {- sparc_TARGET_ARCH -}
1916 \end{code}
1917
1918 %************************************************************************
1919 %*                                                                      *
1920 \subsection{Generating an unconditional branch}
1921 %*                                                                      *
1922 %************************************************************************
1923
1924 We accept two types of targets: an immediate CLabel or a tree that
1925 gets evaluated into a register.  Any CLabels which are AsmTemporaries
1926 are assumed to be in the local block of code, close enough for a
1927 branch instruction.  Other CLabels are assumed to be far away.
1928
1929 (If applicable) Do not fill the delay slots here; you will confuse the
1930 register allocator.
1931
1932 \begin{code}
1933 genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock
1934
1935 #if alpha_TARGET_ARCH
1936
1937 genJump (StCLbl lbl)
1938   | isAsmTemp lbl = returnInstr (BR target)
1939   | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1940   where
1941     target = ImmCLbl lbl
1942
1943 genJump tree
1944   = getRegister tree                        `thenUs` \ register ->
1945     getNewRegNCG PtrRep             `thenUs` \ tmp ->
1946     let
1947         dst    = registerName register pv
1948         code   = registerCode register pv
1949         target = registerName register pv
1950     in
1951     if isFixed register then
1952         returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1953     else
1954     returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1955
1956 #endif {- alpha_TARGET_ARCH -}
1957 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1958 #if i386_TARGET_ARCH
1959
1960 {-
1961 genJump (StCLbl lbl)
1962   | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
1963   | otherwise     = returnInstrs [JMP (OpImm target)]
1964   where
1965     target = ImmCLbl lbl
1966 -}
1967
1968 genJump (StInd pk mem)
1969   = getAmode mem                    `thenUs` \ amode ->
1970     let
1971         code   = amodeCode amode
1972         target = amodeAddr amode
1973     in
1974     returnSeq code [JMP (OpAddr target)]
1975
1976 genJump tree
1977   | maybeToBool imm
1978   = returnInstr (JMP (OpImm target))
1979
1980   | otherwise
1981   = getRegister tree                        `thenUs` \ register ->
1982     getNewRegNCG PtrRep             `thenUs` \ tmp ->
1983     let
1984         code   = registerCode register tmp
1985         target = registerName register tmp
1986     in
1987     returnSeq code [JMP (OpReg target)]
1988   where
1989     imm    = maybeImm tree
1990     target = case imm of Just x -> x
1991
1992 #endif {- i386_TARGET_ARCH -}
1993 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1994 #if sparc_TARGET_ARCH
1995
1996 genJump (StCLbl lbl)
1997   | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
1998   | otherwise     = returnInstrs [CALL target 0 True, NOP]
1999   where
2000     target = ImmCLbl lbl
2001
2002 genJump tree
2003   = getRegister tree                        `thenUs` \ register ->
2004     getNewRegNCG PtrRep             `thenUs` \ tmp ->
2005     let
2006         code   = registerCode register tmp
2007         target = registerName register tmp
2008     in
2009     returnSeq code [JMP (AddrRegReg target g0), NOP]
2010
2011 #endif {- sparc_TARGET_ARCH -}
2012 \end{code}
2013
2014 %************************************************************************
2015 %*                                                                      *
2016 \subsection{Conditional jumps}
2017 %*                                                                      *
2018 %************************************************************************
2019
2020 Conditional jumps are always to local labels, so we can use branch
2021 instructions.  We peek at the arguments to decide what kind of
2022 comparison to do.
2023
2024 ALPHA: For comparisons with 0, we're laughing, because we can just do
2025 the desired conditional branch.
2026
2027 I386: First, we have to ensure that the condition
2028 codes are set according to the supplied comparison operation.
2029
2030 SPARC: First, we have to ensure that the condition codes are set
2031 according to the supplied comparison operation.  We generate slightly
2032 different code for floating point comparisons, because a floating
2033 point operation cannot directly precede a @BF@.  We assume the worst
2034 and fill that slot with a @NOP@.
2035
2036 SPARC: Do not fill the delay slots here; you will confuse the register
2037 allocator.
2038
2039 \begin{code}
2040 genCondJump
2041     :: CLabel       -- the branch target
2042     -> StixTree     -- the condition on which to branch
2043     -> UniqSM InstrBlock
2044
2045 #if alpha_TARGET_ARCH
2046
2047 genCondJump lbl (StPrim op [x, StInt 0])
2048   = getRegister x                           `thenUs` \ register ->
2049     getNewRegNCG (registerRep register)
2050                                     `thenUs` \ tmp ->
2051     let
2052         code   = registerCode register tmp
2053         value  = registerName register tmp
2054         pk     = registerRep register
2055         target = ImmCLbl lbl
2056     in
2057     returnSeq code [BI (cmpOp op) value target]
2058   where
2059     cmpOp CharGtOp = GTT
2060     cmpOp CharGeOp = GE
2061     cmpOp CharEqOp = EQQ
2062     cmpOp CharNeOp = NE
2063     cmpOp CharLtOp = LTT
2064     cmpOp CharLeOp = LE
2065     cmpOp IntGtOp = GTT
2066     cmpOp IntGeOp = GE
2067     cmpOp IntEqOp = EQQ
2068     cmpOp IntNeOp = NE
2069     cmpOp IntLtOp = LTT
2070     cmpOp IntLeOp = LE
2071     cmpOp WordGtOp = NE
2072     cmpOp WordGeOp = ALWAYS
2073     cmpOp WordEqOp = EQQ
2074     cmpOp WordNeOp = NE
2075     cmpOp WordLtOp = NEVER
2076     cmpOp WordLeOp = EQQ
2077     cmpOp AddrGtOp = NE
2078     cmpOp AddrGeOp = ALWAYS
2079     cmpOp AddrEqOp = EQQ
2080     cmpOp AddrNeOp = NE
2081     cmpOp AddrLtOp = NEVER
2082     cmpOp AddrLeOp = EQQ
2083
2084 genCondJump lbl (StPrim op [x, StDouble 0.0])
2085   = getRegister x                           `thenUs` \ register ->
2086     getNewRegNCG (registerRep register)
2087                                     `thenUs` \ tmp ->
2088     let
2089         code   = registerCode register tmp
2090         value  = registerName register tmp
2091         pk     = registerRep register
2092         target = ImmCLbl lbl
2093     in
2094     returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
2095   where
2096     cmpOp FloatGtOp = GTT
2097     cmpOp FloatGeOp = GE
2098     cmpOp FloatEqOp = EQQ
2099     cmpOp FloatNeOp = NE
2100     cmpOp FloatLtOp = LTT
2101     cmpOp FloatLeOp = LE
2102     cmpOp DoubleGtOp = GTT
2103     cmpOp DoubleGeOp = GE
2104     cmpOp DoubleEqOp = EQQ
2105     cmpOp DoubleNeOp = NE
2106     cmpOp DoubleLtOp = LTT
2107     cmpOp DoubleLeOp = LE
2108
2109 genCondJump lbl (StPrim op [x, y])
2110   | fltCmpOp op
2111   = trivialFCode pr instr x y       `thenUs` \ register ->
2112     getNewRegNCG DoubleRep          `thenUs` \ tmp ->
2113     let
2114         code   = registerCode register tmp
2115         result = registerName register tmp
2116         target = ImmCLbl lbl
2117     in
2118     returnUs (code . mkSeqInstr (BF cond result target))
2119   where
2120     pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2121
2122     fltCmpOp op = case op of
2123         FloatGtOp -> True
2124         FloatGeOp -> True
2125         FloatEqOp -> True
2126         FloatNeOp -> True
2127         FloatLtOp -> True
2128         FloatLeOp -> True
2129         DoubleGtOp -> True
2130         DoubleGeOp -> True
2131         DoubleEqOp -> True
2132         DoubleNeOp -> True
2133         DoubleLtOp -> True
2134         DoubleLeOp -> True
2135         _ -> False
2136     (instr, cond) = case op of
2137         FloatGtOp -> (FCMP TF LE, EQQ)
2138         FloatGeOp -> (FCMP TF LTT, EQQ)
2139         FloatEqOp -> (FCMP TF EQQ, NE)
2140         FloatNeOp -> (FCMP TF EQQ, EQQ)
2141         FloatLtOp -> (FCMP TF LTT, NE)
2142         FloatLeOp -> (FCMP TF LE, NE)
2143         DoubleGtOp -> (FCMP TF LE, EQQ)
2144         DoubleGeOp -> (FCMP TF LTT, EQQ)
2145         DoubleEqOp -> (FCMP TF EQQ, NE)
2146         DoubleNeOp -> (FCMP TF EQQ, EQQ)
2147         DoubleLtOp -> (FCMP TF LTT, NE)
2148         DoubleLeOp -> (FCMP TF LE, NE)
2149
2150 genCondJump lbl (StPrim op [x, y])
2151   = trivialCode instr x y           `thenUs` \ register ->
2152     getNewRegNCG IntRep             `thenUs` \ tmp ->
2153     let
2154         code   = registerCode register tmp
2155         result = registerName register tmp
2156         target = ImmCLbl lbl
2157     in
2158     returnUs (code . mkSeqInstr (BI cond result target))
2159   where
2160     (instr, cond) = case op of
2161         CharGtOp -> (CMP LE, EQQ)
2162         CharGeOp -> (CMP LTT, EQQ)
2163         CharEqOp -> (CMP EQQ, NE)
2164         CharNeOp -> (CMP EQQ, EQQ)
2165         CharLtOp -> (CMP LTT, NE)
2166         CharLeOp -> (CMP LE, NE)
2167         IntGtOp -> (CMP LE, EQQ)
2168         IntGeOp -> (CMP LTT, EQQ)
2169         IntEqOp -> (CMP EQQ, NE)
2170         IntNeOp -> (CMP EQQ, EQQ)
2171         IntLtOp -> (CMP LTT, NE)
2172         IntLeOp -> (CMP LE, NE)
2173         WordGtOp -> (CMP ULE, EQQ)
2174         WordGeOp -> (CMP ULT, EQQ)
2175         WordEqOp -> (CMP EQQ, NE)
2176         WordNeOp -> (CMP EQQ, EQQ)
2177         WordLtOp -> (CMP ULT, NE)
2178         WordLeOp -> (CMP ULE, NE)
2179         AddrGtOp -> (CMP ULE, EQQ)
2180         AddrGeOp -> (CMP ULT, EQQ)
2181         AddrEqOp -> (CMP EQQ, NE)
2182         AddrNeOp -> (CMP EQQ, EQQ)
2183         AddrLtOp -> (CMP ULT, NE)
2184         AddrLeOp -> (CMP ULE, NE)
2185
2186 #endif {- alpha_TARGET_ARCH -}
2187 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2188 #if i386_TARGET_ARCH
2189
2190 genCondJump lbl bool
2191   = getCondCode bool                `thenUs` \ condition ->
2192     let
2193         code   = condCode condition
2194         cond   = condName condition
2195         target = ImmCLbl lbl
2196     in
2197     returnSeq code [JXX cond lbl]
2198
2199 #endif {- i386_TARGET_ARCH -}
2200 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2201 #if sparc_TARGET_ARCH
2202
2203 genCondJump lbl bool
2204   = getCondCode bool                `thenUs` \ condition ->
2205     let
2206         code   = condCode condition
2207         cond   = condName condition
2208         target = ImmCLbl lbl
2209     in
2210     returnSeq code (
2211     if condFloat condition then
2212         [NOP, BF cond False target, NOP]
2213     else
2214         [BI cond False target, NOP]
2215     )
2216
2217 #endif {- sparc_TARGET_ARCH -}
2218 \end{code}
2219
2220 %************************************************************************
2221 %*                                                                      *
2222 \subsection{Generating C calls}
2223 %*                                                                      *
2224 %************************************************************************
2225
2226 Now the biggest nightmare---calls.  Most of the nastiness is buried in
2227 @get_arg@, which moves the arguments to the correct registers/stack
2228 locations.  Apart from that, the code is easy.
2229
2230 (If applicable) Do not fill the delay slots here; you will confuse the
2231 register allocator.
2232
2233 \begin{code}
2234 genCCall
2235     :: FAST_STRING      -- function to call
2236     -> PrimRep          -- type of the result
2237     -> [StixTree]       -- arguments (of mixed type)
2238     -> UniqSM InstrBlock
2239
2240 #if alpha_TARGET_ARCH
2241
2242 genCCall fn kind args
2243   = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2244                                     `thenUs` \ ((unused,_), argCode) ->
2245     let
2246         nRegs = length allArgRegs - length unused
2247         code = asmParThen (map ($ asmVoid) argCode)
2248     in
2249         returnSeq code [
2250             LDA pv (AddrImm (ImmLab (ptext fn))),
2251             JSR ra (AddrReg pv) nRegs,
2252             LDGP gp (AddrReg ra)]
2253   where
2254     ------------------------
2255     {-  Try to get a value into a specific register (or registers) for
2256         a call.  The first 6 arguments go into the appropriate
2257         argument register (separate registers for integer and floating
2258         point arguments, but used in lock-step), and the remaining
2259         arguments are dumped to the stack, beginning at 0(sp).  Our
2260         first argument is a pair of the list of remaining argument
2261         registers to be assigned for this call and the next stack
2262         offset to use for overflowing arguments.  This way,
2263         @get_Arg@ can be applied to all of a call's arguments using
2264         @mapAccumLUs@.
2265     -}
2266     get_arg
2267         :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
2268         -> StixTree             -- Current argument
2269         -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2270
2271     -- We have to use up all of our argument registers first...
2272
2273     get_arg ((iDst,fDst):dsts, offset) arg
2274       = getRegister arg                     `thenUs` \ register ->
2275         let
2276             reg  = if isFloatingRep pk then fDst else iDst
2277             code = registerCode register reg
2278             src  = registerName register reg
2279             pk   = registerRep register
2280         in
2281         returnUs (
2282             if isFloatingRep pk then
2283                 ((dsts, offset), if isFixed register then
2284                     code . mkSeqInstr (FMOV src fDst)
2285                     else code)
2286             else
2287                 ((dsts, offset), if isFixed register then
2288                     code . mkSeqInstr (OR src (RIReg src) iDst)
2289                     else code))
2290
2291     -- Once we have run out of argument registers, we move to the
2292     -- stack...
2293
2294     get_arg ([], offset) arg
2295       = getRegister arg                 `thenUs` \ register ->
2296         getNewRegNCG (registerRep register)
2297                                         `thenUs` \ tmp ->
2298         let
2299             code = registerCode register tmp
2300             src  = registerName register tmp
2301             pk   = registerRep register
2302             sz   = primRepToSize pk
2303         in
2304         returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2305
2306 #endif {- alpha_TARGET_ARCH -}
2307 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2308 #if i386_TARGET_ARCH
2309
2310 genCCall fn kind [StInt i]
2311   | fn == SLIT ("PerformGC_wrapper")
2312   = let
2313      call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2314              CALL (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))]
2315     in
2316     returnInstrs call
2317
2318 {- OLD:
2319   = getUniqLabelNCG                 `thenUs` \ lbl ->
2320     let
2321         call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2322                 MOV L (OpImm (ImmCLbl lbl))
2323                       -- this is hardwired
2324                       (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 104))),
2325                 JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
2326                 LABEL lbl]
2327     in
2328     returnInstrs call
2329 -}
2330
2331 genCCall fn kind args
2332   = mapUs get_call_arg args `thenUs` \ argCode ->
2333     let
2334         nargs = length args
2335
2336 {- OLD: Since there's no attempt at stealing %esp at the moment,
2337    restoring %esp from MainRegTable.rCstkptr is not done.  -- SOF 97/09
2338    (ditto for saving away old-esp in MainRegTable.Hp (!!) )
2339         code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))),
2340                         MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
2341                                    ]
2342                            ]
2343 -}
2344         code2 = asmParThen (map ($ asmVoid) (reverse argCode))
2345         call = [CALL fn__2 ,
2346                 -- pop args; all args word sized?
2347                 ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp) --,
2348
2349                 -- Don't restore %esp (see above)
2350                 -- MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
2351                 ]
2352     in
2353     returnSeq (code2) call
2354   where
2355     -- function names that begin with '.' are assumed to be special
2356     -- internally generated names like '.mul,' which don't get an
2357     -- underscore prefix
2358     -- ToDo:needed (WDP 96/03) ???
2359     fn__2 = case (_HEAD_ fn) of
2360               '.' -> ImmLit (ptext fn)
2361               _   -> ImmLab (ptext fn)
2362
2363     ------------
2364     get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock   -- code
2365
2366     get_call_arg arg
2367       = get_op arg              `thenUs` \ (code, op, sz) ->
2368         returnUs (code . mkSeqInstr (PUSH sz op))
2369
2370     ------------
2371     get_op
2372         :: StixTree
2373         -> UniqSM (InstrBlock,Operand, Size)    -- code, operator, size
2374
2375     get_op (StInt i)
2376       = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
2377
2378     get_op (StInd pk mem)
2379       = getAmode mem            `thenUs` \ amode ->
2380         let
2381             code = amodeCode amode --asmVoid
2382             addr = amodeAddr amode
2383             sz   = primRepToSize pk
2384         in
2385         returnUs (code, OpAddr addr, sz)
2386
2387     get_op op
2388       = getRegister op          `thenUs` \ register ->
2389         getNewRegNCG (registerRep register)
2390                                 `thenUs` \ tmp ->
2391         let
2392             code = registerCode register tmp
2393             reg  = registerName register tmp
2394             pk   = registerRep  register
2395             sz   = primRepToSize pk
2396         in
2397         returnUs (code, OpReg reg, sz)
2398
2399 #endif {- i386_TARGET_ARCH -}
2400 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2401 #if sparc_TARGET_ARCH
2402
2403 genCCall fn kind args
2404   = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2405                                     `thenUs` \ ((unused,_), argCode) ->
2406     let
2407         nRegs = length allArgRegs - length unused
2408         call = CALL fn__2 nRegs False
2409         code = asmParThen (map ($ asmVoid) argCode)
2410     in
2411         returnSeq code [call, NOP]
2412   where
2413     -- function names that begin with '.' are assumed to be special
2414     -- internally generated names like '.mul,' which don't get an
2415     -- underscore prefix
2416     -- ToDo:needed (WDP 96/03) ???
2417     fn__2 = case (_HEAD_ fn) of
2418               '.' -> ImmLit (ptext fn)
2419               _   -> ImmLab (ptext fn)
2420
2421     ------------------------------------
2422     {-  Try to get a value into a specific register (or registers) for
2423         a call.  The SPARC calling convention is an absolute
2424         nightmare.  The first 6x32 bits of arguments are mapped into
2425         %o0 through %o5, and the remaining arguments are dumped to the
2426         stack, beginning at [%sp+92].  (Note that %o6 == %sp.)  Our
2427         first argument is a pair of the list of remaining argument
2428         registers to be assigned for this call and the next stack
2429         offset to use for overflowing arguments.  This way,
2430         @get_arg@ can be applied to all of a call's arguments using
2431         @mapAccumL@.
2432     -}
2433     get_arg
2434         :: ([Reg],Int)  -- Argument registers and stack offset (accumulator)
2435         -> StixTree     -- Current argument
2436         -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2437
2438     -- We have to use up all of our argument registers first...
2439
2440     get_arg (dst:dsts, offset) arg
2441       = getRegister arg                 `thenUs` \ register ->
2442         getNewRegNCG (registerRep register)
2443                                         `thenUs` \ tmp ->
2444         let
2445             reg  = if isFloatingRep pk then tmp else dst
2446             code = registerCode register reg
2447             src  = registerName register reg
2448             pk   = registerRep register
2449         in
2450         returnUs (case pk of
2451             DoubleRep ->
2452                 case dsts of
2453                     [] -> (([], offset + 1), code . mkSeqInstrs [
2454                             -- conveniently put the second part in the right stack
2455                             -- location, and load the first part into %o5
2456                             ST DF src (spRel (offset - 1)),
2457                             LD W (spRel (offset - 1)) dst])
2458                     (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
2459                             ST DF src (spRel (-2)),
2460                             LD W (spRel (-2)) dst,
2461                             LD W (spRel (-1)) dst__2])
2462             FloatRep -> ((dsts, offset), code . mkSeqInstrs [
2463                             ST F src (spRel (-2)),
2464                             LD W (spRel (-2)) dst])
2465             _ -> ((dsts, offset), if isFixed register then
2466                                   code . mkSeqInstr (OR False g0 (RIReg src) dst)
2467                                   else code))
2468
2469     -- Once we have run out of argument registers, we move to the
2470     -- stack...
2471
2472     get_arg ([], offset) arg
2473       = getRegister arg                 `thenUs` \ register ->
2474         getNewRegNCG (registerRep register)
2475                                         `thenUs` \ tmp ->
2476         let
2477             code  = registerCode register tmp
2478             src   = registerName register tmp
2479             pk    = registerRep register
2480             sz    = primRepToSize pk
2481             words = if pk == DoubleRep then 2 else 1
2482         in
2483         returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
2484
2485 #endif {- sparc_TARGET_ARCH -}
2486 \end{code}
2487
2488 %************************************************************************
2489 %*                                                                      *
2490 \subsection{Support bits}
2491 %*                                                                      *
2492 %************************************************************************
2493
2494 %************************************************************************
2495 %*                                                                      *
2496 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2497 %*                                                                      *
2498 %************************************************************************
2499
2500 Turn those condition codes into integers now (when they appear on
2501 the right hand side of an assignment).
2502
2503 (If applicable) Do not fill the delay slots here; you will confuse the
2504 register allocator.
2505
2506 \begin{code}
2507 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
2508
2509 #if alpha_TARGET_ARCH
2510 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2511 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2512 #endif {- alpha_TARGET_ARCH -}
2513
2514 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2515 #if i386_TARGET_ARCH
2516
2517 condIntReg cond x y
2518   = condIntCode cond x y        `thenUs` \ condition ->
2519     getNewRegNCG IntRep         `thenUs` \ tmp ->
2520     --getRegister dst           `thenUs` \ register ->
2521     let
2522         --code2 = registerCode register tmp asmVoid
2523         --dst__2  = registerName register tmp
2524         code = condCode condition
2525         cond = condName condition
2526         -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
2527         code__2 dst = code . mkSeqInstrs [
2528             SETCC cond (OpReg tmp),
2529             AND L (OpImm (ImmInt 1)) (OpReg tmp),
2530             MOV L (OpReg tmp) (OpReg dst)]
2531     in
2532     returnUs (Any IntRep code__2)
2533
2534 condFltReg cond x y
2535   = getUniqLabelNCG             `thenUs` \ lbl1 ->
2536     getUniqLabelNCG             `thenUs` \ lbl2 ->
2537     condFltCode cond x y        `thenUs` \ condition ->
2538     let
2539         code = condCode condition
2540         cond = condName condition
2541         code__2 dst = code . mkSeqInstrs [
2542             JXX cond lbl1,
2543             MOV L (OpImm (ImmInt 0)) (OpReg dst),
2544             JXX ALWAYS lbl2,
2545             LABEL lbl1,
2546             MOV L (OpImm (ImmInt 1)) (OpReg dst),
2547             LABEL lbl2]
2548     in
2549     returnUs (Any IntRep code__2)
2550
2551 #endif {- i386_TARGET_ARCH -}
2552 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2553 #if sparc_TARGET_ARCH
2554
2555 condIntReg EQQ x (StInt 0)
2556   = getRegister x               `thenUs` \ register ->
2557     getNewRegNCG IntRep         `thenUs` \ tmp ->
2558     let
2559         code = registerCode register tmp
2560         src  = registerName register tmp
2561         code__2 dst = code . mkSeqInstrs [
2562             SUB False True g0 (RIReg src) g0,
2563             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2564     in
2565     returnUs (Any IntRep code__2)
2566
2567 condIntReg EQQ x y
2568   = getRegister x               `thenUs` \ register1 ->
2569     getRegister y               `thenUs` \ register2 ->
2570     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2571     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2572     let
2573         code1 = registerCode register1 tmp1 asmVoid
2574         src1  = registerName register1 tmp1
2575         code2 = registerCode register2 tmp2 asmVoid
2576         src2  = registerName register2 tmp2
2577         code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2578             XOR False src1 (RIReg src2) dst,
2579             SUB False True g0 (RIReg dst) g0,
2580             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2581     in
2582     returnUs (Any IntRep code__2)
2583
2584 condIntReg NE x (StInt 0)
2585   = getRegister x               `thenUs` \ register ->
2586     getNewRegNCG IntRep         `thenUs` \ tmp ->
2587     let
2588         code = registerCode register tmp
2589         src  = registerName register tmp
2590         code__2 dst = code . mkSeqInstrs [
2591             SUB False True g0 (RIReg src) g0,
2592             ADD True False g0 (RIImm (ImmInt 0)) dst]
2593     in
2594     returnUs (Any IntRep code__2)
2595
2596 condIntReg NE x y
2597   = getRegister x               `thenUs` \ register1 ->
2598     getRegister y               `thenUs` \ register2 ->
2599     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2600     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2601     let
2602         code1 = registerCode register1 tmp1 asmVoid
2603         src1  = registerName register1 tmp1
2604         code2 = registerCode register2 tmp2 asmVoid
2605         src2  = registerName register2 tmp2
2606         code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2607             XOR False src1 (RIReg src2) dst,
2608             SUB False True g0 (RIReg dst) g0,
2609             ADD True False g0 (RIImm (ImmInt 0)) dst]
2610     in
2611     returnUs (Any IntRep code__2)
2612
2613 condIntReg cond x y
2614   = getUniqLabelNCG             `thenUs` \ lbl1 ->
2615     getUniqLabelNCG             `thenUs` \ lbl2 ->
2616     condIntCode cond x y        `thenUs` \ condition ->
2617     let
2618         code = condCode condition
2619         cond = condName condition
2620         code__2 dst = code . mkSeqInstrs [
2621             BI cond False (ImmCLbl lbl1), NOP,
2622             OR False g0 (RIImm (ImmInt 0)) dst,
2623             BI ALWAYS False (ImmCLbl lbl2), NOP,
2624             LABEL lbl1,
2625             OR False g0 (RIImm (ImmInt 1)) dst,
2626             LABEL lbl2]
2627     in
2628     returnUs (Any IntRep code__2)
2629
2630 condFltReg cond x y
2631   = getUniqLabelNCG             `thenUs` \ lbl1 ->
2632     getUniqLabelNCG             `thenUs` \ lbl2 ->
2633     condFltCode cond x y        `thenUs` \ condition ->
2634     let
2635         code = condCode condition
2636         cond = condName condition
2637         code__2 dst = code . mkSeqInstrs [
2638             NOP,
2639             BF cond False (ImmCLbl lbl1), NOP,
2640             OR False g0 (RIImm (ImmInt 0)) dst,
2641             BI ALWAYS False (ImmCLbl lbl2), NOP,
2642             LABEL lbl1,
2643             OR False g0 (RIImm (ImmInt 1)) dst,
2644             LABEL lbl2]
2645     in
2646     returnUs (Any IntRep code__2)
2647
2648 #endif {- sparc_TARGET_ARCH -}
2649 \end{code}
2650
2651 %************************************************************************
2652 %*                                                                      *
2653 \subsubsection{@trivial*Code@: deal with trivial instructions}
2654 %*                                                                      *
2655 %************************************************************************
2656
2657 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2658 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions.  Only look
2659 for constants on the right hand side, because that's where the generic
2660 optimizer will have put them.
2661
2662 Similarly, for unary instructions, we don't have to worry about
2663 matching an StInt as the argument, because genericOpt will already
2664 have handled the constant-folding.
2665
2666 \begin{code}
2667 trivialCode
2668     :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2669       ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2670       ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2671       ,)))
2672     -> StixTree -> StixTree -- the two arguments
2673     -> UniqSM Register
2674
2675 trivialFCode
2676     :: PrimRep
2677     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2678       ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2679       ,IF_ARCH_i386 (
2680               {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
2681                (Size -> Operand -> Instr)
2682             -> (Size -> Operand -> Instr) {-reversed instr-}
2683             -> Instr {-pop-}
2684             -> Instr {-reversed instr: pop-}
2685       ,)))
2686     -> StixTree -> StixTree -- the two arguments
2687     -> UniqSM Register
2688
2689 trivialUCode
2690     :: IF_ARCH_alpha((RI -> Reg -> Instr)
2691       ,IF_ARCH_i386 ((Operand -> Instr)
2692       ,IF_ARCH_sparc((RI -> Reg -> Instr)
2693       ,)))
2694     -> StixTree -- the one argument
2695     -> UniqSM Register
2696
2697 trivialUFCode
2698     :: PrimRep
2699     -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2700       ,IF_ARCH_i386 (Instr
2701       ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2702       ,)))
2703     -> StixTree -- the one argument
2704     -> UniqSM Register
2705
2706 #if alpha_TARGET_ARCH
2707
2708 trivialCode instr x (StInt y)
2709   | fits8Bits y
2710   = getRegister x               `thenUs` \ register ->
2711     getNewRegNCG IntRep         `thenUs` \ tmp ->
2712     let
2713         code = registerCode register tmp
2714         src1 = registerName register tmp
2715         src2 = ImmInt (fromInteger y)
2716         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2717     in
2718     returnUs (Any IntRep code__2)
2719
2720 trivialCode instr x y
2721   = getRegister x               `thenUs` \ register1 ->
2722     getRegister y               `thenUs` \ register2 ->
2723     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2724     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2725     let
2726         code1 = registerCode register1 tmp1 asmVoid
2727         src1  = registerName register1 tmp1
2728         code2 = registerCode register2 tmp2 asmVoid
2729         src2  = registerName register2 tmp2
2730         code__2 dst = asmParThen [code1, code2] .
2731                      mkSeqInstr (instr src1 (RIReg src2) dst)
2732     in
2733     returnUs (Any IntRep code__2)
2734
2735 ------------
2736 trivialUCode instr x
2737   = getRegister x               `thenUs` \ register ->
2738     getNewRegNCG IntRep         `thenUs` \ tmp ->
2739     let
2740         code = registerCode register tmp
2741         src  = registerName register tmp
2742         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2743     in
2744     returnUs (Any IntRep code__2)
2745
2746 ------------
2747 trivialFCode _ instr x y
2748   = getRegister x               `thenUs` \ register1 ->
2749     getRegister y               `thenUs` \ register2 ->
2750     getNewRegNCG DoubleRep      `thenUs` \ tmp1 ->
2751     getNewRegNCG DoubleRep      `thenUs` \ tmp2 ->
2752     let
2753         code1 = registerCode register1 tmp1
2754         src1  = registerName register1 tmp1
2755
2756         code2 = registerCode register2 tmp2
2757         src2  = registerName register2 tmp2
2758
2759         code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2760                       mkSeqInstr (instr src1 src2 dst)
2761     in
2762     returnUs (Any DoubleRep code__2)
2763
2764 trivialUFCode _ instr x
2765   = getRegister x               `thenUs` \ register ->
2766     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
2767     let
2768         code = registerCode register tmp
2769         src  = registerName register tmp
2770         code__2 dst = code . mkSeqInstr (instr src dst)
2771     in
2772     returnUs (Any DoubleRep code__2)
2773
2774 #endif {- alpha_TARGET_ARCH -}
2775 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2776 #if i386_TARGET_ARCH
2777
2778 trivialCode instr x y
2779   | maybeToBool imm
2780   = getRegister x               `thenUs` \ register1 ->
2781     --getNewRegNCG IntRep       `thenUs` \ tmp1 ->
2782     let
2783 --      fixedname  = registerName register1 eax
2784         code__2 dst = let code1 = registerCode register1 dst
2785                           src1  = registerName register1 dst
2786                       in code1 .
2787                          if isFixed register1 && src1 /= dst
2788                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2789                                            instr (OpImm imm__2) (OpReg dst)]
2790                          else
2791                                 mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
2792     in
2793     returnUs (Any IntRep code__2)
2794   where
2795     imm = maybeImm y
2796     imm__2 = case imm of Just x -> x
2797
2798 trivialCode instr x y
2799   | maybeToBool imm
2800   = getRegister y               `thenUs` \ register1 ->
2801     --getNewRegNCG IntRep       `thenUs` \ tmp1 ->
2802     let
2803 --      fixedname  = registerName register1 eax
2804         code__2 dst = let code1 = registerCode register1 dst
2805                           src1  = registerName register1 dst
2806                       in code1 .
2807                          if isFixed register1 && src1 /= dst
2808                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2809                                            instr (OpImm imm__2) (OpReg dst)]
2810                          else
2811                                 mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
2812     in
2813     returnUs (Any IntRep code__2)
2814   where
2815     imm = maybeImm x
2816     imm__2 = case imm of Just x -> x
2817
2818 trivialCode instr x (StInd pk mem)
2819   = getRegister x               `thenUs` \ register ->
2820     --getNewRegNCG IntRep       `thenUs` \ tmp ->
2821     getAmode mem                `thenUs` \ amode ->
2822     let
2823 --      fixedname  = registerName register eax
2824         code2 = amodeCode amode asmVoid
2825         src2  = amodeAddr amode
2826         code__2 dst = let code1 = registerCode register dst asmVoid
2827                           src1  = registerName register dst
2828                       in asmParThen [code1, code2] .
2829                          if isFixed register && src1 /= dst
2830                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2831                                            instr (OpAddr src2)  (OpReg dst)]
2832                          else
2833                                 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2834     in
2835     returnUs (Any pk code__2)
2836
2837 trivialCode instr (StInd pk mem) y
2838   = getRegister y               `thenUs` \ register ->
2839     --getNewRegNCG IntRep       `thenUs` \ tmp ->
2840     getAmode mem                `thenUs` \ amode ->
2841     let
2842 --      fixedname  = registerName register eax
2843         code2 = amodeCode amode asmVoid
2844         src2  = amodeAddr amode
2845         code__2 dst = let
2846                           code1 = registerCode register dst asmVoid
2847                           src1  = registerName register dst
2848                       in asmParThen [code1, code2] .
2849                          if isFixed register && src1 /= dst
2850                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2851                                            instr (OpAddr src2)  (OpReg dst)]
2852                          else
2853                                 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2854     in
2855     returnUs (Any pk code__2)
2856
2857 trivialCode instr x y
2858   = getRegister x               `thenUs` \ register1 ->
2859     getRegister y               `thenUs` \ register2 ->
2860     --getNewRegNCG IntRep       `thenUs` \ tmp1 ->
2861     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2862     let
2863 --      fixedname  = registerName register1 eax
2864         code2 = registerCode register2 tmp2 asmVoid
2865         src2  = registerName register2 tmp2
2866         code__2 dst = let
2867                           code1 = registerCode register1 dst asmVoid
2868                           src1  = registerName register1 dst
2869                       in asmParThen [code1, code2] .
2870                          if isFixed register1 && src1 /= dst
2871                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2872                                            instr (OpReg src2)  (OpReg dst)]
2873                          else
2874                                 mkSeqInstr (instr (OpReg src2) (OpReg src1))
2875     in
2876     returnUs (Any IntRep code__2)
2877
2878 -----------
2879 trivialUCode instr x
2880   = getRegister x               `thenUs` \ register ->
2881 --    getNewRegNCG IntRep       `thenUs` \ tmp ->
2882     let
2883 --      fixedname = registerName register eax
2884         code__2 dst = let
2885                           code = registerCode register dst
2886                           src  = registerName register dst
2887                       in code . if isFixed register && dst /= src
2888                                 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
2889                                                   instr (OpReg dst)]
2890                                 else mkSeqInstr (instr (OpReg src))
2891     in
2892     returnUs (Any IntRep code__2)
2893
2894 -----------
2895 trivialFCode pk _ instrr _ _ (StInd pk' mem) y
2896   = getRegister y               `thenUs` \ register2 ->
2897     --getNewRegNCG (registerRep register2)
2898     --                          `thenUs` \ tmp2 ->
2899     getAmode mem                `thenUs` \ amode ->
2900     let
2901         code1 = amodeCode amode
2902         src1  = amodeAddr amode
2903
2904         code__2 dst = let
2905                           code2 = registerCode register2 dst
2906                           src2  = registerName register2 dst
2907                       in asmParThen [code1 asmVoid,code2 asmVoid] .
2908                          mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
2909     in
2910     returnUs (Any pk code__2)
2911
2912 trivialFCode pk instr _ _ _ x (StInd pk' mem)
2913   = getRegister x               `thenUs` \ register1 ->
2914     --getNewRegNCG (registerRep register1)
2915     --                          `thenUs` \ tmp1 ->
2916     getAmode mem                `thenUs` \ amode ->
2917     let
2918         code2 = amodeCode amode
2919         src2  = amodeAddr amode
2920
2921         code__2 dst = let
2922                           code1 = registerCode register1 dst
2923                           src1  = registerName register1 dst
2924                       in asmParThen [code2 asmVoid,code1 asmVoid] .
2925                          mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
2926     in
2927     returnUs (Any pk code__2)
2928
2929 trivialFCode pk _ _ _ instrpr x y
2930   = getRegister x               `thenUs` \ register1 ->
2931     getRegister y               `thenUs` \ register2 ->
2932     --getNewRegNCG (registerRep register1)
2933     --                          `thenUs` \ tmp1 ->
2934     --getNewRegNCG (registerRep register2)
2935     --                          `thenUs` \ tmp2 ->
2936     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
2937     let
2938         pk1   = registerRep register1
2939         code1 = registerCode register1 st0 --tmp1
2940         src1  = registerName register1 st0 --tmp1
2941
2942         pk2   = registerRep register2
2943
2944         code__2 dst = let
2945                           code2 = registerCode register2 dst
2946                           src2  = registerName register2 dst
2947                       in asmParThen [code1 asmVoid, code2 asmVoid] .
2948                          mkSeqInstr instrpr
2949     in
2950     returnUs (Any pk1 code__2)
2951
2952 -------------
2953 trivialUFCode pk instr (StInd pk' mem)
2954   = getAmode mem                `thenUs` \ amode ->
2955     let
2956         code = amodeCode amode
2957         src  = amodeAddr amode
2958         code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
2959                                           instr]
2960     in
2961     returnUs (Any pk code__2)
2962
2963 trivialUFCode pk instr x
2964   = getRegister x               `thenUs` \ register ->
2965     --getNewRegNCG pk           `thenUs` \ tmp ->
2966     let
2967         code__2 dst = let
2968                           code = registerCode register dst
2969                           src  = registerName register dst
2970                       in code . mkSeqInstrs [instr]
2971     in
2972     returnUs (Any pk code__2)
2973
2974 #endif {- i386_TARGET_ARCH -}
2975 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2976 #if sparc_TARGET_ARCH
2977
2978 trivialCode instr x (StInt y)
2979   | fits13Bits y
2980   = getRegister x               `thenUs` \ register ->
2981     getNewRegNCG IntRep         `thenUs` \ tmp ->
2982     let
2983         code = registerCode register tmp
2984         src1 = registerName register tmp
2985         src2 = ImmInt (fromInteger y)
2986         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2987     in
2988     returnUs (Any IntRep code__2)
2989
2990 trivialCode instr x y
2991   = getRegister x               `thenUs` \ register1 ->
2992     getRegister y               `thenUs` \ register2 ->
2993     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2994     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2995     let
2996         code1 = registerCode register1 tmp1 asmVoid
2997         src1  = registerName register1 tmp1
2998         code2 = registerCode register2 tmp2 asmVoid
2999         src2  = registerName register2 tmp2
3000         code__2 dst = asmParThen [code1, code2] .
3001                      mkSeqInstr (instr src1 (RIReg src2) dst)
3002     in
3003     returnUs (Any IntRep code__2)
3004
3005 ------------
3006 trivialFCode pk instr x y
3007   = getRegister x               `thenUs` \ register1 ->
3008     getRegister y               `thenUs` \ register2 ->
3009     getNewRegNCG (registerRep register1)
3010                                 `thenUs` \ tmp1 ->
3011     getNewRegNCG (registerRep register2)
3012                                 `thenUs` \ tmp2 ->
3013     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
3014     let
3015         promote x = asmInstr (FxTOy F DF x tmp)
3016
3017         pk1   = registerRep register1
3018         code1 = registerCode register1 tmp1
3019         src1  = registerName register1 tmp1
3020
3021         pk2   = registerRep register2
3022         code2 = registerCode register2 tmp2
3023         src2  = registerName register2 tmp2
3024
3025         code__2 dst =
3026                 if pk1 == pk2 then
3027                     asmParThen [code1 asmVoid, code2 asmVoid] .
3028                     mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
3029                 else if pk1 == FloatRep then
3030                     asmParThen [code1 (promote src1), code2 asmVoid] .
3031                     mkSeqInstr (instr DF tmp src2 dst)
3032                 else
3033                     asmParThen [code1 asmVoid, code2 (promote src2)] .
3034                     mkSeqInstr (instr DF src1 tmp dst)
3035     in
3036     returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
3037
3038 ------------
3039 trivialUCode instr x
3040   = getRegister x               `thenUs` \ register ->
3041     getNewRegNCG IntRep         `thenUs` \ tmp ->
3042     let
3043         code = registerCode register tmp
3044         src  = registerName register tmp
3045         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3046     in
3047     returnUs (Any IntRep code__2)
3048
3049 -------------
3050 trivialUFCode pk instr x
3051   = getRegister x               `thenUs` \ register ->
3052     getNewRegNCG pk             `thenUs` \ tmp ->
3053     let
3054         code = registerCode register tmp
3055         src  = registerName register tmp
3056         code__2 dst = code . mkSeqInstr (instr src dst)
3057     in
3058     returnUs (Any pk code__2)
3059
3060 #endif {- sparc_TARGET_ARCH -}
3061 \end{code}
3062
3063 %************************************************************************
3064 %*                                                                      *
3065 \subsubsection{Coercing to/from integer/floating-point...}
3066 %*                                                                      *
3067 %************************************************************************
3068
3069 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3070 to be generated.  Here we just change the type on the Register passed
3071 on up.  The code is machine-independent.
3072
3073 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3074 conversions.  We have to store temporaries in memory to move
3075 between the integer and the floating point register sets.
3076
3077 \begin{code}
3078 coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
3079 coerceFltCode ::            StixTree -> UniqSM Register
3080
3081 coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
3082 coerceFP2Int ::            StixTree -> UniqSM Register
3083
3084 coerceIntCode pk x
3085   = getRegister x               `thenUs` \ register ->
3086     returnUs (
3087     case register of
3088         Fixed _ reg code -> Fixed pk reg code
3089         Any   _ code     -> Any   pk code
3090     )
3091
3092 -------------
3093 coerceFltCode x
3094   = getRegister x               `thenUs` \ register ->
3095     returnUs (
3096     case register of
3097         Fixed _ reg code -> Fixed DoubleRep reg code
3098         Any   _ code     -> Any   DoubleRep code
3099     )
3100 \end{code}
3101
3102 \begin{code}
3103 #if alpha_TARGET_ARCH
3104
3105 coerceInt2FP _ x
3106   = getRegister x               `thenUs` \ register ->
3107     getNewRegNCG IntRep         `thenUs` \ reg ->
3108     let
3109         code = registerCode register reg
3110         src  = registerName register reg
3111
3112         code__2 dst = code . mkSeqInstrs [
3113             ST Q src (spRel 0),
3114             LD TF dst (spRel 0),
3115             CVTxy Q TF dst dst]
3116     in
3117     returnUs (Any DoubleRep code__2)
3118
3119 -------------
3120 coerceFP2Int x
3121   = getRegister x               `thenUs` \ register ->
3122     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
3123     let
3124         code = registerCode register tmp
3125         src  = registerName register tmp
3126
3127         code__2 dst = code . mkSeqInstrs [
3128             CVTxy TF Q src tmp,
3129             ST TF tmp (spRel 0),
3130             LD Q dst (spRel 0)]
3131     in
3132     returnUs (Any IntRep code__2)
3133
3134 #endif {- alpha_TARGET_ARCH -}
3135 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3136 #if i386_TARGET_ARCH
3137
3138 coerceInt2FP pk x
3139   = getRegister x               `thenUs` \ register ->
3140     getNewRegNCG IntRep         `thenUs` \ reg ->
3141     let
3142         code = registerCode register reg
3143         src  = registerName register reg
3144
3145         code__2 dst = code . mkSeqInstrs [
3146         -- to fix: should spill instead of using R1
3147                       MOV L (OpReg src) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
3148                       FILD (primRepToSize pk) (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
3149     in
3150     returnUs (Any pk code__2)
3151
3152 ------------
3153 coerceFP2Int x
3154   = getRegister x               `thenUs` \ register ->
3155     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
3156     let
3157         code = registerCode register tmp
3158         src  = registerName register tmp
3159         pk   = registerRep register
3160
3161         code__2 dst = code . mkSeqInstrs [
3162                                 FRNDINT,
3163                                 FIST L (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)),
3164                                 MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
3165     in
3166     returnUs (Any IntRep code__2)
3167
3168 #endif {- i386_TARGET_ARCH -}
3169 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3170 #if sparc_TARGET_ARCH
3171
3172 coerceInt2FP pk x
3173   = getRegister x               `thenUs` \ register ->
3174     getNewRegNCG IntRep         `thenUs` \ reg ->
3175     let
3176         code = registerCode register reg
3177         src  = registerName register reg
3178
3179         code__2 dst = code . mkSeqInstrs [
3180             ST W src (spRel (-2)),
3181             LD W (spRel (-2)) dst,
3182             FxTOy W (primRepToSize pk) dst dst]
3183     in
3184     returnUs (Any pk code__2)
3185
3186 ------------
3187 coerceFP2Int x
3188   = getRegister x               `thenUs` \ register ->
3189     getNewRegNCG IntRep         `thenUs` \ reg ->
3190     getNewRegNCG FloatRep       `thenUs` \ tmp ->
3191     let
3192         code = registerCode register reg
3193         src  = registerName register reg
3194         pk   = registerRep  register
3195
3196         code__2 dst = code . mkSeqInstrs [
3197             FxTOy (primRepToSize pk) W src tmp,
3198             ST W tmp (spRel (-2)),
3199             LD W (spRel (-2)) dst]
3200     in
3201     returnUs (Any IntRep code__2)
3202
3203 #endif {- sparc_TARGET_ARCH -}
3204 \end{code}
3205
3206 %************************************************************************
3207 %*                                                                      *
3208 \subsubsection{Coercing integer to @Char@...}
3209 %*                                                                      *
3210 %************************************************************************
3211
3212 Integer to character conversion.  Where applicable, we try to do this
3213 in one step if the original object is in memory.
3214
3215 \begin{code}
3216 chrCode :: StixTree -> UniqSM Register
3217
3218 #if alpha_TARGET_ARCH
3219
3220 chrCode x
3221   = getRegister x               `thenUs` \ register ->
3222     getNewRegNCG IntRep         `thenUs` \ reg ->
3223     let
3224         code = registerCode register reg
3225         src  = registerName register reg
3226         code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3227     in
3228     returnUs (Any IntRep code__2)
3229
3230 #endif {- alpha_TARGET_ARCH -}
3231 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3232 #if i386_TARGET_ARCH
3233
3234 chrCode x
3235   = getRegister x               `thenUs` \ register ->
3236     --getNewRegNCG IntRep       `thenUs` \ reg ->
3237     let
3238 --      fixedname = registerName register eax
3239         code__2 dst = let
3240                           code = registerCode register dst
3241                           src  = registerName register dst
3242                       in code .
3243                          if isFixed register && src /= dst
3244                          then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3245                                            AND L (OpImm (ImmInt 255)) (OpReg dst)]
3246                          else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
3247     in
3248     returnUs (Any IntRep code__2)
3249
3250 #endif {- i386_TARGET_ARCH -}
3251 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3252 #if sparc_TARGET_ARCH
3253
3254 chrCode (StInd pk mem)
3255   = getAmode mem                `thenUs` \ amode ->
3256     let
3257         code    = amodeCode amode
3258         src     = amodeAddr amode
3259         src_off = addrOffset src 3
3260         src__2  = case src_off of Just x -> x
3261         code__2 dst = if maybeToBool src_off then
3262                         code . mkSeqInstr (LD BU src__2 dst)
3263                     else
3264                         code . mkSeqInstrs [
3265                             LD (primRepToSize pk) src dst,
3266                             AND False dst (RIImm (ImmInt 255)) dst]
3267     in
3268     returnUs (Any pk code__2)
3269
3270 chrCode x
3271   = getRegister x               `thenUs` \ register ->
3272     getNewRegNCG IntRep         `thenUs` \ reg ->
3273     let
3274         code = registerCode register reg
3275         src  = registerName register reg
3276         code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
3277     in
3278     returnUs (Any IntRep code__2)
3279
3280 #endif {- sparc_TARGET_ARCH -}
3281 \end{code}
3282
3283 %************************************************************************
3284 %*                                                                      *
3285 \subsubsection{Absolute value on integers}
3286 %*                                                                      *
3287 %************************************************************************
3288
3289 Absolute value on integers, mostly for gmp size check macros.  Again,
3290 the argument cannot be an StInt, because genericOpt already folded
3291 constants.
3292
3293 If applicable, do not fill the delay slots here; you will confuse the
3294 register allocator.
3295
3296 \begin{code}
3297 absIntCode :: StixTree -> UniqSM Register
3298
3299 #if alpha_TARGET_ARCH
3300 absIntCode = panic "MachCode.absIntCode: not on Alphas"
3301 #endif {- alpha_TARGET_ARCH -}
3302
3303 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3304 #if i386_TARGET_ARCH
3305
3306 absIntCode x
3307   = getRegister x               `thenUs` \ register ->
3308     --getNewRegNCG IntRep       `thenUs` \ reg ->
3309     getUniqLabelNCG             `thenUs` \ lbl ->
3310     let
3311         code__2 dst = let code = registerCode register dst
3312                           src  = registerName register dst
3313                       in code . if isFixed register && dst /= src
3314                                 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3315                                                   TEST L (OpReg dst) (OpReg dst),
3316                                                   JXX GE lbl,
3317                                                   NEGI L (OpReg dst),
3318                                                   LABEL lbl]
3319                                 else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
3320                                                   JXX GE lbl,
3321                                                   NEGI L (OpReg src),
3322                                                   LABEL lbl]
3323     in
3324     returnUs (Any IntRep code__2)
3325
3326 #endif {- i386_TARGET_ARCH -}
3327 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3328 #if sparc_TARGET_ARCH
3329
3330 absIntCode x
3331   = getRegister x               `thenUs` \ register ->
3332     getNewRegNCG IntRep         `thenUs` \ reg ->
3333     getUniqLabelNCG             `thenUs` \ lbl ->
3334     let
3335         code = registerCode register reg
3336         src  = registerName register reg
3337         code__2 dst = code . mkSeqInstrs [
3338             SUB False True g0 (RIReg src) dst,
3339             BI GE False (ImmCLbl lbl), NOP,
3340             OR False g0 (RIReg src) dst,
3341             LABEL lbl]
3342     in
3343     returnUs (Any IntRep code__2)
3344
3345 #endif {- sparc_TARGET_ARCH -}
3346 \end{code}
3347