ghc/compiler/nativeGen/MachCode.lhs

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