ghc/compiler/nativeGen/AlphaGen.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1995
   3 %
   4
   5 \begin{code}
   6 #include "HsVersions.h"
   7
   8 module AlphaGen (
   9         alphaCodeGen,
  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, extractMappedRegNos, mkReg,
  23                       Reg(..), RegLiveness(..), RegUsage(..), FutureLive(..),
  24                       MachineRegisters(..), MachineCode(..)
  25                     )
  26 import CLabelInfo   ( CLabel, isAsmTemp )
  27 import AlphaCode    {- 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 AlphaDesc
  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[AlphaCodeGen]{Generating Alpha Code}
  48 %*                                                                      *
  49 %************************************************************************
  50
  51 This is the top-level code-generation function for the Alpha.
  52
  53 \begin{code}
  54
  55 alphaCodeGen :: PprStyle -> [[StixTree]] -> SUniqSM Unpretty
  56 alphaCodeGen sty trees =
  57     mapSUs genAlphaCode trees           `thenSUs` \ dynamicCodes ->
  58     let
  59         staticCodes = scheduleAlphaCode 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 scheduleAlphaCode :: [AlphaCode] -> [AlphaInstr]
  73 scheduleAlphaCode = concat . map (runRegAllocate freeAlphaRegs reservedRegs)
  74   where
  75     freeAlphaRegs :: AlphaRegs
  76     freeAlphaRegs = mkMRegs (extractMappedRegNos freeRegs)
  77
  78 \end{code}
  79
  80 Registers passed up the tree.  If the stix code forces the register
  81 to live in a pre-decided machine register, it comes out as @Fixed@;
  82 otherwise, it comes out as @Any@, and the parent can decide which
  83 register to put it in.
  84
  85 \begin{code}
  86
  87 data Register
  88   = Fixed Reg PrimKind (CodeBlock AlphaInstr)
  89   | Any PrimKind (Reg -> (CodeBlock AlphaInstr))
  90
  91 registerCode :: Register -> Reg -> CodeBlock AlphaInstr
  92 registerCode (Fixed _ _ code) reg = code
  93 registerCode (Any _ code) reg = code reg
  94
  95 registerName :: Register -> Reg -> Reg
  96 registerName (Fixed reg _ _) _ = reg
  97 registerName (Any _ _) reg = reg
  98
  99 registerKind :: Register -> PrimKind
 100 registerKind (Fixed _ pk _) = pk
 101 registerKind (Any pk _) = pk
 102
 103 isFixed :: Register -> Bool
 104 isFixed (Fixed _ _ _) = True
 105 isFixed (Any _ _)     = False
 106
 107 \end{code}
 108
 109 Memory addressing modes passed up the tree.
 110
 111 \begin{code}
 112
 113 data Amode = Amode Addr (CodeBlock AlphaInstr)
 114
 115 amodeAddr (Amode addr _) = addr
 116 amodeCode (Amode _ code) = code
 117
 118 \end{code}
 119
 120 General things for putting together code sequences.
 121
 122 \begin{code}
 123
 124 asmVoid :: OrdList AlphaInstr
 125 asmVoid = mkEmptyList
 126
 127 asmInstr :: AlphaInstr -> AlphaCode
 128 asmInstr i = mkUnitList i
 129
 130 asmSeq :: [AlphaInstr] -> AlphaCode
 131 asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
 132
 133 asmParThen :: [AlphaCode] -> CodeBlock AlphaInstr
 134 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
 135
 136 returnInstr :: AlphaInstr -> SUniqSM (CodeBlock AlphaInstr)
 137 returnInstr instr = returnSUs (\xs -> mkSeqList (asmInstr instr) xs)
 138
 139 returnInstrs :: [AlphaInstr] -> SUniqSM (CodeBlock AlphaInstr)
 140 returnInstrs instrs = returnSUs (\xs -> mkSeqList (asmSeq instrs) xs)
 141
 142 returnSeq :: (CodeBlock AlphaInstr) -> [AlphaInstr] -> SUniqSM (CodeBlock AlphaInstr)
 143 returnSeq code instrs = returnSUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
 144
 145 mkSeqInstr :: AlphaInstr -> (CodeBlock AlphaInstr)
 146 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
 147
 148 mkSeqInstrs :: [AlphaInstr] -> (CodeBlock AlphaInstr)
 149 mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
 150
 151 \end{code}
 152
 153 Top level alpha code generator for a chunk of stix code.
 154
 155 \begin{code}
 156
 157 genAlphaCode :: [StixTree] -> SUniqSM (AlphaCode)
 158
 159 genAlphaCode trees =
 160     mapSUs getCode trees                `thenSUs` \ blocks ->
 161     returnSUs (foldr (.) id blocks asmVoid)
 162
 163 \end{code}
 164
 165 Code extractor for an entire stix tree---stix statement level.
 166
 167 \begin{code}
 168
 169 getCode
 170     :: StixTree     -- a stix statement
 171     -> SUniqSM (CodeBlock AlphaInstr)
 172
 173 getCode (StSegment seg) = returnInstr (SEGMENT seg)
 174
 175 getCode (StAssign pk dst src)
 176   | isFloatingKind pk = assignFltCode pk dst src
 177   | otherwise = assignIntCode pk dst src
 178
 179 getCode (StLabel lab) = returnInstr (LABEL lab)
 180
 181 getCode (StFunBegin lab) = returnInstr (FUNBEGIN lab)
 182
 183 getCode (StFunEnd lab) = returnInstr (FUNEND lab)
 184
 185 getCode (StJump arg) = genJump arg
 186
 187 -- When falling through on the alpha, we still have to load pv with the
 188 -- address of the next routine, so that it can load gp
 189 getCode (StFallThrough lbl) = returnInstr (LDA pv (AddrImm (ImmCLbl lbl)))
 190
 191 getCode (StCondJump lbl arg) = genCondJump lbl arg
 192
 193 getCode (StData kind args) =
 194     mapAndUnzipSUs getData args             `thenSUs` \ (codes, imms) ->
 195     returnSUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
 196                                 (foldr1 (.) codes xs))
 197   where
 198     getData :: StixTree -> SUniqSM (CodeBlock AlphaInstr, Imm)
 199     getData (StInt i) = returnSUs (id, ImmInteger i)
 200 #if __GLASGOW_HASKELL__ >= 23
 201 --  getData (StDouble d) = returnSUs (id, strImmLab (_showRational 30 d))
 202     getData (StDouble d) = returnSUs (id, ImmLab (prettyToUn (ppRational d)))
 203 #else
 204     getData (StDouble d) = returnSUs (id, strImmLab (show d))
 205 #endif
 206     getData (StLitLbl s) = returnSUs (id, ImmLab s)
 207     getData (StLitLit s) = returnSUs (id, strImmLab (cvtLitLit (_UNPK_ s)))
 208     getData (StString s) =
 209         getUniqLabelNCG                     `thenSUs` \ lbl ->
 210         returnSUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
 211     getData (StCLbl l)   = returnSUs (id, ImmCLbl l)
 212
 213 getCode (StCall fn VoidKind args) = genCCall fn VoidKind args
 214
 215 getCode (StComment s) = returnInstr (COMMENT s)
 216
 217 \end{code}
 218
 219 Generate code to get a subtree into a register.
 220
 221 \begin{code}
 222
 223 getReg :: StixTree -> SUniqSM Register
 224
 225 getReg (StReg (StixMagicId stgreg)) =
 226     case stgRegMap stgreg of
 227         Just reg -> returnSUs (Fixed reg (kindFromMagicId stgreg) id)
 228         -- cannae be Nothing
 229
 230 getReg (StReg (StixTemp u pk)) = returnSUs (Fixed (UnmappedReg u pk) pk id)
 231
 232 getReg (StDouble d) =
 233     getUniqLabelNCG                 `thenSUs` \ lbl ->
 234     getNewRegNCG PtrKind            `thenSUs` \ tmp ->
 235     let code dst = mkSeqInstrs [
 236             SEGMENT DataSegment,
 237             LABEL lbl,
 238 #if __GLASGOW_HASKELL__ >= 23
 239 --          DATA TF [strImmLab (_showRational 30 d)],
 240             DATA TF [ImmLab (prettyToUn (ppRational d))],
 241 #else
 242             DATA TF [strImmLab (show d)],
 243 #endif
 244             SEGMENT TextSegment,
 245             LDA tmp (AddrImm (ImmCLbl lbl)),
 246             LD TF dst (AddrReg tmp)]
 247     in
 248         returnSUs (Any DoubleKind code)
 249
 250 getReg (StString s) =
 251     getUniqLabelNCG                 `thenSUs` \ lbl ->
 252     let code dst = mkSeqInstrs [
 253             SEGMENT DataSegment,
 254             LABEL lbl,
 255             ASCII True (_UNPK_ s),
 256             SEGMENT TextSegment,
 257             LDA dst (AddrImm (ImmCLbl lbl))]
 258     in
 259         returnSUs (Any PtrKind code)
 260
 261 getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
 262     getUniqLabelNCG                 `thenSUs` \ lbl ->
 263     let code dst = mkSeqInstrs [
 264             SEGMENT DataSegment,
 265             LABEL lbl,
 266             ASCII False (init xs),
 267             SEGMENT TextSegment,
 268             LDA dst (AddrImm (ImmCLbl lbl))]
 269     in
 270         returnSUs (Any PtrKind code)
 271   where
 272     xs = _UNPK_ (_TAIL_ s)
 273
 274 getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
 275
 276 getReg (StCall fn kind args) =
 277     genCCall fn kind args           `thenSUs` \ call ->
 278     returnSUs (Fixed reg kind call)
 279   where
 280     reg = if isFloatingKind kind then f0 else v0
 281
 282 getReg (StPrim primop args) =
 283     case primop of
 284
 285         CharGtOp -> case args of [x,y] -> trivialCode (CMP LT) [y,x]
 286         CharGeOp -> case args of [x,y] -> trivialCode (CMP LE) [y,x]
 287         CharEqOp -> trivialCode (CMP EQ) args
 288         CharNeOp -> intNECode args
 289         CharLtOp -> trivialCode (CMP LT) args
 290         CharLeOp -> trivialCode (CMP LE) args
 291
 292         IntAddOp -> trivialCode (ADD Q False) args
 293
 294         IntSubOp -> trivialCode (SUB Q False) args
 295         IntMulOp -> trivialCode (MUL Q False) args
 296         IntQuotOp -> trivialCode (DIV Q False) args
 297         IntRemOp -> trivialCode (REM Q False) args
 298         IntNegOp -> trivialUCode (NEG Q False) args
 299         IntAbsOp -> trivialUCode (ABS Q) args
 300
 301         AndOp -> trivialCode AND args
 302         OrOp  -> trivialCode OR args
 303         NotOp -> trivialUCode NOT args
 304         SllOp -> trivialCode SLL args
 305         SraOp -> trivialCode SRA args
 306         SrlOp -> trivialCode SRL args
 307         ISllOp -> panic "AlphaGen:isll"
 308         ISraOp -> panic "AlphaGen:isra"
 309         ISrlOp -> panic "AlphaGen:isrl"
 310
 311         IntGtOp -> case args of [x,y] -> trivialCode (CMP LT) [y,x]
 312         IntGeOp -> case args of [x,y] -> trivialCode (CMP LE) [y,x]
 313         IntEqOp -> trivialCode (CMP EQ) args
 314         IntNeOp -> intNECode args
 315         IntLtOp -> trivialCode (CMP LT) args
 316         IntLeOp -> trivialCode (CMP LE) args
 317
 318         WordGtOp -> case args of [x,y] -> trivialCode (CMP ULT) [y,x]
 319         WordGeOp -> case args of [x,y] -> trivialCode (CMP ULE) [y,x]
 320         WordEqOp -> trivialCode (CMP EQ) args
 321         WordNeOp -> intNECode args
 322         WordLtOp -> trivialCode (CMP ULT) args
 323         WordLeOp -> trivialCode (CMP ULE) args
 324
 325         AddrGtOp -> case args of [x,y] -> trivialCode (CMP ULT) [y,x]
 326         AddrGeOp -> case args of [x,y] -> trivialCode (CMP ULE) [y,x]
 327         AddrEqOp -> trivialCode (CMP EQ) args
 328         AddrNeOp -> intNECode args
 329         AddrLtOp -> trivialCode (CMP ULT) args
 330         AddrLeOp -> trivialCode (CMP ULE) args
 331
 332         FloatAddOp -> trivialFCode (FADD TF) args
 333         FloatSubOp -> trivialFCode (FSUB TF) args
 334         FloatMulOp -> trivialFCode (FMUL TF) args
 335         FloatDivOp -> trivialFCode (FDIV TF) args
 336         FloatNegOp -> trivialUFCode (FNEG TF) args
 337
 338         FloatGtOp -> cmpFCode (FCMP TF LE) EQ args
 339         FloatGeOp -> cmpFCode (FCMP TF LT) EQ args
 340         FloatEqOp -> cmpFCode (FCMP TF EQ) NE args
 341         FloatNeOp -> cmpFCode (FCMP TF EQ) EQ args
 342         FloatLtOp -> cmpFCode (FCMP TF LT) NE args
 343         FloatLeOp -> cmpFCode (FCMP TF LE) NE args
 344
 345         FloatExpOp -> call SLIT("exp") DoubleKind
 346         FloatLogOp -> call SLIT("log") DoubleKind
 347         FloatSqrtOp -> call SLIT("sqrt") DoubleKind
 348
 349         FloatSinOp -> call SLIT("sin") DoubleKind
 350         FloatCosOp -> call SLIT("cos") DoubleKind
 351         FloatTanOp -> call SLIT("tan") DoubleKind
 352
 353         FloatAsinOp -> call SLIT("asin") DoubleKind
 354         FloatAcosOp -> call SLIT("acos") DoubleKind
 355         FloatAtanOp -> call SLIT("atan") DoubleKind
 356
 357         FloatSinhOp -> call SLIT("sinh") DoubleKind
 358         FloatCoshOp -> call SLIT("cosh") DoubleKind
 359         FloatTanhOp -> call SLIT("tanh") DoubleKind
 360
 361         FloatPowerOp -> call SLIT("pow") DoubleKind
 362
 363         DoubleAddOp -> trivialFCode (FADD TF) args
 364         DoubleSubOp -> trivialFCode (FSUB TF) args
 365         DoubleMulOp -> trivialFCode (FMUL TF) args
 366         DoubleDivOp -> trivialFCode (FDIV TF) args
 367         DoubleNegOp -> trivialUFCode (FNEG TF) args
 368
 369         DoubleGtOp -> cmpFCode (FCMP TF LE) EQ args
 370         DoubleGeOp -> cmpFCode (FCMP TF LT) EQ args
 371         DoubleEqOp -> cmpFCode (FCMP TF EQ) NE args
 372         DoubleNeOp -> cmpFCode (FCMP TF EQ) EQ args
 373         DoubleLtOp -> cmpFCode (FCMP TF LT) NE args
 374         DoubleLeOp -> cmpFCode (FCMP TF LE) NE args
 375
 376         DoubleExpOp -> call SLIT("exp") DoubleKind
 377         DoubleLogOp -> call SLIT("log") DoubleKind
 378         DoubleSqrtOp -> call SLIT("sqrt") DoubleKind
 379
 380         DoubleSinOp -> call SLIT("sin") DoubleKind
 381         DoubleCosOp -> call SLIT("cos") DoubleKind
 382         DoubleTanOp -> call SLIT("tan") DoubleKind
 383
 384         DoubleAsinOp -> call SLIT("asin") DoubleKind
 385         DoubleAcosOp -> call SLIT("acos") DoubleKind
 386         DoubleAtanOp -> call SLIT("atan") DoubleKind
 387
 388         DoubleSinhOp -> call SLIT("sinh") DoubleKind
 389         DoubleCoshOp -> call SLIT("cosh") DoubleKind
 390         DoubleTanhOp -> call SLIT("tanh") DoubleKind
 391
 392         DoublePowerOp -> call SLIT("pow") DoubleKind
 393
 394         OrdOp -> coerceIntCode IntKind args
 395         ChrOp -> chrCode args
 396
 397         Float2IntOp -> coerceFP2Int args
 398         Int2FloatOp -> coerceInt2FP args
 399         Double2IntOp -> coerceFP2Int args
 400         Int2DoubleOp -> coerceInt2FP args
 401
 402         Double2FloatOp -> coerceFltCode args
 403         Float2DoubleOp -> coerceFltCode args
 404
 405   where
 406     call fn pk = getReg (StCall fn pk args)
 407
 408 getReg (StInd pk mem) =
 409     getAmode mem                    `thenSUs` \ amode ->
 410     let
 411         code = amodeCode amode
 412         src   = amodeAddr amode
 413         size = kindToSize pk
 414         code__2 dst = code . mkSeqInstr (LD size dst src)
 415     in
 416         returnSUs (Any pk code__2)
 417
 418 getReg (StInt i)
 419   | is8Bits i =
 420     let
 421         code dst = mkSeqInstr (OR zero (RIImm src) dst)
 422     in
 423         returnSUs (Any IntKind code)
 424   | otherwise =
 425     let
 426         code dst = mkSeqInstr (LDI Q dst src)
 427     in
 428         returnSUs (Any IntKind code)
 429   where
 430     src = ImmInt (fromInteger i)
 431
 432 getReg leaf
 433   | maybeToBool imm =
 434     let
 435         code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
 436     in
 437         returnSUs (Any PtrKind code)
 438   where
 439     imm = maybeImm leaf
 440     imm__2 = case imm of Just x -> x
 441
 442 \end{code}
 443
 444 Now, given a tree (the argument to an StInd) that references memory,
 445 produce a suitable addressing mode.
 446
 447 \begin{code}
 448
 449 getAmode :: StixTree -> SUniqSM Amode
 450
 451 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
 452
 453 getAmode (StPrim IntSubOp [x, StInt i]) =
 454     getNewRegNCG PtrKind            `thenSUs` \ tmp ->
 455     getReg x                        `thenSUs` \ register ->
 456     let
 457         code = registerCode register tmp
 458         reg  = registerName register tmp
 459         off  = ImmInt (-(fromInteger i))
 460     in
 461         returnSUs (Amode (AddrRegImm reg off) code)
 462
 463
 464 getAmode (StPrim IntAddOp [x, StInt i]) =
 465     getNewRegNCG PtrKind            `thenSUs` \ tmp ->
 466     getReg x                        `thenSUs` \ register ->
 467     let
 468         code = registerCode register tmp
 469         reg  = registerName register tmp
 470         off  = ImmInt (fromInteger i)
 471     in
 472         returnSUs (Amode (AddrRegImm reg off) code)
 473
 474 getAmode leaf
 475   | maybeToBool imm =
 476         returnSUs (Amode (AddrImm imm__2) id)
 477   where
 478     imm = maybeImm leaf
 479     imm__2 = case imm of Just x -> x
 480
 481 getAmode other =
 482     getNewRegNCG PtrKind            `thenSUs` \ tmp ->
 483     getReg other                    `thenSUs` \ register ->
 484     let
 485         code = registerCode register tmp
 486         reg  = registerName register tmp
 487     in
 488         returnSUs (Amode (AddrReg reg) code)
 489
 490 \end{code}
 491
 492 Try to get a value into a specific register (or registers) for a call.
 493 The first 6 arguments go into the appropriate argument register
 494 (separate registers for integer and floating point arguments, but used
 495 in lock-step), and the remaining arguments are dumped to the stack,
 496 beginning at 0(sp).  Our first argument is a pair of the list of
 497 remaining argument registers to be assigned for this call and the next
 498 stack offset to use for overflowing arguments.  This way, @getCallArg@
 499 can be applied to all of a call's arguments using @mapAccumL@.
 500
 501 \begin{code}
 502
 503 getCallArg
 504     :: ([(Reg,Reg)],Int)    -- Argument registers and stack offset (accumulator)
 505     -> StixTree             -- Current argument
 506     -> SUniqSM (([(Reg,Reg)],Int), CodeBlock AlphaInstr) -- Updated accumulator and code
 507
 508 -- We have to use up all of our argument registers first.
 509
 510 getCallArg ((iDst,fDst):dsts, offset) arg =
 511     getReg arg                      `thenSUs` \ register ->
 512     let
 513         reg = if isFloatingKind pk then fDst else iDst
 514         code = registerCode register reg
 515         src = registerName register reg
 516         pk = registerKind register
 517     in
 518         returnSUs (
 519             if isFloatingKind pk then
 520                 ((dsts, offset), if isFixed register then
 521                     code . mkSeqInstr (FMOV src fDst)
 522                     else code)
 523             else
 524                 ((dsts, offset), if isFixed register then
 525                     code . mkSeqInstr (OR src (RIReg src) iDst)
 526                     else code))
 527
 528 -- Once we have run out of argument registers, we move to the stack
 529
 530 getCallArg ([], offset) arg =
 531     getReg arg                      `thenSUs` \ register ->
 532     getNewRegNCG (registerKind register)
 533                                     `thenSUs` \ tmp ->
 534     let
 535         code = registerCode register tmp
 536         src = registerName register tmp
 537         pk = registerKind register
 538         sz = kindToSize pk
 539     in
 540         returnSUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
 541
 542 \end{code}
 543
 544 Assignments are really at the heart of the whole code generation business.
 545 Almost all top-level nodes of any real importance are assignments, which
 546 correspond to loads, stores, or register transfers.  If we're really lucky,
 547 some of the register transfers will go away, because we can use the destination
 548 register to complete the code generation for the right hand side.  This only
 549 fails when the right hand side is forced into a fixed register (e.g. the result
 550 of a call).
 551
 552 \begin{code}
 553
 554 assignIntCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock AlphaInstr)
 555
 556 assignIntCode pk (StInd _ dst) src =
 557     getNewRegNCG IntKind            `thenSUs` \ tmp ->
 558     getAmode dst                    `thenSUs` \ amode ->
 559     getReg src                      `thenSUs` \ register ->
 560     let
 561         code1 = amodeCode amode asmVoid
 562         dst__2  = amodeAddr amode
 563         code2 = registerCode register tmp asmVoid
 564         src__2  = registerName register tmp
 565         sz    = kindToSize pk
 566         code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
 567     in
 568         returnSUs code__2
 569
 570 assignIntCode pk dst src =
 571     getReg dst                      `thenSUs` \ register1 ->
 572     getReg src                      `thenSUs` \ register2 ->
 573     let
 574         dst__2 = registerName register1 zero
 575         code = registerCode register2 dst__2
 576         src__2 = registerName register2 dst__2
 577         code__2 = if isFixed register2 then
 578                     code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
 579                 else code
 580     in
 581         returnSUs code__2
 582
 583 assignFltCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock AlphaInstr)
 584
 585 assignFltCode pk (StInd _ dst) src =
 586     getNewRegNCG pk                 `thenSUs` \ tmp ->
 587     getAmode dst                    `thenSUs` \ amode ->
 588     getReg src                      `thenSUs` \ register ->
 589     let
 590         code1 = amodeCode amode asmVoid
 591         dst__2  = amodeAddr amode
 592         code2 = registerCode register tmp asmVoid
 593         src__2  = registerName register tmp
 594         sz    = kindToSize pk
 595         code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
 596     in
 597         returnSUs code__2
 598
 599 assignFltCode pk dst src =
 600     getReg dst                      `thenSUs` \ register1 ->
 601     getReg src                      `thenSUs` \ register2 ->
 602     let
 603         dst__2 = registerName register1 zero
 604         code = registerCode register2 dst__2
 605         src__2 = registerName register2 dst__2
 606         code__2 = if isFixed register2 then
 607                     code . mkSeqInstr (FMOV src__2 dst__2)
 608                 else code
 609     in
 610         returnSUs code__2
 611
 612 \end{code}
 613
 614 Generating an unconditional branch.  We accept two types of targets:
 615 an immediate CLabel or a tree that gets evaluated into a register.
 616 Any CLabels which are AsmTemporaries are assumed to be in the local
 617 block of code, close enough for a branch instruction.  Other CLabels
 618 are assumed to be far away, so we use jmp.
 619
 620 \begin{code}
 621
 622 genJump
 623     :: StixTree     -- the branch target
 624     -> SUniqSM (CodeBlock AlphaInstr)
 625
 626 genJump (StCLbl lbl)
 627   | isAsmTemp lbl = returnInstr (BR target)
 628   | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zero (AddrReg pv) 0]
 629   where
 630     target = ImmCLbl lbl
 631
 632 genJump tree =
 633     getReg tree                     `thenSUs` \ register ->
 634     getNewRegNCG PtrKind            `thenSUs` \ tmp ->
 635     let
 636         dst = registerName register pv
 637         code = registerCode register pv
 638         target = registerName register pv
 639     in
 640         if isFixed register then
 641             returnSeq code [OR dst (RIReg dst) pv, JMP zero (AddrReg pv) 0]
 642         else
 643             returnSUs (code . mkSeqInstr (JMP zero (AddrReg pv) 0))
 644
 645 \end{code}
 646
 647 Conditional jumps are always to local labels, so we can use
 648 branch instructions.  We peek at the arguments to decide what kind
 649 of comparison to do.  For comparisons with 0, we're laughing, because
 650 we can just do the desired conditional branch.
 651
 652 \begin{code}
 653
 654 genCondJump
 655     :: CLabel       -- the branch target
 656     -> StixTree     -- the condition on which to branch
 657     -> SUniqSM (CodeBlock AlphaInstr)
 658
 659 genCondJump lbl (StPrim op [x, StInt 0]) =
 660     getReg x                        `thenSUs` \ register ->
 661     getNewRegNCG (registerKind register)
 662                                     `thenSUs` \ tmp ->
 663     let
 664         code = registerCode register tmp
 665         value = registerName register tmp
 666         pk = registerKind register
 667         target = ImmCLbl lbl
 668     in
 669             returnSeq code [BI (cmpOp op) value target]
 670   where
 671     cmpOp CharGtOp = GT
 672     cmpOp CharGeOp = GE
 673     cmpOp CharEqOp = EQ
 674     cmpOp CharNeOp = NE
 675     cmpOp CharLtOp = LT
 676     cmpOp CharLeOp = LE
 677     cmpOp IntGtOp = GT
 678     cmpOp IntGeOp = GE
 679     cmpOp IntEqOp = EQ
 680     cmpOp IntNeOp = NE
 681     cmpOp IntLtOp = LT
 682     cmpOp IntLeOp = LE
 683     cmpOp WordGtOp = NE
 684     cmpOp WordGeOp = ALWAYS
 685     cmpOp WordEqOp = EQ
 686     cmpOp WordNeOp = NE
 687     cmpOp WordLtOp = NEVER
 688     cmpOp WordLeOp = EQ
 689     cmpOp AddrGtOp = NE
 690     cmpOp AddrGeOp = ALWAYS
 691     cmpOp AddrEqOp = EQ
 692     cmpOp AddrNeOp = NE
 693     cmpOp AddrLtOp = NEVER
 694     cmpOp AddrLeOp = EQ
 695
 696 genCondJump lbl (StPrim op [x, StDouble 0.0]) =
 697     getReg x                        `thenSUs` \ register ->
 698     getNewRegNCG (registerKind register)
 699                                     `thenSUs` \ tmp ->
 700     let
 701         code = registerCode register tmp
 702         value = registerName register tmp
 703         pk = registerKind register
 704         target = ImmCLbl lbl
 705     in
 706             returnSUs (code . mkSeqInstr (BF (cmpOp op) value target))
 707   where
 708     cmpOp FloatGtOp = GT
 709     cmpOp FloatGeOp = GE
 710     cmpOp FloatEqOp = EQ
 711     cmpOp FloatNeOp = NE
 712     cmpOp FloatLtOp = LT
 713     cmpOp FloatLeOp = LE
 714     cmpOp DoubleGtOp = GT
 715     cmpOp DoubleGeOp = GE
 716     cmpOp DoubleEqOp = EQ
 717     cmpOp DoubleNeOp = NE
 718     cmpOp DoubleLtOp = LT
 719     cmpOp DoubleLeOp = LE
 720
 721 genCondJump lbl (StPrim op args)
 722   | fltCmpOp op =
 723     trivialFCode instr args         `thenSUs` \ register ->
 724     getNewRegNCG DoubleKind         `thenSUs` \ tmp ->
 725     let
 726         code = registerCode register tmp
 727         result = registerName register tmp
 728         target = ImmCLbl lbl
 729     in
 730         returnSUs (code . mkSeqInstr (BF cond result target))
 731   where
 732     fltCmpOp op = case op of
 733         FloatGtOp -> True
 734         FloatGeOp -> True
 735         FloatEqOp -> True
 736         FloatNeOp -> True
 737         FloatLtOp -> True
 738         FloatLeOp -> True
 739         DoubleGtOp -> True
 740         DoubleGeOp -> True
 741         DoubleEqOp -> True
 742         DoubleNeOp -> True
 743         DoubleLtOp -> True
 744         DoubleLeOp -> True
 745         _ -> False
 746     (instr, cond) = case op of
 747         FloatGtOp -> (FCMP TF LE, EQ)
 748         FloatGeOp -> (FCMP TF LT, EQ)
 749         FloatEqOp -> (FCMP TF EQ, NE)
 750         FloatNeOp -> (FCMP TF EQ, EQ)
 751         FloatLtOp -> (FCMP TF LT, NE)
 752         FloatLeOp -> (FCMP TF LE, NE)
 753         DoubleGtOp -> (FCMP TF LE, EQ)
 754         DoubleGeOp -> (FCMP TF LT, EQ)
 755         DoubleEqOp -> (FCMP TF EQ, NE)
 756         DoubleNeOp -> (FCMP TF EQ, EQ)
 757         DoubleLtOp -> (FCMP TF LT, NE)
 758         DoubleLeOp -> (FCMP TF LE, NE)
 759
 760 genCondJump lbl (StPrim op args) =
 761     trivialCode instr args          `thenSUs` \ register ->
 762     getNewRegNCG IntKind            `thenSUs` \ tmp ->
 763     let
 764         code = registerCode register tmp
 765         result = registerName register tmp
 766         target = ImmCLbl lbl
 767     in
 768         returnSUs (code . mkSeqInstr (BI cond result target))
 769   where
 770     (instr, cond) = case op of
 771         CharGtOp -> (CMP LE, EQ)
 772         CharGeOp -> (CMP LT, EQ)
 773         CharEqOp -> (CMP EQ, NE)
 774         CharNeOp -> (CMP EQ, EQ)
 775         CharLtOp -> (CMP LT, NE)
 776         CharLeOp -> (CMP LE, NE)
 777         IntGtOp -> (CMP LE, EQ)
 778         IntGeOp -> (CMP LT, EQ)
 779         IntEqOp -> (CMP EQ, NE)
 780         IntNeOp -> (CMP EQ, EQ)
 781         IntLtOp -> (CMP LT, NE)
 782         IntLeOp -> (CMP LE, NE)
 783         WordGtOp -> (CMP ULE, EQ)
 784         WordGeOp -> (CMP ULT, EQ)
 785         WordEqOp -> (CMP EQ, NE)
 786         WordNeOp -> (CMP EQ, EQ)
 787         WordLtOp -> (CMP ULT, NE)
 788         WordLeOp -> (CMP ULE, NE)
 789         AddrGtOp -> (CMP ULE, EQ)
 790         AddrGeOp -> (CMP ULT, EQ)
 791         AddrEqOp -> (CMP EQ, NE)
 792         AddrNeOp -> (CMP EQ, EQ)
 793         AddrLtOp -> (CMP ULT, NE)
 794         AddrLeOp -> (CMP ULE, NE)
 795
 796 \end{code}
 797
 798 Now the biggest nightmare---calls.  Most of the nastiness is buried in
 799 getCallArg, which moves the arguments to the correct registers/stack
 800 locations.  Apart from that, the code is easy.
 801
 802 \begin{code}
 803
 804 genCCall
 805     :: FAST_STRING    -- function to call
 806     -> PrimKind     -- type of the result
 807     -> [StixTree]   -- arguments (of mixed type)
 808     -> SUniqSM (CodeBlock AlphaInstr)
 809
 810 genCCall fn kind args =
 811     mapAccumLNCG getCallArg (argRegs,stackArgLoc) args
 812                                     `thenSUs` \ ((unused,_), argCode) ->
 813     let
 814         nRegs = length argRegs - length unused
 815         code = asmParThen (map ($ asmVoid) argCode)
 816     in
 817         returnSeq code [
 818             LDA pv (AddrImm (ImmLab (uppPStr fn))),
 819             JSR ra (AddrReg pv) nRegs,
 820             LDGP gp (AddrReg ra)]
 821   where
 822     mapAccumLNCG f b []     = returnSUs (b, [])
 823     mapAccumLNCG f b (x:xs) =
 824         f b x                               `thenSUs` \ (b__2, x__2) ->
 825         mapAccumLNCG f b__2 xs              `thenSUs` \ (b__3, xs__2) ->
 826         returnSUs (b__3, x__2:xs__2)
 827
 828 \end{code}
 829
 830 Trivial (dyadic) instructions.  Only look for constants on the right hand
 831 side, because that's where the generic optimizer will have put them.
 832
 833 \begin{code}
 834
 835 trivialCode
 836     :: (Reg -> RI -> Reg -> AlphaInstr)
 837     -> [StixTree]
 838     -> SUniqSM Register
 839
 840 trivialCode instr [x, StInt y]
 841   | is8Bits y =
 842     getReg x                        `thenSUs` \ register ->
 843     getNewRegNCG IntKind            `thenSUs` \ tmp ->
 844     let
 845         code = registerCode register tmp
 846         src1 = registerName register tmp
 847         src2 = ImmInt (fromInteger y)
 848         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
 849     in
 850         returnSUs (Any IntKind code__2)
 851
 852 trivialCode instr [x, y] =
 853     getReg x                        `thenSUs` \ register1 ->
 854     getReg y                        `thenSUs` \ register2 ->
 855     getNewRegNCG IntKind            `thenSUs` \ tmp1 ->
 856     getNewRegNCG IntKind            `thenSUs` \ tmp2 ->
 857     let
 858         code1 = registerCode register1 tmp1 asmVoid
 859         src1  = registerName register1 tmp1
 860         code2 = registerCode register2 tmp2 asmVoid
 861         src2  = registerName register2 tmp2
 862         code__2 dst = asmParThen [code1, code2] .
 863                      mkSeqInstr (instr src1 (RIReg src2) dst)
 864     in
 865         returnSUs (Any IntKind code__2)
 866
 867 trivialFCode
 868     :: (Reg -> Reg -> Reg -> AlphaInstr)
 869     -> [StixTree]
 870     -> SUniqSM Register
 871
 872 trivialFCode instr [x, y] =
 873     getReg x                        `thenSUs` \ register1 ->
 874     getReg y                        `thenSUs` \ register2 ->
 875     getNewRegNCG DoubleKind         `thenSUs` \ tmp1 ->
 876     getNewRegNCG DoubleKind         `thenSUs` \ tmp2 ->
 877     let
 878         code1 = registerCode register1 tmp1
 879         src1  = registerName register1 tmp1
 880
 881         code2 = registerCode register2 tmp2
 882         src2  = registerName register2 tmp2
 883
 884         code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
 885                       mkSeqInstr (instr src1 src2 dst)
 886     in
 887         returnSUs (Any DoubleKind code__2)
 888
 889 \end{code}
 890
 891 Some bizarre special code for getting condition codes into registers.
 892 Integer non-equality is a test for equality followed by an XOR with 1.
 893 (Integer comparisons always set the result register to 0 or 1.)  Floating
 894 point comparisons of any kind leave the result in a floating point register,
 895 so we need to wrangle an integer register out of things.
 896
 897 \begin{code}
 898 intNECode
 899     :: [StixTree]
 900     -> SUniqSM Register
 901
 902 intNECode args =
 903     trivialCode (CMP EQ) args       `thenSUs` \ register ->
 904     getNewRegNCG IntKind            `thenSUs` \ tmp ->
 905     let
 906         code = registerCode register tmp
 907         src  = registerName register tmp
 908         code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
 909     in
 910         returnSUs (Any IntKind code__2)
 911
 912 cmpFCode
 913     :: (Reg -> Reg -> Reg -> AlphaInstr)
 914     -> Cond
 915     -> [StixTree]
 916     -> SUniqSM Register
 917
 918 cmpFCode instr cond args =
 919     trivialFCode instr args         `thenSUs` \ register ->
 920     getNewRegNCG DoubleKind         `thenSUs` \ tmp ->
 921     getUniqLabelNCG                 `thenSUs` \ lbl ->
 922     let
 923         code = registerCode register tmp
 924         result  = registerName register tmp
 925
 926         code__2 dst = code . mkSeqInstrs [
 927             OR zero (RIImm (ImmInt 1)) dst,
 928             BF cond result (ImmCLbl lbl),
 929             OR zero (RIReg zero) dst,
 930             LABEL lbl]
 931     in
 932         returnSUs (Any IntKind code__2)
 933
 934 \end{code}
 935
 936 Trivial unary instructions.  Note that we don't have to worry about
 937 matching an StInt as the argument, because genericOpt will already
 938 have handled the constant-folding.
 939
 940 \begin{code}
 941
 942 trivialUCode
 943     :: (RI -> Reg -> AlphaInstr)
 944     -> [StixTree]
 945     -> SUniqSM Register
 946
 947 trivialUCode instr [x] =
 948     getReg x                        `thenSUs` \ register ->
 949     getNewRegNCG IntKind            `thenSUs` \ tmp ->
 950     let
 951         code = registerCode register tmp
 952         src  = registerName register tmp
 953         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
 954     in
 955         returnSUs (Any IntKind code__2)
 956
 957 trivialUFCode
 958     :: (Reg -> Reg -> AlphaInstr)
 959     -> [StixTree]
 960     -> SUniqSM Register
 961
 962 trivialUFCode instr [x] =
 963     getReg x                        `thenSUs` \ register ->
 964     getNewRegNCG DoubleKind         `thenSUs` \ tmp ->
 965     let
 966         code = registerCode register tmp
 967         src  = registerName register tmp
 968         code__2 dst = code . mkSeqInstr (instr src dst)
 969     in
 970         returnSUs (Any DoubleKind code__2)
 971
 972 \end{code}
 973
 974 Simple coercions that don't require any code to be generated.
 975 Here we just change the type on the register passed on up
 976
 977 \begin{code}
 978
 979 coerceIntCode :: PrimKind -> [StixTree] -> SUniqSM Register
 980 coerceIntCode pk [x] =
 981     getReg x                        `thenSUs` \ register ->
 982     case register of
 983         Fixed reg _ code -> returnSUs (Fixed reg pk code)
 984         Any _ code       -> returnSUs (Any pk code)
 985
 986 coerceFltCode :: [StixTree] -> SUniqSM Register
 987 coerceFltCode [x] =
 988     getReg x                        `thenSUs` \ register ->
 989     case register of
 990         Fixed reg _ code -> returnSUs (Fixed reg DoubleKind code)
 991         Any _ code       -> returnSUs (Any DoubleKind code)
 992
 993 \end{code}
 994
 995 Integer to character conversion.
 996
 997 \begin{code}
 998
 999 chrCode [x] =
1000     getReg x                        `thenSUs` \ register ->
1001     getNewRegNCG IntKind            `thenSUs` \ reg ->
1002     let
1003         code = registerCode register reg
1004         src  = registerName register reg
1005         code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
1006     in
1007         returnSUs (Any IntKind code__2)
1008
1009 \end{code}
1010
1011 More complicated integer/float conversions.  Here we have to store
1012 temporaries in memory to move between the integer and the floating
1013 point register sets.
1014
1015 \begin{code}
1016
1017 coerceInt2FP :: [StixTree] -> SUniqSM Register
1018 coerceInt2FP [x] =
1019     getReg x                        `thenSUs` \ register ->
1020     getNewRegNCG IntKind            `thenSUs` \ reg ->
1021     let
1022         code = registerCode register reg
1023         src  = registerName register reg
1024
1025         code__2 dst = code . mkSeqInstrs [
1026             ST Q src (spRel 0),
1027             LD TF dst (spRel 0),
1028             CVTxy Q TF dst dst]
1029     in
1030         returnSUs (Any DoubleKind code__2)
1031
1032 coerceFP2Int :: [StixTree] -> SUniqSM Register
1033 coerceFP2Int [x] =
1034     getReg x                        `thenSUs` \ register ->
1035     getNewRegNCG DoubleKind         `thenSUs` \ tmp ->
1036     let
1037         code = registerCode register tmp
1038         src  = registerName register tmp
1039
1040         code__2 dst = code . mkSeqInstrs [
1041             CVTxy TF Q src tmp,
1042             ST TF tmp (spRel 0),
1043             LD Q dst (spRel 0)]
1044     in
1045         returnSUs (Any IntKind code__2)
1046
1047 \end{code}
1048
1049 Some random little helpers.
1050
1051 \begin{code}
1052
1053 is8Bits :: Integer -> Bool
1054 is8Bits i = i >= -256 && i < 256
1055
1056 maybeImm :: StixTree -> Maybe Imm
1057 maybeImm (StInt i)
1058   | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
1059   | otherwise = Just (ImmInteger i)
1060 maybeImm (StLitLbl s)  = Just (ImmLab s)
1061 maybeImm (StLitLit s)  = Just (strImmLab (cvtLitLit (_UNPK_ s)))
1062 maybeImm (StCLbl l) = Just (ImmCLbl l)
1063 maybeImm _          = Nothing
1064
1065 mangleIndexTree :: StixTree -> StixTree
1066
1067 mangleIndexTree (StIndex pk base (StInt i)) =
1068     StPrim IntAddOp [base, off]
1069   where
1070     off = StInt (i * size pk)
1071     size :: PrimKind -> Integer
1072     size pk = case kindToSize pk of
1073         {B -> 1; BU -> 1; W -> 2; WU -> 2; L -> 4; FF -> 4; SF -> 4; _ -> 8}
1074
1075 mangleIndexTree (StIndex pk base off) =
1076     case pk of
1077         CharKind -> StPrim IntAddOp [base, off]
1078         _        -> StPrim IntAddOp [base, off__2]
1079   where
1080     off__2 = StPrim SllOp [off, StInt 3]
1081
1082 cvtLitLit :: String -> String
1083 cvtLitLit "stdin" = "_iob+0"   -- This one is probably okay...
1084 cvtLitLit "stdout" = "_iob+56" -- but these next two are dodgy at best
1085 cvtLitLit "stderr" = "_iob+112"
1086 cvtLitLit s
1087   | isHex s = s
1088   | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
1089   where
1090     isHex ('0':'x':xs) = all isHexDigit xs
1091     isHex _ = False
1092     -- Now, where have I seen this before?
1093     isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'
1094
1095
1096 \end{code}
1097
1098 spRel gives us a stack relative addressing mode for volatile temporaries
1099 and for excess call arguments.
1100
1101 \begin{code}
1102
1103 spRel
1104     :: Int      -- desired stack offset in words, positive or negative
1105     -> Addr
1106 spRel n = AddrRegImm sp (ImmInt (n * 8))
1107
1108 stackArgLoc = 0 :: Int      -- where to stack extra call arguments (beyond 6)
1109
1110 \end{code}
1111
1112 \begin{code}
1113
1114 getNewRegNCG :: PrimKind -> SUniqSM Reg
1115 getNewRegNCG pk =
1116       getSUnique          `thenSUs` \ u ->
1117       returnSUs (mkReg u pk)
1118
1119 \end{code}