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