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