ghc/compiler/nativeGen/MachCode.lhs

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