ghc/compiler/nativeGen/MachCode.lhs

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