diff options
| -rw-r--r-- | compiler/typecheck/TcBinds.hs | 47 | ||||
| -rw-r--r-- | compiler/typecheck/TcEnv.hs | 48 | ||||
| -rw-r--r-- | compiler/typecheck/TcExpr.hs | 155 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnDriver.hs | 5 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnTypes.hs | 48 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr | 3 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs | 9 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr | 35 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_fail/all.T | 2 |
9 files changed, 288 insertions, 64 deletions
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index b34ad0bcad..8cfd5551ca 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -16,7 +16,7 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, TcPragEnv, mkPragEnv, tcUserTypeSig, instTcTySig, chooseInferredQuantifiers, instTcTySigFromId, tcExtendTyVarEnvFromSig, - badBootDeclErr ) where + badBootDeclErr) where import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) @@ -407,7 +407,7 @@ tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside ------------------------ tc_group :: forall thing. TopLevelFlag -> TcSigFun -> TcPragEnv - -> (RecFlag, LHsBinds Name) -> TopLevelFlag -> TcM thing + -> (RecFlag, LHsBinds Name) -> IsGroupClosed -> TcM thing -> TcM ([(RecFlag, LHsBinds TcId)], thing) -- Typecheck one strongly-connected component of the original program. @@ -470,7 +470,7 @@ recursivePatSynErr binds tc_single :: forall thing. TopLevelFlag -> TcSigFun -> TcPragEnv - -> LHsBind Name -> TopLevelFlag -> TcM thing + -> LHsBind Name -> IsGroupClosed -> TcM thing -> TcM (LHsBinds TcId, thing) tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) @@ -522,7 +522,7 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv -> RecFlag -- Whether the group is really recursive -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures - -> TopLevelFlag -- Whether the group is closed + -> IsGroupClosed -- Whether the group is closed -> [LHsBind Name] -- None are PatSynBind -> TcM (LHsBinds TcId, [TcId]) @@ -1913,12 +1913,12 @@ instance Outputable GeneralisationPlan where ppr (CheckGen _ s) = text "CheckGen" <+> ppr s decideGeneralisationPlan - :: DynFlags -> [LHsBind Name] -> TopLevelFlag -> TcSigFun + :: DynFlags -> [LHsBind Name] -> IsGroupClosed -> TcSigFun -> GeneralisationPlan decideGeneralisationPlan dflags lbinds closed sig_fn | unlifted_pat_binds = NoGen | Just bind_sig <- one_funbind_with_sig = sig_plan bind_sig - | mono_local_binds = NoGen + | mono_local_binds closed = NoGen | otherwise = InferGen mono_restriction where binds = map unLoc lbinds @@ -1946,8 +1946,8 @@ decideGeneralisationPlan dflags lbinds closed sig_fn mono_restriction = xopt LangExt.MonomorphismRestriction dflags && any restricted binds - mono_local_binds = xopt LangExt.MonoLocalBinds dflags - && not (isTopLevel closed) + mono_local_binds ClosedGroup = False + mono_local_binds _ = xopt LangExt.MonoLocalBinds dflags no_sig n = noCompleteSig (sig_fn n) @@ -1974,17 +1974,23 @@ decideGeneralisationPlan dflags lbinds closed sig_fn -- No args => like a pattern binding -- Some args => a function binding -isClosedBndrGroup :: Bag (LHsBind Name) -> TcM TopLevelFlag +isClosedBndrGroup :: Bag (LHsBind Name) -> TcM IsGroupClosed isClosedBndrGroup binds = do type_env <- getLclTypeEnv - if foldrBag (is_closed_ns type_env . fvs . unLoc) True binds - then return TopLevel - else return NotTopLevel + if foldUFM (is_closed_ns type_env) True fv_env + then return ClosedGroup + else return $ NonClosedGroup fv_env where - fvs :: HsBind Name -> NameSet - fvs (FunBind { bind_fvs = vs }) = vs - fvs (PatBind { bind_fvs = vs }) = vs - fvs _ = emptyNameSet + fv_env :: NameEnv NameSet + fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds + + bindFvs :: HsBindLR Name idR -> [(Name, NameSet)] + bindFvs (FunBind { fun_id = f, bind_fvs = fvs }) + = [(unLoc f, fvs)] + bindFvs (PatBind { pat_lhs = pat, bind_fvs = fvs }) + = [(b, fvs) | b <- collectPatBinders pat] + bindFvs _ + = [] is_closed_ns :: TcTypeEnv -> NameSet -> Bool -> Bool is_closed_ns type_env ns b = b && nameSetAll (is_closed_id type_env) ns @@ -1995,10 +2001,11 @@ isClosedBndrGroup binds = do is_closed_id type_env name | Just thing <- lookupNameEnv type_env name = case thing of - ATcId { tct_closed = cl } -> isTopLevel cl -- This is the key line - ATyVar {} -> False -- In-scope type variables - AGlobal {} -> True -- are not closed! - _ -> pprPanic "is_closed_id" (ppr name) + ATcId { tct_info = ClosedLet } -> True -- This is the key line + ATcId {} -> False + ATyVar {} -> False -- In-scope type variables + AGlobal {} -> True -- are not closed! + _ -> pprPanic "is_closed_id" (ppr name) | otherwise = True -- The free-var set for a top level binding mentions diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 42a03142c1..525e834393 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -407,40 +407,45 @@ tcExtendTyVarEnv2 binds thing_inside tyvar' = setTyVarName tyvar name' name' = tidyNameOcc name occ' -isTypeClosedLetBndr :: Id -> TopLevelFlag +isTypeClosedLetBndr :: Id -> Bool -- See Note [Bindings with closed types] in TcRnTypes --- Note that we decided if a let-bound variable is closed by --- looking at its type, which is slightly more liberal, and a whole --- lot easier to implement, than looking at its free variables isTypeClosedLetBndr id - | isEmptyVarSet (tyCoVarsOfType (idType id)) = TopLevel - | otherwise = NotTopLevel + | isEmptyVarSet (tyCoVarsOfType (idType id)) = True + | otherwise = False -tcExtendLetEnv :: TopLevelFlag -> TopLevelFlag -> [TcId] -> TcM a -> TcM a +tcExtendLetEnv :: TopLevelFlag -> IsGroupClosed -> [TcId] -> TcM a -> TcM a -- Used for both top-level value bindings and and nested let/where-bindings -- Adds to the TcIdBinderStack too tcExtendLetEnv top_lvl closed_group ids thing_inside = tcExtendIdBndrs [TcIdBndr id top_lvl | id <- ids] $ - tcExtendLetEnvIds' top_lvl closed_group [(idName id, id) | id <- ids] + tcExtendLetEnvIds' top_lvl closed_group + [(idName id, id) | id <- ids] thing_inside -tcExtendLetEnvIds :: TopLevelFlag -> [(Name,TcId)] -> TcM a -> TcM a +tcExtendLetEnvIds :: TopLevelFlag -> [(Name, TcId)] -> TcM a -> TcM a -- Used for both top-level value bindings and and nested let/where-bindings -- Does not extend the TcIdBinderStack tcExtendLetEnvIds top_lvl - = tcExtendLetEnvIds' top_lvl TopLevel + = tcExtendLetEnvIds' top_lvl ClosedGroup -tcExtendLetEnvIds' :: TopLevelFlag -> TopLevelFlag -> [(Name,TcId)] -> TcM a +tcExtendLetEnvIds' :: TopLevelFlag -> IsGroupClosed + -> [(Name,TcId)] -> TcM a -> TcM a -- Used for both top-level value bindings and and nested let/where-bindings -- Does not extend the TcIdBinderStack tcExtendLetEnvIds' top_lvl closed_group pairs thing_inside = tc_extend_local_env top_lvl - [ (name, ATcId { tct_id = id - , tct_closed = case closed_group of - TopLevel -> isTypeClosedLetBndr id - _ -> closed_group }) - | (name,id) <- pairs ] $ + [ (name, ATcId { tct_id = let_id + , tct_info = case closed_group of + ClosedGroup + | isTypeClosedLetBndr let_id -> ClosedLet + | otherwise -> NonClosedLet emptyNameSet False + NonClosedGroup fvs -> + NonClosedLet + (maybe emptyNameSet id $ lookupNameEnv fvs name) + (isTypeClosedLetBndr let_id) + }) + | (name, let_id) <- pairs ] $ thing_inside tcExtendIdEnv :: [TcId] -> TcM a -> TcM a @@ -460,7 +465,7 @@ tcExtendIdEnv2 names_w_ids thing_inside | (_,mono_id) <- names_w_ids ] $ do { tc_extend_local_env NotTopLevel [ (name, ATcId { tct_id = id - , tct_closed = NotTopLevel }) + , tct_info = NotLetBound }) | (name,id) <- names_w_ids] $ thing_inside } @@ -512,11 +517,12 @@ tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things where extra_tvs = foldr get_tvs emptyVarSet tc_ty_things - get_tvs (_, ATcId { tct_id = id, tct_closed = closed }) tvs + get_tvs (_, ATcId { tct_id = id, tct_info = closed }) tvs = case closed of - TopLevel -> ASSERT2( isEmptyVarSet id_tvs, ppr id $$ ppr (idType id) ) - tvs - NotTopLevel -> tvs `unionVarSet` id_tvs + ClosedLet -> + ASSERT2( isEmptyVarSet id_tvs, ppr id $$ ppr (idType id) ) tvs + _ -> + tvs `unionVarSet` id_tvs where id_tvs = tyCoVarsOfType (idType id) get_tvs (_, ATyVar _ tv) tvs -- See Note [Global TyVars] diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 5089cab80a..25a62cb7b3 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -49,6 +49,8 @@ import ConLike import DataCon import PatSyn import Name +import NameEnv +import NameSet import RdrName import TyCon import Type @@ -2499,11 +2501,152 @@ fieldNotInType p rdr ************************************************************************ -} +-- | A data type to describe why a variable is not closed. +data NotClosedReason = NotLetBoundReason + | NotTypeClosed VarSet + | NotClosed Name NotClosedReason + +-- | Checks if the given name is closed and emits an error if not. +-- +-- See Note [Not-closed error messages]. checkClosedInStaticForm :: Name -> TcM () checkClosedInStaticForm name = do - thing <- tcLookup name - case thing of - ATcId { tct_closed = NotTopLevel } -> - addErrTc $ quotes (ppr name) <+> - text "is used in a static form but it is not closed." - _ -> return () + type_env <- getLclTypeEnv + case checkClosed type_env name of + Nothing -> return () + Just reason -> addErrTc $ explain name reason + where + -- See Note [Checking closedness]. + checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason + checkClosed type_env n = checkLoop type_env (unitNameSet n) n + + checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason + checkLoop type_env visited n = do + -- The @visited@ set is an accumulating parameter that contains the set of + -- visited nodes, so we avoid repeating cycles in the traversal. + case lookupNameEnv type_env n of + Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of + ClosedLet -> Nothing + NotLetBound -> Just NotLetBoundReason + NonClosedLet fvs type_closed -> listToMaybe $ + -- Look for a non-closed variable in fvs + [ NotClosed n' reason + | n' <- nameSetElemsStable fvs + , not (elemNameSet n' visited) + , Just reason <- [checkLoop type_env (extendNameSet visited n') n'] + ] ++ + if type_closed then + [] + else + -- We consider non-let-bound variables easier to figure out than + -- non-closed types, so we report non-closed types to the user + -- only if we cannot spot the former. + [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ] + -- The binding is closed. + _ -> Nothing + + -- Converts a reason into a human-readable sentence. + -- + -- @explain name reason@ starts with + -- + -- "<name> is used in a static form but it is not closed because it" + -- + -- and then follows a list of causes. For each id in the path, the text + -- + -- "uses <id> which" + -- + -- is appended, yielding something like + -- + -- "uses <id> which uses <id1> which uses <id2> which" + -- + -- until the end of the path is reached, which is reported as either + -- + -- "is not let-bound" + -- + -- when the final node is not let-bound, or + -- + -- "has a non-closed type because it contains the type variables: + -- v1, v2, v3" + -- + -- when the final node has a non-closed type. + -- + explain :: Name -> NotClosedReason -> SDoc + explain name reason = + quotes (ppr name) <+> text "is used in a static form but it is not closed" + <+> text "because it" + $$ + sep (causes reason) + + causes :: NotClosedReason -> [SDoc] + causes NotLetBoundReason = [text "is not let-bound."] + causes (NotTypeClosed vs) = + [ text "has a non-closed type because it contains the" + , text "type variables:" <+> + pprVarSet vs (hsep . punctuate comma . map (quotes . ppr)) + ] + causes (NotClosed n reason) = + let msg = text "uses" <+> quotes (ppr n) <+> text "which" + in case reason of + NotClosed _ _ -> msg : causes reason + _ -> let (xs0, xs1) = splitAt 1 $ causes reason + in fmap (msg <+>) xs0 ++ xs1 + +-- Note [Not-closed error messages] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- When variables in a static form are not closed, we go through the trouble +-- of explaining why they aren't. +-- +-- Thus, the following program +-- +-- > {-# LANGUAGE StaticPointers #-} +-- > module M where +-- > +-- > f x = static g +-- > where +-- > g = h +-- > h = x +-- +-- produces the error +-- +-- 'g' is used in a static form but it is not closed because it +-- uses 'h' which uses 'x' which is not let-bound. +-- +-- And a program like +-- +-- > {-# LANGUAGE StaticPointers #-} +-- > module M where +-- > +-- > import Data.Typeable +-- > import GHC.StaticPtr +-- > +-- > f :: Typeable a => a -> StaticPtr TypeRep +-- > f x = const (static (g undefined)) (h x) +-- > where +-- > g = h +-- > h = typeOf +-- +-- produces the error +-- +-- 'g' is used in a static form but it is not closed because it +-- uses 'h' which has a non-closed type because it contains the +-- type variables: 'a' +-- + +-- Note [Checking closedness] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- @checkClosed@ checks if a binding is closed and returns a reason if it is +-- not. +-- +-- The bindings define a graph where the nodes are ids, and there is an edge +-- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free +-- variables. +-- +-- When @n@ is not closed, it has to exist in the graph some node reachable +-- from @n@ that it is not a let-bound variable or that it has a non-closed +-- type. Thus, the "reason" is a path from @n@ to this offending node. +-- +-- When @n@ is not closed, we traverse the graph reachable from @n@ to build +-- the reason. +-- diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index c6865f5492..154b127371 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -1639,8 +1639,9 @@ runTcInteractive hsc_env thing_inside -- See Note [Initialising the type environment for GHCi] is_closed thing | AnId id <- thing - , NotTopLevel <- isTypeClosedLetBndr id - = Left (idName id, ATcId { tct_id = id, tct_closed = NotTopLevel }) + , not (isTypeClosedLetBndr id) + = Left (idName id, ATcId { tct_id = id + , tct_info = NotLetBound }) | otherwise = Right thing diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index ef6feafc94..3978302958 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -40,6 +40,8 @@ module TcRnTypes( -- Typechecker types TcTypeEnv, TcIdBinderStack, TcIdBinder(..), TcTyThing(..), PromotionErr(..), + IdBindingInfo(..), + IsGroupClosed(..), SelfBootInfo(..), pprTcTyThingCategory, pprPECategory, @@ -885,7 +887,7 @@ data TcTyThing | ATcId { -- Ids defined in this module; may not be fully zonked tct_id :: TcId, - tct_closed :: TopLevelFlag } -- See Note [Bindings with closed types] + tct_info :: IdBindingInfo } -- See Note [Bindings with closed types] | ATyVar Name TcTyVar -- The type variable to which the lexically scoped type -- variable is bound. We only need the Name @@ -922,11 +924,51 @@ instance Outputable TcTyThing where -- Debugging only ppr elt@(ATcId {}) = text "Identifier" <> brackets (ppr (tct_id elt) <> dcolon <> ppr (varType (tct_id elt)) <> comma - <+> ppr (tct_closed elt)) + <+> ppr (tct_info elt)) ppr (ATyVar n tv) = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv ppr (ATcTyCon tc) = text "ATcTyCon" <+> ppr tc ppr (APromotionErr err) = text "APromotionErr" <+> ppr err +-- | Describes how an Id is bound. +-- +-- It is used for the following purposes: +-- +-- a) for static forms in TcExpr.checkClosedInStaticForm and +-- b) to figure out when a nested binding can be generalised (in +-- TcBinds.decideGeneralisationPlan). +-- +-- See Note [Meaning of IdBindingInfo]. +data IdBindingInfo + = NotLetBound + | ClosedLet + | NonClosedLet NameSet Bool + +-- Note [Meaning of IdBindingInfo] +-- +-- @NotLetBound@ means that the Id is not let-bound (e.g. it is bound in a +-- lambda-abstraction or in a case pattern). +-- +-- @ClosedLet@ means that the Id is let-bound, it is closed and its type is +-- closed as well. +-- +-- @NonClosedLet fvs type-closed@ means that the Id is let-bound but it is not +-- closed. The @fvs@ set contains the free variables of the rhs. The type-closed +-- flag indicates if the type of Id is closed. + +instance Outputable IdBindingInfo where + ppr NotLetBound = text "NotLetBound" + ppr ClosedLet = text "TopLevelLet" + ppr (NonClosedLet fvs closed_type) = + text "TopLevelLet" <+> ppr fvs <+> ppr closed_type + +-- | Tells if a group of binders is closed. +-- +-- When it is not closed, it provides a map of binder ids to the free vars +-- in their right-hand sides. +-- +data IsGroupClosed = ClosedGroup + | NonClosedGroup (NameEnv NameSet) + instance Outputable PromotionErr where ppr ClassPE = text "ClassPE" ppr TyConPE = text "TyConPE" @@ -969,7 +1011,7 @@ have no free type variables, and it is the type variables in the environment that makes things tricky for OutsideIn generalisation. Definition: - A variable is "closed", and has tct_closed set to TopLevel, + A variable is "closed", and has tct_info set to TopLevel, iff a) all its free variables are imported, or are let-bound and closed b) generalisation is not restricted by the monomorphism restriction diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr b/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr index 0590eaa567..52adc5b55b 100644 --- a/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr @@ -1,5 +1,6 @@ RnStaticPointersFail01.hs:5:7: - ‘x’ is used in a static form but it is not closed. + ‘x’ is used in a static form but it is not closed because it + is not let-bound. In the expression: static x In an equation for ‘f’: f x = static x diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs index 141aa89e2a..882af36292 100644 --- a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs @@ -2,6 +2,9 @@ module RnStaticPointersFail03 where +import Data.Typeable +import GHC.StaticPtr + f x = static (x . id) f0 x = static (k . id) @@ -11,3 +14,9 @@ f0 x = static (k . id) f1 x = static (k . id) where k = id + +f2 :: Typeable a => a -> StaticPtr TypeRep +f2 x = const (static (g undefined)) (h x) + where + g = h + h = typeOf diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr index 8102662257..3ba18c6869 100644 --- a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr @@ -1,14 +1,29 @@ -RnStaticPointersFail03.hs:5:7: - ‘x’ is used in a static form but it is not closed. +RnStaticPointersFail03.hs:8:7: + ‘x’ is used in a static form but it is not closed because it + is not let-bound. In the expression: static (x . id) In an equation for ‘f’: f x = static (x . id) -RnStaticPointersFail03.hs:7:8: - ‘k’ is used in a static form but it is not closed. - In the expression: static (k . id) - In an equation for ‘f0’: - f0 x - = static (k . id) - where - k = const (const () x) +RnStaticPointersFail03.hs:10:8: + ‘k’ is used in a static form but it is not closed because it + uses ‘x’ which is not let-bound. + In the expression: static (k . id) + In an equation for ‘f0’: + f0 x + = static (k . id) + where + k = const (const () x) + +RnStaticPointersFail03.hs:19:15: + ‘g’ is used in a static form but it is not closed because it + uses ‘h’ which has a non-closed type because it contains the + type variables: ‘a’ + In the first argument of ‘const’, namely ‘(static (g undefined))’ + In the expression: const (static (g undefined)) (h x) + In an equation for ‘f2’: + f2 x + = const (static (g undefined)) (h x) + where + g = h + h = typeOf diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T index 38106209c3..78b80e8220 100644 --- a/testsuite/tests/rename/should_fail/all.T +++ b/testsuite/tests/rename/should_fail/all.T @@ -115,7 +115,7 @@ test('T8448', normal, compile_fail, ['']) test('T8149', normal, compile, ['']) test('RnStaticPointersFail01', [], compile_fail, ['']) test('RnStaticPointersFail02', [], compile_fail, ['']) -test('RnStaticPointersFail03', [], compile_fail, ['']) +test('RnStaticPointersFail03', [], compile_fail, ['-dsuppress-uniques']) test('T9006', extra_clean(['T9006a.hi', 'T9006a.o']), multimod_compile_fail, ['T9006', '-v0']) |