X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStix.lhs;h=ac10ae2d8e3b989ef727cdf456e77752c261f6b3;hb=225d251337438e2f7870f0ec2781b1c616ef7462;hp=10521a3d68aad6409e0941df67a63e6f60b691d5;hpb=9d4c03805bafb6b1e1d47306b6a6c591c998e517;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index 10521a3..ac10ae2 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -1,28 +1,44 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1996 +% (c) The AQUA Project, Glasgow University, 1993-1998 % \begin{code} -#include "HsVersions.h" - module Stix ( - CodeSegment(..), StixReg(..), StixTree(..), SYN_IE(StixTreeList), - sStLitLbl, + CodeSegment(..), StixReg(..), StixTree(..), StixTreeList, + pprStixTrees, pprStixTree, ppStixReg, + stixCountTempUses, stixSubst, + DestInfo(..), hasDestInfo, + + stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, + stgHp, stgHpLim, stgTagReg, stgR9, stgR10, + stgCurrentTSO, stgCurrentNursery, + + fixedHS, arrWordsHS, arrPtrsHS, + + NatM, initNat, thenNat, returnNat, + mapNat, mapAndUnzipNat, mapAccumLNat, + getUniqueNat, getDeltaNat, setDeltaNat, + NatM_State, mkNatM_State, + uniqOfNatM_State, deltaOfNatM_State, - stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg, - stgSpA, stgSuA, stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg, - stgStdUpdRetVecReg, stgStkStubReg, - getUniqLabelNCG + getUniqLabelNCG, getNatLabelNCG, ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(Ratio(Rational)) +#include "HsVersions.h" -import AbsCSyn ( node, infoptr, MagicId(..) ) -import AbsCUtils ( magicIdPrimRep ) -import CLabel ( mkAsmTempLabel ) -import UniqSupply ( returnUs, thenUs, getUnique, SYN_IE(UniqSM) ) -import Unpretty ( uppPStr, SYN_IE(Unpretty) ) +import Ratio ( Rational ) + +import AbsCSyn ( node, tagreg, MagicId(..) ) +import ForeignCall ( CCallConv ) +import CLabel ( mkAsmTempLabel, CLabel, pprCLabel ) +import PrimRep ( PrimRep(..) ) +import PrimOp ( PrimOp ) +import Unique ( Unique ) +import SMRep ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize ) +import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, + UniqSM, thenUs, returnUs, getUniqueUs ) +import Outputable +import FastTypes \end{code} Here is the tag at the nodes of our @StixTree@. Notice its @@ -37,11 +53,9 @@ data StixTree -- We can tag the leaves with constants/immediates. | StInt Integer -- ** add Kind at some point + | StFloat Rational | StDouble Rational | StString FAST_STRING - | StLitLbl Unpretty -- literal labels - -- (will be _-prefixed on some machines) - | StLitLit FAST_STRING -- innards from CLitLit | StCLbl CLabel -- labels that we might index into -- Abstract registers of various kinds @@ -69,10 +83,15 @@ data StixTree | StFunBegin CLabel | StFunEnd CLabel - -- An unconditional jump. This instruction is terminal. - -- Dynamic targets are allowed + -- An unconditional jump. This instruction may or may not jump + -- out of the register allocation domain (basic block, more or + -- less). For correct register allocation when this insn is used + -- to jump through a jump table, we optionally allow a list of + -- the exact targets to be attached, so that the allocator can + -- easily construct the exact flow edges leaving this insn. + -- Dynamic targets are allowed. - | StJump StixTree + | StJump DestInfo StixTree -- A fall-through, from slow to fast @@ -93,14 +112,77 @@ data StixTree -- Calls to C functions - | StCall FAST_STRING PrimRep [StixTree] + | StCall FAST_STRING CCallConv PrimRep [StixTree] + + -- A volatile memory scratch array, which is allocated + -- relative to the stack pointer. It is an array of + -- ptr/word/int sized things. Do not expect to be preserved + -- beyond basic blocks or over a ccall. Current max size + -- is 6, used in StixInteger. + + | StScratchWord Int -- Assembly-language comments | StComment FAST_STRING -sStLitLbl :: FAST_STRING -> StixTree -sStLitLbl s = StLitLbl (uppPStr s) + +-- used by insnFuture in RegAllocInfo.lhs +data DestInfo + = NoDestInfo -- no supplied dests; infer from context + | DestInfo [CLabel] -- precisely these dests and no others + +hasDestInfo NoDestInfo = False +hasDestInfo (DestInfo _) = True + +pprDests :: DestInfo -> SDoc +pprDests NoDestInfo = text "NoDestInfo" +pprDests (DestInfo dsts) = brack (hsep (map pprCLabel dsts)) + + +pprStixTrees :: [StixTree] -> SDoc +pprStixTrees ts + = vcat [ + vcat (map pprStixTree ts), + char ' ', + char ' ' + ] + +paren t = char '(' <> t <> char ')' +brack t = char '[' <> t <> char ']' + +pprStixTree :: StixTree -> SDoc +pprStixTree t + = case t of + StSegment cseg -> paren (ppCodeSegment cseg) + StInt i -> paren (integer i) + StFloat rat -> paren (text "Float" <+> rational rat) + StDouble rat -> paren (text "Double" <+> rational rat) + StString str -> paren (text "Str `" <> ptext str <> char '\'') + StComment str -> paren (text "Comment" <+> ptext str) + StCLbl lbl -> pprCLabel lbl + StReg reg -> ppStixReg reg + StIndex k b o -> paren (pprStixTree b <+> char '+' <> + ppr k <+> pprStixTree o) + StInd k t -> ppr k <> char '[' <> pprStixTree t <> char ']' + StAssign k d s -> pprStixTree d <> text " :=" <> ppr k + <> text " " <> pprStixTree s + StLabel ll -> pprCLabel ll <+> char ':' + StFunBegin ll -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll) + StFunEnd ll -> paren (text "FunEnd" <+> pprCLabel ll) + StJump dsts t -> paren (text "Jump" <+> pprDests dsts <+> pprStixTree t) + StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll) + StCondJump l t -> paren (text "JumpC" <+> pprCLabel l + <+> pprStixTree t) + StData k ds -> paren (text "Data" <+> ppr k <+> + hsep (map pprStixTree ds)) + StPrim op ts -> paren (text "Prim" <+> ppr op <+> + hsep (map pprStixTree ts)) + StCall nm cc k args + -> paren (text "Call" <+> ptext nm <+> + ppr cc <+> ppr k <+> + hsep (map pprStixTree args)) + StScratchWord i -> text "ScratchWord" <> paren (int i) \end{code} Stix registers can have two forms. They {\em may} or {\em may not} @@ -112,6 +194,27 @@ data StixReg | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in -- the abstract C. + +ppStixReg (StixMagicId mid) + = ppMId mid +ppStixReg (StixTemp u pr) + = hcat [text "Temp(", ppr u, ppr pr, char ')'] + + +ppMId BaseReg = text "BaseReg" +ppMId (VanillaReg kind n) = hcat [ppr kind, text "IntReg(", + int (iBox n), char ')'] +ppMId (FloatReg n) = hcat [text "FltReg(", int (iBox n), char ')'] +ppMId (DoubleReg n) = hcat [text "DblReg(", int (iBox n), char ')'] +ppMId (LongReg kind n) = hcat [ppr kind, text "LongReg(", + int (iBox n), char ')'] +ppMId Sp = text "Sp" +ppMId Su = text "Su" +ppMId SpLim = text "SpLim" +ppMId Hp = text "Hp" +ppMId HpLim = text "HpLim" +ppMId CurCostCentre = text "CCC" +ppMId VoidReg = text "VoidReg" \end{code} We hope that every machine supports the idea of data segment and text @@ -119,35 +222,185 @@ segment (or that it has no segments at all, and we can lump these together). \begin{code} -data CodeSegment = DataSegment | TextSegment deriving Eq +data CodeSegment = DataSegment | TextSegment | RoDataSegment deriving (Eq, Show) +ppCodeSegment = text . show type StixTreeList = [StixTree] -> [StixTree] \end{code} Stix Trees for STG registers: \begin{code} -stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg, stgSpA, - stgSuA, stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg, - stgStdUpdRetVecReg, stgStkStubReg :: StixTree +stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim + :: StixTree stgBaseReg = StReg (StixMagicId BaseReg) -stgStkOReg = StReg (StixMagicId StkOReg) stgNode = StReg (StixMagicId node) -stgInfoPtr = StReg (StixMagicId infoptr) -stgTagReg = StReg (StixMagicId TagReg) -stgRetReg = StReg (StixMagicId RetReg) -stgSpA = StReg (StixMagicId SpA) -stgSuA = StReg (StixMagicId SuA) -stgSpB = StReg (StixMagicId SpB) -stgSuB = StReg (StixMagicId SuB) +stgTagReg = StReg (StixMagicId tagreg) +stgSp = StReg (StixMagicId Sp) +stgSu = StReg (StixMagicId Su) +stgSpLim = StReg (StixMagicId SpLim) stgHp = StReg (StixMagicId Hp) stgHpLim = StReg (StixMagicId HpLim) -stgLivenessReg = StReg (StixMagicId LivenessReg) -stgStdUpdRetVecReg = StReg (StixMagicId StdUpdRetVecReg) -stgStkStubReg = StReg (StixMagicId StkStubReg) +stgCurrentTSO = StReg (StixMagicId CurrentTSO) +stgCurrentNursery = StReg (StixMagicId CurrentNursery) +stgR9 = StReg (StixMagicId (VanillaReg WordRep (_ILIT 9))) +stgR10 = StReg (StixMagicId (VanillaReg WordRep (_ILIT 10))) + +getNatLabelNCG :: NatM CLabel +getNatLabelNCG + = getUniqueNat `thenNat` \ u -> + returnNat (mkAsmTempLabel u) getUniqLabelNCG :: UniqSM CLabel getUniqLabelNCG - = getUnique `thenUs` \ u -> + = getUniqueUs `thenUs` \ u -> returnUs (mkAsmTempLabel u) + +fixedHS = StInt (toInteger fixedHdrSize) +arrWordsHS = StInt (toInteger arrWordsHdrSize) +arrPtrsHS = StInt (toInteger arrPtrsHdrSize) +\end{code} + +Stix optimisation passes may wish to find out how many times a +given temporary appears in a tree, so as to be able to decide +whether or not to inline the assignment's RHS at usage site(s). + +\begin{code} +stixCountTempUses :: Unique -> StixTree -> Int +stixCountTempUses u t + = let qq = stixCountTempUses u + in + case t of + StReg reg + -> case reg of + StixTemp uu pr -> if u == uu then 1 else 0 + StixMagicId mid -> 0 + + StIndex pk t1 t2 -> qq t1 + qq t2 + StInd pk t1 -> qq t1 + StAssign pk t1 t2 -> qq t1 + qq t2 + StJump dsts t1 -> qq t1 + StCondJump lbl t1 -> qq t1 + StData pk ts -> sum (map qq ts) + StPrim op ts -> sum (map qq ts) + StCall nm cconv pk ts -> sum (map qq ts) + + StSegment _ -> 0 + StInt _ -> 0 + StFloat _ -> 0 + StDouble _ -> 0 + StString _ -> 0 + StCLbl _ -> 0 + StLabel _ -> 0 + StFunBegin _ -> 0 + StFunEnd _ -> 0 + StFallThrough _ -> 0 + StScratchWord _ -> 0 + StComment _ -> 0 + + +stixSubst :: Unique -> StixTree -> StixTree -> StixTree +stixSubst u new_u in_this_tree + = stixMapUniques f in_this_tree + where + f :: Unique -> Maybe StixTree + f uu = if uu == u then Just new_u else Nothing + + +stixMapUniques :: (Unique -> Maybe StixTree) -> StixTree -> StixTree +stixMapUniques f t + = let qq = stixMapUniques f + in + case t of + StReg reg + -> case reg of + StixMagicId mid -> t + StixTemp uu pr + -> case f uu of + Just xx -> xx + Nothing -> t + + StIndex pk t1 t2 -> StIndex pk (qq t1) (qq t2) + StInd pk t1 -> StInd pk (qq t1) + StAssign pk t1 t2 -> StAssign pk (qq t1) (qq t2) + StJump dsts t1 -> StJump dsts (qq t1) + StCondJump lbl t1 -> StCondJump lbl (qq t1) + StData pk ts -> StData pk (map qq ts) + StPrim op ts -> StPrim op (map qq ts) + StCall nm cconv pk ts -> StCall nm cconv pk (map qq ts) + + StSegment _ -> t + StInt _ -> t + StFloat _ -> t + StDouble _ -> t + StString _ -> t + StCLbl _ -> t + StLabel _ -> t + StFunBegin _ -> t + StFunEnd _ -> t + StFallThrough _ -> t + StScratchWord _ -> t + StComment _ -> t +\end{code} + +\begin{code} +data NatM_State = NatM_State UniqSupply Int +type NatM result = NatM_State -> (result, NatM_State) + +mkNatM_State :: UniqSupply -> Int -> NatM_State +mkNatM_State = NatM_State + +uniqOfNatM_State (NatM_State us delta) = us +deltaOfNatM_State (NatM_State us delta) = delta + + +initNat :: NatM_State -> NatM a -> (a, NatM_State) +initNat init_st m = case m init_st of { (r,st) -> (r,st) } + +thenNat :: NatM a -> (a -> NatM b) -> NatM b +thenNat expr cont st + = case expr st of { (result, st') -> cont result st' } + +returnNat :: a -> NatM a +returnNat result st = (result, st) + +mapNat :: (a -> NatM b) -> [a] -> NatM [b] +mapNat f [] = returnNat [] +mapNat f (x:xs) + = f x `thenNat` \ r -> + mapNat f xs `thenNat` \ rs -> + returnNat (r:rs) + +mapAndUnzipNat :: (a -> NatM (b,c)) -> [a] -> NatM ([b],[c]) +mapAndUnzipNat f [] = returnNat ([],[]) +mapAndUnzipNat f (x:xs) + = f x `thenNat` \ (r1, r2) -> + mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) -> + returnNat (r1:rs1, r2:rs2) + +mapAccumLNat :: (acc -> x -> NatM (acc, y)) + -> acc + -> [x] + -> NatM (acc, [y]) + +mapAccumLNat f b [] + = returnNat (b, []) +mapAccumLNat f b (x:xs) + = f b x `thenNat` \ (b__2, x__2) -> + mapAccumLNat f b__2 xs `thenNat` \ (b__3, xs__2) -> + returnNat (b__3, x__2:xs__2) + + +getUniqueNat :: NatM Unique +getUniqueNat (NatM_State us delta) + = case splitUniqSupply us of + (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta)) + +getDeltaNat :: NatM Int +getDeltaNat st@(NatM_State us delta) + = (delta, st) + +setDeltaNat :: Int -> NatM () +setDeltaNat delta (NatM_State us _) + = ((), NatM_State us delta) \end{code}