ghc/compiler/nativeGen/MachCode.lhs

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