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