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