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         IntRemOp -> call SLIT(".rem") IntKind
 312         IntNegOp -> trivialUCode (SUB False False g0) args
 313         IntAbsOp -> absIntCode args
 314
 315         AndOp -> trivialCode (AND False) args
 316         OrOp  -> trivialCode (OR False) args
 317         NotOp -> trivialUCode (XNOR False g0) args
 318         SllOp -> trivialCode SLL args
 319         SraOp -> trivialCode SRA args
 320         SrlOp -> trivialCode SRL args
 321         ISllOp -> panic "SparcGen:isll"
 322         ISraOp -> panic "SparcGen:isra"
 323         ISrlOp -> panic "SparcGen:isrl"
 324
 325         IntGtOp -> condIntReg GT args
 326         IntGeOp -> condIntReg GE args
 327         IntEqOp -> condIntReg EQ args
 328         IntNeOp -> condIntReg NE args
 329         IntLtOp -> condIntReg LT args
 330         IntLeOp -> condIntReg LE args
 331
 332         WordGtOp -> condIntReg GU args
 333         WordGeOp -> condIntReg GEU args
 334         WordEqOp -> condIntReg EQ args
 335         WordNeOp -> condIntReg NE args
 336         WordLtOp -> condIntReg LU args
 337         WordLeOp -> condIntReg LEU args
 338
 339         AddrGtOp -> condIntReg GU args
 340         AddrGeOp -> condIntReg GEU args
 341         AddrEqOp -> condIntReg EQ args
 342         AddrNeOp -> condIntReg NE args
 343         AddrLtOp -> condIntReg LU args
 344         AddrLeOp -> condIntReg LEU args
 345
 346         FloatAddOp -> trivialFCode FloatKind FADD args
 347         FloatSubOp -> trivialFCode FloatKind FSUB args
 348         FloatMulOp -> trivialFCode FloatKind FMUL args
 349         FloatDivOp -> trivialFCode FloatKind FDIV args
 350         FloatNegOp -> trivialUFCode FloatKind (FNEG F) args
 351
 352         FloatGtOp -> condFltReg GT args
 353         FloatGeOp -> condFltReg GE args
 354         FloatEqOp -> condFltReg EQ args
 355         FloatNeOp -> condFltReg NE args
 356         FloatLtOp -> condFltReg LT args
 357         FloatLeOp -> condFltReg LE args
 358
 359         FloatExpOp -> promoteAndCall SLIT("exp") DoubleKind
 360         FloatLogOp -> promoteAndCall SLIT("log") DoubleKind
 361         FloatSqrtOp -> promoteAndCall SLIT("sqrt") DoubleKind
 362
 363         FloatSinOp -> promoteAndCall SLIT("sin") DoubleKind
 364         FloatCosOp -> promoteAndCall SLIT("cos") DoubleKind
 365         FloatTanOp -> promoteAndCall SLIT("tan") DoubleKind
 366
 367         FloatAsinOp -> promoteAndCall SLIT("asin") DoubleKind
 368         FloatAcosOp -> promoteAndCall SLIT("acos") DoubleKind
 369         FloatAtanOp -> promoteAndCall SLIT("atan") DoubleKind
 370
 371         FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleKind
 372         FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleKind
 373         FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleKind
 374
 375         FloatPowerOp -> promoteAndCall SLIT("pow") DoubleKind
 376
 377         DoubleAddOp -> trivialFCode DoubleKind FADD args
 378         DoubleSubOp -> trivialFCode DoubleKind FSUB args
 379         DoubleMulOp -> trivialFCode DoubleKind FMUL args
 380         DoubleDivOp -> trivialFCode DoubleKind FDIV args
 381         DoubleNegOp -> trivialUFCode DoubleKind (FNEG DF) args
 382
 383         DoubleGtOp -> condFltReg GT args
 384         DoubleGeOp -> condFltReg GE args
 385         DoubleEqOp -> condFltReg EQ args
 386         DoubleNeOp -> condFltReg NE args
 387         DoubleLtOp -> condFltReg LT args
 388         DoubleLeOp -> condFltReg LE args
 389
 390         DoubleExpOp -> call SLIT("exp") DoubleKind
 391         DoubleLogOp -> call SLIT("log") DoubleKind
 392         DoubleSqrtOp -> call SLIT("sqrt") DoubleKind
 393
 394         DoubleSinOp -> call SLIT("sin") DoubleKind
 395         DoubleCosOp -> call SLIT("cos") DoubleKind
 396         DoubleTanOp -> call SLIT("tan") DoubleKind
 397
 398         DoubleAsinOp -> call SLIT("asin") DoubleKind
 399         DoubleAcosOp -> call SLIT("acos") DoubleKind
 400         DoubleAtanOp -> call SLIT("atan") DoubleKind
 401
 402         DoubleSinhOp -> call SLIT("sinh") DoubleKind
 403         DoubleCoshOp -> call SLIT("cosh") DoubleKind
 404         DoubleTanhOp -> call SLIT("tanh") DoubleKind
 405
 406         DoublePowerOp -> call SLIT("pow") DoubleKind
 407
 408         OrdOp -> coerceIntCode IntKind args
 409         ChrOp -> chrCode args
 410
 411         Float2IntOp -> coerceFP2Int args
 412         Int2FloatOp -> coerceInt2FP FloatKind args
 413         Double2IntOp -> coerceFP2Int args
 414         Int2DoubleOp -> coerceInt2FP DoubleKind args
 415
 416         Double2FloatOp -> trivialUFCode FloatKind (FxTOy DF F) args
 417         Float2DoubleOp -> trivialUFCode DoubleKind (FxTOy F DF) args
 418
 419   where
 420     call fn pk = getReg (StCall fn pk args)
 421     promoteAndCall fn pk = getReg (StCall fn pk (map promote args))
 422       where
 423         promote x = StPrim Float2DoubleOp [x]
 424
 425 getReg (StInd pk mem) =
 426     getAmode mem                    `thenSUs` \ amode ->
 427     let
 428         code = amodeCode amode
 429         src   = amodeAddr amode
 430         size = kindToSize pk
 431         code__2 dst = code . mkSeqInstr (LD size src dst)
 432     in
 433         returnSUs (Any pk code__2)
 434
 435 getReg (StInt i)
 436   | is13Bits i =
 437     let
 438         src = ImmInt (fromInteger i)
 439         code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
 440     in
 441         returnSUs (Any IntKind code)
 442
 443 getReg leaf
 444   | maybeToBool imm =
 445     let
 446         code dst = mkSeqInstrs [
 447             SETHI (HI imm__2) dst,
 448             OR False dst (RIImm (LO imm__2)) dst]
 449     in
 450         returnSUs (Any PtrKind code)
 451   where
 452     imm = maybeImm leaf
 453     imm__2 = case imm of Just x -> x
 454
 455 \end{code}
 456
 457 Now, given a tree (the argument to an StInd) that references memory,
 458 produce a suitable addressing mode.
 459
 460 \begin{code}
 461
 462 getAmode :: StixTree -> SUniqSM Amode
 463
 464 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
 465
 466 getAmode (StPrim IntSubOp [x, StInt i])
 467   | is13Bits (-i) =
 468     getNewRegNCG PtrKind            `thenSUs` \ tmp ->
 469     getReg x                        `thenSUs` \ register ->
 470     let
 471         code = registerCode register tmp
 472         reg  = registerName register tmp
 473         off  = ImmInt (-(fromInteger i))
 474     in
 475         returnSUs (Amode (AddrRegImm reg off) code)
 476
 477
 478 getAmode (StPrim IntAddOp [x, StInt i])
 479   | is13Bits i =
 480     getNewRegNCG PtrKind            `thenSUs` \ tmp ->
 481     getReg x                        `thenSUs` \ register ->
 482     let
 483         code = registerCode register tmp
 484         reg  = registerName register tmp
 485         off  = ImmInt (fromInteger i)
 486     in
 487         returnSUs (Amode (AddrRegImm reg off) code)
 488
 489 getAmode (StPrim IntAddOp [x, y]) =
 490     getNewRegNCG PtrKind            `thenSUs` \ tmp1 ->
 491     getNewRegNCG IntKind            `thenSUs` \ tmp2 ->
 492     getReg x                        `thenSUs` \ register1 ->
 493     getReg y                        `thenSUs` \ register2 ->
 494     let
 495         code1 = registerCode register1 tmp1 asmVoid
 496         reg1  = registerName register1 tmp1
 497         code2 = registerCode register2 tmp2 asmVoid
 498         reg2  = registerName register2 tmp2
 499         code__2 = asmParThen [code1, code2]
 500     in
 501         returnSUs (Amode (AddrRegReg reg1 reg2) code__2)
 502
 503 getAmode leaf
 504   | maybeToBool imm =
 505     getNewRegNCG PtrKind            `thenSUs` \ tmp ->
 506     let
 507         code = mkSeqInstr (SETHI (HI imm__2) tmp)
 508     in
 509         returnSUs (Amode (AddrRegImm tmp (LO imm__2)) code)
 510   where
 511     imm = maybeImm leaf
 512     imm__2 = case imm of Just x -> x
 513
 514 getAmode other =
 515     getNewRegNCG PtrKind            `thenSUs` \ tmp ->
 516     getReg other                    `thenSUs` \ register ->
 517     let
 518         code = registerCode register tmp
 519         reg  = registerName register tmp
 520         off  = ImmInt 0
 521     in
 522         returnSUs (Amode (AddrRegImm reg off) code)
 523
 524 \end{code}
 525
 526 Try to get a value into a specific register (or registers) for a call.  The Sparc
 527 calling convention is an absolute nightmare.  The first 6x32 bits of arguments are
 528 mapped into %o0 through %o5, and the remaining arguments are dumped to the stack,
 529 beginning at [%sp+92].  (Note that %o6 == %sp.)  Our first argument is a pair of
 530 the list of remaining argument registers to be assigned for this call and the next
 531 stack offset to use for overflowing arguments.  This way, @getCallArg@ can be applied
 532 to all of a call's arguments using @mapAccumL@.
 533
 534 \begin{code}
 535
 536 getCallArg
 537     :: ([Reg],Int)          -- Argument registers and stack offset (accumulator)
 538     -> StixTree             -- Current argument
 539     -> SUniqSM (([Reg],Int), CodeBlock SparcInstr)    -- Updated accumulator and code
 540
 541 -- We have to use up all of our argument registers first.
 542
 543 getCallArg (dst:dsts, offset) arg =
 544     getReg arg                      `thenSUs` \ register ->
 545     getNewRegNCG (registerKind register)
 546                                     `thenSUs` \ tmp ->
 547     let
 548         reg = if isFloatingKind pk then tmp else dst
 549         code = registerCode register reg
 550         src = registerName register reg
 551         pk = registerKind register
 552     in
 553         returnSUs (case pk of
 554             DoubleKind ->
 555                 case dsts of
 556                     [] -> (([], offset + 1), code . mkSeqInstrs [
 557                             -- conveniently put the second part in the right stack
 558                             -- location, and load the first part into %o5
 559                             ST DF src (spRel (offset - 1)),
 560                             LD W (spRel (offset - 1)) dst])
 561                     (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
 562                             ST DF src (spRel (-2)),
 563                             LD W (spRel (-2)) dst,
 564                             LD W (spRel (-1)) dst__2])
 565             FloatKind -> ((dsts, offset), code . mkSeqInstrs [
 566                             ST F src (spRel (-2)),
 567                             LD W (spRel (-2)) dst])
 568             _ -> ((dsts, offset), if isFixed register then
 569                                   code . mkSeqInstr (OR False g0 (RIReg src) dst)
 570                                   else code))
 571
 572 -- Once we have run out of argument registers, we move to the stack
 573
 574 getCallArg ([], offset) arg =
 575     getReg arg                      `thenSUs` \ register ->
 576     getNewRegNCG (registerKind register)
 577                                     `thenSUs` \ tmp ->
 578     let
 579         code = registerCode register tmp
 580         src = registerName register tmp
 581         pk = registerKind register
 582         sz = kindToSize pk
 583         words = if pk == DoubleKind then 2 else 1
 584     in
 585         returnSUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
 586
 587 \end{code}
 588
 589 Set up a condition code for a conditional branch.
 590
 591 \begin{code}
 592
 593 getCondition :: StixTree -> SUniqSM Condition
 594
 595 getCondition (StPrim primop args) =
 596     case primop of
 597
 598         CharGtOp -> condIntCode GT args
 599         CharGeOp -> condIntCode GE args
 600         CharEqOp -> condIntCode EQ args
 601         CharNeOp -> condIntCode NE args
 602         CharLtOp -> condIntCode LT args
 603         CharLeOp -> condIntCode LE args
 604
 605         IntGtOp -> condIntCode GT args
 606         IntGeOp -> condIntCode GE args
 607         IntEqOp -> condIntCode EQ args
 608         IntNeOp -> condIntCode NE args
 609         IntLtOp -> condIntCode LT args
 610         IntLeOp -> condIntCode LE args
 611
 612         WordGtOp -> condIntCode GU args
 613         WordGeOp -> condIntCode GEU args
 614         WordEqOp -> condIntCode EQ args
 615         WordNeOp -> condIntCode NE args
 616         WordLtOp -> condIntCode LU args
 617         WordLeOp -> condIntCode LEU args
 618
 619         AddrGtOp -> condIntCode GU args
 620         AddrGeOp -> condIntCode GEU args
 621         AddrEqOp -> condIntCode EQ args
 622         AddrNeOp -> condIntCode NE args
 623         AddrLtOp -> condIntCode LU args
 624         AddrLeOp -> condIntCode LEU args
 625
 626         FloatGtOp -> condFltCode GT args
 627         FloatGeOp -> condFltCode GE args
 628         FloatEqOp -> condFltCode EQ args
 629         FloatNeOp -> condFltCode NE args
 630         FloatLtOp -> condFltCode LT args
 631         FloatLeOp -> condFltCode LE args
 632
 633         DoubleGtOp -> condFltCode GT args
 634         DoubleGeOp -> condFltCode GE args
 635         DoubleEqOp -> condFltCode EQ args
 636         DoubleNeOp -> condFltCode NE args
 637         DoubleLtOp -> condFltCode LT args
 638         DoubleLeOp -> condFltCode LE args
 639
 640 \end{code}
 641
 642 Turn a boolean expression into a condition, to be passed
 643 back up the tree.
 644
 645 \begin{code}
 646
 647 condIntCode, condFltCode :: Cond -> [StixTree] -> SUniqSM Condition
 648
 649 condIntCode cond [x, StInt y]
 650   | is13Bits y =
 651     getReg x                        `thenSUs` \ register ->
 652     getNewRegNCG IntKind            `thenSUs` \ tmp ->
 653     let
 654         code = registerCode register tmp
 655         src1 = registerName register tmp
 656         src2 = ImmInt (fromInteger y)
 657         code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
 658     in
 659         returnSUs (Condition False cond code__2)
 660
 661 condIntCode cond [x, y] =
 662     getReg x                        `thenSUs` \ register1 ->
 663     getReg y                        `thenSUs` \ register2 ->
 664     getNewRegNCG IntKind            `thenSUs` \ tmp1 ->
 665     getNewRegNCG IntKind            `thenSUs` \ tmp2 ->
 666     let
 667         code1 = registerCode register1 tmp1 asmVoid
 668         src1  = registerName register1 tmp1
 669         code2 = registerCode register2 tmp2 asmVoid
 670         src2  = registerName register2 tmp2
 671         code__2 = asmParThen [code1, code2] .
 672                 mkSeqInstr (SUB False True src1 (RIReg src2) g0)
 673     in
 674         returnSUs (Condition False cond code__2)
 675
 676 condFltCode cond [x, y] =
 677     getReg x                        `thenSUs` \ register1 ->
 678     getReg y                        `thenSUs` \ register2 ->
 679     getNewRegNCG (registerKind register1)
 680                                     `thenSUs` \ tmp1 ->
 681     getNewRegNCG (registerKind register2)
 682                                     `thenSUs` \ tmp2 ->
 683     getNewRegNCG DoubleKind         `thenSUs` \ tmp ->
 684     let
 685         promote x = asmInstr (FxTOy F DF x tmp)
 686
 687         pk1   = registerKind register1
 688         code1 = registerCode register1 tmp1
 689         src1  = registerName register1 tmp1
 690
 691         pk2   = registerKind register2
 692         code2 = registerCode register2 tmp2
 693         src2  = registerName register2 tmp2
 694
 695         code__2 =
 696                 if pk1 == pk2 then
 697                     asmParThen [code1 asmVoid, code2 asmVoid] .
 698                     mkSeqInstr (FCMP True (kindToSize pk1) src1 src2)
 699                 else if pk1 == FloatKind then
 700                     asmParThen [code1 (promote src1), code2 asmVoid] .
 701                     mkSeqInstr (FCMP True DF tmp src2)
 702                 else
 703                     asmParThen [code1 asmVoid, code2 (promote src2)] .
 704                     mkSeqInstr (FCMP True DF src1 tmp)
 705     in
 706         returnSUs (Condition True cond code__2)
 707
 708 \end{code}
 709
 710 Turn those condition codes into integers now (when they appear on
 711 the right hand side of an assignment).
 712
 713 Do not fill the delay slots here; you will confuse the register allocator.
 714
 715 \begin{code}
 716
 717 condIntReg :: Cond -> [StixTree] -> SUniqSM Register
 718
 719 condIntReg EQ [x, StInt 0] =
 720     getReg x                        `thenSUs` \ register ->
 721     getNewRegNCG IntKind            `thenSUs` \ tmp ->
 722     let
 723         code = registerCode register tmp
 724         src  = registerName register tmp
 725         code__2 dst = code . mkSeqInstrs [
 726             SUB False True g0 (RIReg src) g0,
 727             SUB True False g0 (RIImm (ImmInt (-1))) dst]
 728     in
 729         returnSUs (Any IntKind code__2)
 730
 731 condIntReg EQ [x, y] =
 732     getReg x                `thenSUs` \ register1 ->
 733     getReg y                `thenSUs` \ register2 ->
 734     getNewRegNCG IntKind        `thenSUs` \ tmp1 ->
 735     getNewRegNCG IntKind        `thenSUs` \ tmp2 ->
 736     let
 737         code1 = registerCode register1 tmp1 asmVoid
 738         src1  = registerName register1 tmp1
 739         code2 = registerCode register2 tmp2 asmVoid
 740         src2  = registerName register2 tmp2
 741         code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
 742             XOR False src1 (RIReg src2) dst,
 743             SUB False True g0 (RIReg dst) g0,
 744             SUB True False g0 (RIImm (ImmInt (-1))) dst]
 745     in
 746         returnSUs (Any IntKind code__2)
 747
 748 condIntReg NE [x, StInt 0] =
 749     getReg x                        `thenSUs` \ register ->
 750     getNewRegNCG IntKind            `thenSUs` \ tmp ->
 751     let
 752         code = registerCode register tmp
 753         src  = registerName register tmp
 754         code__2 dst = code . mkSeqInstrs [
 755             SUB False True g0 (RIReg src) g0,
 756             ADD True False g0 (RIImm (ImmInt 0)) dst]
 757     in
 758         returnSUs (Any IntKind code__2)
 759
 760 condIntReg NE [x, y] =
 761     getReg x                `thenSUs` \ register1 ->
 762     getReg y                `thenSUs` \ register2 ->
 763     getNewRegNCG IntKind        `thenSUs` \ tmp1 ->
 764     getNewRegNCG IntKind        `thenSUs` \ tmp2 ->
 765     let
 766         code1 = registerCode register1 tmp1 asmVoid
 767         src1  = registerName register1 tmp1
 768         code2 = registerCode register2 tmp2 asmVoid
 769         src2  = registerName register2 tmp2
 770         code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
 771             XOR False src1 (RIReg src2) dst,
 772             SUB False True g0 (RIReg dst) g0,
 773             ADD True False g0 (RIImm (ImmInt 0)) dst]
 774     in
 775         returnSUs (Any IntKind code__2)
 776
 777 condIntReg cond args =
 778     getUniqLabelNCG                 `thenSUs` \ lbl1 ->
 779     getUniqLabelNCG                 `thenSUs` \ lbl2 ->
 780     condIntCode cond args           `thenSUs` \ condition ->
 781     let
 782         code = condCode condition
 783         cond = condName condition
 784         code__2 dst = code . mkSeqInstrs [
 785             BI cond False (ImmCLbl lbl1), NOP,
 786             OR False g0 (RIImm (ImmInt 0)) dst,
 787             BI ALWAYS False (ImmCLbl lbl2), NOP,
 788             LABEL lbl1,
 789             OR False g0 (RIImm (ImmInt 1)) dst,
 790             LABEL lbl2]
 791     in
 792         returnSUs (Any IntKind code__2)
 793
 794 condFltReg :: Cond -> [StixTree] -> SUniqSM Register
 795
 796 condFltReg cond args =
 797     getUniqLabelNCG                 `thenSUs` \ lbl1 ->
 798     getUniqLabelNCG                 `thenSUs` \ lbl2 ->
 799     condFltCode cond args           `thenSUs` \ condition ->
 800     let
 801         code = condCode condition
 802         cond = condName condition
 803         code__2 dst = code . mkSeqInstrs [
 804             NOP,
 805             BF cond False (ImmCLbl lbl1), NOP,
 806             OR False g0 (RIImm (ImmInt 0)) dst,
 807             BI ALWAYS False (ImmCLbl lbl2), NOP,
 808             LABEL lbl1,
 809             OR False g0 (RIImm (ImmInt 1)) dst,
 810             LABEL lbl2]
 811     in
 812         returnSUs (Any IntKind code__2)
 813
 814 \end{code}
 815
 816 Assignments are really at the heart of the whole code generation business.
 817 Almost all top-level nodes of any real importance are assignments, which
 818 correspond to loads, stores, or register transfers.  If we're really lucky,
 819 some of the register transfers will go away, because we can use the destination
 820 register to complete the code generation for the right hand side.  This only
 821 fails when the right hand side is forced into a fixed register (e.g. the result
 822 of a call).
 823
 824 \begin{code}
 825
 826 assignIntCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock SparcInstr)
 827
 828 assignIntCode pk (StInd _ dst) src =
 829     getNewRegNCG IntKind            `thenSUs` \ tmp ->
 830     getAmode dst                    `thenSUs` \ amode ->
 831     getReg src                      `thenSUs` \ register ->
 832     let
 833         code1 = amodeCode amode asmVoid
 834         dst__2  = amodeAddr amode
 835         code2 = registerCode register tmp asmVoid
 836         src__2  = registerName register tmp
 837         sz    = kindToSize pk
 838         code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
 839     in
 840         returnSUs code__2
 841
 842 assignIntCode pk dst src =
 843     getReg dst                      `thenSUs` \ register1 ->
 844     getReg src                      `thenSUs` \ register2 ->
 845     let
 846         dst__2 = registerName register1 g0
 847         code = registerCode register2 dst__2
 848         src__2 = registerName register2 dst__2
 849         code__2 = if isFixed register2 then
 850                     code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
 851                 else code
 852     in
 853         returnSUs code__2
 854
 855 assignFltCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock SparcInstr)
 856
 857 assignFltCode pk (StInd _ dst) src =
 858     getNewRegNCG pk                 `thenSUs` \ tmp ->
 859     getAmode dst                    `thenSUs` \ amode ->
 860     getReg src                      `thenSUs` \ register ->
 861     let
 862         sz    = kindToSize pk
 863         dst__2  = amodeAddr amode
 864
 865         code1 = amodeCode amode asmVoid
 866         code2 = registerCode register tmp asmVoid
 867
 868         src__2  = registerName register tmp
 869         pk__2  = registerKind register
 870         sz__2 = kindToSize pk__2
 871
 872         code__2 = asmParThen [code1, code2] .
 873             if pk == pk__2 then
 874                 mkSeqInstr (ST sz src__2 dst__2)
 875             else
 876                 mkSeqInstrs [FxTOy sz__2 sz src__2 tmp, ST sz tmp dst__2]
 877     in
 878         returnSUs code__2
 879
 880 assignFltCode pk dst src =
 881     getReg dst                      `thenSUs` \ register1 ->
 882     getReg src                      `thenSUs` \ register2 ->
 883     getNewRegNCG (registerKind register2)
 884                                     `thenSUs` \ tmp ->
 885     let
 886         sz = kindToSize pk
 887         dst__2 = registerName register1 g0    -- must be Fixed
 888
 889         reg__2 = if pk /= pk__2 then tmp else dst__2
 890
 891         code = registerCode register2 reg__2
 892         src__2 = registerName register2 reg__2
 893         pk__2  = registerKind register2
 894         sz__2 = kindToSize pk__2
 895
 896         code__2 = if pk /= pk__2 then code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
 897                 else if isFixed register2 then code . mkSeqInstr (FMOV sz src__2 dst__2)
 898                 else code
 899     in
 900         returnSUs code__2
 901
 902 \end{code}
 903
 904 Generating an unconditional branch.  We accept two types of targets:
 905 an immediate CLabel or a tree that gets evaluated into a register.
 906 Any CLabels which are AsmTemporaries are assumed to be in the local
 907 block of code, close enough for a branch instruction.  Other CLabels
 908 are assumed to be far away, so we use call.
 909
 910 Do not fill the delay slots here; you will confuse the register allocator.
 911
 912 \begin{code}
 913
 914 genJump
 915     :: StixTree     -- the branch target
 916     -> SUniqSM (CodeBlock SparcInstr)
 917
 918 genJump (StCLbl lbl)
 919   | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
 920   | otherwise     = returnInstrs [CALL target 0 True, NOP]
 921   where
 922     target = ImmCLbl lbl
 923
 924 genJump tree =
 925     getReg tree                     `thenSUs` \ register ->
 926     getNewRegNCG PtrKind            `thenSUs` \ tmp ->
 927     let
 928         code = registerCode register tmp
 929         target = registerName register tmp
 930     in
 931         returnSeq code [JMP (AddrRegReg target g0), NOP]
 932
 933 \end{code}
 934
 935 Conditional jumps are always to local labels, so we can use
 936 branch instructions.  First, we have to ensure that the condition
 937 codes are set according to the supplied comparison operation.
 938 We generate slightly different code for floating point comparisons,
 939 because a floating point operation cannot directly precede a @BF@.
 940 We assume the worst and fill that slot with a @NOP@.
 941
 942 Do not fill the delay slots here; you will confuse the register allocator.
 943
 944 \begin{code}
 945
 946 genCondJump
 947     :: CLabel       -- the branch target
 948     -> StixTree     -- the condition on which to branch
 949     -> SUniqSM (CodeBlock SparcInstr)
 950
 951 genCondJump lbl bool =
 952     getCondition bool               `thenSUs` \ condition ->
 953     let
 954         code = condCode condition
 955         cond = condName condition
 956         target = ImmCLbl lbl
 957     in
 958         if condFloat condition then
 959             returnSeq code [NOP, BF cond False target, NOP]
 960         else
 961             returnSeq code [BI cond False target, NOP]
 962
 963 \end{code}
 964
 965 Now the biggest nightmare---calls.  Most of the nastiness is buried in
 966 getCallArg, which moves the arguments to the correct registers/stack
 967 locations.  Apart from that, the code is easy.
 968
 969 Do not fill the delay slots here; you will confuse the register allocator.
 970
 971 \begin{code}
 972
 973 genCCall
 974     :: FAST_STRING  -- function to call
 975     -> PrimKind     -- type of the result
 976     -> [StixTree]   -- arguments (of mixed type)
 977     -> SUniqSM (CodeBlock SparcInstr)
 978
 979 genCCall fn kind args =
 980     mapAccumLNCG getCallArg (argRegs,stackArgLoc) args
 981                                     `thenSUs` \ ((unused,_), argCode) ->
 982     let
 983         nRegs = length argRegs - length unused
 984         call = CALL fn__2 nRegs False
 985         code = asmParThen (map ($ asmVoid) argCode)
 986     in
 987         returnSeq code [call, NOP]
 988   where
 989     -- function names that begin with '.' are assumed to be special internally
 990     -- generated names like '.mul,' which don't get an underscore prefix
 991     fn__2 = case (_HEAD_ fn) of
 992               '.' -> ImmLit (uppPStr fn)
 993               _   -> ImmLab (uppPStr fn)
 994
 995     mapAccumLNCG f b []     = returnSUs (b, [])
 996     mapAccumLNCG f b (x:xs) =
 997         f b x                               `thenSUs` \ (b__2, x__2) ->
 998         mapAccumLNCG f b__2 xs              `thenSUs` \ (b__3, xs__2) ->
 999         returnSUs (b__3, x__2:xs__2)
1000
1001 \end{code}
1002
1003 Trivial (dyadic) instructions.  Only look for constants on the right hand
1004 side, because that's where the generic optimizer will have put them.
1005
1006 \begin{code}
1007
1008 trivialCode
1009     :: (Reg -> RI -> Reg -> SparcInstr)
1010     -> [StixTree]
1011     -> SUniqSM Register
1012
1013 trivialCode instr [x, StInt y]
1014   | is13Bits y =
1015     getReg x                        `thenSUs` \ register ->
1016     getNewRegNCG IntKind            `thenSUs` \ tmp ->
1017     let
1018         code = registerCode register tmp
1019         src1 = registerName register tmp
1020         src2 = ImmInt (fromInteger y)
1021         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
1022     in
1023         returnSUs (Any IntKind code__2)
1024
1025 trivialCode instr [x, y] =
1026     getReg x                        `thenSUs` \ register1 ->
1027     getReg y                        `thenSUs` \ register2 ->
1028     getNewRegNCG IntKind            `thenSUs` \ tmp1 ->
1029     getNewRegNCG IntKind            `thenSUs` \ tmp2 ->
1030     let
1031         code1 = registerCode register1 tmp1 asmVoid
1032         src1  = registerName register1 tmp1
1033         code2 = registerCode register2 tmp2 asmVoid
1034         src2  = registerName register2 tmp2
1035         code__2 dst = asmParThen [code1, code2] .
1036                      mkSeqInstr (instr src1 (RIReg src2) dst)
1037     in
1038         returnSUs (Any IntKind code__2)
1039
1040 trivialFCode
1041     :: PrimKind
1042     -> (Size -> Reg -> Reg -> Reg -> SparcInstr)
1043     -> [StixTree]
1044     -> SUniqSM Register
1045
1046 trivialFCode pk instr [x, y] =
1047     getReg x                        `thenSUs` \ register1 ->
1048     getReg y                        `thenSUs` \ register2 ->
1049     getNewRegNCG (registerKind register1)
1050                                     `thenSUs` \ tmp1 ->
1051     getNewRegNCG (registerKind register2)
1052                                     `thenSUs` \ tmp2 ->
1053     getNewRegNCG DoubleKind         `thenSUs` \ tmp ->
1054     let
1055         promote x = asmInstr (FxTOy F DF x tmp)
1056
1057         pk1   = registerKind register1
1058         code1 = registerCode register1 tmp1
1059         src1  = registerName register1 tmp1
1060
1061         pk2   = registerKind register2
1062         code2 = registerCode register2 tmp2
1063         src2  = registerName register2 tmp2
1064
1065         code__2 dst =
1066                 if pk1 == pk2 then
1067                     asmParThen [code1 asmVoid, code2 asmVoid] .
1068                     mkSeqInstr (instr (kindToSize pk) src1 src2 dst)
1069                 else if pk1 == FloatKind then
1070                     asmParThen [code1 (promote src1), code2 asmVoid] .
1071                     mkSeqInstr (instr DF tmp src2 dst)
1072                 else
1073                     asmParThen [code1 asmVoid, code2 (promote src2)] .
1074                     mkSeqInstr (instr DF src1 tmp dst)
1075     in
1076         returnSUs (Any (if pk1 == pk2 then pk1 else DoubleKind) code__2)
1077
1078 \end{code}
1079
1080 Trivial unary instructions.  Note that we don't have to worry about
1081 matching an StInt as the argument, because genericOpt will already
1082 have handled the constant-folding.
1083
1084 \begin{code}
1085
1086 trivialUCode
1087     :: (RI -> Reg -> SparcInstr)
1088     -> [StixTree]
1089     -> SUniqSM Register
1090
1091 trivialUCode instr [x] =
1092     getReg x                        `thenSUs` \ register ->
1093     getNewRegNCG IntKind            `thenSUs` \ tmp ->
1094     let
1095         code = registerCode register tmp
1096         src  = registerName register tmp
1097         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
1098     in
1099         returnSUs (Any IntKind code__2)
1100
1101 trivialUFCode
1102     :: PrimKind
1103     -> (Reg -> Reg -> SparcInstr)
1104     -> [StixTree]
1105     -> SUniqSM Register
1106
1107 trivialUFCode pk instr [x] =
1108     getReg x                        `thenSUs` \ register ->
1109     getNewRegNCG pk                 `thenSUs` \ tmp ->
1110     let
1111         code = registerCode register tmp
1112         src  = registerName register tmp
1113         code__2 dst = code . mkSeqInstr (instr src dst)
1114     in
1115         returnSUs (Any pk code__2)
1116
1117 \end{code}
1118
1119 Absolute value on integers, mostly for gmp size check macros.  Again,
1120 the argument cannot be an StInt, because genericOpt already folded
1121 constants.
1122
1123 Do not fill the delay slots here; you will confuse the register allocator.
1124
1125 \begin{code}
1126
1127 absIntCode :: [StixTree] -> SUniqSM Register
1128 absIntCode [x] =
1129     getReg x                        `thenSUs` \ register ->
1130     getNewRegNCG IntKind            `thenSUs` \ reg ->
1131     getUniqLabelNCG                 `thenSUs` \ lbl ->
1132     let
1133         code = registerCode register reg
1134         src  = registerName register reg
1135         code__2 dst = code . mkSeqInstrs [
1136             SUB False True g0 (RIReg src) dst,
1137             BI GE False (ImmCLbl lbl), NOP,
1138             OR False g0 (RIReg src) dst,
1139             LABEL lbl]
1140     in
1141         returnSUs (Any IntKind code__2)
1142
1143 \end{code}
1144
1145 Simple integer coercions that don't require any code to be generated.
1146 Here we just change the type on the register passed on up
1147
1148 \begin{code}
1149
1150 coerceIntCode :: PrimKind -> [StixTree] -> SUniqSM Register
1151 coerceIntCode pk [x] =
1152     getReg x                        `thenSUs` \ register ->
1153     case register of
1154         Fixed reg _ code -> returnSUs (Fixed reg pk code)
1155         Any _ code       -> returnSUs (Any pk code)
1156
1157 \end{code}
1158
1159 Integer to character conversion.  We try to do this in one step if
1160 the original object is in memory.
1161
1162 \begin{code}
1163
1164 chrCode :: [StixTree] -> SUniqSM Register
1165 chrCode [StInd pk mem] =
1166     getAmode mem                    `thenSUs` \ amode ->
1167     let
1168         code = amodeCode amode
1169         src  = amodeAddr amode
1170         srcOff = offset src 3
1171         src__2 = case srcOff of Just x -> x
1172         code__2 dst = if maybeToBool srcOff then
1173                         code . mkSeqInstr (LD UB src__2 dst)
1174                     else
1175                         code . mkSeqInstrs [
1176                             LD (kindToSize pk) src dst,
1177                             AND False dst (RIImm (ImmInt 255)) dst]
1178     in
1179         returnSUs (Any pk code__2)
1180
1181 chrCode [x] =
1182     getReg x                        `thenSUs` \ register ->
1183     getNewRegNCG IntKind            `thenSUs` \ reg ->
1184     let
1185         code = registerCode register reg
1186         src  = registerName register reg
1187         code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
1188     in
1189         returnSUs (Any IntKind code__2)
1190
1191 \end{code}
1192
1193 More complicated integer/float conversions.  Here we have to store
1194 temporaries in memory to move between the integer and the floating
1195 point register sets.
1196
1197 \begin{code}
1198
1199 coerceInt2FP :: PrimKind -> [StixTree] -> SUniqSM Register
1200 coerceInt2FP pk [x] =
1201     getReg x                        `thenSUs` \ register ->
1202     getNewRegNCG IntKind            `thenSUs` \ reg ->
1203     let
1204         code = registerCode register reg
1205         src  = registerName register reg
1206
1207         code__2 dst = code . mkSeqInstrs [
1208             ST W src (spRel (-2)),
1209             LD W (spRel (-2)) dst,
1210             FxTOy W (kindToSize pk) dst dst]
1211     in
1212         returnSUs (Any pk code__2)
1213
1214 coerceFP2Int :: [StixTree] -> SUniqSM Register
1215 coerceFP2Int [x] =
1216     getReg x                        `thenSUs` \ register ->
1217     getNewRegNCG IntKind            `thenSUs` \ reg ->
1218     getNewRegNCG FloatKind          `thenSUs` \ tmp ->
1219     let
1220         code = registerCode register reg
1221         src  = registerName register reg
1222         pk   = registerKind register
1223
1224         code__2 dst = code . mkSeqInstrs [
1225             FxTOy (kindToSize pk) W src tmp,
1226             ST W tmp (spRel (-2)),
1227             LD W (spRel (-2)) dst]
1228     in
1229         returnSUs (Any IntKind code__2)
1230
1231 \end{code}
1232
1233 Some random little helpers.
1234
1235 \begin{code}
1236
1237 maybeImm :: StixTree -> Maybe Imm
1238 maybeImm (StInt i)
1239   | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
1240   | otherwise = Just (ImmInteger i)
1241 maybeImm (StLitLbl s)  = Just (ImmLab s)
1242 maybeImm (StLitLit s)  = Just (strImmLit (cvtLitLit (_UNPK_ s)))
1243 maybeImm (StCLbl l) = Just (ImmCLbl l)
1244 maybeImm _          = Nothing
1245
1246 mangleIndexTree :: StixTree -> StixTree
1247
1248 mangleIndexTree (StIndex pk base (StInt i)) =
1249     StPrim IntAddOp [base, off]
1250   where
1251     off = StInt (i * size pk)
1252     size :: PrimKind -> Integer
1253     size pk = case kindToSize pk of
1254         {SB -> 1; UB -> 1; HW -> 2; UHW -> 2; W -> 4; D -> 8; F -> 4; DF -> 8}
1255
1256 mangleIndexTree (StIndex pk base off) =
1257     case pk of
1258         CharKind -> StPrim IntAddOp [base, off]
1259         _        -> StPrim IntAddOp [base, off__2]
1260   where
1261     off__2 = StPrim SllOp [off, StInt (shift pk)]
1262     shift :: PrimKind -> Integer
1263     shift DoubleKind    = 3
1264     shift _             = 2
1265
1266 cvtLitLit :: String -> String
1267 cvtLitLit "stdin" = "__iob+0x0"   -- This one is probably okay...
1268 cvtLitLit "stdout" = "__iob+0x14" -- but these next two are dodgy at best
1269 cvtLitLit "stderr" = "__iob+0x28"
1270 cvtLitLit s
1271   | isHex s = s
1272   | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
1273   where
1274     isHex ('0':'x':xs) = all isHexDigit xs
1275     isHex _ = False
1276     -- Now, where have I seen this before?
1277     isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'
1278
1279
1280 \end{code}
1281
1282 spRel gives us a stack relative addressing mode for volatile temporaries
1283 and for excess call arguments.
1284
1285 \begin{code}
1286
1287 spRel
1288     :: Int      -- desired stack offset in words, positive or negative
1289     -> Addr
1290 spRel n = AddrRegImm sp (ImmInt (n * 4))
1291
1292 stackArgLoc = 23 :: Int     -- where to stack extra call arguments (beyond 6x32 bits)
1293
1294 \end{code}
1295
1296 \begin{code}
1297
1298 getNewRegNCG :: PrimKind -> SUniqSM Reg
1299 getNewRegNCG pk =
1300       getSUnique          `thenSUs` \ u ->
1301       returnSUs (mkReg u pk)
1302
1303 \end{code}