X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStix.lhs;h=5eb0362ddcc5ac15d4ebce2851b8677d7acf23e4;hb=e2a7f07969b47fef0cdf284e1bf98a0ad7b01d76;hp=e2d4aa7b4e9e926091717ee8f328da7444996f5b;hpb=10521d8418fd3a1cf32882718b5bd28992db36fd;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index e2d4aa7..5eb0362 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -1,176 +1,214 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1998 % \begin{code} -#include "HsVersions.h" - module Stix ( - CodeSegment(..), StixReg(..), StixTree(..), StixTreeList(..), - sStLitLbl, + CodeSegment(..), StixReg(..), StixTree(..), StixTreeList, + sStLitLbl, pprStixTrees, - stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg, - stgSpA, stgSuA, stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg, --- stgActivityReg, - stgStdUpdRetVecReg, stgStkStubReg, + stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim, stgTagReg, getUniqLabelNCG, - -- And for self-sufficiency, by golly... - MagicId, CLabel, PrimKind, PrimOp, Unique, - SplitUniqSupply, SUniqSM(..) + fixedHS, arrHS ) where -import AbsCSyn ( MagicId(..), kindFromMagicId, node, infoptr ) -import AbsPrel ( showPrimOp, PrimOp - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import CLabelInfo ( CLabel, mkAsmTempLabel ) +#include "HsVersions.h" + +import Ratio ( Rational ) + +import AbsCSyn ( node, tagreg, MagicId(..) ) +import AbsCUtils ( magicIdPrimRep ) +import CallConv ( CallConv, pprCallConv ) +import CLabel ( mkAsmTempLabel, CLabel, pprCLabel, pprCLabel_asm ) +import PrimRep ( PrimRep, showPrimRep ) +import PrimOp ( PrimOp, pprPrimOp ) +import Unique ( Unique ) +import SMRep ( fixedHdrSize, arrHdrSize ) +import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM ) import Outputable -import PrimKind ( PrimKind(..) ) -import SplitUniq -import Unique -import Unpretty -import Util \end{code} Here is the tag at the nodes of our @StixTree@. Notice its -relationship with @PrimOp@ in prelude/PrimOps. +relationship with @PrimOp@ in prelude/PrimOp. \begin{code} +data StixTree + = -- Segment (text or data) -data StixTree = - - -- Segment (text or data) - - StSegment CodeSegment + StSegment CodeSegment - -- We can tag the leaves with constants/immediates. + -- We can tag the leaves with constants/immediates. - | StInt Integer -- ** add Kind at some point -#if __GLASGOW_HASKELL__ <= 22 - | StDouble Double -#else - | StDouble Rational -#endif - | 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 + | StInt Integer -- ** add Kind at some point + | StDouble Rational + | StString FAST_STRING + | StLitLbl SDoc -- literal labels + -- (will be _-prefixed on some machines) - -- Abstract registers of various kinds + | StCLbl CLabel -- labels that we might index into - | StReg StixReg + -- Abstract registers of various kinds - -- A typed offset from a base location + | StReg StixReg - | StIndex PrimKind StixTree StixTree -- kind, base, offset + -- A typed offset from a base location - -- An indirection from an address to its contents. + | StIndex PrimRep StixTree StixTree -- kind, base, offset - | StInd PrimKind StixTree + -- An indirection from an address to its contents. - -- Assignment is typed to determine size and register placement + | StInd PrimRep StixTree - | StAssign PrimKind StixTree StixTree -- dst, src + -- Assignment is typed to determine size and register placement - -- A simple assembly label that we might jump to. + | StAssign PrimRep StixTree StixTree -- dst, src - | StLabel CLabel + -- A simple assembly label that we might jump to. - -- A function header and footer + | StLabel CLabel - | StFunBegin CLabel - | StFunEnd CLabel + -- A function header and footer - -- An unconditional jump. This instruction is terminal. - -- Dynamic targets are allowed + | StFunBegin CLabel + | StFunEnd CLabel - | StJump StixTree + -- An unconditional jump. This instruction is terminal. + -- Dynamic targets are allowed - -- A fall-through, from slow to fast + | StJump StixTree - | StFallThrough CLabel + -- A fall-through, from slow to fast - -- A conditional jump. This instruction can be non-terminal :-) - -- Only static, local, forward labels are allowed + | StFallThrough CLabel - | StCondJump CLabel StixTree + -- A conditional jump. This instruction can be non-terminal :-) + -- Only static, local, forward labels are allowed - -- Raw data (as in an info table). + | StCondJump CLabel StixTree - | StData PrimKind [StixTree] + -- Raw data (as in an info table). - -- Primitive Operations + | StData PrimRep [StixTree] - | StPrim PrimOp [StixTree] + -- Primitive Operations - -- Calls to C functions + | StPrim PrimOp [StixTree] - | StCall FAST_STRING PrimKind [StixTree] + -- Calls to C functions - -- Comments, of course + | StCall FAST_STRING CallConv PrimRep [StixTree] - | StComment FAST_STRING -- For assembly comments + -- Assembly-language comments - deriving () + | StComment FAST_STRING sStLitLbl :: FAST_STRING -> StixTree -sStLitLbl s = StLitLbl (uppPStr s) +sStLitLbl s = StLitLbl (ptext s) + + +pprStixTrees :: [StixTree] -> SDoc +pprStixTrees ts + = vcat [ + vcat (map ppStixTree ts), + char ' ', + char ' ' + ] + +paren t = char '(' <> t <> char ')' + +ppStixTree :: StixTree -> SDoc +ppStixTree t + = case t of + StSegment cseg -> paren (ppCodeSegment cseg) + StInt i -> paren (integer i) + StDouble rat -> paren (text "Double" <+> rational rat) + StString str -> paren (text "Str" <+> ptext str) + StComment str -> paren (text "Comment" <+> ptext str) + StLitLbl sd -> sd + StCLbl lbl -> pprCLabel lbl + StReg reg -> ppStixReg reg + StIndex k b o -> paren (ppStixTree b <+> char '+' <> + pprPrimRep k <+> ppStixTree o) + StInd k t -> pprPrimRep k <> char '[' <> ppStixTree t <> char ']' + StAssign k d s -> ppStixTree d <> text " :=" <> pprPrimRep k + <> text " " <> ppStixTree s + StLabel ll -> pprCLabel ll <+> char ':' + StFunBegin ll -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll) + StFunEnd ll -> paren (text "FunEnd" <+> pprCLabel ll) + StJump t -> paren (text "Jump" <+> ppStixTree t) + StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll) + StCondJump l t -> paren (text "JumpC" <+> pprCLabel l <+> ppStixTree t) + StData k ds -> paren (text "Data" <+> pprPrimRep k <+> + hsep (map ppStixTree ds)) + StPrim op ts -> paren (text "Prim" <+> pprPrimOp op <+> hsep (map ppStixTree ts)) + StCall nm cc k args + -> paren (text "Call" <+> ptext nm <+> + pprCallConv cc <+> pprPrimRep k <+> hsep (map ppStixTree args)) + where + pprPrimRep = text . showPrimRep \end{code} Stix registers can have two forms. They {\em may} or {\em may not} -map to real, machine level registers. +map to real, machine-level registers. \begin{code} +data StixReg + = StixMagicId MagicId -- Regs which are part of the abstract machine model -data StixReg = StixMagicId MagicId -- Regs which are part of the abstract machine model - - | StixTemp Unique PrimKind -- "Regs" which model local variables (CTemps) in + | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in -- the abstract C. - deriving () +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 [text "IntReg(", int (I# n), char ')'] +ppMId (FloatReg n) = hcat [text "FltReg(", int (I# n), char ')'] +ppMId (DoubleReg n) = hcat [text "DblReg(", int (I# n), char ')'] +ppMId (LongReg kind n) = hcat [text "LongReg(", int (I# 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 -segment (or that it has no segments at all, and we can lump these together). +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 deriving (Eq, Show) +ppCodeSegment = text . show type StixTreeList = [StixTree] -> [StixTree] - \end{code} --- Stix Trees for STG registers - +Stix Trees for STG registers: \begin{code} - -stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg, stgSpA, stgSuA, - stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg{-, stgActivityReg-}, stgStdUpdRetVecReg, - stgStkStubReg :: 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) -stgHp = StReg (StixMagicId Hp) -stgHpLim = StReg (StixMagicId HpLim) -stgLivenessReg = StReg (StixMagicId LivenessReg) ---stgActivityReg = StReg (StixMagicId ActivityReg) -stgStdUpdRetVecReg = StReg (StixMagicId StdUpdRetVecReg) -stgStkStubReg = StReg (StixMagicId StkStubReg) - -getUniqLabelNCG :: SUniqSM CLabel -getUniqLabelNCG = - getSUnique `thenSUs` \ u -> - returnSUs (mkAsmTempLabel u) - +stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim + :: StixTree + +stgBaseReg = StReg (StixMagicId BaseReg) +stgNode = StReg (StixMagicId node) +stgTagReg = StReg (StixMagicId tagreg) +stgSp = StReg (StixMagicId Sp) +stgSu = StReg (StixMagicId Su) +stgSpLim = StReg (StixMagicId SpLim) +stgHp = StReg (StixMagicId Hp) +stgHpLim = StReg (StixMagicId HpLim) + +getUniqLabelNCG :: UniqSM CLabel +getUniqLabelNCG + = getUniqueUs `thenUs` \ u -> + returnUs (mkAsmTempLabel u) + +fixedHS = StInt (toInteger fixedHdrSize) +arrHS = StInt (toInteger arrHdrSize) \end{code}