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, ImmDouble 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 [ImmDouble 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 [ImmDouble 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 call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2288                 CALL (ImmLit (ptext (if   underscorePrefix
2289                                      then (SLIT ("_PerformGC_wrapper"))
2290                                      else (SLIT ("PerformGC_wrapper")))))]
2291     in
2292     returnInstrs call
2293
2294
2295 genCCall fn cconv kind args
2296   = mapUs get_call_arg args `thenUs` \ sizes_and_argCodes ->
2297     let
2298         (sizes, argCode) = unzip sizes_and_argCodes
2299         tot_arg_size = sum (map (\sz -> case sz of DF -> 8; _ -> 4) sizes)
2300
2301         code2 = asmParThen (map ($ asmVoid) (reverse argCode))
2302         call = [CALL fn__2 ,
2303                 ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)
2304                ]
2305     in
2306     returnSeq (code2) call
2307
2308   where
2309     -- function names that begin with '.' are assumed to be special
2310     -- internally generated names like '.mul,' which don't get an
2311     -- underscore prefix
2312     -- ToDo:needed (WDP 96/03) ???
2313     fn__2 = case (_HEAD_ fn) of
2314               '.' -> ImmLit (ptext fn)
2315               _   -> ImmLab (ptext fn)
2316
2317     ------------
2318     get_call_arg :: StixTree{-current argument-}
2319                     -> UniqSM (Size, InstrBlock)  -- arg size, code
2320
2321     get_call_arg arg
2322       = get_op arg              `thenUs` \ (code, op, sz) ->
2323         case sz of
2324            DF -> returnUs (sz,
2325                            code .
2326                            mkSeqInstr (FLD L op) .
2327                            mkSeqInstr (SUB L (OpImm (ImmInt 8)) (OpReg esp)) .
2328                            mkSeqInstr (FSTP DF (OpAddr (AddrBaseIndex
2329                                                           (Just esp)
2330                                                           Nothing (ImmInt 0))))
2331                           )
2332            _  -> returnUs (sz,
2333                            code . mkSeqInstr (PUSH sz op))
2334
2335     ------------
2336     get_op
2337         :: StixTree
2338         -> UniqSM (InstrBlock,Operand, Size)    -- code, operator, size
2339
2340     get_op (StInt i)
2341       = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
2342
2343     get_op (StInd pk mem)
2344       = getAmode mem            `thenUs` \ amode ->
2345         let
2346             code = amodeCode amode --asmVoid
2347             addr = amodeAddr amode
2348             sz   = primRepToSize pk
2349         in
2350         returnUs (code, OpAddr addr, sz)
2351
2352     get_op op
2353       = getRegister op          `thenUs` \ register ->
2354         getNewRegNCG (registerRep register)
2355                                 `thenUs` \ tmp ->
2356         let
2357             code = registerCode register tmp
2358             reg  = registerName register tmp
2359             pk   = registerRep  register
2360             sz   = primRepToSize pk
2361         in
2362         returnUs (code, OpReg reg, sz)
2363
2364 #endif {- i386_TARGET_ARCH -}
2365 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2366 #if sparc_TARGET_ARCH
2367
2368 genCCall fn cconv kind args
2369   = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2370                                     `thenUs` \ ((unused,_), argCode) ->
2371     let
2372         nRegs = length allArgRegs - length unused
2373         call = CALL fn__2 nRegs False
2374         code = asmParThen (map ($ asmVoid) argCode)
2375     in
2376         returnSeq code [call, NOP]
2377   where
2378     -- function names that begin with '.' are assumed to be special
2379     -- internally generated names like '.mul,' which don't get an
2380     -- underscore prefix
2381     -- ToDo:needed (WDP 96/03) ???
2382     fn__2 = case (_HEAD_ fn) of
2383               '.' -> ImmLit (ptext fn)
2384               _   -> ImmLab (ptext fn)
2385
2386     ------------------------------------
2387     {-  Try to get a value into a specific register (or registers) for
2388         a call.  The SPARC calling convention is an absolute
2389         nightmare.  The first 6x32 bits of arguments are mapped into
2390         %o0 through %o5, and the remaining arguments are dumped to the
2391         stack, beginning at [%sp+92].  (Note that %o6 == %sp.)  Our
2392         first argument is a pair of the list of remaining argument
2393         registers to be assigned for this call and the next stack
2394         offset to use for overflowing arguments.  This way,
2395         @get_arg@ can be applied to all of a call's arguments using
2396         @mapAccumL@.
2397     -}
2398     get_arg
2399         :: ([Reg],Int)  -- Argument registers and stack offset (accumulator)
2400         -> StixTree     -- Current argument
2401         -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2402
2403     -- We have to use up all of our argument registers first...
2404
2405     get_arg (dst:dsts, offset) arg
2406       = getRegister arg                 `thenUs` \ register ->
2407         getNewRegNCG (registerRep register)
2408                                         `thenUs` \ tmp ->
2409         let
2410             reg  = if isFloatingRep pk then tmp else dst
2411             code = registerCode register reg
2412             src  = registerName register reg
2413             pk   = registerRep register
2414         in
2415         returnUs (case pk of
2416             DoubleRep ->
2417                 case dsts of
2418                     [] -> (([], offset + 1), code . mkSeqInstrs [
2419                             -- conveniently put the second part in the right stack
2420                             -- location, and load the first part into %o5
2421                             ST DF src (spRel (offset - 1)),
2422                             LD W (spRel (offset - 1)) dst])
2423                     (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
2424                             ST DF src (spRel (-2)),
2425                             LD W (spRel (-2)) dst,
2426                             LD W (spRel (-1)) dst__2])
2427             FloatRep -> ((dsts, offset), code . mkSeqInstrs [
2428                             ST F src (spRel (-2)),
2429                             LD W (spRel (-2)) dst])
2430             _ -> ((dsts, offset), if isFixed register then
2431                                   code . mkSeqInstr (OR False g0 (RIReg src) dst)
2432                                   else code))
2433
2434     -- Once we have run out of argument registers, we move to the
2435     -- stack...
2436
2437     get_arg ([], offset) arg
2438       = getRegister arg                 `thenUs` \ register ->
2439         getNewRegNCG (registerRep register)
2440                                         `thenUs` \ tmp ->
2441         let
2442             code  = registerCode register tmp
2443             src   = registerName register tmp
2444             pk    = registerRep register
2445             sz    = primRepToSize pk
2446             words = if pk == DoubleRep then 2 else 1
2447         in
2448         returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
2449
2450 #endif {- sparc_TARGET_ARCH -}
2451 \end{code}
2452
2453 %************************************************************************
2454 %*                                                                      *
2455 \subsection{Support bits}
2456 %*                                                                      *
2457 %************************************************************************
2458
2459 %************************************************************************
2460 %*                                                                      *
2461 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2462 %*                                                                      *
2463 %************************************************************************
2464
2465 Turn those condition codes into integers now (when they appear on
2466 the right hand side of an assignment).
2467
2468 (If applicable) Do not fill the delay slots here; you will confuse the
2469 register allocator.
2470
2471 \begin{code}
2472 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
2473
2474 #if alpha_TARGET_ARCH
2475 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2476 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2477 #endif {- alpha_TARGET_ARCH -}
2478
2479 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2480 #if i386_TARGET_ARCH
2481
2482 condIntReg cond x y
2483   = condIntCode cond x y        `thenUs` \ condition ->
2484     getNewRegNCG IntRep         `thenUs` \ tmp ->
2485     --getRegister dst           `thenUs` \ register ->
2486     let
2487         --code2 = registerCode register tmp asmVoid
2488         --dst__2  = registerName register tmp
2489         code = condCode condition
2490         cond = condName condition
2491         -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
2492         code__2 dst = code . mkSeqInstrs [
2493             SETCC cond (OpReg tmp),
2494             AND L (OpImm (ImmInt 1)) (OpReg tmp),
2495             MOV L (OpReg tmp) (OpReg dst)]
2496     in
2497     returnUs (Any IntRep code__2)
2498
2499 condFltReg cond x y
2500   = getUniqLabelNCG             `thenUs` \ lbl1 ->
2501     getUniqLabelNCG             `thenUs` \ lbl2 ->
2502     condFltCode cond x y        `thenUs` \ condition ->
2503     let
2504         code = condCode condition
2505         cond = condName condition
2506         code__2 dst = code . mkSeqInstrs [
2507             JXX cond lbl1,
2508             MOV L (OpImm (ImmInt 0)) (OpReg dst),
2509             JXX ALWAYS lbl2,
2510             LABEL lbl1,
2511             MOV L (OpImm (ImmInt 1)) (OpReg dst),
2512             LABEL lbl2]
2513     in
2514     returnUs (Any IntRep code__2)
2515
2516 #endif {- i386_TARGET_ARCH -}
2517 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2518 #if sparc_TARGET_ARCH
2519
2520 condIntReg EQQ x (StInt 0)
2521   = getRegister x               `thenUs` \ register ->
2522     getNewRegNCG IntRep         `thenUs` \ tmp ->
2523     let
2524         code = registerCode register tmp
2525         src  = registerName register tmp
2526         code__2 dst = code . mkSeqInstrs [
2527             SUB False True g0 (RIReg src) g0,
2528             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2529     in
2530     returnUs (Any IntRep code__2)
2531
2532 condIntReg EQQ x y
2533   = getRegister x               `thenUs` \ register1 ->
2534     getRegister y               `thenUs` \ register2 ->
2535     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2536     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2537     let
2538         code1 = registerCode register1 tmp1 asmVoid
2539         src1  = registerName register1 tmp1
2540         code2 = registerCode register2 tmp2 asmVoid
2541         src2  = registerName register2 tmp2
2542         code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2543             XOR False src1 (RIReg src2) dst,
2544             SUB False True g0 (RIReg dst) g0,
2545             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2546     in
2547     returnUs (Any IntRep code__2)
2548
2549 condIntReg NE x (StInt 0)
2550   = getRegister x               `thenUs` \ register ->
2551     getNewRegNCG IntRep         `thenUs` \ tmp ->
2552     let
2553         code = registerCode register tmp
2554         src  = registerName register tmp
2555         code__2 dst = code . mkSeqInstrs [
2556             SUB False True g0 (RIReg src) g0,
2557             ADD True False g0 (RIImm (ImmInt 0)) dst]
2558     in
2559     returnUs (Any IntRep code__2)
2560
2561 condIntReg NE x y
2562   = getRegister x               `thenUs` \ register1 ->
2563     getRegister y               `thenUs` \ register2 ->
2564     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2565     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2566     let
2567         code1 = registerCode register1 tmp1 asmVoid
2568         src1  = registerName register1 tmp1
2569         code2 = registerCode register2 tmp2 asmVoid
2570         src2  = registerName register2 tmp2
2571         code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2572             XOR False src1 (RIReg src2) dst,
2573             SUB False True g0 (RIReg dst) g0,
2574             ADD True False g0 (RIImm (ImmInt 0)) dst]
2575     in
2576     returnUs (Any IntRep code__2)
2577
2578 condIntReg cond x y
2579   = getUniqLabelNCG             `thenUs` \ lbl1 ->
2580     getUniqLabelNCG             `thenUs` \ lbl2 ->
2581     condIntCode cond x y        `thenUs` \ condition ->
2582     let
2583         code = condCode condition
2584         cond = condName condition
2585         code__2 dst = code . mkSeqInstrs [
2586             BI cond False (ImmCLbl lbl1), NOP,
2587             OR False g0 (RIImm (ImmInt 0)) dst,
2588             BI ALWAYS False (ImmCLbl lbl2), NOP,
2589             LABEL lbl1,
2590             OR False g0 (RIImm (ImmInt 1)) dst,
2591             LABEL lbl2]
2592     in
2593     returnUs (Any IntRep code__2)
2594
2595 condFltReg cond x y
2596   = getUniqLabelNCG             `thenUs` \ lbl1 ->
2597     getUniqLabelNCG             `thenUs` \ lbl2 ->
2598     condFltCode cond x y        `thenUs` \ condition ->
2599     let
2600         code = condCode condition
2601         cond = condName condition
2602         code__2 dst = code . mkSeqInstrs [
2603             NOP,
2604             BF cond False (ImmCLbl lbl1), NOP,
2605             OR False g0 (RIImm (ImmInt 0)) dst,
2606             BI ALWAYS False (ImmCLbl lbl2), NOP,
2607             LABEL lbl1,
2608             OR False g0 (RIImm (ImmInt 1)) dst,
2609             LABEL lbl2]
2610     in
2611     returnUs (Any IntRep code__2)
2612
2613 #endif {- sparc_TARGET_ARCH -}
2614 \end{code}
2615
2616 %************************************************************************
2617 %*                                                                      *
2618 \subsubsection{@trivial*Code@: deal with trivial instructions}
2619 %*                                                                      *
2620 %************************************************************************
2621
2622 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2623 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions.  Only look
2624 for constants on the right hand side, because that's where the generic
2625 optimizer will have put them.
2626
2627 Similarly, for unary instructions, we don't have to worry about
2628 matching an StInt as the argument, because genericOpt will already
2629 have handled the constant-folding.
2630
2631 \begin{code}
2632 trivialCode
2633     :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2634       ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2635       ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2636       ,)))
2637     -> StixTree -> StixTree -- the two arguments
2638     -> UniqSM Register
2639
2640 trivialFCode
2641     :: PrimRep
2642     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2643       ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2644       ,IF_ARCH_i386 (
2645               {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
2646                (Size -> Operand -> Instr)
2647             -> (Size -> Operand -> Instr) {-reversed instr-}
2648             -> Instr {-pop-}
2649             -> Instr {-reversed instr: pop-}
2650       ,)))
2651     -> StixTree -> StixTree -- the two arguments
2652     -> UniqSM Register
2653
2654 trivialUCode
2655     :: IF_ARCH_alpha((RI -> Reg -> Instr)
2656       ,IF_ARCH_i386 ((Operand -> Instr)
2657       ,IF_ARCH_sparc((RI -> Reg -> Instr)
2658       ,)))
2659     -> StixTree -- the one argument
2660     -> UniqSM Register
2661
2662 trivialUFCode
2663     :: PrimRep
2664     -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2665       ,IF_ARCH_i386 (Instr
2666       ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2667       ,)))
2668     -> StixTree -- the one argument
2669     -> UniqSM Register
2670
2671 #if alpha_TARGET_ARCH
2672
2673 trivialCode instr x (StInt y)
2674   | fits8Bits y
2675   = getRegister x               `thenUs` \ register ->
2676     getNewRegNCG IntRep         `thenUs` \ tmp ->
2677     let
2678         code = registerCode register tmp
2679         src1 = registerName register tmp
2680         src2 = ImmInt (fromInteger y)
2681         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2682     in
2683     returnUs (Any IntRep code__2)
2684
2685 trivialCode instr x y
2686   = getRegister x               `thenUs` \ register1 ->
2687     getRegister y               `thenUs` \ register2 ->
2688     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2689     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2690     let
2691         code1 = registerCode register1 tmp1 asmVoid
2692         src1  = registerName register1 tmp1
2693         code2 = registerCode register2 tmp2 asmVoid
2694         src2  = registerName register2 tmp2
2695         code__2 dst = asmParThen [code1, code2] .
2696                      mkSeqInstr (instr src1 (RIReg src2) dst)
2697     in
2698     returnUs (Any IntRep code__2)
2699
2700 ------------
2701 trivialUCode instr x
2702   = getRegister x               `thenUs` \ register ->
2703     getNewRegNCG IntRep         `thenUs` \ tmp ->
2704     let
2705         code = registerCode register tmp
2706         src  = registerName register tmp
2707         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2708     in
2709     returnUs (Any IntRep code__2)
2710
2711 ------------
2712 trivialFCode _ instr x y
2713   = getRegister x               `thenUs` \ register1 ->
2714     getRegister y               `thenUs` \ register2 ->
2715     getNewRegNCG DoubleRep      `thenUs` \ tmp1 ->
2716     getNewRegNCG DoubleRep      `thenUs` \ tmp2 ->
2717     let
2718         code1 = registerCode register1 tmp1
2719         src1  = registerName register1 tmp1
2720
2721         code2 = registerCode register2 tmp2
2722         src2  = registerName register2 tmp2
2723
2724         code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2725                       mkSeqInstr (instr src1 src2 dst)
2726     in
2727     returnUs (Any DoubleRep code__2)
2728
2729 trivialUFCode _ instr x
2730   = getRegister x               `thenUs` \ register ->
2731     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
2732     let
2733         code = registerCode register tmp
2734         src  = registerName register tmp
2735         code__2 dst = code . mkSeqInstr (instr src dst)
2736     in
2737     returnUs (Any DoubleRep code__2)
2738
2739 #endif {- alpha_TARGET_ARCH -}
2740 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2741 #if i386_TARGET_ARCH
2742
2743 trivialCode instr x y
2744   | maybeToBool imm
2745   = getRegister x               `thenUs` \ register1 ->
2746     --getNewRegNCG IntRep       `thenUs` \ tmp1 ->
2747     let
2748         code__2 dst = let code1 = registerCode register1 dst
2749                           src1  = registerName register1 dst
2750                       in code1 .
2751                          if isFixed register1 && src1 /= dst
2752                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2753                                            instr (OpImm imm__2) (OpReg dst)]
2754                          else
2755                                 mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
2756     in
2757     returnUs (Any IntRep code__2)
2758   where
2759     imm = maybeImm y
2760     imm__2 = case imm of Just x -> x
2761
2762 trivialCode instr x y
2763   | maybeToBool imm
2764   = getRegister y               `thenUs` \ register1 ->
2765     --getNewRegNCG IntRep       `thenUs` \ tmp1 ->
2766     let
2767         code__2 dst = let code1 = registerCode register1 dst
2768                           src1  = registerName register1 dst
2769                       in code1 .
2770                          if isFixed register1 && src1 /= dst
2771                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2772                                            instr (OpImm imm__2) (OpReg dst)]
2773                          else
2774                                 mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
2775     in
2776     returnUs (Any IntRep code__2)
2777   where
2778     imm = maybeImm x
2779     imm__2 = case imm of Just x -> x
2780 {-
2781 trivialCode instr x (StInd pk mem)
2782   = getRegister x               `thenUs` \ register ->
2783     --getNewRegNCG IntRep       `thenUs` \ tmp ->
2784     getAmode mem                `thenUs` \ amode ->
2785     let
2786         code2 = amodeCode amode asmVoid
2787         src2  = amodeAddr amode
2788         code__2 dst = let code1 = registerCode register dst asmVoid
2789                           src1  = registerName register dst
2790                       in asmParThen [code1, code2] .
2791                          if isFixed register && src1 /= dst
2792                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2793                                            instr (OpAddr src2)  (OpReg dst)]
2794                          else
2795                                 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2796     in
2797     returnUs (Any pk code__2)
2798
2799 trivialCode instr (StInd pk mem) y
2800   = getRegister y               `thenUs` \ register ->
2801     --getNewRegNCG IntRep       `thenUs` \ tmp ->
2802     getAmode mem                `thenUs` \ amode ->
2803     let
2804         code2 = amodeCode amode asmVoid
2805         src2  = amodeAddr amode
2806         code__2 dst = let
2807                           code1 = registerCode register dst asmVoid
2808                           src1  = registerName register dst
2809                       in asmParThen [code1, code2] .
2810                          if isFixed register && src1 /= dst
2811                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2812                                            instr (OpAddr src2)  (OpReg dst)]
2813                          else
2814                                 mkSeqInstr (instr (OpAddr src2) (OpReg src1))
2815     in
2816     returnUs (Any pk code__2)
2817 -}
2818 trivialCode instr x y
2819   = getRegister x               `thenUs` \ register1 ->
2820     getRegister y               `thenUs` \ register2 ->
2821     --getNewRegNCG IntRep       `thenUs` \ tmp1 ->
2822     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2823     let
2824         code2 = registerCode register2 tmp2 asmVoid
2825         src2  = registerName register2 tmp2
2826         code__2 dst = let
2827                           code1 = registerCode register1 dst asmVoid
2828                           src1  = registerName register1 dst
2829                       in asmParThen [code1, code2] .
2830                          if isFixed register1 && src1 /= dst
2831                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2832                                            instr (OpReg src2)  (OpReg dst)]
2833                          else
2834                                 mkSeqInstr (instr (OpReg src2) (OpReg src1))
2835     in
2836     returnUs (Any IntRep code__2)
2837
2838 -----------
2839 trivialUCode instr x
2840   = getRegister x               `thenUs` \ register ->
2841 --    getNewRegNCG IntRep       `thenUs` \ tmp ->
2842     let
2843         code__2 dst = let
2844                           code = registerCode register dst
2845                           src  = registerName register dst
2846                       in code . if isFixed register && dst /= src
2847                                 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
2848                                                   instr (OpReg dst)]
2849                                 else mkSeqInstr (instr (OpReg src))
2850     in
2851     returnUs (Any IntRep code__2)
2852
2853 -----------
2854 trivialFCode pk _ instrr _ _ (StInd pk' mem) y
2855   = getRegister y               `thenUs` \ register2 ->
2856     --getNewRegNCG (registerRep register2)
2857     --                          `thenUs` \ tmp2 ->
2858     getAmode mem                `thenUs` \ amode ->
2859     let
2860         code1 = amodeCode amode
2861         src1  = amodeAddr amode
2862
2863         code__2 dst = let
2864                           code2 = registerCode register2 dst
2865                           src2  = registerName register2 dst
2866                       in asmParThen [code1 asmVoid,code2 asmVoid] .
2867                          mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
2868     in
2869     returnUs (Any pk code__2)
2870
2871 trivialFCode pk instr _ _ _ x (StInd pk' mem)
2872   = getRegister x               `thenUs` \ register1 ->
2873     --getNewRegNCG (registerRep register1)
2874     --                          `thenUs` \ tmp1 ->
2875     getAmode mem                `thenUs` \ amode ->
2876     let
2877         code2 = amodeCode amode
2878         src2  = amodeAddr amode
2879
2880         code__2 dst = let
2881                           code1 = registerCode register1 dst
2882                           src1  = registerName register1 dst
2883                       in asmParThen [code2 asmVoid,code1 asmVoid] .
2884                          mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
2885     in
2886     returnUs (Any pk code__2)
2887
2888 trivialFCode pk _ _ _ instrpr x y
2889   = getRegister x               `thenUs` \ register1 ->
2890     getRegister y               `thenUs` \ register2 ->
2891     --getNewRegNCG (registerRep register1)
2892     --                          `thenUs` \ tmp1 ->
2893     --getNewRegNCG (registerRep register2)
2894     --                          `thenUs` \ tmp2 ->
2895     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
2896     let
2897         pk1   = registerRep register1
2898         code1 = registerCode register1 st0 --tmp1
2899         src1  = registerName register1 st0 --tmp1
2900
2901         pk2   = registerRep register2
2902
2903         code__2 dst = let
2904                           code2 = registerCode register2 dst
2905                           src2  = registerName register2 dst
2906                       in asmParThen [code1 asmVoid, code2 asmVoid] .
2907                          mkSeqInstr instrpr
2908     in
2909     returnUs (Any pk1 code__2)
2910
2911 -------------
2912 trivialUFCode pk instr (StInd pk' mem)
2913   = getAmode mem                `thenUs` \ amode ->
2914     let
2915         code = amodeCode amode
2916         src  = amodeAddr amode
2917         code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
2918                                           instr]
2919     in
2920     returnUs (Any pk code__2)
2921
2922 trivialUFCode pk instr x
2923   = getRegister x               `thenUs` \ register ->
2924     --getNewRegNCG pk           `thenUs` \ tmp ->
2925     let
2926         code__2 dst = let
2927                           code = registerCode register dst
2928                           src  = registerName register dst
2929                       in code . mkSeqInstrs [instr]
2930     in
2931     returnUs (Any pk code__2)
2932
2933 #endif {- i386_TARGET_ARCH -}
2934 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2935 #if sparc_TARGET_ARCH
2936
2937 trivialCode instr x (StInt y)
2938   | fits13Bits y
2939   = getRegister x               `thenUs` \ register ->
2940     getNewRegNCG IntRep         `thenUs` \ tmp ->
2941     let
2942         code = registerCode register tmp
2943         src1 = registerName register tmp
2944         src2 = ImmInt (fromInteger y)
2945         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2946     in
2947     returnUs (Any IntRep code__2)
2948
2949 trivialCode instr x y
2950   = getRegister x               `thenUs` \ register1 ->
2951     getRegister y               `thenUs` \ register2 ->
2952     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2953     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2954     let
2955         code1 = registerCode register1 tmp1 asmVoid
2956         src1  = registerName register1 tmp1
2957         code2 = registerCode register2 tmp2 asmVoid
2958         src2  = registerName register2 tmp2
2959         code__2 dst = asmParThen [code1, code2] .
2960                      mkSeqInstr (instr src1 (RIReg src2) dst)
2961     in
2962     returnUs (Any IntRep code__2)
2963
2964 ------------
2965 trivialFCode pk instr x y
2966   = getRegister x               `thenUs` \ register1 ->
2967     getRegister y               `thenUs` \ register2 ->
2968     getNewRegNCG (registerRep register1)
2969                                 `thenUs` \ tmp1 ->
2970     getNewRegNCG (registerRep register2)
2971                                 `thenUs` \ tmp2 ->
2972     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
2973     let
2974         promote x = asmInstr (FxTOy F DF x tmp)
2975
2976         pk1   = registerRep register1
2977         code1 = registerCode register1 tmp1
2978         src1  = registerName register1 tmp1
2979
2980         pk2   = registerRep register2
2981         code2 = registerCode register2 tmp2
2982         src2  = registerName register2 tmp2
2983
2984         code__2 dst =
2985                 if pk1 == pk2 then
2986                     asmParThen [code1 asmVoid, code2 asmVoid] .
2987                     mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
2988                 else if pk1 == FloatRep then
2989                     asmParThen [code1 (promote src1), code2 asmVoid] .
2990                     mkSeqInstr (instr DF tmp src2 dst)
2991                 else
2992                     asmParThen [code1 asmVoid, code2 (promote src2)] .
2993                     mkSeqInstr (instr DF src1 tmp dst)
2994     in
2995     returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
2996
2997 ------------
2998 trivialUCode instr x
2999   = getRegister x               `thenUs` \ register ->
3000     getNewRegNCG IntRep         `thenUs` \ tmp ->
3001     let
3002         code = registerCode register tmp
3003         src  = registerName register tmp
3004         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
3005     in
3006     returnUs (Any IntRep code__2)
3007
3008 -------------
3009 trivialUFCode pk instr x
3010   = getRegister x               `thenUs` \ register ->
3011     getNewRegNCG pk             `thenUs` \ tmp ->
3012     let
3013         code = registerCode register tmp
3014         src  = registerName register tmp
3015         code__2 dst = code . mkSeqInstr (instr src dst)
3016     in
3017     returnUs (Any pk code__2)
3018
3019 #endif {- sparc_TARGET_ARCH -}
3020 \end{code}
3021
3022 %************************************************************************
3023 %*                                                                      *
3024 \subsubsection{Coercing to/from integer/floating-point...}
3025 %*                                                                      *
3026 %************************************************************************
3027
3028 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
3029 to be generated.  Here we just change the type on the Register passed
3030 on up.  The code is machine-independent.
3031
3032 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
3033 conversions.  We have to store temporaries in memory to move
3034 between the integer and the floating point register sets.
3035
3036 \begin{code}
3037 coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
3038 coerceFltCode ::            StixTree -> UniqSM Register
3039
3040 coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
3041 coerceFP2Int ::            StixTree -> UniqSM Register
3042
3043 coerceIntCode pk x
3044   = getRegister x               `thenUs` \ register ->
3045     returnUs (
3046     case register of
3047         Fixed _ reg code -> Fixed pk reg code
3048         Any   _ code     -> Any   pk code
3049     )
3050
3051 -------------
3052 coerceFltCode x
3053   = getRegister x               `thenUs` \ register ->
3054     returnUs (
3055     case register of
3056         Fixed _ reg code -> Fixed DoubleRep reg code
3057         Any   _ code     -> Any   DoubleRep code
3058     )
3059 \end{code}
3060
3061 \begin{code}
3062 #if alpha_TARGET_ARCH
3063
3064 coerceInt2FP _ x
3065   = getRegister x               `thenUs` \ register ->
3066     getNewRegNCG IntRep         `thenUs` \ reg ->
3067     let
3068         code = registerCode register reg
3069         src  = registerName register reg
3070
3071         code__2 dst = code . mkSeqInstrs [
3072             ST Q src (spRel 0),
3073             LD TF dst (spRel 0),
3074             CVTxy Q TF dst dst]
3075     in
3076     returnUs (Any DoubleRep code__2)
3077
3078 -------------
3079 coerceFP2Int x
3080   = getRegister x               `thenUs` \ register ->
3081     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
3082     let
3083         code = registerCode register tmp
3084         src  = registerName register tmp
3085
3086         code__2 dst = code . mkSeqInstrs [
3087             CVTxy TF Q src tmp,
3088             ST TF tmp (spRel 0),
3089             LD Q dst (spRel 0)]
3090     in
3091     returnUs (Any IntRep code__2)
3092
3093 #endif {- alpha_TARGET_ARCH -}
3094 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3095 #if i386_TARGET_ARCH
3096
3097 coerceInt2FP pk x
3098   = getRegister x               `thenUs` \ register ->
3099     getNewRegNCG IntRep         `thenUs` \ reg ->
3100     let
3101         code = registerCode register reg
3102         src  = registerName register reg
3103
3104         code__2 dst = code . mkSeqInstrs [
3105         -- to fix: should spill instead of using R1
3106                       MOV L (OpReg src) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
3107                       FILD (primRepToSize pk) (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
3108     in
3109     returnUs (Any pk code__2)
3110
3111 ------------
3112 coerceFP2Int x
3113   = getRegister x               `thenUs` \ register ->
3114     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
3115     let
3116         code = registerCode register tmp
3117         src  = registerName register tmp
3118         pk   = registerRep register
3119
3120         code__2 dst = code . mkSeqInstrs [
3121                                 FRNDINT,
3122                                 FIST L (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)),
3123                                 MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
3124     in
3125     returnUs (Any IntRep code__2)
3126
3127 #endif {- i386_TARGET_ARCH -}
3128 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3129 #if sparc_TARGET_ARCH
3130
3131 coerceInt2FP pk x
3132   = getRegister x               `thenUs` \ register ->
3133     getNewRegNCG IntRep         `thenUs` \ reg ->
3134     let
3135         code = registerCode register reg
3136         src  = registerName register reg
3137
3138         code__2 dst = code . mkSeqInstrs [
3139             ST W src (spRel (-2)),
3140             LD W (spRel (-2)) dst,
3141             FxTOy W (primRepToSize pk) dst dst]
3142     in
3143     returnUs (Any pk code__2)
3144
3145 ------------
3146 coerceFP2Int x
3147   = getRegister x               `thenUs` \ register ->
3148     getNewRegNCG IntRep         `thenUs` \ reg ->
3149     getNewRegNCG FloatRep       `thenUs` \ tmp ->
3150     let
3151         code = registerCode register reg
3152         src  = registerName register reg
3153         pk   = registerRep  register
3154
3155         code__2 dst = code . mkSeqInstrs [
3156             FxTOy (primRepToSize pk) W src tmp,
3157             ST W tmp (spRel (-2)),
3158             LD W (spRel (-2)) dst]
3159     in
3160     returnUs (Any IntRep code__2)
3161
3162 #endif {- sparc_TARGET_ARCH -}
3163 \end{code}
3164
3165 %************************************************************************
3166 %*                                                                      *
3167 \subsubsection{Coercing integer to @Char@...}
3168 %*                                                                      *
3169 %************************************************************************
3170
3171 Integer to character conversion.  Where applicable, we try to do this
3172 in one step if the original object is in memory.
3173
3174 \begin{code}
3175 chrCode :: StixTree -> UniqSM Register
3176
3177 #if alpha_TARGET_ARCH
3178
3179 chrCode x
3180   = getRegister x               `thenUs` \ register ->
3181     getNewRegNCG IntRep         `thenUs` \ reg ->
3182     let
3183         code = registerCode register reg
3184         src  = registerName register reg
3185         code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3186     in
3187     returnUs (Any IntRep code__2)
3188
3189 #endif {- alpha_TARGET_ARCH -}
3190 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3191 #if i386_TARGET_ARCH
3192
3193 chrCode x
3194   = getRegister x               `thenUs` \ register ->
3195     --getNewRegNCG IntRep       `thenUs` \ reg ->
3196     let
3197         code__2 dst = let
3198                           code = registerCode register dst
3199                           src  = registerName register dst
3200                       in code .
3201                          if isFixed register && src /= dst
3202                          then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3203                                            AND L (OpImm (ImmInt 255)) (OpReg dst)]
3204                          else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
3205     in
3206     returnUs (Any IntRep code__2)
3207
3208 #endif {- i386_TARGET_ARCH -}
3209 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3210 #if sparc_TARGET_ARCH
3211
3212 chrCode (StInd pk mem)
3213   = getAmode mem                `thenUs` \ amode ->
3214     let
3215         code    = amodeCode amode
3216         src     = amodeAddr amode
3217         src_off = addrOffset src 3
3218         src__2  = case src_off of Just x -> x
3219         code__2 dst = if maybeToBool src_off then
3220                         code . mkSeqInstr (LD BU src__2 dst)
3221                     else
3222                         code . mkSeqInstrs [
3223                             LD (primRepToSize pk) src dst,
3224                             AND False dst (RIImm (ImmInt 255)) dst]
3225     in
3226     returnUs (Any pk code__2)
3227
3228 chrCode x
3229   = getRegister x               `thenUs` \ register ->
3230     getNewRegNCG IntRep         `thenUs` \ reg ->
3231     let
3232         code = registerCode register reg
3233         src  = registerName register reg
3234         code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
3235     in
3236     returnUs (Any IntRep code__2)
3237
3238 #endif {- sparc_TARGET_ARCH -}
3239 \end{code}