ghc/compiler/nativeGen/MachCode.lhs

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