diff options
Diffstat (limited to 'compiler')
29 files changed, 997 insertions, 1134 deletions
diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs index 4f8bdbd77a..797940c5a2 100644 --- a/compiler/GHC/Cmm.hs +++ b/compiler/GHC/Cmm.hs @@ -6,13 +6,13 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} - +{-# LANGUAGE FlexibleContexts #-} module GHC.Cmm ( -- * Cmm top-level datatypes CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup, CmmDecl, CmmDeclSRTs, GenCmmDecl(..), - CmmGraph, GenCmmGraph(..), + CmmGraph, GenCmmGraph(..), toBlockMap, revPostorder, CmmBlock, RawCmmDecl, Section(..), SectionType(..), GenCmmStatics(..), type CmmStatics, type RawCmmStatics, CmmStatic(..), @@ -30,10 +30,14 @@ module GHC.Cmm ( -- * Statements, expressions and types module GHC.Cmm.Node, module GHC.Cmm.Expr, + + -- * Pretty-printing + pprCmms, pprCmmGroup, pprSection, pprStatic ) where import GHC.Prelude +import GHC.Platform import GHC.Types.Id import GHC.Types.CostCentre import GHC.Cmm.CLabel @@ -46,7 +50,10 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Utils.Outputable + +import Data.List (intersperse) import Data.ByteString (ByteString) +import qualified Data.ByteString as BS ----------------------------------------------------------------------------- -- Cmm, GenCmm @@ -102,6 +109,10 @@ data GenCmmDecl d h g deriving (Functor) +instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i) + => OutputableP Platform (GenCmmDecl d info i) where + pdoc = pprTop + type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph @@ -119,6 +130,26 @@ type CmmGraph = GenCmmGraph CmmNode data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } type CmmBlock = Block CmmNode C C +instance OutputableP Platform CmmGraph where + pdoc = pprCmmGraph + +toBlockMap :: CmmGraph -> LabelMap CmmBlock +toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body + +pprCmmGraph :: Platform -> CmmGraph -> SDoc +pprCmmGraph platform g + = text "{" <> text "offset" + $$ nest 2 (vcat $ map (pdoc platform) blocks) + $$ text "}" + where blocks = revPostorder g + -- revPostorder has the side-effect of discarding unreachable code, + -- so pretty-printed Cmm will omit any unreachable blocks. This can + -- sometimes be confusing. + +revPostorder :: CmmGraph -> [CmmBlock] +revPostorder g = {-# SCC "revPostorder" #-} + revPostorderFrom (toBlockMap g) (g_entry g) + ----------------------------------------------------------------------------- -- Info Tables ----------------------------------------------------------------------------- @@ -128,6 +159,14 @@ type CmmBlock = Block CmmNode C C data CmmTopInfo = TopInfo { info_tbls :: LabelMap CmmInfoTable , stack_info :: CmmStackInfo } +instance OutputableP Platform CmmTopInfo where + pdoc = pprTopInfo + +pprTopInfo :: Platform -> CmmTopInfo -> SDoc +pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) = + vcat [text "info_tbls: " <> pdoc platform info_tbl, + text "stack_info: " <> ppr stack_info] + topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos) topInfoTable _ = Nothing @@ -145,6 +184,13 @@ data CmmStackInfo -- we want to do the stack manipulation manually. } +instance Outputable CmmStackInfo where + ppr = pprStackInfo + +pprStackInfo :: CmmStackInfo -> SDoc +pprStackInfo (StackInfo {arg_space=arg_space}) = + text "arg_space: " <> ppr arg_space + -- | Info table as a haskell data type data CmmInfoTable = CmmInfoTable { @@ -169,6 +215,10 @@ data CmmInfoTable -- GHC.Cmm.Info.Build.doSRTs. } deriving Eq +instance OutputableP Platform CmmInfoTable where + pdoc = pprInfoTable + + data ProfilingInfo = NoProfilingInfo | ProfilingInfo ByteString ByteString -- closure_type, closure_desc @@ -233,6 +283,9 @@ data CmmStatic | CmmFileEmbed FilePath -- ^ an embedded binary file +instance OutputableP Platform CmmStatic where + pdoc = pprStatic + instance Outputable CmmStatic where ppr (CmmStaticLit lit) = text "CmmStaticLit" <+> ppr lit ppr (CmmUninitialised n) = text "CmmUninitialised" <+> ppr n @@ -254,6 +307,9 @@ data GenCmmStatics (rawOnly :: Bool) where -> [CmmStatic] -- The static data itself -> GenCmmStatics a +instance OutputableP Platform (GenCmmStatics a) where + pdoc = pprStatics + type CmmStatics = GenCmmStatics 'False type RawCmmStatics = GenCmmStatics 'True @@ -293,3 +349,122 @@ instance OutputableP env instr => OutputableP env (GenBasicBlock instr) where pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc pprBBlock (BasicBlock ident stmts) = hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) + + +-- -------------------------------------------------------------------------- +-- Pretty-printing Cmm +-- -------------------------------------------------------------------------- +-- +-- This is where we walk over Cmm emitting an external representation, +-- suitable for parsing, in a syntax strongly reminiscent of C--. This +-- is the "External Core" for the Cmm layer. +-- +-- As such, this should be a well-defined syntax: we want it to look nice. +-- Thus, we try wherever possible to use syntax defined in [1], +-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We +-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather +-- than C--'s bits8 .. bits64. +-- +-- We try to ensure that all information available in the abstract +-- syntax is reproduced, or reproducible, in the concrete syntax. +-- Data that is not in printed out can be reconstructed according to +-- conventions used in the pretty printer. There are at least two such +-- cases: +-- 1) if a value has wordRep type, the type is not appended in the +-- output. +-- 2) MachOps that operate over wordRep type are printed in a +-- C-style, rather than as their internal MachRep name. +-- +-- These conventions produce much more readable Cmm output. + +pprCmms :: (OutputableP Platform info, OutputableP Platform g) + => Platform -> [GenCmmGroup RawCmmStatics info g] -> SDoc +pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pdoc platform) cmms)) + where + separator = space $$ text "-------------------" $$ space + +pprCmmGroup :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform g) + => Platform -> GenCmmGroup d info g -> SDoc +pprCmmGroup platform tops + = vcat $ intersperse blankLine $ map (pprTop platform) tops + +-- -------------------------------------------------------------------------- +-- Top level `procedure' blocks. +-- + +pprTop :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i) + => Platform -> GenCmmDecl d info i -> SDoc + +pprTop platform (CmmProc info lbl live graph) + + = vcat [ pdoc platform lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live + , nest 8 $ lbrace <+> pdoc platform info $$ rbrace + , nest 4 $ pdoc platform graph + , rbrace ] + +-- -------------------------------------------------------------------------- +-- We follow [1], 4.5 +-- +-- section "data" { ... } +-- + +pprTop platform (CmmData section ds) = + (hang (pprSection platform section <+> lbrace) 4 (pdoc platform ds)) + $$ rbrace + +-- -------------------------------------------------------------------------- +-- Pretty-printing info tables +-- -------------------------------------------------------------------------- + +pprInfoTable :: Platform -> CmmInfoTable -> SDoc +pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep + , cit_prof = prof_info + , cit_srt = srt }) + = vcat [ text "label: " <> pdoc platform lbl + , text "rep: " <> ppr rep + , case prof_info of + NoProfilingInfo -> empty + ProfilingInfo ct cd -> + vcat [ text "type: " <> text (show (BS.unpack ct)) + , text "desc: " <> text (show (BS.unpack cd)) ] + , text "srt: " <> pdoc platform srt ] + +-- -------------------------------------------------------------------------- +-- Static data. +-- Strings are printed as C strings, and we print them as I8[], +-- following C-- +-- + +pprStatics :: Platform -> GenCmmStatics a -> SDoc +pprStatics platform (CmmStatics lbl itbl ccs payload) = + pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload +pprStatics platform (CmmStaticsRaw lbl ds) = vcat ((pdoc platform lbl <> colon) : map (pprStatic platform) ds) + +pprStatic :: Platform -> CmmStatic -> SDoc +pprStatic platform s = case s of + CmmStaticLit lit -> nest 4 $ text "const" <+> pdoc platform lit <> semi + CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) + CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') + CmmFileEmbed path -> nest 4 $ text "incbin " <+> text (show path) + +-- -------------------------------------------------------------------------- +-- data sections +-- +pprSection :: Platform -> Section -> SDoc +pprSection platform (Section t suffix) = + section <+> doubleQuotes (pprSectionType t <+> char '.' <+> pdoc platform suffix) + where + section = text "section" + +pprSectionType :: SectionType -> SDoc +pprSectionType s = doubleQuotes $ case s of + Text -> text "text" + Data -> text "data" + ReadOnlyData -> text "readonly" + ReadOnlyData16 -> text "readonly16" + RelocatableReadOnlyData -> text "relreadonly" + UninitialisedData -> text "uninitialised" + InitArray -> text "initarray" + FiniArray -> text "finiarray" + CString -> text "cstring" + OtherSection s' -> text s' diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index 6d0870e281..adb5150f1a 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -827,6 +827,9 @@ data InfoProvEnt = InfoProvEnt -- Position and information about the info table deriving (Eq, Ord) +instance OutputableP Platform InfoProvEnt where + pdoc platform (InfoProvEnt clabel _ _ _ _) = pdoc platform clabel + -- Constructing Cost Center Labels mkCCLabel :: CostCentre -> CLabel mkCCSLabel :: CostCentreStack -> CLabel diff --git a/compiler/GHC/Cmm/CallConv.hs b/compiler/GHC/Cmm/CallConv.hs index ecee8d902d..a0fee0e5c6 100644 --- a/compiler/GHC/Cmm/CallConv.hs +++ b/compiler/GHC/Cmm/CallConv.hs @@ -12,7 +12,6 @@ import Data.List (nub) import GHC.Cmm.Expr import GHC.Runtime.Heap.Layout import GHC.Cmm (Convention(..)) -import GHC.Cmm.Ppr () -- For Outputable instances import GHC.Platform import GHC.Platform.Profile diff --git a/compiler/GHC/Cmm/Dataflow/Graph.hs b/compiler/GHC/Cmm/Dataflow/Graph.hs index 953ccdabaa..0beaee7357 100644 --- a/compiler/GHC/Cmm/Dataflow/Graph.hs +++ b/compiler/GHC/Cmm/Dataflow/Graph.hs @@ -12,6 +12,7 @@ module GHC.Cmm.Dataflow.Graph , NonLocal(..) , addBlock , bodyList + , bodyToBlockList , emptyBody , labelsDefined , mapGraph @@ -56,6 +57,9 @@ emptyBody = mapEmpty bodyList :: Body' block n -> [(Label,block n C C)] bodyList body = mapToList body +bodyToBlockList :: Body n -> [Block n C C] +bodyToBlockList body = mapElems body + addBlock :: (NonLocal block, HasDebugCallStack) => block C C -> LabelMap (block C C) -> LabelMap (block C C) diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs index 06c1f9aace..b4528ae301 100644 --- a/compiler/GHC/Cmm/DebugBlock.hs +++ b/compiler/GHC/Cmm/DebugBlock.hs @@ -43,7 +43,6 @@ import GHC.Data.FastString ( nilFS, mkFastString ) import GHC.Unit.Module import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Cmm.Ppr.Expr ( pprExpr ) import GHC.Types.SrcLoc import GHC.Types.Tickish import GHC.Utils.Misc ( seqList ) @@ -559,6 +558,6 @@ toUnwindExpr platform e@(CmmMachOp op [e1, e2]) = (MO_Sub{}, u1, u2 ) -> UwMinus u1 u2 (MO_Mul{}, u1, u2 ) -> UwTimes u1 u2 _otherwise -> pprPanic "Unsupported operator in unwind expression!" - (pprExpr platform e) + (pdoc platform e) toUnwindExpr platform e = pprPanic "Unsupported unwind expression!" (pdoc platform e) diff --git a/compiler/GHC/Cmm/Expr.hs b/compiler/GHC/Cmm/Expr.hs index f910e65f04..ccc94a8b92 100644 --- a/compiler/GHC/Cmm/Expr.hs +++ b/compiler/GHC/Cmm/Expr.hs @@ -10,6 +10,7 @@ module GHC.Cmm.Expr , CmmReg(..), cmmRegType, cmmRegWidth , CmmLit(..), cmmLitType , AlignmentSpec(..) + -- TODO: Remove: , LocalReg(..), localRegType , GlobalReg(..), isArgReg, globalRegType , spReg, hpReg, spLimReg, hpLimReg, nodeReg @@ -26,6 +27,11 @@ module GHC.Cmm.Expr , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet , regSetToList + , isTrivialCmmExpr + , hasNoGlobalRegs + , isLit + , isComparisonExpr + , Area(..) , module GHC.Cmm.MachOp , module GHC.Cmm.Type @@ -39,12 +45,16 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm.MachOp import GHC.Cmm.Type +import GHC.Cmm.Reg +import GHC.Utils.Trace (pprTrace) import GHC.Utils.Panic (panic) import GHC.Utils.Outputable import GHC.Types.Unique +import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set +import Numeric ( fromRat ) import GHC.Types.Basic (Alignment, mkAlignment, alignmentOf) @@ -78,14 +88,12 @@ instance Eq CmmExpr where -- Equality ignores the types CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2 _e1 == _e2 = False +instance OutputableP Platform CmmExpr where + pdoc = pprExpr + data AlignmentSpec = NaturallyAligned | Unaligned deriving (Eq, Ord, Show) -data CmmReg - = CmmLocal {-# UNPACK #-} !LocalReg - | CmmGlobal GlobalReg - deriving( Eq, Ord, Show ) - -- | A stack area is either the stack slot where a variable is spilled -- or the stack space where function arguments and results are passed. data Area @@ -94,6 +102,14 @@ data Area -- See Note [Continuation BlockIds] in GHC.Cmm.Node. deriving (Eq, Ord, Show) +instance Outputable Area where + ppr e = pprArea e + +pprArea :: Area -> SDoc +pprArea Old = text "old" +pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ] + + {- Note [Old Area] ~~~~~~~~~~~~~~~~~~ There is a single call area 'Old', allocated at the extreme old @@ -217,6 +233,9 @@ data CmmLit -- of bytes used deriving (Eq, Show) +instance OutputableP Platform CmmLit where + pdoc = pprLit + instance Outputable CmmLit where ppr (CmmInt n w) = text "CmmInt" <+> ppr n <+> ppr w ppr (CmmFloat n w) = text "CmmFloat" <+> text (show n) <+> ppr w @@ -276,38 +295,34 @@ maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op return (CmmMachOp op' args) maybeInvertCmmExpr _ = Nothing ------------------------------------------------------------------------------ --- Local registers ------------------------------------------------------------------------------ - -data LocalReg - = LocalReg {-# UNPACK #-} !Unique !CmmType - -- ^ Parameters: - -- 1. Identifier - -- 2. Type - deriving Show - -instance Eq LocalReg where - (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2 +--------------------------------------------------- +-- CmmExpr predicates +--------------------------------------------------- --- This is non-deterministic but we do not currently support deterministic --- code-generation. See Note [Unique Determinism and code generation] --- See Note [No Ord for Unique] -instance Ord LocalReg where - compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2 +isTrivialCmmExpr :: CmmExpr -> Bool +isTrivialCmmExpr (CmmLoad _ _ _) = False +isTrivialCmmExpr (CmmMachOp _ _) = False +isTrivialCmmExpr (CmmLit _) = True +isTrivialCmmExpr (CmmReg _) = True +isTrivialCmmExpr (CmmRegOff _ _) = True +isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot" -instance Uniquable LocalReg where - getUnique (LocalReg uniq _) = uniq +hasNoGlobalRegs :: CmmExpr -> Bool +hasNoGlobalRegs (CmmLoad e _ _) = hasNoGlobalRegs e +hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es +hasNoGlobalRegs (CmmLit _) = True +hasNoGlobalRegs (CmmReg (CmmLocal _)) = True +hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True +hasNoGlobalRegs _ = False -cmmRegType :: Platform -> CmmReg -> CmmType -cmmRegType _ (CmmLocal reg) = localRegType reg -cmmRegType platform (CmmGlobal reg) = globalRegType platform reg +isLit :: CmmExpr -> Bool +isLit (CmmLit _) = True +isLit _ = False -cmmRegWidth :: Platform -> CmmReg -> Width -cmmRegWidth platform = typeWidth . cmmRegType platform +isComparisonExpr :: CmmExpr -> Bool +isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op +isComparisonExpr _ = False -localRegType :: LocalReg -> CmmType -localRegType (LocalReg _ rep) = rep ----------------------------------------------------------------------------- -- Register-use information for expressions and other types @@ -404,241 +419,159 @@ instance DefinerOfRegs r a => DefinerOfRegs r [a] where foldRegsDefd platform f set as = foldl' (foldRegsDefd platform f) set as {-# INLINABLE foldRegsDefd #-} ------------------------------------------------------------------------------ --- Global STG registers ------------------------------------------------------------------------------ - -data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show ) - ------------------------------------------------------------------------------ --- Global STG registers ------------------------------------------------------------------------------ -{- -Note [Overlapping global registers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The backend might not faithfully implement the abstraction of the STG -machine with independent registers for different values of type -GlobalReg. Specifically, certain pairs of registers (r1, r2) may -overlap in the sense that a store to r1 invalidates the value in r2, -and vice versa. - -Currently this occurs only on the x86_64 architecture where FloatReg n -and DoubleReg n are assigned the same microarchitectural register, in -order to allow functions to receive more Float# or Double# arguments -in registers (as opposed to on the stack). - -There are no specific rules about which registers might overlap with -which other registers, but presumably it's safe to assume that nothing -will overlap with special registers like Sp or BaseReg. - -Use GHC.Cmm.Utils.regsOverlap to determine whether two GlobalRegs overlap -on a particular platform. The instance Eq GlobalReg is syntactic -equality of STG registers and does not take overlap into -account. However it is still used in UserOfRegs/DefinerOfRegs and -there are likely still bugs there, beware! --} - -data GlobalReg - -- Argument and return registers - = VanillaReg -- pointers, unboxed ints and chars - {-# UNPACK #-} !Int -- its number - VGcPtr - - | FloatReg -- single-precision floating-point registers - {-# UNPACK #-} !Int -- its number - - | DoubleReg -- double-precision floating-point registers - {-# UNPACK #-} !Int -- its number - - | LongReg -- long int registers (64-bit, really) - {-# UNPACK #-} !Int -- its number - - | XmmReg -- 128-bit SIMD vector register - {-# UNPACK #-} !Int -- its number - - | YmmReg -- 256-bit SIMD vector register - {-# UNPACK #-} !Int -- its number - - | ZmmReg -- 512-bit SIMD vector register - {-# UNPACK #-} !Int -- its number - - -- STG registers - | Sp -- Stack ptr; points to last occupied stack location. - | SpLim -- Stack limit - | Hp -- Heap ptr; points to last occupied heap location. - | HpLim -- Heap limit register - | CCCS -- Current cost-centre stack - | CurrentTSO -- pointer to current thread's TSO - | CurrentNursery -- pointer to allocation area - | HpAlloc -- allocation count for heap check failure - - -- We keep the address of some commonly-called - -- functions in the register table, to keep code - -- size down: - | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info - | GCEnter1 -- stg_gc_enter_1 - | GCFun -- stg_gc_fun - - -- Base offset for the register table, used for accessing registers - -- which do not have real registers assigned to them. This register - -- will only appear after we have expanded GlobalReg into memory accesses - -- (where necessary) in the native code generator. - | BaseReg - - -- The register used by the platform for the C stack pointer. This is - -- a break in the STG abstraction used exclusively to setup stack unwinding - -- information. - | MachSp - - -- The is a dummy register used to indicate to the stack unwinder where - -- a routine would return to. - | UnwindReturnReg - - -- Base Register for PIC (position-independent code) calculations - -- Only used inside the native code generator. It's exact meaning differs - -- from platform to platform (see module PositionIndependentCode). - | PicBaseReg - - deriving( Show ) - -instance Eq GlobalReg where - VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes - FloatReg i == FloatReg j = i==j - DoubleReg i == DoubleReg j = i==j - LongReg i == LongReg j = i==j - -- NOTE: XMM, YMM, ZMM registers actually are the same registers - -- at least with respect to store at YMM i and then read from XMM i - -- and similarly for ZMM etc. - XmmReg i == XmmReg j = i==j - YmmReg i == YmmReg j = i==j - ZmmReg i == ZmmReg j = i==j - Sp == Sp = True - SpLim == SpLim = True - Hp == Hp = True - HpLim == HpLim = True - CCCS == CCCS = True - CurrentTSO == CurrentTSO = True - CurrentNursery == CurrentNursery = True - HpAlloc == HpAlloc = True - EagerBlackholeInfo == EagerBlackholeInfo = True - GCEnter1 == GCEnter1 = True - GCFun == GCFun = True - BaseReg == BaseReg = True - MachSp == MachSp = True - UnwindReturnReg == UnwindReturnReg = True - PicBaseReg == PicBaseReg = True - _r1 == _r2 = False - --- NOTE: this Ord instance affects the tuple layout in GHCi, see --- Note [GHCi tuple layout] -instance Ord GlobalReg where - compare (VanillaReg i _) (VanillaReg j _) = compare i j - -- Ignore type when seeking clashes - compare (FloatReg i) (FloatReg j) = compare i j - compare (DoubleReg i) (DoubleReg j) = compare i j - compare (LongReg i) (LongReg j) = compare i j - compare (XmmReg i) (XmmReg j) = compare i j - compare (YmmReg i) (YmmReg j) = compare i j - compare (ZmmReg i) (ZmmReg j) = compare i j - compare Sp Sp = EQ - compare SpLim SpLim = EQ - compare Hp Hp = EQ - compare HpLim HpLim = EQ - compare CCCS CCCS = EQ - compare CurrentTSO CurrentTSO = EQ - compare CurrentNursery CurrentNursery = EQ - compare HpAlloc HpAlloc = EQ - compare EagerBlackholeInfo EagerBlackholeInfo = EQ - compare GCEnter1 GCEnter1 = EQ - compare GCFun GCFun = EQ - compare BaseReg BaseReg = EQ - compare MachSp MachSp = EQ - compare UnwindReturnReg UnwindReturnReg = EQ - compare PicBaseReg PicBaseReg = EQ - compare (VanillaReg _ _) _ = LT - compare _ (VanillaReg _ _) = GT - compare (FloatReg _) _ = LT - compare _ (FloatReg _) = GT - compare (DoubleReg _) _ = LT - compare _ (DoubleReg _) = GT - compare (LongReg _) _ = LT - compare _ (LongReg _) = GT - compare (XmmReg _) _ = LT - compare _ (XmmReg _) = GT - compare (YmmReg _) _ = LT - compare _ (YmmReg _) = GT - compare (ZmmReg _) _ = LT - compare _ (ZmmReg _) = GT - compare Sp _ = LT - compare _ Sp = GT - compare SpLim _ = LT - compare _ SpLim = GT - compare Hp _ = LT - compare _ Hp = GT - compare HpLim _ = LT - compare _ HpLim = GT - compare CCCS _ = LT - compare _ CCCS = GT - compare CurrentTSO _ = LT - compare _ CurrentTSO = GT - compare CurrentNursery _ = LT - compare _ CurrentNursery = GT - compare HpAlloc _ = LT - compare _ HpAlloc = GT - compare GCEnter1 _ = LT - compare _ GCEnter1 = GT - compare GCFun _ = LT - compare _ GCFun = GT - compare BaseReg _ = LT - compare _ BaseReg = GT - compare MachSp _ = LT - compare _ MachSp = GT - compare UnwindReturnReg _ = LT - compare _ UnwindReturnReg = GT - compare EagerBlackholeInfo _ = LT - compare _ EagerBlackholeInfo = GT - --- convenient aliases -baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg, - currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: CmmReg -baseReg = CmmGlobal BaseReg -spReg = CmmGlobal Sp -hpReg = CmmGlobal Hp -hpLimReg = CmmGlobal HpLim -spLimReg = CmmGlobal SpLim -nodeReg = CmmGlobal node -currentTSOReg = CmmGlobal CurrentTSO -currentNurseryReg = CmmGlobal CurrentNursery -hpAllocReg = CmmGlobal HpAlloc -cccsReg = CmmGlobal CCCS - -node :: GlobalReg -node = VanillaReg 1 VGcPtr - -globalRegType :: Platform -> GlobalReg -> CmmType -globalRegType platform = \case - (VanillaReg _ VGcPtr) -> gcWord platform - (VanillaReg _ VNonGcPtr) -> bWord platform - (FloatReg _) -> cmmFloat W32 - (DoubleReg _) -> cmmFloat W64 - (LongReg _) -> cmmBits W64 - -- TODO: improve the internal model of SIMD/vectorized registers - -- the right design SHOULd improve handling of float and double code too. - -- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim - (XmmReg _) -> cmmVec 4 (cmmBits W32) - (YmmReg _) -> cmmVec 8 (cmmBits W32) - (ZmmReg _) -> cmmVec 16 (cmmBits W32) - - Hp -> gcWord platform -- The initialiser for all - -- dynamically allocated closures - _ -> bWord platform - -isArgReg :: GlobalReg -> Bool -isArgReg (VanillaReg {}) = True -isArgReg (FloatReg {}) = True -isArgReg (DoubleReg {}) = True -isArgReg (LongReg {}) = True -isArgReg (XmmReg {}) = True -isArgReg (YmmReg {}) = True -isArgReg (ZmmReg {}) = True -isArgReg _ = False +-- -------------------------------------------------------------------------- +-- Pretty-printing expressions +-- -------------------------------------------------------------------------- + +pprExpr :: Platform -> CmmExpr -> SDoc +pprExpr platform e + = case e of + CmmRegOff reg i -> + pprExpr platform (CmmMachOp (MO_Add rep) + [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) + where rep = typeWidth (cmmRegType platform reg) + CmmLit lit -> pprLit platform lit + _other -> pprExpr1 platform e + +-- Here's the precedence table from GHC.Cmm.Parser: +-- %nonassoc '>=' '>' '<=' '<' '!=' '==' +-- %left '|' +-- %left '^' +-- %left '&' +-- %left '>>' '<<' +-- %left '-' '+' +-- %left '/' '*' '%' +-- %right '~' + +-- We just cope with the common operators for now, the rest will get +-- a default conservative behaviour. + +-- %nonassoc '>=' '>' '<=' '<' '!=' '==' +pprExpr1, pprExpr7, pprExpr8 :: Platform -> CmmExpr -> SDoc +pprExpr1 platform (CmmMachOp op [x,y]) + | Just doc <- infixMachOp1 op + = pprExpr7 platform x <+> doc <+> pprExpr7 platform y +pprExpr1 platform e = pprExpr7 platform e + +infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc + +infixMachOp1 (MO_Eq _) = Just (text "==") +infixMachOp1 (MO_Ne _) = Just (text "!=") +infixMachOp1 (MO_Shl _) = Just (text "<<") +infixMachOp1 (MO_U_Shr _) = Just (text ">>") +infixMachOp1 (MO_U_Ge _) = Just (text ">=") +infixMachOp1 (MO_U_Le _) = Just (text "<=") +infixMachOp1 (MO_U_Gt _) = Just (char '>') +infixMachOp1 (MO_U_Lt _) = Just (char '<') +infixMachOp1 _ = Nothing + +-- %left '-' '+' +pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 + = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)]) +pprExpr7 platform (CmmMachOp op [x,y]) + | Just doc <- infixMachOp7 op + = pprExpr7 platform x <+> doc <+> pprExpr8 platform y +pprExpr7 platform e = pprExpr8 platform e + +infixMachOp7 (MO_Add _) = Just (char '+') +infixMachOp7 (MO_Sub _) = Just (char '-') +infixMachOp7 _ = Nothing + +-- %left '/' '*' '%' +pprExpr8 platform (CmmMachOp op [x,y]) + | Just doc <- infixMachOp8 op + = pprExpr8 platform x <+> doc <+> pprExpr9 platform y +pprExpr8 platform e = pprExpr9 platform e + +infixMachOp8 (MO_U_Quot _) = Just (char '/') +infixMachOp8 (MO_Mul _) = Just (char '*') +infixMachOp8 (MO_U_Rem _) = Just (char '%') +infixMachOp8 _ = Nothing + +pprExpr9 :: Platform -> CmmExpr -> SDoc +pprExpr9 platform e = + case e of + CmmLit lit -> pprLit1 platform lit + CmmLoad expr rep align + -> let align_mark = + case align of + NaturallyAligned -> empty + Unaligned -> text "^" + in ppr rep <> align_mark <> brackets (pdoc platform expr) + CmmReg reg -> ppr reg + CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) + CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off) + CmmMachOp mop args -> genMachOp platform mop args + +genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc +genMachOp platform mop args + | Just doc <- infixMachOp mop = case args of + -- dyadic + [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y + + -- unary + [x] -> doc <> pprExpr9 platform x + + _ -> pprTrace "GHC.Cmm.Expr.genMachOp: machop with strange number of args" + (pprMachOp mop <+> + parens (hcat $ punctuate comma (map (pprExpr platform) args))) + empty + + | isJust (infixMachOp1 mop) + || isJust (infixMachOp7 mop) + || isJust (infixMachOp8 mop) = parens (pprExpr platform (CmmMachOp mop args)) + + | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) args)) + where ppr_op = text (map (\c -> if c == ' ' then '_' else c) + (show mop)) + -- replace spaces in (show mop) with underscores, + +-- +-- Unsigned ops on the word size of the machine get nice symbols. +-- All else get dumped in their ugly format. +-- +infixMachOp :: MachOp -> Maybe SDoc +infixMachOp mop + = case mop of + MO_And _ -> Just $ char '&' + MO_Or _ -> Just $ char '|' + MO_Xor _ -> Just $ char '^' + MO_Not _ -> Just $ char '~' + MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :) + _ -> Nothing + +-- -------------------------------------------------------------------------- +-- Pretty-printing literals +-- +-- To minimise line noise we adopt the convention that if the literal +-- has the natural machine word size, we do not append the type +-- -------------------------------------------------------------------------- + +pprLit :: Platform -> CmmLit -> SDoc +pprLit platform lit = case lit of + CmmInt i rep -> + hcat [ (if i < 0 then parens else id)(integer i) + , ppUnless (rep == wordWidth platform) $ + space <> dcolon <+> ppr rep ] + + CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ] + CmmVec lits -> char '<' <> commafy (map (pprLit platform) lits) <> char '>' + CmmLabel clbl -> pdoc platform clbl + CmmLabelOff clbl i -> pdoc platform clbl <> ppr_offset i + CmmLabelDiffOff clbl1 clbl2 i _ -> pdoc platform clbl1 <> char '-' + <> pdoc platform clbl2 <> ppr_offset i + CmmBlock id -> ppr id + CmmHighStackMark -> text "<highSp>" + +pprLit1 :: Platform -> CmmLit -> SDoc +pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit) +pprLit1 platform lit = pprLit platform lit + +ppr_offset :: Int -> SDoc +ppr_offset i + | i==0 = empty + | i>=0 = char '+' <> int i + | otherwise = char '-' <> int (-i) + +commafy :: [SDoc] -> SDoc +commafy xs = fsep $ punctuate comma xs diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs index e76be551f9..f1d60c133b 100644 --- a/compiler/GHC/Cmm/Lint.hs +++ b/compiler/GHC/Cmm/Lint.hs @@ -24,7 +24,6 @@ import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Liveness import GHC.Cmm.Switch (switchTargetsToList) -import GHC.Cmm.Ppr () -- For Outputable instances import GHC.Utils.Outputable import Control.Monad (ap, unless) diff --git a/compiler/GHC/Cmm/Liveness.hs b/compiler/GHC/Cmm/Liveness.hs index a1526be099..769c701c2b 100644 --- a/compiler/GHC/Cmm/Liveness.hs +++ b/compiler/GHC/Cmm/Liveness.hs @@ -20,7 +20,6 @@ import GHC.Prelude import GHC.Platform import GHC.Cmm.BlockId import GHC.Cmm -import GHC.Cmm.Ppr.Expr () -- For Outputable instances import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs index 841c726b14..117ed9747a 100644 --- a/compiler/GHC/Cmm/Node.hs +++ b/compiler/GHC/Cmm/Node.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -28,6 +29,7 @@ module GHC.Cmm.Node ( import GHC.Prelude hiding (succ) import GHC.Platform.Regs +import GHC.Cmm.CLabel import GHC.Cmm.Expr import GHC.Cmm.Switch import GHC.Data.FastString @@ -36,7 +38,9 @@ import GHC.Utils.Outputable import GHC.Runtime.Heap.Layout import GHC.Types.Tickish (CmmTickish) import qualified GHC.Types.Unique as U +import GHC.Types.Basic (FunctionOrData(..)) +import GHC.Platform import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Collections @@ -44,6 +48,7 @@ import GHC.Cmm.Dataflow.Label import Data.Maybe import Data.List (tails,sortBy) import GHC.Types.Unique (nonDetCmpUnique) +import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc @@ -165,6 +170,177 @@ data CmmNode e x where intrbl:: Bool -- whether or not the call is interruptible } -> CmmNode O C +instance OutputableP Platform (CmmNode e x) where + pdoc = pprNode + +pprNode :: Platform -> CmmNode e x -> SDoc +pprNode platform node = pp_node <+> pp_debug + where + pp_node :: SDoc + pp_node = case node of + -- label: + CmmEntry id tscope -> + (sdocOption sdocSuppressUniques $ \case + True -> text "_lbl_" + False -> ppr id + ) + <> colon + <+> ppUnlessOption sdocSuppressTicks (text "//" <+> ppr tscope) + + -- // text + CmmComment s -> text "//" <+> ftext s + + -- //tick bla<...> + CmmTick t -> ppUnlessOption sdocSuppressTicks + (text "//tick" <+> ppr t) + + -- unwind reg = expr; + CmmUnwind regs -> + text "unwind " + <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> pdoc platform e) regs) <> semi + + -- reg = expr; + CmmAssign reg expr -> ppr reg <+> equals <+> pdoc platform expr <> semi + + -- rep[lv] = expr; + CmmStore lv expr align -> rep <> align_mark <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi + where + align_mark = case align of + Unaligned -> text "^" + NaturallyAligned -> empty + rep = ppr ( cmmExprType platform expr ) + + -- call "ccall" foo(x, y)[r1, r2]; + -- ToDo ppr volatile + CmmUnsafeForeignCall target results args -> + hsep [ ppUnless (null results) $ + parens (commafy $ map ppr results) <+> equals, + text "call", + pdoc platform target <> parens (commafy $ map (pdoc platform) args) <> semi] + + -- goto label; + CmmBranch ident -> text "goto" <+> ppr ident <> semi + + -- if (expr) goto t; else goto f; + CmmCondBranch expr t f l -> + hsep [ text "if" + , parens (pdoc platform expr) + , case l of + Nothing -> empty + Just b -> parens (text "likely:" <+> ppr b) + , text "goto" + , ppr t <> semi + , text "else goto" + , ppr f <> semi + ] + + CmmSwitch expr ids -> + hang (hsep [ text "switch" + , range + , if isTrivialCmmExpr expr + then pdoc platform expr + else parens (pdoc platform expr) + , text "{" + ]) + 4 (vcat (map ppCase cases) $$ def) $$ rbrace + where + (cases, mbdef) = switchTargetsFallThrough ids + ppCase (is,l) = hsep + [ text "case" + , commafy $ map integer is + , text ": goto" + , ppr l <> semi + ] + def | Just l <- mbdef = hsep + [ text "default:" + , braces (text "goto" <+> ppr l <> semi) + ] + | otherwise = empty + + range = brackets $ hsep [integer lo, text "..", integer hi] + where (lo,hi) = switchTargetsRange ids + + CmmCall tgt k regs out res updfr_off -> + hcat [ text "call", space + , pprFun tgt, parens (interpp'SP regs), space + , returns <+> + text "args: " <> ppr out <> comma <+> + text "res: " <> ppr res <> comma <+> + text "upd: " <> ppr updfr_off + , semi ] + where pprFun f@(CmmLit _) = pdoc platform f + pprFun f = parens (pdoc platform f) + + returns + | Just r <- k = text "returns to" <+> ppr r <> comma + | otherwise = empty + + CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} -> + hcat $ if i then [text "interruptible", space] else [] ++ + [ text "foreign call", space + , pdoc platform t, text "(...)", space + , text "returns to" <+> ppr s + <+> text "args:" <+> parens (pdoc platform as) + <+> text "ress:" <+> parens (ppr rs) + , text "ret_args:" <+> ppr a + , text "ret_off:" <+> ppr u + , semi ] + + pp_debug :: SDoc + pp_debug = + if not debugIsOn then empty + else case node of + CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry" + CmmComment {} -> empty -- Looks also terrible with text " // CmmComment" + CmmTick {} -> empty + CmmUnwind {} -> text " // CmmUnwind" + CmmAssign {} -> text " // CmmAssign" + CmmStore {} -> text " // CmmStore" + CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall" + CmmBranch {} -> text " // CmmBranch" + CmmCondBranch {} -> text " // CmmCondBranch" + CmmSwitch {} -> text " // CmmSwitch" + CmmCall {} -> text " // CmmCall" + CmmForeignCall {} -> text " // CmmForeignCall" + + commafy :: [SDoc] -> SDoc + commafy xs = hsep $ punctuate comma xs + +instance OutputableP Platform (Block CmmNode C C) where + pdoc = pprBlock +instance OutputableP Platform (Block CmmNode C O) where + pdoc = pprBlock +instance OutputableP Platform (Block CmmNode O C) where + pdoc = pprBlock +instance OutputableP Platform (Block CmmNode O O) where + pdoc = pprBlock + +instance OutputableP Platform (Graph CmmNode e x) where + pdoc = pprGraph + +pprBlock :: IndexedCO x SDoc SDoc ~ SDoc + => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc +pprBlock platform block + = foldBlockNodesB3 ( ($$) . pdoc platform + , ($$) . (nest 4) . pdoc platform + , ($$) . (nest 4) . pdoc platform + ) + block + empty + +pprGraph :: Platform -> Graph CmmNode e x -> SDoc +pprGraph platform = \case + GNil -> empty + GUnit block -> pdoc platform block + GMany entry body exit -> + text "{" + $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pdoc platform) $ bodyToBlockList body) $$ pprMaybeO exit) + $$ text "}" + where pprMaybeO :: OutputableP Platform (Block CmmNode e x) + => MaybeO ex (Block CmmNode e x) -> SDoc + pprMaybeO NothingO = empty + pprMaybeO (JustO block) = pdoc platform block + {- Note [Foreign calls] ~~~~~~~~~~~~~~~~~~~~~~~ A CmmUnsafeForeignCall is used for *unsafe* foreign calls; @@ -291,11 +467,25 @@ data ForeignConvention CmmReturnInfo deriving Eq +instance Outputable ForeignConvention where + ppr = pprForeignConvention + +pprForeignConvention :: ForeignConvention -> SDoc +pprForeignConvention (ForeignConvention c args res ret) = + doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret + data CmmReturnInfo = CmmMayReturn | CmmNeverReturns deriving ( Eq ) +instance Outputable CmmReturnInfo where + ppr = pprReturnInfo + +pprReturnInfo :: CmmReturnInfo -> SDoc +pprReturnInfo CmmMayReturn = empty +pprReturnInfo CmmNeverReturns = text "never returns" + data ForeignTarget -- The target of a foreign call = ForeignTarget -- A foreign procedure CmmExpr -- Its address @@ -304,6 +494,35 @@ data ForeignTarget -- The target of a foreign call CallishMachOp -- Which one deriving Eq +instance OutputableP Platform ForeignTarget where + pdoc = pprForeignTarget + +pprForeignTarget :: Platform -> ForeignTarget -> SDoc +pprForeignTarget platform (ForeignTarget fn c) = + ppr c <+> ppr_target fn + where + ppr_target :: CmmExpr -> SDoc + ppr_target t@(CmmLit _) = pdoc platform t + ppr_target fn' = parens (pdoc platform fn') +pprForeignTarget platform (PrimTarget op) + -- HACK: We're just using a ForeignLabel to get this printed, the label + -- might not really be foreign. + = pdoc platform + (CmmLabel (mkForeignLabel + (mkFastString (show op)) + Nothing ForeignLabelInThisPackage IsFunction)) + +instance Outputable Convention where + ppr = pprConvention + +pprConvention :: Convention -> SDoc +pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>" +pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>" +pprConvention (NativeReturn {}) = text "<native-ret-convention>" +pprConvention Slow = text "<slow-convention>" +pprConvention GC = text "<gc-convention>" + + foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint]) foreignTargetHints target = ( res_hints ++ repeat NoHint diff --git a/compiler/GHC/Cmm/Ppr.hs b/compiler/GHC/Cmm/Ppr.hs deleted file mode 100644 index c7a1579962..0000000000 --- a/compiler/GHC/Cmm/Ppr.hs +++ /dev/null @@ -1,319 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - ----------------------------------------------------------------------------- --- --- Pretty-printing of Cmm as (a superset of) C-- --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ --- --- This is where we walk over CmmNode emitting an external representation, --- suitable for parsing, in a syntax strongly reminiscent of C--. This --- is the "External Core" for the Cmm layer. --- --- As such, this should be a well-defined syntax: we want it to look nice. --- Thus, we try wherever possible to use syntax defined in [1], --- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We --- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather --- than C--'s bits8 .. bits64. --- --- We try to ensure that all information available in the abstract --- syntax is reproduced, or reproducible, in the concrete syntax. --- Data that is not in printed out can be reconstructed according to --- conventions used in the pretty printer. There are at least two such --- cases: --- 1) if a value has wordRep type, the type is not appended in the --- output. --- 2) MachOps that operate over wordRep type are printed in a --- C-style, rather than as their internal MachRep name. --- --- These conventions produce much more readable Cmm output. --- --- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs - -module GHC.Cmm.Ppr - ( module GHC.Cmm.Ppr.Decl - , module GHC.Cmm.Ppr.Expr - ) -where - -import GHC.Prelude hiding (succ) - -import GHC.Platform -import GHC.Cmm.CLabel -import GHC.Cmm -import GHC.Cmm.Utils -import GHC.Cmm.Switch -import GHC.Data.FastString -import GHC.Utils.Outputable -import GHC.Cmm.Ppr.Decl -import GHC.Cmm.Ppr.Expr -import GHC.Utils.Constants (debugIsOn) - -import GHC.Types.Basic -import GHC.Cmm.Dataflow.Block -import GHC.Cmm.Dataflow.Graph - -------------------------------------------------- --- Outputable instances -instance OutputableP Platform InfoProvEnt where - pdoc platform (InfoProvEnt clabel _ _ _ _) = pdoc platform clabel - -instance Outputable CmmStackInfo where - ppr = pprStackInfo - -instance OutputableP Platform CmmTopInfo where - pdoc = pprTopInfo - - -instance OutputableP Platform (CmmNode e x) where - pdoc = pprNode - -instance Outputable Convention where - ppr = pprConvention - -instance Outputable ForeignConvention where - ppr = pprForeignConvention - -instance OutputableP Platform ForeignTarget where - pdoc = pprForeignTarget - -instance Outputable CmmReturnInfo where - ppr = pprReturnInfo - -instance OutputableP Platform (Block CmmNode C C) where - pdoc = pprBlock -instance OutputableP Platform (Block CmmNode C O) where - pdoc = pprBlock -instance OutputableP Platform (Block CmmNode O C) where - pdoc = pprBlock -instance OutputableP Platform (Block CmmNode O O) where - pdoc = pprBlock - -instance OutputableP Platform (Graph CmmNode e x) where - pdoc = pprGraph - -instance OutputableP Platform CmmGraph where - pdoc = pprCmmGraph - ----------------------------------------------------------- --- Outputting types Cmm contains - -pprStackInfo :: CmmStackInfo -> SDoc -pprStackInfo (StackInfo {arg_space=arg_space}) = - text "arg_space: " <> ppr arg_space - -pprTopInfo :: Platform -> CmmTopInfo -> SDoc -pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) = - vcat [text "info_tbls: " <> pdoc platform info_tbl, - text "stack_info: " <> ppr stack_info] - ----------------------------------------------------------- --- Outputting blocks and graphs - -pprBlock :: IndexedCO x SDoc SDoc ~ SDoc - => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc -pprBlock platform block - = foldBlockNodesB3 ( ($$) . pdoc platform - , ($$) . (nest 4) . pdoc platform - , ($$) . (nest 4) . pdoc platform - ) - block - empty - -pprGraph :: Platform -> Graph CmmNode e x -> SDoc -pprGraph platform = \case - GNil -> empty - GUnit block -> pdoc platform block - GMany entry body exit -> - text "{" - $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pdoc platform) $ bodyToBlockList body) $$ pprMaybeO exit) - $$ text "}" - where pprMaybeO :: OutputableP Platform (Block CmmNode e x) - => MaybeO ex (Block CmmNode e x) -> SDoc - pprMaybeO NothingO = empty - pprMaybeO (JustO block) = pdoc platform block - -pprCmmGraph :: Platform -> CmmGraph -> SDoc -pprCmmGraph platform g - = text "{" <> text "offset" - $$ nest 2 (vcat $ map (pdoc platform) blocks) - $$ text "}" - where blocks = revPostorder g - -- revPostorder has the side-effect of discarding unreachable code, - -- so pretty-printed Cmm will omit any unreachable blocks. This can - -- sometimes be confusing. - ---------------------------------------------- --- Outputting CmmNode and types which it contains - -pprConvention :: Convention -> SDoc -pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>" -pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>" -pprConvention (NativeReturn {}) = text "<native-ret-convention>" -pprConvention Slow = text "<slow-convention>" -pprConvention GC = text "<gc-convention>" - -pprForeignConvention :: ForeignConvention -> SDoc -pprForeignConvention (ForeignConvention c args res ret) = - doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret - -pprReturnInfo :: CmmReturnInfo -> SDoc -pprReturnInfo CmmMayReturn = empty -pprReturnInfo CmmNeverReturns = text "never returns" - -pprForeignTarget :: Platform -> ForeignTarget -> SDoc -pprForeignTarget platform (ForeignTarget fn c) = ppr c <+> ppr_target fn - where - ppr_target :: CmmExpr -> SDoc - ppr_target t@(CmmLit _) = pdoc platform t - ppr_target fn' = parens (pdoc platform fn') - -pprForeignTarget platform (PrimTarget op) - -- HACK: We're just using a ForeignLabel to get this printed, the label - -- might not really be foreign. - = pdoc platform - (CmmLabel (mkForeignLabel - (mkFastString (show op)) - Nothing ForeignLabelInThisPackage IsFunction)) - -pprNode :: Platform -> CmmNode e x -> SDoc -pprNode platform node = pp_node <+> pp_debug - where - pp_node :: SDoc - pp_node = case node of - -- label: - CmmEntry id tscope -> - (sdocOption sdocSuppressUniques $ \case - True -> text "_lbl_" - False -> ppr id - ) - <> colon - <+> ppUnlessOption sdocSuppressTicks (text "//" <+> ppr tscope) - - -- // text - CmmComment s -> text "//" <+> ftext s - - -- //tick bla<...> - CmmTick t -> ppUnlessOption sdocSuppressTicks - (text "//tick" <+> ppr t) - - -- unwind reg = expr; - CmmUnwind regs -> - text "unwind " - <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> pdoc platform e) regs) <> semi - - -- reg = expr; - CmmAssign reg expr -> ppr reg <+> equals <+> pdoc platform expr <> semi - - -- rep[lv] = expr; - CmmStore lv expr align -> rep <> align_mark <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi - where - align_mark = case align of - Unaligned -> text "^" - NaturallyAligned -> empty - rep = ppr ( cmmExprType platform expr ) - - -- call "ccall" foo(x, y)[r1, r2]; - -- ToDo ppr volatile - CmmUnsafeForeignCall target results args -> - hsep [ ppUnless (null results) $ - parens (commafy $ map ppr results) <+> equals, - text "call", - pdoc platform target <> parens (commafy $ map (pdoc platform) args) <> semi] - - -- goto label; - CmmBranch ident -> text "goto" <+> ppr ident <> semi - - -- if (expr) goto t; else goto f; - CmmCondBranch expr t f l -> - hsep [ text "if" - , parens (pdoc platform expr) - , case l of - Nothing -> empty - Just b -> parens (text "likely:" <+> ppr b) - , text "goto" - , ppr t <> semi - , text "else goto" - , ppr f <> semi - ] - - CmmSwitch expr ids -> - hang (hsep [ text "switch" - , range - , if isTrivialCmmExpr expr - then pdoc platform expr - else parens (pdoc platform expr) - , text "{" - ]) - 4 (vcat (map ppCase cases) $$ def) $$ rbrace - where - (cases, mbdef) = switchTargetsFallThrough ids - ppCase (is,l) = hsep - [ text "case" - , commafy $ map integer is - , text ": goto" - , ppr l <> semi - ] - def | Just l <- mbdef = hsep - [ text "default:" - , braces (text "goto" <+> ppr l <> semi) - ] - | otherwise = empty - - range = brackets $ hsep [integer lo, text "..", integer hi] - where (lo,hi) = switchTargetsRange ids - - CmmCall tgt k regs out res updfr_off -> - hcat [ text "call", space - , pprFun tgt, parens (interpp'SP regs), space - , returns <+> - text "args: " <> ppr out <> comma <+> - text "res: " <> ppr res <> comma <+> - text "upd: " <> ppr updfr_off - , semi ] - where pprFun f@(CmmLit _) = pdoc platform f - pprFun f = parens (pdoc platform f) - - returns - | Just r <- k = text "returns to" <+> ppr r <> comma - | otherwise = empty - - CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} -> - hcat $ if i then [text "interruptible", space] else [] ++ - [ text "foreign call", space - , pdoc platform t, text "(...)", space - , text "returns to" <+> ppr s - <+> text "args:" <+> parens (pdoc platform as) - <+> text "ress:" <+> parens (ppr rs) - , text "ret_args:" <+> ppr a - , text "ret_off:" <+> ppr u - , semi ] - - pp_debug :: SDoc - pp_debug = - if not debugIsOn then empty - else case node of - CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry" - CmmComment {} -> empty -- Looks also terrible with text " // CmmComment" - CmmTick {} -> empty - CmmUnwind {} -> text " // CmmUnwind" - CmmAssign {} -> text " // CmmAssign" - CmmStore {} -> text " // CmmStore" - CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall" - CmmBranch {} -> text " // CmmBranch" - CmmCondBranch {} -> text " // CmmCondBranch" - CmmSwitch {} -> text " // CmmSwitch" - CmmCall {} -> text " // CmmCall" - CmmForeignCall {} -> text " // CmmForeignCall" - - commafy :: [SDoc] -> SDoc - commafy xs = hsep $ punctuate comma xs diff --git a/compiler/GHC/Cmm/Ppr/Decl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs deleted file mode 100644 index 3b1eff78ff..0000000000 --- a/compiler/GHC/Cmm/Ppr/Decl.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} - - ----------------------------------------------------------------------------- --- --- Pretty-printing of common Cmm types --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - --- --- This is where we walk over Cmm emitting an external representation, --- suitable for parsing, in a syntax strongly reminiscent of C--. This --- is the "External Core" for the Cmm layer. --- --- As such, this should be a well-defined syntax: we want it to look nice. --- Thus, we try wherever possible to use syntax defined in [1], --- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We --- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather --- than C--'s bits8 .. bits64. --- --- We try to ensure that all information available in the abstract --- syntax is reproduced, or reproducible, in the concrete syntax. --- Data that is not in printed out can be reconstructed according to --- conventions used in the pretty printer. There are at least two such --- cases: --- 1) if a value has wordRep type, the type is not appended in the --- output. --- 2) MachOps that operate over wordRep type are printed in a --- C-style, rather than as their internal MachRep name. --- --- These conventions produce much more readable Cmm output. --- --- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs --- - -{-# OPTIONS_GHC -fno-warn-orphans #-} -module GHC.Cmm.Ppr.Decl - ( pprCmms, pprCmmGroup, pprSection, pprStatic - ) -where - -import GHC.Prelude - -import GHC.Platform -import GHC.Cmm.Ppr.Expr -import GHC.Cmm - -import GHC.Utils.Outputable - -import Data.List (intersperse) - -import qualified Data.ByteString as BS - - -pprCmms :: (OutputableP Platform info, OutputableP Platform g) - => Platform -> [GenCmmGroup RawCmmStatics info g] -> SDoc -pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pdoc platform) cmms)) - where - separator = space $$ text "-------------------" $$ space - ------------------------------------------------------------------------------ - -instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i) - => OutputableP Platform (GenCmmDecl d info i) where - pdoc = pprTop - -instance OutputableP Platform (GenCmmStatics a) where - pdoc = pprStatics - -instance OutputableP Platform CmmStatic where - pdoc = pprStatic - -instance OutputableP Platform CmmInfoTable where - pdoc = pprInfoTable - - ------------------------------------------------------------------------------ - -pprCmmGroup :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform g) - => Platform -> GenCmmGroup d info g -> SDoc -pprCmmGroup platform tops - = vcat $ intersperse blankLine $ map (pprTop platform) tops - --- -------------------------------------------------------------------------- --- Top level `procedure' blocks. --- -pprTop :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i) - => Platform -> GenCmmDecl d info i -> SDoc - -pprTop platform (CmmProc info lbl live graph) - - = vcat [ pdoc platform lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live - , nest 8 $ lbrace <+> pdoc platform info $$ rbrace - , nest 4 $ pdoc platform graph - , rbrace ] - --- -------------------------------------------------------------------------- --- We follow [1], 4.5 --- --- section "data" { ... } --- -pprTop platform (CmmData section ds) = - (hang (pprSection platform section <+> lbrace) 4 (pdoc platform ds)) - $$ rbrace - --- -------------------------------------------------------------------------- --- Info tables. - -pprInfoTable :: Platform -> CmmInfoTable -> SDoc -pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep - , cit_prof = prof_info - , cit_srt = srt }) - = vcat [ text "label: " <> pdoc platform lbl - , text "rep: " <> ppr rep - , case prof_info of - NoProfilingInfo -> empty - ProfilingInfo ct cd -> - vcat [ text "type: " <> text (show (BS.unpack ct)) - , text "desc: " <> text (show (BS.unpack cd)) ] - , text "srt: " <> pdoc platform srt ] - -instance Outputable ForeignHint where - ppr NoHint = empty - ppr SignedHint = quotes(text "signed") --- ppr AddrHint = quotes(text "address") --- Temp Jan08 - ppr AddrHint = (text "PtrHint") - --- -------------------------------------------------------------------------- --- Static data. --- Strings are printed as C strings, and we print them as I8[], --- following C-- --- - -pprStatics :: Platform -> GenCmmStatics a -> SDoc -pprStatics platform (CmmStatics lbl itbl ccs payload) = - pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload -pprStatics platform (CmmStaticsRaw lbl ds) = vcat ((pdoc platform lbl <> colon) : map (pprStatic platform) ds) - -pprStatic :: Platform -> CmmStatic -> SDoc -pprStatic platform s = case s of - CmmStaticLit lit -> nest 4 $ text "const" <+> pprLit platform lit <> semi - CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) - CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') - CmmFileEmbed path -> nest 4 $ text "incbin " <+> text (show path) - --- -------------------------------------------------------------------------- --- data sections --- -pprSection :: Platform -> Section -> SDoc -pprSection platform (Section t suffix) = - section <+> doubleQuotes (pprSectionType t <+> char '.' <+> pdoc platform suffix) - where - section = text "section" - -pprSectionType :: SectionType -> SDoc -pprSectionType s = doubleQuotes $ case s of - Text -> text "text" - Data -> text "data" - ReadOnlyData -> text "readonly" - ReadOnlyData16 -> text "readonly16" - RelocatableReadOnlyData -> text "relreadonly" - UninitialisedData -> text "uninitialised" - InitArray -> text "initarray" - FiniArray -> text "finiarray" - CString -> text "cstring" - OtherSection s' -> text s' diff --git a/compiler/GHC/Cmm/Ppr/Expr.hs b/compiler/GHC/Cmm/Ppr/Expr.hs deleted file mode 100644 index 3ef4b07af5..0000000000 --- a/compiler/GHC/Cmm/Ppr/Expr.hs +++ /dev/null @@ -1,299 +0,0 @@ ----------------------------------------------------------------------------- --- --- Pretty-printing of common Cmm types --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - --- --- This is where we walk over Cmm emitting an external representation, --- suitable for parsing, in a syntax strongly reminiscent of C--. This --- is the "External Core" for the Cmm layer. --- --- As such, this should be a well-defined syntax: we want it to look nice. --- Thus, we try wherever possible to use syntax defined in [1], --- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We --- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather --- than C--'s bits8 .. bits64. --- --- We try to ensure that all information available in the abstract --- syntax is reproduced, or reproducible, in the concrete syntax. --- Data that is not in printed out can be reconstructed according to --- conventions used in the pretty printer. There are at least two such --- cases: --- 1) if a value has wordRep type, the type is not appended in the --- output. --- 2) MachOps that operate over wordRep type are printed in a --- C-style, rather than as their internal MachRep name. --- --- These conventions produce much more readable Cmm output. --- --- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs --- -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module GHC.Cmm.Ppr.Expr - ( pprExpr, pprLit - ) -where - -import GHC.Prelude - -import GHC.Platform -import GHC.Cmm.Expr - -import GHC.Utils.Outputable -import GHC.Utils.Trace - -import Data.Maybe -import Numeric ( fromRat ) - ------------------------------------------------------------------------------ - -instance OutputableP Platform CmmExpr where - pdoc = pprExpr - -instance Outputable CmmReg where - ppr e = pprReg e - -instance OutputableP Platform CmmLit where - pdoc = pprLit - -instance Outputable LocalReg where - ppr e = pprLocalReg e - -instance Outputable Area where - ppr e = pprArea e - -instance Outputable GlobalReg where - ppr e = pprGlobalReg e - -instance OutputableP env GlobalReg where - pdoc _ = ppr - --- -------------------------------------------------------------------------- --- Expressions --- - -pprExpr :: Platform -> CmmExpr -> SDoc -pprExpr platform e - = case e of - CmmRegOff reg i -> - pprExpr platform (CmmMachOp (MO_Add rep) - [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) - where rep = typeWidth (cmmRegType platform reg) - CmmLit lit -> pprLit platform lit - _other -> pprExpr1 platform e - --- Here's the precedence table from GHC.Cmm.Parser: --- %nonassoc '>=' '>' '<=' '<' '!=' '==' --- %left '|' --- %left '^' --- %left '&' --- %left '>>' '<<' --- %left '-' '+' --- %left '/' '*' '%' --- %right '~' - --- We just cope with the common operators for now, the rest will get --- a default conservative behaviour. - --- %nonassoc '>=' '>' '<=' '<' '!=' '==' -pprExpr1, pprExpr7, pprExpr8 :: Platform -> CmmExpr -> SDoc -pprExpr1 platform (CmmMachOp op [x,y]) - | Just doc <- infixMachOp1 op - = pprExpr7 platform x <+> doc <+> pprExpr7 platform y -pprExpr1 platform e = pprExpr7 platform e - -infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc - -infixMachOp1 (MO_Eq _) = Just (text "==") -infixMachOp1 (MO_Ne _) = Just (text "!=") -infixMachOp1 (MO_Shl _) = Just (text "<<") -infixMachOp1 (MO_U_Shr _) = Just (text ">>") -infixMachOp1 (MO_U_Ge _) = Just (text ">=") -infixMachOp1 (MO_U_Le _) = Just (text "<=") -infixMachOp1 (MO_U_Gt _) = Just (char '>') -infixMachOp1 (MO_U_Lt _) = Just (char '<') -infixMachOp1 _ = Nothing - --- %left '-' '+' -pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 - = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)]) -pprExpr7 platform (CmmMachOp op [x,y]) - | Just doc <- infixMachOp7 op - = pprExpr7 platform x <+> doc <+> pprExpr8 platform y -pprExpr7 platform e = pprExpr8 platform e - -infixMachOp7 (MO_Add _) = Just (char '+') -infixMachOp7 (MO_Sub _) = Just (char '-') -infixMachOp7 _ = Nothing - --- %left '/' '*' '%' -pprExpr8 platform (CmmMachOp op [x,y]) - | Just doc <- infixMachOp8 op - = pprExpr8 platform x <+> doc <+> pprExpr9 platform y -pprExpr8 platform e = pprExpr9 platform e - -infixMachOp8 (MO_U_Quot _) = Just (char '/') -infixMachOp8 (MO_Mul _) = Just (char '*') -infixMachOp8 (MO_U_Rem _) = Just (char '%') -infixMachOp8 _ = Nothing - -pprExpr9 :: Platform -> CmmExpr -> SDoc -pprExpr9 platform e = - case e of - CmmLit lit -> pprLit1 platform lit - CmmLoad expr rep align - -> let align_mark = - case align of - NaturallyAligned -> empty - Unaligned -> text "^" - in ppr rep <> align_mark <> brackets (pdoc platform expr) - CmmReg reg -> ppr reg - CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) - CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off) - CmmMachOp mop args -> genMachOp platform mop args - -genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc -genMachOp platform mop args - | Just doc <- infixMachOp mop = case args of - -- dyadic - [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y - - -- unary - [x] -> doc <> pprExpr9 platform x - - _ -> pprTrace "GHC.Cmm.Ppr.Expr.genMachOp: machop with strange number of args" - (pprMachOp mop <+> - parens (hcat $ punctuate comma (map (pprExpr platform) args))) - empty - - | isJust (infixMachOp1 mop) - || isJust (infixMachOp7 mop) - || isJust (infixMachOp8 mop) = parens (pprExpr platform (CmmMachOp mop args)) - - | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) args)) - where ppr_op = text (map (\c -> if c == ' ' then '_' else c) - (show mop)) - -- replace spaces in (show mop) with underscores, - --- --- Unsigned ops on the word size of the machine get nice symbols. --- All else get dumped in their ugly format. --- -infixMachOp :: MachOp -> Maybe SDoc -infixMachOp mop - = case mop of - MO_And _ -> Just $ char '&' - MO_Or _ -> Just $ char '|' - MO_Xor _ -> Just $ char '^' - MO_Not _ -> Just $ char '~' - MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :) - _ -> Nothing - --- -------------------------------------------------------------------------- --- Literals. --- To minimise line noise we adopt the convention that if the literal --- has the natural machine word size, we do not append the type --- -pprLit :: Platform -> CmmLit -> SDoc -pprLit platform lit = case lit of - CmmInt i rep -> - hcat [ (if i < 0 then parens else id)(integer i) - , ppUnless (rep == wordWidth platform) $ - space <> dcolon <+> ppr rep ] - - CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ] - CmmVec lits -> char '<' <> commafy (map (pprLit platform) lits) <> char '>' - CmmLabel clbl -> pdoc platform clbl - CmmLabelOff clbl i -> pdoc platform clbl <> ppr_offset i - CmmLabelDiffOff clbl1 clbl2 i _ -> pdoc platform clbl1 <> char '-' - <> pdoc platform clbl2 <> ppr_offset i - CmmBlock id -> ppr id - CmmHighStackMark -> text "<highSp>" - -pprLit1 :: Platform -> CmmLit -> SDoc -pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit) -pprLit1 platform lit = pprLit platform lit - -ppr_offset :: Int -> SDoc -ppr_offset i - | i==0 = empty - | i>=0 = char '+' <> int i - | otherwise = char '-' <> int (-i) - --- -------------------------------------------------------------------------- --- Registers, whether local (temps) or global --- -pprReg :: CmmReg -> SDoc -pprReg r - = case r of - CmmLocal local -> pprLocalReg local - CmmGlobal global -> pprGlobalReg global - --- --- We only print the type of the local reg if it isn't wordRep --- -pprLocalReg :: LocalReg -> SDoc -pprLocalReg (LocalReg uniq rep) = --- = ppr rep <> char '_' <> ppr uniq --- Temp Jan08 - char '_' <> pprUnique uniq <> - (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh - then dcolon <> ptr <> ppr rep - else dcolon <> ptr <> ppr rep) - where - pprUnique unique = sdocOption sdocSuppressUniques $ \case - True -> text "_locVar_" - False -> ppr unique - ptr = empty - --if isGcPtrType rep - -- then doubleQuotes (text "ptr") - -- else empty - --- Stack areas -pprArea :: Area -> SDoc -pprArea Old = text "old" -pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ] - --- needs to be kept in syn with 'GHC.Cmm.Expr.GlobalReg' --- -pprGlobalReg :: GlobalReg -> SDoc -pprGlobalReg gr - = case gr of - VanillaReg n _ -> char 'R' <> int n --- Temp Jan08 --- VanillaReg n VNonGcPtr -> char 'R' <> int n --- VanillaReg n VGcPtr -> char 'P' <> int n - FloatReg n -> char 'F' <> int n - DoubleReg n -> char 'D' <> int n - LongReg n -> char 'L' <> int n - XmmReg n -> text "XMM" <> int n - YmmReg n -> text "YMM" <> int n - ZmmReg n -> text "ZMM" <> int n - Sp -> text "Sp" - SpLim -> text "SpLim" - Hp -> text "Hp" - HpLim -> text "HpLim" - MachSp -> text "MachSp" - UnwindReturnReg-> text "UnwindReturnReg" - CCCS -> text "CCCS" - CurrentTSO -> text "CurrentTSO" - CurrentNursery -> text "CurrentNursery" - HpAlloc -> text "HpAlloc" - EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info" - GCEnter1 -> text "stg_gc_enter_1" - GCFun -> text "stg_gc_fun" - BaseReg -> text "BaseReg" - PicBaseReg -> text "PicBaseReg" - ------------------------------------------------------------------------------ - -commafy :: [SDoc] -> SDoc -commafy xs = fsep $ punctuate comma xs diff --git a/compiler/GHC/Cmm/ProcPoint.hs b/compiler/GHC/Cmm/ProcPoint.hs index 9297a25378..ccf542aff0 100644 --- a/compiler/GHC/Cmm/ProcPoint.hs +++ b/compiler/GHC/Cmm/ProcPoint.hs @@ -17,7 +17,6 @@ import GHC.Prelude hiding (last, unzip, succ, zip) import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm -import GHC.Cmm.Ppr () -- For Outputable instances import GHC.Cmm.Utils import GHC.Cmm.Info import GHC.Cmm.Liveness diff --git a/compiler/GHC/Cmm/Reg.hs b/compiler/GHC/Cmm/Reg.hs new file mode 100644 index 0000000000..a37e5ce6f8 --- /dev/null +++ b/compiler/GHC/Cmm/Reg.hs @@ -0,0 +1,372 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module GHC.Cmm.Reg + ( -- * Cmm Registers + CmmReg(..) + , cmmRegType + , cmmRegWidth + -- * Local registers + , LocalReg(..) + , localRegType + -- * Global registers + , GlobalReg(..), isArgReg, globalRegType + , spReg, hpReg, spLimReg, hpLimReg, nodeReg + , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg + , node, baseReg + , VGcPtr(..) + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Cmm.Type + +----------------------------------------------------------------------------- +-- Cmm registers +----------------------------------------------------------------------------- + +data CmmReg + = CmmLocal {-# UNPACK #-} !LocalReg + | CmmGlobal GlobalReg + deriving( Eq, Ord, Show ) + +instance Outputable CmmReg where + ppr e = pprReg e + +pprReg :: CmmReg -> SDoc +pprReg r + = case r of + CmmLocal local -> pprLocalReg local + CmmGlobal global -> pprGlobalReg global + +cmmRegType :: Platform -> CmmReg -> CmmType +cmmRegType _ (CmmLocal reg) = localRegType reg +cmmRegType platform (CmmGlobal reg) = globalRegType platform reg + +cmmRegWidth :: Platform -> CmmReg -> Width +cmmRegWidth platform = typeWidth . cmmRegType platform + + +----------------------------------------------------------------------------- +-- Local registers +----------------------------------------------------------------------------- + +data LocalReg + = LocalReg {-# UNPACK #-} !Unique !CmmType + -- ^ Parameters: + -- 1. Identifier + -- 2. Type + deriving Show + +instance Eq LocalReg where + (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2 + +instance Outputable LocalReg where + ppr e = pprLocalReg e + +-- This is non-deterministic but we do not currently support deterministic +-- code-generation. See Note [Unique Determinism and code generation] +-- See Note [No Ord for Unique] +instance Ord LocalReg where + compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2 + +instance Uniquable LocalReg where + getUnique (LocalReg uniq _) = uniq + +localRegType :: LocalReg -> CmmType +localRegType (LocalReg _ rep) = rep + +-- +-- We only print the type of the local reg if it isn't wordRep +-- +pprLocalReg :: LocalReg -> SDoc +pprLocalReg (LocalReg uniq rep) = +-- = ppr rep <> char '_' <> ppr uniq +-- Temp Jan08 + char '_' <> pprUnique uniq <> + (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh + then dcolon <> ptr <> ppr rep + else dcolon <> ptr <> ppr rep) + where + pprUnique unique = sdocOption sdocSuppressUniques $ \case + True -> text "_locVar_" + False -> ppr unique + ptr = empty + --if isGcPtrType rep + -- then doubleQuotes (text "ptr") + -- else empty + +----------------------------------------------------------------------------- +-- Global STG registers +----------------------------------------------------------------------------- +{- +Note [Overlapping global registers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The backend might not faithfully implement the abstraction of the STG +machine with independent registers for different values of type +GlobalReg. Specifically, certain pairs of registers (r1, r2) may +overlap in the sense that a store to r1 invalidates the value in r2, +and vice versa. + +Currently this occurs only on the x86_64 architecture where FloatReg n +and DoubleReg n are assigned the same microarchitectural register, in +order to allow functions to receive more Float# or Double# arguments +in registers (as opposed to on the stack). + +There are no specific rules about which registers might overlap with +which other registers, but presumably it's safe to assume that nothing +will overlap with special registers like Sp or BaseReg. + +Use GHC.Cmm.Utils.regsOverlap to determine whether two GlobalRegs overlap +on a particular platform. The instance Eq GlobalReg is syntactic +equality of STG registers and does not take overlap into +account. However it is still used in UserOfRegs/DefinerOfRegs and +there are likely still bugs there, beware! +-} + +data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show ) + +data GlobalReg + -- Argument and return registers + = VanillaReg -- pointers, unboxed ints and chars + {-# UNPACK #-} !Int -- its number + VGcPtr + + | FloatReg -- single-precision floating-point registers + {-# UNPACK #-} !Int -- its number + + | DoubleReg -- double-precision floating-point registers + {-# UNPACK #-} !Int -- its number + + | LongReg -- long int registers (64-bit, really) + {-# UNPACK #-} !Int -- its number + + | XmmReg -- 128-bit SIMD vector register + {-# UNPACK #-} !Int -- its number + + | YmmReg -- 256-bit SIMD vector register + {-# UNPACK #-} !Int -- its number + + | ZmmReg -- 512-bit SIMD vector register + {-# UNPACK #-} !Int -- its number + + -- STG registers + | Sp -- Stack ptr; points to last occupied stack location. + | SpLim -- Stack limit + | Hp -- Heap ptr; points to last occupied heap location. + | HpLim -- Heap limit register + | CCCS -- Current cost-centre stack + | CurrentTSO -- pointer to current thread's TSO + | CurrentNursery -- pointer to allocation area + | HpAlloc -- allocation count for heap check failure + + -- We keep the address of some commonly-called + -- functions in the register table, to keep code + -- size down: + | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info + | GCEnter1 -- stg_gc_enter_1 + | GCFun -- stg_gc_fun + + -- Base offset for the register table, used for accessing registers + -- which do not have real registers assigned to them. This register + -- will only appear after we have expanded GlobalReg into memory accesses + -- (where necessary) in the native code generator. + | BaseReg + + -- The register used by the platform for the C stack pointer. This is + -- a break in the STG abstraction used exclusively to setup stack unwinding + -- information. + | MachSp + + -- The is a dummy register used to indicate to the stack unwinder where + -- a routine would return to. + | UnwindReturnReg + + -- Base Register for PIC (position-independent code) calculations + -- Only used inside the native code generator. It's exact meaning differs + -- from platform to platform (see module PositionIndependentCode). + | PicBaseReg + + deriving( Show ) + +instance Eq GlobalReg where + VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes + FloatReg i == FloatReg j = i==j + DoubleReg i == DoubleReg j = i==j + LongReg i == LongReg j = i==j + -- NOTE: XMM, YMM, ZMM registers actually are the same registers + -- at least with respect to store at YMM i and then read from XMM i + -- and similarly for ZMM etc. + XmmReg i == XmmReg j = i==j + YmmReg i == YmmReg j = i==j + ZmmReg i == ZmmReg j = i==j + Sp == Sp = True + SpLim == SpLim = True + Hp == Hp = True + HpLim == HpLim = True + CCCS == CCCS = True + CurrentTSO == CurrentTSO = True + CurrentNursery == CurrentNursery = True + HpAlloc == HpAlloc = True + EagerBlackholeInfo == EagerBlackholeInfo = True + GCEnter1 == GCEnter1 = True + GCFun == GCFun = True + BaseReg == BaseReg = True + MachSp == MachSp = True + UnwindReturnReg == UnwindReturnReg = True + PicBaseReg == PicBaseReg = True + _r1 == _r2 = False + +-- NOTE: this Ord instance affects the tuple layout in GHCi, see +-- Note [GHCi tuple layout] +instance Ord GlobalReg where + compare (VanillaReg i _) (VanillaReg j _) = compare i j + -- Ignore type when seeking clashes + compare (FloatReg i) (FloatReg j) = compare i j + compare (DoubleReg i) (DoubleReg j) = compare i j + compare (LongReg i) (LongReg j) = compare i j + compare (XmmReg i) (XmmReg j) = compare i j + compare (YmmReg i) (YmmReg j) = compare i j + compare (ZmmReg i) (ZmmReg j) = compare i j + compare Sp Sp = EQ + compare SpLim SpLim = EQ + compare Hp Hp = EQ + compare HpLim HpLim = EQ + compare CCCS CCCS = EQ + compare CurrentTSO CurrentTSO = EQ + compare CurrentNursery CurrentNursery = EQ + compare HpAlloc HpAlloc = EQ + compare EagerBlackholeInfo EagerBlackholeInfo = EQ + compare GCEnter1 GCEnter1 = EQ + compare GCFun GCFun = EQ + compare BaseReg BaseReg = EQ + compare MachSp MachSp = EQ + compare UnwindReturnReg UnwindReturnReg = EQ + compare PicBaseReg PicBaseReg = EQ + compare (VanillaReg _ _) _ = LT + compare _ (VanillaReg _ _) = GT + compare (FloatReg _) _ = LT + compare _ (FloatReg _) = GT + compare (DoubleReg _) _ = LT + compare _ (DoubleReg _) = GT + compare (LongReg _) _ = LT + compare _ (LongReg _) = GT + compare (XmmReg _) _ = LT + compare _ (XmmReg _) = GT + compare (YmmReg _) _ = LT + compare _ (YmmReg _) = GT + compare (ZmmReg _) _ = LT + compare _ (ZmmReg _) = GT + compare Sp _ = LT + compare _ Sp = GT + compare SpLim _ = LT + compare _ SpLim = GT + compare Hp _ = LT + compare _ Hp = GT + compare HpLim _ = LT + compare _ HpLim = GT + compare CCCS _ = LT + compare _ CCCS = GT + compare CurrentTSO _ = LT + compare _ CurrentTSO = GT + compare CurrentNursery _ = LT + compare _ CurrentNursery = GT + compare HpAlloc _ = LT + compare _ HpAlloc = GT + compare GCEnter1 _ = LT + compare _ GCEnter1 = GT + compare GCFun _ = LT + compare _ GCFun = GT + compare BaseReg _ = LT + compare _ BaseReg = GT + compare MachSp _ = LT + compare _ MachSp = GT + compare UnwindReturnReg _ = LT + compare _ UnwindReturnReg = GT + compare EagerBlackholeInfo _ = LT + compare _ EagerBlackholeInfo = GT + +instance Outputable GlobalReg where + ppr e = pprGlobalReg e + +instance OutputableP env GlobalReg where + pdoc _ = ppr + +pprGlobalReg :: GlobalReg -> SDoc +pprGlobalReg gr + = case gr of + VanillaReg n _ -> char 'R' <> int n +-- Temp Jan08 +-- VanillaReg n VNonGcPtr -> char 'R' <> int n +-- VanillaReg n VGcPtr -> char 'P' <> int n + FloatReg n -> char 'F' <> int n + DoubleReg n -> char 'D' <> int n + LongReg n -> char 'L' <> int n + XmmReg n -> text "XMM" <> int n + YmmReg n -> text "YMM" <> int n + ZmmReg n -> text "ZMM" <> int n + Sp -> text "Sp" + SpLim -> text "SpLim" + Hp -> text "Hp" + HpLim -> text "HpLim" + MachSp -> text "MachSp" + UnwindReturnReg-> text "UnwindReturnReg" + CCCS -> text "CCCS" + CurrentTSO -> text "CurrentTSO" + CurrentNursery -> text "CurrentNursery" + HpAlloc -> text "HpAlloc" + EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info" + GCEnter1 -> text "stg_gc_enter_1" + GCFun -> text "stg_gc_fun" + BaseReg -> text "BaseReg" + PicBaseReg -> text "PicBaseReg" + + +-- convenient aliases +baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg, + currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: CmmReg +baseReg = CmmGlobal BaseReg +spReg = CmmGlobal Sp +hpReg = CmmGlobal Hp +hpLimReg = CmmGlobal HpLim +spLimReg = CmmGlobal SpLim +nodeReg = CmmGlobal node +currentTSOReg = CmmGlobal CurrentTSO +currentNurseryReg = CmmGlobal CurrentNursery +hpAllocReg = CmmGlobal HpAlloc +cccsReg = CmmGlobal CCCS + +node :: GlobalReg +node = VanillaReg 1 VGcPtr + +globalRegType :: Platform -> GlobalReg -> CmmType +globalRegType platform = \case + (VanillaReg _ VGcPtr) -> gcWord platform + (VanillaReg _ VNonGcPtr) -> bWord platform + (FloatReg _) -> cmmFloat W32 + (DoubleReg _) -> cmmFloat W64 + (LongReg _) -> cmmBits W64 + -- TODO: improve the internal model of SIMD/vectorized registers + -- the right design SHOULd improve handling of float and double code too. + -- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim + (XmmReg _) -> cmmVec 4 (cmmBits W32) + (YmmReg _) -> cmmVec 8 (cmmBits W32) + (ZmmReg _) -> cmmVec 16 (cmmBits W32) + + Hp -> gcWord platform -- The initialiser for all + -- dynamically allocated closures + _ -> bWord platform + +isArgReg :: GlobalReg -> Bool +isArgReg (VanillaReg {}) = True +isArgReg (FloatReg {}) = True +isArgReg (DoubleReg {}) = True +isArgReg (LongReg {}) = True +isArgReg (XmmReg {}) = True +isArgReg (YmmReg {}) = True +isArgReg (ZmmReg {}) = True +isArgReg _ = False diff --git a/compiler/GHC/Cmm/Type.hs b/compiler/GHC/Cmm/Type.hs index ee059caa12..ec000a3c47 100644 --- a/compiler/GHC/Cmm/Type.hs +++ b/compiler/GHC/Cmm/Type.hs @@ -364,6 +364,14 @@ data ForeignHint -- Used to give extra per-argument or per-result -- information needed by foreign calling conventions +instance Outputable ForeignHint where + ppr NoHint = empty + ppr SignedHint = quotes(text "signed") +-- ppr AddrHint = quotes(text "address") +-- Temp Jan08 + ppr AddrHint = (text "PtrHint") + + ------------------------------------------------------------------------- -- These don't really belong here, but I don't know where is best to diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs index 2060be5bda..fda3ee23f6 100644 --- a/compiler/GHC/Cmm/Utils.hs +++ b/compiler/GHC/Cmm/Utils.hs @@ -42,8 +42,6 @@ module GHC.Cmm.Utils( cmmMkAssign, - isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr, - baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr, currentTSOExpr, currentNurseryExpr, cccsExpr, @@ -61,9 +59,9 @@ module GHC.Cmm.Utils( modifyGraph, ofBlockMap, toBlockMap, - ofBlockList, toBlockList, bodyToBlockList, + ofBlockList, toBlockList, toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough, - foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1, + foldlGraphBlocks, mapGraphNodes, mapGraphNodes1, -- * Ticks blockTicks @@ -400,36 +398,6 @@ cmmMkAssign platform expr uq = --------------------------------------------------- -- --- CmmExpr predicates --- ---------------------------------------------------- - -isTrivialCmmExpr :: CmmExpr -> Bool -isTrivialCmmExpr (CmmLoad _ _ _) = False -isTrivialCmmExpr (CmmMachOp _ _) = False -isTrivialCmmExpr (CmmLit _) = True -isTrivialCmmExpr (CmmReg _) = True -isTrivialCmmExpr (CmmRegOff _ _) = True -isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot" - -hasNoGlobalRegs :: CmmExpr -> Bool -hasNoGlobalRegs (CmmLoad e _ _) = hasNoGlobalRegs e -hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es -hasNoGlobalRegs (CmmLit _) = True -hasNoGlobalRegs (CmmReg (CmmLocal _)) = True -hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True -hasNoGlobalRegs _ = False - -isLit :: CmmExpr -> Bool -isLit (CmmLit _) = True -isLit _ = False - -isComparisonExpr :: CmmExpr -> Bool -isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op -isComparisonExpr _ = False - ---------------------------------------------------- --- -- Tagging -- --------------------------------------------------- @@ -525,9 +493,6 @@ mkLiveness platform (reg:regs) modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n' modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)} -toBlockMap :: CmmGraph -> LabelMap CmmBlock -toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body - ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO} @@ -578,9 +543,6 @@ ofBlockList entry blocks = CmmGraph { g_entry = entry , g_graph = GMany NothingO body NothingO } where body = foldr addBlock emptyBody blocks -bodyToBlockList :: Body CmmNode -> [CmmBlock] -bodyToBlockList body = mapElems body - mapGraphNodes :: ( CmmNode C O -> CmmNode C O , CmmNode O O -> CmmNode O O , CmmNode O C -> CmmNode O C) @@ -596,10 +558,6 @@ mapGraphNodes1 f = modifyGraph (mapGraph f) foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g -revPostorder :: CmmGraph -> [CmmBlock] -revPostorder g = {-# SCC "revPostorder" #-} - revPostorderFrom (toBlockMap g) (g_entry g) - ------------------------------------------------- -- Tick utilities diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs index 29ec7559f6..21b68a8f01 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -116,7 +116,6 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Block import GHC.Cmm.Opt ( cmmMachOpFold ) -import GHC.Cmm.Ppr import GHC.Cmm.CLabel import GHC.Types.Unique.FM diff --git a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs index b1761a1db2..5190633448 100644 --- a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs @@ -22,7 +22,6 @@ import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) import GHC.Cmm.BlockId import GHC.Cmm.CLabel -import GHC.Cmm.Ppr.Expr () -- For Outputable instances import GHC.Types.Unique ( pprUniqueAlways, getUnique ) import GHC.Platform diff --git a/compiler/GHC/CmmToAsm/CFG.hs b/compiler/GHC/CmmToAsm/CFG.hs index e992116117..2d8caefcc5 100644 --- a/compiler/GHC/CmmToAsm/CFG.hs +++ b/compiler/GHC/CmmToAsm/CFG.hs @@ -78,7 +78,6 @@ import GHC.Utils.Panic.Plain --import GHC.Cmm.DebugBlock --import GHC.Data.OrdList --import GHC.Cmm.DebugBlock.Trace -import GHC.Cmm.Ppr () -- For Outputable instances import Data.List (sort, nub, partition) import Data.STRef.Strict diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs index 844e4744da..099d10920e 100644 --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -48,7 +48,6 @@ import GHC.Platform -- Our intermediate code: import GHC.Cmm.BlockId -import GHC.Cmm.Ppr ( pprExpr ) import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Switch @@ -395,7 +394,7 @@ iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do iselExpr64 expr = do platform <- getPlatform - pprPanic "iselExpr64(powerpc)" (pprExpr platform expr) + pprPanic "iselExpr64(powerpc)" (pdoc platform expr) @@ -689,7 +688,7 @@ getRegister' config platform (CmmLit lit) `consOL` (addr_code `snocOL` LD format dst addr) return (Any format code) -getRegister' _ platform other = pprPanic "getRegister(ppc)" (pprExpr platform other) +getRegister' _ platform other = pprPanic "getRegister(ppc)" (pdoc platform other) -- extend?Rep: wrap integer expression of type `from` -- in a conversion to `to` diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs index a842eef998..c0b2385b3c 100644 --- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs @@ -34,7 +34,6 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm.BlockId import GHC.Cmm.CLabel -import GHC.Cmm.Ppr.Expr () -- For Outputable instances import GHC.Types.Unique ( pprUniqueAlways, getUnique ) import GHC.Platform diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs index c9f86e9afe..1659575459 100644 --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -33,8 +33,7 @@ import GHC.CmmToAsm.CPrim import GHC.Cmm.BlockId import GHC.Cmm.CLabel -import GHC.Cmm hiding (pprBBlock) -import GHC.Cmm.Ppr () -- For Outputable instances +import GHC.Cmm hiding (pprBBlock, pprStatic) import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs index 1833ddb74f..80a68e76e7 100644 --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -25,7 +25,6 @@ import GHC.CmmToLlvm.Mangler import GHC.StgToCmm.CgUtils ( fixStgRegisters ) import GHC.Cmm import GHC.Cmm.Dataflow.Collections -import GHC.Cmm.Ppr import GHC.Utils.BufHandle import GHC.Driver.Session diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs index f72411c4ec..33592092de 100644 --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -42,7 +42,6 @@ import GHC.CmmToLlvm.Regs import GHC.CmmToLlvm.Config import GHC.Cmm.CLabel -import GHC.Cmm.Ppr.Expr () import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe ) import GHC.Driver.Session import GHC.Data.FastString diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs index f44fe1af6e..55c6e18883 100644 --- a/compiler/GHC/CmmToLlvm/CodeGen.hs +++ b/compiler/GHC/CmmToLlvm/CodeGen.hs @@ -19,7 +19,6 @@ import GHC.CmmToLlvm.Regs import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm -import GHC.Cmm.Ppr as PprCmm import GHC.Cmm.Utils import GHC.Cmm.Switch import GHC.Cmm.Dataflow.Block @@ -1204,7 +1203,7 @@ genStore_slow addr val alignment meta = do other -> pprPanic "genStore: ptr not right type!" - (PprCmm.pprExpr platform addr <+> text ( + (pdoc platform addr <+> text ( "Size of Ptr: " ++ show (llvmPtrBits platform) ++ ", Size of var: " ++ show (llvmWidthInBits platform other) ++ ", Var: " ++ renderWithContext (llvmCgContext cfg) (ppVar cfg vaddr))) @@ -1725,7 +1724,7 @@ genMachOp_slow opt op [x, y] = case op of -> do -- Error. Continue anyway so we can debug the generated ll file. let render = renderWithContext (llvmCgContext cfg) - cmmToStr = (lines . render . PprCmm.pprExpr platform) + cmmToStr = (lines . render . pdoc platform) statement $ Comment $ map fsLit $ cmmToStr x statement $ Comment $ map fsLit $ cmmToStr y doExprW (ty vx) $ binOp vx vy @@ -1882,7 +1881,7 @@ genLoad_slow atomic e ty align meta = do doExprW (cmmToLlvmType ty) (MExpr meta $ mkLoad atomic ptr align) other -> pprPanic "exprToVar: CmmLoad expression is not right type!" - (PprCmm.pprExpr platform e <+> text ( + (pdoc platform e <+> text ( "Size of Ptr: " ++ show (llvmPtrBits platform) ++ ", Size of var: " ++ show (llvmWidthInBits platform other) ++ ", Var: " ++ renderWithContext (llvmCgContext cfg) (ppVar cfg iptr))) diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index 7c1b5250e4..d935bb4b99 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -76,7 +76,6 @@ import GHC.Stg.Syntax import GHC.Runtime.Heap.Layout import GHC.Cmm import GHC.Cmm.Utils -import GHC.Cmm.Ppr.Expr() -- For Outputable instances import GHC.StgToCmm.Types import GHC.StgToCmm.Sequel diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index 7992e34417..9494a3c57d 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -38,7 +38,6 @@ import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG ) -import GHC.Cmm.Ppr import GHC.Core import GHC.Core.DataCon import GHC.Types.ForeignCall @@ -1021,7 +1020,7 @@ cgIdApp fun_id args = do assertTag = whenCheckTags $ do mod <- getModuleName emitTagAssertion (showPprUnsafe - (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pprExpr platform fun)) + (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pdoc platform fun)) fun EnterIt -> assert (null args) $ -- Discarding arguments diff --git a/compiler/GHC/StgToCmm/Sequel.hs b/compiler/GHC/StgToCmm/Sequel.hs index ac55c3620f..e799e79678 100644 --- a/compiler/GHC/StgToCmm/Sequel.hs +++ b/compiler/GHC/StgToCmm/Sequel.hs @@ -17,7 +17,6 @@ module GHC.StgToCmm.Sequel import GHC.Cmm.BlockId import GHC.Cmm -import GHC.Cmm.Ppr() import GHC.Types.Id import GHC.Utils.Outputable diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 452b34cce6..dc6de716f7 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -208,10 +208,8 @@ Library GHC.Cmm.Parser.Config GHC.Cmm.Parser.Monad GHC.Cmm.Pipeline - GHC.Cmm.Ppr - GHC.Cmm.Ppr.Decl - GHC.Cmm.Ppr.Expr GHC.Cmm.ProcPoint + GHC.Cmm.Reg GHC.Cmm.Sink GHC.Cmm.Switch GHC.Cmm.Switch.Implement |