[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Add info about typeclass evidence to .hie files
Marge Bot
gitlab at gitlab.haskell.org
Tue May 26 01:33:24 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
696879f9 by Zubin Duggal at 2020-05-25T21:32:33-04:00
Add info about typeclass evidence to .hie files
See `testsuite/tests/hiefile/should_run/HieQueries.hs` and
`testsuite/tests/hiefile/should_run/HieQueries.stdout` for an example of this
We add two new fields, `EvidenceVarBind` and `EvidenceVarUse` to the
`ContextInfo` associated with an Identifier. These are associated with the
appropriate identifiers for the evidence variables collected when we come across
`HsWrappers`, `TcEvBinds` and `IPBinds` while traversing the AST.
Instance dictionary and superclass selector dictionaries from `tcg_insts` and
classes defined in `tcg_tcs` are also recorded in the AST as originating from
their definition span
This allows us to save a complete picture of the evidence constructed by the
constraint solver, and will let us report this to the user, enabling features
like going to the instance definition from the invocation of a class method(or
any other method taking a constraint) and finding all usages of a particular
instance.
Additionally,
- Mark NodeInfo with an origin so we can differentiate between bindings
origininating in the source vs those in ghc
- Along with typeclass evidence info, also include information on Implicit
Parameters
- Add a few utility functions to HieUtils in order to query the new info
Updates haddock submodule
- - - - -
2e5fd786 by Sebastian Graf at 2020-05-25T21:32:35-04:00
Make WorkWrap.Lib.isWorkerSmallEnough aware of the old arity
We should allow a wrapper with up to 82 parameters when the original
function had 82 parameters to begin with.
I verified that this made no difference on NoFib, but then again
it doesn't use huge records...
Fixes #18122.
- - - - -
38ad4a19 by Sylvain Henry at 2020-05-25T21:33:10-04:00
Enhance Note [About units] for Backpack
- - - - -
19 changed files:
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Ext/Debug.hs
- compiler/GHC/Iface/Ext/Types.hs
- compiler/GHC/Iface/Ext/Utils.hs
- compiler/GHC/Unit.hs
- docs/users_guide/using-optimisation.rst
- testsuite/tests/hiefile/should_compile/Scopes.hs
- + testsuite/tests/hiefile/should_run/HieQueries.hs
- + testsuite/tests/hiefile/should_run/HieQueries.stdout
- testsuite/tests/hiefile/should_run/PatTypes.hs
- testsuite/tests/hiefile/should_run/all.T
- + testsuite/tests/stranal/should_compile/T18122.hs
- + testsuite/tests/stranal/should_compile/T18122.stderr
- testsuite/tests/stranal/should_compile/all.T
- utils/haddock
Changes:
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -1947,7 +1947,7 @@ callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
-- Remove ones that have too many worker variables
small_pats = filterOut too_big non_dups
- too_big (vars,_) = not (isWorkerSmallEnough (sc_dflags env) vars)
+ too_big (vars,args) = not (isWorkerSmallEnough (sc_dflags env) (valArgCount args) vars)
-- We are about to construct w/w pair in 'spec_one'.
-- Omit specialisation leading to high arity workers.
-- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils
@@ -2101,12 +2101,12 @@ argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
argToPat env in_scope val_env (Tick _ arg) arg_occ
= argToPat env in_scope val_env arg arg_occ
- -- Note [Notes in call patterns]
+ -- Note [Tick annotations in call patterns]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Ignore Notes. In particular, we want to ignore any InlineMe notes
-- Perhaps we should not ignore profiling notes, but I'm going to
-- ride roughshod over them all for now.
- --- See Note [Notes in RULE matching] in GHC.Core.Rules
+ --- See Note [Tick annotations in RULE matching] in GHC.Core.Rules
argToPat env in_scope val_env (Let _ arg) arg_occ
= argToPat env in_scope val_env arg arg_occ
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -162,7 +162,7 @@ mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info
wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var
worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args
- ; if isWorkerSmallEnough dflags work_args
+ ; if isWorkerSmallEnough dflags (length demands) work_args
&& not (too_many_args_for_join_point wrap_args)
&& ((useful1 && not only_one_void_argument) || useful2)
then return (Just (worker_args_dmds, length work_call_args,
@@ -203,10 +203,13 @@ mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info
= False
-- See Note [Limit w/w arity]
-isWorkerSmallEnough :: DynFlags -> [Var] -> Bool
-isWorkerSmallEnough dflags vars = count isId vars <= maxWorkerArgs dflags
+isWorkerSmallEnough :: DynFlags -> Int -> [Var] -> Bool
+isWorkerSmallEnough dflags old_n_args vars
+ = count isId vars <= max old_n_args (maxWorkerArgs dflags)
-- We count only Free variables (isId) to skip Type, Kind
-- variables which have no runtime representation.
+ -- Also if the function took 82 arguments before (old_n_args), it's fine if
+ -- it takes <= 82 arguments afterwards.
{-
Note [Always do CPR w/w]
@@ -227,7 +230,8 @@ Guard against high worker arity as it generates a lot of stack traffic.
A simplified example is #11565#comment:6
Current strategy is very simple: don't perform w/w transformation at all
-if the result produces a wrapper with arity higher than -fmax-worker-args=.
+if the result produces a wrapper with arity higher than -fmax-worker-args
+and the number arguments before w/w.
It is a bit all or nothing, consider
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -1034,7 +1034,7 @@ ways in which these may be introduced (e.g. #18162, #17619). Such ticks are
ignored by the matcher. See Note [Simplifying rules] in
GHC.Core.Opt.Simplify.Utils for details.
-cf Note [Notes in call patterns] in GHC.Core.Opt.SpecConstr
+cf Note [Tick annotations in call patterns] in GHC.Core.Opt.SpecConstr
Note [Matching lets]
~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -13,36 +13,47 @@ Main functions for .hie file generation
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts) where
+import GHC.Utils.Outputable(ppr)
+
import GHC.Prelude
import GHC.Types.Avail ( Avails )
import GHC.Data.Bag ( Bag, bagToList )
import GHC.Types.Basic
import GHC.Data.BooleanFormula
-import GHC.Core.Class ( FunDep )
+import GHC.Core.Class ( FunDep, className, classSCSelIds )
import GHC.Core.Utils ( exprType )
import GHC.Core.ConLike ( conLikeName )
+import GHC.Core.TyCon ( TyCon, tyConClass_maybe )
+import GHC.Core.FVs
import GHC.HsToCore ( deSugarExpr )
import GHC.Types.FieldLabel
import GHC.Hs
import GHC.Driver.Types
import GHC.Unit.Module ( ModuleName, ml_hs_file )
import GHC.Utils.Monad ( concatMapM, liftIO )
-import GHC.Types.Name ( Name, nameSrcSpan, setNameLoc )
+import GHC.Types.Name ( Name, nameSrcSpan, setNameLoc, nameUnique )
import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )
import GHC.Types.SrcLoc
import GHC.Tc.Utils.Zonk ( hsLitType, hsPatType )
import GHC.Core.Type ( mkVisFunTys, Type )
+import GHC.Core.Predicate
+import GHC.Core.InstEnv
import GHC.Builtin.Types ( mkListTy, mkSumTy )
-import GHC.Types.Var ( Id, Var, setVarName, varName, varType )
import GHC.Tc.Types
+import GHC.Tc.Types.Evidence
+import GHC.Types.Var ( Id, Var, EvId, setVarName, varName, varType, varUnique )
+import GHC.Types.Var.Env
+import GHC.Types.Unique
import GHC.Iface.Make ( mkIfaceExports )
import GHC.Utils.Panic
import GHC.Data.Maybe
+import GHC.Data.FastString
import GHC.Iface.Ext.Types
import GHC.Iface.Ext.Utils
@@ -53,6 +64,8 @@ import qualified Data.Map as M
import qualified Data.Set as S
import Data.Data ( Data, Typeable )
import Data.List ( foldl1' )
+import Control.Monad ( forM_ )
+import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class ( lift )
@@ -196,12 +209,47 @@ The Typechecker introduces new names for mono names in AbsBinds.
We don't care about the distinction between mono and poly bindings,
so we replace all occurrences of the mono name with the poly name.
-}
-newtype HieState = HieState
+type VarMap a = DVarEnv (Var,a)
+data HieState = HieState
{ name_remapping :: NameEnv Id
+ , unlocated_ev_binds :: VarMap (S.Set ContextInfo)
+ -- These contain evidence bindings that we don't have a location for
+ -- These are placed at the top level Node in the HieAST after everything
+ -- else has been generated
+ -- This includes things like top level evidence bindings.
}
+addUnlocatedEvBind :: Var -> ContextInfo -> HieM ()
+addUnlocatedEvBind var ci = do
+ let go (a,b) (_,c) = (a,S.union b c)
+ lift $ modify' $ \s ->
+ s { unlocated_ev_binds =
+ extendDVarEnv_C go (unlocated_ev_binds s)
+ var (var,S.singleton ci)
+ }
+
+getUnlocatedEvBinds :: FastString -> HieM (NodeIdentifiers Type,[HieAST Type])
+getUnlocatedEvBinds file = do
+ binds <- lift $ gets unlocated_ev_binds
+ org <- ask
+ let elts = dVarEnvElts binds
+
+ mkNodeInfo (n,ci) = (Right (varName n), IdentifierDetails (Just $ varType n) ci)
+
+ go e@(v,_) (xs,ys) = case nameSrcSpan $ varName v of
+ RealSrcSpan spn _
+ | srcSpanFile spn == file ->
+ let node = Node (mkSourcedNodeInfo org ni) spn []
+ ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e]
+ in (xs,node:ys)
+ _ -> (mkNodeInfo e : xs,ys)
+
+ (nis,asts) = foldr go ([],[]) elts
+
+ pure $ (M.fromList nis, asts)
+
initState :: HieState
-initState = HieState emptyNameEnv
+initState = HieState emptyNameEnv emptyDVarEnv
class ModifyState a where -- See Note [Name Remapping]
addSubstitution :: a -> a -> HieState -> HieState
@@ -216,10 +264,11 @@ instance ModifyState Id where
modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState
modifyState = foldr go id
where
- go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f
+ go ABE{abe_poly=poly,abe_mono=mono} f
+ = addSubstitution mono poly . f
go _ f = f
-type HieM = ReaderT HieState Hsc
+type HieM = ReaderT NodeOrigin (StateT HieState Hsc)
-- | Construct an 'HieFile' from the outputs of the typechecker.
mkHieFile :: ModSummary
@@ -239,7 +288,10 @@ mkHieFileWithSource :: FilePath
-> RenamedSource -> Hsc HieFile
mkHieFileWithSource src_file src ms ts rs = do
let tc_binds = tcg_binds ts
- (asts', arr) <- getCompressedAsts tc_binds rs
+ top_ev_binds = tcg_ev_binds ts
+ insts = tcg_insts ts
+ tcs = tcg_tcs ts
+ (asts', arr) <- getCompressedAsts tc_binds rs top_ev_binds insts tcs
return $ HieFile
{ hie_hs_file = src_file
, hie_module = ms_mod ms
@@ -250,38 +302,70 @@ mkHieFileWithSource src_file src ms ts rs = do
, hie_hs_src = src
}
-getCompressedAsts :: TypecheckedSource -> RenamedSource
+getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]
-> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
-getCompressedAsts ts rs = do
- asts <- enrichHie ts rs
+getCompressedAsts ts rs top_ev_binds insts tcs = do
+ asts <- enrichHie ts rs top_ev_binds insts tcs
return $ compressTypes asts
-enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)
-enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do
+enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]
+ -> Hsc (HieASTs Type)
+enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs =
+ flip evalStateT initState $ flip runReaderT SourceInfo $ do
tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts
rasts <- processGrp hsGrp
imps <- toHie $ filter (not . ideclImplicit . unLoc) imports
exps <- toHie $ fmap (map $ IEC Export . fst) exports
- let spanFile children = case children of
- [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)
+ -- Add Instance bindings
+ forM_ insts $ \i ->
+ addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind False (is_cls_nm i)) ModuleScope Nothing)
+ -- Add class parent bindings
+ forM_ tcs $ \tc ->
+ case tyConClass_maybe tc of
+ Nothing -> pure ()
+ Just c -> forM_ (classSCSelIds c) $ \v ->
+ addUnlocatedEvBind v (EvidenceVarBind (EvInstBind True (className c)) ModuleScope Nothing)
+ let spanFile file children = case children of
+ [] -> realSrcLocSpan (mkRealSrcLoc file 1 1)
_ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)
(realSrcSpanEnd $ nodeSpan $ last children)
- modulify xs =
- Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs
-
- asts = HieASTs
- $ resolveTyVarScopes
- $ M.map (modulify . mergeSortAsts)
- $ M.fromListWith (++)
- $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
-
flat_asts = concat
[ tasts
, rasts
, imps
, exps
]
+
+ modulify file xs' = do
+
+ top_ev_asts <-
+ toHie $ EvBindContext ModuleScope Nothing
+ $ L (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Nothing)
+ $ EvBinds ev_bs
+
+ (uloc_evs,more_ev_asts) <- getUnlocatedEvBinds file
+
+ let xs = mergeSortAsts $ xs' ++ top_ev_asts ++ more_ev_asts
+ span = spanFile file xs
+
+ moduleInfo = SourcedNodeInfo
+ $ M.singleton SourceInfo
+ $ (simpleNodeInfo "Module" "Module")
+ {nodeIdentifiers = uloc_evs}
+
+ moduleNode = Node moduleInfo span []
+
+ case mergeSortAsts $ moduleNode : xs of
+ [x] -> return x
+ xs -> panicDoc "enrichHie: mergeSortAsts returned more than one result" (ppr $ map nodeSpan xs)
+
+ asts' <- sequence
+ $ M.mapWithKey modulify
+ $ M.fromListWith (++)
+ $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
+
+ let asts = HieASTs $ resolveTyVarScopes asts'
return asts
where
processGrp grp = concatM
@@ -305,13 +389,16 @@ grhss_span :: GRHSs p body -> SrcSpan
grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)
grhss_span (XGRHSs _) = panic "XGRHS has no span"
-bindingsOnly :: [Context Name] -> [HieAST a]
-bindingsOnly [] = []
-bindingsOnly (C c n : xs) = case nameSrcSpan n of
- RealSrcSpan span _ -> Node nodeinfo span [] : bindingsOnly xs
- where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
- info = mempty{identInfo = S.singleton c}
- _ -> bindingsOnly xs
+bindingsOnly :: [Context Name] -> HieM [HieAST a]
+bindingsOnly [] = pure []
+bindingsOnly (C c n : xs) = do
+ org <- ask
+ rest <- bindingsOnly xs
+ pure $ case nameSrcSpan n of
+ RealSrcSpan span _ -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest
+ where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
+ info = mempty{identInfo = S.singleton c}
+ _ -> rest
concatM :: Monad m => [m [a]] -> m [a]
concatM xs = concat <$> sequence xs
@@ -345,6 +432,8 @@ data SigInfo = SI SigType (Maybe Span)
data SigType = BindSig | ClassSig | InstSig
+data EvBindContext a = EvBindContext Scope (Maybe Span) a
+
data RScoped a = RS Scope a
-- ^ Scope spans over everything to the right of a, (mostly) not
-- including a itself
@@ -502,8 +591,9 @@ instance ToHie (TScoped NoExtField) where
toHie _ = pure []
instance ToHie (IEContext (Located ModuleName)) where
- toHie (IEC c (L (RealSrcSpan span _) mname)) =
- pure $ [Node (NodeInfo S.empty [] idents) span []]
+ toHie (IEC c (L (RealSrcSpan span _) mname)) = do
+ org <- ask
+ pure $ [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []]
where details = mempty{identInfo = S.singleton (IEThing c)}
idents = M.singleton (Left mname) details
toHie _ = pure []
@@ -511,38 +601,90 @@ instance ToHie (IEContext (Located ModuleName)) where
instance ToHie (Context (Located Var)) where
toHie c = case c of
C context (L (RealSrcSpan span _) name')
- -> do
- m <- asks name_remapping
- let name = case lookupNameEnv m (varName name') of
- Just var -> var
- Nothing-> name'
- pure
- [Node
- (NodeInfo S.empty [] $
- M.singleton (Right $ varName name)
- (IdentifierDetails (Just $ varType name')
- (S.singleton context)))
- span
- []]
+ | varUnique name' == mkBuiltinUnique 1 -> pure []
+ -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
+ | otherwise -> do
+ m <- lift $ gets name_remapping
+ org <- ask
+ let name = case lookupNameEnv m (varName name') of
+ Just var -> var
+ Nothing-> name'
+ pure
+ [Node
+ (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
+ M.singleton (Right $ varName name)
+ (IdentifierDetails (Just $ varType name')
+ (S.singleton context)))
+ span
+ []]
+ C (EvidenceVarBind i _ sp) (L _ name) -> do
+ addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp)
+ pure []
_ -> pure []
instance ToHie (Context (Located Name)) where
toHie c = case c of
- C context (L (RealSrcSpan span _) name') -> do
- m <- asks name_remapping
- let name = case lookupNameEnv m name' of
- Just var -> varName var
- Nothing -> name'
- pure
- [Node
- (NodeInfo S.empty [] $
- M.singleton (Right name)
- (IdentifierDetails Nothing
- (S.singleton context)))
- span
- []]
+ C context (L (RealSrcSpan span _) name')
+ | nameUnique name' == mkBuiltinUnique 1 -> pure []
+ -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
+ | otherwise -> do
+ m <- lift $ gets name_remapping
+ org <- ask
+ let name = case lookupNameEnv m name' of
+ Just var -> varName var
+ Nothing -> name'
+ pure
+ [Node
+ (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
+ M.singleton (Right name)
+ (IdentifierDetails Nothing
+ (S.singleton context)))
+ span
+ []]
_ -> pure []
+evVarsOfTermList :: EvTerm -> [EvId]
+evVarsOfTermList (EvExpr e) = exprSomeFreeVarsList isEvVar e
+evVarsOfTermList (EvTypeable _ ev) =
+ case ev of
+ EvTypeableTyCon _ e -> concatMap evVarsOfTermList e
+ EvTypeableTyApp e1 e2 -> concatMap evVarsOfTermList [e1,e2]
+ EvTypeableTrFun e1 e2 -> concatMap evVarsOfTermList [e1,e2]
+ EvTypeableTyLit e -> evVarsOfTermList e
+evVarsOfTermList (EvFun{}) = []
+
+instance ToHie (EvBindContext (Located TcEvBinds)) where
+ toHie (EvBindContext sc sp (L span (EvBinds bs)))
+ = concatMapM go $ bagToList bs
+ where
+ go evbind = do
+ let evDeps = evVarsOfTermList $ eb_rhs evbind
+ depNames = EvBindDeps $ map varName evDeps
+ concatM $
+ [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp)
+ (L span $ eb_lhs evbind))
+ , toHie $ map (C EvidenceVarUse . L span) $ evDeps
+ ]
+ toHie _ = pure []
+
+instance ToHie (EvBindContext (Located NoExtField)) where
+ toHie _ = pure []
+
+instance ToHie (Located HsWrapper) where
+ toHie (L osp wrap)
+ = case wrap of
+ (WpLet bs) -> toHie $ EvBindContext (mkScope osp) (getRealSpan osp) (L osp bs)
+ (WpCompose a b) -> concatM $
+ [toHie (L osp a), toHie (L osp b)]
+ (WpFun a b _ _) -> concatM $
+ [toHie (L osp a), toHie (L osp b)]
+ (WpEvLam a) ->
+ toHie $ C (EvidenceVarBind EvWrapperBind (mkScope osp) (getRealSpan osp))
+ $ L osp a
+ (WpEvApp a) ->
+ concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a
+ _ -> pure []
+
-- | Dummy instances - never called
instance ToHie (TScoped (LHsSigWcType GhcTc)) where
toHie _ = pure []
@@ -586,7 +728,7 @@ instance HasType (LHsExpr GhcRn) where
--
-- See #16233
instance HasType (LHsExpr GhcTc) where
- getTypeNode e@(L spn e') = lift $
+ getTypeNode e@(L spn e') =
-- Some expression forms have their type immediately available
let tyOpt = case e' of
HsLit _ l -> Just (hsLitType l)
@@ -609,7 +751,7 @@ instance HasType (LHsExpr GhcTc) where
Nothing
| skipDesugaring e' -> fallback
| otherwise -> do
- hs_env <- Hsc $ \e w -> return (e,w)
+ hs_env <- lift $ lift $ Hsc $ \e w -> return (e,w)
(_,mbe) <- liftIO $ deSugarExpr hs_env e
maybe fallback (makeTypeNode e' spn . exprType) mbe
where
@@ -634,21 +776,25 @@ instance HasType (LHsExpr GhcTc) where
XExpr (HsWrap{}) -> False
_ -> True
-instance ( ToHie (Context (Located (IdP a)))
- , ToHie (MatchGroup a (LHsExpr a))
- , ToHie (PScoped (LPat a))
- , ToHie (GRHSs a (LHsExpr a))
- , ToHie (LHsExpr a)
- , ToHie (Located (PatSynBind a a))
- , HasType (LHsBind a)
- , ModifyState (IdP a)
- , Data (HsBind a)
- ) => ToHie (BindContext (LHsBind a)) where
+instance ( ToHie (Context (Located (IdP (GhcPass a))))
+ , ToHie (MatchGroup (GhcPass a) (LHsExpr (GhcPass a)))
+ , ToHie (PScoped (LPat (GhcPass a)))
+ , ToHie (GRHSs (GhcPass a) (LHsExpr (GhcPass a)))
+ , ToHie (LHsExpr (GhcPass a))
+ , ToHie (Located (PatSynBind (GhcPass a) (GhcPass a)))
+ , HasType (LHsBind (GhcPass a))
+ , ModifyState (IdP (GhcPass a))
+ , Data (HsBind (GhcPass a))
+ , IsPass a
+ ) => ToHie (BindContext (LHsBind (GhcPass a))) where
toHie (BC context scope b@(L span bind)) =
concatM $ getTypeNode b : case bind of
- FunBind{fun_id = name, fun_matches = matches} ->
+ FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} ->
[ toHie $ C (ValBind context scope $ getRealSpan span) name
, toHie matches
+ , case ghcPass @a of
+ GhcTc -> toHie $ L span wrap
+ _ -> pure []
]
PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
[ toHie $ PS (getRealSpan span) scope NoScope lhs
@@ -657,39 +803,55 @@ instance ( ToHie (Context (Located (IdP a)))
VarBind{var_rhs = expr} ->
[ toHie expr
]
- AbsBinds{abs_exports = xs, abs_binds = binds} ->
- [ local (modifyState xs) $ -- Note [Name Remapping]
- toHie $ fmap (BC context scope) binds
+ AbsBinds{ abs_exports = xs, abs_binds = binds
+ , abs_ev_binds = ev_binds
+ , abs_ev_vars = ev_vars } ->
+ [ lift (modify (modifyState xs)) >> -- Note [Name Remapping]
+ (toHie $ fmap (BC context scope) binds)
+ , toHie $ map (L span . abe_wrap) xs
+ , toHie $
+ map (EvBindContext (mkScope span) (getRealSpan span)
+ . L span) ev_binds
+ , toHie $
+ map (C (EvidenceVarBind EvSigBind
+ (mkScope span)
+ (getRealSpan span))
+ . L span) ev_vars
]
PatSynBind _ psb ->
[ toHie $ L span psb -- PatSynBinds only occur at the top level
]
- XHsBindsLR _ -> []
instance ( ToHie (LMatch a body)
) => ToHie (MatchGroup a body) where
- toHie mg = concatM $ case mg of
- MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->
- [ pure $ locOnly span
- , toHie alts
- ]
- MG{} -> []
- XMatchGroup _ -> []
+ toHie mg = case mg of
+ MG{ mg_alts = (L span alts) , mg_origin = origin} ->
+ local (setOrigin origin) $ concatM
+ [ locOnly span
+ , toHie alts
+ ]
+ XMatchGroup _ -> pure []
+
+setOrigin :: Origin -> NodeOrigin -> NodeOrigin
+setOrigin FromSource _ = SourceInfo
+setOrigin Generated _ = GeneratedInfo
instance ( ToHie (Context (Located (IdP a)))
, ToHie (PScoped (LPat a))
, ToHie (HsPatSynDir a)
+ , (a ~ GhcPass p)
) => ToHie (Located (PatSynBind a a)) where
toHie (L sp psb) = concatM $ case psb of
PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->
[ toHie $ C (Decl PatSynDec $ getRealSpan sp) var
, toHie $ toBind dets
- , toHie $ PS Nothing lhsScope NoScope pat
+ , toHie $ PS Nothing lhsScope patScope pat
, toHie dir
]
where
lhsScope = combineScopes varScope detScope
varScope = mkLScope var
+ patScope = mkScope $ getLoc pat
detScope = case dets of
(PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args
(InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)
@@ -702,7 +864,6 @@ instance ( ToHie (Context (Located (IdP a)))
toBind (PrefixCon args) = PrefixCon $ map (C Use) args
toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
toBind (RecCon r) = RecCon $ map (PSC detSpan) r
- XPatSynBind _ -> []
instance ( ToHie (MatchGroup a (LHsExpr a))
) => ToHie (HsPatSynDir a) where
@@ -780,12 +941,24 @@ instance ( a ~ GhcPass p
SumPat _ pat _ _ ->
[ toHie $ PS rsp scope pscope pat
]
- ConPat {pat_con = con, pat_args = dets}->
+ ConPat {pat_con = con, pat_args = dets, pat_con_ext = ext}->
[ case ghcPass @p of
GhcPs -> toHie $ C Use $ con
GhcRn -> toHie $ C Use $ con
GhcTc -> toHie $ C Use $ fmap conLikeName con
, toHie $ contextify dets
+ , case ghcPass @p of
+ GhcTc ->
+ let ev_binds = cpt_binds ext
+ ev_vars = cpt_dicts ext
+ wrap = cpt_wrap ext
+ evscope = mkScope ospan `combineScopes` scope `combineScopes` pscope
+ in concatM [ toHie $ EvBindContext scope rsp $ L ospan ev_binds
+ , toHie $ L ospan wrap
+ , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp)
+ . L ospan) ev_vars
+ ]
+ _ -> pure []
]
ViewPat _ expr pat ->
[ toHie expr
@@ -816,10 +989,12 @@ instance ( a ~ GhcPass p
GhcPs -> noExtCon e
GhcRn -> noExtCon e
#endif
- GhcTc -> []
+ GhcTc ->
+ [ toHie $ L ospan wrap
+ , toHie $ PS rsp scope pscope $ (L ospan pat :: LPat a)
+ ]
where
- -- Make sure we get an error if this changes
- _noWarn@(CoPat _ _ _) = e
+ CoPat wrap pat _ = e
where
contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
contextify (InfixCon a b) = InfixCon a' b'
@@ -833,7 +1008,7 @@ instance ( a ~ GhcPass p
instance ToHie (TScoped (HsPatSigType GhcRn)) where
toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $
- [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs)
+ [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs)
, toHie body
]
-- See Note [Scoping Rules for SigPat]
@@ -850,15 +1025,14 @@ instance ( ToHie body
XGRHSs _ -> []
instance ( ToHie (Located body)
- , ToHie (RScoped (GuardLStmt a))
- , Data (GRHS a (Located body))
- ) => ToHie (LGRHS a (Located body)) where
+ , ToHie (RScoped (GuardLStmt (GhcPass a)))
+ , Data (GRHS (GhcPass a) (Located body))
+ ) => ToHie (LGRHS (GhcPass a) (Located body)) where
toHie (L span g) = concatM $ makeNode g span : case g of
GRHS _ guards body ->
[ toHie $ listScopes (mkLScope body) guards
, toHie body
]
- XGRHS _ -> []
instance ( a ~ GhcPass p
, ToHie (Context (Located (IdP a)))
@@ -954,7 +1128,7 @@ instance ( a ~ GhcPass p
, toHie expr
]
HsDo _ _ (L ispan stmts) ->
- [ pure $ locOnly ispan
+ [ locOnly ispan
, toHie $ listScopes NoScope stmts
]
ExplicitList _ _ exprs ->
@@ -1008,9 +1182,10 @@ instance ( a ~ GhcPass p
]
XExpr x
| GhcTc <- ghcPass @p
- , HsWrap _ a <- x
- -> [ toHie $ L mspan a ]
-
+ , HsWrap w a <- x
+ -> [ toHie $ L mspan a
+ , toHie (L mspan w)
+ ]
| otherwise
-> []
@@ -1070,17 +1245,37 @@ instance ( ToHie (LHsExpr a)
, ToHie (BindContext (LHsBind a))
, ToHie (SigContext (LSig a))
, ToHie (RScoped (HsValBindsLR a a))
+ , ToHie (EvBindContext (Located (XIPBinds a)))
+ , ToHie (RScoped (LIPBind a))
, Data (HsLocalBinds a)
) => ToHie (RScoped (LHsLocalBinds a)) where
toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of
EmptyLocalBinds _ -> []
- HsIPBinds _ _ -> []
+ HsIPBinds _ ipbinds -> case ipbinds of
+ IPBinds evbinds xs -> let sc = combineScopes scope $ mkScope sp in
+ [ toHie $ EvBindContext sc (getRealSpan sp) $ L sp evbinds
+ , toHie $ map (RS sc) xs
+ ]
+ XHsIPBinds _ -> []
HsValBinds _ valBinds ->
[ toHie $ RS (combineScopes scope $ mkScope sp)
valBinds
]
XHsLocalBindsLR _ -> []
+instance ( ToHie (LHsExpr a)
+ , ToHie (Context (Located (IdP a)))
+ , Data (IPBind a)
+ ) => ToHie (RScoped (LIPBind a)) where
+ toHie (RS scope (L sp bind)) = concatM $ makeNode bind sp : case bind of
+ IPBind _ (Left _) expr -> [toHie expr]
+ IPBind _ (Right v) expr ->
+ [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpan sp))
+ $ L sp v
+ , toHie expr
+ ]
+ XIPBind _ -> []
+
instance ( ToHie (BindContext (LHsBind a))
, ToHie (SigContext (LSig a))
, ToHie (RScoped (XXValBindsLR a a))
@@ -1160,6 +1355,7 @@ instance ( a ~ GhcPass p
, ToHie (LHsExpr a)
, ToHie (SigContext (LSig a))
, ToHie (RScoped (HsValBindsLR a a))
+ , ToHie (RScoped (ExprLStmt a))
, Data (StmtLR a a (Located (HsExpr a)))
, Data (HsLocalBinds a)
) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
@@ -1193,6 +1389,7 @@ instance ( a ~ GhcPass p
, ToHie (MatchGroup a (LHsCmd a))
, ToHie (SigContext (LSig a))
, ToHie (RScoped (HsValBindsLR a a))
+ , ToHie (RScoped (LHsLocalBinds a))
, Data (HsCmd a)
, Data (HsCmdTop a)
, Data (StmtLR a a (Located (HsCmd a)))
@@ -1235,7 +1432,7 @@ instance ( a ~ GhcPass p
, toHie cmd'
]
HsCmdDo _ (L ispan stmts) ->
- [ pure $ locOnly ispan
+ [ locOnly ispan
, toHie $ listScopes NoScope stmts
]
XCmd _ -> []
@@ -1289,7 +1486,7 @@ instance ToHie (LTyClDecl GhcRn) where
, toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs
, toHie $ fmap (BC InstanceBind ModuleScope) meths
, toHie typs
- , concatMapM (pure . locOnly . getLoc) deftyps
+ , concatMapM (locOnly . getLoc) deftyps
, toHie deftyps
]
where
@@ -1313,7 +1510,7 @@ instance ToHie (LFamilyDecl GhcRn) where
instance ToHie (FamilyInfo GhcRn) where
toHie (ClosedTypeFamily (Just eqns)) = concatM $
- [ concatMapM (pure . locOnly . getLoc) eqns
+ [ concatMapM (locOnly . getLoc) eqns
, toHie $ map go eqns
]
where
@@ -1371,7 +1568,7 @@ instance ToHie (HsDataDefn GhcRn) where
instance ToHie (HsDeriving GhcRn) where
toHie (L span clauses) = concatM
- [ pure $ locOnly span
+ [ locOnly span
, toHie clauses
]
@@ -1379,7 +1576,7 @@ instance ToHie (LHsDerivingClause GhcRn) where
toHie (L span cl) = concatM $ makeNode cl span : case cl of
HsDerivingClause _ strat (L ispan tys) ->
[ toHie strat
- , pure $ locOnly ispan
+ , locOnly ispan
, toHie $ map (TS (ResolvedScopes [])) tys
]
@@ -1391,14 +1588,14 @@ instance ToHie (Located (DerivStrategy GhcRn)) where
ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]
instance ToHie (Located OverlapMode) where
- toHie (L span _) = pure $ locOnly span
+ toHie (L span _) = locOnly span
instance ToHie (LConDecl GhcRn) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars
, con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
[ toHie $ map (C (Decl ConDec $ getRealSpan span)) names
- , concatM $ [ pure $ bindingsOnly bindings
+ , concatM $ [ bindingsOnly bindings
, toHie $ tvScopes resScope NoScope exp_vars ]
, toHie ctx
, toHie args
@@ -1429,7 +1626,7 @@ instance ToHie (LConDecl GhcRn) where
instance ToHie (Located [LConDeclField GhcRn]) where
toHie (L span decls) = concatM $
- [ pure $ locOnly span
+ [ locOnly span
, toHie decls
]
@@ -1437,7 +1634,7 @@ instance ( HasLoc thing
, ToHie (TScoped thing)
) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where
toHie (TS sc (HsIB ibrn a)) = concatM $
- [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
+ [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
, toHie $ TS sc a
]
where span = loc a
@@ -1446,7 +1643,7 @@ instance ( HasLoc thing
, ToHie (TScoped thing)
) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where
toHie (TS sc (HsWC names a)) = concatM $
- [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
+ [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
, toHie $ TS sc a
]
where span = loc a
@@ -1496,10 +1693,10 @@ instance ToHie (SigContext (LSig GhcRn)) where
]
SCCFunSig _ _ name mtxt ->
[ toHie $ (C Use) name
- , pure $ maybe [] (locOnly . getLoc) mtxt
+ , maybe (pure []) (locOnly . getLoc) mtxt
]
CompleteMatchSig _ _ (L ispan names) typ ->
- [ pure $ locOnly ispan
+ [ locOnly ispan
, toHie $ map (C Use) names
, toHie $ fmap (C Use) typ
]
@@ -1583,7 +1780,7 @@ instance ToHie (TScoped (LHsType GhcRn)) where
instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
toHie (HsValArg tm) = toHie tm
toHie (HsTypeArg _ ty) = toHie ty
- toHie (HsArgPar sp) = pure $ locOnly sp
+ toHie (HsArgPar sp) = locOnly sp
instance Data flag => ToHie (TVScoped (LHsTyVarBndr flag GhcRn)) where
toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
@@ -1597,7 +1794,7 @@ instance Data flag => ToHie (TVScoped (LHsTyVarBndr flag GhcRn)) where
instance ToHie (TScoped (LHsQTyVars GhcRn)) where
toHie (TS sc (HsQTvs implicits vars)) = concatM $
- [ pure $ bindingsOnly bindings
+ [ bindingsOnly bindings
, toHie $ tvScopes sc NoScope vars
]
where
@@ -1606,7 +1803,7 @@ instance ToHie (TScoped (LHsQTyVars GhcRn)) where
instance ToHie (LHsContext GhcRn) where
toHie (L span tys) = concatM $
- [ pure $ locOnly span
+ [ locOnly span
, toHie tys
]
@@ -1679,7 +1876,7 @@ instance ( a ~ GhcPass p
[ toHie expr
]
HsQuasiQuote _ _ _ ispan _ ->
- [ pure $ locOnly ispan
+ [ locOnly ispan
]
HsSpliced _ _ _ ->
[]
@@ -1695,7 +1892,7 @@ instance ToHie (LRoleAnnotDecl GhcRn) where
toHie (L span annot) = concatM $ makeNode annot span : case annot of
RoleAnnotDecl _ var roles ->
[ toHie $ C Use var
- , concatMapM (pure . locOnly . getLoc) roles
+ , concatMapM (locOnly . getLoc) roles
]
instance ToHie (LInstDecl GhcRn) where
@@ -1715,9 +1912,9 @@ instance ToHie (LClsInstDecl GhcRn) where
[ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
, toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
, toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl
- , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl
+ , concatMapM (locOnly . getLoc) $ cid_tyfam_insts decl
, toHie $ cid_tyfam_insts decl
- , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl
+ , concatMapM (locOnly . getLoc) $ cid_datafam_insts decl
, toHie $ cid_datafam_insts decl
, toHie $ cid_overlap_mode decl
]
@@ -1769,14 +1966,14 @@ instance ToHie (LForeignDecl GhcRn) where
]
instance ToHie ForeignImport where
- toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $
+ toHie (CImport (L a _) (L b _) _ _ (L c _)) = concatM $
[ locOnly a
, locOnly b
, locOnly c
]
instance ToHie ForeignExport where
- toHie (CExport (L a _) (L b _)) = pure $ concat $
+ toHie (CExport (L a _) (L b _)) = concatM $
[ locOnly a
, locOnly b
]
@@ -1814,7 +2011,7 @@ instance ToHie (LRuleDecls GhcRn) where
instance ToHie (LRuleDecl GhcRn) where
toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
[ makeNode r span
- , pure $ locOnly $ getLoc rname
+ , locOnly $ getLoc rname
, toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
, toHie $ map (RS $ mkScope span) bndrs
, toHie exprA
@@ -1844,7 +2041,7 @@ instance ToHie (LImportDecl GhcRn) where
]
where
goIE (hiding, (L sp liens)) = concatM $
- [ pure $ locOnly sp
+ [ locOnly sp
, toHie $ map (IEC c) liens
]
where
=====================================
compiler/GHC/Iface/Ext/Binary.hs
=====================================
@@ -23,7 +23,6 @@ import GHC.Utils.Binary
import GHC.Iface.Binary ( getDictFastString )
import GHC.Data.FastMutInt
import GHC.Data.FastString ( FastString )
-import GHC.Unit.Module ( Module )
import GHC.Types.Name
import GHC.Types.Name.Cache
import GHC.Utils.Outputable
@@ -32,7 +31,6 @@ import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Unique.Supply ( takeUniqFromSupply )
import GHC.Types.Unique
import GHC.Types.Unique.FM
-import GHC.Utils.Misc
import GHC.Iface.Env (NameCacheUpdater(..))
import qualified Data.Array as A
@@ -48,42 +46,6 @@ import System.FilePath ( takeDirectory )
import GHC.Iface.Ext.Types
--- | `Name`'s get converted into `HieName`'s before being written into @.hie@
--- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
--- these two types.
-data HieName
- = ExternalName !Module !OccName !SrcSpan
- | LocalName !OccName !SrcSpan
- | KnownKeyName !Unique
- deriving (Eq)
-
-instance Ord HieName where
- compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) `thenCmp` SrcLoc.leftmost_smallest c f
- -- TODO (int-index): Perhaps use RealSrcSpan in HieName?
- compare (LocalName a b) (LocalName c d) = compare a c `thenCmp` SrcLoc.leftmost_smallest b d
- -- TODO (int-index): Perhaps use RealSrcSpan in HieName?
- compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
- -- Not actually non deterministic as it is a KnownKey
- compare ExternalName{} _ = LT
- compare LocalName{} ExternalName{} = GT
- compare LocalName{} _ = LT
- compare KnownKeyName{} _ = GT
-
-instance Outputable HieName where
- ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp
- ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
- ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
-
-hieNameOcc :: HieName -> OccName
-hieNameOcc (ExternalName _ occ _) = occ
-hieNameOcc (LocalName occ _) = occ
-hieNameOcc (KnownKeyName u) =
- case lookupKnownKeyName u of
- Just n -> nameOccName n
- Nothing -> pprPanic "hieNameOcc:unknown known-key unique"
- (ppr (unpkUnique u))
-
-
data HieSymbolTable = HieSymbolTable
{ hie_symtab_next :: !FastMutInt
, hie_symtab_map :: !(IORef (UniqFM (Int, HieName)))
@@ -352,14 +314,6 @@ putName (HieSymbolTable next ref) bh name = do
-- ** Converting to and from `HieName`'s
-toHieName :: Name -> HieName
-toHieName name
- | isKnownKeyName name = KnownKeyName (nameUnique name)
- | isExternalName name = ExternalName (nameModule name)
- (nameOccName name)
- (nameSrcSpan name)
- | otherwise = LocalName (nameOccName name) (nameSrcSpan name)
-
fromHieName :: NameCache -> HieName -> (NameCache, Name)
fromHieName nc (ExternalName mod occ span) =
let cache = nsNames nc
=====================================
compiler/GHC/Iface/Ext/Debug.hs
=====================================
@@ -15,7 +15,6 @@ import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Iface.Ext.Types
-import GHC.Iface.Ext.Binary
import GHC.Iface.Ext.Utils
import GHC.Types.Name
@@ -39,17 +38,18 @@ diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =
spanDiff
| span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]]
| otherwise = []
- infoDiff'
- = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2
- ++ (diffList diffType `on` nodeType) info1 info2
- ++ (diffIdents `on` nodeIdentifiers) info1 info2
- infoDiff = case infoDiff' of
+ infoDiff' i1 i2
+ = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) i1 i2
+ ++ (diffList diffType `on` nodeType) i1 i2
+ ++ (diffIdents `on` nodeIdentifiers) i1 i2
+ sinfoDiff = diffList (\(k1,a) (k2,b) -> eqDiff k1 k2 ++ infoDiff' a b) `on` (M.toList . getSourcedNodeInfo)
+ infoDiff = case sinfoDiff info1 info2 of
[] -> []
- xs -> xs ++ [vcat ["In Node:",ppr (nodeIdentifiers info1,span1)
- , "and", ppr (nodeIdentifiers info2,span2)
+ xs -> xs ++ [vcat ["In Node:",ppr (sourcedNodeIdents info1,span1)
+ , "and", ppr (sourcedNodeIdents info2,span2)
, "While comparing"
- , ppr (normalizeIdents $ nodeIdentifiers info1), "and"
- , ppr (normalizeIdents $ nodeIdentifiers info2)
+ , ppr (normalizeIdents $ sourcedNodeIdents info1), "and"
+ , ppr (normalizeIdents $ sourcedNodeIdents info2)
]
]
@@ -107,11 +107,24 @@ validAst (Node _ span children) = do
-- | Look for any identifiers which occur outside of their supposed scopes.
-- Returns a list of error messages.
validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc]
-validateScopes mod asts = validScopes
+validateScopes mod asts = validScopes ++ validEvs
where
refMap = generateReferencesMap asts
-- We use a refmap for most of the computation
+ evs = M.keys
+ $ M.filter (any isEvidenceContext . concatMap (S.toList . identInfo . snd)) refMap
+
+ validEvs = do
+ i@(Right ev) <- evs
+ case M.lookup i refMap of
+ Nothing -> ["Impossible, ev"<+> ppr ev <+> "not found in refmap" ]
+ Just refs
+ | nameIsLocalOrFrom mod ev
+ , not (any isEvidenceBind . concatMap (S.toList . identInfo . snd) $ refs)
+ -> ["Evidence var" <+> ppr ev <+> "not bound in refmap"]
+ | otherwise -> []
+
-- Check if all the names occur in their calculated scopes
validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap
valid (Left _) _ = []
@@ -122,15 +135,18 @@ validateScopes mod asts = validScopes
Just xs -> xs
Nothing -> []
inScope (sp, dets)
- | (definedInAsts asts n)
+ | (definedInAsts asts n || (any isEvidenceContext (identInfo dets)))
&& any isOccurrence (identInfo dets)
-- We validate scopes for names which are defined locally, and occur
- -- in this span
+ -- in this span, or are evidence variables
= case scopes of
- [] | (nameIsLocalOrFrom mod n
- && not (isDerivedOccName $ nameOccName n))
- -- If we don't get any scopes for a local name then its an error.
- -- We can ignore derived names.
+ [] | nameIsLocalOrFrom mod n
+ , ( not (isDerivedOccName $ nameOccName n)
+ || any isEvidenceContext (identInfo dets))
+ -- If we don't get any scopes for a local name or
+ -- an evidence variable, then its an error.
+ -- We can ignore other kinds of derived names as
+ -- long as we take evidence vars into account
-> return $ hsep $
[ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp
, "Doesn't have a calculated scope: ", ppr scopes]
=====================================
compiler/GHC/Iface/Ext/Types.hs
=====================================
@@ -17,13 +17,16 @@ import GHC.Prelude
import GHC.Settings.Config
import GHC.Utils.Binary
import GHC.Data.FastString ( FastString )
+import GHC.Builtin.Utils
import GHC.Iface.Type
-import GHC.Unit.Module ( ModuleName, Module )
-import GHC.Types.Name ( Name )
+import GHC.Unit.Module ( ModuleName, Module )
+import GHC.Types.Name
import GHC.Utils.Outputable hiding ( (<>) )
-import GHC.Types.SrcLoc ( RealSrcSpan )
+import GHC.Types.SrcLoc
import GHC.Types.Avail
+import GHC.Types.Unique
import qualified GHC.Utils.Outputable as O ( (<>) )
+import GHC.Utils.Misc
import qualified Data.Array as A
import qualified Data.Map as M
@@ -33,6 +36,8 @@ import Data.Data ( Typeable, Data )
import Data.Semigroup ( Semigroup(..) )
import Data.Word ( Word8 )
import Control.Applicative ( (<|>) )
+import Data.Coerce ( coerce )
+import Data.Function ( on )
type Span = RealSrcSpan
@@ -222,17 +227,16 @@ instance Outputable a => Outputable (HieASTs a) where
, rest
]
-
data HieAST a =
Node
- { nodeInfo :: NodeInfo a
+ { sourcedNodeInfo :: SourcedNodeInfo a
, nodeSpan :: Span
, nodeChildren :: [HieAST a]
} deriving (Functor, Foldable, Traversable)
instance Binary (HieAST TypeIndex) where
put_ bh ast = do
- put_ bh $ nodeInfo ast
+ put_ bh $ sourcedNodeInfo ast
put_ bh $ nodeSpan ast
put_ bh $ nodeChildren ast
@@ -247,6 +251,38 @@ instance Outputable a => Outputable (HieAST a) where
header = text "Node@" O.<> ppr sp O.<> ":" <+> ppr ni
rest = vcat (map ppr ch)
+
+-- | NodeInfos grouped by source
+newtype SourcedNodeInfo a = SourcedNodeInfo { getSourcedNodeInfo :: (M.Map NodeOrigin (NodeInfo a)) }
+ deriving (Functor, Foldable, Traversable)
+
+instance Binary (SourcedNodeInfo TypeIndex) where
+ put_ bh asts = put_ bh $ M.toAscList $ getSourcedNodeInfo asts
+ get bh = SourcedNodeInfo <$> fmap M.fromDistinctAscList (get bh)
+
+instance Outputable a => Outputable (SourcedNodeInfo a) where
+ ppr (SourcedNodeInfo asts) = M.foldrWithKey go "" asts
+ where
+ go k a rest = vcat $
+ [ "Source: " O.<> ppr k
+ , ppr a
+ , rest
+ ]
+
+-- | Source of node info
+data NodeOrigin
+ = SourceInfo
+ | GeneratedInfo
+ deriving (Eq, Enum, Ord)
+
+instance Outputable NodeOrigin where
+ ppr SourceInfo = text "From source"
+ ppr GeneratedInfo = text "generated by ghc"
+
+instance Binary NodeOrigin where
+ put_ bh b = putByte bh (fromIntegral (fromEnum b))
+ get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
+
-- | The information stored in one AST node.
--
-- The type parameter exists to provide flexibility in representation of types
@@ -314,7 +350,7 @@ instance Monoid (IdentifierDetails a) where
instance Binary (IdentifierDetails TypeIndex) where
put_ bh dets = do
put_ bh $ identType dets
- put_ bh $ S.toAscList $ identInfo dets
+ put_ bh $ S.toList $ identInfo dets
get bh = IdentifierDetails
<$> get bh
<*> fmap S.fromDistinctAscList (get bh)
@@ -363,6 +399,14 @@ data ContextInfo
-- | Record field
| RecField RecFieldContext (Maybe Span)
+ -- | Constraint/Dictionary evidence variable binding
+ | EvidenceVarBind
+ EvVarSource -- ^ how did this bind come into being
+ Scope -- ^ scope over which the value is bound
+ (Maybe Span) -- ^ span of the binding site
+
+ -- | Usage of evidence variable
+ | EvidenceVarUse
deriving (Eq, Ord)
instance Outputable ContextInfo where
@@ -385,10 +429,16 @@ instance Outputable ContextInfo where
<+> ppr sc1 <+> "," <+> ppr sc2
ppr (RecField ctx sp) =
text "record field" <+> ppr ctx <+> pprBindSpan sp
+ ppr (EvidenceVarBind ctx sc sp) =
+ text "evidence variable" <+> ppr ctx
+ $$ "with scope:" <+> ppr sc
+ $$ pprBindSpan sp
+ ppr (EvidenceVarUse) =
+ text "usage of evidence variable"
pprBindSpan :: Maybe Span -> SDoc
pprBindSpan Nothing = text ""
-pprBindSpan (Just sp) = text "at:" <+> ppr sp
+pprBindSpan (Just sp) = text "bound at:" <+> ppr sp
instance Binary ContextInfo where
put_ bh Use = putByte bh 0
@@ -422,6 +472,12 @@ instance Binary ContextInfo where
put_ bh a
put_ bh b
put_ bh MatchBind = putByte bh 9
+ put_ bh (EvidenceVarBind a b c) = do
+ putByte bh 10
+ put_ bh a
+ put_ bh b
+ put_ bh c
+ put_ bh EvidenceVarUse = putByte bh 11
get bh = do
(t :: Word8) <- get bh
@@ -436,8 +492,69 @@ instance Binary ContextInfo where
7 -> TyVarBind <$> get bh <*> get bh
8 -> RecField <$> get bh <*> get bh
9 -> return MatchBind
+ 10 -> EvidenceVarBind <$> get bh <*> get bh <*> get bh
+ 11 -> return EvidenceVarUse
_ -> panic "Binary ContextInfo: invalid tag"
+data EvVarSource
+ = EvPatternBind -- ^ bound by a pattern match
+ | EvSigBind -- ^ bound by a type signature
+ | EvWrapperBind -- ^ bound by a hswrapper
+ | EvImplicitBind -- ^ bound by an implicit variable
+ | EvInstBind { isSuperInst :: Bool, cls :: Name } -- ^ Bound by some instance of given class
+ | EvLetBind EvBindDeps -- ^ A direct let binding
+ deriving (Eq,Ord)
+
+instance Binary EvVarSource where
+ put_ bh EvPatternBind = putByte bh 0
+ put_ bh EvSigBind = putByte bh 1
+ put_ bh EvWrapperBind = putByte bh 2
+ put_ bh EvImplicitBind = putByte bh 3
+ put_ bh (EvInstBind b cls) = do
+ putByte bh 4
+ put_ bh b
+ put_ bh cls
+ put_ bh (EvLetBind deps) = do
+ putByte bh 5
+ put_ bh deps
+
+ get bh = do
+ (t :: Word8) <- get bh
+ case t of
+ 0 -> pure EvPatternBind
+ 1 -> pure EvSigBind
+ 2 -> pure EvWrapperBind
+ 3 -> pure EvImplicitBind
+ 4 -> EvInstBind <$> get bh <*> get bh
+ 5 -> EvLetBind <$> get bh
+ _ -> panic "Binary EvVarSource: invalid tag"
+
+instance Outputable EvVarSource where
+ ppr EvPatternBind = text "bound by a pattern"
+ ppr EvSigBind = text "bound by a type signature"
+ ppr EvWrapperBind = text "bound by a HsWrapper"
+ ppr EvImplicitBind = text "bound by an implicit variable binding"
+ ppr (EvInstBind False cls) = text "bound by an instance of class" <+> ppr cls
+ ppr (EvInstBind True cls) = text "bound due to a superclass of " <+> ppr cls
+ ppr (EvLetBind deps) = text "bound by a let, depending on:" <+> ppr deps
+
+-- | Eq/Ord instances compare on the converted HieName,
+-- as non-exported names may have different uniques after
+-- a roundtrip
+newtype EvBindDeps = EvBindDeps { getEvBindDeps :: [Name] }
+ deriving Outputable
+
+instance Eq EvBindDeps where
+ (==) = coerce ((==) `on` map toHieName)
+
+instance Ord EvBindDeps where
+ compare = coerce (compare `on` map toHieName)
+
+instance Binary EvBindDeps where
+ put_ bh (EvBindDeps xs) = put_ bh xs
+ get bh = EvBindDeps <$> get bh
+
+
-- | Types of imports and exports
data IEType
= Import
@@ -587,3 +704,46 @@ instance Binary TyVarScope where
0 -> ResolvedScopes <$> get bh
1 -> UnresolvedScope <$> get bh <*> get bh
_ -> panic "Binary TyVarScope: invalid tag"
+
+-- | `Name`'s get converted into `HieName`'s before being written into @.hie@
+-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
+-- these two types.
+data HieName
+ = ExternalName !Module !OccName !SrcSpan
+ | LocalName !OccName !SrcSpan
+ | KnownKeyName !Unique
+ deriving (Eq)
+
+instance Ord HieName where
+ compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) `thenCmp` leftmost_smallest c f
+ -- TODO (int-index): Perhaps use RealSrcSpan in HieName?
+ compare (LocalName a b) (LocalName c d) = compare a c `thenCmp` leftmost_smallest b d
+ -- TODO (int-index): Perhaps use RealSrcSpan in HieName?
+ compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
+ -- Not actually non deterministic as it is a KnownKey
+ compare ExternalName{} _ = LT
+ compare LocalName{} ExternalName{} = GT
+ compare LocalName{} _ = LT
+ compare KnownKeyName{} _ = GT
+
+instance Outputable HieName where
+ ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp
+ ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
+ ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
+
+hieNameOcc :: HieName -> OccName
+hieNameOcc (ExternalName _ occ _) = occ
+hieNameOcc (LocalName occ _) = occ
+hieNameOcc (KnownKeyName u) =
+ case lookupKnownKeyName u of
+ Just n -> nameOccName n
+ Nothing -> pprPanic "hieNameOcc:unknown known-key unique"
+ (ppr (unpkUnique u))
+
+toHieName :: Name -> HieName
+toHieName name
+ | isKnownKeyName name = KnownKeyName (nameUnique name)
+ | isExternalName name = ExternalName (nameModule name)
+ (nameOccName name)
+ (nameSrcSpan name)
+ | otherwise = LocalName (nameOccName name) (nameSrcSpan name)
=====================================
compiler/GHC/Iface/Ext/Utils.hs
=====================================
@@ -1,7 +1,9 @@
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveFunctor #-}
module GHC.Iface.Ext.Utils where
import GHC.Prelude
@@ -11,7 +13,9 @@ import GHC.Driver.Session ( DynFlags )
import GHC.Data.FastString ( FastString, mkFastString )
import GHC.Iface.Type
import GHC.Types.Name hiding (varName)
-import GHC.Utils.Outputable ( renderWithStyle, ppr, defaultUserStyle, initSDocContext )
+import GHC.Types.Name.Set
+import GHC.Utils.Outputable hiding ( (<>) )
+import qualified GHC.Utils.Outputable as O
import GHC.Types.SrcLoc
import GHC.CoreToIface
import GHC.Core.TyCon
@@ -27,21 +31,26 @@ import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
import qualified Data.Array as A
import Data.Data ( typeOf, typeRepTyCon, Data(toConstr) )
-import Data.Maybe ( maybeToList )
+import Data.Maybe ( maybeToList, mapMaybe)
import Data.Monoid
+import Data.List (find)
import Data.Traversable ( for )
+import Data.Coerce
import Control.Monad.Trans.State.Strict hiding (get)
+import Control.Monad.Trans.Reader
+import qualified Data.Tree as Tree
+type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)]
generateReferencesMap
:: Foldable f
=> f (HieAST a)
- -> M.Map Identifier [(Span, IdentifierDetails a)]
+ -> RefMap a
generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty
where
go ast = M.unionsWith (++) (this : map go (nodeChildren ast))
where
- this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast
+ this = fmap (pure . (nodeSpan ast,)) $ sourcedNodeIdents $ sourcedNodeInfo ast
renderHieType :: DynFlags -> HieTypeFix -> String
renderHieType dflags ht = renderWithStyle (initSDocContext dflags defaultUserStyle) (ppr $ hieTypeToIface ht)
@@ -72,6 +81,73 @@ resolveVisibility kind ty_args
foldType :: (HieType a -> a) -> HieTypeFix -> a
foldType f (Roll t) = f $ fmap (foldType f) t
+selectPoint :: HieFile -> (Int,Int) -> Maybe (HieAST Int)
+selectPoint hf (sl,sc) = getFirst $
+ flip foldMap (M.toList (getAsts $ hie_asts hf)) $ \(fs,ast) -> First $
+ case selectSmallestContaining (sp fs) ast of
+ Nothing -> Nothing
+ Just ast' -> Just ast'
+ where
+ sloc fs = mkRealSrcLoc fs sl sc
+ sp fs = mkRealSrcSpan (sloc fs) (sloc fs)
+
+findEvidenceUse :: NodeIdentifiers a -> [Name]
+findEvidenceUse ni = [n | (Right n, dets) <- xs, any isEvidenceUse (identInfo dets)]
+ where
+ xs = M.toList ni
+
+data EvidenceInfo a
+ = EvidenceInfo
+ { evidenceVar :: Name
+ , evidenceSpan :: RealSrcSpan
+ , evidenceType :: a
+ , evidenceDetails :: Maybe (EvVarSource, Scope, Maybe Span)
+ } deriving (Eq,Ord,Functor)
+
+instance (Outputable a) => Outputable (EvidenceInfo a) where
+ ppr (EvidenceInfo name span typ dets) =
+ hang (ppr name <+> text "at" <+> ppr span O.<> text ", of type:" <+> ppr typ) 4 $
+ pdets $$ (pprDefinedAt name)
+ where
+ pdets = case dets of
+ Nothing -> text "is a usage of an external evidence variable"
+ Just (src,scp,spn) -> text "is an" <+> ppr (EvidenceVarBind src scp spn)
+
+getEvidenceTreesAtPoint :: HieFile -> RefMap a -> (Int,Int) -> Tree.Forest (EvidenceInfo a)
+getEvidenceTreesAtPoint hf refmap point =
+ [t | Just ast <- pure $ selectPoint hf point
+ , n <- findEvidenceUse (sourcedNodeIdents $ sourcedNodeInfo ast)
+ , Just t <- pure $ getEvidenceTree refmap n
+ ]
+
+getEvidenceTree :: RefMap a -> Name -> Maybe (Tree.Tree (EvidenceInfo a))
+getEvidenceTree refmap var = go emptyNameSet var
+ where
+ go seen var
+ | var `elemNameSet` seen = Nothing
+ | otherwise = do
+ xs <- M.lookup (Right var) refmap
+ case find (any isEvidenceBind . identInfo . snd) xs of
+ Just (sp,dets) -> do
+ typ <- identType dets
+ (evdet,children) <- getFirst $ foldMap First $ do
+ det <- S.toList $ identInfo dets
+ case det of
+ EvidenceVarBind src@(EvLetBind (getEvBindDeps -> xs)) scp spn ->
+ pure $ Just ((src,scp,spn),mapMaybe (go $ extendNameSet seen var) xs)
+ EvidenceVarBind src scp spn -> pure $ Just ((src,scp,spn),[])
+ _ -> pure Nothing
+ pure $ Tree.Node (EvidenceInfo var sp typ (Just evdet)) children
+ -- It is externally bound
+ Nothing -> getFirst $ foldMap First $ do
+ (sp,dets) <- xs
+ if (any isEvidenceUse $ identInfo dets)
+ then do
+ case identType dets of
+ Nothing -> pure Nothing
+ Just typ -> pure $ Just $ Tree.Node (EvidenceInfo var sp typ Nothing) []
+ else pure Nothing
+
hieTypeToIface :: HieTypeFix -> IfaceType
hieTypeToIface = foldType go
where
@@ -194,8 +270,10 @@ resolveTyVarScopeLocal ast asts = go ast
resolveScope scope = scope
go (Node info span children) = Node info' span $ map go children
where
- info' = info { nodeIdentifiers = idents }
- idents = M.map resolveNameScope $ nodeIdentifiers info
+ info' = SourcedNodeInfo (updateNodeInfo <$> getSourcedNodeInfo info)
+ updateNodeInfo i = i { nodeIdentifiers = idents }
+ where
+ idents = M.map resolveNameScope $ nodeIdentifiers i
getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span
getNameBinding n asts = do
@@ -217,7 +295,7 @@ getNameBindingInClass n sp asts = do
getFirst $ foldMap First $ do
child <- flattenAst ast
dets <- maybeToList
- $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo child
+ $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo child
let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
return (getFirst binding)
@@ -232,7 +310,7 @@ getNameScopeAndBinding n asts = case nameSrcSpan n of
getFirst $ foldMap First $ do -- @[]
node <- flattenAst defNode
dets <- maybeToList
- $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo node
+ $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo node
scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets)
let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
return $ Just (scopes, getFirst binding)
@@ -245,6 +323,7 @@ getScopeFromContext (ClassTyDecl _) = Just [ModuleScope]
getScopeFromContext (Decl _ _) = Just [ModuleScope]
getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs
getScopeFromContext (TyVarBind a _) = Just [a]
+getScopeFromContext (EvidenceVarBind _ a _) = Just [a]
getScopeFromContext _ = Nothing
getBindSiteFromContext :: ContextInfo -> Maybe Span
@@ -292,8 +371,27 @@ definedInAsts asts n = case nameSrcSpan n of
RealSrcSpan sp _ -> srcSpanFile sp `elem` M.keys asts
_ -> False
+getEvidenceBindDeps :: ContextInfo -> [Name]
+getEvidenceBindDeps (EvidenceVarBind (EvLetBind xs) _ _) =
+ getEvBindDeps xs
+getEvidenceBindDeps _ = []
+
+isEvidenceBind :: ContextInfo -> Bool
+isEvidenceBind EvidenceVarBind{} = True
+isEvidenceBind _ = False
+
+isEvidenceContext :: ContextInfo -> Bool
+isEvidenceContext EvidenceVarUse = True
+isEvidenceContext EvidenceVarBind{} = True
+isEvidenceContext _ = False
+
+isEvidenceUse :: ContextInfo -> Bool
+isEvidenceUse EvidenceVarUse = True
+isEvidenceUse _ = False
+
isOccurrence :: ContextInfo -> Bool
isOccurrence Use = True
+isOccurrence EvidenceVarUse = True
isOccurrence _ = False
scopeContainsSpan :: Scope -> Span -> Bool
@@ -304,7 +402,7 @@ scopeContainsSpan (LocalScope a) b = a `containsSpan` b
-- | One must contain the other. Leaf nodes cannot contain anything
combineAst :: HieAST Type -> HieAST Type -> HieAST Type
combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys)
- | aSpn == bSpn = Node (aInf `combineNodeInfo` bInf) aSpn (mergeAsts xs ys)
+ | aSpn == bSpn = Node (aInf `combineSourcedNodeInfo` bInf) aSpn (mergeAsts xs ys)
| aSpn `containsSpan` bSpn = combineAst b a
combineAst a (Node xs span children) = Node xs span (insertAst a children)
@@ -312,6 +410,18 @@ combineAst a (Node xs span children) = Node xs span (insertAst a children)
insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type]
insertAst x = mergeAsts [x]
+nodeInfo :: HieAST Type -> NodeInfo Type
+nodeInfo = foldl' combineNodeInfo emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo
+
+emptyNodeInfo :: NodeInfo a
+emptyNodeInfo = NodeInfo S.empty [] M.empty
+
+sourcedNodeIdents :: SourcedNodeInfo a -> NodeIdentifiers a
+sourcedNodeIdents = M.unionsWith (<>) . fmap nodeIdentifiers . getSourcedNodeInfo
+
+combineSourcedNodeInfo :: SourcedNodeInfo Type -> SourcedNodeInfo Type -> SourcedNodeInfo Type
+combineSourcedNodeInfo = coerce $ M.unionWith combineNodeInfo
+
-- | Merge two nodes together.
--
-- Precondition and postcondition: elements in 'nodeType' are ordered.
@@ -404,11 +514,12 @@ mergeSortAsts = go . map pure
simpleNodeInfo :: FastString -> FastString -> NodeInfo a
simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty
-locOnly :: SrcSpan -> [HieAST a]
-locOnly (RealSrcSpan span _) =
- [Node e span []]
- where e = NodeInfo S.empty [] M.empty
-locOnly _ = []
+locOnly :: Monad m => SrcSpan -> ReaderT NodeOrigin m [HieAST a]
+locOnly (RealSrcSpan span _) = do
+ org <- ask
+ let e = mkSourcedNodeInfo org $ emptyNodeInfo
+ pure [Node e span []]
+locOnly _ = pure []
mkScope :: SrcSpan -> Scope
mkScope (RealSrcSpan sp _) = LocalScope sp
@@ -425,30 +536,37 @@ combineScopes x NoScope = x
combineScopes (LocalScope a) (LocalScope b) =
mkScope $ combineSrcSpans (RealSrcSpan a Nothing) (RealSrcSpan b Nothing)
+mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a
+mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni
+
{-# INLINEABLE makeNode #-}
makeNode
- :: (Applicative m, Data a)
+ :: (Monad m, Data a)
=> a -- ^ helps fill in 'nodeAnnotations' (with 'Data')
-> SrcSpan -- ^ return an empty list if this is unhelpful
- -> m [HieAST b]
-makeNode x spn = pure $ case spn of
- RealSrcSpan span _ -> [Node (simpleNodeInfo cons typ) span []]
- _ -> []
+ -> ReaderT NodeOrigin m [HieAST b]
+makeNode x spn = do
+ org <- ask
+ pure $ case spn of
+ RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []]
+ _ -> []
where
cons = mkFastString . show . toConstr $ x
typ = mkFastString . show . typeRepTyCon . typeOf $ x
{-# INLINEABLE makeTypeNode #-}
makeTypeNode
- :: (Applicative m, Data a)
+ :: (Monad m, Data a)
=> a -- ^ helps fill in 'nodeAnnotations' (with 'Data')
-> SrcSpan -- ^ return an empty list if this is unhelpful
-> Type -- ^ type to associate with the node
- -> m [HieAST Type]
-makeTypeNode x spn etyp = pure $ case spn of
- RealSrcSpan span _ ->
- [Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]
- _ -> []
+ -> ReaderT NodeOrigin m [HieAST Type]
+makeTypeNode x spn etyp = do
+ org <- ask
+ pure $ case spn of
+ RealSrcSpan span _ ->
+ [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]
+ _ -> []
where
cons = mkFastString . show . toConstr $ x
typ = mkFastString . show . typeRepTyCon . typeOf $ x
=====================================
compiler/GHC/Unit.hs
=====================================
@@ -21,237 +21,334 @@ import GHC.Unit.State
import GHC.Unit.Subst
import GHC.Unit.Module
--- Note [About Units]
--- ~~~~~~~~~~~~~~~~~~
---
--- Haskell users are used to manipulate Cabal packages. These packages are
--- identified by:
--- - a package name :: String
--- - a package version :: Version
--- - (a revision number, when they are registered on Hackage)
---
--- Cabal packages may contain several components (libraries, programs,
--- testsuites). In GHC we are mostly interested in libraries because those are
--- the components that can be depended upon by other components. Components in a
--- package are identified by their component name. Historically only one library
--- component was allowed per package, hence it didn't need a name. For this
--- reason, component name may be empty for one library component in each
--- package:
--- - a component name :: Maybe String
---
--- UnitId
--- ------
---
--- Cabal libraries can be compiled in various ways (different compiler options
--- or Cabal flags, different dependencies, etc.), hence using package name,
--- package version and component name isn't enough to identify a built library.
--- We use another identifier called UnitId:
---
--- package name \
--- package version | ________
--- component name | hash of all this ==> | UnitId |
--- Cabal flags | --------
--- compiler options |
--- dependencies' UnitId /
---
--- Fortunately GHC doesn't have to generate these UnitId: they are provided by
--- external build tools (e.g. Cabal) with `-this-unit-id` command-line parameter.
---
--- UnitIds are important because they are used to generate internal names
--- (symbols, etc.).
---
--- Wired-in units
--- --------------
---
--- Certain libraries are known to the compiler, in that we know about certain
--- entities that reside in these libraries. The compiler needs to declare static
--- Modules and Names that refer to units built from these libraries.
---
--- Hence UnitIds of wired-in libraries are fixed. Instead of letting Cabal chose
--- the UnitId for these libraries, their .cabal file uses the following stanza to
--- force it to a specific value:
---
--- ghc-options: -this-unit-id ghc-prim -- taken from ghc-prim.cabal
---
--- The RTS also uses entities of wired-in units by directly referring to symbols
--- such as "base_GHCziIOziException_heapOverflow_closure" where the prefix is
--- the UnitId of "base" unit.
---
--- Unit databases
--- --------------
---
--- Units are stored in databases in order to be reused by other codes:
---
--- UnitKey ---> UnitInfo { exposed modules, package name, package version
--- component name, various file paths,
--- dependencies :: [UnitKey], etc. }
---
--- Because of the wired-in units described above, we can't exactly use UnitIds
--- as UnitKeys in the database: if we did this, we could only have a single unit
--- (compiled library) in the database for each wired-in library. As we want to
--- support databases containing several different units for the same wired-in
--- library, we do this:
---
--- * for non wired-in units:
--- * UnitId = UnitKey = Identifier (hash) computed by Cabal
---
--- * for wired-in units:
--- * UnitKey = Identifier computed by Cabal (just like for non wired-in units)
--- * UnitId = unit-id specified with -this-unit-id command-line flag
---
--- We can expose several units to GHC via the `package-id <UnitKey>`
--- command-line parameter. We must use the UnitKeys of the units so that GHC can
--- find them in the database.
---
--- GHC then replaces the UnitKeys with UnitIds by taking into account wired-in
--- units: these units are detected thanks to their UnitInfo (especially their
--- package name).
---
--- For example, knowing that "base", "ghc-prim" and "rts" are wired-in packages,
--- the following dependency graph expressed with UnitKeys (as found in the
--- database) will be transformed into a similar graph expressed with UnitIds
--- (that are what matters for compilation):
---
--- UnitKeys
--- ~~~~~~~~ ---> rts-1.0-hashABC <--
--- | |
--- | |
--- foo-2.0-hash123 --> base-4.1-hashXYZ ---> ghc-prim-0.5.3-hashABC
---
--- UnitIds
--- ~~~~~~~ ---> rts <--
--- | |
--- | |
--- foo-2.0-hash123 --> base ---------------> ghc-prim
---
---
--- Module signatures / indefinite units / instantiated units
--- ---------------------------------------------------------
---
--- GHC distinguishes two kinds of units:
---
--- * definite: units for which every module has an associated code object
--- (i.e. real compiled code in a .o/.a/.so/.dll/...)
---
--- * indefinite: units for which some modules are replaced by module
--- signatures.
---
--- Module signatures are a kind of interface (similar to .hs-boot files). They
--- are used in place of some real code. GHC allows real modules from other
--- units to be used to fill these module holes. The process is called
--- "unit/module instantiation".
---
--- You can think of this as polymorphism at the module level: module signatures
--- give constraints on the "type" of module that can be used to fill the hole
--- (where "type" means types of the exported module entitites, etc.).
---
--- Module signatures contain enough information (datatypes, abstract types, type
--- synonyms, classes, etc.) to typecheck modules depending on them but not
--- enough to compile them. As such, indefinite units found in databases only
--- provide module interfaces (the .hi ones this time), not object code.
---
--- To distinguish between indefinite and finite unit ids at the type level, we
--- respectively use 'IndefUnitId' and 'DefUnitId' datatypes that are basically
--- wrappers over 'UnitId'.
---
--- Unit instantiation
--- ------------------
---
--- Indefinite units can be instantiated with modules from other units. The
--- instantiating units can also be instantiated themselves (if there are
--- indefinite) and so on. The 'Unit' datatype represents a unit which may have
--- been instantiated:
---
--- data Unit = RealUnit DefUnitId
--- | VirtUnit InstantiatedUnit
---
--- 'InstantiatedUnit' has two interesting fields:
---
--- * instUnitInstanceOf :: IndefUnitId
--- -- ^ the indefinite unit that is instantiated
---
--- * instUnitInsts :: [(ModuleName,(Unit,ModuleName)]
--- -- ^ a list of instantiations, where an instantiation is:
--- (module hole name, (instantiating unit, instantiating module name))
---
--- A 'Unit' may be indefinite or definite, it depends on whether some holes
--- remain in the instantiated unit OR in the instantiating units (recursively).
---
--- Pretty-printing UnitId
--- ----------------------
---
--- GHC mostly deals with UnitIds which are some opaque strings. We could display
--- them when we pretty-print a module origin, a name, etc. But it wouldn't be
--- very friendly to the user because of the hash they usually contain. E.g.
---
--- foo-4.18.1:thelib-XYZsomeUglyHashABC
---
--- Instead when we want to pretty-print a 'UnitId' we query the database to
--- get the 'UnitInfo' and print something nicer to the user:
---
--- foo-4.18.1:thelib
---
--- We do the same for wired-in units.
---
--- Currently (2020-04-06), we don't thread the database into every function that
--- pretty-prints a Name/Module/Unit. Instead querying the database is delayed
--- until the `SDoc` is transformed into a `Doc` using the database that is
--- active at this point in time. This is an issue because we want to be able to
--- unload units from the database and we also want to support several
--- independent databases loaded at the same time (see #14335). The alternatives
--- we have are:
---
--- * threading the database into every function that pretty-prints a UnitId
--- for the user (directly or indirectly).
---
--- * storing enough info to correctly display a UnitId into the UnitId
--- datatype itself. This is done in the IndefUnitId wrapper (see
--- 'UnitPprInfo' datatype) but not for every 'UnitId'. Statically defined
--- 'UnitId' for wired-in units would have empty UnitPprInfo so we need to
--- find some places to update them if we want to display wired-in UnitId
--- correctly. This leads to a solution similar to the first one above.
---
--- Note [VirtUnit to RealUnit improvement]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- Over the course of instantiating VirtUnits on the fly while typechecking an
--- indefinite library, we may end up with a fully instantiated VirtUnit. I.e.
--- one that could be compiled and installed in the database. During
--- type-checking we generate a virtual UnitId for it, say "abc".
---
--- Now the question is: do we have a matching installed unit in the database?
--- Suppose we have one with UnitId "xyz" (provided by Cabal so we don't know how
--- to generate it). The trouble is that if both units end up being used in the
--- same type-checking session, their names won't match (e.g. "abc:M.X" vs
--- "xyz:M.X").
---
--- As we want them to match we just replace the virtual unit with the installed
--- one: for some reason this is called "improvement".
---
--- There is one last niggle: improvement based on the package database means
--- that we might end up developing on a package that is not transitively
--- depended upon by the packages the user specified directly via command line
--- flags. This could lead to strange and difficult to understand bugs if those
--- instantiations are out of date. The solution is to only improve a
--- unit id if the new unit id is part of the 'preloadClosure'; i.e., the
--- closure of all the packages which were explicitly specified.
-
--- Note [Representation of module/name variables]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- In our ICFP'16, we use <A> to represent module holes, and {A.T} to represent
--- name holes. This could have been represented by adding some new cases
--- to the core data types, but this would have made the existing 'moduleName'
--- and 'moduleUnit' partial, which would have required a lot of modifications
--- to existing code.
---
--- Instead, we use a fake "hole" unit:
---
--- <A> ===> hole:A
--- {A.T} ===> hole:A.T
---
--- This encoding is quite convenient, but it is also a bit dangerous too,
--- because if you have a 'hole:A' you need to know if it's actually a
--- 'Module' or just a module stored in a 'Name'; these two cases must be
--- treated differently when doing substitutions. 'renameHoleModule'
--- and 'renameHoleUnit' assume they are NOT operating on a
--- 'Name'; 'NameShape' handles name substitutions exclusively.
+{-
+
+Note [About Units]
+~~~~~~~~~~~~~~~~~~
+
+Haskell users are used to manipulate Cabal packages. These packages are
+identified by:
+ - a package name :: String
+ - a package version :: Version
+ - (a revision number, when they are registered on Hackage)
+
+Cabal packages may contain several components (libraries, programs,
+testsuites). In GHC we are mostly interested in libraries because those are
+the components that can be depended upon by other components. Components in a
+package are identified by their component name. Historically only one library
+component was allowed per package, hence it didn't need a name. For this
+reason, component name may be empty for one library component in each
+package:
+ - a component name :: Maybe String
+
+UnitId
+------
+
+Cabal libraries can be compiled in various ways (different compiler options
+or Cabal flags, different dependencies, etc.), hence using package name,
+package version and component name isn't enough to identify a built library.
+We use another identifier called UnitId:
+
+ package name \
+ package version | ________
+ component name | hash of all this ==> | UnitId |
+ Cabal flags | --------
+ compiler options |
+ dependencies' UnitId /
+
+Fortunately GHC doesn't have to generate these UnitId: they are provided by
+external build tools (e.g. Cabal) with `-this-unit-id` command-line parameter.
+
+UnitIds are important because they are used to generate internal names
+(symbols, etc.).
+
+Wired-in units
+--------------
+
+Certain libraries (ghc-prim, base, etc.) are known to the compiler and to the
+RTS as they provide some basic primitives. Hence UnitIds of wired-in libraries
+are fixed. Instead of letting Cabal chose the UnitId for these libraries, their
+.cabal file uses the following stanza to force it to a specific value:
+
+ ghc-options: -this-unit-id ghc-prim -- taken from ghc-prim.cabal
+
+The RTS also uses entities of wired-in units by directly referring to symbols
+such as "base_GHCziIOziException_heapOverflow_closure" where the prefix is
+the UnitId of "base" unit.
+
+Unit databases
+--------------
+
+Units are stored in databases in order to be reused by other codes:
+
+ UnitKey ---> UnitInfo { exposed modules, package name, package version
+ component name, various file paths,
+ dependencies :: [UnitKey], etc. }
+
+Because of the wired-in units described above, we can't exactly use UnitIds
+as UnitKeys in the database: if we did this, we could only have a single unit
+(compiled library) in the database for each wired-in library. As we want to
+support databases containing several different units for the same wired-in
+library, we do this:
+
+ * for non wired-in units:
+ * UnitId = UnitKey = Identifier (hash) computed by Cabal
+
+ * for wired-in units:
+ * UnitKey = Identifier computed by Cabal (just like for non wired-in units)
+ * UnitId = unit-id specified with -this-unit-id command-line flag
+
+We can expose several units to GHC via the `package-id <unit-key>` command-line
+parameter. We must use the UnitKeys of the units so that GHC can find them in
+the database.
+
+During unit loading, GHC replaces UnitKeys with UnitIds. It identifies wired
+units by their package name (stored in their UnitInfo) and uses wired-in UnitIds
+for them.
+
+For example, knowing that "base", "ghc-prim" and "rts" are wired-in units, the
+following dependency graph expressed with database UnitKeys will be transformed
+into a similar graph expressed with UnitIds:
+
+ UnitKeys
+ ~~~~~~~~ ----------> rts-1.0-hashABC <--
+ | |
+ | |
+ foo-2.0-hash123 --> base-4.1-hashXYZ ---> ghc-prim-0.5.3-hashUVW
+
+ UnitIds
+ ~~~~~~~ ---------------> rts <--
+ | |
+ | |
+ foo-2.0-hash123 --> base ---------------> ghc-prim
+
+
+Note that "foo-2.0-hash123" isn't wired-in so its UnitId is the same as its UnitKey.
+
+
+Module signatures / indefinite units / instantiated units
+---------------------------------------------------------
+
+GHC distinguishes two kinds of units:
+
+ * definite units:
+ * units without module holes and with definite dependencies
+ * can be compiled into machine code (.o/.a/.so/.dll/...)
+
+ * indefinite units:
+ * units with some module holes or with some indefinite dependencies
+ * can only be type-checked
+
+Module holes are constrained by module signatures (.hsig files). Module
+signatures are a kind of interface (similar to .hs-boot files). They are used in
+place of some real code. GHC allows modules from other units to be used to fill
+these module holes: the process is called "unit/module instantiation". The
+instantiating module may either be a concrete module or a module signature. In
+the latter case, the signatures are merged to form a new one.
+
+You can think of this as polymorphism at the module level: module signatures
+give constraints on the "type" of module that can be used to fill the hole
+(where "type" means types of the exported module entitites, etc.).
+
+Module signatures contain enough information (datatypes, abstract types, type
+synonyms, classes, etc.) to typecheck modules depending on them but not
+enough to compile them. As such, indefinite units found in databases only
+provide module interfaces (the .hi ones this time), not object code.
+
+To distinguish between indefinite and definite unit ids at the type level, we
+respectively use 'IndefUnitId' and 'DefUnitId' datatypes that are basically
+wrappers over 'UnitId'.
+
+Unit instantiation / on-the-fly instantiation
+---------------------------------------------
+
+Indefinite units can be instantiated with modules from other units. The
+instantiating units can also be instantiated themselves (if there are
+indefinite) and so on.
+
+On-the-fly unit instantiation is a tricky optimization explained in
+http://blog.ezyang.com/2016/08/optimizing-incremental-compilation
+Here is a summary:
+
+ 1. Indefinite units can only be type-checked, not compiled into real code.
+ Type-checking produces interface files (.hi) which are incomplete for code
+ generation (they lack unfoldings, etc.) but enough to perform type-checking
+ of units depending on them.
+
+ 2. Type-checking an instantiated unit is cheap as we only have to merge
+ interface files (.hi) of the instantiated unit and of the instantiating
+ units, hence it can be done on-the-fly. Interface files of the dependencies
+ can be concrete or produced on-the-fly recursively.
+
+ 3. When we compile a unit, we mustn't use interfaces produced by the
+ type-checker (on-the-fly or not) for the instantiated unit dependencies
+ because they lack some information.
+
+ 4. When we type-check an indefinite unit, we must be consistent about the
+ interfaces we use for each dependency: only those produced by the
+ type-checker (on-the-fly or not) or only those produced after a full
+ compilation, but not both at the same time.
+
+ It can be tricky if we have the following kind of dependency graph:
+
+ X (indefinite) ------> D (definite, compiled) -----> I (instantiated, definite, compiled)
+ |----------------------------------------------------^
+
+ Suppose we want to type-check unit X which depends on unit I and D:
+ * I is definite and compiled: we have compiled .hi files for its modules on disk
+ * I is instantiated: it is cheap to produce type-checker .hi files for its modules on-the-fly
+
+ But we must not do:
+
+ X (indefinite) ------> D (definite, compiled) -----> I (instantiated, definite, compiled)
+ |--------------------------------------------------> I (instantiated on-the-fly)
+
+ ==> inconsistent module interfaces for I
+
+ Nor:
+
+ X (indefinite) ------> D (definite, compiled) -------v
+ |--------------------------------------------------> I (instantiated on-the-fly)
+
+ ==> D's interfaces may refer to things that only exist in I's *compiled* interfaces
+
+ An alternative would be to store both type-checked and compiled interfaces
+ for every compiled non-instantiated unit (instantiated unit can be done
+ on-the-fly) so that we could use type-checked interfaces of D in the
+ example above. But it would increase compilation time and unit size.
+
+
+The 'Unit' datatype represents a unit which may have been instantiated
+on-the-fly:
+
+ data Unit = RealUnit DefUnitId -- use compiled interfaces on disk
+ | VirtUnit InstantiatedUnit -- use on-the-fly instantiation
+
+'InstantiatedUnit' has two interesting fields:
+
+ * instUnitInstanceOf :: IndefUnitId
+ -- ^ the indefinite unit that is instantiated
+
+ * instUnitInsts :: [(ModuleName,(Unit,ModuleName)]
+ -- ^ a list of instantiations, where an instantiation is:
+ (module hole name, (instantiating unit, instantiating module name))
+
+A 'VirtUnit' may be indefinite or definite, it depends on whether some holes
+remain in the instantiated unit OR in the instantiating units (recursively).
+Having a fully instantiated (i.e. definite) virtual unit can lead to some issues
+if there is a matching compiled unit in the preload closure. See Note [VirtUnit
+to RealUnit improvement]
+
+Unit database and indefinite units
+----------------------------------
+
+We don't store partially instantiated units in the unit database. Units in the
+database are either:
+
+ * definite (fully instantiated or without holes): in this case we have
+ *compiled* module interfaces (.hi) and object codes (.o/.a/.so/.dll/...).
+
+ * fully indefinite (not instantiated at all): in this case we only have
+ *type-checked* module interfaces (.hi).
+
+Note that indefinite units are stored as an instantiation of themselves where
+each instantiating module is a module variable (see Note [Representation of
+module/name variables]). E.g.
+
+ "xyz" (UnitKey) ---> UnitInfo { instanceOf = "xyz"
+ , instantiatedWith = [A=<A>,B=<B>...]
+ , ...
+ }
+
+Note that non-instantiated units are also stored as an instantiation of
+themselves. It is a reminiscence of previous terminology (when "instanceOf" was
+"componentId"). E.g.
+
+ "xyz" (UnitKey) ---> UnitInfo { instanceOf = "xyz"
+ , instantiatedWith = []
+ , ...
+ }
+
+TODO: We should probably have `instanceOf :: Maybe IndefUnitId` instead.
+
+
+Pretty-printing UnitId
+----------------------
+
+GHC mostly deals with UnitIds which are some opaque strings. We could display
+them when we pretty-print a module origin, a name, etc. But it wouldn't be
+very friendly to the user because of the hash they usually contain. E.g.
+
+ foo-4.18.1:thelib-XYZsomeUglyHashABC
+
+Instead when we want to pretty-print a 'UnitId' we query the database to
+get the 'UnitInfo' and print something nicer to the user:
+
+ foo-4.18.1:thelib
+
+We do the same for wired-in units.
+
+Currently (2020-04-06), we don't thread the database into every function that
+pretty-prints a Name/Module/Unit. Instead querying the database is delayed
+until the `SDoc` is transformed into a `Doc` using the database that is
+active at this point in time. This is an issue because we want to be able to
+unload units from the database and we also want to support several
+independent databases loaded at the same time (see #14335). The alternatives
+we have are:
+
+ * threading the database into every function that pretty-prints a UnitId
+ for the user (directly or indirectly).
+
+ * storing enough info to correctly display a UnitId into the UnitId
+ datatype itself. This is done in the IndefUnitId wrapper (see
+ 'UnitPprInfo' datatype) but not for every 'UnitId'. Statically defined
+ 'UnitId' for wired-in units would have empty UnitPprInfo so we need to
+ find some places to update them if we want to display wired-in UnitId
+ correctly. This leads to a solution similar to the first one above.
+
+Note [VirtUnit to RealUnit improvement]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Over the course of instantiating VirtUnits on the fly while typechecking an
+indefinite library, we may end up with a fully instantiated VirtUnit. I.e.
+one that could be compiled and installed in the database. During
+type-checking we generate a virtual UnitId for it, say "abc".
+
+Now the question is: do we have a matching installed unit in the database?
+Suppose we have one with UnitId "xyz" (provided by Cabal so we don't know how
+to generate it). The trouble is that if both units end up being used in the
+same type-checking session, their names won't match (e.g. "abc:M.X" vs
+"xyz:M.X").
+
+As we want them to match we just replace the virtual unit with the installed
+one: for some reason this is called "improvement".
+
+There is one last niggle: improvement based on the unit database means
+that we might end up developing on a unit that is not transitively
+depended upon by the units the user specified directly via command line
+flags. This could lead to strange and difficult to understand bugs if those
+instantiations are out of date. The solution is to only improve a
+unit id if the new unit id is part of the 'preloadClosure'; i.e., the
+closure of all the units which were explicitly specified.
+
+Note [Representation of module/name variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In our ICFP'16, we use <A> to represent module holes, and {A.T} to represent
+name holes. This could have been represented by adding some new cases
+to the core data types, but this would have made the existing 'moduleName'
+and 'moduleUnit' partial, which would have required a lot of modifications
+to existing code.
+
+Instead, we use a fake "hole" unit:
+
+ <A> ===> hole:A
+ {A.T} ===> hole:A.T
+
+This encoding is quite convenient, but it is also a bit dangerous too,
+because if you have a 'hole:A' you need to know if it's actually a
+'Module' or just a module stored in a 'Name'; these two cases must be
+treated differently when doing substitutions. 'renameHoleModule'
+and 'renameHoleUnit' assume they are NOT operating on a
+'Name'; 'NameShape' handles name substitutions exclusively.
+
+-}
=====================================
docs/users_guide/using-optimisation.rst
=====================================
@@ -655,14 +655,15 @@ by saying ``-fno-wombat``.
Sets the maximal number of iterations for the simplifier.
.. ghc-flag:: -fmax-worker-args=⟨n⟩
- :shortdesc: *default: 10.* If a worker has that many arguments, none will
- be unpacked anymore.
+ :shortdesc: *default: 10.* Maximum number of value arguments for a worker.
:type: dynamic
:category:
:default: 10
- If a worker has that many arguments, none will be unpacked anymore.
+ A function will not be split into worker and wrapper if the number of
+ value arguments of the resulting worker exceeds both that of the original
+ function and this setting.
.. ghc-flag:: -fno-opt-coercion
:shortdesc: Turn off the coercion optimiser
=====================================
testsuite/tests/hiefile/should_compile/Scopes.hs
=====================================
@@ -1,10 +1,33 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
+{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE RecordWildCards #-}
module Scopes where
+
+-- Verify that evidence bound by patern
+-- synonyms has correct scope
+pattern LL :: Num a => a -> a
+pattern LL x <- (subtract 1 -> x)
+ where
+ LL x = x + 1
+
data T = C { x :: Int, y :: Char }
--- Verify that names generated from record construction are in scope
+-- Verify that names generated from record construction
+-- have correct scope
foo = C { x = 1 , y = 'a' }
+-- Verify that implicit paramters have correct scope
+bar :: (?x :: Int) => Int
+bar = ?x + 1
+
+baz :: Int
+baz = bar + ?x
+ where ?x = 2
+
+-- Verify that variables bound in pattern
+-- synonyms have the correct scope
+pattern A a b = (a , b)
+
-- Verify that record wildcards are in scope
sdaf :: T
sdaf = C{..}
=====================================
testsuite/tests/hiefile/should_run/HieQueries.hs
=====================================
@@ -0,0 +1,82 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Main where
+
+import System.Environment
+
+import GHC.Types.Name.Cache
+import GHC.Types.SrcLoc
+import GHC.Types.Unique.Supply
+import GHC.Types.Name
+import Data.Tree
+import GHC.Iface.Ext.Binary
+import GHC.Iface.Ext.Types
+import GHC.Iface.Ext.Utils
+import Data.Maybe (fromJust)
+import GHC.Driver.Session
+import GHC.SysTools
+import GHC.Utils.Outputable ( Outputable, renderWithStyle, ppr, defaultUserStyle, initSDocContext, text)
+import qualified Data.Map as M
+import Data.Foldable
+
+class C a where
+ f :: a -> Char
+
+instance C Char where
+ f x = x
+
+instance C a => C [a] where
+ f x = 'a'
+
+foo :: C a => a -> Char
+foo x = f [x]
+-- ^ this is the point
+point :: (Int,Int)
+point = (31,9)
+
+bar :: Show x => x -> String
+bar x = show [(1,x,A)]
+-- ^ this is the point'
+point' :: (Int,Int)
+point' = (37,9)
+
+data A = A deriving Show
+
+makeNc :: IO NameCache
+makeNc = do
+ uniq_supply <- mkSplitUniqSupply 'z'
+ return $ initNameCache uniq_supply []
+
+dynFlagsForPrinting :: String -> IO DynFlags
+dynFlagsForPrinting libdir = do
+ systemSettings <- initSysTools libdir
+ return $ defaultDynFlags systemSettings (LlvmConfig [] [])
+
+main = do
+ libdir:_ <- getArgs
+ df <- dynFlagsForPrinting libdir
+ nc <- makeNc
+ hfr <- readHieFile (NCU (\f -> pure $ snd $ f nc)) "HieQueries.hie"
+ let hf = hie_file_result hfr
+ refmap = generateReferencesMap $ getAsts $ hie_asts hf
+ explainEv df hf refmap point
+ explainEv df hf refmap point'
+ return ()
+
+explainEv :: DynFlags -> HieFile -> RefMap Int -> (Int,Int) -> IO ()
+explainEv df hf refmap point = do
+ putStrLn $ replicate 26 '='
+ putStrLn $ "At point " ++ show point ++ ", we found:"
+ putStrLn $ replicate 26 '='
+ putStr $ drawForest ptrees
+ where
+ trees = getEvidenceTreesAtPoint hf refmap point
+
+ ptrees = fmap (pprint . fmap expandType) <$> trees
+
+ expandType = text . renderHieType df .
+ flip recoverFullType (hie_types hf)
+
+ pretty = unlines . (++["└"]) . ("┌":) . map ("│ "++) . lines
+
+ pprint = pretty . renderWithStyle (initSDocContext df sty) . ppr
+ sty = defaultUserStyle
=====================================
testsuite/tests/hiefile/should_run/HieQueries.stdout
=====================================
@@ -0,0 +1,98 @@
+==========================
+At point (31,9), we found:
+==========================
+┌
+│ $dC at HieQueries.hs:31:1-13, of type: C [a]
+│ is an evidence variable bound by a let, depending on: [$fC[], $dC]
+│ with scope: LocalScope HieQueries.hs:31:1-13
+│ bound at: HieQueries.hs:31:1-13
+│ Defined at <no location info>
+└
+|
++- ┌
+| │ $fC[] at HieQueries.hs:27:10-21, of type: forall a. C a => C [a]
+| │ is an evidence variable bound by an instance of class C
+| │ with scope: ModuleScope
+| │
+| │ Defined at HieQueries.hs:27:10
+| └
+|
+`- ┌
+ │ $dC at HieQueries.hs:31:1-13, of type: C a
+ │ is an evidence variable bound by a type signature
+ │ with scope: LocalScope HieQueries.hs:31:1-13
+ │ bound at: HieQueries.hs:31:1-13
+ │ Defined at <no location info>
+ └
+
+==========================
+At point (37,9), we found:
+==========================
+┌
+│ $dShow at HieQueries.hs:37:1-22, of type: Show [(Integer, x, A)]
+│ is an evidence variable bound by a let, depending on: [$fShow[],
+│ $dShow]
+│ with scope: LocalScope HieQueries.hs:37:1-22
+│ bound at: HieQueries.hs:37:1-22
+│ Defined at <no location info>
+└
+|
++- ┌
+| │ $fShow[] at HieQueries.hs:37:1-22, of type: forall a. Show a => Show [a]
+| │ is a usage of an external evidence variable
+| │ Defined in `GHC.Show'
+| └
+|
+`- ┌
+ │ $dShow at HieQueries.hs:37:1-22, of type: Show (Integer, x, A)
+ │ is an evidence variable bound by a let, depending on: [$fShow(,,),
+ │ $dShow, $dShow, $dShow]
+ │ with scope: LocalScope HieQueries.hs:37:1-22
+ │ bound at: HieQueries.hs:37:1-22
+ │ Defined at <no location info>
+ └
+ |
+ +- ┌
+ | │ $fShow(,,) at HieQueries.hs:37:1-22, of type: forall a b c. (Show a, Show b, Show c) => Show (a, b, c)
+ | │ is a usage of an external evidence variable
+ | │ Defined in `GHC.Show'
+ | └
+ |
+ +- ┌
+ | │ $dShow at HieQueries.hs:37:1-22, of type: Show Integer
+ | │ is an evidence variable bound by a let, depending on: [$fShowInteger]
+ | │ with scope: LocalScope HieQueries.hs:37:1-22
+ | │ bound at: HieQueries.hs:37:1-22
+ | │ Defined at <no location info>
+ | └
+ | |
+ | `- ┌
+ | │ $fShowInteger at HieQueries.hs:37:1-22, of type: Show Integer
+ | │ is a usage of an external evidence variable
+ | │ Defined in `GHC.Show'
+ | └
+ |
+ +- ┌
+ | │ $dShow at HieQueries.hs:37:1-22, of type: Show x
+ | │ is an evidence variable bound by a type signature
+ | │ with scope: LocalScope HieQueries.hs:37:1-22
+ | │ bound at: HieQueries.hs:37:1-22
+ | │ Defined at <no location info>
+ | └
+ |
+ `- ┌
+ │ $dShow at HieQueries.hs:37:1-22, of type: Show A
+ │ is an evidence variable bound by a let, depending on: [$fShowA]
+ │ with scope: LocalScope HieQueries.hs:37:1-22
+ │ bound at: HieQueries.hs:37:1-22
+ │ Defined at <no location info>
+ └
+ |
+ `- ┌
+ │ $fShowA at HieQueries.hs:42:21-24, of type: Show A
+ │ is an evidence variable bound by an instance of class Show
+ │ with scope: ModuleScope
+ │
+ │ Defined at HieQueries.hs:42:21
+ └
+
=====================================
testsuite/tests/hiefile/should_run/PatTypes.hs
=====================================
@@ -42,16 +42,9 @@ dynFlagsForPrinting libdir = do
systemSettings <- initSysTools libdir
return $ defaultDynFlags systemSettings (LlvmConfig [] [])
-selectPoint :: HieFile -> (Int,Int) -> HieAST Int
-selectPoint hf (sl,sc) = case M.toList (getAsts $ hie_asts hf) of
- [(fs,ast)] ->
- case selectSmallestContaining (sp fs) ast of
- Nothing -> error "point not found"
- Just ast' -> ast'
- _ -> error "map should only contain a single AST"
- where
- sloc fs = mkRealSrcLoc fs sl sc
- sp fs = mkRealSrcSpan (sloc fs) (sloc fs)
+selectPoint' :: HieFile -> (Int,Int) -> HieAST Int
+selectPoint' hf loc =
+ maybe (error "point not found") id $ selectPoint hf loc
main = do
libdir:_ <- getArgs
@@ -61,6 +54,6 @@ main = do
let hf = hie_file_result hfr
forM_ [p1,p2,p3,p4] $ \point -> do
putStr $ "At " ++ show point ++ ", got type: "
- let types = nodeType $ nodeInfo $ selectPoint hf point
+ let types = concatMap nodeType $ getSourcedNodeInfo $ sourcedNodeInfo $ selectPoint' hf point
forM_ types $ \typ -> do
putStrLn (renderHieType df $ recoverFullType typ (hie_types hf))
=====================================
testsuite/tests/hiefile/should_run/all.T
=====================================
@@ -1 +1,2 @@
test('PatTypes', [extra_run_opts('"' + config.libdir + '"')], compile_and_run, ['-package ghc -fwrite-ide-info'])
+test('HieQueries', [extra_run_opts('"' + config.libdir + '"')], compile_and_run, ['-package ghc -fwrite-ide-info'])
=====================================
testsuite/tests/stranal/should_compile/T18122.hs
=====================================
@@ -0,0 +1,6 @@
+{-# OPTIONS_GHC -fforce-recomp -O2 -fmax-worker-args=1 #-}
+module Lib where
+
+foo :: (Int, Int) -> Int -> Int
+foo (x, y) z = x+z
+{-# NOINLINE foo #-}
=====================================
testsuite/tests/stranal/should_compile/T18122.stderr
=====================================
@@ -0,0 +1,83 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 35, types: 27, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Lib.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+Lib.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Lib.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Cpr=m1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+Lib.$trModule3 = GHC.Types.TrNameS Lib.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Lib.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+Lib.$trModule2 = "Lib"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Lib.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Cpr=m1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+Lib.$trModule1 = GHC.Types.TrNameS Lib.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+Lib.$trModule :: GHC.Types.Module
+[GblId,
+ Cpr=m1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
+Lib.$trModule = GHC.Types.Module Lib.$trModule3 Lib.$trModule1
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Lib.$wfoo [InlPrag=NOINLINE]
+ :: GHC.Prim.Int# -> GHC.Prim.Int# -> GHC.Prim.Int#
+[GblId, Arity=2, Str=<L,U><L,U>, Unf=OtherCon []]
+Lib.$wfoo = (GHC.Prim.+#)
+
+-- RHS size: {terms: 18, types: 14, coercions: 0, joins: 0/0}
+foo [InlPrag=NOUSERINLINE[0]] :: (Int, Int) -> Int -> Int
+[GblId,
+ Arity=2,
+ Str=<S(SL),1*U(1*U(U),A)><S,1*U(U)>,
+ Cpr=m1,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (w_sHs [Occ=Once!] :: (Int, Int))
+ (w1_sHt [Occ=Once!] :: Int) ->
+ case w_sHs of { (ww1_sHw [Occ=Once!], _ [Occ=Dead]) ->
+ case ww1_sHw of { GHC.Types.I# ww4_sHz [Occ=Once] ->
+ case w1_sHt of { GHC.Types.I# ww6_sHF [Occ=Once] ->
+ case Lib.$wfoo ww4_sHz ww6_sHF of ww7_sHJ [Occ=Once] { __DEFAULT ->
+ GHC.Types.I# ww7_sHJ
+ }
+ }
+ }
+ }}]
+foo
+ = \ (w_sHs :: (Int, Int)) (w1_sHt :: Int) ->
+ case w_sHs of { (ww1_sHw, ww2_sHB) ->
+ case ww1_sHw of { GHC.Types.I# ww4_sHz ->
+ case w1_sHt of { GHC.Types.I# ww6_sHF ->
+ case Lib.$wfoo ww4_sHz ww6_sHF of ww7_sHJ { __DEFAULT ->
+ GHC.Types.I# ww7_sHJ
+ }
+ }
+ }
+ }
+
+
+
=====================================
testsuite/tests/stranal/should_compile/all.T
=====================================
@@ -52,3 +52,6 @@ test('T17852', [ grep_errmsg(r'\\$wf ::') ], compile, ['-ddump-worker-wrapper -
test('T16029', normal, makefile_test, [])
test('T10069', [ grep_errmsg(r'(wc1).*Int#$') ], compile, ['-dppr-cols=200 -ddump-simpl'])
test('T13380b', [ grep_errmsg('bigDeadAction') ], compile, ['-dppr-cols=200 -ddump-simpl'])
+
+# We just want to find the worker of foo in there:
+test('T18122', [ grep_errmsg(r'wfoo =') ], compile, ['-ddump-simpl'])
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 8f340aef12df5f5df02d49ab5c6c5d7cccfa398b
+Subproject commit 8134a3be2c01ab5f1b88fed86c4ad7cc2f417f0a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c68ae868ac09e2904a4c724fdbd6bbcce7fcc725...38ad4a1965699128fb4858fc2b1fd8022cc9df49
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c68ae868ac09e2904a4c724fdbd6bbcce7fcc725...38ad4a1965699128fb4858fc2b1fd8022cc9df49
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/20200525/639c6d31/attachment-0001.html>
More information about the ghc-commits
mailing list