ghc/compiler/nativeGen/MachCode.lhs

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