ghc/compiler/nativeGen/MachCode.lhs

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