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