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