ghc/compiler/nativeGen/MachCode.lhs

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