diff options
Diffstat (limited to 'ghc/compiler/nativeGen/SparcGen.lhs')
| -rw-r--r-- | ghc/compiler/nativeGen/SparcGen.lhs | 1304 |
1 files changed, 1304 insertions, 0 deletions
diff --git a/ghc/compiler/nativeGen/SparcGen.lhs b/ghc/compiler/nativeGen/SparcGen.lhs new file mode 100644 index 0000000000..f5bc3a032c --- /dev/null +++ b/ghc/compiler/nativeGen/SparcGen.lhs @@ -0,0 +1,1304 @@ +% +% (c) The AQUA Project, Glasgow University, 1993-1995 +% + +\begin{code} +#include "HsVersions.h" + +module SparcGen ( + sparcCodeGen, + + -- and, for self-sufficiency + PprStyle, StixTree, CSeq + ) where + +IMPORT_Trace + +import AbsCSyn ( AbstractC, MagicId(..), kindFromMagicId ) +import AbsPrel ( PrimOp(..) + IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) + IF_ATTACK_PRAGMAS(COMMA pprPrimOp) + ) +import AsmRegAlloc ( runRegAllocate, mkReg, extractMappedRegNos, + Reg(..), RegLiveness(..), RegUsage(..), + FutureLive(..), MachineRegisters(..), MachineCode(..) + ) +import CLabelInfo ( CLabel, isAsmTemp ) +import SparcCode {- everything -} +import MachDesc +import Maybes ( maybeToBool, Maybe(..) ) +import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList ) +import Outputable +import PrimKind ( PrimKind(..), isFloatingKind ) +import SparcDesc +import Stix +import SplitUniq +import Unique +import Pretty +import Unpretty +import Util + +type CodeBlock a = (OrdList a -> OrdList a) + +\end{code} + +%************************************************************************ +%* * +\subsection[SparcCodeGen]{Generating Sparc Code} +%* * +%************************************************************************ + +This is the top-level code-generation function for the Sparc. + +\begin{code} + +sparcCodeGen :: PprStyle -> [[StixTree]] -> SUniqSM Unpretty +sparcCodeGen sty trees = + mapSUs genSparcCode trees `thenSUs` \ dynamicCodes -> + let + staticCodes = scheduleSparcCode dynamicCodes + pretty = printLabeledCodes sty staticCodes + in + returnSUs pretty + +\end{code} + +This bit does the code scheduling. The scheduler must also deal with +register allocation of temporaries. Much parallelism can be exposed via +the OrdList, but more might occur, so further analysis might be needed. + +\begin{code} + +scheduleSparcCode :: [SparcCode] -> [SparcInstr] +scheduleSparcCode = concat . map (runRegAllocate freeSparcRegs reservedRegs) + where + freeSparcRegs :: SparcRegs + freeSparcRegs = mkMRegs (extractMappedRegNos freeRegs) + + +\end{code} + +Registers passed up the tree. If the stix code forces the register +to live in a pre-decided machine register, it comes out as @Fixed@; +otherwise, it comes out as @Any@, and the parent can decide which +register to put it in. + +\begin{code} + +data Register + = Fixed Reg PrimKind (CodeBlock SparcInstr) + | Any PrimKind (Reg -> (CodeBlock SparcInstr)) + +registerCode :: Register -> Reg -> CodeBlock SparcInstr +registerCode (Fixed _ _ code) reg = code +registerCode (Any _ code) reg = code reg + +registerName :: Register -> Reg -> Reg +registerName (Fixed reg _ _) _ = reg +registerName (Any _ _) reg = reg + +registerKind :: Register -> PrimKind +registerKind (Fixed _ pk _) = pk +registerKind (Any pk _) = pk + +isFixed :: Register -> Bool +isFixed (Fixed _ _ _) = True +isFixed (Any _ _) = False + +\end{code} + +Memory addressing modes passed up the tree. + +\begin{code} + +data Amode = Amode Addr (CodeBlock SparcInstr) + +amodeAddr (Amode addr _) = addr +amodeCode (Amode _ code) = code + +\end{code} + +Condition codes passed up the tree. + +\begin{code} + +data Condition = Condition Bool Cond (CodeBlock SparcInstr) + +condName (Condition _ cond _) = cond +condFloat (Condition float _ _) = float +condCode (Condition _ _ code) = code + +\end{code} + +General things for putting together code sequences. + +\begin{code} + +asmVoid :: OrdList SparcInstr +asmVoid = mkEmptyList + +asmInstr :: SparcInstr -> SparcCode +asmInstr i = mkUnitList i + +asmSeq :: [SparcInstr] -> SparcCode +asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is + +asmParThen :: [SparcCode] -> (CodeBlock SparcInstr) +asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code + +returnInstr :: SparcInstr -> SUniqSM (CodeBlock SparcInstr) +returnInstr instr = returnSUs (\xs -> mkSeqList (asmInstr instr) xs) + +returnInstrs :: [SparcInstr] -> SUniqSM (CodeBlock SparcInstr) +returnInstrs instrs = returnSUs (\xs -> mkSeqList (asmSeq instrs) xs) + +returnSeq :: (CodeBlock SparcInstr) -> [SparcInstr] -> SUniqSM (CodeBlock SparcInstr) +returnSeq code instrs = returnSUs (\xs -> code (mkSeqList (asmSeq instrs) xs)) + +mkSeqInstr :: SparcInstr -> (CodeBlock SparcInstr) +mkSeqInstr instr code = mkSeqList (asmInstr instr) code + +mkSeqInstrs :: [SparcInstr] -> (CodeBlock SparcInstr) +mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code + +\end{code} + +Top level sparc code generator for a chunk of stix code. + +\begin{code} + +genSparcCode :: [StixTree] -> SUniqSM (SparcCode) + +genSparcCode trees = + mapSUs getCode trees `thenSUs` \ blocks -> + returnSUs (foldr (.) id blocks asmVoid) + +\end{code} + +Code extractor for an entire stix tree---stix statement level. + +\begin{code} + +getCode + :: StixTree -- a stix statement + -> SUniqSM (CodeBlock SparcInstr) + +getCode (StSegment seg) = returnInstr (SEGMENT seg) + +getCode (StAssign pk dst src) + | isFloatingKind pk = assignFltCode pk dst src + | otherwise = assignIntCode pk dst src + +getCode (StLabel lab) = returnInstr (LABEL lab) + +getCode (StFunBegin lab) = returnInstr (LABEL lab) + +getCode (StFunEnd lab) = returnSUs id + +getCode (StJump arg) = genJump arg + +getCode (StFallThrough lbl) = returnSUs id + +getCode (StCondJump lbl arg) = genCondJump lbl arg + +getCode (StData kind args) = + mapAndUnzipSUs getData args `thenSUs` \ (codes, imms) -> + returnSUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms)) + (foldr1 (.) codes xs)) + where + getData :: StixTree -> SUniqSM (CodeBlock SparcInstr, Imm) + getData (StInt i) = returnSUs (id, ImmInteger i) +#if __GLASGOW_HASKELL__ >= 23 +-- getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'r' : _showRational 30 d)) + -- yurgh (WDP 94/12) + getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'r' : ppShow 80 (ppRational d))) +#else + getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'r' : show d)) +#endif + getData (StLitLbl s) = returnSUs (id, ImmLab s) + getData (StLitLit s) = returnSUs (id, strImmLit (cvtLitLit (_UNPK_ s))) + getData (StString s) = + getUniqLabelNCG `thenSUs` \ lbl -> + returnSUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl) + getData (StCLbl l) = returnSUs (id, ImmCLbl l) + +getCode (StCall fn VoidKind args) = genCCall fn VoidKind args + +getCode (StComment s) = returnInstr (COMMENT s) + +\end{code} + +Generate code to get a subtree into a register. + +\begin{code} + +getReg :: StixTree -> SUniqSM Register + +getReg (StReg (StixMagicId stgreg)) = + case stgRegMap stgreg of + Just reg -> returnSUs (Fixed reg (kindFromMagicId stgreg) id) + -- cannae be Nothing + +getReg (StReg (StixTemp u pk)) = returnSUs (Fixed (UnmappedReg u pk) pk id) + +getReg (StDouble d) = + getUniqLabelNCG `thenSUs` \ lbl -> + getNewRegNCG PtrKind `thenSUs` \ tmp -> + let code dst = mkSeqInstrs [ + SEGMENT DataSegment, + LABEL lbl, +#if __GLASGOW_HASKELL__ >= 23 +-- DATA DF [strImmLit ('0' : 'r' : (_showRational 30 d))], + DATA DF [strImmLit ('0' : 'r' : ppShow 80 (ppRational d))], +#else + DATA DF [strImmLit ('0' : 'r' : (show d))], +#endif + SEGMENT TextSegment, + SETHI (HI (ImmCLbl lbl)) tmp, + LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] + in + returnSUs (Any DoubleKind code) + +getReg (StString s) = + getUniqLabelNCG `thenSUs` \ lbl -> + let code dst = mkSeqInstrs [ + SEGMENT DataSegment, + LABEL lbl, + ASCII True (_UNPK_ s), + SEGMENT TextSegment, + SETHI (HI (ImmCLbl lbl)) dst, + OR False dst (RIImm (LO (ImmCLbl lbl))) dst] + in + returnSUs (Any PtrKind code) + +getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' = + getUniqLabelNCG `thenSUs` \ lbl -> + let code dst = mkSeqInstrs [ + SEGMENT DataSegment, + LABEL lbl, + ASCII False (init xs), + SEGMENT TextSegment, + SETHI (HI (ImmCLbl lbl)) dst, + OR False dst (RIImm (LO (ImmCLbl lbl))) dst] + in + returnSUs (Any PtrKind code) + where + xs = _UNPK_ (_TAIL_ s) + +getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree) + +getReg (StCall fn kind args) = + genCCall fn kind args `thenSUs` \ call -> + returnSUs (Fixed reg kind call) + where + reg = if isFloatingKind kind then f0 else o0 + +getReg (StPrim primop args) = + case primop of + + CharGtOp -> condIntReg GT args + CharGeOp -> condIntReg GE args + CharEqOp -> condIntReg EQ args + CharNeOp -> condIntReg NE args + CharLtOp -> condIntReg LT args + CharLeOp -> condIntReg LE args + + IntAddOp -> trivialCode (ADD False False) args + + IntSubOp -> trivialCode (SUB False False) args + IntMulOp -> call SLIT(".umul") IntKind + IntQuotOp -> call SLIT(".div") IntKind + IntDivOp -> call SLIT("stg_div") IntKind + IntRemOp -> call SLIT(".rem") IntKind + IntNegOp -> trivialUCode (SUB False False g0) args + IntAbsOp -> absIntCode args + + AndOp -> trivialCode (AND False) args + OrOp -> trivialCode (OR False) args + NotOp -> trivialUCode (XNOR False g0) args + SllOp -> trivialCode SLL args + SraOp -> trivialCode SRA args + SrlOp -> trivialCode SRL args + ISllOp -> panic "SparcGen:isll" + ISraOp -> panic "SparcGen:isra" + ISrlOp -> panic "SparcGen:isrl" + + IntGtOp -> condIntReg GT args + IntGeOp -> condIntReg GE args + IntEqOp -> condIntReg EQ args + IntNeOp -> condIntReg NE args + IntLtOp -> condIntReg LT args + IntLeOp -> condIntReg LE args + + WordGtOp -> condIntReg GU args + WordGeOp -> condIntReg GEU args + WordEqOp -> condIntReg EQ args + WordNeOp -> condIntReg NE args + WordLtOp -> condIntReg LU args + WordLeOp -> condIntReg LEU args + + AddrGtOp -> condIntReg GU args + AddrGeOp -> condIntReg GEU args + AddrEqOp -> condIntReg EQ args + AddrNeOp -> condIntReg NE args + AddrLtOp -> condIntReg LU args + AddrLeOp -> condIntReg LEU args + + FloatAddOp -> trivialFCode FloatKind FADD args + FloatSubOp -> trivialFCode FloatKind FSUB args + FloatMulOp -> trivialFCode FloatKind FMUL args + FloatDivOp -> trivialFCode FloatKind FDIV args + FloatNegOp -> trivialUFCode FloatKind (FNEG F) args + + FloatGtOp -> condFltReg GT args + FloatGeOp -> condFltReg GE args + FloatEqOp -> condFltReg EQ args + FloatNeOp -> condFltReg NE args + FloatLtOp -> condFltReg LT args + FloatLeOp -> condFltReg LE args + + FloatExpOp -> promoteAndCall SLIT("exp") DoubleKind + FloatLogOp -> promoteAndCall SLIT("log") DoubleKind + FloatSqrtOp -> promoteAndCall SLIT("sqrt") DoubleKind + + FloatSinOp -> promoteAndCall SLIT("sin") DoubleKind + FloatCosOp -> promoteAndCall SLIT("cos") DoubleKind + FloatTanOp -> promoteAndCall SLIT("tan") DoubleKind + + FloatAsinOp -> promoteAndCall SLIT("asin") DoubleKind + FloatAcosOp -> promoteAndCall SLIT("acos") DoubleKind + FloatAtanOp -> promoteAndCall SLIT("atan") DoubleKind + + FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleKind + FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleKind + FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleKind + + FloatPowerOp -> promoteAndCall SLIT("pow") DoubleKind + + DoubleAddOp -> trivialFCode DoubleKind FADD args + DoubleSubOp -> trivialFCode DoubleKind FSUB args + DoubleMulOp -> trivialFCode DoubleKind FMUL args + DoubleDivOp -> trivialFCode DoubleKind FDIV args + DoubleNegOp -> trivialUFCode DoubleKind (FNEG DF) args + + DoubleGtOp -> condFltReg GT args + DoubleGeOp -> condFltReg GE args + DoubleEqOp -> condFltReg EQ args + DoubleNeOp -> condFltReg NE args + DoubleLtOp -> condFltReg LT args + DoubleLeOp -> condFltReg LE args + + DoubleExpOp -> call SLIT("exp") DoubleKind + DoubleLogOp -> call SLIT("log") DoubleKind + DoubleSqrtOp -> call SLIT("sqrt") DoubleKind + + DoubleSinOp -> call SLIT("sin") DoubleKind + DoubleCosOp -> call SLIT("cos") DoubleKind + DoubleTanOp -> call SLIT("tan") DoubleKind + + DoubleAsinOp -> call SLIT("asin") DoubleKind + DoubleAcosOp -> call SLIT("acos") DoubleKind + DoubleAtanOp -> call SLIT("atan") DoubleKind + + DoubleSinhOp -> call SLIT("sinh") DoubleKind + DoubleCoshOp -> call SLIT("cosh") DoubleKind + DoubleTanhOp -> call SLIT("tanh") DoubleKind + + DoublePowerOp -> call SLIT("pow") DoubleKind + + OrdOp -> coerceIntCode IntKind args + ChrOp -> chrCode args + + Float2IntOp -> coerceFP2Int args + Int2FloatOp -> coerceInt2FP FloatKind args + Double2IntOp -> coerceFP2Int args + Int2DoubleOp -> coerceInt2FP DoubleKind args + + Double2FloatOp -> trivialUFCode FloatKind (FxTOy DF F) args + Float2DoubleOp -> trivialUFCode DoubleKind (FxTOy F DF) args + + where + call fn pk = getReg (StCall fn pk args) + promoteAndCall fn pk = getReg (StCall fn pk (map promote args)) + where + promote x = StPrim Float2DoubleOp [x] + +getReg (StInd pk mem) = + getAmode mem `thenSUs` \ amode -> + let + code = amodeCode amode + src = amodeAddr amode + size = kindToSize pk + code__2 dst = code . mkSeqInstr (LD size src dst) + in + returnSUs (Any pk code__2) + +getReg (StInt i) + | is13Bits i = + let + src = ImmInt (fromInteger i) + code dst = mkSeqInstr (OR False g0 (RIImm src) dst) + in + returnSUs (Any IntKind code) + +getReg leaf + | maybeToBool imm = + let + code dst = mkSeqInstrs [ + SETHI (HI imm__2) dst, + OR False dst (RIImm (LO imm__2)) dst] + in + returnSUs (Any PtrKind code) + where + imm = maybeImm leaf + imm__2 = case imm of Just x -> x + +\end{code} + +Now, given a tree (the argument to an StInd) that references memory, +produce a suitable addressing mode. + +\begin{code} + +getAmode :: StixTree -> SUniqSM Amode + +getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree) + +getAmode (StPrim IntSubOp [x, StInt i]) + | is13Bits (-i) = + getNewRegNCG PtrKind `thenSUs` \ tmp -> + getReg x `thenSUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = ImmInt (-(fromInteger i)) + in + returnSUs (Amode (AddrRegImm reg off) code) + + +getAmode (StPrim IntAddOp [x, StInt i]) + | is13Bits i = + getNewRegNCG PtrKind `thenSUs` \ tmp -> + getReg x `thenSUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = ImmInt (fromInteger i) + in + returnSUs (Amode (AddrRegImm reg off) code) + +getAmode (StPrim IntAddOp [x, y]) = + getNewRegNCG PtrKind `thenSUs` \ tmp1 -> + getNewRegNCG IntKind `thenSUs` \ tmp2 -> + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + let + code1 = registerCode register1 tmp1 asmVoid + reg1 = registerName register1 tmp1 + code2 = registerCode register2 tmp2 asmVoid + reg2 = registerName register2 tmp2 + code__2 = asmParThen [code1, code2] + in + returnSUs (Amode (AddrRegReg reg1 reg2) code__2) + +getAmode leaf + | maybeToBool imm = + getNewRegNCG PtrKind `thenSUs` \ tmp -> + let + code = mkSeqInstr (SETHI (HI imm__2) tmp) + in + returnSUs (Amode (AddrRegImm tmp (LO imm__2)) code) + where + imm = maybeImm leaf + imm__2 = case imm of Just x -> x + +getAmode other = + getNewRegNCG PtrKind `thenSUs` \ tmp -> + getReg other `thenSUs` \ register -> + let + code = registerCode register tmp + reg = registerName register tmp + off = ImmInt 0 + in + returnSUs (Amode (AddrRegImm reg off) code) + +\end{code} + +Try to get a value into a specific register (or registers) for a call. The Sparc +calling convention is an absolute nightmare. The first 6x32 bits of arguments are +mapped into %o0 through %o5, and the remaining arguments are dumped to the stack, +beginning at [%sp+92]. (Note that %o6 == %sp.) Our first argument is a pair of +the list of remaining argument registers to be assigned for this call and the next +stack offset to use for overflowing arguments. This way, @getCallArg@ can be applied +to all of a call's arguments using @mapAccumL@. + +\begin{code} + +getCallArg + :: ([Reg],Int) -- Argument registers and stack offset (accumulator) + -> StixTree -- Current argument + -> SUniqSM (([Reg],Int), CodeBlock SparcInstr) -- Updated accumulator and code + +-- We have to use up all of our argument registers first. + +getCallArg (dst:dsts, offset) arg = + getReg arg `thenSUs` \ register -> + getNewRegNCG (registerKind register) + `thenSUs` \ tmp -> + let + reg = if isFloatingKind pk then tmp else dst + code = registerCode register reg + src = registerName register reg + pk = registerKind register + in + returnSUs (case pk of + DoubleKind -> + case dsts of + [] -> (([], offset + 1), code . mkSeqInstrs [ + -- conveniently put the second part in the right stack + -- location, and load the first part into %o5 + ST DF src (spRel (offset - 1)), + LD W (spRel (offset - 1)) dst]) + (dst__2:dsts__2) -> ((dsts__2, offset), code . mkSeqInstrs [ + ST DF src (spRel (-2)), + LD W (spRel (-2)) dst, + LD W (spRel (-1)) dst__2]) + FloatKind -> ((dsts, offset), code . mkSeqInstrs [ + ST F src (spRel (-2)), + LD W (spRel (-2)) dst]) + _ -> ((dsts, offset), if isFixed register then + code . mkSeqInstr (OR False g0 (RIReg src) dst) + else code)) + +-- Once we have run out of argument registers, we move to the stack + +getCallArg ([], offset) arg = + getReg arg `thenSUs` \ register -> + getNewRegNCG (registerKind register) + `thenSUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + pk = registerKind register + sz = kindToSize pk + words = if pk == DoubleKind then 2 else 1 + in + returnSUs (([], offset + words), code . mkSeqInstr (ST sz src (spRel offset))) + +\end{code} + +Set up a condition code for a conditional branch. + +\begin{code} + +getCondition :: StixTree -> SUniqSM Condition + +getCondition (StPrim primop args) = + case primop of + + CharGtOp -> condIntCode GT args + CharGeOp -> condIntCode GE args + CharEqOp -> condIntCode EQ args + CharNeOp -> condIntCode NE args + CharLtOp -> condIntCode LT args + CharLeOp -> condIntCode LE args + + IntGtOp -> condIntCode GT args + IntGeOp -> condIntCode GE args + IntEqOp -> condIntCode EQ args + IntNeOp -> condIntCode NE args + IntLtOp -> condIntCode LT args + IntLeOp -> condIntCode LE args + + WordGtOp -> condIntCode GU args + WordGeOp -> condIntCode GEU args + WordEqOp -> condIntCode EQ args + WordNeOp -> condIntCode NE args + WordLtOp -> condIntCode LU args + WordLeOp -> condIntCode LEU args + + AddrGtOp -> condIntCode GU args + AddrGeOp -> condIntCode GEU args + AddrEqOp -> condIntCode EQ args + AddrNeOp -> condIntCode NE args + AddrLtOp -> condIntCode LU args + AddrLeOp -> condIntCode LEU args + + FloatGtOp -> condFltCode GT args + FloatGeOp -> condFltCode GE args + FloatEqOp -> condFltCode EQ args + FloatNeOp -> condFltCode NE args + FloatLtOp -> condFltCode LT args + FloatLeOp -> condFltCode LE args + + DoubleGtOp -> condFltCode GT args + DoubleGeOp -> condFltCode GE args + DoubleEqOp -> condFltCode EQ args + DoubleNeOp -> condFltCode NE args + DoubleLtOp -> condFltCode LT args + DoubleLeOp -> condFltCode LE args + +\end{code} + +Turn a boolean expression into a condition, to be passed +back up the tree. + +\begin{code} + +condIntCode, condFltCode :: Cond -> [StixTree] -> SUniqSM Condition + +condIntCode cond [x, StInt y] + | is13Bits y = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + src1 = registerName register tmp + src2 = ImmInt (fromInteger y) + code__2 = code . mkSeqInstr (SUB False True src1 (RIImm src2) g0) + in + returnSUs (Condition False cond code__2) + +condIntCode cond [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG IntKind `thenSUs` \ tmp1 -> + getNewRegNCG IntKind `thenSUs` \ tmp2 -> + let + code1 = registerCode register1 tmp1 asmVoid + src1 = registerName register1 tmp1 + code2 = registerCode register2 tmp2 asmVoid + src2 = registerName register2 tmp2 + code__2 = asmParThen [code1, code2] . + mkSeqInstr (SUB False True src1 (RIReg src2) g0) + in + returnSUs (Condition False cond code__2) + +condFltCode cond [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG (registerKind register1) + `thenSUs` \ tmp1 -> + getNewRegNCG (registerKind register2) + `thenSUs` \ tmp2 -> + getNewRegNCG DoubleKind `thenSUs` \ tmp -> + let + promote x = asmInstr (FxTOy F DF x tmp) + + pk1 = registerKind register1 + code1 = registerCode register1 tmp1 + src1 = registerName register1 tmp1 + + pk2 = registerKind register2 + code2 = registerCode register2 tmp2 + src2 = registerName register2 tmp2 + + code__2 = + if pk1 == pk2 then + asmParThen [code1 asmVoid, code2 asmVoid] . + mkSeqInstr (FCMP True (kindToSize pk1) src1 src2) + else if pk1 == FloatKind then + asmParThen [code1 (promote src1), code2 asmVoid] . + mkSeqInstr (FCMP True DF tmp src2) + else + asmParThen [code1 asmVoid, code2 (promote src2)] . + mkSeqInstr (FCMP True DF src1 tmp) + in + returnSUs (Condition True cond code__2) + +\end{code} + +Turn those condition codes into integers now (when they appear on +the right hand side of an assignment). + +Do not fill the delay slots here; you will confuse the register allocator. + +\begin{code} + +condIntReg :: Cond -> [StixTree] -> SUniqSM Register + +condIntReg EQ [x, StInt 0] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + code__2 dst = code . mkSeqInstrs [ + SUB False True g0 (RIReg src) g0, + SUB True False g0 (RIImm (ImmInt (-1))) dst] + in + returnSUs (Any IntKind code__2) + +condIntReg EQ [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG IntKind `thenSUs` \ tmp1 -> + getNewRegNCG IntKind `thenSUs` \ tmp2 -> + let + code1 = registerCode register1 tmp1 asmVoid + src1 = registerName register1 tmp1 + code2 = registerCode register2 tmp2 asmVoid + src2 = registerName register2 tmp2 + code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [ + XOR False src1 (RIReg src2) dst, + SUB False True g0 (RIReg dst) g0, + SUB True False g0 (RIImm (ImmInt (-1))) dst] + in + returnSUs (Any IntKind code__2) + +condIntReg NE [x, StInt 0] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + code__2 dst = code . mkSeqInstrs [ + SUB False True g0 (RIReg src) g0, + ADD True False g0 (RIImm (ImmInt 0)) dst] + in + returnSUs (Any IntKind code__2) + +condIntReg NE [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG IntKind `thenSUs` \ tmp1 -> + getNewRegNCG IntKind `thenSUs` \ tmp2 -> + let + code1 = registerCode register1 tmp1 asmVoid + src1 = registerName register1 tmp1 + code2 = registerCode register2 tmp2 asmVoid + src2 = registerName register2 tmp2 + code__2 dst = asmParThen [code1, code2] . mkSeqInstrs [ + XOR False src1 (RIReg src2) dst, + SUB False True g0 (RIReg dst) g0, + ADD True False g0 (RIImm (ImmInt 0)) dst] + in + returnSUs (Any IntKind code__2) + +condIntReg cond args = + getUniqLabelNCG `thenSUs` \ lbl1 -> + getUniqLabelNCG `thenSUs` \ lbl2 -> + condIntCode cond args `thenSUs` \ condition -> + let + code = condCode condition + cond = condName condition + code__2 dst = code . mkSeqInstrs [ + BI cond False (ImmCLbl lbl1), NOP, + OR False g0 (RIImm (ImmInt 0)) dst, + BI ALWAYS False (ImmCLbl lbl2), NOP, + LABEL lbl1, + OR False g0 (RIImm (ImmInt 1)) dst, + LABEL lbl2] + in + returnSUs (Any IntKind code__2) + +condFltReg :: Cond -> [StixTree] -> SUniqSM Register + +condFltReg cond args = + getUniqLabelNCG `thenSUs` \ lbl1 -> + getUniqLabelNCG `thenSUs` \ lbl2 -> + condFltCode cond args `thenSUs` \ condition -> + let + code = condCode condition + cond = condName condition + code__2 dst = code . mkSeqInstrs [ + NOP, + BF cond False (ImmCLbl lbl1), NOP, + OR False g0 (RIImm (ImmInt 0)) dst, + BI ALWAYS False (ImmCLbl lbl2), NOP, + LABEL lbl1, + OR False g0 (RIImm (ImmInt 1)) dst, + LABEL lbl2] + in + returnSUs (Any IntKind code__2) + +\end{code} + +Assignments are really at the heart of the whole code generation business. +Almost all top-level nodes of any real importance are assignments, which +correspond to loads, stores, or register transfers. If we're really lucky, +some of the register transfers will go away, because we can use the destination +register to complete the code generation for the right hand side. This only +fails when the right hand side is forced into a fixed register (e.g. the result +of a call). + +\begin{code} + +assignIntCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock SparcInstr) + +assignIntCode pk (StInd _ dst) src = + getNewRegNCG IntKind `thenSUs` \ tmp -> + getAmode dst `thenSUs` \ amode -> + getReg src `thenSUs` \ register -> + let + code1 = amodeCode amode asmVoid + dst__2 = amodeAddr amode + code2 = registerCode register tmp asmVoid + src__2 = registerName register tmp + sz = kindToSize pk + code__2 = asmParThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) + in + returnSUs code__2 + +assignIntCode pk dst src = + getReg dst `thenSUs` \ register1 -> + getReg src `thenSUs` \ register2 -> + let + dst__2 = registerName register1 g0 + code = registerCode register2 dst__2 + src__2 = registerName register2 dst__2 + code__2 = if isFixed register2 then + code . mkSeqInstr (OR False g0 (RIReg src__2) dst__2) + else code + in + returnSUs code__2 + +assignFltCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock SparcInstr) + +assignFltCode pk (StInd _ dst) src = + getNewRegNCG pk `thenSUs` \ tmp -> + getAmode dst `thenSUs` \ amode -> + getReg src `thenSUs` \ register -> + let + sz = kindToSize pk + dst__2 = amodeAddr amode + + code1 = amodeCode amode asmVoid + code2 = registerCode register tmp asmVoid + + src__2 = registerName register tmp + pk__2 = registerKind register + sz__2 = kindToSize pk__2 + + code__2 = asmParThen [code1, code2] . + if pk == pk__2 then + mkSeqInstr (ST sz src__2 dst__2) + else + mkSeqInstrs [FxTOy sz__2 sz src__2 tmp, ST sz tmp dst__2] + in + returnSUs code__2 + +assignFltCode pk dst src = + getReg dst `thenSUs` \ register1 -> + getReg src `thenSUs` \ register2 -> + getNewRegNCG (registerKind register2) + `thenSUs` \ tmp -> + let + sz = kindToSize pk + dst__2 = registerName register1 g0 -- must be Fixed + + reg__2 = if pk /= pk__2 then tmp else dst__2 + + code = registerCode register2 reg__2 + src__2 = registerName register2 reg__2 + pk__2 = registerKind register2 + sz__2 = kindToSize pk__2 + + code__2 = if pk /= pk__2 then code . mkSeqInstr (FxTOy sz__2 sz src__2 dst__2) + else if isFixed register2 then code . mkSeqInstr (FMOV sz src__2 dst__2) + else code + in + returnSUs code__2 + +\end{code} + +Generating an unconditional branch. We accept two types of targets: +an immediate CLabel or a tree that gets evaluated into a register. +Any CLabels which are AsmTemporaries are assumed to be in the local +block of code, close enough for a branch instruction. Other CLabels +are assumed to be far away, so we use call. + +Do not fill the delay slots here; you will confuse the register allocator. + +\begin{code} + +genJump + :: StixTree -- the branch target + -> SUniqSM (CodeBlock SparcInstr) + +genJump (StCLbl lbl) + | isAsmTemp lbl = returnInstrs [BI ALWAYS False target, NOP] + | otherwise = returnInstrs [CALL target 0 True, NOP] + where + target = ImmCLbl lbl + +genJump tree = + getReg tree `thenSUs` \ register -> + getNewRegNCG PtrKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + target = registerName register tmp + in + returnSeq code [JMP (AddrRegReg target g0), NOP] + +\end{code} + +Conditional jumps are always to local labels, so we can use +branch instructions. First, we have to ensure that the condition +codes are set according to the supplied comparison operation. +We generate slightly different code for floating point comparisons, +because a floating point operation cannot directly precede a @BF@. +We assume the worst and fill that slot with a @NOP@. + +Do not fill the delay slots here; you will confuse the register allocator. + +\begin{code} + +genCondJump + :: CLabel -- the branch target + -> StixTree -- the condition on which to branch + -> SUniqSM (CodeBlock SparcInstr) + +genCondJump lbl bool = + getCondition bool `thenSUs` \ condition -> + let + code = condCode condition + cond = condName condition + target = ImmCLbl lbl + in + if condFloat condition then + returnSeq code [NOP, BF cond False target, NOP] + else + returnSeq code [BI cond False target, NOP] + +\end{code} + +Now the biggest nightmare---calls. Most of the nastiness is buried in +getCallArg, which moves the arguments to the correct registers/stack +locations. Apart from that, the code is easy. + +Do not fill the delay slots here; you will confuse the register allocator. + +\begin{code} + +genCCall + :: FAST_STRING -- function to call + -> PrimKind -- type of the result + -> [StixTree] -- arguments (of mixed type) + -> SUniqSM (CodeBlock SparcInstr) + +genCCall fn kind args = + mapAccumLNCG getCallArg (argRegs,stackArgLoc) args + `thenSUs` \ ((unused,_), argCode) -> + let + nRegs = length argRegs - length unused + call = CALL fn__2 nRegs False + code = asmParThen (map ($ asmVoid) argCode) + in + returnSeq code [call, NOP] + where + -- function names that begin with '.' are assumed to be special internally + -- generated names like '.mul,' which don't get an underscore prefix + fn__2 = case (_HEAD_ fn) of + '.' -> ImmLit (uppPStr fn) + _ -> ImmLab (uppPStr fn) + + mapAccumLNCG f b [] = returnSUs (b, []) + mapAccumLNCG f b (x:xs) = + f b x `thenSUs` \ (b__2, x__2) -> + mapAccumLNCG f b__2 xs `thenSUs` \ (b__3, xs__2) -> + returnSUs (b__3, x__2:xs__2) + +\end{code} + +Trivial (dyadic) instructions. Only look for constants on the right hand +side, because that's where the generic optimizer will have put them. + +\begin{code} + +trivialCode + :: (Reg -> RI -> Reg -> SparcInstr) + -> [StixTree] + -> SUniqSM Register + +trivialCode instr [x, StInt y] + | is13Bits y = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + src1 = registerName register tmp + src2 = ImmInt (fromInteger y) + code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst) + in + returnSUs (Any IntKind code__2) + +trivialCode instr [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG IntKind `thenSUs` \ tmp1 -> + getNewRegNCG IntKind `thenSUs` \ tmp2 -> + let + code1 = registerCode register1 tmp1 asmVoid + src1 = registerName register1 tmp1 + code2 = registerCode register2 tmp2 asmVoid + src2 = registerName register2 tmp2 + code__2 dst = asmParThen [code1, code2] . + mkSeqInstr (instr src1 (RIReg src2) dst) + in + returnSUs (Any IntKind code__2) + +trivialFCode + :: PrimKind + -> (Size -> Reg -> Reg -> Reg -> SparcInstr) + -> [StixTree] + -> SUniqSM Register + +trivialFCode pk instr [x, y] = + getReg x `thenSUs` \ register1 -> + getReg y `thenSUs` \ register2 -> + getNewRegNCG (registerKind register1) + `thenSUs` \ tmp1 -> + getNewRegNCG (registerKind register2) + `thenSUs` \ tmp2 -> + getNewRegNCG DoubleKind `thenSUs` \ tmp -> + let + promote x = asmInstr (FxTOy F DF x tmp) + + pk1 = registerKind register1 + code1 = registerCode register1 tmp1 + src1 = registerName register1 tmp1 + + pk2 = registerKind register2 + code2 = registerCode register2 tmp2 + src2 = registerName register2 tmp2 + + code__2 dst = + if pk1 == pk2 then + asmParThen [code1 asmVoid, code2 asmVoid] . + mkSeqInstr (instr (kindToSize pk) src1 src2 dst) + else if pk1 == FloatKind then + asmParThen [code1 (promote src1), code2 asmVoid] . + mkSeqInstr (instr DF tmp src2 dst) + else + asmParThen [code1 asmVoid, code2 (promote src2)] . + mkSeqInstr (instr DF src1 tmp dst) + in + returnSUs (Any (if pk1 == pk2 then pk1 else DoubleKind) code__2) + +\end{code} + +Trivial unary instructions. Note that we don't have to worry about +matching an StInt as the argument, because genericOpt will already +have handled the constant-folding. + +\begin{code} + +trivialUCode + :: (RI -> Reg -> SparcInstr) + -> [StixTree] + -> SUniqSM Register + +trivialUCode instr [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + code__2 dst = code . mkSeqInstr (instr (RIReg src) dst) + in + returnSUs (Any IntKind code__2) + +trivialUFCode + :: PrimKind + -> (Reg -> Reg -> SparcInstr) + -> [StixTree] + -> SUniqSM Register + +trivialUFCode pk instr [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG pk `thenSUs` \ tmp -> + let + code = registerCode register tmp + src = registerName register tmp + code__2 dst = code . mkSeqInstr (instr src dst) + in + returnSUs (Any pk code__2) + +\end{code} + +Absolute value on integers, mostly for gmp size check macros. Again, +the argument cannot be an StInt, because genericOpt already folded +constants. + +Do not fill the delay slots here; you will confuse the register allocator. + +\begin{code} + +absIntCode :: [StixTree] -> SUniqSM Register +absIntCode [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ reg -> + getUniqLabelNCG `thenSUs` \ lbl -> + let + code = registerCode register reg + src = registerName register reg + code__2 dst = code . mkSeqInstrs [ + SUB False True g0 (RIReg src) dst, + BI GE False (ImmCLbl lbl), NOP, + OR False g0 (RIReg src) dst, + LABEL lbl] + in + returnSUs (Any IntKind code__2) + +\end{code} + +Simple integer coercions that don't require any code to be generated. +Here we just change the type on the register passed on up + +\begin{code} + +coerceIntCode :: PrimKind -> [StixTree] -> SUniqSM Register +coerceIntCode pk [x] = + getReg x `thenSUs` \ register -> + case register of + Fixed reg _ code -> returnSUs (Fixed reg pk code) + Any _ code -> returnSUs (Any pk code) + +\end{code} + +Integer to character conversion. We try to do this in one step if +the original object is in memory. + +\begin{code} + +chrCode :: [StixTree] -> SUniqSM Register +chrCode [StInd pk mem] = + getAmode mem `thenSUs` \ amode -> + let + code = amodeCode amode + src = amodeAddr amode + srcOff = offset src 3 + src__2 = case srcOff of Just x -> x + code__2 dst = if maybeToBool srcOff then + code . mkSeqInstr (LD UB src__2 dst) + else + code . mkSeqInstrs [ + LD (kindToSize pk) src dst, + AND False dst (RIImm (ImmInt 255)) dst] + in + returnSUs (Any pk code__2) + +chrCode [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ reg -> + let + code = registerCode register reg + src = registerName register reg + code__2 dst = code . mkSeqInstr (AND False src (RIImm (ImmInt 255)) dst) + in + returnSUs (Any IntKind code__2) + +\end{code} + +More complicated integer/float conversions. Here we have to store +temporaries in memory to move between the integer and the floating +point register sets. + +\begin{code} + +coerceInt2FP :: PrimKind -> [StixTree] -> SUniqSM Register +coerceInt2FP pk [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ reg -> + let + code = registerCode register reg + src = registerName register reg + + code__2 dst = code . mkSeqInstrs [ + ST W src (spRel (-2)), + LD W (spRel (-2)) dst, + FxTOy W (kindToSize pk) dst dst] + in + returnSUs (Any pk code__2) + +coerceFP2Int :: [StixTree] -> SUniqSM Register +coerceFP2Int [x] = + getReg x `thenSUs` \ register -> + getNewRegNCG IntKind `thenSUs` \ reg -> + getNewRegNCG FloatKind `thenSUs` \ tmp -> + let + code = registerCode register reg + src = registerName register reg + pk = registerKind register + + code__2 dst = code . mkSeqInstrs [ + FxTOy (kindToSize pk) W src tmp, + ST W tmp (spRel (-2)), + LD W (spRel (-2)) dst] + in + returnSUs (Any IntKind code__2) + +\end{code} + +Some random little helpers. + +\begin{code} + +maybeImm :: StixTree -> Maybe Imm +maybeImm (StInt i) + | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i)) + | otherwise = Just (ImmInteger i) +maybeImm (StLitLbl s) = Just (ImmLab s) +maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s))) +maybeImm (StCLbl l) = Just (ImmCLbl l) +maybeImm _ = Nothing + +mangleIndexTree :: StixTree -> StixTree + +mangleIndexTree (StIndex pk base (StInt i)) = + StPrim IntAddOp [base, off] + where + off = StInt (i * size pk) + size :: PrimKind -> Integer + size pk = case kindToSize pk of + {SB -> 1; UB -> 1; HW -> 2; UHW -> 2; W -> 4; D -> 8; F -> 4; DF -> 8} + +mangleIndexTree (StIndex pk base off) = + case pk of + CharKind -> StPrim IntAddOp [base, off] + _ -> StPrim IntAddOp [base, off__2] + where + off__2 = StPrim SllOp [off, StInt (shift pk)] + shift :: PrimKind -> Integer + shift DoubleKind = 3 + shift _ = 2 + +cvtLitLit :: String -> String +cvtLitLit "stdin" = "__iob+0x0" -- This one is probably okay... +cvtLitLit "stdout" = "__iob+0x14" -- but these next two are dodgy at best +cvtLitLit "stderr" = "__iob+0x28" +cvtLitLit s + | isHex s = s + | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''") + where + isHex ('0':'x':xs) = all isHexDigit xs + isHex _ = False + -- Now, where have I seen this before? + isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f' + + +\end{code} + +spRel gives us a stack relative addressing mode for volatile temporaries +and for excess call arguments. + +\begin{code} + +spRel + :: Int -- desired stack offset in words, positive or negative + -> Addr +spRel n = AddrRegImm sp (ImmInt (n * 4)) + +stackArgLoc = 23 :: Int -- where to stack extra call arguments (beyond 6x32 bits) + +\end{code} + +\begin{code} + +getNewRegNCG :: PrimKind -> SUniqSM Reg +getNewRegNCG pk = + getSUnique `thenSUs` \ u -> + returnSUs (mkReg u pk) + +\end{code} |