Commit c9e8f801 authored by Facundo Domínguez's avatar Facundo Domínguez
Browse files

Set tct_closed to TopLevel for closed bindings.

Summary:
Till now tct_closed determined whether the type of a binding is closed.
With this patch tct_closed indicates whether the binding is closed.

Test Plan: ./validate

Reviewers: simonpj, austin, bgamari

Reviewed By: simonpj

Subscribers: mboes, thomie, simonpj

Differential Revision: https://phabricator.haskell.org/D2016

GHC Trac Issues: #11698
parent 0f58d348
......@@ -378,22 +378,41 @@ tcBindGroups _ _ _ [] thing_inside
; return ([], thing) }
tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
= do { (group', (groups', thing))
<- tc_group top_lvl sig_fn prag_fn group $
= do { -- See Note [Closed binder groups]
closed <- isClosedBndrGroup $ snd group
; (group', (groups', thing))
<- tc_group top_lvl sig_fn prag_fn group closed $
tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
; return (group' ++ groups', thing) }
-- Note [Closed binder groups]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- A mutually recursive group is "closed" if all of the free variables of
-- the bindings are closed. For example
--
-- > h = \x -> let f = ...g...
-- > g = ....f...x...
-- > in ...
--
-- Here @g@ is not closed because it mentions @x@; and hence neither is @f@
-- closed.
--
-- So we need to compute closed-ness on each strongly connected components,
-- before we sub-divide it based on what type signatures it has.
--
------------------------
tc_group :: forall thing.
TopLevelFlag -> TcSigFun -> TcPragEnv
-> (RecFlag, LHsBinds Name) -> TcM thing
-> (RecFlag, LHsBinds Name) -> TopLevelFlag -> TcM thing
-> TcM ([(RecFlag, LHsBinds TcId)], thing)
-- Typecheck one strongly-connected component of the original program.
-- We get a list of groups back, because there may
-- be specialisations etc as well
tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside
-- A single non-recursive binding
-- We want to keep non-recursive things non-recursive
-- so that we desugar unlifted bindings correctly
......@@ -401,10 +420,11 @@ tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
[bind] -> bind
[] -> panic "tc_group: empty list of binds"
_ -> panic "tc_group: NonRecursive binds is not a singleton bag"
; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind thing_inside
; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed
thing_inside
; return ( [(NonRecursive, bind')], thing) }
tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
= -- To maximise polymorphism, we do a new
-- strongly-connected-component analysis, this time omitting
-- any references to variables with type signatures.
......@@ -425,15 +445,16 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing)
go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc
; (binds2, thing) <- tcExtendLetEnv top_lvl ids1 $
go sccs
; (binds2, thing) <- tcExtendLetEnv top_lvl closed ids1
(go sccs)
; return (binds1 `unionBags` binds2, thing) }
go [] = do { thing <- thing_inside; return (emptyBag, thing) }
tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds
tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
tc_sub_group rec_tc binds =
tcPolyBinds top_lvl sig_fn prag_fn Recursive rec_tc closed binds
recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a
recursivePatSynErr binds
......@@ -447,9 +468,11 @@ recursivePatSynErr binds
tc_single :: forall thing.
TopLevelFlag -> TcSigFun -> TcPragEnv
-> LHsBind Name -> TcM thing
-> LHsBind Name -> TopLevelFlag -> TcM thing
-> TcM (LHsBinds TcId, thing)
tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) thing_inside
tc_single _top_lvl sig_fn _prag_fn
(L _ (PatSynBind psb@PSB{ psb_id = L _ name }))
_ thing_inside
= do { (aux_binds, tcg_env) <- tc_pat_syn_decl
; thing <- setGblEnv tcg_env thing_inside
; return (aux_binds, thing)
......@@ -461,11 +484,12 @@ tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name }
Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
Just _ -> panic "tc_single"
tc_single top_lvl sig_fn prag_fn lbind thing_inside
tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
= do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn
NonRecursive NonRecursive
closed
[lbind]
; thing <- tcExtendLetEnv top_lvl ids thing_inside
; thing <- tcExtendLetEnv top_lvl closed ids thing_inside
; return (binds1, thing) }
------------------------
......@@ -493,6 +517,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
-> [LHsBind Name] -- None are PatSynBind
-> TcM (LHsBinds TcId, [TcId])
......@@ -507,7 +532,7 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv
-- Knows nothing about the scope of the bindings
-- None of the bindings are pattern synonyms
tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list
= setSrcSpan loc $
recoverM (recoveryCode binder_names sig_fn) $ do
-- Set up main recover; take advantage of any type sigs
......@@ -515,9 +540,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
{ traceTc "------------------------------------------------" Outputable.empty
; traceTc "Bindings for {" (ppr binder_names)
; dflags <- getDynFlags
; type_env <- getLclTypeEnv
; let plan = decideGeneralisationPlan dflags type_env
binder_names bind_list sig_fn
; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn
; traceTc "Generalisation plan" (ppr plan)
; result@(tc_binds, poly_ids) <- case plan of
NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
......@@ -1881,15 +1904,14 @@ instance Outputable GeneralisationPlan where
ppr (CheckGen _ s) = text "CheckGen" <+> ppr s
decideGeneralisationPlan
:: DynFlags -> TcTypeEnv -> [Name]
-> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
:: DynFlags -> [LHsBind Name] -> TopLevelFlag -> 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
| otherwise = InferGen mono_restriction
where
bndr_set = mkNameSet bndr_names
binds = map unLoc lbinds
sig_plan :: (LHsBind Name, TcIdSigInfo) -> GeneralisationPlan
......@@ -1915,32 +1937,8 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
mono_restriction = xopt LangExt.MonomorphismRestriction dflags
&& any restricted binds
is_closed_ns :: NameSet -> Bool -> Bool
is_closed_ns ns b = foldNameSet ((&&) . is_closed_id) b ns
-- ns are the Names referred to from the RHS of this bind
is_closed_id :: Name -> Bool
-- See Note [Bindings with closed types] in TcRnTypes
is_closed_id name
| name `elemNameSet` bndr_set
= True -- Ignore binders in this groups, of course
| 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)
| otherwise
= WARN( isInternalName name, ppr name ) True
-- The free-var set for a top level binding mentions
-- imported things too, so that we can report unused imports
-- These won't be in the local type env.
-- Ditto class method etc from the current module
mono_local_binds = xopt LangExt.MonoLocalBinds dflags
&& not closed_flag
closed_flag = foldr (is_closed_ns . bind_fvs) True binds
&& not (isTopLevel closed)
no_sig n = noCompleteSig (sig_fn n)
......@@ -1967,6 +1965,38 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
-- No args => like a pattern binding
-- Some args => a function binding
isClosedBndrGroup :: Bag (LHsBind Name) -> TcM TopLevelFlag
isClosedBndrGroup binds = do
type_env <- getLclTypeEnv
if foldrBag (is_closed_ns type_env . fvs . unLoc) True binds
then return TopLevel
else return NotTopLevel
where
fvs :: HsBind Name -> NameSet
fvs (FunBind { bind_fvs = vs }) = vs
fvs (PatBind { bind_fvs = vs }) = vs
fvs _ = emptyNameSet
is_closed_ns :: TcTypeEnv -> NameSet -> Bool -> Bool
is_closed_ns type_env ns b = foldNameSet ((&&) . is_closed_id type_env) b ns
-- ns are the Names referred to from the RHS of this bind
is_closed_id :: TcTypeEnv -> Name -> Bool
-- See Note [Bindings with closed types] in TcRnTypes
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)
| otherwise
= True
-- The free-var set for a top level binding mentions
-- imported things too, so that we can report unused imports
-- These won't be in the local type env.
-- Ditto class method etc from the current module
-------------------
checkStrictBinds :: TopLevelFlag -> RecFlag
-> [LHsBind Name]
......
......@@ -28,7 +28,7 @@ module TcEnv(
tcExtendLetEnv, tcExtendLetEnvIds,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
tcExtendIdBndrs, tcExtendLocalTypeEnv,
isClosedLetBndr,
isTypeClosedLetBndr,
tcLookup, tcLookupLocated, tcLookupLocalIds,
tcLookupId, tcLookupTyVar,
......@@ -409,29 +409,40 @@ getScopedTyVarBinds
= do { lcl_env <- getLclEnv
; return [(name, tv) | ATyVar name tv <- nameEnvElts (tcl_env lcl_env)] }
isClosedLetBndr :: Id -> TopLevelFlag
isTypeClosedLetBndr :: Id -> TopLevelFlag
-- 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
isClosedLetBndr id
isTypeClosedLetBndr id
| isEmptyVarSet (tyCoVarsOfType (idType id)) = TopLevel
| otherwise = NotTopLevel
tcExtendLetEnv :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
tcExtendLetEnv :: TopLevelFlag -> TopLevelFlag -> [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 ids thing_inside
tcExtendLetEnv top_lvl closed_group ids thing_inside
= tcExtendIdBndrs [TcIdBndr id top_lvl | id <- ids] $
tcExtendLetEnvIds top_lvl [(idName id, id) | id <- ids] thing_inside
tcExtendLetEnvIds' top_lvl closed_group [(idName id, id) | id <- ids]
thing_inside
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 pairs thing_inside
= tc_extend_local_env top_lvl [ (name, ATcId { tct_id = id
, tct_closed = isClosedLetBndr id })
| (name,id) <- pairs ] $
tcExtendLetEnvIds top_lvl
= tcExtendLetEnvIds' top_lvl TopLevel
tcExtendLetEnvIds' :: TopLevelFlag -> 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 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 ] $
thing_inside
tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
......
......@@ -757,7 +757,7 @@ tcInstDecls2 tycl_decls inst_decls
; let dm_ids = collectHsBindsBinders dm_binds
-- Add the default method Ids (again)
-- See Note [Default methods and instances]
; inst_binds_s <- tcExtendLetEnv TopLevel dm_ids $
; inst_binds_s <- tcExtendLetEnv TopLevel TopLevel dm_ids $
mapM tcInstDecl2 inst_decls
-- Done
......
......@@ -1629,7 +1629,7 @@ runTcInteractive hsc_env thing_inside
-- See Note [Initialising the type environment for GHCi]
is_closed thing
| AnId id <- thing
, NotTopLevel <- isClosedLetBndr id
, NotTopLevel <- isTypeClosedLetBndr id
= Left (idName id, ATcId { tct_id = id, tct_closed = NotTopLevel })
| otherwise
= Right thing
......
......@@ -962,10 +962,14 @@ environment that makes things tricky for OutsideIn generalisation.
Definition:
A variable is "closed", and has tct_closed set to TopLevel,
iff
a) all its free variables are imported, or are let-bound with closed types
a) all its free variables are imported, or are let-bound and closed
b) generalisation is not restricted by the monomorphism restriction
Invariant: a closed variable has no free type variables in its type.
Why? Assume (induction hypothesis) that closed variables have closed
types, and that we have a new binding f = e, satisfying (a) and (b).
Then since monomorphism restriction does not apply, and there are no
free type variables, we can fully generalise, so its type will be closed.
Under OutsideIn we are free to generalise a closed let-binding.
This is an extension compared to the JFP paper on OutsideIn, which
......
{-# LANGUAGE MonoLocalBinds #-}
module T11698 where
f x = (k 'v', k True)
where
h = const True x
k z = const h (k z) -- k type should not be generalized because h is closed.
T11698.hs:4:17: error:
• Couldn't match expected type ‘Char’ with actual type ‘Bool’
• In the first argument of ‘k’, namely ‘True’
In the expression: k True
In the expression: (k 'v', k True)
......@@ -412,3 +412,4 @@ test('T11313', normal, compile_fail, [''])
test('T11723', normal, compile_fail, [''])
test('T11724', normal, compile_fail, [''])
test('BadUnboxedTuple', normal, compile_fail, [''])
test('T11698', normal, compile_fail, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment