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