ghc/compiler/nativeGen/MachCode.lhs

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