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(..), pprStixTrees
  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   | otherwise
 893   = pprPanic "getRegister(x86)" (pprStixTrees [leaf])
 894
 895   where
 896     imm = maybeImm leaf
 897     imm__2 = case imm of Just x -> x
 898
 899 #endif {- i386_TARGET_ARCH -}
 900 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 901 #if sparc_TARGET_ARCH
 902
 903 getRegister (StDouble d)
 904   = getUniqLabelNCG                 `thenUs` \ lbl ->
 905     getNewRegNCG PtrRep             `thenUs` \ tmp ->
 906     let code dst = mkSeqInstrs [
 907             SEGMENT DataSegment,
 908             LABEL lbl,
 909             DATA DF [ImmDouble d],
 910             SEGMENT TextSegment,
 911             SETHI (HI (ImmCLbl lbl)) tmp,
 912             LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
 913     in
 914         returnUs (Any DoubleRep code)
 915
 916 getRegister (StPrim primop [x]) -- unary PrimOps
 917   = case primop of
 918       IntNegOp -> trivialUCode (SUB False False g0) x
 919       NotOp    -> trivialUCode (XNOR False g0) x
 920
 921       FloatNegOp  -> trivialUFCode FloatRep (FNEG F) x
 922
 923       DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) x
 924
 925       Double2FloatOp -> trivialUFCode FloatRep  (FxTOy DF F) x
 926       Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) x
 927
 928       OrdOp -> coerceIntCode IntRep x
 929       ChrOp -> chrCode x
 930
 931       Float2IntOp  -> coerceFP2Int x
 932       Int2FloatOp  -> coerceInt2FP FloatRep x
 933       Double2IntOp -> coerceFP2Int x
 934       Int2DoubleOp -> coerceInt2FP DoubleRep x
 935
 936       other_op ->
 937         let
 938             fixed_x = if is_float_op  -- promote to double
 939                           then StPrim Float2DoubleOp [x]
 940                           else x
 941         in
 942         getRegister (StCall fn cCallConv DoubleRep [x])
 943        where
 944         (is_float_op, fn)
 945           = case primop of
 946               FloatExpOp    -> (True,  SLIT("exp"))
 947               FloatLogOp    -> (True,  SLIT("log"))
 948               FloatSqrtOp   -> (True,  SLIT("sqrt"))
 949
 950               FloatSinOp    -> (True,  SLIT("sin"))
 951               FloatCosOp    -> (True,  SLIT("cos"))
 952               FloatTanOp    -> (True,  SLIT("tan"))
 953
 954               FloatAsinOp   -> (True,  SLIT("asin"))
 955               FloatAcosOp   -> (True,  SLIT("acos"))
 956               FloatAtanOp   -> (True,  SLIT("atan"))
 957
 958               FloatSinhOp   -> (True,  SLIT("sinh"))
 959               FloatCoshOp   -> (True,  SLIT("cosh"))
 960               FloatTanhOp   -> (True,  SLIT("tanh"))
 961
 962               DoubleExpOp   -> (False, SLIT("exp"))
 963               DoubleLogOp   -> (False, SLIT("log"))
 964               DoubleSqrtOp  -> (True,  SLIT("sqrt"))
 965
 966               DoubleSinOp   -> (False, SLIT("sin"))
 967               DoubleCosOp   -> (False, SLIT("cos"))
 968               DoubleTanOp   -> (False, SLIT("tan"))
 969
 970               DoubleAsinOp  -> (False, SLIT("asin"))
 971               DoubleAcosOp  -> (False, SLIT("acos"))
 972               DoubleAtanOp  -> (False, SLIT("atan"))
 973
 974               DoubleSinhOp  -> (False, SLIT("sinh"))
 975               DoubleCoshOp  -> (False, SLIT("cosh"))
 976               DoubleTanhOp  -> (False, SLIT("tanh"))
 977               _             -> panic ("Monadic PrimOp not handled: " ++ show primop)
 978
 979 getRegister (StPrim primop [x, y]) -- dyadic PrimOps
 980   = case primop of
 981       CharGtOp -> condIntReg GTT x y
 982       CharGeOp -> condIntReg GE x y
 983       CharEqOp -> condIntReg EQQ x y
 984       CharNeOp -> condIntReg NE x y
 985       CharLtOp -> condIntReg LTT x y
 986       CharLeOp -> condIntReg LE x y
 987
 988       IntGtOp  -> condIntReg GTT x y
 989       IntGeOp  -> condIntReg GE x y
 990       IntEqOp  -> condIntReg EQQ x y
 991       IntNeOp  -> condIntReg NE x y
 992       IntLtOp  -> condIntReg LTT x y
 993       IntLeOp  -> condIntReg LE x y
 994
 995       WordGtOp -> condIntReg GU  x y
 996       WordGeOp -> condIntReg GEU x y
 997       WordEqOp -> condIntReg EQQ  x y
 998       WordNeOp -> condIntReg NE  x y
 999       WordLtOp -> condIntReg LU  x y
1000       WordLeOp -> condIntReg LEU x y
1001
1002       AddrGtOp -> condIntReg GU  x y
1003       AddrGeOp -> condIntReg GEU x y
1004       AddrEqOp -> condIntReg EQQ  x y
1005       AddrNeOp -> condIntReg NE  x y
1006       AddrLtOp -> condIntReg LU  x y
1007       AddrLeOp -> condIntReg LEU x y
1008
1009       FloatGtOp -> condFltReg GTT x y
1010       FloatGeOp -> condFltReg GE x y
1011       FloatEqOp -> condFltReg EQQ x y
1012       FloatNeOp -> condFltReg NE x y
1013       FloatLtOp -> condFltReg LTT x y
1014       FloatLeOp -> condFltReg LE x y
1015
1016       DoubleGtOp -> condFltReg GTT x y
1017       DoubleGeOp -> condFltReg GE x y
1018       DoubleEqOp -> condFltReg EQQ x y
1019       DoubleNeOp -> condFltReg NE x y
1020       DoubleLtOp -> condFltReg LTT x y
1021       DoubleLeOp -> condFltReg LE x y
1022
1023       IntAddOp -> trivialCode (ADD False False) x y
1024       IntSubOp -> trivialCode (SUB False False) x y
1025
1026         -- ToDo: teach about V8+ SPARC mul/div instructions
1027       IntMulOp    -> imul_div SLIT(".umul") x y
1028       IntQuotOp   -> imul_div SLIT(".div")  x y
1029       IntRemOp    -> imul_div SLIT(".rem")  x y
1030
1031       FloatAddOp  -> trivialFCode FloatRep  FADD x y
1032       FloatSubOp  -> trivialFCode FloatRep  FSUB x y
1033       FloatMulOp  -> trivialFCode FloatRep  FMUL x y
1034       FloatDivOp  -> trivialFCode FloatRep  FDIV x y
1035
1036       DoubleAddOp -> trivialFCode DoubleRep FADD x y
1037       DoubleSubOp -> trivialFCode DoubleRep FSUB x y
1038       DoubleMulOp -> trivialFCode DoubleRep FMUL x y
1039       DoubleDivOp -> trivialFCode DoubleRep FDIV x y
1040
1041       AndOp -> trivialCode (AND False) x y
1042       OrOp  -> trivialCode (OR  False) x y
1043       XorOp -> trivialCode (XOR False) x y
1044       SllOp -> trivialCode SLL x y
1045       SrlOp -> trivialCode SRL x y
1046
1047       ISllOp -> trivialCode SLL x y  --was: panic "SparcGen:isll"
1048       ISraOp -> trivialCode SRA x y  --was: panic "SparcGen:isra"
1049       ISrlOp -> trivialCode SRL x y  --was: panic "SparcGen:isrl"
1050
1051       FloatPowerOp  -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
1052                        where promote x = StPrim Float2DoubleOp [x]
1053       DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
1054 --      _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!"
1055   where
1056     imul_div fn x y = getRegister (StCall fn cCallConv IntRep [x, y])
1057
1058 getRegister (StInd pk mem)
1059   = getAmode mem                    `thenUs` \ amode ->
1060     let
1061         code = amodeCode amode
1062         src   = amodeAddr amode
1063         size = primRepToSize pk
1064         code__2 dst = code . mkSeqInstr (LD size src dst)
1065     in
1066         returnUs (Any pk code__2)
1067
1068 getRegister (StInt i)
1069   | fits13Bits i
1070   = let
1071         src = ImmInt (fromInteger i)
1072         code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
1073     in
1074         returnUs (Any IntRep code)
1075
1076 getRegister leaf
1077   | maybeToBool imm
1078   = let
1079         code dst = mkSeqInstrs [
1080             SETHI (HI imm__2) dst,
1081             OR False dst (RIImm (LO imm__2)) dst]
1082     in
1083         returnUs (Any PtrRep code)
1084   where
1085     imm = maybeImm leaf
1086     imm__2 = case imm of Just x -> x
1087
1088 #endif {- sparc_TARGET_ARCH -}
1089 \end{code}
1090
1091 %************************************************************************
1092 %*                                                                      *
1093 \subsection{The @Amode@ type}
1094 %*                                                                      *
1095 %************************************************************************
1096
1097 @Amode@s: Memory addressing modes passed up the tree.
1098 \begin{code}
1099 data Amode = Amode MachRegsAddr InstrBlock
1100
1101 amodeAddr (Amode addr _) = addr
1102 amodeCode (Amode _ code) = code
1103 \end{code}
1104
1105 Now, given a tree (the argument to an StInd) that references memory,
1106 produce a suitable addressing mode.
1107
1108 \begin{code}
1109 getAmode :: StixTree -> UniqSM Amode
1110
1111 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
1112
1113 #if alpha_TARGET_ARCH
1114
1115 getAmode (StPrim IntSubOp [x, StInt i])
1116   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1117     getRegister x               `thenUs` \ register ->
1118     let
1119         code = registerCode register tmp
1120         reg  = registerName register tmp
1121         off  = ImmInt (-(fromInteger i))
1122     in
1123     returnUs (Amode (AddrRegImm reg off) code)
1124
1125 getAmode (StPrim IntAddOp [x, StInt i])
1126   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1127     getRegister x               `thenUs` \ register ->
1128     let
1129         code = registerCode register tmp
1130         reg  = registerName register tmp
1131         off  = ImmInt (fromInteger i)
1132     in
1133     returnUs (Amode (AddrRegImm reg off) code)
1134
1135 getAmode leaf
1136   | maybeToBool imm
1137   = returnUs (Amode (AddrImm imm__2) id)
1138   where
1139     imm = maybeImm leaf
1140     imm__2 = case imm of Just x -> x
1141
1142 getAmode other
1143   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1144     getRegister other           `thenUs` \ register ->
1145     let
1146         code = registerCode register tmp
1147         reg  = registerName register tmp
1148     in
1149     returnUs (Amode (AddrReg reg) code)
1150
1151 #endif {- alpha_TARGET_ARCH -}
1152 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1153 #if i386_TARGET_ARCH
1154
1155 getAmode (StPrim IntSubOp [x, StInt i])
1156   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1157     getRegister x               `thenUs` \ register ->
1158     let
1159         code = registerCode register tmp
1160         reg  = registerName register tmp
1161         off  = ImmInt (-(fromInteger i))
1162     in
1163     returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1164
1165 getAmode (StPrim IntAddOp [x, StInt i])
1166   | maybeToBool imm
1167   = let
1168         code = mkSeqInstrs []
1169     in
1170     returnUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
1171   where
1172     imm    = maybeImm x
1173     imm__2 = case imm of Just x -> x
1174
1175 getAmode (StPrim IntAddOp [x, StInt i])
1176   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1177     getRegister x               `thenUs` \ register ->
1178     let
1179         code = registerCode register tmp
1180         reg  = registerName register tmp
1181         off  = ImmInt (fromInteger i)
1182     in
1183     returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
1184
1185 getAmode (StPrim IntAddOp [x, y])
1186   = getNewRegNCG PtrRep         `thenUs` \ tmp1 ->
1187     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1188     getRegister x               `thenUs` \ register1 ->
1189     getRegister y               `thenUs` \ register2 ->
1190     let
1191         code1 = registerCode register1 tmp1 asmVoid
1192         reg1  = registerName register1 tmp1
1193         code2 = registerCode register2 tmp2 asmVoid
1194         reg2  = registerName register2 tmp2
1195         code__2 = asmParThen [code1, code2]
1196     in
1197     returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
1198
1199 getAmode leaf
1200   | maybeToBool imm
1201   = let
1202         code = mkSeqInstrs []
1203     in
1204     returnUs (Amode (ImmAddr imm__2 0) code)
1205   where
1206     imm    = maybeImm leaf
1207     imm__2 = case imm of Just x -> x
1208
1209 getAmode other
1210   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1211     getRegister other           `thenUs` \ register ->
1212     let
1213         code = registerCode register tmp
1214         reg  = registerName register tmp
1215         off  = Nothing
1216     in
1217     returnUs (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
1218
1219 #endif {- i386_TARGET_ARCH -}
1220 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1221 #if sparc_TARGET_ARCH
1222
1223 getAmode (StPrim IntSubOp [x, StInt i])
1224   | fits13Bits (-i)
1225   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1226     getRegister x               `thenUs` \ register ->
1227     let
1228         code = registerCode register tmp
1229         reg  = registerName register tmp
1230         off  = ImmInt (-(fromInteger i))
1231     in
1232     returnUs (Amode (AddrRegImm reg off) code)
1233
1234
1235 getAmode (StPrim IntAddOp [x, StInt i])
1236   | fits13Bits i
1237   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1238     getRegister x               `thenUs` \ register ->
1239     let
1240         code = registerCode register tmp
1241         reg  = registerName register tmp
1242         off  = ImmInt (fromInteger i)
1243     in
1244     returnUs (Amode (AddrRegImm reg off) code)
1245
1246 getAmode (StPrim IntAddOp [x, y])
1247   = getNewRegNCG PtrRep         `thenUs` \ tmp1 ->
1248     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1249     getRegister x               `thenUs` \ register1 ->
1250     getRegister y               `thenUs` \ register2 ->
1251     let
1252         code1 = registerCode register1 tmp1 asmVoid
1253         reg1  = registerName register1 tmp1
1254         code2 = registerCode register2 tmp2 asmVoid
1255         reg2  = registerName register2 tmp2
1256         code__2 = asmParThen [code1, code2]
1257     in
1258     returnUs (Amode (AddrRegReg reg1 reg2) code__2)
1259
1260 getAmode leaf
1261   | maybeToBool imm
1262   = getNewRegNCG PtrRep             `thenUs` \ tmp ->
1263     let
1264         code = mkSeqInstr (SETHI (HI imm__2) tmp)
1265     in
1266     returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
1267   where
1268     imm    = maybeImm leaf
1269     imm__2 = case imm of Just x -> x
1270
1271 getAmode other
1272   = getNewRegNCG PtrRep         `thenUs` \ tmp ->
1273     getRegister other           `thenUs` \ register ->
1274     let
1275         code = registerCode register tmp
1276         reg  = registerName register tmp
1277         off  = ImmInt 0
1278     in
1279     returnUs (Amode (AddrRegImm reg off) code)
1280
1281 #endif {- sparc_TARGET_ARCH -}
1282 \end{code}
1283
1284 %************************************************************************
1285 %*                                                                      *
1286 \subsection{The @CondCode@ type}
1287 %*                                                                      *
1288 %************************************************************************
1289
1290 Condition codes passed up the tree.
1291 \begin{code}
1292 data CondCode = CondCode Bool Cond InstrBlock
1293
1294 condName  (CondCode _ cond _)      = cond
1295 condFloat (CondCode is_float _ _) = is_float
1296 condCode  (CondCode _ _ code)      = code
1297 \end{code}
1298
1299 Set up a condition code for a conditional branch.
1300
1301 \begin{code}
1302 getCondCode :: StixTree -> UniqSM CondCode
1303
1304 #if alpha_TARGET_ARCH
1305 getCondCode = panic "MachCode.getCondCode: not on Alphas"
1306 #endif {- alpha_TARGET_ARCH -}
1307 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1308
1309 #if i386_TARGET_ARCH || sparc_TARGET_ARCH
1310 -- yes, they really do seem to want exactly the same!
1311
1312 getCondCode (StPrim primop [x, y])
1313   = case primop of
1314       CharGtOp -> condIntCode GTT  x y
1315       CharGeOp -> condIntCode GE  x y
1316       CharEqOp -> condIntCode EQQ  x y
1317       CharNeOp -> condIntCode NE  x y
1318       CharLtOp -> condIntCode LTT  x y
1319       CharLeOp -> condIntCode LE  x y
1320
1321       IntGtOp  -> condIntCode GTT  x y
1322       IntGeOp  -> condIntCode GE  x y
1323       IntEqOp  -> condIntCode EQQ  x y
1324       IntNeOp  -> condIntCode NE  x y
1325       IntLtOp  -> condIntCode LTT  x y
1326       IntLeOp  -> condIntCode LE  x y
1327
1328       WordGtOp -> condIntCode GU  x y
1329       WordGeOp -> condIntCode GEU x y
1330       WordEqOp -> condIntCode EQQ  x y
1331       WordNeOp -> condIntCode NE  x y
1332       WordLtOp -> condIntCode LU  x y
1333       WordLeOp -> condIntCode LEU x y
1334
1335       AddrGtOp -> condIntCode GU  x y
1336       AddrGeOp -> condIntCode GEU x y
1337       AddrEqOp -> condIntCode EQQ  x y
1338       AddrNeOp -> condIntCode NE  x y
1339       AddrLtOp -> condIntCode LU  x y
1340       AddrLeOp -> condIntCode LEU x y
1341
1342       FloatGtOp -> condFltCode GTT x y
1343       FloatGeOp -> condFltCode GE x y
1344       FloatEqOp -> condFltCode EQQ x y
1345       FloatNeOp -> condFltCode NE x y
1346       FloatLtOp -> condFltCode LTT x y
1347       FloatLeOp -> condFltCode LE x y
1348
1349       DoubleGtOp -> condFltCode GTT x y
1350       DoubleGeOp -> condFltCode GE x y
1351       DoubleEqOp -> condFltCode EQQ x y
1352       DoubleNeOp -> condFltCode NE x y
1353       DoubleLtOp -> condFltCode LTT x y
1354       DoubleLeOp -> condFltCode LE x y
1355
1356 #endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
1357 \end{code}
1358
1359 % -----------------
1360
1361 @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
1362 passed back up the tree.
1363
1364 \begin{code}
1365 condIntCode, condFltCode :: Cond -> StixTree -> StixTree -> UniqSM CondCode
1366
1367 #if alpha_TARGET_ARCH
1368 condIntCode = panic "MachCode.condIntCode: not on Alphas"
1369 condFltCode = panic "MachCode.condFltCode: not on Alphas"
1370 #endif {- alpha_TARGET_ARCH -}
1371
1372 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1373 #if i386_TARGET_ARCH
1374
1375 condIntCode cond (StInd _ x) y
1376   | maybeToBool imm
1377   = getAmode x                  `thenUs` \ amode ->
1378     let
1379         code1 = amodeCode amode asmVoid
1380         y__2  = amodeAddr amode
1381         code__2 = asmParThen [code1] .
1382                   mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
1383     in
1384     returnUs (CondCode False cond code__2)
1385   where
1386     imm    = maybeImm y
1387     imm__2 = case imm of Just x -> x
1388
1389 condIntCode cond x (StInt 0)
1390   = getRegister x               `thenUs` \ register1 ->
1391     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
1392     let
1393         code1 = registerCode register1 tmp1 asmVoid
1394         src1  = registerName register1 tmp1
1395         code__2 = asmParThen [code1] .
1396                 mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
1397     in
1398     returnUs (CondCode False cond code__2)
1399
1400 condIntCode cond x y
1401   | maybeToBool imm
1402   = getRegister x               `thenUs` \ register1 ->
1403     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
1404     let
1405         code1 = registerCode register1 tmp1 asmVoid
1406         src1  = registerName register1 tmp1
1407         code__2 = asmParThen [code1] .
1408                 mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
1409     in
1410     returnUs (CondCode False cond code__2)
1411   where
1412     imm    = maybeImm y
1413     imm__2 = case imm of Just x -> x
1414
1415 condIntCode cond (StInd _ x) y
1416   = getAmode x                  `thenUs` \ amode ->
1417     getRegister y               `thenUs` \ register2 ->
1418     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1419     let
1420         code1 = amodeCode amode asmVoid
1421         src1  = amodeAddr amode
1422         code2 = registerCode register2 tmp2 asmVoid
1423         src2  = registerName register2 tmp2
1424         code__2 = asmParThen [code1, code2] .
1425                   mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
1426     in
1427     returnUs (CondCode False cond code__2)
1428
1429 condIntCode cond y (StInd _ x)
1430   = getAmode x                  `thenUs` \ amode ->
1431     getRegister y               `thenUs` \ register2 ->
1432     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1433     let
1434         code1 = amodeCode amode asmVoid
1435         src1  = amodeAddr amode
1436         code2 = registerCode register2 tmp2 asmVoid
1437         src2  = registerName register2 tmp2
1438         code__2 = asmParThen [code1, code2] .
1439                   mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
1440     in
1441     returnUs (CondCode False cond code__2)
1442
1443 condIntCode cond x y
1444   = getRegister x               `thenUs` \ register1 ->
1445     getRegister y               `thenUs` \ register2 ->
1446     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
1447     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1448     let
1449         code1 = registerCode register1 tmp1 asmVoid
1450         src1  = registerName register1 tmp1
1451         code2 = registerCode register2 tmp2 asmVoid
1452         src2  = registerName register2 tmp2
1453         code__2 = asmParThen [code1, code2] .
1454                 mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
1455     in
1456     returnUs (CondCode False cond code__2)
1457
1458 -----------
1459 condFltCode cond x y
1460   = getRegister x               `thenUs` \ register1 ->
1461     getRegister y               `thenUs` \ register2 ->
1462     getNewRegNCG (registerRep register1)
1463                                 `thenUs` \ tmp1 ->
1464     getNewRegNCG (registerRep register2)
1465                                 `thenUs` \ tmp2 ->
1466     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
1467     let
1468         pk1   = registerRep register1
1469         code1 = registerCode register1 tmp1
1470         src1  = registerName register1 tmp1
1471
1472         pk2   = registerRep register2
1473         code2 = registerCode register2 tmp2
1474         src2  = registerName register2 tmp2
1475
1476         code__2 =   asmParThen [code1 asmVoid, code2 asmVoid] .
1477                     mkSeqInstr (GCMP (primRepToSize pk1) src1 src2)
1478
1479         {- On the 486, the flags set by FP compare are the unsigned ones!
1480            (This looks like a HACK to me.  WDP 96/03)
1481         -}
1482         fix_FP_cond :: Cond -> Cond
1483
1484         fix_FP_cond GE  = GEU
1485         fix_FP_cond GTT  = GU
1486         fix_FP_cond LTT  = LU
1487         fix_FP_cond LE  = LEU
1488         fix_FP_cond any = any
1489     in
1490     returnUs (CondCode True (fix_FP_cond cond) code__2)
1491
1492
1493
1494 #endif {- i386_TARGET_ARCH -}
1495 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1496 #if sparc_TARGET_ARCH
1497
1498 condIntCode cond x (StInt y)
1499   | fits13Bits y
1500   = getRegister x               `thenUs` \ register ->
1501     getNewRegNCG IntRep         `thenUs` \ tmp ->
1502     let
1503         code = registerCode register tmp
1504         src1 = registerName register tmp
1505         src2 = ImmInt (fromInteger y)
1506         code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
1507     in
1508     returnUs (CondCode False cond code__2)
1509
1510 condIntCode cond x y
1511   = getRegister x               `thenUs` \ register1 ->
1512     getRegister y               `thenUs` \ register2 ->
1513     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
1514     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
1515     let
1516         code1 = registerCode register1 tmp1 asmVoid
1517         src1  = registerName register1 tmp1
1518         code2 = registerCode register2 tmp2 asmVoid
1519         src2  = registerName register2 tmp2
1520         code__2 = asmParThen [code1, code2] .
1521                 mkSeqInstr (SUB False True src1 (RIReg src2) g0)
1522     in
1523     returnUs (CondCode False cond code__2)
1524
1525 -----------
1526 condFltCode cond x y
1527   = getRegister x               `thenUs` \ register1 ->
1528     getRegister y               `thenUs` \ register2 ->
1529     getNewRegNCG (registerRep register1)
1530                                 `thenUs` \ tmp1 ->
1531     getNewRegNCG (registerRep register2)
1532                                 `thenUs` \ tmp2 ->
1533     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
1534     let
1535         promote x = asmInstr (FxTOy F DF x tmp)
1536
1537         pk1   = registerRep register1
1538         code1 = registerCode register1 tmp1
1539         src1  = registerName register1 tmp1
1540
1541         pk2   = registerRep register2
1542         code2 = registerCode register2 tmp2
1543         src2  = registerName register2 tmp2
1544
1545         code__2 =
1546                 if pk1 == pk2 then
1547                     asmParThen [code1 asmVoid, code2 asmVoid] .
1548                     mkSeqInstr (FCMP True (primRepToSize pk1) src1 src2)
1549                 else if pk1 == FloatRep then
1550                     asmParThen [code1 (promote src1), code2 asmVoid] .
1551                     mkSeqInstr (FCMP True DF tmp src2)
1552                 else
1553                     asmParThen [code1 asmVoid, code2 (promote src2)] .
1554                     mkSeqInstr (FCMP True DF src1 tmp)
1555     in
1556     returnUs (CondCode True cond code__2)
1557
1558 #endif {- sparc_TARGET_ARCH -}
1559 \end{code}
1560
1561 %************************************************************************
1562 %*                                                                      *
1563 \subsection{Generating assignments}
1564 %*                                                                      *
1565 %************************************************************************
1566
1567 Assignments are really at the heart of the whole code generation
1568 business.  Almost all top-level nodes of any real importance are
1569 assignments, which correspond to loads, stores, or register transfers.
1570 If we're really lucky, some of the register transfers will go away,
1571 because we can use the destination register to complete the code
1572 generation for the right hand side.  This only fails when the right
1573 hand side is forced into a fixed register (e.g. the result of a call).
1574
1575 \begin{code}
1576 assignIntCode, assignFltCode
1577         :: PrimRep -> StixTree -> StixTree -> UniqSM InstrBlock
1578
1579 #if alpha_TARGET_ARCH
1580
1581 assignIntCode pk (StInd _ dst) src
1582   = getNewRegNCG IntRep             `thenUs` \ tmp ->
1583     getAmode dst                    `thenUs` \ amode ->
1584     getRegister src                 `thenUs` \ register ->
1585     let
1586         code1   = amodeCode amode asmVoid
1587         dst__2  = amodeAddr amode
1588         code2   = registerCode register tmp asmVoid
1589         src__2  = registerName register tmp
1590         sz      = primRepToSize pk
1591         code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1592     in
1593     returnUs code__2
1594
1595 assignIntCode pk dst src
1596   = getRegister dst                         `thenUs` \ register1 ->
1597     getRegister src                         `thenUs` \ register2 ->
1598     let
1599         dst__2  = registerName register1 zeroh
1600         code    = registerCode register2 dst__2
1601         src__2  = registerName register2 dst__2
1602         code__2 = if isFixed register2
1603                   then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
1604                   else code
1605     in
1606     returnUs code__2
1607
1608 #endif {- alpha_TARGET_ARCH -}
1609 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1610 #if i386_TARGET_ARCH
1611
1612 assignIntCode pk (StInd _ dst) src
1613   = getAmode dst                `thenUs` \ amode ->
1614     get_op_RI src               `thenUs` \ (codesrc, opsrc, sz) ->
1615     let
1616         code1   = amodeCode amode asmVoid
1617         dst__2  = amodeAddr amode
1618         code__2 = asmParThen [code1, codesrc asmVoid] .
1619                   mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
1620     in
1621     returnUs code__2
1622   where
1623     get_op_RI
1624         :: StixTree
1625         -> UniqSM (InstrBlock,Operand, Size)    -- code, operator, size
1626
1627     get_op_RI op
1628       | maybeToBool imm
1629       = returnUs (asmParThen [], OpImm imm_op, L)
1630       where
1631         imm    = maybeImm op
1632         imm_op = case imm of Just x -> x
1633
1634     get_op_RI op
1635       = getRegister op                  `thenUs` \ register ->
1636         getNewRegNCG (registerRep register)
1637                                         `thenUs` \ tmp ->
1638         let
1639             code = registerCode register tmp
1640             reg  = registerName register tmp
1641             pk   = registerRep  register
1642             sz   = primRepToSize pk
1643         in
1644         returnUs (code, OpReg reg, sz)
1645
1646 assignIntCode pk dst (StInd _ src)
1647   = getNewRegNCG IntRep             `thenUs` \ tmp ->
1648     getAmode src                    `thenUs` \ amode ->
1649     getRegister dst                         `thenUs` \ register ->
1650     let
1651         code1   = amodeCode amode asmVoid
1652         src__2  = amodeAddr amode
1653         code2   = registerCode register tmp asmVoid
1654         dst__2  = registerName register tmp
1655         sz      = primRepToSize pk
1656         code__2 = asmParThen [code1, code2] .
1657                   mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
1658     in
1659     returnUs code__2
1660
1661 assignIntCode pk dst src
1662   = getRegister dst                         `thenUs` \ register1 ->
1663     getRegister src                         `thenUs` \ register2 ->
1664     getNewRegNCG IntRep             `thenUs` \ tmp ->
1665     let
1666         dst__2  = registerName register1 tmp
1667         code    = registerCode register2 dst__2
1668         src__2  = registerName register2 dst__2
1669         code__2 = if isFixed register2 && dst__2 /= src__2
1670                   then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
1671                   else code
1672     in
1673     returnUs code__2
1674
1675 #endif {- i386_TARGET_ARCH -}
1676 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1677 #if sparc_TARGET_ARCH
1678
1679 assignIntCode pk (StInd _ dst) src
1680   = getNewRegNCG IntRep             `thenUs` \ tmp ->
1681     getAmode dst                    `thenUs` \ amode ->
1682     getRegister src                         `thenUs` \ register ->
1683     let
1684         code1   = amodeCode amode asmVoid
1685         dst__2  = amodeAddr amode
1686         code2   = registerCode register tmp asmVoid
1687         src__2  = registerName register tmp
1688         sz      = primRepToSize pk
1689         code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1690     in
1691     returnUs code__2
1692
1693 assignIntCode pk dst src
1694   = getRegister dst                         `thenUs` \ register1 ->
1695     getRegister src                         `thenUs` \ register2 ->
1696     let
1697         dst__2  = registerName register1 g0
1698         code    = registerCode register2 dst__2
1699         src__2  = registerName register2 dst__2
1700         code__2 = if isFixed register2
1701                   then code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
1702                   else code
1703     in
1704     returnUs code__2
1705
1706 #endif {- sparc_TARGET_ARCH -}
1707 \end{code}
1708
1709 % --------------------------------
1710 Floating-point assignments:
1711 % --------------------------------
1712 \begin{code}
1713 #if alpha_TARGET_ARCH
1714
1715 assignFltCode pk (StInd _ dst) src
1716   = getNewRegNCG pk                 `thenUs` \ tmp ->
1717     getAmode dst                    `thenUs` \ amode ->
1718     getRegister src                         `thenUs` \ register ->
1719     let
1720         code1   = amodeCode amode asmVoid
1721         dst__2  = amodeAddr amode
1722         code2   = registerCode register tmp asmVoid
1723         src__2  = registerName register tmp
1724         sz      = primRepToSize pk
1725         code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
1726     in
1727     returnUs code__2
1728
1729 assignFltCode pk dst src
1730   = getRegister dst                         `thenUs` \ register1 ->
1731     getRegister src                         `thenUs` \ register2 ->
1732     let
1733         dst__2  = registerName register1 zeroh
1734         code    = registerCode register2 dst__2
1735         src__2  = registerName register2 dst__2
1736         code__2 = if isFixed register2
1737                   then code . mkSeqInstr (FMOV src__2 dst__2)
1738                   else code
1739     in
1740     returnUs code__2
1741
1742 #endif {- alpha_TARGET_ARCH -}
1743 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1744 #if i386_TARGET_ARCH
1745
1746 assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
1747   = getNewRegNCG IntRep             `thenUs` \ tmp ->
1748     getAmode src                    `thenUs` \ amodesrc ->
1749     getAmode dst                    `thenUs` \ amodedst ->
1750     let
1751         codesrc1 = amodeCode amodesrc asmVoid
1752         addrsrc1 = amodeAddr amodesrc
1753         codedst1 = amodeCode amodedst asmVoid
1754         addrdst1 = amodeAddr amodedst
1755         addrsrc2 = case (addrOffset addrsrc1 4) of Just x -> x
1756         addrdst2 = case (addrOffset addrdst1 4) of Just x -> x
1757
1758         code__2 = asmParThen [codesrc1, codedst1] .
1759                   mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
1760                                 MOV L (OpReg tmp) (OpAddr addrdst1)]
1761                                ++
1762                                if pk == DoubleRep
1763                                then [MOV L (OpAddr addrsrc2) (OpReg tmp),
1764                                      MOV L (OpReg tmp) (OpAddr addrdst2)]
1765                                else [])
1766     in
1767     returnUs code__2
1768
1769 assignFltCode pk (StInd _ dst) src
1770   = getNewRegNCG pk                 `thenUs` \ tmp ->
1771     getAmode dst                    `thenUs` \ amode ->
1772     getRegister src                 `thenUs` \ register ->
1773     let
1774         sz      = primRepToSize pk
1775         dst__2  = amodeAddr amode
1776
1777         code1   = amodeCode amode asmVoid
1778         code2   = registerCode register tmp asmVoid
1779
1780         src__2  = registerName register tmp
1781
1782         code__2 = asmParThen [code1, code2] .
1783                   mkSeqInstr (GST sz src__2 dst__2)
1784     in
1785     returnUs code__2
1786
1787 assignFltCode pk dst src
1788   = getRegister dst                         `thenUs` \ register1 ->
1789     getRegister src                         `thenUs` \ register2 ->
1790     getNewRegNCG pk                         `thenUs` \ tmp ->
1791     let
1792         -- the register which is dst
1793         dst__2  = registerName register1 tmp
1794         -- the register into which src is computed, preferably dst__2
1795         src__2  = registerName register2 dst__2
1796         -- code to compute src into src__2
1797         code    = registerCode register2 dst__2
1798
1799         code__2 = if isFixed register2
1800                   then code . mkSeqInstr (GMOV src__2 dst__2)
1801                   else code
1802     in
1803     returnUs code__2
1804
1805 #endif {- i386_TARGET_ARCH -}
1806 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1807 #if sparc_TARGET_ARCH
1808
1809 assignFltCode pk (StInd _ dst) src
1810   = getNewRegNCG pk                 `thenUs` \ tmp1 ->
1811     getAmode dst                    `thenUs` \ amode ->
1812     getRegister src                 `thenUs` \ register ->
1813     let
1814         sz      = primRepToSize pk
1815         dst__2  = amodeAddr amode
1816
1817         code1   = amodeCode amode asmVoid
1818         code2   = registerCode register tmp1 asmVoid
1819
1820         src__2  = registerName register tmp1
1821         pk__2   = registerRep register
1822         sz__2   = primRepToSize pk__2
1823
1824         code__2 = asmParThen [code1, code2] .
1825             if pk == pk__2 then
1826                     mkSeqInstr (ST sz src__2 dst__2)
1827             else
1828                 mkSeqInstrs [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2]
1829     in
1830     returnUs code__2
1831
1832 assignFltCode pk dst src
1833   = getRegister dst                         `thenUs` \ register1 ->
1834     getRegister src                         `thenUs` \ register2 ->
1835     let
1836         pk__2   = registerRep register2
1837         sz__2   = primRepToSize pk__2
1838     in
1839     getNewRegNCG pk__2                      `thenUs` \ tmp ->
1840     let
1841         sz      = primRepToSize pk
1842         dst__2  = registerName register1 g0    -- must be Fixed
1843
1844
1845         reg__2  = if pk /= pk__2 then tmp else dst__2
1846
1847         code    = registerCode register2 reg__2
1848
1849         src__2  = registerName register2 reg__2
1850
1851         code__2 =
1852                 if pk /= pk__2 then
1853                      code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
1854                 else if isFixed register2 then
1855                      code . mkSeqInstr (FMOV sz src__2 dst__2)
1856                 else
1857                      code
1858     in
1859     returnUs code__2
1860
1861 #endif {- sparc_TARGET_ARCH -}
1862 \end{code}
1863
1864 %************************************************************************
1865 %*                                                                      *
1866 \subsection{Generating an unconditional branch}
1867 %*                                                                      *
1868 %************************************************************************
1869
1870 We accept two types of targets: an immediate CLabel or a tree that
1871 gets evaluated into a register.  Any CLabels which are AsmTemporaries
1872 are assumed to be in the local block of code, close enough for a
1873 branch instruction.  Other CLabels are assumed to be far away.
1874
1875 (If applicable) Do not fill the delay slots here; you will confuse the
1876 register allocator.
1877
1878 \begin{code}
1879 genJump :: StixTree{-the branch target-} -> UniqSM InstrBlock
1880
1881 #if alpha_TARGET_ARCH
1882
1883 genJump (StCLbl lbl)
1884   | isAsmTemp lbl = returnInstr (BR target)
1885   | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
1886   where
1887     target = ImmCLbl lbl
1888
1889 genJump tree
1890   = getRegister tree                        `thenUs` \ register ->
1891     getNewRegNCG PtrRep             `thenUs` \ tmp ->
1892     let
1893         dst    = registerName register pv
1894         code   = registerCode register pv
1895         target = registerName register pv
1896     in
1897     if isFixed register then
1898         returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
1899     else
1900     returnUs (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
1901
1902 #endif {- alpha_TARGET_ARCH -}
1903 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1904 #if i386_TARGET_ARCH
1905
1906 {-
1907 genJump (StCLbl lbl)
1908   | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
1909   | otherwise     = returnInstrs [JMP (OpImm target)]
1910   where
1911     target = ImmCLbl lbl
1912 -}
1913
1914 genJump (StInd pk mem)
1915   = getAmode mem                    `thenUs` \ amode ->
1916     let
1917         code   = amodeCode amode
1918         target = amodeAddr amode
1919     in
1920     returnSeq code [JMP (OpAddr target)]
1921
1922 genJump tree
1923   | maybeToBool imm
1924   = returnInstr (JMP (OpImm target))
1925
1926   | otherwise
1927   = getRegister tree                        `thenUs` \ register ->
1928     getNewRegNCG PtrRep             `thenUs` \ tmp ->
1929     let
1930         code   = registerCode register tmp
1931         target = registerName register tmp
1932     in
1933     returnSeq code [JMP (OpReg target)]
1934   where
1935     imm    = maybeImm tree
1936     target = case imm of Just x -> x
1937
1938 #endif {- i386_TARGET_ARCH -}
1939 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1940 #if sparc_TARGET_ARCH
1941
1942 genJump (StCLbl lbl)
1943   | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
1944   | otherwise     = returnInstrs [CALL target 0 True, NOP]
1945   where
1946     target = ImmCLbl lbl
1947
1948 genJump tree
1949   = getRegister tree                        `thenUs` \ register ->
1950     getNewRegNCG PtrRep             `thenUs` \ tmp ->
1951     let
1952         code   = registerCode register tmp
1953         target = registerName register tmp
1954     in
1955     returnSeq code [JMP (AddrRegReg target g0), NOP]
1956
1957 #endif {- sparc_TARGET_ARCH -}
1958 \end{code}
1959
1960 %************************************************************************
1961 %*                                                                      *
1962 \subsection{Conditional jumps}
1963 %*                                                                      *
1964 %************************************************************************
1965
1966 Conditional jumps are always to local labels, so we can use branch
1967 instructions.  We peek at the arguments to decide what kind of
1968 comparison to do.
1969
1970 ALPHA: For comparisons with 0, we're laughing, because we can just do
1971 the desired conditional branch.
1972
1973 I386: First, we have to ensure that the condition
1974 codes are set according to the supplied comparison operation.
1975
1976 SPARC: First, we have to ensure that the condition codes are set
1977 according to the supplied comparison operation.  We generate slightly
1978 different code for floating point comparisons, because a floating
1979 point operation cannot directly precede a @BF@.  We assume the worst
1980 and fill that slot with a @NOP@.
1981
1982 SPARC: Do not fill the delay slots here; you will confuse the register
1983 allocator.
1984
1985 \begin{code}
1986 genCondJump
1987     :: CLabel       -- the branch target
1988     -> StixTree     -- the condition on which to branch
1989     -> UniqSM InstrBlock
1990
1991 #if alpha_TARGET_ARCH
1992
1993 genCondJump lbl (StPrim op [x, StInt 0])
1994   = getRegister x                           `thenUs` \ register ->
1995     getNewRegNCG (registerRep register)
1996                                     `thenUs` \ tmp ->
1997     let
1998         code   = registerCode register tmp
1999         value  = registerName register tmp
2000         pk     = registerRep register
2001         target = ImmCLbl lbl
2002     in
2003     returnSeq code [BI (cmpOp op) value target]
2004   where
2005     cmpOp CharGtOp = GTT
2006     cmpOp CharGeOp = GE
2007     cmpOp CharEqOp = EQQ
2008     cmpOp CharNeOp = NE
2009     cmpOp CharLtOp = LTT
2010     cmpOp CharLeOp = LE
2011     cmpOp IntGtOp = GTT
2012     cmpOp IntGeOp = GE
2013     cmpOp IntEqOp = EQQ
2014     cmpOp IntNeOp = NE
2015     cmpOp IntLtOp = LTT
2016     cmpOp IntLeOp = LE
2017     cmpOp WordGtOp = NE
2018     cmpOp WordGeOp = ALWAYS
2019     cmpOp WordEqOp = EQQ
2020     cmpOp WordNeOp = NE
2021     cmpOp WordLtOp = NEVER
2022     cmpOp WordLeOp = EQQ
2023     cmpOp AddrGtOp = NE
2024     cmpOp AddrGeOp = ALWAYS
2025     cmpOp AddrEqOp = EQQ
2026     cmpOp AddrNeOp = NE
2027     cmpOp AddrLtOp = NEVER
2028     cmpOp AddrLeOp = EQQ
2029
2030 genCondJump lbl (StPrim op [x, StDouble 0.0])
2031   = getRegister x                           `thenUs` \ register ->
2032     getNewRegNCG (registerRep register)
2033                                     `thenUs` \ tmp ->
2034     let
2035         code   = registerCode register tmp
2036         value  = registerName register tmp
2037         pk     = registerRep register
2038         target = ImmCLbl lbl
2039     in
2040     returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
2041   where
2042     cmpOp FloatGtOp = GTT
2043     cmpOp FloatGeOp = GE
2044     cmpOp FloatEqOp = EQQ
2045     cmpOp FloatNeOp = NE
2046     cmpOp FloatLtOp = LTT
2047     cmpOp FloatLeOp = LE
2048     cmpOp DoubleGtOp = GTT
2049     cmpOp DoubleGeOp = GE
2050     cmpOp DoubleEqOp = EQQ
2051     cmpOp DoubleNeOp = NE
2052     cmpOp DoubleLtOp = LTT
2053     cmpOp DoubleLeOp = LE
2054
2055 genCondJump lbl (StPrim op [x, y])
2056   | fltCmpOp op
2057   = trivialFCode pr instr x y       `thenUs` \ register ->
2058     getNewRegNCG DoubleRep          `thenUs` \ tmp ->
2059     let
2060         code   = registerCode register tmp
2061         result = registerName register tmp
2062         target = ImmCLbl lbl
2063     in
2064     returnUs (code . mkSeqInstr (BF cond result target))
2065   where
2066     pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
2067
2068     fltCmpOp op = case op of
2069         FloatGtOp -> True
2070         FloatGeOp -> True
2071         FloatEqOp -> True
2072         FloatNeOp -> True
2073         FloatLtOp -> True
2074         FloatLeOp -> True
2075         DoubleGtOp -> True
2076         DoubleGeOp -> True
2077         DoubleEqOp -> True
2078         DoubleNeOp -> True
2079         DoubleLtOp -> True
2080         DoubleLeOp -> True
2081         _ -> False
2082     (instr, cond) = case op of
2083         FloatGtOp -> (FCMP TF LE, EQQ)
2084         FloatGeOp -> (FCMP TF LTT, EQQ)
2085         FloatEqOp -> (FCMP TF EQQ, NE)
2086         FloatNeOp -> (FCMP TF EQQ, EQQ)
2087         FloatLtOp -> (FCMP TF LTT, NE)
2088         FloatLeOp -> (FCMP TF LE, NE)
2089         DoubleGtOp -> (FCMP TF LE, EQQ)
2090         DoubleGeOp -> (FCMP TF LTT, EQQ)
2091         DoubleEqOp -> (FCMP TF EQQ, NE)
2092         DoubleNeOp -> (FCMP TF EQQ, EQQ)
2093         DoubleLtOp -> (FCMP TF LTT, NE)
2094         DoubleLeOp -> (FCMP TF LE, NE)
2095
2096 genCondJump lbl (StPrim op [x, y])
2097   = trivialCode instr x y           `thenUs` \ register ->
2098     getNewRegNCG IntRep             `thenUs` \ tmp ->
2099     let
2100         code   = registerCode register tmp
2101         result = registerName register tmp
2102         target = ImmCLbl lbl
2103     in
2104     returnUs (code . mkSeqInstr (BI cond result target))
2105   where
2106     (instr, cond) = case op of
2107         CharGtOp -> (CMP LE, EQQ)
2108         CharGeOp -> (CMP LTT, EQQ)
2109         CharEqOp -> (CMP EQQ, NE)
2110         CharNeOp -> (CMP EQQ, EQQ)
2111         CharLtOp -> (CMP LTT, NE)
2112         CharLeOp -> (CMP LE, NE)
2113         IntGtOp -> (CMP LE, EQQ)
2114         IntGeOp -> (CMP LTT, EQQ)
2115         IntEqOp -> (CMP EQQ, NE)
2116         IntNeOp -> (CMP EQQ, EQQ)
2117         IntLtOp -> (CMP LTT, NE)
2118         IntLeOp -> (CMP LE, NE)
2119         WordGtOp -> (CMP ULE, EQQ)
2120         WordGeOp -> (CMP ULT, EQQ)
2121         WordEqOp -> (CMP EQQ, NE)
2122         WordNeOp -> (CMP EQQ, EQQ)
2123         WordLtOp -> (CMP ULT, NE)
2124         WordLeOp -> (CMP ULE, NE)
2125         AddrGtOp -> (CMP ULE, EQQ)
2126         AddrGeOp -> (CMP ULT, EQQ)
2127         AddrEqOp -> (CMP EQQ, NE)
2128         AddrNeOp -> (CMP EQQ, EQQ)
2129         AddrLtOp -> (CMP ULT, NE)
2130         AddrLeOp -> (CMP ULE, NE)
2131
2132 #endif {- alpha_TARGET_ARCH -}
2133 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2134 #if i386_TARGET_ARCH
2135
2136 genCondJump lbl bool
2137   = getCondCode bool                `thenUs` \ condition ->
2138     let
2139         code   = condCode condition
2140         cond   = condName condition
2141         target = ImmCLbl lbl
2142     in
2143     returnSeq code [JXX cond lbl]
2144
2145 #endif {- i386_TARGET_ARCH -}
2146 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2147 #if sparc_TARGET_ARCH
2148
2149 genCondJump lbl bool
2150   = getCondCode bool                `thenUs` \ condition ->
2151     let
2152         code   = condCode condition
2153         cond   = condName condition
2154         target = ImmCLbl lbl
2155     in
2156     returnSeq code (
2157     if condFloat condition then
2158         [NOP, BF cond False target, NOP]
2159     else
2160         [BI cond False target, NOP]
2161     )
2162
2163 #endif {- sparc_TARGET_ARCH -}
2164 \end{code}
2165
2166 %************************************************************************
2167 %*                                                                      *
2168 \subsection{Generating C calls}
2169 %*                                                                      *
2170 %************************************************************************
2171
2172 Now the biggest nightmare---calls.  Most of the nastiness is buried in
2173 @get_arg@, which moves the arguments to the correct registers/stack
2174 locations.  Apart from that, the code is easy.
2175
2176 (If applicable) Do not fill the delay slots here; you will confuse the
2177 register allocator.
2178
2179 \begin{code}
2180 genCCall
2181     :: FAST_STRING      -- function to call
2182     -> CallConv
2183     -> PrimRep          -- type of the result
2184     -> [StixTree]       -- arguments (of mixed type)
2185     -> UniqSM InstrBlock
2186
2187 #if alpha_TARGET_ARCH
2188
2189 genCCall fn cconv kind args
2190   = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2191                                     `thenUs` \ ((unused,_), argCode) ->
2192     let
2193         nRegs = length allArgRegs - length unused
2194         code = asmParThen (map ($ asmVoid) argCode)
2195     in
2196         returnSeq code [
2197             LDA pv (AddrImm (ImmLab (ptext fn))),
2198             JSR ra (AddrReg pv) nRegs,
2199             LDGP gp (AddrReg ra)]
2200   where
2201     ------------------------
2202     {-  Try to get a value into a specific register (or registers) for
2203         a call.  The first 6 arguments go into the appropriate
2204         argument register (separate registers for integer and floating
2205         point arguments, but used in lock-step), and the remaining
2206         arguments are dumped to the stack, beginning at 0(sp).  Our
2207         first argument is a pair of the list of remaining argument
2208         registers to be assigned for this call and the next stack
2209         offset to use for overflowing arguments.  This way,
2210         @get_Arg@ can be applied to all of a call's arguments using
2211         @mapAccumLUs@.
2212     -}
2213     get_arg
2214         :: ([(Reg,Reg)], Int)   -- Argument registers and stack offset (accumulator)
2215         -> StixTree             -- Current argument
2216         -> UniqSM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
2217
2218     -- We have to use up all of our argument registers first...
2219
2220     get_arg ((iDst,fDst):dsts, offset) arg
2221       = getRegister arg                     `thenUs` \ register ->
2222         let
2223             reg  = if isFloatingRep pk then fDst else iDst
2224             code = registerCode register reg
2225             src  = registerName register reg
2226             pk   = registerRep register
2227         in
2228         returnUs (
2229             if isFloatingRep pk then
2230                 ((dsts, offset), if isFixed register then
2231                     code . mkSeqInstr (FMOV src fDst)
2232                     else code)
2233             else
2234                 ((dsts, offset), if isFixed register then
2235                     code . mkSeqInstr (OR src (RIReg src) iDst)
2236                     else code))
2237
2238     -- Once we have run out of argument registers, we move to the
2239     -- stack...
2240
2241     get_arg ([], offset) arg
2242       = getRegister arg                 `thenUs` \ register ->
2243         getNewRegNCG (registerRep register)
2244                                         `thenUs` \ tmp ->
2245         let
2246             code = registerCode register tmp
2247             src  = registerName register tmp
2248             pk   = registerRep register
2249             sz   = primRepToSize pk
2250         in
2251         returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
2252
2253 #endif {- alpha_TARGET_ARCH -}
2254 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2255 #if i386_TARGET_ARCH
2256
2257 genCCall fn cconv kind [StInt i]
2258   | fn == SLIT ("PerformGC_wrapper")
2259   = let call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
2260                 CALL (ImmLit (ptext (if   underscorePrefix
2261                                      then (SLIT ("_PerformGC_wrapper"))
2262                                      else (SLIT ("PerformGC_wrapper")))))]
2263     in
2264     returnInstrs call
2265
2266
2267 genCCall fn cconv kind args
2268   = get_call_args args `thenUs` \ (tot_arg_size, argCode) ->
2269     let
2270         code2 = asmParThen (map ($ asmVoid) argCode)
2271         call = [SUB L (OpImm (ImmInt tot_arg_size)) (OpReg esp),
2272                 CALL fn__2 ,
2273                 ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)
2274                ]
2275     in
2276     returnSeq code2 call
2277
2278   where
2279     -- function names that begin with '.' are assumed to be special
2280     -- internally generated names like '.mul,' which don't get an
2281     -- underscore prefix
2282     -- ToDo:needed (WDP 96/03) ???
2283     fn__2 = case (_HEAD_ fn) of
2284               '.' -> ImmLit (ptext fn)
2285               _   -> ImmLab (ptext fn)
2286
2287     arg_size DF = 8
2288     arg_size _  = 4
2289
2290     ------------
2291     -- do get_call_arg on each arg, threading the total arg size along
2292     -- process the args right-to-left
2293     get_call_args :: [StixTree] -> UniqSM (Int, [InstrBlock])
2294     get_call_args args
2295        = f 0 args
2296          where
2297             f curr_sz []
2298                = returnUs (curr_sz, [])
2299             f curr_sz (arg:args)
2300                = f curr_sz args          `thenUs` \ (new_sz, iblocks) ->
2301                  get_call_arg arg new_sz `thenUs` \ (new_sz2, iblock) ->
2302                  returnUs (new_sz2, iblock:iblocks)
2303
2304
2305     ------------
2306     get_call_arg :: StixTree{-current argument-}
2307                     -> Int{-running total of arg sizes seen so far-}
2308                     -> UniqSM (Int, InstrBlock)  -- updated tot argsz, code
2309
2310     get_call_arg arg old_sz
2311       = get_op arg              `thenUs` \ (code, reg, sz) ->
2312         let new_sz = old_sz + arg_size sz
2313         in  if   (case sz of DF -> True; F -> True; _ -> False)
2314             then returnUs (new_sz,
2315                            code .
2316                            mkSeqInstr (GST sz reg
2317                                               (AddrBaseIndex (Just esp)
2318                                                   Nothing (ImmInt (- new_sz))))
2319                           )
2320             else returnUs (new_sz,
2321                            code .
2322                            mkSeqInstr (MOV sz (OpReg reg)
2323                                               (OpAddr
2324                                                   (AddrBaseIndex (Just esp)
2325                                                      Nothing (ImmInt (- new_sz)))))
2326                           )
2327     ------------
2328     get_op
2329         :: StixTree
2330         -> UniqSM (InstrBlock, Reg, Size) -- code, reg, size
2331
2332     get_op op
2333       = getRegister op          `thenUs` \ register ->
2334         getNewRegNCG (registerRep register)
2335                                 `thenUs` \ tmp ->
2336         let
2337             code = registerCode register tmp
2338             reg  = registerName register tmp
2339             pk   = registerRep  register
2340             sz   = primRepToSize pk
2341         in
2342         returnUs (code, reg, sz)
2343
2344 #endif {- i386_TARGET_ARCH -}
2345 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2346 #if sparc_TARGET_ARCH
2347
2348 genCCall fn cconv kind args
2349   = mapAccumLUs get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
2350                                     `thenUs` \ ((unused,_), argCode) ->
2351     let
2352         nRegs = length allArgRegs - length unused
2353         call = CALL fn__2 nRegs False
2354         code = asmParThen (map ($ asmVoid) argCode)
2355     in
2356         returnSeq code [call, NOP]
2357   where
2358     -- function names that begin with '.' are assumed to be special
2359     -- internally generated names like '.mul,' which don't get an
2360     -- underscore prefix
2361     -- ToDo:needed (WDP 96/03) ???
2362     fn__2 = case (_HEAD_ fn) of
2363               '.' -> ImmLit (ptext fn)
2364               _   -> ImmLab (ptext fn)
2365
2366     ------------------------------------
2367     {-  Try to get a value into a specific register (or registers) for
2368         a call.  The SPARC calling convention is an absolute
2369         nightmare.  The first 6x32 bits of arguments are mapped into
2370         %o0 through %o5, and the remaining arguments are dumped to the
2371         stack, beginning at [%sp+92].  (Note that %o6 == %sp.)  Our
2372         first argument is a pair of the list of remaining argument
2373         registers to be assigned for this call and the next stack
2374         offset to use for overflowing arguments.  This way,
2375         @get_arg@ can be applied to all of a call's arguments using
2376         @mapAccumL@.
2377     -}
2378     get_arg
2379         :: ([Reg],Int)  -- Argument registers and stack offset (accumulator)
2380         -> StixTree     -- Current argument
2381         -> UniqSM (([Reg],Int), InstrBlock) -- Updated accumulator and code
2382
2383     -- We have to use up all of our argument registers first...
2384
2385     get_arg (dst:dsts, offset) arg
2386       = getRegister arg                 `thenUs` \ register ->
2387         getNewRegNCG (registerRep register)
2388                                         `thenUs` \ tmp ->
2389         let
2390             reg  = if isFloatingRep pk then tmp else dst
2391             code = registerCode register reg
2392             src  = registerName register reg
2393             pk   = registerRep register
2394         in
2395         returnUs (case pk of
2396             DoubleRep ->
2397                 case dsts of
2398                     [] -> (([], offset + 1), code . mkSeqInstrs [
2399                             -- conveniently put the second part in the right stack
2400                             -- location, and load the first part into %o5
2401                             ST DF src (spRel (offset - 1)),
2402                             LD W (spRel (offset - 1)) dst])
2403                     (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
2404                             ST DF src (spRel (-2)),
2405                             LD W (spRel (-2)) dst,
2406                             LD W (spRel (-1)) dst__2])
2407             FloatRep -> ((dsts, offset), code . mkSeqInstrs [
2408                             ST F src (spRel (-2)),
2409                             LD W (spRel (-2)) dst])
2410             _ -> ((dsts, offset), if isFixed register then
2411                                   code . mkSeqInstr (OR False g0 (RIReg src) dst)
2412                                   else code))
2413
2414     -- Once we have run out of argument registers, we move to the
2415     -- stack...
2416
2417     get_arg ([], offset) arg
2418       = getRegister arg                 `thenUs` \ register ->
2419         getNewRegNCG (registerRep register)
2420                                         `thenUs` \ tmp ->
2421         let
2422             code  = registerCode register tmp
2423             src   = registerName register tmp
2424             pk    = registerRep register
2425             sz    = primRepToSize pk
2426             words = if pk == DoubleRep then 2 else 1
2427         in
2428         returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
2429
2430 #endif {- sparc_TARGET_ARCH -}
2431 \end{code}
2432
2433 %************************************************************************
2434 %*                                                                      *
2435 \subsection{Support bits}
2436 %*                                                                      *
2437 %************************************************************************
2438
2439 %************************************************************************
2440 %*                                                                      *
2441 \subsubsection{@condIntReg@ and @condFltReg@: condition codes into registers}
2442 %*                                                                      *
2443 %************************************************************************
2444
2445 Turn those condition codes into integers now (when they appear on
2446 the right hand side of an assignment).
2447
2448 (If applicable) Do not fill the delay slots here; you will confuse the
2449 register allocator.
2450
2451 \begin{code}
2452 condIntReg, condFltReg :: Cond -> StixTree -> StixTree -> UniqSM Register
2453
2454 #if alpha_TARGET_ARCH
2455 condIntReg = panic "MachCode.condIntReg (not on Alpha)"
2456 condFltReg = panic "MachCode.condFltReg (not on Alpha)"
2457 #endif {- alpha_TARGET_ARCH -}
2458
2459 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2460 #if i386_TARGET_ARCH
2461
2462 condIntReg cond x y
2463   = condIntCode cond x y        `thenUs` \ condition ->
2464     getNewRegNCG IntRep         `thenUs` \ tmp ->
2465     --getRegister dst           `thenUs` \ register ->
2466     let
2467         --code2 = registerCode register tmp asmVoid
2468         --dst__2  = registerName register tmp
2469         code = condCode condition
2470         cond = condName condition
2471         -- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
2472         code__2 dst = code . mkSeqInstrs [
2473             SETCC cond (OpReg tmp),
2474             AND L (OpImm (ImmInt 1)) (OpReg tmp),
2475             MOV L (OpReg tmp) (OpReg dst)]
2476     in
2477     returnUs (Any IntRep code__2)
2478
2479 condFltReg cond x y
2480   = getUniqLabelNCG             `thenUs` \ lbl1 ->
2481     getUniqLabelNCG             `thenUs` \ lbl2 ->
2482     condFltCode cond x y        `thenUs` \ condition ->
2483     let
2484         code = condCode condition
2485         cond = condName condition
2486         code__2 dst = code . mkSeqInstrs [
2487             JXX cond lbl1,
2488             MOV L (OpImm (ImmInt 0)) (OpReg dst),
2489             JXX ALWAYS lbl2,
2490             LABEL lbl1,
2491             MOV L (OpImm (ImmInt 1)) (OpReg dst),
2492             LABEL lbl2]
2493     in
2494     returnUs (Any IntRep code__2)
2495
2496 #endif {- i386_TARGET_ARCH -}
2497 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2498 #if sparc_TARGET_ARCH
2499
2500 condIntReg EQQ x (StInt 0)
2501   = getRegister x               `thenUs` \ register ->
2502     getNewRegNCG IntRep         `thenUs` \ tmp ->
2503     let
2504         code = registerCode register tmp
2505         src  = registerName register tmp
2506         code__2 dst = code . mkSeqInstrs [
2507             SUB False True g0 (RIReg src) g0,
2508             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2509     in
2510     returnUs (Any IntRep code__2)
2511
2512 condIntReg EQQ x y
2513   = getRegister x               `thenUs` \ register1 ->
2514     getRegister y               `thenUs` \ register2 ->
2515     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2516     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2517     let
2518         code1 = registerCode register1 tmp1 asmVoid
2519         src1  = registerName register1 tmp1
2520         code2 = registerCode register2 tmp2 asmVoid
2521         src2  = registerName register2 tmp2
2522         code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2523             XOR False src1 (RIReg src2) dst,
2524             SUB False True g0 (RIReg dst) g0,
2525             SUB True False g0 (RIImm (ImmInt (-1))) dst]
2526     in
2527     returnUs (Any IntRep code__2)
2528
2529 condIntReg NE x (StInt 0)
2530   = getRegister x               `thenUs` \ register ->
2531     getNewRegNCG IntRep         `thenUs` \ tmp ->
2532     let
2533         code = registerCode register tmp
2534         src  = registerName register tmp
2535         code__2 dst = code . mkSeqInstrs [
2536             SUB False True g0 (RIReg src) g0,
2537             ADD True False g0 (RIImm (ImmInt 0)) dst]
2538     in
2539     returnUs (Any IntRep code__2)
2540
2541 condIntReg NE x y
2542   = getRegister x               `thenUs` \ register1 ->
2543     getRegister y               `thenUs` \ register2 ->
2544     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2545     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2546     let
2547         code1 = registerCode register1 tmp1 asmVoid
2548         src1  = registerName register1 tmp1
2549         code2 = registerCode register2 tmp2 asmVoid
2550         src2  = registerName register2 tmp2
2551         code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
2552             XOR False src1 (RIReg src2) dst,
2553             SUB False True g0 (RIReg dst) g0,
2554             ADD True False g0 (RIImm (ImmInt 0)) dst]
2555     in
2556     returnUs (Any IntRep code__2)
2557
2558 condIntReg cond x y
2559   = getUniqLabelNCG             `thenUs` \ lbl1 ->
2560     getUniqLabelNCG             `thenUs` \ lbl2 ->
2561     condIntCode cond x y        `thenUs` \ condition ->
2562     let
2563         code = condCode condition
2564         cond = condName condition
2565         code__2 dst = code . mkSeqInstrs [
2566             BI cond False (ImmCLbl lbl1), NOP,
2567             OR False g0 (RIImm (ImmInt 0)) dst,
2568             BI ALWAYS False (ImmCLbl lbl2), NOP,
2569             LABEL lbl1,
2570             OR False g0 (RIImm (ImmInt 1)) dst,
2571             LABEL lbl2]
2572     in
2573     returnUs (Any IntRep code__2)
2574
2575 condFltReg cond x y
2576   = getUniqLabelNCG             `thenUs` \ lbl1 ->
2577     getUniqLabelNCG             `thenUs` \ lbl2 ->
2578     condFltCode cond x y        `thenUs` \ condition ->
2579     let
2580         code = condCode condition
2581         cond = condName condition
2582         code__2 dst = code . mkSeqInstrs [
2583             NOP,
2584             BF cond False (ImmCLbl lbl1), NOP,
2585             OR False g0 (RIImm (ImmInt 0)) dst,
2586             BI ALWAYS False (ImmCLbl lbl2), NOP,
2587             LABEL lbl1,
2588             OR False g0 (RIImm (ImmInt 1)) dst,
2589             LABEL lbl2]
2590     in
2591     returnUs (Any IntRep code__2)
2592
2593 #endif {- sparc_TARGET_ARCH -}
2594 \end{code}
2595
2596 %************************************************************************
2597 %*                                                                      *
2598 \subsubsection{@trivial*Code@: deal with trivial instructions}
2599 %*                                                                      *
2600 %************************************************************************
2601
2602 Trivial (dyadic: @trivialCode@, floating-point: @trivialFCode@, unary:
2603 @trivialUCode@, unary fl-pt:@trivialUFCode@) instructions.  Only look
2604 for constants on the right hand side, because that's where the generic
2605 optimizer will have put them.
2606
2607 Similarly, for unary instructions, we don't have to worry about
2608 matching an StInt as the argument, because genericOpt will already
2609 have handled the constant-folding.
2610
2611 \begin{code}
2612 trivialCode
2613     :: IF_ARCH_alpha((Reg -> RI -> Reg -> Instr)
2614       ,IF_ARCH_i386 ((Operand -> Operand -> Instr)
2615       ,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
2616       ,)))
2617     -> StixTree -> StixTree -- the two arguments
2618     -> UniqSM Register
2619
2620 trivialFCode
2621     :: PrimRep
2622     -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
2623       ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
2624       ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
2625       ,)))
2626     -> StixTree -> StixTree -- the two arguments
2627     -> UniqSM Register
2628
2629 trivialUCode
2630     :: IF_ARCH_alpha((RI -> Reg -> Instr)
2631       ,IF_ARCH_i386 ((Operand -> Instr)
2632       ,IF_ARCH_sparc((RI -> Reg -> Instr)
2633       ,)))
2634     -> StixTree -- the one argument
2635     -> UniqSM Register
2636
2637 trivialUFCode
2638     :: PrimRep
2639     -> IF_ARCH_alpha((Reg -> Reg -> Instr)
2640       ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
2641       ,IF_ARCH_sparc((Reg -> Reg -> Instr)
2642       ,)))
2643     -> StixTree -- the one argument
2644     -> UniqSM Register
2645
2646 #if alpha_TARGET_ARCH
2647
2648 trivialCode instr x (StInt y)
2649   | fits8Bits y
2650   = getRegister x               `thenUs` \ register ->
2651     getNewRegNCG IntRep         `thenUs` \ tmp ->
2652     let
2653         code = registerCode register tmp
2654         src1 = registerName register tmp
2655         src2 = ImmInt (fromInteger y)
2656         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2657     in
2658     returnUs (Any IntRep code__2)
2659
2660 trivialCode instr x y
2661   = getRegister x               `thenUs` \ register1 ->
2662     getRegister y               `thenUs` \ register2 ->
2663     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2664     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2665     let
2666         code1 = registerCode register1 tmp1 asmVoid
2667         src1  = registerName register1 tmp1
2668         code2 = registerCode register2 tmp2 asmVoid
2669         src2  = registerName register2 tmp2
2670         code__2 dst = asmParThen [code1, code2] .
2671                      mkSeqInstr (instr src1 (RIReg src2) dst)
2672     in
2673     returnUs (Any IntRep code__2)
2674
2675 ------------
2676 trivialUCode instr x
2677   = getRegister x               `thenUs` \ register ->
2678     getNewRegNCG IntRep         `thenUs` \ tmp ->
2679     let
2680         code = registerCode register tmp
2681         src  = registerName register tmp
2682         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2683     in
2684     returnUs (Any IntRep code__2)
2685
2686 ------------
2687 trivialFCode _ instr x y
2688   = getRegister x               `thenUs` \ register1 ->
2689     getRegister y               `thenUs` \ register2 ->
2690     getNewRegNCG DoubleRep      `thenUs` \ tmp1 ->
2691     getNewRegNCG DoubleRep      `thenUs` \ tmp2 ->
2692     let
2693         code1 = registerCode register1 tmp1
2694         src1  = registerName register1 tmp1
2695
2696         code2 = registerCode register2 tmp2
2697         src2  = registerName register2 tmp2
2698
2699         code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2700                       mkSeqInstr (instr src1 src2 dst)
2701     in
2702     returnUs (Any DoubleRep code__2)
2703
2704 trivialUFCode _ instr x
2705   = getRegister x               `thenUs` \ register ->
2706     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
2707     let
2708         code = registerCode register tmp
2709         src  = registerName register tmp
2710         code__2 dst = code . mkSeqInstr (instr src dst)
2711     in
2712     returnUs (Any DoubleRep code__2)
2713
2714 #endif {- alpha_TARGET_ARCH -}
2715 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2716 #if i386_TARGET_ARCH
2717
2718 trivialCode instr x y
2719   | maybeToBool imm
2720   = getRegister x               `thenUs` \ register1 ->
2721     let
2722         code__2 dst = let code1 = registerCode register1 dst
2723                           src1  = registerName register1 dst
2724                       in code1 .
2725                          if isFixed register1 && src1 /= dst
2726                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2727                                            instr (OpImm imm__2) (OpReg dst)]
2728                          else
2729                                 mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
2730     in
2731     returnUs (Any IntRep code__2)
2732   where
2733     imm = maybeImm y
2734     imm__2 = case imm of Just x -> x
2735 {-
2736 -- This seems pretty dubious to me.  JRS, 000125.
2737 trivialCode instr x y
2738   | maybeToBool imm
2739   = getRegister y               `thenUs` \ register1 ->
2740     let
2741         code__2 dst = let code1 = registerCode register1 dst
2742                           src1  = registerName register1 dst
2743                       in code1 .
2744                          if   isFixed register1 && src1 /= dst
2745                          then mkSeqInstrs [MOV L (OpImm imm__2) (OpReg dst),
2746                                            instr (OpReg src1) (OpReg dst)]
2747                          else
2748                                 -- can't possibly be right, if instr is
2749                                 -- non-commutative
2750                                 mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
2751     in
2752     returnUs (Any IntRep code__2)
2753   where
2754     imm = maybeImm x
2755     imm__2 = case imm of Just x -> x
2756 -}
2757
2758 trivialCode instr x y
2759   = getRegister x               `thenUs` \ register1 ->
2760     getRegister y               `thenUs` \ register2 ->
2761     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2762     let
2763         code2 = registerCode register2 tmp2 asmVoid
2764         src2  = registerName register2 tmp2
2765         code__2 dst = let
2766                           code1 = registerCode register1 dst asmVoid
2767                           src1  = registerName register1 dst
2768                       in asmParThen [code1, code2] .
2769                          if isFixed register1 && src1 /= dst
2770                          then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
2771                                            instr (OpReg src2)  (OpReg dst)]
2772                          else
2773                                 mkSeqInstr (instr (OpReg src2) (OpReg src1))
2774     in
2775     returnUs (Any IntRep code__2)
2776
2777 -----------
2778 trivialUCode instr x
2779   = getRegister x               `thenUs` \ register ->
2780     let
2781         code__2 dst = let
2782                           code = registerCode register dst
2783                           src  = registerName register dst
2784                       in code . if isFixed register && dst /= src
2785                                 then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
2786                                                   instr (OpReg dst)]
2787                                 else mkSeqInstr (instr (OpReg src))
2788     in
2789     returnUs (Any IntRep code__2)
2790
2791 -----------
2792 trivialFCode pk instr x y
2793   = getRegister x               `thenUs` \ register1 ->
2794     getRegister y               `thenUs` \ register2 ->
2795     getNewRegNCG DoubleRep      `thenUs` \ tmp1 ->
2796     getNewRegNCG DoubleRep      `thenUs` \ tmp2 ->
2797     let
2798         code1 = registerCode register1 tmp1
2799         src1  = registerName register1 tmp1
2800
2801         code2 = registerCode register2 tmp2
2802         src2  = registerName register2 tmp2
2803
2804         code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
2805                       mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
2806     in
2807     returnUs (Any DoubleRep code__2)
2808
2809
2810 -------------
2811 trivialUFCode pk instr x
2812   = getRegister x               `thenUs` \ register ->
2813     getNewRegNCG pk             `thenUs` \ tmp ->
2814     let
2815         code = registerCode register tmp
2816         src  = registerName register tmp
2817         code__2 dst = code . mkSeqInstr (instr src dst)
2818     in
2819     returnUs (Any pk code__2)
2820
2821 #endif {- i386_TARGET_ARCH -}
2822 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2823 #if sparc_TARGET_ARCH
2824
2825 trivialCode instr x (StInt y)
2826   | fits13Bits y
2827   = getRegister x               `thenUs` \ register ->
2828     getNewRegNCG IntRep         `thenUs` \ tmp ->
2829     let
2830         code = registerCode register tmp
2831         src1 = registerName register tmp
2832         src2 = ImmInt (fromInteger y)
2833         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
2834     in
2835     returnUs (Any IntRep code__2)
2836
2837 trivialCode instr x y
2838   = getRegister x               `thenUs` \ register1 ->
2839     getRegister y               `thenUs` \ register2 ->
2840     getNewRegNCG IntRep         `thenUs` \ tmp1 ->
2841     getNewRegNCG IntRep         `thenUs` \ tmp2 ->
2842     let
2843         code1 = registerCode register1 tmp1 asmVoid
2844         src1  = registerName register1 tmp1
2845         code2 = registerCode register2 tmp2 asmVoid
2846         src2  = registerName register2 tmp2
2847         code__2 dst = asmParThen [code1, code2] .
2848                      mkSeqInstr (instr src1 (RIReg src2) dst)
2849     in
2850     returnUs (Any IntRep code__2)
2851
2852 ------------
2853 trivialFCode pk instr x y
2854   = getRegister x               `thenUs` \ register1 ->
2855     getRegister y               `thenUs` \ register2 ->
2856     getNewRegNCG (registerRep register1)
2857                                 `thenUs` \ tmp1 ->
2858     getNewRegNCG (registerRep register2)
2859                                 `thenUs` \ tmp2 ->
2860     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
2861     let
2862         promote x = asmInstr (FxTOy F DF x tmp)
2863
2864         pk1   = registerRep register1
2865         code1 = registerCode register1 tmp1
2866         src1  = registerName register1 tmp1
2867
2868         pk2   = registerRep register2
2869         code2 = registerCode register2 tmp2
2870         src2  = registerName register2 tmp2
2871
2872         code__2 dst =
2873                 if pk1 == pk2 then
2874                     asmParThen [code1 asmVoid, code2 asmVoid] .
2875                     mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
2876                 else if pk1 == FloatRep then
2877                     asmParThen [code1 (promote src1), code2 asmVoid] .
2878                     mkSeqInstr (instr DF tmp src2 dst)
2879                 else
2880                     asmParThen [code1 asmVoid, code2 (promote src2)] .
2881                     mkSeqInstr (instr DF src1 tmp dst)
2882     in
2883     returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
2884
2885 ------------
2886 trivialUCode instr x
2887   = getRegister x               `thenUs` \ register ->
2888     getNewRegNCG IntRep         `thenUs` \ tmp ->
2889     let
2890         code = registerCode register tmp
2891         src  = registerName register tmp
2892         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
2893     in
2894     returnUs (Any IntRep code__2)
2895
2896 -------------
2897 trivialUFCode pk instr x
2898   = getRegister x               `thenUs` \ register ->
2899     getNewRegNCG pk             `thenUs` \ tmp ->
2900     let
2901         code = registerCode register tmp
2902         src  = registerName register tmp
2903         code__2 dst = code . mkSeqInstr (instr src dst)
2904     in
2905     returnUs (Any pk code__2)
2906
2907 #endif {- sparc_TARGET_ARCH -}
2908 \end{code}
2909
2910 %************************************************************************
2911 %*                                                                      *
2912 \subsubsection{Coercing to/from integer/floating-point...}
2913 %*                                                                      *
2914 %************************************************************************
2915
2916 @coerce(Int|Flt)Code@ are simple coercions that don't require any code
2917 to be generated.  Here we just change the type on the Register passed
2918 on up.  The code is machine-independent.
2919
2920 @coerce(Int2FP|FP2Int)@ are more complicated integer/float
2921 conversions.  We have to store temporaries in memory to move
2922 between the integer and the floating point register sets.
2923
2924 \begin{code}
2925 coerceIntCode :: PrimRep -> StixTree -> UniqSM Register
2926 coerceFltCode ::            StixTree -> UniqSM Register
2927
2928 coerceInt2FP :: PrimRep -> StixTree -> UniqSM Register
2929 coerceFP2Int ::            StixTree -> UniqSM Register
2930
2931 coerceIntCode pk x
2932   = getRegister x               `thenUs` \ register ->
2933     returnUs (
2934     case register of
2935         Fixed _ reg code -> Fixed pk reg code
2936         Any   _ code     -> Any   pk code
2937     )
2938
2939 -------------
2940 coerceFltCode x
2941   = getRegister x               `thenUs` \ register ->
2942     returnUs (
2943     case register of
2944         Fixed _ reg code -> Fixed DoubleRep reg code
2945         Any   _ code     -> Any   DoubleRep code
2946     )
2947 \end{code}
2948
2949 \begin{code}
2950 #if alpha_TARGET_ARCH
2951
2952 coerceInt2FP _ x
2953   = getRegister x               `thenUs` \ register ->
2954     getNewRegNCG IntRep         `thenUs` \ reg ->
2955     let
2956         code = registerCode register reg
2957         src  = registerName register reg
2958
2959         code__2 dst = code . mkSeqInstrs [
2960             ST Q src (spRel 0),
2961             LD TF dst (spRel 0),
2962             CVTxy Q TF dst dst]
2963     in
2964     returnUs (Any DoubleRep code__2)
2965
2966 -------------
2967 coerceFP2Int x
2968   = getRegister x               `thenUs` \ register ->
2969     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
2970     let
2971         code = registerCode register tmp
2972         src  = registerName register tmp
2973
2974         code__2 dst = code . mkSeqInstrs [
2975             CVTxy TF Q src tmp,
2976             ST TF tmp (spRel 0),
2977             LD Q dst (spRel 0)]
2978     in
2979     returnUs (Any IntRep code__2)
2980
2981 #endif {- alpha_TARGET_ARCH -}
2982 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2983 #if i386_TARGET_ARCH
2984
2985 coerceInt2FP pk x
2986   = getRegister x               `thenUs` \ register ->
2987     getNewRegNCG IntRep         `thenUs` \ reg ->
2988     let
2989         code = registerCode register reg
2990         src  = registerName register reg
2991         opc  = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
2992         code__2 dst = code .
2993                       mkSeqInstr (opc src dst)
2994     in
2995     returnUs (Any pk code__2)
2996
2997 ------------
2998 coerceFP2Int x
2999   = getRegister x               `thenUs` \ register ->
3000     getNewRegNCG DoubleRep      `thenUs` \ tmp ->
3001     let
3002         code = registerCode register tmp
3003         src  = registerName register tmp
3004         pk   = registerRep register
3005
3006         opc  = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
3007         code__2 dst = code .
3008                       mkSeqInstr (opc src dst)
3009     in
3010     returnUs (Any IntRep code__2)
3011
3012 #endif {- i386_TARGET_ARCH -}
3013 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3014 #if sparc_TARGET_ARCH
3015
3016 coerceInt2FP pk x
3017   = getRegister x               `thenUs` \ register ->
3018     getNewRegNCG IntRep         `thenUs` \ reg ->
3019     let
3020         code = registerCode register reg
3021         src  = registerName register reg
3022
3023         code__2 dst = code . mkSeqInstrs [
3024             ST W src (spRel (-2)),
3025             LD W (spRel (-2)) dst,
3026             FxTOy W (primRepToSize pk) dst dst]
3027     in
3028     returnUs (Any pk code__2)
3029
3030 ------------
3031 coerceFP2Int x
3032   = getRegister x               `thenUs` \ register ->
3033     getNewRegNCG IntRep         `thenUs` \ reg ->
3034     getNewRegNCG FloatRep       `thenUs` \ tmp ->
3035     let
3036         code = registerCode register reg
3037         src  = registerName register reg
3038         pk   = registerRep  register
3039
3040         code__2 dst = code . mkSeqInstrs [
3041             FxTOy (primRepToSize pk) W src tmp,
3042             ST W tmp (spRel (-2)),
3043             LD W (spRel (-2)) dst]
3044     in
3045     returnUs (Any IntRep code__2)
3046
3047 #endif {- sparc_TARGET_ARCH -}
3048 \end{code}
3049
3050 %************************************************************************
3051 %*                                                                      *
3052 \subsubsection{Coercing integer to @Char@...}
3053 %*                                                                      *
3054 %************************************************************************
3055
3056 Integer to character conversion.  Where applicable, we try to do this
3057 in one step if the original object is in memory.
3058
3059 \begin{code}
3060 chrCode :: StixTree -> UniqSM Register
3061
3062 #if alpha_TARGET_ARCH
3063
3064 chrCode x
3065   = getRegister x               `thenUs` \ register ->
3066     getNewRegNCG IntRep         `thenUs` \ reg ->
3067     let
3068         code = registerCode register reg
3069         src  = registerName register reg
3070         code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
3071     in
3072     returnUs (Any IntRep code__2)
3073
3074 #endif {- alpha_TARGET_ARCH -}
3075 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3076 #if i386_TARGET_ARCH
3077
3078 chrCode x
3079   = getRegister x               `thenUs` \ register ->
3080     --getNewRegNCG IntRep       `thenUs` \ reg ->
3081     let
3082         code__2 dst = let
3083                           code = registerCode register dst
3084                           src  = registerName register dst
3085                       in code .
3086                          if isFixed register && src /= dst
3087                          then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
3088                                            AND L (OpImm (ImmInt 255)) (OpReg dst)]
3089                          else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
3090     in
3091     returnUs (Any IntRep code__2)
3092
3093 #endif {- i386_TARGET_ARCH -}
3094 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3095 #if sparc_TARGET_ARCH
3096
3097 chrCode (StInd pk mem)
3098   = getAmode mem                `thenUs` \ amode ->
3099     let
3100         code    = amodeCode amode
3101         src     = amodeAddr amode
3102         src_off = addrOffset src 3
3103         src__2  = case src_off of Just x -> x
3104         code__2 dst = if maybeToBool src_off then
3105                         code . mkSeqInstr (LD BU src__2 dst)
3106                     else
3107                         code . mkSeqInstrs [
3108                             LD (primRepToSize pk) src dst,
3109                             AND False dst (RIImm (ImmInt 255)) dst]
3110     in
3111     returnUs (Any pk code__2)
3112
3113 chrCode x
3114   = getRegister x               `thenUs` \ register ->
3115     getNewRegNCG IntRep         `thenUs` \ reg ->
3116     let
3117         code = registerCode register reg
3118         src  = registerName register reg
3119         code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
3120     in
3121     returnUs (Any IntRep code__2)
3122
3123 #endif {- sparc_TARGET_ARCH -}
3124 \end{code}