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