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, mkReg, extractMappedRegNos,
23 Reg(..), RegLiveness(..), RegUsage(..),
24 FutureLive(..), MachineRegisters(..), MachineCode(..)
26 import CLabel ( CLabel, isAsmTemp )
27 import SparcCode {- everything -}
29 import Maybes ( maybeToBool, Maybe(..) )
30 import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
39 type CodeBlock a = (OrdList a -> OrdList a)
42 %************************************************************************
44 \subsection[SparcCodeGen]{Generating Sparc Code}
46 %************************************************************************
48 This is the top-level code-generation function for the Sparc.
52 sparcCodeGen :: PprStyle -> [[StixTree]] -> UniqSM Unpretty
53 sparcCodeGen sty trees =
54 mapUs genSparcCode trees `thenUs` \ dynamicCodes ->
56 staticCodes = scheduleSparcCode dynamicCodes
57 pretty = printLabeledCodes sty staticCodes
63 This bit does the code scheduling. The scheduler must also deal with
64 register allocation of temporaries. Much parallelism can be exposed via
65 the OrdList, but more might occur, so further analysis might be needed.
69 scheduleSparcCode :: [SparcCode] -> [SparcInstr]
70 scheduleSparcCode = concat . map (runRegAllocate freeSparcRegs reservedRegs)
72 freeSparcRegs :: SparcRegs
73 freeSparcRegs = 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 SparcInstr)
87 | Any PrimRep (Reg -> (CodeBlock SparcInstr))
89 registerCode :: Register -> Reg -> CodeBlock SparcInstr
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 SparcInstr)
113 amodeAddr (Amode addr _) = addr
114 amodeCode (Amode _ code) = code
118 Condition codes passed up the tree.
122 data Condition = Condition Bool Cond (CodeBlock SparcInstr)
124 condName (Condition _ cond _) = cond
125 condFloat (Condition float _ _) = float
126 condCode (Condition _ _ code) = code
130 General things for putting together code sequences.
134 asmVoid :: OrdList SparcInstr
135 asmVoid = mkEmptyList
137 asmInstr :: SparcInstr -> SparcCode
138 asmInstr i = mkUnitList i
140 asmSeq :: [SparcInstr] -> SparcCode
141 asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
143 asmParThen :: [SparcCode] -> (CodeBlock SparcInstr)
144 asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
146 returnInstr :: SparcInstr -> UniqSM (CodeBlock SparcInstr)
147 returnInstr instr = returnUs (\xs -> mkSeqList (asmInstr instr) xs)
149 returnInstrs :: [SparcInstr] -> UniqSM (CodeBlock SparcInstr)
150 returnInstrs instrs = returnUs (\xs -> mkSeqList (asmSeq instrs) xs)
152 returnSeq :: (CodeBlock SparcInstr) -> [SparcInstr] -> UniqSM (CodeBlock SparcInstr)
153 returnSeq code instrs = returnUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
155 mkSeqInstr :: SparcInstr -> (CodeBlock SparcInstr)
156 mkSeqInstr instr code = mkSeqList (asmInstr instr) code
158 mkSeqInstrs :: [SparcInstr] -> (CodeBlock SparcInstr)
159 mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
163 Top level sparc code generator for a chunk of stix code.
167 genSparcCode :: [StixTree] -> UniqSM (SparcCode)
170 mapUs getCode trees `thenUs` \ blocks ->
171 returnUs (foldr (.) id blocks asmVoid)
175 Code extractor for an entire stix tree---stix statement level.
180 :: StixTree -- a stix statement
181 -> UniqSM (CodeBlock SparcInstr)
183 getCode (StSegment seg) = returnInstr (SEGMENT seg)
185 getCode (StAssign pk dst src)
186 | isFloatingRep pk = assignFltCode pk dst src
187 | otherwise = assignIntCode pk dst src
189 getCode (StLabel lab) = returnInstr (LABEL lab)
191 getCode (StFunBegin lab) = returnInstr (LABEL lab)
193 getCode (StFunEnd lab) = returnUs id
195 getCode (StJump arg) = genJump arg
197 getCode (StFallThrough lbl) = returnUs id
199 getCode (StCondJump lbl arg) = genCondJump lbl arg
201 getCode (StData kind args) =
202 mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
203 returnUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
204 (foldr1 (.) codes xs))
206 getData :: StixTree -> UniqSM (CodeBlock SparcInstr, Imm)
207 getData (StInt i) = returnUs (id, ImmInteger i)
208 getData (StDouble d) = returnUs (id, strImmLit ('0' : 'r' : ppShow 80 (ppRational d)))
209 getData (StLitLbl s) = returnUs (id, ImmLab s)
210 getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
211 getData (StString s) =
212 getUniqLabelNCG `thenUs` \ lbl ->
213 returnUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
214 getData (StCLbl l) = returnUs (id, ImmCLbl l)
216 getCode (StCall fn VoidRep args) = genCCall fn VoidRep args
218 getCode (StComment s) = returnInstr (COMMENT s)
222 Generate code to get a subtree into a register.
226 getReg :: StixTree -> UniqSM Register
228 getReg (StReg (StixMagicId stgreg)) =
229 case stgRegMap stgreg of
230 Just reg -> returnUs (Fixed reg (kindFromMagicId stgreg) id)
233 getReg (StReg (StixTemp u pk)) = returnUs (Fixed (UnmappedReg u pk) pk id)
235 getReg (StDouble d) =
236 getUniqLabelNCG `thenUs` \ lbl ->
237 getNewRegNCG PtrRep `thenUs` \ tmp ->
238 let code dst = mkSeqInstrs [
241 DATA DF [strImmLit ('0' : 'r' : ppShow 80 (ppRational d))],
243 SETHI (HI (ImmCLbl lbl)) tmp,
244 LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
246 returnUs (Any DoubleRep code)
248 getReg (StString s) =
249 getUniqLabelNCG `thenUs` \ lbl ->
250 let code dst = mkSeqInstrs [
253 ASCII True (_UNPK_ s),
255 SETHI (HI (ImmCLbl lbl)) dst,
256 OR False dst (RIImm (LO (ImmCLbl lbl))) dst]
258 returnUs (Any PtrRep code)
260 getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
261 getUniqLabelNCG `thenUs` \ lbl ->
262 let code dst = mkSeqInstrs [
265 ASCII False (init xs),
267 SETHI (HI (ImmCLbl lbl)) dst,
268 OR False dst (RIImm (LO (ImmCLbl lbl))) dst]
270 returnUs (Any PtrRep code)
272 xs = _UNPK_ (_TAIL_ s)
274 getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
276 getReg (StCall fn kind args) =
277 genCCall fn kind args `thenUs` \ call ->
278 returnUs (Fixed reg kind call)
280 reg = if isFloatingRep kind then f0 else o0
282 getReg (StPrim primop args) =
285 CharGtOp -> condIntReg GT args
286 CharGeOp -> condIntReg GE args
287 CharEqOp -> condIntReg EQ args
288 CharNeOp -> condIntReg NE args
289 CharLtOp -> condIntReg LT args
290 CharLeOp -> condIntReg LE args
292 IntAddOp -> trivialCode (ADD False False) args
294 IntSubOp -> trivialCode (SUB False False) args
295 IntMulOp -> call SLIT(".umul") IntRep
296 IntQuotOp -> call SLIT(".div") IntRep
297 IntRemOp -> call SLIT(".rem") IntRep
298 IntNegOp -> trivialUCode (SUB False False g0) args
299 IntAbsOp -> absIntCode args
301 AndOp -> trivialCode (AND False) args
302 OrOp -> trivialCode (OR False) args
303 NotOp -> trivialUCode (XNOR False g0) args
304 SllOp -> trivialCode SLL args
305 SraOp -> trivialCode SRA args
306 SrlOp -> trivialCode SRL args
307 ISllOp -> panic "SparcGen:isll"
308 ISraOp -> panic "SparcGen:isra"
309 ISrlOp -> panic "SparcGen:isrl"
311 IntGtOp -> condIntReg GT args
312 IntGeOp -> condIntReg GE args
313 IntEqOp -> condIntReg EQ args
314 IntNeOp -> condIntReg NE args
315 IntLtOp -> condIntReg LT args
316 IntLeOp -> condIntReg LE args
318 WordGtOp -> condIntReg GU args
319 WordGeOp -> condIntReg GEU args
320 WordEqOp -> condIntReg EQ args
321 WordNeOp -> condIntReg NE args
322 WordLtOp -> condIntReg LU args
323 WordLeOp -> condIntReg LEU args
325 AddrGtOp -> condIntReg GU args
326 AddrGeOp -> condIntReg GEU args
327 AddrEqOp -> condIntReg EQ args
328 AddrNeOp -> condIntReg NE args
329 AddrLtOp -> condIntReg LU args
330 AddrLeOp -> condIntReg LEU args
332 FloatAddOp -> trivialFCode FloatRep FADD args
333 FloatSubOp -> trivialFCode FloatRep FSUB args
334 FloatMulOp -> trivialFCode FloatRep FMUL args
335 FloatDivOp -> trivialFCode FloatRep FDIV args
336 FloatNegOp -> trivialUFCode FloatRep (FNEG F) args
338 FloatGtOp -> condFltReg GT args
339 FloatGeOp -> condFltReg GE args
340 FloatEqOp -> condFltReg EQ args
341 FloatNeOp -> condFltReg NE args
342 FloatLtOp -> condFltReg LT args
343 FloatLeOp -> condFltReg LE args
345 FloatExpOp -> promoteAndCall SLIT("exp") DoubleRep
346 FloatLogOp -> promoteAndCall SLIT("log") DoubleRep
347 FloatSqrtOp -> promoteAndCall SLIT("sqrt") DoubleRep
349 FloatSinOp -> promoteAndCall SLIT("sin") DoubleRep
350 FloatCosOp -> promoteAndCall SLIT("cos") DoubleRep
351 FloatTanOp -> promoteAndCall SLIT("tan") DoubleRep
353 FloatAsinOp -> promoteAndCall SLIT("asin") DoubleRep
354 FloatAcosOp -> promoteAndCall SLIT("acos") DoubleRep
355 FloatAtanOp -> promoteAndCall SLIT("atan") DoubleRep
357 FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleRep
358 FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleRep
359 FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleRep
361 FloatPowerOp -> promoteAndCall SLIT("pow") DoubleRep
363 DoubleAddOp -> trivialFCode DoubleRep FADD args
364 DoubleSubOp -> trivialFCode DoubleRep FSUB args
365 DoubleMulOp -> trivialFCode DoubleRep FMUL args
366 DoubleDivOp -> trivialFCode DoubleRep FDIV args
367 DoubleNegOp -> trivialUFCode DoubleRep (FNEG DF) args
369 DoubleGtOp -> condFltReg GT args
370 DoubleGeOp -> condFltReg GE args
371 DoubleEqOp -> condFltReg EQ args
372 DoubleNeOp -> condFltReg NE args
373 DoubleLtOp -> condFltReg LT args
374 DoubleLeOp -> condFltReg LE args
376 DoubleExpOp -> call SLIT("exp") DoubleRep
377 DoubleLogOp -> call SLIT("log") DoubleRep
378 DoubleSqrtOp -> call SLIT("sqrt") DoubleRep
380 DoubleSinOp -> call SLIT("sin") DoubleRep
381 DoubleCosOp -> call SLIT("cos") DoubleRep
382 DoubleTanOp -> call SLIT("tan") DoubleRep
384 DoubleAsinOp -> call SLIT("asin") DoubleRep
385 DoubleAcosOp -> call SLIT("acos") DoubleRep
386 DoubleAtanOp -> call SLIT("atan") DoubleRep
388 DoubleSinhOp -> call SLIT("sinh") DoubleRep
389 DoubleCoshOp -> call SLIT("cosh") DoubleRep
390 DoubleTanhOp -> call SLIT("tanh") DoubleRep
392 DoublePowerOp -> call SLIT("pow") DoubleRep
394 OrdOp -> coerceIntCode IntRep args
395 ChrOp -> chrCode args
397 Float2IntOp -> coerceFP2Int args
398 Int2FloatOp -> coerceInt2FP FloatRep args
399 Double2IntOp -> coerceFP2Int args
400 Int2DoubleOp -> coerceInt2FP DoubleRep args
402 Double2FloatOp -> trivialUFCode FloatRep (FxTOy DF F) args
403 Float2DoubleOp -> trivialUFCode DoubleRep (FxTOy F DF) args
406 call fn pk = getReg (StCall fn pk args)
407 promoteAndCall fn pk = getReg (StCall fn pk (map promote args))
409 promote x = StPrim Float2DoubleOp [x]
411 getReg (StInd pk mem) =
412 getAmode mem `thenUs` \ amode ->
414 code = amodeCode amode
415 src = amodeAddr amode
417 code__2 dst = code . mkSeqInstr (LD size src dst)
419 returnUs (Any pk code__2)
424 src = ImmInt (fromInteger i)
425 code dst = mkSeqInstr (OR False g0 (RIImm src) dst)
427 returnUs (Any IntRep code)
432 code dst = mkSeqInstrs [
433 SETHI (HI imm__2) dst,
434 OR False dst (RIImm (LO imm__2)) dst]
436 returnUs (Any PtrRep code)
439 imm__2 = case imm of Just x -> x
443 Now, given a tree (the argument to an StInd) that references memory,
444 produce a suitable addressing mode.
448 getAmode :: StixTree -> UniqSM Amode
450 getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
452 getAmode (StPrim IntSubOp [x, StInt i])
454 getNewRegNCG PtrRep `thenUs` \ tmp ->
455 getReg x `thenUs` \ register ->
457 code = registerCode register tmp
458 reg = registerName register tmp
459 off = ImmInt (-(fromInteger i))
461 returnUs (Amode (AddrRegImm reg off) code)
464 getAmode (StPrim IntAddOp [x, StInt i])
466 getNewRegNCG PtrRep `thenUs` \ tmp ->
467 getReg x `thenUs` \ register ->
469 code = registerCode register tmp
470 reg = registerName register tmp
471 off = ImmInt (fromInteger i)
473 returnUs (Amode (AddrRegImm reg off) code)
475 getAmode (StPrim IntAddOp [x, y]) =
476 getNewRegNCG PtrRep `thenUs` \ tmp1 ->
477 getNewRegNCG IntRep `thenUs` \ tmp2 ->
478 getReg x `thenUs` \ register1 ->
479 getReg y `thenUs` \ register2 ->
481 code1 = registerCode register1 tmp1 asmVoid
482 reg1 = registerName register1 tmp1
483 code2 = registerCode register2 tmp2 asmVoid
484 reg2 = registerName register2 tmp2
485 code__2 = asmParThen [code1, code2]
487 returnUs (Amode (AddrRegReg reg1 reg2) code__2)
491 getNewRegNCG PtrRep `thenUs` \ tmp ->
493 code = mkSeqInstr (SETHI (HI imm__2) tmp)
495 returnUs (Amode (AddrRegImm tmp (LO imm__2)) code)
498 imm__2 = case imm of Just x -> x
501 getNewRegNCG PtrRep `thenUs` \ tmp ->
502 getReg other `thenUs` \ register ->
504 code = registerCode register tmp
505 reg = registerName register tmp
508 returnUs (Amode (AddrRegImm reg off) code)
512 Try to get a value into a specific register (or registers) for a call. The Sparc
513 calling convention is an absolute nightmare. The first 6x32 bits of arguments are
514 mapped into %o0 through %o5, and the remaining arguments are dumped to the stack,
515 beginning at [%sp+92]. (Note that %o6 == %sp.) Our first argument is a pair of
516 the list of remaining argument registers to be assigned for this call and the next
517 stack offset to use for overflowing arguments. This way, @getCallArg@ can be applied
518 to all of a call's arguments using @mapAccumL@.
523 :: ([Reg],Int) -- Argument registers and stack offset (accumulator)
524 -> StixTree -- Current argument
525 -> UniqSM (([Reg],Int), CodeBlock SparcInstr) -- Updated accumulator and code
527 -- We have to use up all of our argument registers first.
529 getCallArg (dst:dsts, offset) arg =
530 getReg arg `thenUs` \ register ->
531 getNewRegNCG (registerKind register)
534 reg = if isFloatingRep pk then tmp else dst
535 code = registerCode register reg
536 src = registerName register reg
537 pk = registerKind register
542 [] -> (([], offset + 1), code . mkSeqInstrs [
543 -- conveniently put the second part in the right stack
544 -- location, and load the first part into %o5
545 ST DF src (spRel (offset - 1)),
546 LD W (spRel (offset - 1)) dst])
547 (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [
548 ST DF src (spRel (-2)),
549 LD W (spRel (-2)) dst,
550 LD W (spRel (-1)) dst__2])
551 FloatRep -> ((dsts, offset), code . mkSeqInstrs [
552 ST F src (spRel (-2)),
553 LD W (spRel (-2)) dst])
554 _ -> ((dsts, offset), if isFixed register then
555 code . mkSeqInstr (OR False g0 (RIReg src) dst)
558 -- Once we have run out of argument registers, we move to the stack
560 getCallArg ([], offset) arg =
561 getReg arg `thenUs` \ register ->
562 getNewRegNCG (registerKind register)
565 code = registerCode register tmp
566 src = registerName register tmp
567 pk = registerKind register
569 words = if pk == DoubleRep then 2 else 1
571 returnUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset)))
575 Set up a condition code for a conditional branch.
579 getCondition :: StixTree -> UniqSM Condition
581 getCondition (StPrim primop args) =
584 CharGtOp -> condIntCode GT args
585 CharGeOp -> condIntCode GE args
586 CharEqOp -> condIntCode EQ args
587 CharNeOp -> condIntCode NE args
588 CharLtOp -> condIntCode LT args
589 CharLeOp -> condIntCode LE args
591 IntGtOp -> condIntCode GT args
592 IntGeOp -> condIntCode GE args
593 IntEqOp -> condIntCode EQ args
594 IntNeOp -> condIntCode NE args
595 IntLtOp -> condIntCode LT args
596 IntLeOp -> condIntCode LE args
598 WordGtOp -> condIntCode GU args
599 WordGeOp -> condIntCode GEU args
600 WordEqOp -> condIntCode EQ args
601 WordNeOp -> condIntCode NE args
602 WordLtOp -> condIntCode LU args
603 WordLeOp -> condIntCode LEU args
605 AddrGtOp -> condIntCode GU args
606 AddrGeOp -> condIntCode GEU args
607 AddrEqOp -> condIntCode EQ args
608 AddrNeOp -> condIntCode NE args
609 AddrLtOp -> condIntCode LU args
610 AddrLeOp -> condIntCode LEU args
612 FloatGtOp -> condFltCode GT args
613 FloatGeOp -> condFltCode GE args
614 FloatEqOp -> condFltCode EQ args
615 FloatNeOp -> condFltCode NE args
616 FloatLtOp -> condFltCode LT args
617 FloatLeOp -> condFltCode LE args
619 DoubleGtOp -> condFltCode GT args
620 DoubleGeOp -> condFltCode GE args
621 DoubleEqOp -> condFltCode EQ args
622 DoubleNeOp -> condFltCode NE args
623 DoubleLtOp -> condFltCode LT args
624 DoubleLeOp -> condFltCode LE args
628 Turn a boolean expression into a condition, to be passed
633 condIntCode, condFltCode :: Cond -> [StixTree] -> UniqSM Condition
635 condIntCode cond [x, StInt y]
637 getReg x `thenUs` \ register ->
638 getNewRegNCG IntRep `thenUs` \ tmp ->
640 code = registerCode register tmp
641 src1 = registerName register tmp
642 src2 = ImmInt (fromInteger y)
643 code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0)
645 returnUs (Condition False cond code__2)
647 condIntCode cond [x, y] =
648 getReg x `thenUs` \ register1 ->
649 getReg y `thenUs` \ register2 ->
650 getNewRegNCG IntRep `thenUs` \ tmp1 ->
651 getNewRegNCG IntRep `thenUs` \ tmp2 ->
653 code1 = registerCode register1 tmp1 asmVoid
654 src1 = registerName register1 tmp1
655 code2 = registerCode register2 tmp2 asmVoid
656 src2 = registerName register2 tmp2
657 code__2 = asmParThen [code1, code2] .
658 mkSeqInstr (SUB False True src1 (RIReg src2) g0)
660 returnUs (Condition False cond code__2)
662 condFltCode cond [x, y] =
663 getReg x `thenUs` \ register1 ->
664 getReg y `thenUs` \ register2 ->
665 getNewRegNCG (registerKind register1)
667 getNewRegNCG (registerKind register2)
669 getNewRegNCG DoubleRep `thenUs` \ tmp ->
671 promote x = asmInstr (FxTOy F DF x tmp)
673 pk1 = registerKind register1
674 code1 = registerCode register1 tmp1
675 src1 = registerName register1 tmp1
677 pk2 = registerKind register2
678 code2 = registerCode register2 tmp2
679 src2 = registerName register2 tmp2
683 asmParThen [code1 asmVoid, code2 asmVoid] .
684 mkSeqInstr (FCMP True (kindToSize pk1) src1 src2)
685 else if pk1 == FloatRep then
686 asmParThen [code1 (promote src1), code2 asmVoid] .
687 mkSeqInstr (FCMP True DF tmp src2)
689 asmParThen [code1 asmVoid, code2 (promote src2)] .
690 mkSeqInstr (FCMP True DF src1 tmp)
692 returnUs (Condition True cond code__2)
696 Turn those condition codes into integers now (when they appear on
697 the right hand side of an assignment).
699 Do not fill the delay slots here; you will confuse the register allocator.
703 condIntReg :: Cond -> [StixTree] -> UniqSM Register
705 condIntReg EQ [x, StInt 0] =
706 getReg x `thenUs` \ register ->
707 getNewRegNCG IntRep `thenUs` \ tmp ->
709 code = registerCode register tmp
710 src = registerName register tmp
711 code__2 dst = code . mkSeqInstrs [
712 SUB False True g0 (RIReg src) g0,
713 SUB True False g0 (RIImm (ImmInt (-1))) dst]
715 returnUs (Any IntRep code__2)
717 condIntReg EQ [x, y] =
718 getReg x `thenUs` \ register1 ->
719 getReg y `thenUs` \ register2 ->
720 getNewRegNCG IntRep `thenUs` \ tmp1 ->
721 getNewRegNCG IntRep `thenUs` \ tmp2 ->
723 code1 = registerCode register1 tmp1 asmVoid
724 src1 = registerName register1 tmp1
725 code2 = registerCode register2 tmp2 asmVoid
726 src2 = registerName register2 tmp2
727 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
728 XOR False src1 (RIReg src2) dst,
729 SUB False True g0 (RIReg dst) g0,
730 SUB True False g0 (RIImm (ImmInt (-1))) dst]
732 returnUs (Any IntRep code__2)
734 condIntReg NE [x, StInt 0] =
735 getReg x `thenUs` \ register ->
736 getNewRegNCG IntRep `thenUs` \ tmp ->
738 code = registerCode register tmp
739 src = registerName register tmp
740 code__2 dst = code . mkSeqInstrs [
741 SUB False True g0 (RIReg src) g0,
742 ADD True False g0 (RIImm (ImmInt 0)) dst]
744 returnUs (Any IntRep code__2)
746 condIntReg NE [x, y] =
747 getReg x `thenUs` \ register1 ->
748 getReg y `thenUs` \ register2 ->
749 getNewRegNCG IntRep `thenUs` \ tmp1 ->
750 getNewRegNCG IntRep `thenUs` \ tmp2 ->
752 code1 = registerCode register1 tmp1 asmVoid
753 src1 = registerName register1 tmp1
754 code2 = registerCode register2 tmp2 asmVoid
755 src2 = registerName register2 tmp2
756 code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [
757 XOR False src1 (RIReg src2) dst,
758 SUB False True g0 (RIReg dst) g0,
759 ADD True False g0 (RIImm (ImmInt 0)) dst]
761 returnUs (Any IntRep code__2)
763 condIntReg cond args =
764 getUniqLabelNCG `thenUs` \ lbl1 ->
765 getUniqLabelNCG `thenUs` \ lbl2 ->
766 condIntCode cond args `thenUs` \ condition ->
768 code = condCode condition
769 cond = condName condition
770 code__2 dst = code . mkSeqInstrs [
771 BI cond False (ImmCLbl lbl1), NOP,
772 OR False g0 (RIImm (ImmInt 0)) dst,
773 BI ALWAYS False (ImmCLbl lbl2), NOP,
775 OR False g0 (RIImm (ImmInt 1)) dst,
778 returnUs (Any IntRep code__2)
780 condFltReg :: Cond -> [StixTree] -> UniqSM Register
782 condFltReg cond args =
783 getUniqLabelNCG `thenUs` \ lbl1 ->
784 getUniqLabelNCG `thenUs` \ lbl2 ->
785 condFltCode cond args `thenUs` \ condition ->
787 code = condCode condition
788 cond = condName condition
789 code__2 dst = code . mkSeqInstrs [
791 BF cond False (ImmCLbl lbl1), NOP,
792 OR False g0 (RIImm (ImmInt 0)) dst,
793 BI ALWAYS False (ImmCLbl lbl2), NOP,
795 OR False g0 (RIImm (ImmInt 1)) dst,
798 returnUs (Any IntRep code__2)
802 Assignments are really at the heart of the whole code generation business.
803 Almost all top-level nodes of any real importance are assignments, which
804 correspond to loads, stores, or register transfers. If we're really lucky,
805 some of the register transfers will go away, because we can use the destination
806 register to complete the code generation for the right hand side. This only
807 fails when the right hand side is forced into a fixed register (e.g. the result
812 assignIntCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock SparcInstr)
814 assignIntCode pk (StInd _ dst) src =
815 getNewRegNCG IntRep `thenUs` \ tmp ->
816 getAmode dst `thenUs` \ amode ->
817 getReg src `thenUs` \ register ->
819 code1 = amodeCode amode asmVoid
820 dst__2 = amodeAddr amode
821 code2 = registerCode register tmp asmVoid
822 src__2 = registerName register tmp
824 code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
828 assignIntCode pk dst src =
829 getReg dst `thenUs` \ register1 ->
830 getReg src `thenUs` \ register2 ->
832 dst__2 = registerName register1 g0
833 code = registerCode register2 dst__2
834 src__2 = registerName register2 dst__2
835 code__2 = if isFixed register2 then
836 code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2)
841 assignFltCode :: PrimRep -> StixTree -> StixTree -> UniqSM (CodeBlock SparcInstr)
843 assignFltCode pk (StInd _ dst) src =
844 getNewRegNCG pk `thenUs` \ tmp ->
845 getAmode dst `thenUs` \ amode ->
846 getReg src `thenUs` \ register ->
849 dst__2 = amodeAddr amode
851 code1 = amodeCode amode asmVoid
852 code2 = registerCode register tmp asmVoid
854 src__2 = registerName register tmp
855 pk__2 = registerKind register
856 sz__2 = kindToSize pk__2
858 code__2 = asmParThen [code1, code2] .
860 mkSeqInstr (ST sz src__2 dst__2)
862 mkSeqInstrs [FxTOy sz__2 sz src__2 tmp, ST sz tmp dst__2]
866 assignFltCode pk dst src =
867 getReg dst `thenUs` \ register1 ->
868 getReg src `thenUs` \ register2 ->
869 getNewRegNCG (registerKind register2)
873 dst__2 = registerName register1 g0 -- must be Fixed
875 reg__2 = if pk /= pk__2 then tmp else dst__2
877 code = registerCode register2 reg__2
878 src__2 = registerName register2 reg__2
879 pk__2 = registerKind register2
880 sz__2 = kindToSize pk__2
882 code__2 = if pk /= pk__2 then code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2)
883 else if isFixed register2 then code . mkSeqInstr (FMOV sz src__2 dst__2)
890 Generating an unconditional branch. We accept two types of targets:
891 an immediate CLabel or a tree that gets evaluated into a register.
892 Any CLabels which are AsmTemporaries are assumed to be in the local
893 block of code, close enough for a branch instruction. Other CLabels
894 are assumed to be far away, so we use call.
896 Do not fill the delay slots here; you will confuse the register allocator.
901 :: StixTree -- the branch target
902 -> UniqSM (CodeBlock SparcInstr)
905 | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP]
906 | otherwise = returnInstrs [CALL target 0 True, NOP]
911 getReg tree `thenUs` \ register ->
912 getNewRegNCG PtrRep `thenUs` \ tmp ->
914 code = registerCode register tmp
915 target = registerName register tmp
917 returnSeq code [JMP (AddrRegReg target g0), NOP]
921 Conditional jumps are always to local labels, so we can use
922 branch instructions. First, we have to ensure that the condition
923 codes are set according to the supplied comparison operation.
924 We generate slightly different code for floating point comparisons,
925 because a floating point operation cannot directly precede a @BF@.
926 We assume the worst and fill that slot with a @NOP@.
928 Do not fill the delay slots here; you will confuse the register allocator.
933 :: CLabel -- the branch target
934 -> StixTree -- the condition on which to branch
935 -> UniqSM (CodeBlock SparcInstr)
937 genCondJump lbl bool =
938 getCondition bool `thenUs` \ condition ->
940 code = condCode condition
941 cond = condName condition
944 if condFloat condition then
945 returnSeq code [NOP, BF cond False target, NOP]
947 returnSeq code [BI cond False target, NOP]
951 Now the biggest nightmare---calls. Most of the nastiness is buried in
952 getCallArg, which moves the arguments to the correct registers/stack
953 locations. Apart from that, the code is easy.
955 Do not fill the delay slots here; you will confuse the register allocator.
960 :: FAST_STRING -- function to call
961 -> PrimRep -- type of the result
962 -> [StixTree] -- arguments (of mixed type)
963 -> UniqSM (CodeBlock SparcInstr)
965 genCCall fn kind args =
966 mapAccumLNCG getCallArg (argRegs,stackArgLoc) args
967 `thenUs` \ ((unused,_), argCode) ->
969 nRegs = length argRegs - length unused
970 call = CALL fn__2 nRegs False
971 code = asmParThen (map ($ asmVoid) argCode)
973 returnSeq code [call, NOP]
975 -- function names that begin with '.' are assumed to be special internally
976 -- generated names like '.mul,' which don't get an underscore prefix
977 fn__2 = case (_HEAD_ fn) of
978 '.' -> ImmLit (uppPStr fn)
979 _ -> ImmLab (uppPStr fn)
981 mapAccumLNCG f b [] = returnUs (b, [])
982 mapAccumLNCG f b (x:xs) =
983 f b x `thenUs` \ (b__2, x__2) ->
984 mapAccumLNCG f b__2 xs `thenUs` \ (b__3, xs__2) ->
985 returnUs (b__3, x__2:xs__2)
989 Trivial (dyadic) instructions. Only look for constants on the right hand
990 side, because that's where the generic optimizer will have put them.
995 :: (Reg -> RI -> Reg -> SparcInstr)
999 trivialCode instr [x, StInt y]
1001 getReg x `thenUs` \ register ->
1002 getNewRegNCG IntRep `thenUs` \ tmp ->
1004 code = registerCode register tmp
1005 src1 = registerName register tmp
1006 src2 = ImmInt (fromInteger y)
1007 code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
1009 returnUs (Any IntRep code__2)
1011 trivialCode instr [x, y] =
1012 getReg x `thenUs` \ register1 ->
1013 getReg y `thenUs` \ register2 ->
1014 getNewRegNCG IntRep `thenUs` \ tmp1 ->
1015 getNewRegNCG IntRep `thenUs` \ tmp2 ->
1017 code1 = registerCode register1 tmp1 asmVoid
1018 src1 = registerName register1 tmp1
1019 code2 = registerCode register2 tmp2 asmVoid
1020 src2 = registerName register2 tmp2
1021 code__2 dst = asmParThen [code1, code2] .
1022 mkSeqInstr (instr src1 (RIReg src2) dst)
1024 returnUs (Any IntRep code__2)
1028 -> (Size -> Reg -> Reg -> Reg -> SparcInstr)
1032 trivialFCode pk instr [x, y] =
1033 getReg x `thenUs` \ register1 ->
1034 getReg y `thenUs` \ register2 ->
1035 getNewRegNCG (registerKind register1)
1037 getNewRegNCG (registerKind register2)
1039 getNewRegNCG DoubleRep `thenUs` \ tmp ->
1041 promote x = asmInstr (FxTOy F DF x tmp)
1043 pk1 = registerKind register1
1044 code1 = registerCode register1 tmp1
1045 src1 = registerName register1 tmp1
1047 pk2 = registerKind register2
1048 code2 = registerCode register2 tmp2
1049 src2 = registerName register2 tmp2
1053 asmParThen [code1 asmVoid, code2 asmVoid] .
1054 mkSeqInstr (instr (kindToSize pk) src1 src2 dst)
1055 else if pk1 == FloatRep then
1056 asmParThen [code1 (promote src1), code2 asmVoid] .
1057 mkSeqInstr (instr DF tmp src2 dst)
1059 asmParThen [code1 asmVoid, code2 (promote src2)] .
1060 mkSeqInstr (instr DF src1 tmp dst)
1062 returnUs (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
1066 Trivial unary instructions. Note that we don't have to worry about
1067 matching an StInt as the argument, because genericOpt will already
1068 have handled the constant-folding.
1073 :: (RI -> Reg -> SparcInstr)
1077 trivialUCode instr [x] =
1078 getReg x `thenUs` \ register ->
1079 getNewRegNCG IntRep `thenUs` \ tmp ->
1081 code = registerCode register tmp
1082 src = registerName register tmp
1083 code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
1085 returnUs (Any IntRep code__2)
1089 -> (Reg -> Reg -> SparcInstr)
1093 trivialUFCode pk instr [x] =
1094 getReg x `thenUs` \ register ->
1095 getNewRegNCG pk `thenUs` \ tmp ->
1097 code = registerCode register tmp
1098 src = registerName register tmp
1099 code__2 dst = code . mkSeqInstr (instr src dst)
1101 returnUs (Any pk code__2)
1105 Absolute value on integers, mostly for gmp size check macros. Again,
1106 the argument cannot be an StInt, because genericOpt already folded
1109 Do not fill the delay slots here; you will confuse the register allocator.
1113 absIntCode :: [StixTree] -> UniqSM Register
1115 getReg x `thenUs` \ register ->
1116 getNewRegNCG IntRep `thenUs` \ reg ->
1117 getUniqLabelNCG `thenUs` \ lbl ->
1119 code = registerCode register reg
1120 src = registerName register reg
1121 code__2 dst = code . mkSeqInstrs [
1122 SUB False True g0 (RIReg src) dst,
1123 BI GE False (ImmCLbl lbl), NOP,
1124 OR False g0 (RIReg src) dst,
1127 returnUs (Any IntRep code__2)
1131 Simple integer coercions that don't require any code to be generated.
1132 Here we just change the type on the register passed on up
1136 coerceIntCode :: PrimRep -> [StixTree] -> UniqSM Register
1137 coerceIntCode pk [x] =
1138 getReg x `thenUs` \ register ->
1140 Fixed reg _ code -> returnUs (Fixed reg pk code)
1141 Any _ code -> returnUs (Any pk code)
1145 Integer to character conversion. We try to do this in one step if
1146 the original object is in memory.
1150 chrCode :: [StixTree] -> UniqSM Register
1151 chrCode [StInd pk mem] =
1152 getAmode mem `thenUs` \ amode ->
1154 code = amodeCode amode
1155 src = amodeAddr amode
1156 srcOff = offset src 3
1157 src__2 = case srcOff of Just x -> x
1158 code__2 dst = if maybeToBool srcOff then
1159 code . mkSeqInstr (LD UB src__2 dst)
1161 code . mkSeqInstrs [
1162 LD (kindToSize pk) src dst,
1163 AND False dst (RIImm (ImmInt 255)) dst]
1165 returnUs (Any pk code__2)
1168 getReg x `thenUs` \ register ->
1169 getNewRegNCG IntRep `thenUs` \ reg ->
1171 code = registerCode register reg
1172 src = registerName register reg
1173 code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst)
1175 returnUs (Any IntRep code__2)
1179 More complicated integer/float conversions. Here we have to store
1180 temporaries in memory to move between the integer and the floating
1181 point register sets.
1185 coerceInt2FP :: PrimRep -> [StixTree] -> UniqSM Register
1186 coerceInt2FP pk [x] =
1187 getReg x `thenUs` \ register ->
1188 getNewRegNCG IntRep `thenUs` \ reg ->
1190 code = registerCode register reg
1191 src = registerName register reg
1193 code__2 dst = code . mkSeqInstrs [
1194 ST W src (spRel (-2)),
1195 LD W (spRel (-2)) dst,
1196 FxTOy W (kindToSize pk) dst dst]
1198 returnUs (Any pk code__2)
1200 coerceFP2Int :: [StixTree] -> UniqSM Register
1202 getReg x `thenUs` \ register ->
1203 getNewRegNCG IntRep `thenUs` \ reg ->
1204 getNewRegNCG FloatRep `thenUs` \ tmp ->
1206 code = registerCode register reg
1207 src = registerName register reg
1208 pk = registerKind register
1210 code__2 dst = code . mkSeqInstrs [
1211 FxTOy (kindToSize pk) W src tmp,
1212 ST W tmp (spRel (-2)),
1213 LD W (spRel (-2)) dst]
1215 returnUs (Any IntRep code__2)
1219 Some random little helpers.
1223 maybeImm :: StixTree -> Maybe Imm
1225 | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
1226 | otherwise = Just (ImmInteger i)
1227 maybeImm (StLitLbl s) = Just (ImmLab s)
1228 maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
1229 maybeImm (StCLbl l) = Just (ImmCLbl l)
1230 maybeImm _ = Nothing
1232 mangleIndexTree :: StixTree -> StixTree
1234 mangleIndexTree (StIndex pk base (StInt i)) =
1235 StPrim IntAddOp [base, off]
1237 off = StInt (i * size pk)
1238 size :: PrimRep -> Integer
1239 size pk = case kindToSize pk of
1240 {SB -> 1; UB -> 1; HW -> 2; UHW -> 2; W -> 4; D -> 8; F -> 4; DF -> 8}
1242 mangleIndexTree (StIndex pk base off) =
1244 CharRep -> StPrim IntAddOp [base, off]
1245 _ -> StPrim IntAddOp [base, off__2]
1247 off__2 = StPrim SllOp [off, StInt (shift pk)]
1248 shift :: PrimRep -> Integer
1252 cvtLitLit :: String -> String
1253 cvtLitLit "stdin" = "__iob+0x0" -- This one is probably okay...
1254 cvtLitLit "stdout" = "__iob+0x14" -- but these next two are dodgy at best
1255 cvtLitLit "stderr" = "__iob+0x28"
1258 | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
1260 isHex ('0':'x':xs) = all isHexDigit xs
1262 -- Now, where have I seen this before?
1263 isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'
1268 spRel gives us a stack relative addressing mode for volatile temporaries
1269 and for excess call arguments.
1274 :: Int -- desired stack offset in words, positive or negative
1276 spRel n = AddrRegImm sp (ImmInt (n * 4))
1278 stackArgLoc = 23 :: Int -- where to stack extra call arguments (beyond 6x32 bits)
1284 getNewRegNCG :: PrimRep -> UniqSM Reg
1286 getUnique `thenUs` \ u ->
1287 returnUs (mkReg u pk)