2 % (c) The AQUA Project, Glasgow University, 1993-1995
6 #include "HsVersions.h"
11 -- and, for self-sufficiency
12 PprStyle, StixTree, CSeq
17 import AbsCSyn ( AbstractC, MagicId(..), kindFromMagicId )
18 import AbsPrel ( PrimOp(..)
19 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
20 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
22 import AsmRegAlloc ( runRegAllocate, extractMappedRegNos, mkReg,
23 Reg(..), RegLiveness(..), RegUsage(..), FutureLive(..),
24 MachineRegisters(..), MachineCode(..)
26 import CLabelInfo ( CLabel, isAsmTemp )
27 import AlphaCode {- everything -}
29 import Maybes ( maybeToBool, Maybe(..) )
30 import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
32 import PrimKind ( PrimKind(..), isFloatingKind )
41 type CodeBlock a = (OrdList a -> OrdList a)
45 %************************************************************************
47 \subsection[AlphaCodeGen]{Generating Alpha Code}
49 %************************************************************************
51 This is the top-level code-generation function for the Alpha.
55 alphaCodeGen :: PprStyle -> [[StixTree]] -> SUniqSM Unpretty
56 alphaCodeGen sty trees =
57 mapSUs genAlphaCode trees `thenSUs` \ dynamicCodes ->
59 staticCodes = scheduleAlphaCode dynamicCodes
60 pretty = printLabeledCodes sty staticCodes
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.
72 scheduleAlphaCode :: [AlphaCode] -> [AlphaInstr]
73 scheduleAlphaCode = concat . map (runRegAllocate freeAlphaRegs reservedRegs)
75 freeAlphaRegs :: AlphaRegs
76 freeAlphaRegs = mkMRegs (extractMappedRegNos freeRegs)
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.
88 = Fixed Reg PrimKind (CodeBlock AlphaInstr)
89 | Any PrimKind (Reg -> (CodeBlock AlphaInstr))
91 registerCode :: Register -> Reg -> CodeBlock AlphaInstr
92 registerCode (Fixed _ _ code) reg = code
93 registerCode (Any _ code) reg = code reg
95 registerName :: Register -> Reg -> Reg
96 registerName (Fixed reg _ _) _ = reg
97 registerName (Any _ _) reg = reg
99 registerKind :: Register -> PrimKind
100 registerKind (Fixed _ pk _) = pk
101 registerKind (Any pk _) = pk
103 isFixed :: Register -> Bool
104 isFixed (Fixed _ _ _) = True
105 isFixed (Any _ _) = False
109 Memory addressing modes passed up the tree.
113 data Amode = Amode Addr (CodeBlock AlphaInstr)
115 amodeAddr (Amode addr _) = addr
116 amodeCode (Amode _ code) = code
120 General things for putting together code sequences.
124 asmVoid :: OrdList AlphaInstr
125 asmVoid = mkEmptyList
127 asmInstr :: AlphaInstr -> AlphaCode
128 asmInstr i = mkUnitList i
130 asmSeq :: [AlphaInstr] -> AlphaCode
131 asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
133 asmParThen :: [AlphaCode] -> CodeBlock AlphaInstr
134 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
136 returnInstr :: AlphaInstr -> SUniqSM (CodeBlock AlphaInstr)
137 returnInstr instr = returnSUs (\xs -> mkSeqList (asmInstr instr) xs)
139 returnInstrs :: [AlphaInstr] -> SUniqSM (CodeBlock AlphaInstr)
140 returnInstrs instrs = returnSUs (\xs -> mkSeqList (asmSeq instrs) xs)
142 returnSeq :: (CodeBlock AlphaInstr) -> [AlphaInstr] -> SUniqSM (CodeBlock AlphaInstr)
143 returnSeq code instrs = returnSUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
145 mkSeqInstr :: AlphaInstr -> (CodeBlock AlphaInstr)
146 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
148 mkSeqInstrs :: [AlphaInstr] -> (CodeBlock AlphaInstr)
149 mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
153 Top level alpha code generator for a chunk of stix code.
157 genAlphaCode :: [StixTree] -> SUniqSM (AlphaCode)
160 mapSUs getCode trees `thenSUs` \ blocks ->
161 returnSUs (foldr (.) id blocks asmVoid)
165 Code extractor for an entire stix tree---stix statement level.
170 :: StixTree -- a stix statement
171 -> SUniqSM (CodeBlock AlphaInstr)
173 getCode (StSegment seg) = returnInstr (SEGMENT seg)
175 getCode (StAssign pk dst src)
176 | isFloatingKind pk = assignFltCode pk dst src
177 | otherwise = assignIntCode pk dst src
179 getCode (StLabel lab) = returnInstr (LABEL lab)
181 getCode (StFunBegin lab) = returnInstr (FUNBEGIN lab)
183 getCode (StFunEnd lab) = returnInstr (FUNEND lab)
185 getCode (StJump arg) = genJump arg
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)))
191 getCode (StCondJump lbl arg) = genCondJump lbl arg
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))
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)))
204 getData (StDouble d) = returnSUs (id, strImmLab (show d))
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)
213 getCode (StCall fn VoidKind args) = genCCall fn VoidKind args
215 getCode (StComment s) = returnInstr (COMMENT s)
219 Generate code to get a subtree into a register.
223 getReg :: StixTree -> SUniqSM Register
225 getReg (StReg (StixMagicId stgreg)) =
226 case stgRegMap stgreg of
227 Just reg -> returnSUs (Fixed reg (kindFromMagicId stgreg) id)
230 getReg (StReg (StixTemp u pk)) = returnSUs (Fixed (UnmappedReg u pk) pk id)
232 getReg (StDouble d) =
233 getUniqLabelNCG `thenSUs` \ lbl ->
234 getNewRegNCG PtrKind `thenSUs` \ tmp ->
235 let code dst = mkSeqInstrs [
238 #if __GLASGOW_HASKELL__ >= 23
239 -- DATA TF [strImmLab (_showRational 30 d)],
240 DATA TF [ImmLab (prettyToUn (ppRational d))],
242 DATA TF [strImmLab (show d)],
245 LDA tmp (AddrImm (ImmCLbl lbl)),
246 LD TF dst (AddrReg tmp)]
248 returnSUs (Any DoubleKind code)
250 getReg (StString s) =
251 getUniqLabelNCG `thenSUs` \ lbl ->
252 let code dst = mkSeqInstrs [
255 ASCII True (_UNPK_ s),
257 LDA dst (AddrImm (ImmCLbl lbl))]
259 returnSUs (Any PtrKind code)
261 getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
262 getUniqLabelNCG `thenSUs` \ lbl ->
263 let code dst = mkSeqInstrs [
266 ASCII False (init xs),
268 LDA dst (AddrImm (ImmCLbl lbl))]
270 returnSUs (Any PtrKind code)
272 xs = _UNPK_ (_TAIL_ s)
274 getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
276 getReg (StCall fn kind args) =
277 genCCall fn kind args `thenSUs` \ call ->
278 returnSUs (Fixed reg kind call)
280 reg = if isFloatingKind kind then f0 else v0
282 getReg (StPrim primop args) =
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
292 IntAddOp -> trivialCode (ADD Q False) args
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
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"
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
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
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
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
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
346 FloatExpOp -> call SLIT("exp") DoubleKind
347 FloatLogOp -> call SLIT("log") DoubleKind
348 FloatSqrtOp -> call SLIT("sqrt") DoubleKind
350 FloatSinOp -> call SLIT("sin") DoubleKind
351 FloatCosOp -> call SLIT("cos") DoubleKind
352 FloatTanOp -> call SLIT("tan") DoubleKind
354 FloatAsinOp -> call SLIT("asin") DoubleKind
355 FloatAcosOp -> call SLIT("acos") DoubleKind
356 FloatAtanOp -> call SLIT("atan") DoubleKind
358 FloatSinhOp -> call SLIT("sinh") DoubleKind
359 FloatCoshOp -> call SLIT("cosh") DoubleKind
360 FloatTanhOp -> call SLIT("tanh") DoubleKind
362 FloatPowerOp -> call SLIT("pow") DoubleKind
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
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
377 DoubleExpOp -> call SLIT("exp") DoubleKind
378 DoubleLogOp -> call SLIT("log") DoubleKind
379 DoubleSqrtOp -> call SLIT("sqrt") DoubleKind
381 DoubleSinOp -> call SLIT("sin") DoubleKind
382 DoubleCosOp -> call SLIT("cos") DoubleKind
383 DoubleTanOp -> call SLIT("tan") DoubleKind
385 DoubleAsinOp -> call SLIT("asin") DoubleKind
386 DoubleAcosOp -> call SLIT("acos") DoubleKind
387 DoubleAtanOp -> call SLIT("atan") DoubleKind
389 DoubleSinhOp -> call SLIT("sinh") DoubleKind
390 DoubleCoshOp -> call SLIT("cosh") DoubleKind
391 DoubleTanhOp -> call SLIT("tanh") DoubleKind
393 DoublePowerOp -> call SLIT("pow") DoubleKind
395 OrdOp -> coerceIntCode IntKind args
396 ChrOp -> chrCode args
398 Float2IntOp -> coerceFP2Int args
399 Int2FloatOp -> coerceInt2FP args
400 Double2IntOp -> coerceFP2Int args
401 Int2DoubleOp -> coerceInt2FP args
403 Double2FloatOp -> coerceFltCode args
404 Float2DoubleOp -> coerceFltCode args
407 call fn pk = getReg (StCall fn pk args)
409 getReg (StInd pk mem) =
410 getAmode mem `thenSUs` \ amode ->
412 code = amodeCode amode
413 src = amodeAddr amode
415 code__2 dst = code . mkSeqInstr (LD size dst src)
417 returnSUs (Any pk code__2)
422 code dst = mkSeqInstr (OR zero (RIImm src) dst)
424 returnSUs (Any IntKind code)
427 code dst = mkSeqInstr (LDI Q dst src)
429 returnSUs (Any IntKind code)
431 src = ImmInt (fromInteger i)
436 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
438 returnSUs (Any PtrKind code)
441 imm__2 = case imm of Just x -> x
445 Now, given a tree (the argument to an StInd) that references memory,
446 produce a suitable addressing mode.
450 getAmode :: StixTree -> SUniqSM Amode
452 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
454 getAmode (StPrim IntSubOp [x, StInt i]) =
455 getNewRegNCG PtrKind `thenSUs` \ tmp ->
456 getReg x `thenSUs` \ register ->
458 code = registerCode register tmp
459 reg = registerName register tmp
460 off = ImmInt (-(fromInteger i))
462 returnSUs (Amode (AddrRegImm reg off) code)
465 getAmode (StPrim IntAddOp [x, StInt i]) =
466 getNewRegNCG PtrKind `thenSUs` \ tmp ->
467 getReg x `thenSUs` \ register ->
469 code = registerCode register tmp
470 reg = registerName register tmp
471 off = ImmInt (fromInteger i)
473 returnSUs (Amode (AddrRegImm reg off) code)
477 returnSUs (Amode (AddrImm imm__2) id)
480 imm__2 = case imm of Just x -> x
483 getNewRegNCG PtrKind `thenSUs` \ tmp ->
484 getReg other `thenSUs` \ register ->
486 code = registerCode register tmp
487 reg = registerName register tmp
489 returnSUs (Amode (AddrReg reg) code)
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@.
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
509 -- We have to use up all of our argument registers first.
511 getCallArg ((iDst,fDst):dsts, offset) arg =
512 getReg arg `thenSUs` \ register ->
514 reg = if isFloatingKind pk then fDst else iDst
515 code = registerCode register reg
516 src = registerName register reg
517 pk = registerKind register
520 if isFloatingKind pk then
521 ((dsts, offset), if isFixed register then
522 code . mkSeqInstr (FMOV src fDst)
525 ((dsts, offset), if isFixed register then
526 code . mkSeqInstr (OR src (RIReg src) iDst)
529 -- Once we have run out of argument registers, we move to the stack
531 getCallArg ([], offset) arg =
532 getReg arg `thenSUs` \ register ->
533 getNewRegNCG (registerKind register)
536 code = registerCode register tmp
537 src = registerName register tmp
538 pk = registerKind register
541 returnSUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
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
555 assignIntCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock AlphaInstr)
557 assignIntCode pk (StInd _ dst) src =
558 getNewRegNCG IntKind `thenSUs` \ tmp ->
559 getAmode dst `thenSUs` \ amode ->
560 getReg src `thenSUs` \ register ->
562 code1 = amodeCode amode asmVoid
563 dst__2 = amodeAddr amode
564 code2 = registerCode register tmp asmVoid
565 src__2 = registerName register tmp
567 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
571 assignIntCode pk dst src =
572 getReg dst `thenSUs` \ register1 ->
573 getReg src `thenSUs` \ register2 ->
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)
584 assignFltCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock AlphaInstr)
586 assignFltCode pk (StInd _ dst) src =
587 getNewRegNCG pk `thenSUs` \ tmp ->
588 getAmode dst `thenSUs` \ amode ->
589 getReg src `thenSUs` \ register ->
591 code1 = amodeCode amode asmVoid
592 dst__2 = amodeAddr amode
593 code2 = registerCode register tmp asmVoid
594 src__2 = registerName register tmp
596 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
600 assignFltCode pk dst src =
601 getReg dst `thenSUs` \ register1 ->
602 getReg src `thenSUs` \ register2 ->
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)
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.
624 :: StixTree -- the branch target
625 -> SUniqSM (CodeBlock AlphaInstr)
628 | isAsmTemp lbl = returnInstr (BR target)
629 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zero (AddrReg pv) 0]
634 getReg tree `thenSUs` \ register ->
635 getNewRegNCG PtrKind `thenSUs` \ tmp ->
637 dst = registerName register pv
638 code = registerCode register pv
639 target = registerName register pv
641 if isFixed register then
642 returnSeq code [OR dst (RIReg dst) pv, JMP zero (AddrReg pv) 0]
644 returnSUs (code . mkSeqInstr (JMP zero (AddrReg pv) 0))
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.
656 :: CLabel -- the branch target
657 -> StixTree -- the condition on which to branch
658 -> SUniqSM (CodeBlock AlphaInstr)
660 genCondJump lbl (StPrim op [x, StInt 0]) =
661 getReg x `thenSUs` \ register ->
662 getNewRegNCG (registerKind register)
665 code = registerCode register tmp
666 value = registerName register tmp
667 pk = registerKind register
670 returnSeq code [BI (cmpOp op) value target]
685 cmpOp WordGeOp = ALWAYS
688 cmpOp WordLtOp = NEVER
691 cmpOp AddrGeOp = ALWAYS
694 cmpOp AddrLtOp = NEVER
697 genCondJump lbl (StPrim op [x, StDouble 0.0]) =
698 getReg x `thenSUs` \ register ->
699 getNewRegNCG (registerKind register)
702 code = registerCode register tmp
703 value = registerName register tmp
704 pk = registerKind register
707 returnSUs (code . mkSeqInstr (BF (cmpOp op) value target))
715 cmpOp DoubleGtOp = GT
716 cmpOp DoubleGeOp = GE
717 cmpOp DoubleEqOp = EQ
718 cmpOp DoubleNeOp = NE
719 cmpOp DoubleLtOp = LT
720 cmpOp DoubleLeOp = LE
722 genCondJump lbl (StPrim op args)
724 trivialFCode instr args `thenSUs` \ register ->
725 getNewRegNCG DoubleKind `thenSUs` \ tmp ->
727 code = registerCode register tmp
728 result = registerName register tmp
731 returnSUs (code . mkSeqInstr (BF cond result target))
733 fltCmpOp op = case op of
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)
761 genCondJump lbl (StPrim op args) =
762 trivialCode instr args `thenSUs` \ register ->
763 getNewRegNCG IntKind `thenSUs` \ tmp ->
765 code = registerCode register tmp
766 result = registerName register tmp
769 returnSUs (code . mkSeqInstr (BI cond result target))
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)
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.
806 :: FAST_STRING -- function to call
807 -> PrimKind -- type of the result
808 -> [StixTree] -- arguments (of mixed type)
809 -> SUniqSM (CodeBlock AlphaInstr)
811 genCCall fn kind args =
812 mapAccumLNCG getCallArg (argRegs,stackArgLoc) args
813 `thenSUs` \ ((unused,_), argCode) ->
815 nRegs = length argRegs - length unused
816 code = asmParThen (map ($ asmVoid) argCode)
819 LDA pv (AddrImm (ImmLab (uppPStr fn))),
820 JSR ra (AddrReg pv) nRegs,
821 LDGP gp (AddrReg ra)]
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)
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.
837 :: (Reg -> RI -> Reg -> AlphaInstr)
841 trivialCode instr [x, StInt y]
843 getReg x `thenSUs` \ register ->
844 getNewRegNCG IntKind `thenSUs` \ tmp ->
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)
851 returnSUs (Any IntKind code__2)
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 ->
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)
866 returnSUs (Any IntKind code__2)
869 :: (Reg -> Reg -> Reg -> AlphaInstr)
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 ->
879 code1 = registerCode register1 tmp1
880 src1 = registerName register1 tmp1
882 code2 = registerCode register2 tmp2
883 src2 = registerName register2 tmp2
885 code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
886 mkSeqInstr (instr src1 src2 dst)
888 returnSUs (Any DoubleKind code__2)
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.
904 trivialCode (CMP EQ) args `thenSUs` \ register ->
905 getNewRegNCG IntKind `thenSUs` \ tmp ->
907 code = registerCode register tmp
908 src = registerName register tmp
909 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
911 returnSUs (Any IntKind code__2)
914 :: (Reg -> Reg -> Reg -> AlphaInstr)
919 cmpFCode instr cond args =
920 trivialFCode instr args `thenSUs` \ register ->
921 getNewRegNCG DoubleKind `thenSUs` \ tmp ->
922 getUniqLabelNCG `thenSUs` \ lbl ->
924 code = registerCode register tmp
925 result = registerName register tmp
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,
933 returnSUs (Any IntKind code__2)
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.
944 :: (RI -> Reg -> AlphaInstr)
948 trivialUCode instr [x] =
949 getReg x `thenSUs` \ register ->
950 getNewRegNCG IntKind `thenSUs` \ tmp ->
952 code = registerCode register tmp
953 src = registerName register tmp
954 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
956 returnSUs (Any IntKind code__2)
959 :: (Reg -> Reg -> AlphaInstr)
963 trivialUFCode instr [x] =
964 getReg x `thenSUs` \ register ->
965 getNewRegNCG DoubleKind `thenSUs` \ tmp ->
967 code = registerCode register tmp
968 src = registerName register tmp
969 code__2 dst = code . mkSeqInstr (instr src dst)
971 returnSUs (Any DoubleKind code__2)
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
980 coerceIntCode :: PrimKind -> [StixTree] -> SUniqSM Register
981 coerceIntCode pk [x] =
982 getReg x `thenSUs` \ register ->
984 Fixed reg _ code -> returnSUs (Fixed reg pk code)
985 Any _ code -> returnSUs (Any pk code)
987 coerceFltCode :: [StixTree] -> SUniqSM Register
989 getReg x `thenSUs` \ register ->
991 Fixed reg _ code -> returnSUs (Fixed reg DoubleKind code)
992 Any _ code -> returnSUs (Any DoubleKind code)
996 Integer to character conversion.
1001 getReg x `thenSUs` \ register ->
1002 getNewRegNCG IntKind `thenSUs` \ reg ->
1004 code = registerCode register reg
1005 src = registerName register reg
1006 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
1008 returnSUs (Any IntKind code__2)
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.
1018 coerceInt2FP :: [StixTree] -> SUniqSM Register
1020 getReg x `thenSUs` \ register ->
1021 getNewRegNCG IntKind `thenSUs` \ reg ->
1023 code = registerCode register reg
1024 src = registerName register reg
1026 code__2 dst = code . mkSeqInstrs [
1028 LD TF dst (spRel 0),
1031 returnSUs (Any DoubleKind code__2)
1033 coerceFP2Int :: [StixTree] -> SUniqSM Register
1035 getReg x `thenSUs` \ register ->
1036 getNewRegNCG DoubleKind `thenSUs` \ tmp ->
1038 code = registerCode register tmp
1039 src = registerName register tmp
1041 code__2 dst = code . mkSeqInstrs [
1043 ST TF tmp (spRel 0),
1046 returnSUs (Any IntKind code__2)
1050 Some random little helpers.
1054 is8Bits :: Integer -> Bool
1055 is8Bits i = i >= -256 && i < 256
1057 maybeImm :: StixTree -> Maybe Imm
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
1066 mangleIndexTree :: StixTree -> StixTree
1068 mangleIndexTree (StIndex pk base (StInt i)) =
1069 StPrim IntAddOp [base, off]
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}
1076 mangleIndexTree (StIndex pk base off) =
1078 CharKind -> StPrim IntAddOp [base, off]
1079 _ -> StPrim IntAddOp [base, off__2]
1081 off__2 = StPrim SllOp [off, StInt 3]
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"
1089 | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
1091 isHex ('0':'x':xs) = all isHexDigit xs
1093 -- Now, where have I seen this before?
1094 isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'
1099 spRel gives us a stack relative addressing mode for volatile temporaries
1100 and for excess call arguments.
1105 :: Int -- desired stack offset in words, positive or negative
1107 spRel n = AddrRegImm sp (ImmInt (n * 8))
1109 stackArgLoc = 0 :: Int -- where to stack extra call arguments (beyond 6)
1115 getNewRegNCG :: PrimKind -> SUniqSM Reg
1117 getSUnique `thenSUs` \ u ->
1118 returnSUs (mkReg u pk)