ghc/compiler/nativeGen/MachCode.lhs

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