ghc/compiler/nativeGen/SparcGen.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1995
   3 %
   4
   5 \begin{code}
   6 #include "HsVersions.h"
   7
   8 module SparcGen (
   9         sparcCodeGen,
  10
  11         -- and, for self-sufficiency
  12         PprStyle, StixTree, CSeq
  13     ) where
  14
  15 IMPORT_Trace
  16
  17 import AbsCSyn      ( AbstractC, MagicId(..), kindFromMagicId )
  18 import PrelInfo     ( PrimOp(..)
  19                       IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  20                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  21                     )
  22 import AsmRegAlloc  ( runRegAllocate, mkReg, extractMappedRegNos,
  23                       Reg(..), RegLiveness(..), RegUsage(..),
  24                       FutureLive(..), MachineRegisters(..), MachineCode(..)
  25                     )
  26 import CLabel   ( CLabel, isAsmTemp )
  27 import SparcCode    {- everything -}
  28 import MachDesc
  29 import Maybes       ( maybeToBool, Maybe(..) )
  30 import OrdList      -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
  31 import Outputable
  32 import SparcDesc
  33 import Stix
  34 import UniqSupply
  35 import Pretty
  36 import Unpretty
  37 import Util
  38
  39 type CodeBlock a = (OrdList a -> OrdList a)
  40 \end{code}
  41
  42 %************************************************************************
  43 %*                                                                      *
  44 \subsection[SparcCodeGen]{Generating Sparc Code}
  45 %*                                                                      *
  46 %************************************************************************
  47
  48 This is the top-level code-generation function for the Sparc.
  49
  50 \begin{code}
  51
  52 sparcCodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty
  53 sparcCodeGen sty trees =
  54     mapUs genSparcCode trees            `thenUs` \ dynamicCodes ->
  55     let
  56         staticCodes = scheduleSparcCode dynamicCodes
  57         pretty = printLabeledCodes sty staticCodes
  58     in
  59         returnUs pretty
  60
  61 \end{code}
  62
  63 This bit does the code scheduling.  The scheduler must also deal with
  64 register allocation of temporaries.  Much parallelism can be exposed via
  65 the OrdList, but more might occur, so further analysis might be needed.
  66
  67 \begin{code}
  68
  69 scheduleSparcCode :: [SparcCode] -> [SparcInstr]
  70 scheduleSparcCode = concat . map (runRegAllocate freeSparcRegs reservedRegs)
  71   where
  72     freeSparcRegs :: SparcRegs
  73     freeSparcRegs = mkMRegs (extractMappedRegNos freeRegs)
  74
  75
  76 \end{code}
  77
  78 Registers passed up the tree.  If the stix code forces the register
  79 to live in a pre-decided machine register, it comes out as @Fixed@;
  80 otherwise, it comes out as @Any@, and the parent can decide which
  81 register to put it in.
  82
  83 \begin{code}
  84
  85 data Register
  86   = Fixed Reg PrimRep (CodeBlock SparcInstr)
  87   | Any PrimRep (Reg -> (CodeBlock SparcInstr))
  88
  89 registerCode :: Register -> Reg -> CodeBlock SparcInstr
  90 registerCode (Fixed _ _ code) reg = code
  91 registerCode (Any _ code) reg = code reg
  92
  93 registerName :: Register -> Reg -> Reg
  94 registerName (Fixed reg _ _) _ = reg
  95 registerName (Any _ _) reg = reg
  96
  97 registerKind :: Register -> PrimRep
  98 registerKind (Fixed _ pk _) = pk
  99 registerKind (Any pk _) = pk
 100
 101 isFixed :: Register -> Bool
 102 isFixed (Fixed _ _ _) = True
 103 isFixed (Any _ _)     = False
 104
 105 \end{code}
 106
 107 Memory addressing modes passed up the tree.
 108
 109 \begin{code}
 110
 111 data Amode = Amode Addr (CodeBlock SparcInstr)
 112
 113 amodeAddr (Amode addr _) = addr
 114 amodeCode (Amode _ code) = code
 115
 116 \end{code}
 117
 118 Condition codes passed up the tree.
 119
 120 \begin{code}
 121
 122 data Condition = Condition Bool Cond (CodeBlock SparcInstr)
 123
 124 condName (Condition _ cond _) = cond
 125 condFloat (Condition float _ _) = float
 126 condCode (Condition _ _ code) = code
 127
 128 \end{code}
 129
 130 General things for putting together code sequences.
 131
 132 \begin{code}
 133
 134 asmVoid :: OrdList SparcInstr
 135 asmVoid = mkEmptyList
 136
 137 asmInstr :: SparcInstr -> SparcCode
 138 asmInstr i = mkUnitList i
 139
 140 asmSeq :: [SparcInstr] -> SparcCode
 141 asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
 142
 143 asmParThen :: [SparcCode] -> (CodeBlock SparcInstr)
 144 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
 145
 146 returnInstr :: SparcInstr -> UniqSM (CodeBlock SparcInstr)
 147 returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
 148
 149 returnInstrs :: [SparcInstr] -> UniqSM (CodeBlock SparcInstr)
 150 returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
 151
 152 returnSeq :: (CodeBlock SparcInstr) -> [SparcInstr] -> UniqSM (CodeBlock SparcInstr)
 153 returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
 154
 155 mkSeqInstr :: SparcInstr -> (CodeBlock SparcInstr)
 156 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
 157
 158 mkSeqInstrs :: [SparcInstr] -> (CodeBlock SparcInstr)
 159 mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
 160
 161 \end{code}
 162
 163 Top level sparc code generator for a chunk of stix code.
 164
 165 \begin{code}
 166
 167 genSparcCode :: [StixTree] -> UniqSM (SparcCode)
 168
 169 genSparcCode trees =
 170     mapUs getCode trees                 `thenUs` \ blocks ->
 171     returnUs (foldr (.) id blocks asmVoid)
 172
 173 \end{code}
 174
 175 Code extractor for an entire stix tree---stix statement level.
 176
 177 \begin{code}
 178
 179 getCode
 180     :: StixTree     -- a stix statement
 181     -> UniqSM (CodeBlock SparcInstr)
 182
 183 getCode (StSegment seg) = returnInstr (SEGMENT seg)
 184
 185 getCode (StAssign pk dst src)
 186   | isFloatingRep pk = assignFltCode pk dst src
 187   | otherwise = assignIntCode pk dst src
 188
 189 getCode (StLabel lab) = returnInstr (LABEL lab)
 190
 191 getCode (StFunBegin lab) = returnInstr (LABEL lab)
 192
 193 getCode (StFunEnd lab) = returnUs id
 194
 195 getCode (StJump arg) = genJump arg
 196
 197 getCode (StFallThrough lbl) = returnUs id
 198
 199 getCode (StCondJump lbl arg) = genCondJump lbl arg
 200
 201 getCode (StData kind args) =
 202     mapAndUnzipUs getData args              `thenUs` \ (codes, imms) ->
 203     returnUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
 204                                 (foldr1 (.) codes xs))
 205   where
 206     getData :: StixTree -> UniqSM (CodeBlock SparcInstr, Imm)
 207     getData (StInt i) = returnUs (id, ImmInteger i)
 208     getData (StDouble d) = returnUs (id, strImmLit ('0' : 'r' : ppShow 80 (ppRational d)))
 209     getData (StLitLbl s) = returnUs (id, ImmLab s)
 210     getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
 211     getData (StString s) =
 212         getUniqLabelNCG                     `thenUs` \ lbl ->
 213         returnUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
 214     getData (StCLbl l)   = returnUs (id, ImmCLbl l)
 215
 216 getCode (StCall fn VoidRep args) = genCCall fn VoidRep args
 217
 218 getCode (StComment s) = returnInstr (COMMENT s)
 219
 220 \end{code}
 221
 222 Generate code to get a subtree into a register.
 223
 224 \begin{code}
 225
 226 getReg :: StixTree -> UniqSM Register
 227
 228 getReg (StReg (StixMagicId stgreg)) =
 229     case stgRegMap stgreg of
 230         Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id)
 231         -- cannae be Nothing
 232
 233 getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id)
 234
 235 getReg (StDouble d) =
 236     getUniqLabelNCG                 `thenUs` \ lbl ->
 237     getNewRegNCG PtrRep             `thenUs` \ tmp ->
 238     let code dst = mkSeqInstrs [
 239             SEGMENT DataSegment,
 240             LABEL lbl,
 241             DATA DF [strImmLit ('0' : 'r' : ppShow  80 (ppRational d))],
 242             SEGMENT TextSegment,
 243             SETHI (HI (ImmCLbl lbl)) tmp,
 244             LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
 245     in
 246         returnUs (Any DoubleRep code)
 247
 248 getReg (StString s) =
 249     getUniqLabelNCG                 `thenUs` \ lbl ->
 250     let code dst = mkSeqInstrs [
 251             SEGMENT DataSegment,
 252             LABEL lbl,
 253             ASCII True (_UNPK_ s),
 254             SEGMENT TextSegment,
 255             SETHI (HI (ImmCLbl lbl)) dst,
 256             OR False dst (RIImm (LO (ImmCLbl lbl))) dst]
 257     in
 258         returnUs (Any PtrRep code)
 259
 260 getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
 261     getUniqLabelNCG                 `thenUs` \ lbl ->
 262     let code dst = mkSeqInstrs [
 263             SEGMENT DataSegment,
 264             LABEL lbl,
 265             ASCII False (init xs),
 266             SEGMENT TextSegment,
 267             SETHI (HI (ImmCLbl lbl)) dst,
 268             OR False dst (RIImm (LO (ImmCLbl lbl))) dst]
 269     in
 270         returnUs (Any PtrRep code)
 271   where
 272     xs = _UNPK_ (_TAIL_ s)
 273
 274 getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
 275
 276 getReg (StCall fn kind args) =
 277     genCCall fn kind args           `thenUs` \ call ->
 278     returnUs (Fixed reg kind call)
 279   where
 280     reg = if isFloatingRep kind then f0 else o0
 281
 282 getReg (StPrim primop args) =
 283     case primop of
 284
 285         CharGtOp -> condIntReg GT args
 286         CharGeOp -> condIntReg GE args
 287         CharEqOp -> condIntReg EQ args
 288         CharNeOp -> condIntReg NE args
 289         CharLtOp -> condIntReg LT args
 290         CharLeOp -> condIntReg LE args
 291
 292         IntAddOp -> trivialCode (ADD False False) args
 293
 294         IntSubOp -> trivialCode (SUB False False) args
 295         IntMulOp -> call SLIT(".umul") IntRep
 296         IntQuotOp -> call SLIT(".div") IntRep
 297         IntRemOp -> call SLIT(".rem") IntRep
 298         IntNegOp -> trivialUCode (SUB False False g0) args
 299         IntAbsOp -> absIntCode args
 300
 301         AndOp -> trivialCode (AND False) args
 302         OrOp  -> trivialCode (OR False) args
 303         NotOp -> trivialUCode (XNOR False g0) args
 304         SllOp -> trivialCode SLL args
 305         SraOp -> trivialCode SRA args
 306         SrlOp -> trivialCode SRL args
 307         ISllOp -> panic "SparcGen:isll"
 308         ISraOp -> panic "SparcGen:isra"
 309         ISrlOp -> panic "SparcGen:isrl"
 310
 311         IntGtOp -> condIntReg GT args
 312         IntGeOp -> condIntReg GE args
 313         IntEqOp -> condIntReg EQ args
 314         IntNeOp -> condIntReg NE args
 315         IntLtOp -> condIntReg LT args
 316         IntLeOp -> condIntReg LE args
 317
 318         WordGtOp -> condIntReg GU args
 319         WordGeOp -> condIntReg GEU args
 320         WordEqOp -> condIntReg EQ args
 321         WordNeOp -> condIntReg NE args
 322         WordLtOp -> condIntReg LU args
 323         WordLeOp -> condIntReg LEU args
 324
 325         AddrGtOp -> condIntReg GU args
 326         AddrGeOp -> condIntReg GEU args
 327         AddrEqOp -> condIntReg EQ args
 328         AddrNeOp -> condIntReg NE args
 329         AddrLtOp -> condIntReg LU args
 330         AddrLeOp -> condIntReg LEU args
 331
 332         FloatAddOp -> trivialFCode FloatRep FADD args
 333         FloatSubOp -> trivialFCode FloatRep FSUB args
 334         FloatMulOp -> trivialFCode FloatRep FMUL args
 335         FloatDivOp -> trivialFCode FloatRep FDIV args
 336         FloatNegOp -> trivialUFCode FloatRep (FNEG F) args
 337
 338         FloatGtOp -> condFltReg GT args
 339         FloatGeOp -> condFltReg GE args
 340         FloatEqOp -> condFltReg EQ args
 341         FloatNeOp -> condFltReg NE args
 342         FloatLtOp -> condFltReg LT args
 343         FloatLeOp -> condFltReg LE args
 344
 345         FloatExpOp -> promoteAndCall SLIT("exp") DoubleRep
 346         FloatLogOp -> promoteAndCall SLIT("log") DoubleRep
 347         FloatSqrtOp -> promoteAndCall SLIT("sqrt") DoubleRep
 348
 349         FloatSinOp -> promoteAndCall SLIT("sin") DoubleRep
 350         FloatCosOp -> promoteAndCall SLIT("cos") DoubleRep
 351         FloatTanOp -> promoteAndCall SLIT("tan") DoubleRep
 352
 353         FloatAsinOp -> promoteAndCall SLIT("asin") DoubleRep
 354         FloatAcosOp -> promoteAndCall SLIT("acos") DoubleRep
 355         FloatAtanOp -> promoteAndCall SLIT("atan") DoubleRep
 356
 357         FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleRep
 358         FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleRep
 359         FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleRep
 360
 361         FloatPowerOp -> promoteAndCall SLIT("pow") DoubleRep
 362
 363         DoubleAddOp -> trivialFCode DoubleRep FADD args
 364         DoubleSubOp -> trivialFCode DoubleRep FSUB args
 365         DoubleMulOp -> trivialFCode DoubleRep FMUL args
 366         DoubleDivOp -> trivialFCode DoubleRep FDIV args
 367         DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) args
 368
 369         DoubleGtOp -> condFltReg GT args
 370         DoubleGeOp -> condFltReg GE args
 371         DoubleEqOp -> condFltReg EQ args
 372         DoubleNeOp -> condFltReg NE args
 373         DoubleLtOp -> condFltReg LT args
 374         DoubleLeOp -> condFltReg LE args
 375
 376         DoubleExpOp -> call SLIT("exp") DoubleRep
 377         DoubleLogOp -> call SLIT("log") DoubleRep
 378         DoubleSqrtOp -> call SLIT("sqrt") DoubleRep
 379
 380         DoubleSinOp -> call SLIT("sin") DoubleRep
 381         DoubleCosOp -> call SLIT("cos") DoubleRep
 382         DoubleTanOp -> call SLIT("tan") DoubleRep
 383
 384         DoubleAsinOp -> call SLIT("asin") DoubleRep
 385         DoubleAcosOp -> call SLIT("acos") DoubleRep
 386         DoubleAtanOp -> call SLIT("atan") DoubleRep
 387
 388         DoubleSinhOp -> call SLIT("sinh") DoubleRep
 389         DoubleCoshOp -> call SLIT("cosh") DoubleRep
 390         DoubleTanhOp -> call SLIT("tanh") DoubleRep
 391
 392         DoublePowerOp -> call SLIT("pow") DoubleRep
 393
 394         OrdOp -> coerceIntCode IntRep args
 395         ChrOp -> chrCode args
 396
 397         Float2IntOp -> coerceFP2Int args
 398         Int2FloatOp -> coerceInt2FP FloatRep args
 399         Double2IntOp -> coerceFP2Int args
 400         Int2DoubleOp -> coerceInt2FP DoubleRep args
 401
 402         Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) args
 403         Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) args
 404
 405   where
 406     call fn pk = getReg (StCall fn pk args)
 407     promoteAndCall fn pk = getReg (StCall fn pk (map promote args))
 408       where
 409         promote x = StPrim Float2DoubleOp [x]
 410
 411 getReg (StInd pk mem) =
 412     getAmode mem                    `thenUs` \ amode ->
 413     let
 414         code = amodeCode amode
 415         src   = amodeAddr amode
 416         size = kindToSize pk
 417         code__2 dst = code . mkSeqInstr (LD size src dst)
 418     in
 419         returnUs (Any pk code__2)
 420
 421 getReg (StInt i)
 422   | is13Bits i =
 423     let
 424         src = ImmInt (fromInteger i)
 425         code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
 426     in
 427         returnUs (Any IntRep code)
 428
 429 getReg leaf
 430   | maybeToBool imm =
 431     let
 432         code dst = mkSeqInstrs [
 433             SETHI (HI imm__2) dst,
 434             OR False dst (RIImm (LO imm__2)) dst]
 435     in
 436         returnUs (Any PtrRep code)
 437   where
 438     imm = maybeImm leaf
 439     imm__2 = case imm of Just x -> x
 440
 441 \end{code}
 442
 443 Now, given a tree (the argument to an StInd) that references memory,
 444 produce a suitable addressing mode.
 445
 446 \begin{code}
 447
 448 getAmode :: StixTree -> UniqSM Amode
 449
 450 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
 451
 452 getAmode (StPrim IntSubOp [x, StInt i])
 453   | is13Bits (-i) =
 454     getNewRegNCG PtrRep             `thenUs` \ tmp ->
 455     getReg x                        `thenUs` \ register ->
 456     let
 457         code = registerCode register tmp
 458         reg  = registerName register tmp
 459         off  = ImmInt (-(fromInteger i))
 460     in
 461         returnUs (Amode (AddrRegImm reg off) code)
 462
 463
 464 getAmode (StPrim IntAddOp [x, StInt i])
 465   | is13Bits i =
 466     getNewRegNCG PtrRep             `thenUs` \ tmp ->
 467     getReg x                        `thenUs` \ register ->
 468     let
 469         code = registerCode register tmp
 470         reg  = registerName register tmp
 471         off  = ImmInt (fromInteger i)
 472     in
 473         returnUs (Amode (AddrRegImm reg off) code)
 474
 475 getAmode (StPrim IntAddOp [x, y]) =
 476     getNewRegNCG PtrRep             `thenUs` \ tmp1 ->
 477     getNewRegNCG IntRep             `thenUs` \ tmp2 ->
 478     getReg x                        `thenUs` \ register1 ->
 479     getReg y                        `thenUs` \ register2 ->
 480     let
 481         code1 = registerCode register1 tmp1 asmVoid
 482         reg1  = registerName register1 tmp1
 483         code2 = registerCode register2 tmp2 asmVoid
 484         reg2  = registerName register2 tmp2
 485         code__2 = asmParThen [code1, code2]
 486     in
 487         returnUs (Amode (AddrRegReg reg1 reg2) code__2)
 488
 489 getAmode leaf
 490   | maybeToBool imm =
 491     getNewRegNCG PtrRep             `thenUs` \ tmp ->
 492     let
 493         code = mkSeqInstr (SETHI (HI imm__2) tmp)
 494     in
 495         returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
 496   where
 497     imm = maybeImm leaf
 498     imm__2 = case imm of Just x -> x
 499
 500 getAmode other =
 501     getNewRegNCG PtrRep             `thenUs` \ tmp ->
 502     getReg other                    `thenUs` \ register ->
 503     let
 504         code = registerCode register tmp
 505         reg  = registerName register tmp
 506         off  = ImmInt 0
 507     in
 508         returnUs (Amode (AddrRegImm reg off) code)
 509
 510 \end{code}
 511
 512 Try to get a value into a specific register (or registers) for a call.  The Sparc
 513 calling convention is an absolute nightmare.  The first 6x32 bits of arguments are
 514 mapped into %o0 through %o5, and the remaining arguments are dumped to the stack,
 515 beginning at [%sp+92].  (Note that %o6 == %sp.)  Our first argument is a pair of
 516 the list of remaining argument registers to be assigned for this call and the next
 517 stack offset to use for overflowing arguments.  This way, @getCallArg@ can be applied
 518 to all of a call's arguments using @mapAccumL@.
 519
 520 \begin{code}
 521
 522 getCallArg
 523     :: ([Reg],Int)          -- Argument registers and stack offset (accumulator)
 524     -> StixTree             -- Current argument
 525     -> UniqSM (([Reg],Int), CodeBlock SparcInstr)    -- Updated accumulator and code
 526
 527 -- We have to use up all of our argument registers first.
 528
 529 getCallArg (dst:dsts, offset) arg =
 530     getReg arg                      `thenUs` \ register ->
 531     getNewRegNCG (registerKind register)
 532                                     `thenUs` \ tmp ->
 533     let
 534         reg = if isFloatingRep pk then tmp else dst
 535         code = registerCode register reg
 536         src = registerName register reg
 537         pk = registerKind register
 538     in
 539         returnUs (case pk of
 540             DoubleRep ->
 541                 case dsts of
 542                     [] -> (([], offset + 1), code . mkSeqInstrs [
 543                             -- conveniently put the second part in the right stack
 544                             -- location, and load the first part into %o5
 545                             ST DF src (spRel (offset - 1)),
 546                             LD W (spRel (offset - 1)) dst])
 547                     (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
 548                             ST DF src (spRel (-2)),
 549                             LD W (spRel (-2)) dst,
 550                             LD W (spRel (-1)) dst__2])
 551             FloatRep -> ((dsts, offset), code . mkSeqInstrs [
 552                             ST F src (spRel (-2)),
 553                             LD W (spRel (-2)) dst])
 554             _ -> ((dsts, offset), if isFixed register then
 555                                   code . mkSeqInstr (OR False g0 (RIReg src) dst)
 556                                   else code))
 557
 558 -- Once we have run out of argument registers, we move to the stack
 559
 560 getCallArg ([], offset) arg =
 561     getReg arg                      `thenUs` \ register ->
 562     getNewRegNCG (registerKind register)
 563                                     `thenUs` \ tmp ->
 564     let
 565         code = registerCode register tmp
 566         src = registerName register tmp
 567         pk = registerKind register
 568         sz = kindToSize pk
 569         words = if pk == DoubleRep then 2 else 1
 570     in
 571         returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
 572
 573 \end{code}
 574
 575 Set up a condition code for a conditional branch.
 576
 577 \begin{code}
 578
 579 getCondition :: StixTree -> UniqSM Condition
 580
 581 getCondition (StPrim primop args) =
 582     case primop of
 583
 584         CharGtOp -> condIntCode GT args
 585         CharGeOp -> condIntCode GE args
 586         CharEqOp -> condIntCode EQ args
 587         CharNeOp -> condIntCode NE args
 588         CharLtOp -> condIntCode LT args
 589         CharLeOp -> condIntCode LE args
 590
 591         IntGtOp -> condIntCode GT args
 592         IntGeOp -> condIntCode GE args
 593         IntEqOp -> condIntCode EQ args
 594         IntNeOp -> condIntCode NE args
 595         IntLtOp -> condIntCode LT args
 596         IntLeOp -> condIntCode LE args
 597
 598         WordGtOp -> condIntCode GU args
 599         WordGeOp -> condIntCode GEU args
 600         WordEqOp -> condIntCode EQ args
 601         WordNeOp -> condIntCode NE args
 602         WordLtOp -> condIntCode LU args
 603         WordLeOp -> condIntCode LEU args
 604
 605         AddrGtOp -> condIntCode GU args
 606         AddrGeOp -> condIntCode GEU args
 607         AddrEqOp -> condIntCode EQ args
 608         AddrNeOp -> condIntCode NE args
 609         AddrLtOp -> condIntCode LU args
 610         AddrLeOp -> condIntCode LEU args
 611
 612         FloatGtOp -> condFltCode GT args
 613         FloatGeOp -> condFltCode GE args
 614         FloatEqOp -> condFltCode EQ args
 615         FloatNeOp -> condFltCode NE args
 616         FloatLtOp -> condFltCode LT args
 617         FloatLeOp -> condFltCode LE args
 618
 619         DoubleGtOp -> condFltCode GT args
 620         DoubleGeOp -> condFltCode GE args
 621         DoubleEqOp -> condFltCode EQ args
 622         DoubleNeOp -> condFltCode NE args
 623         DoubleLtOp -> condFltCode LT args
 624         DoubleLeOp -> condFltCode LE args
 625
 626 \end{code}
 627
 628 Turn a boolean expression into a condition, to be passed
 629 back up the tree.
 630
 631 \begin{code}
 632
 633 condIntCode, condFltCode :: Cond -> [StixTree] -> UniqSM Condition
 634
 635 condIntCode cond [x, StInt y]
 636   | is13Bits y =
 637     getReg x                        `thenUs` \ register ->
 638     getNewRegNCG IntRep             `thenUs` \ tmp ->
 639     let
 640         code = registerCode register tmp
 641         src1 = registerName register tmp
 642         src2 = ImmInt (fromInteger y)
 643         code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
 644     in
 645         returnUs (Condition False cond code__2)
 646
 647 condIntCode cond [x, y] =
 648     getReg x                        `thenUs` \ register1 ->
 649     getReg y                        `thenUs` \ register2 ->
 650     getNewRegNCG IntRep             `thenUs` \ tmp1 ->
 651     getNewRegNCG IntRep             `thenUs` \ tmp2 ->
 652     let
 653         code1 = registerCode register1 tmp1 asmVoid
 654         src1  = registerName register1 tmp1
 655         code2 = registerCode register2 tmp2 asmVoid
 656         src2  = registerName register2 tmp2
 657         code__2 = asmParThen [code1, code2] .
 658                 mkSeqInstr (SUB False True src1 (RIReg src2) g0)
 659     in
 660         returnUs (Condition False cond code__2)
 661
 662 condFltCode cond [x, y] =
 663     getReg x                        `thenUs` \ register1 ->
 664     getReg y                        `thenUs` \ register2 ->
 665     getNewRegNCG (registerKind register1)
 666                                     `thenUs` \ tmp1 ->
 667     getNewRegNCG (registerKind register2)
 668                                     `thenUs` \ tmp2 ->
 669     getNewRegNCG DoubleRep          `thenUs` \ tmp ->
 670     let
 671         promote x = asmInstr (FxTOy F DF x tmp)
 672
 673         pk1   = registerKind register1
 674         code1 = registerCode register1 tmp1
 675         src1  = registerName register1 tmp1
 676
 677         pk2   = registerKind register2
 678         code2 = registerCode register2 tmp2
 679         src2  = registerName register2 tmp2
 680
 681         code__2 =
 682                 if pk1 == pk2 then
 683                     asmParThen [code1 asmVoid, code2 asmVoid] .
 684                     mkSeqInstr (FCMP True (kindToSize pk1) src1 src2)
 685                 else if pk1 == FloatRep then
 686                     asmParThen [code1 (promote src1), code2 asmVoid] .
 687                     mkSeqInstr (FCMP True DF tmp src2)
 688                 else
 689                     asmParThen [code1 asmVoid, code2 (promote src2)] .
 690                     mkSeqInstr (FCMP True DF src1 tmp)
 691     in
 692         returnUs (Condition True cond code__2)
 693
 694 \end{code}
 695
 696 Turn those condition codes into integers now (when they appear on
 697 the right hand side of an assignment).
 698
 699 Do not fill the delay slots here; you will confuse the register allocator.
 700
 701 \begin{code}
 702
 703 condIntReg :: Cond -> [StixTree] -> UniqSM Register
 704
 705 condIntReg EQ [x, StInt 0] =
 706     getReg x                        `thenUs` \ register ->
 707     getNewRegNCG IntRep             `thenUs` \ tmp ->
 708     let
 709         code = registerCode register tmp
 710         src  = registerName register tmp
 711         code__2 dst = code . mkSeqInstrs [
 712             SUB False True g0 (RIReg src) g0,
 713             SUB True False g0 (RIImm (ImmInt (-1))) dst]
 714     in
 715         returnUs (Any IntRep code__2)
 716
 717 condIntReg EQ [x, y] =
 718     getReg x                `thenUs` \ register1 ->
 719     getReg y                `thenUs` \ register2 ->
 720     getNewRegNCG IntRep        `thenUs` \ tmp1 ->
 721     getNewRegNCG IntRep        `thenUs` \ tmp2 ->
 722     let
 723         code1 = registerCode register1 tmp1 asmVoid
 724         src1  = registerName register1 tmp1
 725         code2 = registerCode register2 tmp2 asmVoid
 726         src2  = registerName register2 tmp2
 727         code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
 728             XOR False src1 (RIReg src2) dst,
 729             SUB False True g0 (RIReg dst) g0,
 730             SUB True False g0 (RIImm (ImmInt (-1))) dst]
 731     in
 732         returnUs (Any IntRep code__2)
 733
 734 condIntReg NE [x, StInt 0] =
 735     getReg x                        `thenUs` \ register ->
 736     getNewRegNCG IntRep             `thenUs` \ tmp ->
 737     let
 738         code = registerCode register tmp
 739         src  = registerName register tmp
 740         code__2 dst = code . mkSeqInstrs [
 741             SUB False True g0 (RIReg src) g0,
 742             ADD True False g0 (RIImm (ImmInt 0)) dst]
 743     in
 744         returnUs (Any IntRep code__2)
 745
 746 condIntReg NE [x, y] =
 747     getReg x                `thenUs` \ register1 ->
 748     getReg y                `thenUs` \ register2 ->
 749     getNewRegNCG IntRep        `thenUs` \ tmp1 ->
 750     getNewRegNCG IntRep        `thenUs` \ tmp2 ->
 751     let
 752         code1 = registerCode register1 tmp1 asmVoid
 753         src1  = registerName register1 tmp1
 754         code2 = registerCode register2 tmp2 asmVoid
 755         src2  = registerName register2 tmp2
 756         code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
 757             XOR False src1 (RIReg src2) dst,
 758             SUB False True g0 (RIReg dst) g0,
 759             ADD True False g0 (RIImm (ImmInt 0)) dst]
 760     in
 761         returnUs (Any IntRep code__2)
 762
 763 condIntReg cond args =
 764     getUniqLabelNCG                 `thenUs` \ lbl1 ->
 765     getUniqLabelNCG                 `thenUs` \ lbl2 ->
 766     condIntCode cond args           `thenUs` \ condition ->
 767     let
 768         code = condCode condition
 769         cond = condName condition
 770         code__2 dst = code . mkSeqInstrs [
 771             BI cond False (ImmCLbl lbl1), NOP,
 772             OR False g0 (RIImm (ImmInt 0)) dst,
 773             BI ALWAYS False (ImmCLbl lbl2), NOP,
 774             LABEL lbl1,
 775             OR False g0 (RIImm (ImmInt 1)) dst,
 776             LABEL lbl2]
 777     in
 778         returnUs (Any IntRep code__2)
 779
 780 condFltReg :: Cond -> [StixTree] -> UniqSM Register
 781
 782 condFltReg cond args =
 783     getUniqLabelNCG                 `thenUs` \ lbl1 ->
 784     getUniqLabelNCG                 `thenUs` \ lbl2 ->
 785     condFltCode cond args           `thenUs` \ condition ->
 786     let
 787         code = condCode condition
 788         cond = condName condition
 789         code__2 dst = code . mkSeqInstrs [
 790             NOP,
 791             BF cond False (ImmCLbl lbl1), NOP,
 792             OR False g0 (RIImm (ImmInt 0)) dst,
 793             BI ALWAYS False (ImmCLbl lbl2), NOP,
 794             LABEL lbl1,
 795             OR False g0 (RIImm (ImmInt 1)) dst,
 796             LABEL lbl2]
 797     in
 798         returnUs (Any IntRep code__2)
 799
 800 \end{code}
 801
 802 Assignments are really at the heart of the whole code generation business.
 803 Almost all top-level nodes of any real importance are assignments, which
 804 correspond to loads, stores, or register transfers.  If we're really lucky,
 805 some of the register transfers will go away, because we can use the destination
 806 register to complete the code generation for the right hand side.  This only
 807 fails when the right hand side is forced into a fixed register (e.g. the result
 808 of a call).
 809
 810 \begin{code}
 811
 812 assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock SparcInstr)
 813
 814 assignIntCode pk (StInd _ dst) src =
 815     getNewRegNCG IntRep             `thenUs` \ tmp ->
 816     getAmode dst                    `thenUs` \ amode ->
 817     getReg src                      `thenUs` \ register ->
 818     let
 819         code1 = amodeCode amode asmVoid
 820         dst__2  = amodeAddr amode
 821         code2 = registerCode register tmp asmVoid
 822         src__2  = registerName register tmp
 823         sz    = kindToSize pk
 824         code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
 825     in
 826         returnUs code__2
 827
 828 assignIntCode pk dst src =
 829     getReg dst                      `thenUs` \ register1 ->
 830     getReg src                      `thenUs` \ register2 ->
 831     let
 832         dst__2 = registerName register1 g0
 833         code = registerCode register2 dst__2
 834         src__2 = registerName register2 dst__2
 835         code__2 = if isFixed register2 then
 836                     code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
 837                 else code
 838     in
 839         returnUs code__2
 840
 841 assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock SparcInstr)
 842
 843 assignFltCode pk (StInd _ dst) src =
 844     getNewRegNCG pk                 `thenUs` \ tmp ->
 845     getAmode dst                    `thenUs` \ amode ->
 846     getReg src                      `thenUs` \ register ->
 847     let
 848         sz    = kindToSize pk
 849         dst__2  = amodeAddr amode
 850
 851         code1 = amodeCode amode asmVoid
 852         code2 = registerCode register tmp asmVoid
 853
 854         src__2  = registerName register tmp
 855         pk__2  = registerKind register
 856         sz__2 = kindToSize pk__2
 857
 858         code__2 = asmParThen [code1, code2] .
 859             if pk == pk__2 then
 860                 mkSeqInstr (ST sz src__2 dst__2)
 861             else
 862                 mkSeqInstrs [FxTOy sz__2 sz src__2 tmp, ST sz tmp dst__2]
 863     in
 864         returnUs code__2
 865
 866 assignFltCode pk dst src =
 867     getReg dst                      `thenUs` \ register1 ->
 868     getReg src                      `thenUs` \ register2 ->
 869     getNewRegNCG (registerKind register2)
 870                                     `thenUs` \ tmp ->
 871     let
 872         sz = kindToSize pk
 873         dst__2 = registerName register1 g0    -- must be Fixed
 874
 875         reg__2 = if pk /= pk__2 then tmp else dst__2
 876
 877         code = registerCode register2 reg__2
 878         src__2 = registerName register2 reg__2
 879         pk__2  = registerKind register2
 880         sz__2 = kindToSize pk__2
 881
 882         code__2 = if pk /= pk__2 then code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
 883                 else if isFixed register2 then code . mkSeqInstr (FMOV sz src__2 dst__2)
 884                 else code
 885     in
 886         returnUs code__2
 887
 888 \end{code}
 889
 890 Generating an unconditional branch.  We accept two types of targets:
 891 an immediate CLabel or a tree that gets evaluated into a register.
 892 Any CLabels which are AsmTemporaries are assumed to be in the local
 893 block of code, close enough for a branch instruction.  Other CLabels
 894 are assumed to be far away, so we use call.
 895
 896 Do not fill the delay slots here; you will confuse the register allocator.
 897
 898 \begin{code}
 899
 900 genJump
 901     :: StixTree     -- the branch target
 902     -> UniqSM (CodeBlock SparcInstr)
 903
 904 genJump (StCLbl lbl)
 905   | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
 906   | otherwise     = returnInstrs [CALL target 0 True, NOP]
 907   where
 908     target = ImmCLbl lbl
 909
 910 genJump tree =
 911     getReg tree                     `thenUs` \ register ->
 912     getNewRegNCG PtrRep             `thenUs` \ tmp ->
 913     let
 914         code = registerCode register tmp
 915         target = registerName register tmp
 916     in
 917         returnSeq code [JMP (AddrRegReg target g0), NOP]
 918
 919 \end{code}
 920
 921 Conditional jumps are always to local labels, so we can use
 922 branch instructions.  First, we have to ensure that the condition
 923 codes are set according to the supplied comparison operation.
 924 We generate slightly different code for floating point comparisons,
 925 because a floating point operation cannot directly precede a @BF@.
 926 We assume the worst and fill that slot with a @NOP@.
 927
 928 Do not fill the delay slots here; you will confuse the register allocator.
 929
 930 \begin{code}
 931
 932 genCondJump
 933     :: CLabel       -- the branch target
 934     -> StixTree     -- the condition on which to branch
 935     -> UniqSM (CodeBlock SparcInstr)
 936
 937 genCondJump lbl bool =
 938     getCondition bool               `thenUs` \ condition ->
 939     let
 940         code = condCode condition
 941         cond = condName condition
 942         target = ImmCLbl lbl
 943     in
 944         if condFloat condition then
 945             returnSeq code [NOP, BF cond False target, NOP]
 946         else
 947             returnSeq code [BI cond False target, NOP]
 948
 949 \end{code}
 950
 951 Now the biggest nightmare---calls.  Most of the nastiness is buried in
 952 getCallArg, which moves the arguments to the correct registers/stack
 953 locations.  Apart from that, the code is easy.
 954
 955 Do not fill the delay slots here; you will confuse the register allocator.
 956
 957 \begin{code}
 958
 959 genCCall
 960     :: FAST_STRING  -- function to call
 961     -> PrimRep      -- type of the result
 962     -> [StixTree]   -- arguments (of mixed type)
 963     -> UniqSM (CodeBlock SparcInstr)
 964
 965 genCCall fn kind args =
 966     mapAccumLNCG getCallArg (argRegs,stackArgLoc) args
 967                                     `thenUs` \ ((unused,_), argCode) ->
 968     let
 969         nRegs = length argRegs - length unused
 970         call = CALL fn__2 nRegs False
 971         code = asmParThen (map ($ asmVoid) argCode)
 972     in
 973         returnSeq code [call, NOP]
 974   where
 975     -- function names that begin with '.' are assumed to be special internally
 976     -- generated names like '.mul,' which don't get an underscore prefix
 977     fn__2 = case (_HEAD_ fn) of
 978               '.' -> ImmLit (uppPStr fn)
 979               _   -> ImmLab (uppPStr fn)
 980
 981     mapAccumLNCG f b []     = returnUs (b, [])
 982     mapAccumLNCG f b (x:xs) =
 983         f b x                               `thenUs` \ (b__2, x__2) ->
 984         mapAccumLNCG f b__2 xs              `thenUs` \ (b__3, xs__2) ->
 985         returnUs (b__3, x__2:xs__2)
 986
 987 \end{code}
 988
 989 Trivial (dyadic) instructions.  Only look for constants on the right hand
 990 side, because that's where the generic optimizer will have put them.
 991
 992 \begin{code}
 993
 994 trivialCode
 995     :: (Reg -> RI -> Reg -> SparcInstr)
 996     -> [StixTree]
 997     -> UniqSM Register
 998
 999 trivialCode instr [x, StInt y]
1000   | is13Bits y =
1001     getReg x                        `thenUs` \ register ->
1002     getNewRegNCG IntRep             `thenUs` \ tmp ->
1003     let
1004         code = registerCode register tmp
1005         src1 = registerName register tmp
1006         src2 = ImmInt (fromInteger y)
1007         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
1008     in
1009         returnUs (Any IntRep code__2)
1010
1011 trivialCode instr [x, y] =
1012     getReg x                        `thenUs` \ register1 ->
1013     getReg y                        `thenUs` \ register2 ->
1014     getNewRegNCG IntRep             `thenUs` \ tmp1 ->
1015     getNewRegNCG IntRep             `thenUs` \ tmp2 ->
1016     let
1017         code1 = registerCode register1 tmp1 asmVoid
1018         src1  = registerName register1 tmp1
1019         code2 = registerCode register2 tmp2 asmVoid
1020         src2  = registerName register2 tmp2
1021         code__2 dst = asmParThen [code1, code2] .
1022                      mkSeqInstr (instr src1 (RIReg src2) dst)
1023     in
1024         returnUs (Any IntRep code__2)
1025
1026 trivialFCode
1027     :: PrimRep
1028     -> (Size -> Reg -> Reg -> Reg -> SparcInstr)
1029     -> [StixTree]
1030     -> UniqSM Register
1031
1032 trivialFCode pk instr [x, y] =
1033     getReg x                        `thenUs` \ register1 ->
1034     getReg y                        `thenUs` \ register2 ->
1035     getNewRegNCG (registerKind register1)
1036                                     `thenUs` \ tmp1 ->
1037     getNewRegNCG (registerKind register2)
1038                                     `thenUs` \ tmp2 ->
1039     getNewRegNCG DoubleRep          `thenUs` \ tmp ->
1040     let
1041         promote x = asmInstr (FxTOy F DF x tmp)
1042
1043         pk1   = registerKind register1
1044         code1 = registerCode register1 tmp1
1045         src1  = registerName register1 tmp1
1046
1047         pk2   = registerKind register2
1048         code2 = registerCode register2 tmp2
1049         src2  = registerName register2 tmp2
1050
1051         code__2 dst =
1052                 if pk1 == pk2 then
1053                     asmParThen [code1 asmVoid, code2 asmVoid] .
1054                     mkSeqInstr (instr (kindToSize pk) src1 src2 dst)
1055                 else if pk1 == FloatRep then
1056                     asmParThen [code1 (promote src1), code2 asmVoid] .
1057                     mkSeqInstr (instr DF tmp src2 dst)
1058                 else
1059                     asmParThen [code1 asmVoid, code2 (promote src2)] .
1060                     mkSeqInstr (instr DF src1 tmp dst)
1061     in
1062         returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
1063
1064 \end{code}
1065
1066 Trivial unary instructions.  Note that we don't have to worry about
1067 matching an StInt as the argument, because genericOpt will already
1068 have handled the constant-folding.
1069
1070 \begin{code}
1071
1072 trivialUCode
1073     :: (RI -> Reg -> SparcInstr)
1074     -> [StixTree]
1075     -> UniqSM Register
1076
1077 trivialUCode instr [x] =
1078     getReg x                        `thenUs` \ register ->
1079     getNewRegNCG IntRep             `thenUs` \ tmp ->
1080     let
1081         code = registerCode register tmp
1082         src  = registerName register tmp
1083         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
1084     in
1085         returnUs (Any IntRep code__2)
1086
1087 trivialUFCode
1088     :: PrimRep
1089     -> (Reg -> Reg -> SparcInstr)
1090     -> [StixTree]
1091     -> UniqSM Register
1092
1093 trivialUFCode pk instr [x] =
1094     getReg x                        `thenUs` \ register ->
1095     getNewRegNCG pk                 `thenUs` \ tmp ->
1096     let
1097         code = registerCode register tmp
1098         src  = registerName register tmp
1099         code__2 dst = code . mkSeqInstr (instr src dst)
1100     in
1101         returnUs (Any pk code__2)
1102
1103 \end{code}
1104
1105 Absolute value on integers, mostly for gmp size check macros.  Again,
1106 the argument cannot be an StInt, because genericOpt already folded
1107 constants.
1108
1109 Do not fill the delay slots here; you will confuse the register allocator.
1110
1111 \begin{code}
1112
1113 absIntCode :: [StixTree] -> UniqSM Register
1114 absIntCode [x] =
1115     getReg x                        `thenUs` \ register ->
1116     getNewRegNCG IntRep             `thenUs` \ reg ->
1117     getUniqLabelNCG                 `thenUs` \ lbl ->
1118     let
1119         code = registerCode register reg
1120         src  = registerName register reg
1121         code__2 dst = code . mkSeqInstrs [
1122             SUB False True g0 (RIReg src) dst,
1123             BI GE False (ImmCLbl lbl), NOP,
1124             OR False g0 (RIReg src) dst,
1125             LABEL lbl]
1126     in
1127         returnUs (Any IntRep code__2)
1128
1129 \end{code}
1130
1131 Simple integer coercions that don't require any code to be generated.
1132 Here we just change the type on the register passed on up
1133
1134 \begin{code}
1135
1136 coerceIntCode :: PrimRep -> [StixTree] -> UniqSM Register
1137 coerceIntCode pk [x] =
1138     getReg x                        `thenUs` \ register ->
1139     case register of
1140         Fixed reg _ code -> returnUs (Fixed reg pk code)
1141         Any _ code       -> returnUs (Any pk code)
1142
1143 \end{code}
1144
1145 Integer to character conversion.  We try to do this in one step if
1146 the original object is in memory.
1147
1148 \begin{code}
1149
1150 chrCode :: [StixTree] -> UniqSM Register
1151 chrCode [StInd pk mem] =
1152     getAmode mem                    `thenUs` \ amode ->
1153     let
1154         code = amodeCode amode
1155         src  = amodeAddr amode
1156         srcOff = offset src 3
1157         src__2 = case srcOff of Just x -> x
1158         code__2 dst = if maybeToBool srcOff then
1159                         code . mkSeqInstr (LD UB src__2 dst)
1160                     else
1161                         code . mkSeqInstrs [
1162                             LD (kindToSize pk) src dst,
1163                             AND False dst (RIImm (ImmInt 255)) dst]
1164     in
1165         returnUs (Any pk code__2)
1166
1167 chrCode [x] =
1168     getReg x                        `thenUs` \ register ->
1169     getNewRegNCG IntRep             `thenUs` \ reg ->
1170     let
1171         code = registerCode register reg
1172         src  = registerName register reg
1173         code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
1174     in
1175         returnUs (Any IntRep code__2)
1176
1177 \end{code}
1178
1179 More complicated integer/float conversions.  Here we have to store
1180 temporaries in memory to move between the integer and the floating
1181 point register sets.
1182
1183 \begin{code}
1184
1185 coerceInt2FP :: PrimRep -> [StixTree] -> UniqSM Register
1186 coerceInt2FP pk [x] =
1187     getReg x                        `thenUs` \ register ->
1188     getNewRegNCG IntRep             `thenUs` \ reg ->
1189     let
1190         code = registerCode register reg
1191         src  = registerName register reg
1192
1193         code__2 dst = code . mkSeqInstrs [
1194             ST W src (spRel (-2)),
1195             LD W (spRel (-2)) dst,
1196             FxTOy W (kindToSize pk) dst dst]
1197     in
1198         returnUs (Any pk code__2)
1199
1200 coerceFP2Int :: [StixTree] -> UniqSM Register
1201 coerceFP2Int [x] =
1202     getReg x                        `thenUs` \ register ->
1203     getNewRegNCG IntRep             `thenUs` \ reg ->
1204     getNewRegNCG FloatRep           `thenUs` \ tmp ->
1205     let
1206         code = registerCode register reg
1207         src  = registerName register reg
1208         pk   = registerKind register
1209
1210         code__2 dst = code . mkSeqInstrs [
1211             FxTOy (kindToSize pk) W src tmp,
1212             ST W tmp (spRel (-2)),
1213             LD W (spRel (-2)) dst]
1214     in
1215         returnUs (Any IntRep code__2)
1216
1217 \end{code}
1218
1219 Some random little helpers.
1220
1221 \begin{code}
1222
1223 maybeImm :: StixTree -> Maybe Imm
1224 maybeImm (StInt i)
1225   | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
1226   | otherwise = Just (ImmInteger i)
1227 maybeImm (StLitLbl s)  = Just (ImmLab s)
1228 maybeImm (StLitLit s)  = Just (strImmLit (cvtLitLit (_UNPK_ s)))
1229 maybeImm (StCLbl l) = Just (ImmCLbl l)
1230 maybeImm _          = Nothing
1231
1232 mangleIndexTree :: StixTree -> StixTree
1233
1234 mangleIndexTree (StIndex pk base (StInt i)) =
1235     StPrim IntAddOp [base, off]
1236   where
1237     off = StInt (i * size pk)
1238     size :: PrimRep -> Integer
1239     size pk = case kindToSize pk of
1240         {SB -> 1; UB -> 1; HW -> 2; UHW -> 2; W -> 4; D -> 8; F -> 4; DF -> 8}
1241
1242 mangleIndexTree (StIndex pk base off) =
1243     case pk of
1244         CharRep -> StPrim IntAddOp [base, off]
1245         _        -> StPrim IntAddOp [base, off__2]
1246   where
1247     off__2 = StPrim SllOp [off, StInt (shift pk)]
1248     shift :: PrimRep -> Integer
1249     shift DoubleRep     = 3
1250     shift _             = 2
1251
1252 cvtLitLit :: String -> String
1253 cvtLitLit "stdin" = "__iob+0x0"   -- This one is probably okay...
1254 cvtLitLit "stdout" = "__iob+0x14" -- but these next two are dodgy at best
1255 cvtLitLit "stderr" = "__iob+0x28"
1256 cvtLitLit s
1257   | isHex s = s
1258   | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
1259   where
1260     isHex ('0':'x':xs) = all isHexDigit xs
1261     isHex _ = False
1262     -- Now, where have I seen this before?
1263     isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'
1264
1265
1266 \end{code}
1267
1268 spRel gives us a stack relative addressing mode for volatile temporaries
1269 and for excess call arguments.
1270
1271 \begin{code}
1272
1273 spRel
1274     :: Int      -- desired stack offset in words, positive or negative
1275     -> Addr
1276 spRel n = AddrRegImm sp (ImmInt (n * 4))
1277
1278 stackArgLoc = 23 :: Int     -- where to stack extra call arguments (beyond 6x32 bits)
1279
1280 \end{code}
1281
1282 \begin{code}
1283
1284 getNewRegNCG :: PrimRep -> UniqSM Reg
1285 getNewRegNCG pk =
1286       getUnique          `thenUs` \ u ->
1287       returnUs (mkReg u pk)
1288
1289 \end{code}