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