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