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::Integer
 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` \ tmp1 ->
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 tmp1 asmVoid
1808
1809         src__2  = registerName register tmp1
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 tmp1, ST sz tmp1 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     let
1825         pk__2   = registerRep register2
1826         sz__2   = primRepToSize pk__2
1827     in
1828     getNewRegNCG pk__2                      `thenUs` \ tmp ->
1829     let
1830         sz      = primRepToSize pk
1831         dst__2  = registerName register1 g0    -- must be Fixed
1832
1833
1834         reg__2  = if pk /= pk__2 then tmp else dst__2
1835
1836         code    = registerCode register2 reg__2
1837
1838         src__2  = registerName register2 reg__2
1839
1840         code__2 =
1841                 if pk /= pk__2 then
1842                      code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
1843                 else if isFixed register2 then
1844                      code . mkSeqInstr (FMOV sz src__2 dst__2)
1845                 else
1846                      code
1847     in
1848     returnUs code__2
1849
1850 #endif {- sparc_TARGET_ARCH -}
1851 \end{code}
1852
1853 %************************************************************************
1854 %*                                                                      *
1855 \subsection{Generating an unconditional branch}
1856 %*                                                                      *
1857 %************************************************************************
1858
1859 We accept two types of targets: an immediate CLabel or a tree that
1860 gets evaluated into a register.  Any CLabels which are AsmTemporaries
1861 are assumed to be in the local block of code, close enough for a
1862 branch instruction.  Other CLabels are assumed to be far away.
1863
1864 (If applicable) Do not fill the delay slots here; you will confuse the
1865 register allocator.
1866
1867 \begin{code}
1868 genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock
1869
1870 #if alpha_TARGET_ARCH
1871
1872 genJump (StCLbl lbl)
1873   | isAsmTemp lbl = returnInstr (BR target)
1874   | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1875   where
1876     target = ImmCLbl lbl
1877
1878 genJump tree
1879   = getRegister tree                        `thenUs` \ register ->
1880     getNewRegNCG PtrRep             `thenUs` \ tmp ->
1881     let
1882         dst    = registerName register pv
1883         code   = registerCode register pv
1884         target = registerName register pv
1885     in
1886     if isFixed register then
1887         returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1888     else
1889     returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1890
1891 #endif {- alpha_TARGET_ARCH -}
1892 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1893 #if i386_TARGET_ARCH
1894
1895 {-
1896 genJump (StCLbl lbl)
1897   | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
1898   | otherwise     = returnInstrs [JMP (OpImm target)]
1899   where
1900     target = ImmCLbl lbl
1901 -}
1902
1903 genJump (StInd pk mem)
1904   = getAmode mem                    `thenUs` \ amode ->
1905     let
1906         code   = amodeCode amode
1907         target = amodeAddr amode
1908     in
1909     returnSeq code [JMP (OpAddr target)]
1910
1911 genJump tree
1912   | maybeToBool imm
1913   = returnInstr (JMP (OpImm target))
1914
1915   | otherwise
1916   = getRegister tree                        `thenUs` \ register ->
1917     getNewRegNCG PtrRep             `thenUs` \ tmp ->
1918     let
1919         code   = registerCode register tmp
1920         target = registerName register tmp
1921     in
1922     returnSeq code [JMP (OpReg target)]
1923   where
1924     imm    = maybeImm tree
1925     target = case imm of Just x -> x
1926
1927 #endif {- i386_TARGET_ARCH -}
1928 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1929 #if sparc_TARGET_ARCH
1930
1931 genJump (StCLbl lbl)
1932   | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
1933   | otherwise     = returnInstrs [CALL target 0 True, NOP]
1934   where
1935     target = ImmCLbl lbl
1936
1937 genJump tree
1938   = getRegister tree                        `thenUs` \ register ->
1939     getNewRegNCG PtrRep             `thenUs` \ tmp ->
1940     let
1941         code   = registerCode register tmp
1942         target = registerName register tmp
1943     in
1944     returnSeq code [JMP (MachRegsAddrRegReg target g0), NOP]
1945
1946 #endif {- sparc_TARGET_ARCH -}
1947 \end{code}
1948
1949 %************************************************************************
1950 %*                                                                      *
1951 \subsection{Conditional jumps}
1952 %*                                                                      *
1953 %************************************************************************
1954
1955 Conditional jumps are always to local labels, so we can use branch
1956 instructions.  We peek at the arguments to decide what kind of
1957 comparison to do.
1958
1959 ALPHA: For comparisons with 0, we're laughing, because we can just do
1960 the desired conditional branch.
1961
1962 I386: First, we have to ensure that the condition
1963 codes are set according to the supplied comparison operation.
1964
1965 SPARC: First, we have to ensure that the condition codes are set
1966 according to the supplied comparison operation.  We generate slightly
1967 different code for floating point comparisons, because a floating
1968 point operation cannot directly precede a @BF@.  We assume the worst
1969 and fill that slot with a @NOP@.
1970
1971 SPARC: Do not fill the delay slots here; you will confuse the register
1972 allocator.
1973
1974 \begin{code}
1975 genCondJump
1976     :: CLabel       -- the branch target
1977     -> StixTree     -- the condition on which to branch
1978     -> UniqSM InstrBlock
1979
1980 #if alpha_TARGET_ARCH
1981
1982 genCondJump lbl (StPrim op [x, StInt 0])
1983   = getRegister x                           `thenUs` \ register ->
1984     getNewRegNCG (registerRep register)
1985                                     `thenUs` \ tmp ->
1986     let
1987         code   = registerCode register tmp
1988         value  = registerName register tmp
1989         pk     = registerRep register
1990         target = ImmCLbl lbl
1991     in
1992     returnSeq code [BI (cmpOp op) value target]
1993   where
1994     cmpOp CharGtOp = GTT
1995     cmpOp CharGeOp = GE
1996     cmpOp CharEqOp = EQQ
1997     cmpOp CharNeOp = NE
1998     cmpOp CharLtOp = LTT
1999     cmpOp CharLeOp = LE
2000     cmpOp IntGtOp = GTT
2001     cmpOp IntGeOp = GE
2002     cmpOp IntEqOp = EQQ
2003     cmpOp IntNeOp = NE
2004     cmpOp IntLtOp = LTT
2005     cmpOp IntLeOp = LE
2006     cmpOp WordGtOp = NE
2007     cmpOp WordGeOp = ALWAYS
2008     cmpOp WordEqOp = EQQ
2009     cmpOp WordNeOp = NE
2010     cmpOp WordLtOp = NEVER
2011     cmpOp WordLeOp = EQQ
2012     cmpOp AddrGtOp = NE
2013     cmpOp AddrGeOp = ALWAYS
2014     cmpOp AddrEqOp = EQQ
2015     cmpOp AddrNeOp = NE
2016     cmpOp AddrLtOp = NEVER
2017     cmpOp AddrLeOp = EQQ
2018
2019 genCondJump lbl (StPrim op [x, StDouble 0.0])
2020   = getRegister x                           `thenUs` \ register ->
2021     getNewRegNCG (registerRep register)
2022                                     `thenUs` \ tmp ->
2023     let
2024         code   = registerCode register tmp
2025         value  = registerName register tmp
2026         pk     = registerRep register
2027         target = ImmCLbl lbl
2028     in
2029     returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
2030   where
2031     cmpOp FloatGtOp = GTT
2032     cmpOp FloatGeOp = GE
2033     cmpOp FloatEqOp = EQQ
2034     cmpOp FloatNeOp = NE
2035     cmpOp FloatLtOp = LTT
2036     cmpOp FloatLeOp = LE
2037     cmpOp DoubleGtOp = GTT
2038     cmpOp DoubleGeOp = GE
2039     cmpOp DoubleEqOp = EQQ
2040     cmpOp DoubleNeOp = NE
2041     cmpOp DoubleLtOp = LTT
2042     cmpOp DoubleLeOp = LE
2043
2044 genCondJump lbl (StPrim op [x, y])
2045   | fltCmpOp op
2046   = trivialFCode pr instr x y       `thenUs` \ register ->
2047     getNewRegNCG DoubleRep          `thenUs` \ tmp ->
2048     let
2049         code   = registerCode register tmp
2050         result = registerName register tmp
2051         target = ImmCLbl lbl
2052     in
2053     returnUs (code . mkSeqInstr (BF cond result target))
2054   where
2055     pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2056
2057     fltCmpOp op = case op of
2058         FloatGtOp -> True
2059         FloatGeOp -> True
2060         FloatEqOp -> True
2061         FloatNeOp -> True
2062         FloatLtOp -> True
2063         FloatLeOp -> True
2064         DoubleGtOp -> True
2065         DoubleGeOp -> True
2066         DoubleEqOp -> True
2067         DoubleNeOp -> True
2068         DoubleLtOp -> True
2069         DoubleLeOp -> True
2070         _ -> False
2071     (instr, cond) = case op of
2072         FloatGtOp -> (FCMP TF LE, EQQ)
2073         FloatGeOp -> (FCMP TF LTT, EQQ)
2074         FloatEqOp -> (FCMP TF EQQ, NE)
2075         FloatNeOp -> (FCMP TF EQQ, EQQ)
2076         FloatLtOp -> (FCMP TF LTT, NE)
2077         FloatLeOp -> (FCMP TF LE, NE)
2078         DoubleGtOp -> (FCMP TF LE, EQQ)
2079         DoubleGeOp -> (FCMP TF LTT, EQQ)
2080         DoubleEqOp -> (FCMP TF EQQ, NE)
2081         DoubleNeOp -> (FCMP TF EQQ, EQQ)
2082         DoubleLtOp -> (FCMP TF LTT, NE)
2083         DoubleLeOp -> (FCMP TF LE, NE)
2084
2085 genCondJump lbl (StPrim op [x, y])
2086   = trivialCode instr x y           `thenUs` \ register ->
2087     getNewRegNCG IntRep             `thenUs` \ tmp ->
2088     let
2089         code   = registerCode register tmp
2090         result = registerName register tmp
2091         target = ImmCLbl lbl
2092     in
2093     returnUs (code . mkSeqInstr (BI cond result target))
2094   where
2095     (instr, cond) = case op of
2096         CharGtOp -> (CMP LE, EQQ)
2097         CharGeOp -> (CMP LTT, EQQ)
2098         CharEqOp -> (CMP EQQ, NE)
2099         CharNeOp -> (CMP EQQ, EQQ)
2100         CharLtOp -> (CMP LTT, NE)
2101         CharLeOp -> (CMP LE, NE)
2102         IntGtOp -> (CMP LE, EQQ)
2103         IntGeOp -> (CMP LTT, EQQ)
2104         IntEqOp -> (CMP EQQ, NE)
2105         IntNeOp -> (CMP EQQ, EQQ)
2106         IntLtOp -> (CMP LTT, NE)
2107         IntLeOp -> (CMP LE, NE)
2108         WordGtOp -> (CMP ULE, EQQ)
2109         WordGeOp -> (CMP ULT, EQQ)
2110         WordEqOp -> (CMP EQQ, NE)
2111         WordNeOp -> (CMP EQQ, EQQ)
2112         WordLtOp -> (CMP ULT, NE)
2113         WordLeOp -> (CMP ULE, NE)
2114         AddrGtOp -> (CMP ULE, EQQ)
2115         AddrGeOp -> (CMP ULT, EQQ)
2116         AddrEqOp -> (CMP EQQ, NE)
2117         AddrNeOp -> (CMP EQQ, EQQ)
2118         AddrLtOp -> (CMP ULT, NE)
2119         AddrLeOp -> (CMP ULE, NE)
2120
2121 #endif {- alpha_TARGET_ARCH -}
2122 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2123 #if i386_TARGET_ARCH
2124
2125 genCondJump lbl bool
2126   = getCondCode bool                `thenUs` \ condition ->
2127     let
2128         code   = condCode condition
2129         cond   = condName condition
2130         target = ImmCLbl lbl
2131     in
2132     returnSeq code [JXX cond lbl]
2133
2134 #endif {- i386_TARGET_ARCH -}
2135 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2136 #if sparc_TARGET_ARCH
2137
2138 genCondJump lbl bool
2139   = getCondCode bool                `thenUs` \ condition ->
2140     let
2141         code   = condCode condition
2142         cond   = condName condition
2143         target = ImmCLbl lbl
2144     in
2145     returnSeq code (
2146     if condFloat condition then
2147         [NOP, BF cond False target, NOP]
2148     else
2149         [BI cond False target, NOP]
2150     )
2151
2152 #endif {- sparc_TARGET_ARCH -}
2153 \end{code}
2154
2155 %************************************************************************
2156 %*                                                                      *
2157 \subsection{Generating C calls}
2158 %*                                                                      *
2159 %************************************************************************
2160
2161 Now the biggest nightmare---calls.  Most of the nastiness is buried in
2162 @get_arg@, which moves the arguments to the correct registers/stack
2163 locations.  Apart from that, the code is easy.
2164
2165 (If applicable) Do not fill the delay slots here; you will confuse the
2166 register allocator.
2167
2168 \begin{code}
2169 genCCall
2170     :: FAST_STRING      -- function to call
2171     -> PrimRep          -- type of the result
2172     -> [StixTree]       -- arguments (of mixed type)
2173     -> UniqSM InstrBlock
2174
2175 #if alpha_TARGET_ARCH
2176
2177 genCCall fn kind args
2178   = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2179                                     `thenUs` \ ((unused,_), argCode) ->
2180     let
2181         nRegs = length allArgRegs - length unused
2182         code = asmParThen (map ($ asmVoid) argCode)
2183     in
2184         returnSeq code [
2185             LDA pv (AddrImm (ImmLab (ptext fn))),
2186             JSR ra (AddrReg pv) nRegs,
2187             LDGP gp (AddrReg ra)]
2188   where
2189     ------------------------
2190     {-  Try to get a value into a specific register (or registers) for
2191         a call.  The first 6 arguments go into the appropriate
2192         argument register (separate registers for integer and floating
2193         point arguments, but used in lock-step), and the remaining
2194         arguments are dumped to the stack, beginning at 0(sp).  Our
2195         first argument is a pair of the list of remaining argument
2196         registers to be assigned for this call and the next stack
2197         offset to use for overflowing arguments.  This way,
2198         @get_Arg@ can be applied to all of a call's arguments using
2199         @mapAccumLUs@.
2200     -}
2201     get_arg
2202         :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
2203         -> StixTree             -- Current argument
2204         -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2205
2206     -- We have to use up all of our argument registers first...
2207
2208     get_arg ((iDst,fDst):dsts, offset) arg
2209       = getRegister arg                     `thenUs` \ register ->
2210         let
2211             reg  = if isFloatingRep pk then fDst else iDst
2212             code = registerCode register reg
2213             src  = registerName register reg
2214             pk   = registerRep register
2215         in
2216         returnUs (
2217             if isFloatingRep pk then
2218                 ((dsts, offset), if isFixed register then
2219                     code . mkSeqInstr (FMOV src fDst)
2220                     else code)
2221             else
2222                 ((dsts, offset), if isFixed register then
2223                     code . mkSeqInstr (OR src (RIReg src) iDst)
2224                     else code))
2225
2226     -- Once we have run out of argument registers, we move to the
2227     -- stack...
2228
2229     get_arg ([], offset) arg
2230       = getRegister arg                 `thenUs` \ register ->
2231         getNewRegNCG (registerRep register)
2232                                         `thenUs` \ tmp ->
2233         let
2234             code = registerCode register tmp
2235             src  = registerName register tmp
2236             pk   = registerRep register
2237             sz   = primRepToSize pk
2238         in
2239         returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2240
2241 #endif {- alpha_TARGET_ARCH -}
2242 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2243 #if i386_TARGET_ARCH
2244
2245 genCCall fn kind [StInt i]
2246   | fn == SLIT ("PerformGC_wrapper")
2247   = getUniqLabelNCG                 `thenUs` \ lbl ->
2248     let
2249         call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2250                 MOV L (OpImm (ImmCLbl lbl))
2251                       -- this is hardwired
2252                       (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 104))),
2253                 JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
2254                 LABEL lbl]
2255     in
2256     returnInstrs call
2257
2258 genCCall fn kind args
2259   = mapUs get_call_arg args `thenUs` \ argCode ->
2260     let
2261         nargs = length args
2262         code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 80))),
2263                         MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
2264                                    ]
2265                            ]
2266         code2 = asmParThen (map ($ asmVoid) (reverse argCode))
2267         call = [CALL fn__2 -- ,
2268                 -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
2269                 -- MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
2270                 ]
2271     in
2272     returnSeq (code1 . code2) call
2273   where
2274     -- function names that begin with '.' are assumed to be special
2275     -- internally generated names like '.mul,' which don't get an
2276     -- underscore prefix
2277     -- ToDo:needed (WDP 96/03) ???
2278     fn__2 = case (_HEAD_ fn) of
2279               '.' -> ImmLit (ptext fn)
2280               _   -> ImmLab (ptext fn)
2281
2282     ------------
2283     get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock   -- code
2284
2285     get_call_arg arg
2286       = get_op arg              `thenUs` \ (code, op, sz) ->
2287         returnUs (code . mkSeqInstr (PUSH sz op))
2288
2289     ------------
2290     get_op
2291         :: StixTree
2292         -> UniqSM (InstrBlock,Operand, Size)    -- code, operator, size
2293
2294     get_op (StInt i)
2295       = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
2296
2297     get_op (StInd pk mem)
2298       = getAmode mem            `thenUs` \ amode ->
2299         let
2300             code = amodeCode amode --asmVoid
2301             addr = amodeAddr amode
2302             sz   = primRepToSize pk
2303         in
2304         returnUs (code, OpAddr addr, sz)
2305
2306     get_op op
2307       = getRegister op          `thenUs` \ register ->
2308         getNewRegNCG (registerRep register)
2309                                 `thenUs` \ tmp ->
2310         let
2311             code = registerCode register tmp
2312             reg  = registerName register tmp
2313             pk   = registerRep  register
2314             sz   = primRepToSize pk
2315         in
2316         returnUs (code, OpReg reg, sz)
2317
2318 #endif {- i386_TARGET_ARCH -}
2319 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2320 #if sparc_TARGET_ARCH
2321
2322 genCCall fn kind args
2323   = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2324                                     `thenUs` \ ((unused,_), argCode) ->
2325     let
2326         nRegs = length allArgRegs - length unused
2327         call = CALL fn__2 nRegs False
2328         code = asmParThen (map ($ asmVoid) argCode)
2329     in
2330         returnSeq code [call, NOP]
2331   where
2332     -- function names that begin with '.' are assumed to be special
2333     -- internally generated names like '.mul,' which don't get an
2334     -- underscore prefix
2335     -- ToDo:needed (WDP 96/03) ???
2336     fn__2 = case (_HEAD_ fn) of
2337               '.' -> ImmLit (ptext fn)
2338               _   -> ImmLab (ptext fn)
2339
2340     ------------------------------------
2341     {-  Try to get a value into a specific register (or registers) for
2342         a call.  The SPARC calling convention is an absolute
2343         nightmare.  The first 6x32 bits of arguments are mapped into
2344         %o0 through %o5, and the remaining arguments are dumped to the
2345         stack, beginning at [%sp+92].  (Note that %o6 == %sp.)  Our
2346         first argument is a pair of the list of remaining argument
2347         registers to be assigned for this call and the next stack
2348         offset to use for overflowing arguments.  This way,
2349         @get_arg@ can be applied to all of a call's arguments using
2350         @mapAccumL@.
2351     -}
2352     get_arg
2353         :: ([Reg],Int)  -- Argument registers and stack offset (accumulator)
2354         -> StixTree     -- Current argument
2355         -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2356
2357     -- We have to use up all of our argument registers first...
2358
2359     get_arg (dst:dsts, offset) arg
2360       = getRegister arg                 `thenUs` \ register ->
2361         getNewRegNCG (registerRep register)
2362                                         `thenUs` \ tmp ->
2363         let
2364             reg  = if isFloatingRep pk then tmp else dst
2365             code = registerCode register reg
2366             src  = registerName register reg
2367             pk   = registerRep register
2368         in
2369         returnUs (case pk of
2370             DoubleRep ->
2371                 case dsts of
2372                     [] -> (([], offset + 1), code . mkSeqInstrs [
2373                             -- conveniently put the second part in the right stack
2374                             -- location, and load the first part into %o5
2375                             ST DF src (spRel (offset - 1)),
2376                             LD W (spRel (offset - 1)) dst])
2377                     (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
2378                             ST DF src (spRel (-2)),
2379                             LD W (spRel (-2)) dst,
2380                             LD W (spRel (-1)) dst__2])
2381             FloatRep -> ((dsts, offset), code . mkSeqInstrs [
2382                             ST F src (spRel (-2)),
2383                             LD W (spRel (-2)) dst])
2384             _ -> ((dsts, offset), if isFixed register then
2385                                   code . mkSeqInstr (OR False g0 (RIReg src) dst)
2386                                   else code))
2387
2388     -- Once we have run out of argument registers, we move to the
2389     -- stack...
2390
2391     get_arg ([], offset) arg
2392       = getRegister arg                 `thenUs` \ register ->
2393         getNewRegNCG (registerRep register)
2394                                         `thenUs` \ tmp ->
2395         let
2396             code  = registerCode register tmp
2397             src   = registerName register tmp
2398             pk    = registerRep register
2399             sz    = primRepToSize pk
2400             words = if pk == DoubleRep then 2 else 1
2401         in
2402         returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
2403
2404 #endif {- sparc_TARGET_ARCH -}
2405 \end{code}
2406
2407 %************************************************************************
2408 %*                                                                      *
2409 \subsection{Support bits}
2410 %*                                                                      *
2411 %************************************************************************
2412
2413 %************************************************************************
2414 %*                                                                      *
2415 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2416 %*                                                                      *
2417 %************************************************************************
2418
2419 Turn those condition codes into integers now (when they appear on
2420 the right hand side of an assignment).
2421
2422 (If applicable) Do not fill the delay slots here; you will confuse the
2423 register allocator.
2424
2425 \begin{code}
2426 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
2427
2428 #if alpha_TARGET_ARCH
2429 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2430 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2431 #endif {- alpha_TARGET_ARCH -}
2432
2433 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2434 #if i386_TARGET_ARCH
2435
2436 condIntReg cond x y
2437   = condIntCode cond x y        `thenUs` \ condition ->
2438     getNewRegNCG IntRep         `thenUs` \ tmp ->
2439     --getRegister dst           `thenUs` \ register ->
2440     let
2441         --code2 = registerCode register tmp asmVoid
2442         --dst__2  = registerName register tmp
2443         code = condCode condition
2444         cond = condName condition
2445         -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
2446         code__2 dst = code . mkSeqInstrs [
2447             SETCC cond (OpReg tmp),
2448             AND L (OpImm (ImmInt 1)) (OpReg tmp),
2449             MOV L (OpReg tmp) (OpReg dst)]
2450     in
2451     returnUs (Any IntRep code__2)
2452
2453 condFltReg cond x y
2454   = getUniqLabelNCG             `thenUs` \ lbl1 ->
2455     getUniqLabelNCG             `thenUs` \ lbl2 ->
2456     condFltCode cond x y        `thenUs` \ condition ->
2457     let
2458         code = condCode condition
2459         cond = condName condition
2460         code__2 dst = code . mkSeqInstrs [
2461             JXX cond lbl1,
2462             MOV L (OpImm (ImmInt 0)) (OpReg dst),
2463             JXX ALWAYS lbl2,
2464             LABEL lbl1,
2465             MOV L (OpImm (ImmInt 1)) (OpReg dst),
2466             LABEL lbl2]
2467     in
2468     returnUs (Any IntRep code__2)
2469
2470 #endif {- i386_TARGET_ARCH -}
2471 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2472 #if sparc_TARGET_ARCH
2473
2474 condIntReg EQQ x (StInt 0)
2475   = getRegister x               `thenUs` \ register ->
2476     getNewRegNCG IntRep         `thenUs` \ tmp ->
2477     let
2478         code = registerCode register tmp
2479         src  = registerName register tmp
2480         code__2 dst = code . mkSeqInstrs [
2481             SUB False True g0 (RIReg src) g0,
2482             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2483     in
2484     returnUs (Any IntRep code__2)
2485
2486 condIntReg EQQ x y
2487   = getRegister x               `thenUs` \ register1 ->
2488     getRegister y               `thenUs` \ register2 ->
2489     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2490     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2491     let
2492         code1 = registerCode register1 tmp1 asmVoid
2493         src1  = registerName register1 tmp1
2494         code2 = registerCode register2 tmp2 asmVoid
2495         src2  = registerName register2 tmp2
2496         code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2497             XOR False src1 (RIReg src2) dst,
2498             SUB False True g0 (RIReg dst) g0,
2499             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2500     in
2501     returnUs (Any IntRep code__2)
2502
2503 condIntReg NE x (StInt 0)
2504   = getRegister x               `thenUs` \ register ->
2505     getNewRegNCG IntRep         `thenUs` \ tmp ->
2506     let
2507         code = registerCode register tmp
2508         src  = registerName register tmp
2509         code__2 dst = code . mkSeqInstrs [
2510             SUB False True g0 (RIReg src) g0,
2511             ADD True False g0 (RIImm (ImmInt 0)) dst]
2512     in
2513     returnUs (Any IntRep code__2)
2514
2515 condIntReg NE x y
2516   = getRegister x               `thenUs` \ register1 ->
2517     getRegister y               `thenUs` \ register2 ->
2518     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2519     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2520     let
2521         code1 = registerCode register1 tmp1 asmVoid
2522         src1  = registerName register1 tmp1
2523         code2 = registerCode register2 tmp2 asmVoid
2524         src2  = registerName register2 tmp2
2525         code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2526             XOR False src1 (RIReg src2) dst,
2527             SUB False True g0 (RIReg dst) g0,
2528             ADD True False g0 (RIImm (ImmInt 0)) dst]
2529     in
2530     returnUs (Any IntRep code__2)
2531
2532 condIntReg cond x y
2533   = getUniqLabelNCG             `thenUs` \ lbl1 ->
2534     getUniqLabelNCG             `thenUs` \ lbl2 ->
2535     condIntCode cond x y        `thenUs` \ condition ->
2536     let
2537         code = condCode condition
2538         cond = condName condition
2539         code__2 dst = code . mkSeqInstrs [
2540             BI cond False (ImmCLbl lbl1), NOP,
2541             OR False g0 (RIImm (ImmInt 0)) dst,
2542             BI ALWAYS False (ImmCLbl lbl2), NOP,
2543             LABEL lbl1,
2544             OR False g0 (RIImm (ImmInt 1)) dst,
2545             LABEL lbl2]
2546     in
2547     returnUs (Any IntRep code__2)
2548
2549 condFltReg cond x y
2550   = getUniqLabelNCG             `thenUs` \ lbl1 ->
2551     getUniqLabelNCG             `thenUs` \ lbl2 ->
2552     condFltCode cond x y        `thenUs` \ condition ->
2553     let
2554         code = condCode condition
2555         cond = condName condition
2556         code__2 dst = code . mkSeqInstrs [
2557             NOP,
2558             BF cond False (ImmCLbl lbl1), NOP,
2559             OR False g0 (RIImm (ImmInt 0)) dst,
2560             BI ALWAYS False (ImmCLbl lbl2), NOP,
2561             LABEL lbl1,
2562             OR False g0 (RIImm (ImmInt 1)) dst,
2563             LABEL lbl2]
2564     in
2565     returnUs (Any IntRep code__2)
2566
2567 #endif {- sparc_TARGET_ARCH -}
2568 \end{code}
2569
2570 %************************************************************************
2571 %*                                                                      *
2572 \subsubsection{@trivial*Code@: deal with trivial instructions}
2573 %*                                                                      *
2574 %************************************************************************
2575
2576 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2577 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions.  Only look
2578 for constants on the right hand side, because that's where the generic
2579 optimizer will have put them.
2580
2581 Similarly, for unary instructions, we don't have to worry about
2582 matching an StInt as the argument, because genericOpt will already
2583 have handled the constant-folding.
2584
2585 \begin{code}
2586 trivialCode
2587     :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2588       ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2589       ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2590       ,)))
2591     -> StixTree -> StixTree -- the two arguments
2592     -> UniqSM Register
2593
2594 trivialFCode
2595     :: PrimRep
2596     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2597       ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2598       ,IF_ARCH_i386 (
2599               {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
2600                (Size -> Operand -> Instr)
2601             -> (Size -> Operand -> Instr) {-reversed instr-}
2602             -> Instr {-pop-}
2603             -> Instr {-reversed instr: pop-}
2604       ,)))
2605     -> StixTree -> StixTree -- the two arguments
2606     -> UniqSM Register
2607
2608 trivialUCode
2609     :: IF_ARCH_alpha((RI -> Reg -> Instr)
2610       ,IF_ARCH_i386 ((Operand -> Instr)
2611       ,IF_ARCH_sparc((RI -> Reg -> Instr)
2612       ,)))
2613     -> StixTree -- the one argument
2614     -> UniqSM Register
2615
2616 trivialUFCode
2617     :: PrimRep
2618     -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2619       ,IF_ARCH_i386 (Instr
2620       ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2621       ,)))
2622     -> StixTree -- the one argument
2623     -> UniqSM Register
2624
2625 #if alpha_TARGET_ARCH
2626
2627 trivialCode instr x (StInt y)
2628   | fits8Bits y
2629   = getRegister x               `thenUs` \ register ->
2630     getNewRegNCG IntRep         `thenUs` \ tmp ->
2631     let
2632         code = registerCode register tmp
2633         src1 = registerName register tmp
2634         src2 = ImmInt (fromInteger y)
2635         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2636     in
2637     returnUs (Any IntRep code__2)
2638
2639 trivialCode instr x y
2640   = getRegister x               `thenUs` \ register1 ->
2641     getRegister y               `thenUs` \ register2 ->
2642     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2643     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2644     let
2645         code1 = registerCode register1 tmp1 asmVoid
2646         src1  = registerName register1 tmp1
2647         code2 = registerCode register2 tmp2 asmVoid
2648         src2  = registerName register2 tmp2
2649         code__2 dst = asmParThen [code1, code2] .
2650                      mkSeqInstr (instr src1 (RIReg src2) dst)
2651     in
2652     returnUs (Any IntRep code__2)
2653
2654 ------------
2655 trivialUCode instr x
2656   = getRegister x               `thenUs` \ register ->
2657     getNewRegNCG IntRep         `thenUs` \ tmp ->
2658     let
2659         code = registerCode register tmp
2660         src  = registerName register tmp
2661         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2662     in
2663     returnUs (Any IntRep code__2)
2664
2665 ------------
2666 trivialFCode _ instr x y
2667   = getRegister x               `thenUs` \ register1 ->
2668     getRegister y               `thenUs` \ register2 ->
2669     getNewRegNCG DoubleRep      `thenUs` \ tmp1 ->
2670     getNewRegNCG DoubleRep      `thenUs` \ tmp2 ->
2671     let
2672         code1 = registerCode register1 tmp1
2673         src1  = registerName register1 tmp1
2674
2675         code2 = registerCode register2 tmp2
2676         src2  = registerName register2 tmp2
2677
2678         code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2679                       mkSeqInstr (instr src1 src2 dst)
2680     in
2681     returnUs (Any DoubleRep code__2)
2682
2683 trivialUFCode _ instr x
2684   = getRegister x               `thenUs` \ register ->
2685     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
2686     let
2687         code = registerCode register tmp
2688         src  = registerName register tmp
2689         code__2 dst = code . mkSeqInstr (instr src dst)
2690     in
2691     returnUs (Any DoubleRep code__2)
2692
2693 #endif {- alpha_TARGET_ARCH -}
2694 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2695 #if i386_TARGET_ARCH
2696
2697 trivialCode instr x y
2698   | maybeToBool imm
2699   = getRegister x               `thenUs` \ register1 ->
2700     --getNewRegNCG IntRep       `thenUs` \ tmp1 ->
2701     let
2702         fixedname  = registerName register1 eax
2703         code__2 dst = let code1 = registerCode register1 dst
2704                           src1  = registerName register1 dst
2705                       in code1 .
2706                          if isFixed register1 && src1 /= dst
2707                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2708                                            instr (OpImm imm__2) (OpReg dst)]
2709                          else
2710                                 mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
2711     in
2712     returnUs (Any IntRep code__2)
2713   where
2714     imm = maybeImm y
2715     imm__2 = case imm of Just x -> x
2716
2717 trivialCode instr x y
2718   | maybeToBool imm
2719   = getRegister y               `thenUs` \ register1 ->
2720     --getNewRegNCG IntRep       `thenUs` \ tmp1 ->
2721     let
2722         fixedname  = registerName register1 eax
2723         code__2 dst = let code1 = registerCode register1 dst
2724                           src1  = registerName register1 dst
2725                       in code1 .
2726                          if isFixed register1 && src1 /= dst
2727                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2728                                            instr (OpImm imm__2) (OpReg dst)]
2729                          else
2730                                 mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
2731     in
2732     returnUs (Any IntRep code__2)
2733   where
2734     imm = maybeImm x
2735     imm__2 = case imm of Just x -> x
2736
2737 trivialCode instr x (StInd pk mem)
2738   = getRegister x               `thenUs` \ register ->
2739     --getNewRegNCG IntRep       `thenUs` \ tmp ->
2740     getAmode mem                `thenUs` \ amode ->
2741     let
2742         fixedname  = registerName register eax
2743         code2 = amodeCode amode asmVoid
2744         src2  = amodeAddr amode
2745         code__2 dst = let code1 = registerCode register dst asmVoid
2746                           src1  = registerName register dst
2747                       in asmParThen [code1, code2] .
2748                          if isFixed register && src1 /= dst
2749                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2750                                            instr (OpAddr src2)  (OpReg dst)]
2751                          else
2752                                 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2753     in
2754     returnUs (Any pk code__2)
2755
2756 trivialCode instr (StInd pk mem) y
2757   = getRegister y               `thenUs` \ register ->
2758     --getNewRegNCG IntRep       `thenUs` \ tmp ->
2759     getAmode mem                `thenUs` \ amode ->
2760     let
2761         fixedname  = registerName register eax
2762         code2 = amodeCode amode asmVoid
2763         src2  = amodeAddr amode
2764         code__2 dst = let
2765                           code1 = registerCode register dst asmVoid
2766                           src1  = registerName register dst
2767                       in asmParThen [code1, code2] .
2768                          if isFixed register && src1 /= dst
2769                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2770                                            instr (OpAddr src2)  (OpReg dst)]
2771                          else
2772                                 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2773     in
2774     returnUs (Any pk code__2)
2775
2776 trivialCode instr x y
2777   = getRegister x               `thenUs` \ register1 ->
2778     getRegister y               `thenUs` \ register2 ->
2779     --getNewRegNCG IntRep       `thenUs` \ tmp1 ->
2780     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2781     let
2782         fixedname  = registerName register1 eax
2783         code2 = registerCode register2 tmp2 asmVoid
2784         src2  = registerName register2 tmp2
2785         code__2 dst = let
2786                           code1 = registerCode register1 dst asmVoid
2787                           src1  = registerName register1 dst
2788                       in asmParThen [code1, code2] .
2789                          if isFixed register1 && src1 /= dst
2790                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2791                                            instr (OpReg src2)  (OpReg dst)]
2792                          else
2793                                 mkSeqInstr (instr (OpReg src2) (OpReg src1))
2794     in
2795     returnUs (Any IntRep code__2)
2796
2797 -----------
2798 trivialUCode instr x
2799   = getRegister x               `thenUs` \ register ->
2800 --    getNewRegNCG IntRep       `thenUs` \ tmp ->
2801     let
2802 --      fixedname = registerName register eax
2803         code__2 dst = let
2804                           code = registerCode register dst
2805                           src  = registerName register dst
2806                       in code . if isFixed register && dst /= src
2807                                 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
2808                                                   instr (OpReg dst)]
2809                                 else mkSeqInstr (instr (OpReg src))
2810     in
2811     returnUs (Any IntRep code__2)
2812
2813 -----------
2814 trivialFCode pk _ instrr _ _ (StInd pk' mem) y
2815   = getRegister y               `thenUs` \ register2 ->
2816     --getNewRegNCG (registerRep register2)
2817     --                          `thenUs` \ tmp2 ->
2818     getAmode mem                `thenUs` \ amode ->
2819     let
2820         code1 = amodeCode amode
2821         src1  = amodeAddr amode
2822
2823         code__2 dst = let
2824                           code2 = registerCode register2 dst
2825                           src2  = registerName register2 dst
2826                       in asmParThen [code1 asmVoid,code2 asmVoid] .
2827                          mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
2828     in
2829     returnUs (Any pk code__2)
2830
2831 trivialFCode pk instr _ _ _ x (StInd pk' mem)
2832   = getRegister x               `thenUs` \ register1 ->
2833     --getNewRegNCG (registerRep register1)
2834     --                          `thenUs` \ tmp1 ->
2835     getAmode mem                `thenUs` \ amode ->
2836     let
2837         code2 = amodeCode amode
2838         src2  = amodeAddr amode
2839
2840         code__2 dst = let
2841                           code1 = registerCode register1 dst
2842                           src1  = registerName register1 dst
2843                       in asmParThen [code2 asmVoid,code1 asmVoid] .
2844                          mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
2845     in
2846     returnUs (Any pk code__2)
2847
2848 trivialFCode pk _ _ _ instrpr x y
2849   = getRegister x               `thenUs` \ register1 ->
2850     getRegister y               `thenUs` \ register2 ->
2851     --getNewRegNCG (registerRep register1)
2852     --                          `thenUs` \ tmp1 ->
2853     --getNewRegNCG (registerRep register2)
2854     --                          `thenUs` \ tmp2 ->
2855     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
2856     let
2857         pk1   = registerRep register1
2858         code1 = registerCode register1 st0 --tmp1
2859         src1  = registerName register1 st0 --tmp1
2860
2861         pk2   = registerRep register2
2862
2863         code__2 dst = let
2864                           code2 = registerCode register2 dst
2865                           src2  = registerName register2 dst
2866                       in asmParThen [code1 asmVoid, code2 asmVoid] .
2867                          mkSeqInstr instrpr
2868     in
2869     returnUs (Any pk1 code__2)
2870
2871 -------------
2872 trivialUFCode pk instr (StInd pk' mem)
2873   = getAmode mem                `thenUs` \ amode ->
2874     let
2875         code = amodeCode amode
2876         src  = amodeAddr amode
2877         code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
2878                                           instr]
2879     in
2880     returnUs (Any pk code__2)
2881
2882 trivialUFCode pk instr x
2883   = getRegister x               `thenUs` \ register ->
2884     --getNewRegNCG pk           `thenUs` \ tmp ->
2885     let
2886         code__2 dst = let
2887                           code = registerCode register dst
2888                           src  = registerName register dst
2889                       in code . mkSeqInstrs [instr]
2890     in
2891     returnUs (Any pk code__2)
2892
2893 #endif {- i386_TARGET_ARCH -}
2894 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2895 #if sparc_TARGET_ARCH
2896
2897 trivialCode instr x (StInt y)
2898   | fits13Bits y
2899   = getRegister x               `thenUs` \ register ->
2900     getNewRegNCG IntRep         `thenUs` \ tmp ->
2901     let
2902         code = registerCode register tmp
2903         src1 = registerName register tmp
2904         src2 = ImmInt (fromInteger y)
2905         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2906     in
2907     returnUs (Any IntRep code__2)
2908
2909 trivialCode instr x y
2910   = getRegister x               `thenUs` \ register1 ->
2911     getRegister y               `thenUs` \ register2 ->
2912     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2913     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2914     let
2915         code1 = registerCode register1 tmp1 asmVoid
2916         src1  = registerName register1 tmp1
2917         code2 = registerCode register2 tmp2 asmVoid
2918         src2  = registerName register2 tmp2
2919         code__2 dst = asmParThen [code1, code2] .
2920                      mkSeqInstr (instr src1 (RIReg src2) dst)
2921     in
2922     returnUs (Any IntRep code__2)
2923
2924 ------------
2925 trivialFCode pk instr x y
2926   = getRegister x               `thenUs` \ register1 ->
2927     getRegister y               `thenUs` \ register2 ->
2928     getNewRegNCG (registerRep register1)
2929                                 `thenUs` \ tmp1 ->
2930     getNewRegNCG (registerRep register2)
2931                                 `thenUs` \ tmp2 ->
2932     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
2933     let
2934         promote x = asmInstr (FxTOy F DF x tmp)
2935
2936         pk1   = registerRep register1
2937         code1 = registerCode register1 tmp1
2938         src1  = registerName register1 tmp1
2939
2940         pk2   = registerRep register2
2941         code2 = registerCode register2 tmp2
2942         src2  = registerName register2 tmp2
2943
2944         code__2 dst =
2945                 if pk1 == pk2 then
2946                     asmParThen [code1 asmVoid, code2 asmVoid] .
2947                     mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
2948                 else if pk1 == FloatRep then
2949                     asmParThen [code1 (promote src1), code2 asmVoid] .
2950                     mkSeqInstr (instr DF tmp src2 dst)
2951                 else
2952                     asmParThen [code1 asmVoid, code2 (promote src2)] .
2953                     mkSeqInstr (instr DF src1 tmp dst)
2954     in
2955     returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
2956
2957 ------------
2958 trivialUCode instr x
2959   = getRegister x               `thenUs` \ register ->
2960     getNewRegNCG IntRep         `thenUs` \ tmp ->
2961     let
2962         code = registerCode register tmp
2963         src  = registerName register tmp
2964         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2965     in
2966     returnUs (Any IntRep code__2)
2967
2968 -------------
2969 trivialUFCode pk instr x
2970   = getRegister x               `thenUs` \ register ->
2971     getNewRegNCG pk             `thenUs` \ tmp ->
2972     let
2973         code = registerCode register tmp
2974         src  = registerName register tmp
2975         code__2 dst = code . mkSeqInstr (instr src dst)
2976     in
2977     returnUs (Any pk code__2)
2978
2979 #endif {- sparc_TARGET_ARCH -}
2980 \end{code}
2981
2982 %************************************************************************
2983 %*                                                                      *
2984 \subsubsection{Coercing to/from integer/floating-point...}
2985 %*                                                                      *
2986 %************************************************************************
2987
2988 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
2989 to be generated.  Here we just change the type on the Register passed
2990 on up.  The code is machine-independent.
2991
2992 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
2993 conversions.  We have to store temporaries in memory to move
2994 between the integer and the floating point register sets.
2995
2996 \begin{code}
2997 coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
2998 coerceFltCode ::            StixTree -> UniqSM Register
2999
3000 coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
3001 coerceFP2Int ::            StixTree -> UniqSM Register
3002
3003 coerceIntCode pk x
3004   = getRegister x               `thenUs` \ register ->
3005     returnUs (
3006     case register of
3007         Fixed _ reg code -> Fixed pk reg code
3008         Any   _ code     -> Any   pk code
3009     )
3010
3011 -------------
3012 coerceFltCode x
3013   = getRegister x               `thenUs` \ register ->
3014     returnUs (
3015     case register of
3016         Fixed _ reg code -> Fixed DoubleRep reg code
3017         Any   _ code     -> Any   DoubleRep code
3018     )
3019 \end{code}
3020
3021 \begin{code}
3022 #if alpha_TARGET_ARCH
3023
3024 coerceInt2FP _ x
3025   = getRegister x               `thenUs` \ register ->
3026     getNewRegNCG IntRep         `thenUs` \ reg ->
3027     let
3028         code = registerCode register reg
3029         src  = registerName register reg
3030
3031         code__2 dst = code . mkSeqInstrs [
3032             ST Q src (spRel 0),
3033             LD TF dst (spRel 0),
3034             CVTxy Q TF dst dst]
3035     in
3036     returnUs (Any DoubleRep code__2)
3037
3038 -------------
3039 coerceFP2Int x
3040   = getRegister x               `thenUs` \ register ->
3041     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
3042     let
3043         code = registerCode register tmp
3044         src  = registerName register tmp
3045
3046         code__2 dst = code . mkSeqInstrs [
3047             CVTxy TF Q src tmp,
3048             ST TF tmp (spRel 0),
3049             LD Q dst (spRel 0)]
3050     in
3051     returnUs (Any IntRep code__2)
3052
3053 #endif {- alpha_TARGET_ARCH -}
3054 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3055 #if i386_TARGET_ARCH
3056
3057 coerceInt2FP pk x
3058   = getRegister x               `thenUs` \ register ->
3059     getNewRegNCG IntRep         `thenUs` \ reg ->
3060     let
3061         code = registerCode register reg
3062         src  = registerName register reg
3063
3064         code__2 dst = code . mkSeqInstrs [
3065         -- to fix: should spill instead of using R1
3066                       MOV L (OpReg src) (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))),
3067                       FILD (primRepToSize pk) (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
3068     in
3069     returnUs (Any pk code__2)
3070
3071 ------------
3072 coerceFP2Int x
3073   = getRegister x               `thenUs` \ register ->
3074     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
3075     let
3076         code = registerCode register tmp
3077         src  = registerName register tmp
3078         pk   = registerRep register
3079
3080         code__2 dst = let
3081                       in code . mkSeqInstrs [
3082                                 FRNDINT,
3083                                 FIST L (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1)),
3084                                 MOV L (OpAddr (MachRegsAddr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
3085     in
3086     returnUs (Any IntRep code__2)
3087
3088 #endif {- i386_TARGET_ARCH -}
3089 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3090 #if sparc_TARGET_ARCH
3091
3092 coerceInt2FP pk x
3093   = getRegister x               `thenUs` \ register ->
3094     getNewRegNCG IntRep         `thenUs` \ reg ->
3095     let
3096         code = registerCode register reg
3097         src  = registerName register reg
3098
3099         code__2 dst = code . mkSeqInstrs [
3100             ST W src (spRel (-2)),
3101             LD W (spRel (-2)) dst,
3102             FxTOy W (primRepToSize pk) dst dst]
3103     in
3104     returnUs (Any pk code__2)
3105
3106 ------------
3107 coerceFP2Int x
3108   = getRegister x               `thenUs` \ register ->
3109     getNewRegNCG IntRep         `thenUs` \ reg ->
3110     getNewRegNCG FloatRep       `thenUs` \ tmp ->
3111     let
3112         code = registerCode register reg
3113         src  = registerName register reg
3114         pk   = registerRep  register
3115
3116         code__2 dst = code . mkSeqInstrs [
3117             FxTOy (primRepToSize pk) W src tmp,
3118             ST W tmp (spRel (-2)),
3119             LD W (spRel (-2)) dst]
3120     in
3121     returnUs (Any IntRep code__2)
3122
3123 #endif {- sparc_TARGET_ARCH -}
3124 \end{code}
3125
3126 %************************************************************************
3127 %*                                                                      *
3128 \subsubsection{Coercing integer to @Char@...}
3129 %*                                                                      *
3130 %************************************************************************
3131
3132 Integer to character conversion.  Where applicable, we try to do this
3133 in one step if the original object is in memory.
3134
3135 \begin{code}
3136 chrCode :: StixTree -> UniqSM Register
3137
3138 #if alpha_TARGET_ARCH
3139
3140 chrCode x
3141   = getRegister x               `thenUs` \ register ->
3142     getNewRegNCG IntRep         `thenUs` \ reg ->
3143     let
3144         code = registerCode register reg
3145         src  = registerName register reg
3146         code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3147     in
3148     returnUs (Any IntRep code__2)
3149
3150 #endif {- alpha_TARGET_ARCH -}
3151 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3152 #if i386_TARGET_ARCH
3153
3154 chrCode x
3155   = getRegister x               `thenUs` \ register ->
3156     --getNewRegNCG IntRep       `thenUs` \ reg ->
3157     let
3158         fixedname = registerName register eax
3159         code__2 dst = let
3160                           code = registerCode register dst
3161                           src  = registerName register dst
3162                       in code .
3163                          if isFixed register && src /= dst
3164                          then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3165                                            AND L (OpImm (ImmInt 255)) (OpReg dst)]
3166                          else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
3167     in
3168     returnUs (Any IntRep code__2)
3169
3170 #endif {- i386_TARGET_ARCH -}
3171 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3172 #if sparc_TARGET_ARCH
3173
3174 chrCode (StInd pk mem)
3175   = getAmode mem                `thenUs` \ amode ->
3176     let
3177         code    = amodeCode amode
3178         src     = amodeAddr amode
3179         src_off = addrOffset src 3
3180         src__2  = case src_off of Just x -> x
3181         code__2 dst = if maybeToBool src_off then
3182                         code . mkSeqInstr (LD BU src__2 dst)
3183                     else
3184                         code . mkSeqInstrs [
3185                             LD (primRepToSize pk) src dst,
3186                             AND False dst (RIImm (ImmInt 255)) dst]
3187     in
3188     returnUs (Any pk code__2)
3189
3190 chrCode x
3191   = getRegister x               `thenUs` \ register ->
3192     getNewRegNCG IntRep         `thenUs` \ reg ->
3193     let
3194         code = registerCode register reg
3195         src  = registerName register reg
3196         code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
3197     in
3198     returnUs (Any IntRep code__2)
3199
3200 #endif {- sparc_TARGET_ARCH -}
3201 \end{code}
3202
3203 %************************************************************************
3204 %*                                                                      *
3205 \subsubsection{Absolute value on integers}
3206 %*                                                                      *
3207 %************************************************************************
3208
3209 Absolute value on integers, mostly for gmp size check macros.  Again,
3210 the argument cannot be an StInt, because genericOpt already folded
3211 constants.
3212
3213 If applicable, do not fill the delay slots here; you will confuse the
3214 register allocator.
3215
3216 \begin{code}
3217 absIntCode :: StixTree -> UniqSM Register
3218
3219 #if alpha_TARGET_ARCH
3220 absIntCode = panic "MachCode.absIntCode: not on Alphas"
3221 #endif {- alpha_TARGET_ARCH -}
3222
3223 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3224 #if i386_TARGET_ARCH
3225
3226 absIntCode x
3227   = getRegister x               `thenUs` \ register ->
3228     --getNewRegNCG IntRep       `thenUs` \ reg ->
3229     getUniqLabelNCG             `thenUs` \ lbl ->
3230     let
3231         code__2 dst = let code = registerCode register dst
3232                           src  = registerName register dst
3233                       in code . if isFixed register && dst /= src
3234                                 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3235                                                   TEST L (OpReg dst) (OpReg dst),
3236                                                   JXX GE lbl,
3237                                                   NEGI L (OpReg dst),
3238                                                   LABEL lbl]
3239                                 else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
3240                                                   JXX GE lbl,
3241                                                   NEGI L (OpReg src),
3242                                                   LABEL lbl]
3243     in
3244     returnUs (Any IntRep code__2)
3245
3246 #endif {- i386_TARGET_ARCH -}
3247 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3248 #if sparc_TARGET_ARCH
3249
3250 absIntCode x
3251   = getRegister x               `thenUs` \ register ->
3252     getNewRegNCG IntRep         `thenUs` \ reg ->
3253     getUniqLabelNCG             `thenUs` \ lbl ->
3254     let
3255         code = registerCode register reg
3256         src  = registerName register reg
3257         code__2 dst = code . mkSeqInstrs [
3258             SUB False True g0 (RIReg src) dst,
3259             BI GE False (ImmCLbl lbl), NOP,
3260             OR False g0 (RIReg src) dst,
3261             LABEL lbl]
3262     in
3263     returnUs (Any IntRep code__2)
3264
3265 #endif {- sparc_TARGET_ARCH -}
3266 \end{code}
3267