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         IntDivOp -> call SLIT("stg_div") IntKind
 298         IntRemOp -> trivialCode (REM Q False) args
 299         IntNegOp -> trivialUCode (NEG Q False) args
 300         IntAbsOp -> trivialUCode (ABS Q) args
 301
 302         AndOp -> trivialCode AND args
 303         OrOp  -> trivialCode OR args
 304         NotOp -> trivialUCode NOT args
 305         SllOp -> trivialCode SLL args
 306         SraOp -> trivialCode SRA args
 307         SrlOp -> trivialCode SRL args
 308         ISllOp -> panic "AlphaGen:isll"
 309         ISraOp -> panic "AlphaGen:isra"
 310         ISrlOp -> panic "AlphaGen:isrl"
 311
 312         IntGtOp -> case args of [x,y] -> trivialCode (CMP LT) [y,x]
 313         IntGeOp -> case args of [x,y] -> trivialCode (CMP LE) [y,x]
 314         IntEqOp -> trivialCode (CMP EQ) args
 315         IntNeOp -> intNECode args
 316         IntLtOp -> trivialCode (CMP LT) args
 317         IntLeOp -> trivialCode (CMP LE) args
 318
 319         WordGtOp -> case args of [x,y] -> trivialCode (CMP ULT) [y,x]
 320         WordGeOp -> case args of [x,y] -> trivialCode (CMP ULE) [y,x]
 321         WordEqOp -> trivialCode (CMP EQ) args
 322         WordNeOp -> intNECode args
 323         WordLtOp -> trivialCode (CMP ULT) args
 324         WordLeOp -> trivialCode (CMP ULE) args
 325
 326         AddrGtOp -> case args of [x,y] -> trivialCode (CMP ULT) [y,x]
 327         AddrGeOp -> case args of [x,y] -> trivialCode (CMP ULE) [y,x]
 328         AddrEqOp -> trivialCode (CMP EQ) args
 329         AddrNeOp -> intNECode args
 330         AddrLtOp -> trivialCode (CMP ULT) args
 331         AddrLeOp -> trivialCode (CMP ULE) args
 332
 333         FloatAddOp -> trivialFCode (FADD TF) args
 334         FloatSubOp -> trivialFCode (FSUB TF) args
 335         FloatMulOp -> trivialFCode (FMUL TF) args
 336         FloatDivOp -> trivialFCode (FDIV TF) args
 337         FloatNegOp -> trivialUFCode (FNEG TF) args
 338
 339         FloatGtOp -> cmpFCode (FCMP TF LE) EQ args
 340         FloatGeOp -> cmpFCode (FCMP TF LT) EQ args
 341         FloatEqOp -> cmpFCode (FCMP TF EQ) NE args
 342         FloatNeOp -> cmpFCode (FCMP TF EQ) EQ args
 343         FloatLtOp -> cmpFCode (FCMP TF LT) NE args
 344         FloatLeOp -> cmpFCode (FCMP TF LE) NE args
 345
 346         FloatExpOp -> call SLIT("exp") DoubleKind
 347         FloatLogOp -> call SLIT("log") DoubleKind
 348         FloatSqrtOp -> call SLIT("sqrt") DoubleKind
 349
 350         FloatSinOp -> call SLIT("sin") DoubleKind
 351         FloatCosOp -> call SLIT("cos") DoubleKind
 352         FloatTanOp -> call SLIT("tan") DoubleKind
 353
 354         FloatAsinOp -> call SLIT("asin") DoubleKind
 355         FloatAcosOp -> call SLIT("acos") DoubleKind
 356         FloatAtanOp -> call SLIT("atan") DoubleKind
 357
 358         FloatSinhOp -> call SLIT("sinh") DoubleKind
 359         FloatCoshOp -> call SLIT("cosh") DoubleKind
 360         FloatTanhOp -> call SLIT("tanh") DoubleKind
 361
 362         FloatPowerOp -> call SLIT("pow") DoubleKind
 363
 364         DoubleAddOp -> trivialFCode (FADD TF) args
 365         DoubleSubOp -> trivialFCode (FSUB TF) args
 366         DoubleMulOp -> trivialFCode (FMUL TF) args
 367         DoubleDivOp -> trivialFCode (FDIV TF) args
 368         DoubleNegOp -> trivialUFCode (FNEG TF) args
 369
 370         DoubleGtOp -> cmpFCode (FCMP TF LE) EQ args
 371         DoubleGeOp -> cmpFCode (FCMP TF LT) EQ args
 372         DoubleEqOp -> cmpFCode (FCMP TF EQ) NE args
 373         DoubleNeOp -> cmpFCode (FCMP TF EQ) EQ args
 374         DoubleLtOp -> cmpFCode (FCMP TF LT) NE args
 375         DoubleLeOp -> cmpFCode (FCMP TF LE) NE args
 376
 377         DoubleExpOp -> call SLIT("exp") DoubleKind
 378         DoubleLogOp -> call SLIT("log") DoubleKind
 379         DoubleSqrtOp -> call SLIT("sqrt") DoubleKind
 380
 381         DoubleSinOp -> call SLIT("sin") DoubleKind
 382         DoubleCosOp -> call SLIT("cos") DoubleKind
 383         DoubleTanOp -> call SLIT("tan") DoubleKind
 384
 385         DoubleAsinOp -> call SLIT("asin") DoubleKind
 386         DoubleAcosOp -> call SLIT("acos") DoubleKind
 387         DoubleAtanOp -> call SLIT("atan") DoubleKind
 388
 389         DoubleSinhOp -> call SLIT("sinh") DoubleKind
 390         DoubleCoshOp -> call SLIT("cosh") DoubleKind
 391         DoubleTanhOp -> call SLIT("tanh") DoubleKind
 392
 393         DoublePowerOp -> call SLIT("pow") DoubleKind
 394
 395         OrdOp -> coerceIntCode IntKind args
 396         ChrOp -> chrCode args
 397
 398         Float2IntOp -> coerceFP2Int args
 399         Int2FloatOp -> coerceInt2FP args
 400         Double2IntOp -> coerceFP2Int args
 401         Int2DoubleOp -> coerceInt2FP args
 402
 403         Double2FloatOp -> coerceFltCode args
 404         Float2DoubleOp -> coerceFltCode args
 405
 406   where
 407     call fn pk = getReg (StCall fn pk args)
 408
 409 getReg (StInd pk mem) =
 410     getAmode mem                    `thenSUs` \ amode ->
 411     let
 412         code = amodeCode amode
 413         src   = amodeAddr amode
 414         size = kindToSize pk
 415         code__2 dst = code . mkSeqInstr (LD size dst src)
 416     in
 417         returnSUs (Any pk code__2)
 418
 419 getReg (StInt i)
 420   | is8Bits i =
 421     let
 422         code dst = mkSeqInstr (OR zero (RIImm src) dst)
 423     in
 424         returnSUs (Any IntKind code)
 425   | otherwise =
 426     let
 427         code dst = mkSeqInstr (LDI Q dst src)
 428     in
 429         returnSUs (Any IntKind code)
 430   where
 431     src = ImmInt (fromInteger i)
 432
 433 getReg leaf
 434   | maybeToBool imm =
 435     let
 436         code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
 437     in
 438         returnSUs (Any PtrKind code)
 439   where
 440     imm = maybeImm leaf
 441     imm__2 = case imm of Just x -> x
 442
 443 \end{code}
 444
 445 Now, given a tree (the argument to an StInd) that references memory,
 446 produce a suitable addressing mode.
 447
 448 \begin{code}
 449
 450 getAmode :: StixTree -> SUniqSM Amode
 451
 452 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
 453
 454 getAmode (StPrim IntSubOp [x, StInt i]) =
 455     getNewRegNCG PtrKind            `thenSUs` \ tmp ->
 456     getReg x                        `thenSUs` \ register ->
 457     let
 458         code = registerCode register tmp
 459         reg  = registerName register tmp
 460         off  = ImmInt (-(fromInteger i))
 461     in
 462         returnSUs (Amode (AddrRegImm reg off) code)
 463
 464
 465 getAmode (StPrim IntAddOp [x, StInt i]) =
 466     getNewRegNCG PtrKind            `thenSUs` \ tmp ->
 467     getReg x                        `thenSUs` \ register ->
 468     let
 469         code = registerCode register tmp
 470         reg  = registerName register tmp
 471         off  = ImmInt (fromInteger i)
 472     in
 473         returnSUs (Amode (AddrRegImm reg off) code)
 474
 475 getAmode leaf
 476   | maybeToBool imm =
 477         returnSUs (Amode (AddrImm imm__2) id)
 478   where
 479     imm = maybeImm leaf
 480     imm__2 = case imm of Just x -> x
 481
 482 getAmode other =
 483     getNewRegNCG PtrKind            `thenSUs` \ tmp ->
 484     getReg other                    `thenSUs` \ register ->
 485     let
 486         code = registerCode register tmp
 487         reg  = registerName register tmp
 488     in
 489         returnSUs (Amode (AddrReg reg) code)
 490
 491 \end{code}
 492
 493 Try to get a value into a specific register (or registers) for a call.
 494 The first 6 arguments go into the appropriate argument register
 495 (separate registers for integer and floating point arguments, but used
 496 in lock-step), and the remaining arguments are dumped to the stack,
 497 beginning at 0(sp).  Our first argument is a pair of the list of
 498 remaining argument registers to be assigned for this call and the next
 499 stack offset to use for overflowing arguments.  This way, @getCallArg@
 500 can be applied to all of a call's arguments using @mapAccumL@.
 501
 502 \begin{code}
 503
 504 getCallArg
 505     :: ([(Reg,Reg)],Int)    -- Argument registers and stack offset (accumulator)
 506     -> StixTree             -- Current argument
 507     -> SUniqSM (([(Reg,Reg)],Int), CodeBlock AlphaInstr) -- Updated accumulator and code
 508
 509 -- We have to use up all of our argument registers first.
 510
 511 getCallArg ((iDst,fDst):dsts, offset) arg =
 512     getReg arg                      `thenSUs` \ register ->
 513     let
 514         reg = if isFloatingKind pk then fDst else iDst
 515         code = registerCode register reg
 516         src = registerName register reg
 517         pk = registerKind register
 518     in
 519         returnSUs (
 520             if isFloatingKind pk then
 521                 ((dsts, offset), if isFixed register then
 522                     code . mkSeqInstr (FMOV src fDst)
 523                     else code)
 524             else
 525                 ((dsts, offset), if isFixed register then
 526                     code . mkSeqInstr (OR src (RIReg src) iDst)
 527                     else code))
 528
 529 -- Once we have run out of argument registers, we move to the stack
 530
 531 getCallArg ([], offset) arg =
 532     getReg arg                      `thenSUs` \ register ->
 533     getNewRegNCG (registerKind register)
 534                                     `thenSUs` \ tmp ->
 535     let
 536         code = registerCode register tmp
 537         src = registerName register tmp
 538         pk = registerKind register
 539         sz = kindToSize pk
 540     in
 541         returnSUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
 542
 543 \end{code}
 544
 545 Assignments are really at the heart of the whole code generation business.
 546 Almost all top-level nodes of any real importance are assignments, which
 547 correspond to loads, stores, or register transfers.  If we're really lucky,
 548 some of the register transfers will go away, because we can use the destination
 549 register to complete the code generation for the right hand side.  This only
 550 fails when the right hand side is forced into a fixed register (e.g. the result
 551 of a call).
 552
 553 \begin{code}
 554
 555 assignIntCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock AlphaInstr)
 556
 557 assignIntCode pk (StInd _ dst) src =
 558     getNewRegNCG IntKind            `thenSUs` \ tmp ->
 559     getAmode dst                    `thenSUs` \ amode ->
 560     getReg src                      `thenSUs` \ register ->
 561     let
 562         code1 = amodeCode amode asmVoid
 563         dst__2  = amodeAddr amode
 564         code2 = registerCode register tmp asmVoid
 565         src__2  = registerName register tmp
 566         sz    = kindToSize pk
 567         code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
 568     in
 569         returnSUs code__2
 570
 571 assignIntCode pk dst src =
 572     getReg dst                      `thenSUs` \ register1 ->
 573     getReg src                      `thenSUs` \ register2 ->
 574     let
 575         dst__2 = registerName register1 zero
 576         code = registerCode register2 dst__2
 577         src__2 = registerName register2 dst__2
 578         code__2 = if isFixed register2 then
 579                     code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
 580                 else code
 581     in
 582         returnSUs code__2
 583
 584 assignFltCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock AlphaInstr)
 585
 586 assignFltCode pk (StInd _ dst) src =
 587     getNewRegNCG pk                 `thenSUs` \ tmp ->
 588     getAmode dst                    `thenSUs` \ amode ->
 589     getReg src                      `thenSUs` \ register ->
 590     let
 591         code1 = amodeCode amode asmVoid
 592         dst__2  = amodeAddr amode
 593         code2 = registerCode register tmp asmVoid
 594         src__2  = registerName register tmp
 595         sz    = kindToSize pk
 596         code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
 597     in
 598         returnSUs code__2
 599
 600 assignFltCode pk dst src =
 601     getReg dst                      `thenSUs` \ register1 ->
 602     getReg src                      `thenSUs` \ register2 ->
 603     let
 604         dst__2 = registerName register1 zero
 605         code = registerCode register2 dst__2
 606         src__2 = registerName register2 dst__2
 607         code__2 = if isFixed register2 then
 608                     code . mkSeqInstr (FMOV src__2 dst__2)
 609                 else code
 610     in
 611         returnSUs code__2
 612
 613 \end{code}
 614
 615 Generating an unconditional branch.  We accept two types of targets:
 616 an immediate CLabel or a tree that gets evaluated into a register.
 617 Any CLabels which are AsmTemporaries are assumed to be in the local
 618 block of code, close enough for a branch instruction.  Other CLabels
 619 are assumed to be far away, so we use jmp.
 620
 621 \begin{code}
 622
 623 genJump
 624     :: StixTree     -- the branch target
 625     -> SUniqSM (CodeBlock AlphaInstr)
 626
 627 genJump (StCLbl lbl)
 628   | isAsmTemp lbl = returnInstr (BR target)
 629   | otherwise     = returnInstrs [LDA pv (AddrImm target), JMP zero (AddrReg pv) 0]
 630   where
 631     target = ImmCLbl lbl
 632
 633 genJump tree =
 634     getReg tree                     `thenSUs` \ register ->
 635     getNewRegNCG PtrKind            `thenSUs` \ tmp ->
 636     let
 637         dst = registerName register pv
 638         code = registerCode register pv
 639         target = registerName register pv
 640     in
 641         if isFixed register then
 642             returnSeq code [OR dst (RIReg dst) pv, JMP zero (AddrReg pv) 0]
 643         else
 644             returnSUs (code . mkSeqInstr (JMP zero (AddrReg pv) 0))
 645
 646 \end{code}
 647
 648 Conditional jumps are always to local labels, so we can use
 649 branch instructions.  We peek at the arguments to decide what kind
 650 of comparison to do.  For comparisons with 0, we're laughing, because
 651 we can just do the desired conditional branch.
 652
 653 \begin{code}
 654
 655 genCondJump
 656     :: CLabel       -- the branch target
 657     -> StixTree     -- the condition on which to branch
 658     -> SUniqSM (CodeBlock AlphaInstr)
 659
 660 genCondJump lbl (StPrim op [x, StInt 0]) =
 661     getReg x                        `thenSUs` \ register ->
 662     getNewRegNCG (registerKind register)
 663                                     `thenSUs` \ tmp ->
 664     let
 665         code = registerCode register tmp
 666         value = registerName register tmp
 667         pk = registerKind register
 668         target = ImmCLbl lbl
 669     in
 670             returnSeq code [BI (cmpOp op) value target]
 671   where
 672     cmpOp CharGtOp = GT
 673     cmpOp CharGeOp = GE
 674     cmpOp CharEqOp = EQ
 675     cmpOp CharNeOp = NE
 676     cmpOp CharLtOp = LT
 677     cmpOp CharLeOp = LE
 678     cmpOp IntGtOp = GT
 679     cmpOp IntGeOp = GE
 680     cmpOp IntEqOp = EQ
 681     cmpOp IntNeOp = NE
 682     cmpOp IntLtOp = LT
 683     cmpOp IntLeOp = LE
 684     cmpOp WordGtOp = NE
 685     cmpOp WordGeOp = ALWAYS
 686     cmpOp WordEqOp = EQ
 687     cmpOp WordNeOp = NE
 688     cmpOp WordLtOp = NEVER
 689     cmpOp WordLeOp = EQ
 690     cmpOp AddrGtOp = NE
 691     cmpOp AddrGeOp = ALWAYS
 692     cmpOp AddrEqOp = EQ
 693     cmpOp AddrNeOp = NE
 694     cmpOp AddrLtOp = NEVER
 695     cmpOp AddrLeOp = EQ
 696
 697 genCondJump lbl (StPrim op [x, StDouble 0.0]) =
 698     getReg x                        `thenSUs` \ register ->
 699     getNewRegNCG (registerKind register)
 700                                     `thenSUs` \ tmp ->
 701     let
 702         code = registerCode register tmp
 703         value = registerName register tmp
 704         pk = registerKind register
 705         target = ImmCLbl lbl
 706     in
 707             returnSUs (code . mkSeqInstr (BF (cmpOp op) value target))
 708   where
 709     cmpOp FloatGtOp = GT
 710     cmpOp FloatGeOp = GE
 711     cmpOp FloatEqOp = EQ
 712     cmpOp FloatNeOp = NE
 713     cmpOp FloatLtOp = LT
 714     cmpOp FloatLeOp = LE
 715     cmpOp DoubleGtOp = GT
 716     cmpOp DoubleGeOp = GE
 717     cmpOp DoubleEqOp = EQ
 718     cmpOp DoubleNeOp = NE
 719     cmpOp DoubleLtOp = LT
 720     cmpOp DoubleLeOp = LE
 721
 722 genCondJump lbl (StPrim op args)
 723   | fltCmpOp op =
 724     trivialFCode instr args         `thenSUs` \ register ->
 725     getNewRegNCG DoubleKind         `thenSUs` \ tmp ->
 726     let
 727         code = registerCode register tmp
 728         result = registerName register tmp
 729         target = ImmCLbl lbl
 730     in
 731         returnSUs (code . mkSeqInstr (BF cond result target))
 732   where
 733     fltCmpOp op = case op of
 734         FloatGtOp -> True
 735         FloatGeOp -> True
 736         FloatEqOp -> True
 737         FloatNeOp -> True
 738         FloatLtOp -> True
 739         FloatLeOp -> True
 740         DoubleGtOp -> True
 741         DoubleGeOp -> True
 742         DoubleEqOp -> True
 743         DoubleNeOp -> True
 744         DoubleLtOp -> True
 745         DoubleLeOp -> True
 746         _ -> False
 747     (instr, cond) = case op of
 748         FloatGtOp -> (FCMP TF LE, EQ)
 749         FloatGeOp -> (FCMP TF LT, EQ)
 750         FloatEqOp -> (FCMP TF EQ, NE)
 751         FloatNeOp -> (FCMP TF EQ, EQ)
 752         FloatLtOp -> (FCMP TF LT, NE)
 753         FloatLeOp -> (FCMP TF LE, NE)
 754         DoubleGtOp -> (FCMP TF LE, EQ)
 755         DoubleGeOp -> (FCMP TF LT, EQ)
 756         DoubleEqOp -> (FCMP TF EQ, NE)
 757         DoubleNeOp -> (FCMP TF EQ, EQ)
 758         DoubleLtOp -> (FCMP TF LT, NE)
 759         DoubleLeOp -> (FCMP TF LE, NE)
 760
 761 genCondJump lbl (StPrim op args) =
 762     trivialCode instr args          `thenSUs` \ register ->
 763     getNewRegNCG IntKind            `thenSUs` \ tmp ->
 764     let
 765         code = registerCode register tmp
 766         result = registerName register tmp
 767         target = ImmCLbl lbl
 768     in
 769         returnSUs (code . mkSeqInstr (BI cond result target))
 770   where
 771     (instr, cond) = case op of
 772         CharGtOp -> (CMP LE, EQ)
 773         CharGeOp -> (CMP LT, EQ)
 774         CharEqOp -> (CMP EQ, NE)
 775         CharNeOp -> (CMP EQ, EQ)
 776         CharLtOp -> (CMP LT, NE)
 777         CharLeOp -> (CMP LE, NE)
 778         IntGtOp -> (CMP LE, EQ)
 779         IntGeOp -> (CMP LT, EQ)
 780         IntEqOp -> (CMP EQ, NE)
 781         IntNeOp -> (CMP EQ, EQ)
 782         IntLtOp -> (CMP LT, NE)
 783         IntLeOp -> (CMP LE, NE)
 784         WordGtOp -> (CMP ULE, EQ)
 785         WordGeOp -> (CMP ULT, EQ)
 786         WordEqOp -> (CMP EQ, NE)
 787         WordNeOp -> (CMP EQ, EQ)
 788         WordLtOp -> (CMP ULT, NE)
 789         WordLeOp -> (CMP ULE, NE)
 790         AddrGtOp -> (CMP ULE, EQ)
 791         AddrGeOp -> (CMP ULT, EQ)
 792         AddrEqOp -> (CMP EQ, NE)
 793         AddrNeOp -> (CMP EQ, EQ)
 794         AddrLtOp -> (CMP ULT, NE)
 795         AddrLeOp -> (CMP ULE, NE)
 796
 797 \end{code}
 798
 799 Now the biggest nightmare---calls.  Most of the nastiness is buried in
 800 getCallArg, which moves the arguments to the correct registers/stack
 801 locations.  Apart from that, the code is easy.
 802
 803 \begin{code}
 804
 805 genCCall
 806     :: FAST_STRING    -- function to call
 807     -> PrimKind     -- type of the result
 808     -> [StixTree]   -- arguments (of mixed type)
 809     -> SUniqSM (CodeBlock AlphaInstr)
 810
 811 genCCall fn kind args =
 812     mapAccumLNCG getCallArg (argRegs,stackArgLoc) args
 813                                     `thenSUs` \ ((unused,_), argCode) ->
 814     let
 815         nRegs = length argRegs - length unused
 816         code = asmParThen (map ($ asmVoid) argCode)
 817     in
 818         returnSeq code [
 819             LDA pv (AddrImm (ImmLab (uppPStr fn))),
 820             JSR ra (AddrReg pv) nRegs,
 821             LDGP gp (AddrReg ra)]
 822   where
 823     mapAccumLNCG f b []     = returnSUs (b, [])
 824     mapAccumLNCG f b (x:xs) =
 825         f b x                               `thenSUs` \ (b__2, x__2) ->
 826         mapAccumLNCG f b__2 xs              `thenSUs` \ (b__3, xs__2) ->
 827         returnSUs (b__3, x__2:xs__2)
 828
 829 \end{code}
 830
 831 Trivial (dyadic) instructions.  Only look for constants on the right hand
 832 side, because that's where the generic optimizer will have put them.
 833
 834 \begin{code}
 835
 836 trivialCode
 837     :: (Reg -> RI -> Reg -> AlphaInstr)
 838     -> [StixTree]
 839     -> SUniqSM Register
 840
 841 trivialCode instr [x, StInt y]
 842   | is8Bits y =
 843     getReg x                        `thenSUs` \ register ->
 844     getNewRegNCG IntKind            `thenSUs` \ tmp ->
 845     let
 846         code = registerCode register tmp
 847         src1 = registerName register tmp
 848         src2 = ImmInt (fromInteger y)
 849         code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
 850     in
 851         returnSUs (Any IntKind code__2)
 852
 853 trivialCode instr [x, y] =
 854     getReg x                        `thenSUs` \ register1 ->
 855     getReg y                        `thenSUs` \ register2 ->
 856     getNewRegNCG IntKind            `thenSUs` \ tmp1 ->
 857     getNewRegNCG IntKind            `thenSUs` \ tmp2 ->
 858     let
 859         code1 = registerCode register1 tmp1 asmVoid
 860         src1  = registerName register1 tmp1
 861         code2 = registerCode register2 tmp2 asmVoid
 862         src2  = registerName register2 tmp2
 863         code__2 dst = asmParThen [code1, code2] .
 864                      mkSeqInstr (instr src1 (RIReg src2) dst)
 865     in
 866         returnSUs (Any IntKind code__2)
 867
 868 trivialFCode
 869     :: (Reg -> Reg -> Reg -> AlphaInstr)
 870     -> [StixTree]
 871     -> SUniqSM Register
 872
 873 trivialFCode instr [x, y] =
 874     getReg x                        `thenSUs` \ register1 ->
 875     getReg y                        `thenSUs` \ register2 ->
 876     getNewRegNCG DoubleKind         `thenSUs` \ tmp1 ->
 877     getNewRegNCG DoubleKind         `thenSUs` \ tmp2 ->
 878     let
 879         code1 = registerCode register1 tmp1
 880         src1  = registerName register1 tmp1
 881
 882         code2 = registerCode register2 tmp2
 883         src2  = registerName register2 tmp2
 884
 885         code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
 886                       mkSeqInstr (instr src1 src2 dst)
 887     in
 888         returnSUs (Any DoubleKind code__2)
 889
 890 \end{code}
 891
 892 Some bizarre special code for getting condition codes into registers.
 893 Integer non-equality is a test for equality followed by an XOR with 1.
 894 (Integer comparisons always set the result register to 0 or 1.)  Floating
 895 point comparisons of any kind leave the result in a floating point register,
 896 so we need to wrangle an integer register out of things.
 897
 898 \begin{code}
 899 intNECode
 900     :: [StixTree]
 901     -> SUniqSM Register
 902
 903 intNECode args =
 904     trivialCode (CMP EQ) args       `thenSUs` \ register ->
 905     getNewRegNCG IntKind            `thenSUs` \ tmp ->
 906     let
 907         code = registerCode register tmp
 908         src  = registerName register tmp
 909         code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
 910     in
 911         returnSUs (Any IntKind code__2)
 912
 913 cmpFCode
 914     :: (Reg -> Reg -> Reg -> AlphaInstr)
 915     -> Cond
 916     -> [StixTree]
 917     -> SUniqSM Register
 918
 919 cmpFCode instr cond args =
 920     trivialFCode instr args         `thenSUs` \ register ->
 921     getNewRegNCG DoubleKind         `thenSUs` \ tmp ->
 922     getUniqLabelNCG                 `thenSUs` \ lbl ->
 923     let
 924         code = registerCode register tmp
 925         result  = registerName register tmp
 926
 927         code__2 dst = code . mkSeqInstrs [
 928             OR zero (RIImm (ImmInt 1)) dst,
 929             BF cond result (ImmCLbl lbl),
 930             OR zero (RIReg zero) dst,
 931             LABEL lbl]
 932     in
 933         returnSUs (Any IntKind code__2)
 934
 935 \end{code}
 936
 937 Trivial unary instructions.  Note that we don't have to worry about
 938 matching an StInt as the argument, because genericOpt will already
 939 have handled the constant-folding.
 940
 941 \begin{code}
 942
 943 trivialUCode
 944     :: (RI -> Reg -> AlphaInstr)
 945     -> [StixTree]
 946     -> SUniqSM Register
 947
 948 trivialUCode instr [x] =
 949     getReg x                        `thenSUs` \ register ->
 950     getNewRegNCG IntKind            `thenSUs` \ tmp ->
 951     let
 952         code = registerCode register tmp
 953         src  = registerName register tmp
 954         code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
 955     in
 956         returnSUs (Any IntKind code__2)
 957
 958 trivialUFCode
 959     :: (Reg -> Reg -> AlphaInstr)
 960     -> [StixTree]
 961     -> SUniqSM Register
 962
 963 trivialUFCode instr [x] =
 964     getReg x                        `thenSUs` \ register ->
 965     getNewRegNCG DoubleKind         `thenSUs` \ tmp ->
 966     let
 967         code = registerCode register tmp
 968         src  = registerName register tmp
 969         code__2 dst = code . mkSeqInstr (instr src dst)
 970     in
 971         returnSUs (Any DoubleKind code__2)
 972
 973 \end{code}
 974
 975 Simple coercions that don't require any code to be generated.
 976 Here we just change the type on the register passed on up
 977
 978 \begin{code}
 979
 980 coerceIntCode :: PrimKind -> [StixTree] -> SUniqSM Register
 981 coerceIntCode pk [x] =
 982     getReg x                        `thenSUs` \ register ->
 983     case register of
 984         Fixed reg _ code -> returnSUs (Fixed reg pk code)
 985         Any _ code       -> returnSUs (Any pk code)
 986
 987 coerceFltCode :: [StixTree] -> SUniqSM Register
 988 coerceFltCode [x] =
 989     getReg x                        `thenSUs` \ register ->
 990     case register of
 991         Fixed reg _ code -> returnSUs (Fixed reg DoubleKind code)
 992         Any _ code       -> returnSUs (Any DoubleKind code)
 993
 994 \end{code}
 995
 996 Integer to character conversion.
 997
 998 \begin{code}
 999
1000 chrCode [x] =
1001     getReg x                        `thenSUs` \ register ->
1002     getNewRegNCG IntKind            `thenSUs` \ reg ->
1003     let
1004         code = registerCode register reg
1005         src  = registerName register reg
1006         code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
1007     in
1008         returnSUs (Any IntKind code__2)
1009
1010 \end{code}
1011
1012 More complicated integer/float conversions.  Here we have to store
1013 temporaries in memory to move between the integer and the floating
1014 point register sets.
1015
1016 \begin{code}
1017
1018 coerceInt2FP :: [StixTree] -> SUniqSM Register
1019 coerceInt2FP [x] =
1020     getReg x                        `thenSUs` \ register ->
1021     getNewRegNCG IntKind            `thenSUs` \ reg ->
1022     let
1023         code = registerCode register reg
1024         src  = registerName register reg
1025
1026         code__2 dst = code . mkSeqInstrs [
1027             ST Q src (spRel 0),
1028             LD TF dst (spRel 0),
1029             CVTxy Q TF dst dst]
1030     in
1031         returnSUs (Any DoubleKind code__2)
1032
1033 coerceFP2Int :: [StixTree] -> SUniqSM Register
1034 coerceFP2Int [x] =
1035     getReg x                        `thenSUs` \ register ->
1036     getNewRegNCG DoubleKind         `thenSUs` \ tmp ->
1037     let
1038         code = registerCode register tmp
1039         src  = registerName register tmp
1040
1041         code__2 dst = code . mkSeqInstrs [
1042             CVTxy TF Q src tmp,
1043             ST TF tmp (spRel 0),
1044             LD Q dst (spRel 0)]
1045     in
1046         returnSUs (Any IntKind code__2)
1047
1048 \end{code}
1049
1050 Some random little helpers.
1051
1052 \begin{code}
1053
1054 is8Bits :: Integer -> Bool
1055 is8Bits i = i >= -256 && i < 256
1056
1057 maybeImm :: StixTree -> Maybe Imm
1058 maybeImm (StInt i)
1059   | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
1060   | otherwise = Just (ImmInteger i)
1061 maybeImm (StLitLbl s)  = Just (ImmLab s)
1062 maybeImm (StLitLit s)  = Just (strImmLab (cvtLitLit (_UNPK_ s)))
1063 maybeImm (StCLbl l) = Just (ImmCLbl l)
1064 maybeImm _          = Nothing
1065
1066 mangleIndexTree :: StixTree -> StixTree
1067
1068 mangleIndexTree (StIndex pk base (StInt i)) =
1069     StPrim IntAddOp [base, off]
1070   where
1071     off = StInt (i * size pk)
1072     size :: PrimKind -> Integer
1073     size pk = case kindToSize pk of
1074         {B -> 1; BU -> 1; W -> 2; WU -> 2; L -> 4; FF -> 4; SF -> 4; _ -> 8}
1075
1076 mangleIndexTree (StIndex pk base off) =
1077     case pk of
1078         CharKind -> StPrim IntAddOp [base, off]
1079         _        -> StPrim IntAddOp [base, off__2]
1080   where
1081     off__2 = StPrim SllOp [off, StInt 3]
1082
1083 cvtLitLit :: String -> String
1084 cvtLitLit "stdin" = "_iob+0"   -- This one is probably okay...
1085 cvtLitLit "stdout" = "_iob+56" -- but these next two are dodgy at best
1086 cvtLitLit "stderr" = "_iob+112"
1087 cvtLitLit s
1088   | isHex s = s
1089   | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
1090   where
1091     isHex ('0':'x':xs) = all isHexDigit xs
1092     isHex _ = False
1093     -- Now, where have I seen this before?
1094     isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'
1095
1096
1097 \end{code}
1098
1099 spRel gives us a stack relative addressing mode for volatile temporaries
1100 and for excess call arguments.
1101
1102 \begin{code}
1103
1104 spRel
1105     :: Int      -- desired stack offset in words, positive or negative
1106     -> Addr
1107 spRel n = AddrRegImm sp (ImmInt (n * 8))
1108
1109 stackArgLoc = 0 :: Int      -- where to stack extra call arguments (beyond 6)
1110
1111 \end{code}
1112
1113 \begin{code}
1114
1115 getNewRegNCG :: PrimKind -> SUniqSM Reg
1116 getNewRegNCG pk =
1117       getSUnique          `thenSUs` \ u ->
1118       returnSUs (mkReg u pk)
1119
1120 \end{code}