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