ghc/compiler/nativeGen/MachCode.lhs

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