From f1c449910256c61cb35e361a367d5209bc51cc7a Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 29 Jun 2022 18:20:51 -0400 Subject: cmm: Eliminate orphan Outputable instances Here we reorganize `GHC.Cmm` to eliminate the orphan `Outputable` and `OutputableP` instances for the Cmm AST. This makes it significantly easier to use the Cmm pretty-printers in tracing output without incurring module import cycles. --- compiler/GHC/Cmm/CLabel.hs | 3 + compiler/GHC/Cmm/CallConv.hs | 1 - compiler/GHC/Cmm/Dataflow/Graph.hs | 4 + compiler/GHC/Cmm/DebugBlock.hs | 3 +- compiler/GHC/Cmm/Expr.hs | 473 ++++++++++++++++--------------------- compiler/GHC/Cmm/Lint.hs | 1 - compiler/GHC/Cmm/Liveness.hs | 1 - compiler/GHC/Cmm/Node.hs | 219 +++++++++++++++++ compiler/GHC/Cmm/Ppr.hs | 319 ------------------------- compiler/GHC/Cmm/Ppr/Decl.hs | 172 -------------- compiler/GHC/Cmm/Ppr/Expr.hs | 299 ----------------------- compiler/GHC/Cmm/ProcPoint.hs | 1 - compiler/GHC/Cmm/Reg.hs | 372 +++++++++++++++++++++++++++++ compiler/GHC/Cmm/Type.hs | 8 + compiler/GHC/Cmm/Utils.hs | 46 +--- 15 files changed, 812 insertions(+), 1110 deletions(-) delete mode 100644 compiler/GHC/Cmm/Ppr.hs delete mode 100644 compiler/GHC/Cmm/Ppr/Decl.hs delete mode 100644 compiler/GHC/Cmm/Ppr/Expr.hs create mode 100644 compiler/GHC/Cmm/Reg.hs (limited to 'compiler/GHC/Cmm') 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 "" + +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 "" +pprConvention (NativeDirectCall {}) = text "" +pprConvention (NativeReturn {}) = text "" +pprConvention Slow = text "" +pprConvention GC = text "" + + 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 "" -pprConvention (NativeDirectCall {}) = text "" -pprConvention (NativeReturn {}) = text "" -pprConvention Slow = text "" -pprConvention GC = text "" - -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 "" - -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 @@ -398,36 +396,6 @@ cmmMkAssign platform expr uq = in (CmmAssign reg expr, CmmReg reg) ---------------------------------------------------- --- --- 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 -- cgit v1.2.1