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 PrelInfo ( 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 CLabel ( CLabel, isAsmTemp )
27 import AlphaCode {- everything -}
29 import Maybes ( maybeToBool, Maybe(..) )
30 import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
39 type CodeBlock a = (OrdList a -> OrdList a)
43 %************************************************************************
45 \subsection[AlphaCodeGen]{Generating Alpha Code}
47 %************************************************************************
49 This is the top-level code-generation function for the Alpha.
53 alphaCodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty
54 alphaCodeGen sty trees =
55 mapUs genAlphaCode trees `thenUs` \ dynamicCodes ->
57 staticCodes = scheduleAlphaCode dynamicCodes
58 pretty = printLabeledCodes sty staticCodes
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.
70 scheduleAlphaCode :: [AlphaCode] -> [AlphaInstr]
71 scheduleAlphaCode = concat . map (runRegAllocate freeAlphaRegs reservedRegs)
73 freeAlphaRegs :: AlphaRegs
74 freeAlphaRegs = mkMRegs (extractMappedRegNos freeRegs)
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.
86 = Fixed Reg PrimRep (CodeBlock AlphaInstr)
87 | Any PrimRep (Reg -> (CodeBlock AlphaInstr))
89 registerCode :: Register -> Reg -> CodeBlock AlphaInstr
90 registerCode (Fixed _ _ code) reg = code
91 registerCode (Any _ code) reg = code reg
93 registerName :: Register -> Reg -> Reg
94 registerName (Fixed reg _ _) _ = reg
95 registerName (Any _ _) reg = reg
97 registerKind :: Register -> PrimRep
98 registerKind (Fixed _ pk _) = pk
99 registerKind (Any pk _) = pk
101 isFixed :: Register -> Bool
102 isFixed (Fixed _ _ _) = True
103 isFixed (Any _ _) = False
107 Memory addressing modes passed up the tree.
111 data Amode = Amode Addr (CodeBlock AlphaInstr)
113 amodeAddr (Amode addr _) = addr
114 amodeCode (Amode _ code) = code
118 General things for putting together code sequences.
122 asmVoid :: OrdList AlphaInstr
123 asmVoid = mkEmptyList
125 asmInstr :: AlphaInstr -> AlphaCode
126 asmInstr i = mkUnitList i
128 asmSeq :: [AlphaInstr] -> AlphaCode
129 asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
131 asmParThen :: [AlphaCode] -> CodeBlock AlphaInstr
132 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
134 returnInstr :: AlphaInstr -> UniqSM (CodeBlock AlphaInstr)
135 returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
137 returnInstrs :: [AlphaInstr] -> UniqSM (CodeBlock AlphaInstr)
138 returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
140 returnSeq :: (CodeBlock AlphaInstr) -> [AlphaInstr] -> UniqSM (CodeBlock AlphaInstr)
141 returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
143 mkSeqInstr :: AlphaInstr -> (CodeBlock AlphaInstr)
144 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
146 mkSeqInstrs :: [AlphaInstr] -> (CodeBlock AlphaInstr)
147 mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
151 Top level alpha code generator for a chunk of stix code.
155 genAlphaCode :: [StixTree] -> UniqSM (AlphaCode)
158 mapUs getCode trees `thenUs` \ blocks ->
159 returnUs (foldr (.) id blocks asmVoid)
163 Code extractor for an entire stix tree---stix statement level.
168 :: StixTree -- a stix statement
169 -> UniqSM (CodeBlock AlphaInstr)
171 getCode (StSegment seg) = returnInstr (SEGMENT seg)
173 getCode (StAssign pk dst src)
174 | isFloatingRep pk = assignFltCode pk dst src
175 | otherwise = assignIntCode pk dst src
177 getCode (StLabel lab) = returnInstr (LABEL lab)
179 getCode (StFunBegin lab) = returnInstr (FUNBEGIN lab)
181 getCode (StFunEnd lab) = returnInstr (FUNEND lab)
183 getCode (StJump arg) = genJump arg
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)))
189 getCode (StCondJump lbl arg) = genCondJump lbl arg
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))
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)
206 getCode (StCall fn VoidRep args) = genCCall fn VoidRep args
208 getCode (StComment s) = returnInstr (COMMENT s)
212 Generate code to get a subtree into a register.
216 getReg :: StixTree -> UniqSM Register
218 getReg (StReg (StixMagicId stgreg)) =
219 case stgRegMap stgreg of
220 Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id)
223 getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id)
225 getReg (StDouble d) =
226 getUniqLabelNCG `thenUs` \ lbl ->
227 getNewRegNCG PtrRep `thenUs` \ tmp ->
228 let code dst = mkSeqInstrs [
231 DATA TF [ImmLab (prettyToUn (ppRational d))],
233 LDA tmp (AddrImm (ImmCLbl lbl)),
234 LD TF dst (AddrReg tmp)]
236 returnUs (Any DoubleRep code)
238 getReg (StString s) =
239 getUniqLabelNCG `thenUs` \ lbl ->
240 let code dst = mkSeqInstrs [
243 ASCII True (_UNPK_ s),
245 LDA dst (AddrImm (ImmCLbl lbl))]
247 returnUs (Any PtrRep code)
249 getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
250 getUniqLabelNCG `thenUs` \ lbl ->
251 let code dst = mkSeqInstrs [
254 ASCII False (init xs),
256 LDA dst (AddrImm (ImmCLbl lbl))]
258 returnUs (Any PtrRep code)
260 xs = _UNPK_ (_TAIL_ s)
262 getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
264 getReg (StCall fn kind args) =
265 genCCall fn kind args `thenUs` \ call ->
266 returnUs (Fixed reg kind call)
268 reg = if isFloatingRep kind then f0 else v0
270 getReg (StPrim primop args) =
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
280 IntAddOp -> trivialCode (ADD Q False) args
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
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"
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
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
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
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
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
333 FloatExpOp -> call SLIT("exp") DoubleRep
334 FloatLogOp -> call SLIT("log") DoubleRep
335 FloatSqrtOp -> call SLIT("sqrt") DoubleRep
337 FloatSinOp -> call SLIT("sin") DoubleRep
338 FloatCosOp -> call SLIT("cos") DoubleRep
339 FloatTanOp -> call SLIT("tan") DoubleRep
341 FloatAsinOp -> call SLIT("asin") DoubleRep
342 FloatAcosOp -> call SLIT("acos") DoubleRep
343 FloatAtanOp -> call SLIT("atan") DoubleRep
345 FloatSinhOp -> call SLIT("sinh") DoubleRep
346 FloatCoshOp -> call SLIT("cosh") DoubleRep
347 FloatTanhOp -> call SLIT("tanh") DoubleRep
349 FloatPowerOp -> call SLIT("pow") DoubleRep
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
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
364 DoubleExpOp -> call SLIT("exp") DoubleRep
365 DoubleLogOp -> call SLIT("log") DoubleRep
366 DoubleSqrtOp -> call SLIT("sqrt") DoubleRep
368 DoubleSinOp -> call SLIT("sin") DoubleRep
369 DoubleCosOp -> call SLIT("cos") DoubleRep
370 DoubleTanOp -> call SLIT("tan") DoubleRep
372 DoubleAsinOp -> call SLIT("asin") DoubleRep
373 DoubleAcosOp -> call SLIT("acos") DoubleRep
374 DoubleAtanOp -> call SLIT("atan") DoubleRep
376 DoubleSinhOp -> call SLIT("sinh") DoubleRep
377 DoubleCoshOp -> call SLIT("cosh") DoubleRep
378 DoubleTanhOp -> call SLIT("tanh") DoubleRep
380 DoublePowerOp -> call SLIT("pow") DoubleRep
382 OrdOp -> coerceIntCode IntRep args
383 ChrOp -> chrCode args
385 Float2IntOp -> coerceFP2Int args
386 Int2FloatOp -> coerceInt2FP args
387 Double2IntOp -> coerceFP2Int args
388 Int2DoubleOp -> coerceInt2FP args
390 Double2FloatOp -> coerceFltCode args
391 Float2DoubleOp -> coerceFltCode args
394 call fn pk = getReg (StCall fn pk args)
396 getReg (StInd pk mem) =
397 getAmode mem `thenUs` \ amode ->
399 code = amodeCode amode
400 src = amodeAddr amode
402 code__2 dst = code . mkSeqInstr (LD size dst src)
404 returnUs (Any pk code__2)
409 code dst = mkSeqInstr (OR zero (RIImm src) dst)
411 returnUs (Any IntRep code)
414 code dst = mkSeqInstr (LDI Q dst src)
416 returnUs (Any IntRep code)
418 src = ImmInt (fromInteger i)
423 code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
425 returnUs (Any PtrRep code)
428 imm__2 = case imm of Just x -> x
432 Now, given a tree (the argument to an StInd) that references memory,
433 produce a suitable addressing mode.
437 getAmode :: StixTree -> UniqSM Amode
439 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
441 getAmode (StPrim IntSubOp [x, StInt i]) =
442 getNewRegNCG PtrRep `thenUs` \ tmp ->
443 getReg x `thenUs` \ register ->
445 code = registerCode register tmp
446 reg = registerName register tmp
447 off = ImmInt (-(fromInteger i))
449 returnUs (Amode (AddrRegImm reg off) code)
452 getAmode (StPrim IntAddOp [x, StInt i]) =
453 getNewRegNCG PtrRep `thenUs` \ tmp ->
454 getReg x `thenUs` \ register ->
456 code = registerCode register tmp
457 reg = registerName register tmp
458 off = ImmInt (fromInteger i)
460 returnUs (Amode (AddrRegImm reg off) code)
464 returnUs (Amode (AddrImm imm__2) id)
467 imm__2 = case imm of Just x -> x
470 getNewRegNCG PtrRep `thenUs` \ tmp ->
471 getReg other `thenUs` \ register ->
473 code = registerCode register tmp
474 reg = registerName register tmp
476 returnUs (Amode (AddrReg reg) code)
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@.
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
496 -- We have to use up all of our argument registers first.
498 getCallArg ((iDst,fDst):dsts, offset) arg =
499 getReg arg `thenUs` \ register ->
501 reg = if isFloatingRep pk then fDst else iDst
502 code = registerCode register reg
503 src = registerName register reg
504 pk = registerKind register
507 if isFloatingRep pk then
508 ((dsts, offset), if isFixed register then
509 code . mkSeqInstr (FMOV src fDst)
512 ((dsts, offset), if isFixed register then
513 code . mkSeqInstr (OR src (RIReg src) iDst)
516 -- Once we have run out of argument registers, we move to the stack
518 getCallArg ([], offset) arg =
519 getReg arg `thenUs` \ register ->
520 getNewRegNCG (registerKind register)
523 code = registerCode register tmp
524 src = registerName register tmp
525 pk = registerKind register
528 returnUs (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
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
542 assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock AlphaInstr)
544 assignIntCode pk (StInd _ dst) src =
545 getNewRegNCG IntRep `thenUs` \ tmp ->
546 getAmode dst `thenUs` \ amode ->
547 getReg src `thenUs` \ register ->
549 code1 = amodeCode amode asmVoid
550 dst__2 = amodeAddr amode
551 code2 = registerCode register tmp asmVoid
552 src__2 = registerName register tmp
554 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
558 assignIntCode pk dst src =
559 getReg dst `thenUs` \ register1 ->
560 getReg src `thenUs` \ register2 ->
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)
571 assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock AlphaInstr)
573 assignFltCode pk (StInd _ dst) src =
574 getNewRegNCG pk `thenUs` \ tmp ->
575 getAmode dst `thenUs` \ amode ->
576 getReg src `thenUs` \ register ->
578 code1 = amodeCode amode asmVoid
579 dst__2 = amodeAddr amode
580 code2 = registerCode register tmp asmVoid
581 src__2 = registerName register tmp
583 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
587 assignFltCode pk dst src =
588 getReg dst `thenUs` \ register1 ->
589 getReg src `thenUs` \ register2 ->
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)
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.
611 :: StixTree -- the branch target
612 -> UniqSM (CodeBlock AlphaInstr)
615 | isAsmTemp lbl = returnInstr (BR target)
616 | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zero (AddrReg pv) 0]
621 getReg tree `thenUs` \ register ->
622 getNewRegNCG PtrRep `thenUs` \ tmp ->
624 dst = registerName register pv
625 code = registerCode register pv
626 target = registerName register pv
628 if isFixed register then
629 returnSeq code [OR dst (RIReg dst) pv, JMP zero (AddrReg pv) 0]
631 returnUs (code . mkSeqInstr (JMP zero (AddrReg pv) 0))
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.
643 :: CLabel -- the branch target
644 -> StixTree -- the condition on which to branch
645 -> UniqSM (CodeBlock AlphaInstr)
647 genCondJump lbl (StPrim op [x, StInt 0]) =
648 getReg x `thenUs` \ register ->
649 getNewRegNCG (registerKind register)
652 code = registerCode register tmp
653 value = registerName register tmp
654 pk = registerKind register
657 returnSeq code [BI (cmpOp op) value target]
672 cmpOp WordGeOp = ALWAYS
675 cmpOp WordLtOp = NEVER
678 cmpOp AddrGeOp = ALWAYS
681 cmpOp AddrLtOp = NEVER
684 genCondJump lbl (StPrim op [x, StDouble 0.0]) =
685 getReg x `thenUs` \ register ->
686 getNewRegNCG (registerKind register)
689 code = registerCode register tmp
690 value = registerName register tmp
691 pk = registerKind register
694 returnUs (code . mkSeqInstr (BF (cmpOp op) value target))
702 cmpOp DoubleGtOp = GT
703 cmpOp DoubleGeOp = GE
704 cmpOp DoubleEqOp = EQ
705 cmpOp DoubleNeOp = NE
706 cmpOp DoubleLtOp = LT
707 cmpOp DoubleLeOp = LE
709 genCondJump lbl (StPrim op args)
711 trivialFCode instr args `thenUs` \ register ->
712 getNewRegNCG DoubleRep `thenUs` \ tmp ->
714 code = registerCode register tmp
715 result = registerName register tmp
718 returnUs (code . mkSeqInstr (BF cond result target))
720 fltCmpOp op = case op of
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)
748 genCondJump lbl (StPrim op args) =
749 trivialCode instr args `thenUs` \ register ->
750 getNewRegNCG IntRep `thenUs` \ tmp ->
752 code = registerCode register tmp
753 result = registerName register tmp
756 returnUs (code . mkSeqInstr (BI cond result target))
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)
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.
793 :: FAST_STRING -- function to call
794 -> PrimRep -- type of the result
795 -> [StixTree] -- arguments (of mixed type)
796 -> UniqSM (CodeBlock AlphaInstr)
798 genCCall fn kind args =
799 mapAccumLNCG getCallArg (argRegs,stackArgLoc) args
800 `thenUs` \ ((unused,_), argCode) ->
802 nRegs = length argRegs - length unused
803 code = asmParThen (map ($ asmVoid) argCode)
806 LDA pv (AddrImm (ImmLab (uppPStr fn))),
807 JSR ra (AddrReg pv) nRegs,
808 LDGP gp (AddrReg ra)]
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)
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.
824 :: (Reg -> RI -> Reg -> AlphaInstr)
828 trivialCode instr [x, StInt y]
830 getReg x `thenUs` \ register ->
831 getNewRegNCG IntRep `thenUs` \ tmp ->
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)
838 returnUs (Any IntRep code__2)
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 ->
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)
853 returnUs (Any IntRep code__2)
856 :: (Reg -> Reg -> Reg -> AlphaInstr)
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 ->
866 code1 = registerCode register1 tmp1
867 src1 = registerName register1 tmp1
869 code2 = registerCode register2 tmp2
870 src2 = registerName register2 tmp2
872 code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
873 mkSeqInstr (instr src1 src2 dst)
875 returnUs (Any DoubleRep code__2)
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.
891 trivialCode (CMP EQ) args `thenUs` \ register ->
892 getNewRegNCG IntRep `thenUs` \ tmp ->
894 code = registerCode register tmp
895 src = registerName register tmp
896 code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
898 returnUs (Any IntRep code__2)
901 :: (Reg -> Reg -> Reg -> AlphaInstr)
906 cmpFCode instr cond args =
907 trivialFCode instr args `thenUs` \ register ->
908 getNewRegNCG DoubleRep `thenUs` \ tmp ->
909 getUniqLabelNCG `thenUs` \ lbl ->
911 code = registerCode register tmp
912 result = registerName register tmp
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,
920 returnUs (Any IntRep code__2)
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.
931 :: (RI -> Reg -> AlphaInstr)
935 trivialUCode instr [x] =
936 getReg x `thenUs` \ register ->
937 getNewRegNCG IntRep `thenUs` \ tmp ->
939 code = registerCode register tmp
940 src = registerName register tmp
941 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
943 returnUs (Any IntRep code__2)
946 :: (Reg -> Reg -> AlphaInstr)
950 trivialUFCode instr [x] =
951 getReg x `thenUs` \ register ->
952 getNewRegNCG DoubleRep `thenUs` \ tmp ->
954 code = registerCode register tmp
955 src = registerName register tmp
956 code__2 dst = code . mkSeqInstr (instr src dst)
958 returnUs (Any DoubleRep code__2)
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
967 coerceIntCode :: PrimRep -> [StixTree] -> UniqSM Register
968 coerceIntCode pk [x] =
969 getReg x `thenUs` \ register ->
971 Fixed reg _ code -> returnUs (Fixed reg pk code)
972 Any _ code -> returnUs (Any pk code)
974 coerceFltCode :: [StixTree] -> UniqSM Register
976 getReg x `thenUs` \ register ->
978 Fixed reg _ code -> returnUs (Fixed reg DoubleRep code)
979 Any _ code -> returnUs (Any DoubleRep code)
983 Integer to character conversion.
988 getReg x `thenUs` \ register ->
989 getNewRegNCG IntRep `thenUs` \ reg ->
991 code = registerCode register reg
992 src = registerName register reg
993 code__2 dst = code . mkSeqInstr (ZAPNOT src (RIImm (ImmInt 1)) dst)
995 returnUs (Any IntRep code__2)
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.
1005 coerceInt2FP :: [StixTree] -> UniqSM Register
1007 getReg x `thenUs` \ register ->
1008 getNewRegNCG IntRep `thenUs` \ reg ->
1010 code = registerCode register reg
1011 src = registerName register reg
1013 code__2 dst = code . mkSeqInstrs [
1015 LD TF dst (spRel 0),
1018 returnUs (Any DoubleRep code__2)
1020 coerceFP2Int :: [StixTree] -> UniqSM Register
1022 getReg x `thenUs` \ register ->
1023 getNewRegNCG DoubleRep `thenUs` \ tmp ->
1025 code = registerCode register tmp
1026 src = registerName register tmp
1028 code__2 dst = code . mkSeqInstrs [
1030 ST TF tmp (spRel 0),
1033 returnUs (Any IntRep code__2)
1037 Some random little helpers.
1041 is8Bits :: Integer -> Bool
1042 is8Bits i = i >= -256 && i < 256
1044 maybeImm :: StixTree -> Maybe Imm
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
1053 mangleIndexTree :: StixTree -> StixTree
1055 mangleIndexTree (StIndex pk base (StInt i)) =
1056 StPrim IntAddOp [base, off]
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}
1063 mangleIndexTree (StIndex pk base off) =
1065 CharRep -> StPrim IntAddOp [base, off]
1066 _ -> StPrim IntAddOp [base, off__2]
1068 off__2 = StPrim SllOp [off, StInt 3]
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"
1076 | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
1078 isHex ('0':'x':xs) = all isHexDigit xs
1080 -- Now, where have I seen this before?
1081 isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'
1086 spRel gives us a stack relative addressing mode for volatile temporaries
1087 and for excess call arguments.
1092 :: Int -- desired stack offset in words, positive or negative
1094 spRel n = AddrRegImm sp (ImmInt (n * 8))
1096 stackArgLoc = 0 :: Int -- where to stack extra call arguments (beyond 6)
1102 getNewRegNCG :: PrimRep -> UniqSM Reg
1104 getUnique `thenUs` \ u ->
1105 returnUs (mkReg u pk)