[Git][ghc/ghc][master] Add outputable instances for the types in GHC.Iface.Ext.Types, add -ddump-hie
Marge Bot
gitlab at gitlab.haskell.org
Fri Apr 3 10:25:06 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
ef7576c4 by Zubin Duggal at 2020-04-03T06:24:56-04:00
Add outputable instances for the types in GHC.Iface.Ext.Types, add -ddump-hie
flag to dump pretty printed contents of the .hie file
Metric Increase:
hie002
Because of the regression on i386:
compile_time/bytes allocated increased from i386-linux-deb9 baseline @ HEAD~10:
Expected hie002 (normal) compile_time/bytes allocated: 583014888.0 +/-10%
Lower bound hie002 (normal) compile_time/bytes allocated: 524713399
Upper bound hie002 (normal) compile_time/bytes allocated: 641316377
Actual hie002 (normal) compile_time/bytes allocated: 877986292
Deviation hie002 (normal) compile_time/bytes allocated: 50.6 %
*** unexpected stat test failure for hie002(normal)
- - - - -
6 changed files:
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Ext/Debug.hs
- compiler/GHC/Iface/Ext/Types.hs
- docs/users_guide/debugging.rst
Changes:
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -79,6 +79,7 @@ data DumpFlag
| Opt_D_dump_cpr_signatures
| Opt_D_dump_tc
| Opt_D_dump_tc_ast
+ | Opt_D_dump_hie
| Opt_D_dump_types
| Opt_D_dump_rules
| Opt_D_dump_cse
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -425,14 +425,14 @@ extract_renamed_stuff mod_summary tc_result = do
hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
let out_file = ml_hie_file $ ms_location mod_summary
liftIO $ writeHieFile out_file hieFile
+ liftIO $ dumpIfSet_dyn dflags Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)
-- Validate HIE files
when (gopt Opt_ValidateHie dflags) $ do
hs_env <- Hsc $ \e w -> return (e, w)
liftIO $ do
-- Validate Scopes
- let mdl = hie_module hieFile
- case validateScopes mdl $ getAsts $ hie_asts hieFile of
+ case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of
[] -> putMsg dflags $ text "Got valid scopes"
xs -> do
putMsg dflags $ text "Got invalid scopes"
@@ -445,7 +445,7 @@ extract_renamed_stuff mod_summary tc_result = do
putMsg dflags $ text "Got no roundtrip errors"
xs -> do
putMsg dflags $ text "Got roundtrip errors"
- mapM_ (putMsg dflags) xs
+ mapM_ (putMsg (dopt_set dflags Opt_D_ppr_debug)) xs
return rn_info
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2741,6 +2741,8 @@ dynamic_flags_deps = [
(setDumpFlag Opt_D_dump_tc)
, make_ord_flag defGhcFlag "ddump-tc-ast"
(setDumpFlag Opt_D_dump_tc_ast)
+ , make_ord_flag defGhcFlag "ddump-hie"
+ (setDumpFlag Opt_D_dump_hie)
, make_ord_flag defGhcFlag "ddump-types"
(setDumpFlag Opt_D_dump_types)
, make_ord_flag defGhcFlag "ddump-rules"
=====================================
compiler/GHC/Iface/Ext/Debug.hs
=====================================
@@ -23,35 +23,6 @@ import qualified Data.Map as M
import qualified Data.Set as S
import Data.Function ( on )
import Data.List ( sortOn )
-import Data.Foldable ( toList )
-
-ppHies :: Outputable a => (HieASTs a) -> SDoc
-ppHies (HieASTs asts) = M.foldrWithKey go "" asts
- where
- go k a rest = vcat $
- [ "File: " <> ppr k
- , ppHie a
- , rest
- ]
-
-ppHie :: Outputable a => HieAST a -> SDoc
-ppHie = go 0
- where
- go n (Node inf sp children) = hang header n rest
- where
- rest = vcat $ map (go (n+2)) children
- header = hsep
- [ "Node"
- , ppr sp
- , ppInfo inf
- ]
-
-ppInfo :: Outputable a => NodeInfo a -> SDoc
-ppInfo ni = hsep
- [ ppr $ toList $ nodeAnnotations ni
- , ppr $ nodeType ni
- , ppr $ M.toList $ nodeIdentifiers ni
- ]
type Diff a = a -> a -> [SDoc]
=====================================
compiler/GHC/Iface/Ext/Types.hs
=====================================
@@ -5,9 +5,11 @@ For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files
-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
module GHC.Iface.Ext.Types where
import GhcPrelude
@@ -21,6 +23,7 @@ import GHC.Types.Name ( Name )
import Outputable hiding ( (<>) )
import GHC.Types.SrcLoc ( RealSrcSpan )
import GHC.Types.Avail
+import qualified Outputable as O ( (<>) )
import qualified Data.Array as A
import qualified Data.Map as M
@@ -210,6 +213,15 @@ instance Binary (HieASTs TypeIndex) where
put_ bh asts = put_ bh $ M.toAscList $ getAsts asts
get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh)
+instance Outputable a => Outputable (HieASTs a) where
+ ppr (HieASTs asts) = M.foldrWithKey go "" asts
+ where
+ go k a rest = vcat $
+ [ "File: " O.<> ppr k
+ , ppr a
+ , rest
+ ]
+
data HieAST a =
Node
@@ -229,6 +241,11 @@ instance Binary (HieAST TypeIndex) where
<*> get bh
<*> get bh
+instance Outputable a => Outputable (HieAST a) where
+ ppr (Node ni sp ch) = hang header 2 rest
+ where
+ header = text "Node@" O.<> ppr sp O.<> ":" <+> ppr ni
+ rest = vcat (map ppr ch)
-- | The information stored in one AST node.
--
@@ -255,6 +272,22 @@ instance Binary (NodeInfo TypeIndex) where
<*> get bh
<*> fmap (M.fromList) (get bh)
+instance Outputable a => Outputable (NodeInfo a) where
+ ppr (NodeInfo anns typs idents) = braces $ fsep $ punctuate ", "
+ [ parens (text "annotations:" <+> ppr anns)
+ , parens (text "types:" <+> ppr typs)
+ , parens (text "identifier info:" <+> pprNodeIdents idents)
+ ]
+
+pprNodeIdents :: Outputable a => NodeIdentifiers a -> SDoc
+pprNodeIdents ni = braces $ fsep $ punctuate ", " $ map go $ M.toList ni
+ where
+ go (i,id) = parens $ hsep $ punctuate ", " [pprIdentifier i, ppr id]
+
+pprIdentifier :: Identifier -> SDoc
+pprIdentifier (Left mod) = text "module" <+> ppr mod
+pprIdentifier (Right name) = text "name" <+> ppr name
+
type Identifier = Either ModuleName Name
type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a)
@@ -269,7 +302,7 @@ data IdentifierDetails a = IdentifierDetails
} deriving (Eq, Functor, Foldable, Traversable)
instance Outputable a => Outputable (IdentifierDetails a) where
- ppr x = text "IdentifierDetails" <+> ppr (identType x) <+> ppr (identInfo x)
+ ppr x = text "Details: " <+> ppr (identType x) <+> ppr (identInfo x)
instance Semigroup (IdentifierDetails a) where
d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2)
@@ -284,7 +317,7 @@ instance Binary (IdentifierDetails TypeIndex) where
put_ bh $ S.toAscList $ identInfo dets
get bh = IdentifierDetails
<$> get bh
- <*> fmap (S.fromDistinctAscList) (get bh)
+ <*> fmap S.fromDistinctAscList (get bh)
-- | Different contexts under which identifiers exist
@@ -330,10 +363,32 @@ data ContextInfo
-- | Record field
| RecField RecFieldContext (Maybe Span)
- deriving (Eq, Ord, Show)
+ deriving (Eq, Ord)
instance Outputable ContextInfo where
- ppr = text . show
+ ppr (Use) = text "usage"
+ ppr (MatchBind) = text "LHS of a match group"
+ ppr (IEThing x) = ppr x
+ ppr (TyDecl) = text "bound in a type signature declaration"
+ ppr (ValBind t sc sp) =
+ ppr t <+> text "value bound with scope:" <+> ppr sc <+> pprBindSpan sp
+ ppr (PatternBind sc1 sc2 sp) =
+ text "bound in a pattern with scope:"
+ <+> ppr sc1 <+> "," <+> ppr sc2
+ <+> pprBindSpan sp
+ ppr (ClassTyDecl sp) =
+ text "bound in a class type declaration" <+> pprBindSpan sp
+ ppr (Decl d sp) =
+ text "declaration of" <+> ppr d <+> pprBindSpan sp
+ ppr (TyVarBind sc1 sc2) =
+ text "type variable binding with scope:"
+ <+> ppr sc1 <+> "," <+> ppr sc2
+ ppr (RecField ctx sp) =
+ text "record field" <+> ppr ctx <+> pprBindSpan sp
+
+pprBindSpan :: Maybe Span -> SDoc
+pprBindSpan Nothing = text ""
+pprBindSpan (Just sp) = text "at:" <+> ppr sp
instance Binary ContextInfo where
put_ bh Use = putByte bh 0
@@ -383,14 +438,19 @@ instance Binary ContextInfo where
9 -> return MatchBind
_ -> panic "Binary ContextInfo: invalid tag"
-
-- | Types of imports and exports
data IEType
= Import
| ImportAs
| ImportHiding
| Export
- deriving (Eq, Enum, Ord, Show)
+ deriving (Eq, Enum, Ord)
+
+instance Outputable IEType where
+ ppr Import = text "import"
+ ppr ImportAs = text "import as"
+ ppr ImportHiding = text "import hiding"
+ ppr Export = text "export"
instance Binary IEType where
put_ bh b = putByte bh (fromIntegral (fromEnum b))
@@ -402,7 +462,13 @@ data RecFieldContext
| RecFieldAssign
| RecFieldMatch
| RecFieldOcc
- deriving (Eq, Enum, Ord, Show)
+ deriving (Eq, Enum, Ord)
+
+instance Outputable RecFieldContext where
+ ppr RecFieldDecl = text "declaration"
+ ppr RecFieldAssign = text "assignment"
+ ppr RecFieldMatch = text "pattern match"
+ ppr RecFieldOcc = text "occurence"
instance Binary RecFieldContext where
put_ bh b = putByte bh (fromIntegral (fromEnum b))
@@ -412,13 +478,16 @@ instance Binary RecFieldContext where
data BindType
= RegularBind
| InstanceBind
- deriving (Eq, Ord, Show, Enum)
+ deriving (Eq, Ord, Enum)
+
+instance Outputable BindType where
+ ppr RegularBind = "regular"
+ ppr InstanceBind = "instance"
instance Binary BindType where
put_ bh b = putByte bh (fromIntegral (fromEnum b))
get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
-
data DeclType
= FamDec -- ^ type or data family
| SynDec -- ^ type synonym
@@ -427,18 +496,26 @@ data DeclType
| PatSynDec -- ^ pattern synonym
| ClassDec -- ^ class declaration
| InstDec -- ^ instance declaration
- deriving (Eq, Ord, Show, Enum)
+ deriving (Eq, Ord, Enum)
+
+instance Outputable DeclType where
+ ppr FamDec = text "type or data family"
+ ppr SynDec = text "type synonym"
+ ppr DataDec = text "data"
+ ppr ConDec = text "constructor"
+ ppr PatSynDec = text "pattern synonym"
+ ppr ClassDec = text "class"
+ ppr InstDec = text "instance"
instance Binary DeclType where
put_ bh b = putByte bh (fromIntegral (fromEnum b))
get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
-
data Scope
= NoScope
| LocalScope Span
| ModuleScope
- deriving (Eq, Ord, Show, Typeable, Data)
+ deriving (Eq, Ord, Typeable, Data)
instance Outputable Scope where
ppr NoScope = text "NoScope"
@@ -488,9 +565,12 @@ data TyVarScope
-- method type signature
deriving (Eq, Ord)
-instance Show TyVarScope where
- show (ResolvedScopes sc) = show sc
- show _ = error "UnresolvedScope"
+instance Outputable TyVarScope where
+ ppr (ResolvedScopes xs) =
+ text "type variable scopes:" <+> hsep (punctuate ", " $ map ppr xs)
+ ppr (UnresolvedScope ns sp) =
+ text "unresolved type variable scope for name" O.<> plural ns
+ <+> pprBindSpan sp
instance Binary TyVarScope where
put_ bh (ResolvedScopes xs) = do
=====================================
docs/users_guide/debugging.rst
=====================================
@@ -177,6 +177,12 @@ These flags dump various information from GHC's typechecker and renamer.
Dump typechecker output as a syntax tree
+.. ghc-flag:: -ddump-hie
+ :shortdesc: Dump the hie file syntax tree
+ :type: dynamic
+
+ Dump the hie file syntax tree if we are generating extended interface files
+
.. ghc-flag:: -ddump-splices
:shortdesc: Dump TH spliced expressions, and what they evaluate to
:type: dynamic
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef7576c40f8de391ed8b1c81c38156202e6d17cf
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef7576c40f8de391ed8b1c81c38156202e6d17cf
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200403/51b35c46/attachment-0001.html>
More information about the ghc-commits
mailing list