Commit eb46e0de authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Fix the trimming of bind_fvs (fixes Trac #5439)

For the bind_fvs field of FunBind/PatBind, we need to be careful to
keep track of uses of all functions in this module (although not
imported ones).  Moreover in TcBinds.decideGeneralisationPlan we
need to take note of uses of lexically scoped type variables.

These two buglets led to a (useful) assertion failure in TcEnv.
parent 4ea2675c
......@@ -119,11 +119,10 @@ data HsBindLR idL idR
-- type Int -> forall a'. a' -> a'
-- Notice that the coercion captures the free a'.
bind_fvs :: NameSet, -- ^ After the renamer, this contains a superset of the
-- Names of the other binders in this binding group that
-- are free in the RHS of the defn
-- Before renaming, and after typechecking,
-- the field is unused; it's just an error thunk
bind_fvs :: NameSet, -- ^ After the renamer, this contains the locally-bound
-- free variables of this defn.
-- See Note [Bind free vars]
fun_tick :: Maybe (Int,[Id]) -- ^ This is the (optional) module-local tick number.
}
......@@ -133,7 +132,7 @@ data HsBindLR idL idR
pat_lhs :: LPat idL,
pat_rhs :: GRHSs idR,
pat_rhs_ty :: PostTcType, -- Type of the GRHSs
bind_fvs :: NameSet -- Same as for FunBind
bind_fvs :: NameSet -- See Note [Bind free vars]
}
| VarBind { -- Dictionary binding and suchlike
......@@ -182,8 +181,47 @@ data ABExport id
placeHolderNames :: NameSet
-- Used for the NameSet in FunBind and PatBind prior to the renamer
placeHolderNames = panic "placeHolderNames"
\end{code}
------------
Note [AbsBinds wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~
Consdider
(f,g) = (\x.x, \y.y)
This ultimately desugars to something like this:
tup :: forall a b. (a->a, b->b)
tup = /\a b. (\x:a.x, \y:b.y)
f :: forall a. a -> a
f = /\a. case tup a Any of
(fm::a->a,gm:Any->Any) -> fm
...similarly for g...
The abe_wrap field deals with impedence-matching between
(/\a b. case tup a b of { (f,g) -> f })
and the thing we really want, which may have fewer type
variables. The action happens in TcBinds.mkExport.
Note [Bind free vars]
~~~~~~~~~~~~~~~~~~~~~
The bind_fvs field of FunBind and PatBind records the free variables
of the definition. It is used for two purposes
a) Dependency analysis prior to type checking
(see TcBinds.tc_group)
b) Deciding whether we can do generalisation of the binding
(see TcBinds.decideGeneralisationPlan)
Specifically,
* bind_fvs includes all free vars that are defined in this module
(including top-level things and lexically scoped type variables)
* bind_fvs excludes imported vars; this is just to keep the set smaller
* Before renaming, and after typechecking, the field is unused;
it's just an error thunk
\begin{code}
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where
ppr (HsValBinds bs) = ppr bs
ppr (HsIPBinds bs) = ppr bs
......
......@@ -172,8 +172,7 @@ rnTopBindsRHS binds
= do { is_boot <- tcIsHsBoot
; if is_boot
then rnTopBindsBoot binds
else rnValBindsRHS noTrimFVs -- don't trim free vars
Nothing -- Allow SPEC prags for imports
else rnValBindsRHS Nothing -- Allow SPEC prags for imports
binds }
-- Wrapper if we don't need to do anything in between the left and right,
......@@ -186,7 +185,7 @@ rnTopBinds b
= do { nl <- rnTopBindsLHS emptyFsEnv b
; let bound_names = collectHsValBinders nl
; bindLocalNames bound_names $
rnValBindsRHS noTrimFVs (Just (mkNameSet bound_names)) nl }
rnValBindsRHS (Just (mkNameSet bound_names)) nl }
rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
......@@ -296,17 +295,14 @@ rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
-- Assumes the LHS vars are in scope
--
-- Does not bind the local fixity declarations
rnValBindsRHS :: (FreeVars -> FreeVars) -- for trimming free var sets
-- The trimming function trims the free vars we attach to a
-- binding so that it stays reasonably small
-> Maybe NameSet -- Names bound by the LHSes
rnValBindsRHS :: Maybe NameSet -- Names bound by the LHSes
-- Nothing if expect sigs for imports
-> HsValBindsLR Name RdrName
-> RnM (HsValBinds Name, DefUses)
rnValBindsRHS trim mb_bound_names (ValBindsIn mbinds sigs)
rnValBindsRHS mb_bound_names (ValBindsIn mbinds sigs)
= do { sigs' <- renameSigs mb_bound_names okBindSig sigs
; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds
; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs')) mbinds
; case depAnalBinds binds_w_dus of
(anal_binds, anal_dus) -> return (valbind', valbind'_dus)
where
......@@ -317,10 +313,7 @@ rnValBindsRHS trim mb_bound_names (ValBindsIn mbinds sigs)
-- the uses in the sigs
}
rnValBindsRHS _ _ b = pprPanic "rnValBindsRHS" (ppr b)
noTrimFVs :: FreeVars -> FreeVars
noTrimFVs fvs = fvs
rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)
-- Wrapper for local binds
--
......@@ -332,12 +325,7 @@ rnLocalValBindsRHS :: NameSet -- names bound by the LHSes
-> HsValBindsLR Name RdrName
-> RnM (HsValBinds Name, DefUses)
rnLocalValBindsRHS bound_names binds
= rnValBindsRHS trim (Just bound_names) binds
where
trim fvs = filterNameSet isInternalName fvs
-- Keep Internal Names; these are the non-top-level ones
-- As well as dependency analysis, we need these for the
-- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
= rnValBindsRHS (Just bound_names) binds
-- for local binds
-- wrapper that does both the left- and right-hand sides
......@@ -459,50 +447,54 @@ rnBindLHS _ _ b = pprPanic "rnBindLHS" (ppr b)
-- assumes the left-hands-side vars are in scope
rnBind :: (Name -> [Name]) -- Signature tyvar function
-> (FreeVars -> FreeVars) -- Trimming function for rhs free vars
-> LHsBindLR Name RdrName
-> RnM (LHsBind Name, [Name], Uses)
rnBind _ trim (L loc bind@(PatBind { pat_lhs = pat
, pat_rhs = grhss
rnBind _ (L loc bind@(PatBind { pat_lhs = pat
, pat_rhs = grhss
-- pat fvs were stored in bind_fvs
-- after processing the LHS
, bind_fvs = pat_fvs }))
, bind_fvs = pat_fvs }))
= setSrcSpan loc $
do { let bndrs = collectPatBinders pat
do { mod <- getModule
; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs grhss
; (grhss', fvs) <- rnGRHSs PatBindRhs grhss
-- No scoped type variables for pattern bindings
; let all_fvs = pat_fvs `plusFV` fvs
fvs' = trim all_fvs
; let all_fvs = pat_fvs `plusFV` rhs_fvs
fvs' = filterNameSet (nameIsLocalOrFrom mod) all_fvs
-- Keep locally-defined Names
-- As well as dependency analysis, we need these for the
-- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
; fvs' `seq` -- See Note [Free-variable space leak]
return (L loc (bind { pat_rhs = grhss'
, bind_fvs = fvs' }),
bndrs, all_fvs) }
collectPatBinders pat, all_fvs) }
rnBind sig_fn trim
(L loc bind@(FunBind { fun_id = name
, fun_infix = is_infix
, fun_matches = matches }))
rnBind sig_fn (L loc bind@(FunBind { fun_id = name
, fun_infix = is_infix
, fun_matches = matches }))
-- invariant: no free vars here when it's a FunBind
= setSrcSpan loc $
do { let plain_name = unLoc name
; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
-- bindSigTyVars tests for Opt_ScopedTyVars
rnMatchGroup (FunRhs plain_name is_infix) matches
; let fvs' = trim fvs
rnMatchGroup (FunRhs plain_name is_infix) matches
; when is_infix $ checkPrecMatch plain_name matches'
; fvs' `seq` -- See Note [Free-variable space leak]
; mod <- getModule
; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs
-- Keep locally-defined Names
-- As well as dependency analysis, we need these for the
-- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
; fvs' `seq` -- See Note [Free-variable space leak]
return (L loc (bind { fun_matches = matches'
, bind_fvs = fvs' }),
[plain_name], fvs)
[plain_name], rhs_fvs)
}
rnBind _ _ b = pprPanic "rnBind" (ppr b)
rnBind _ b = pprPanic "rnBind" (ppr b)
{-
Note [Free-variable space leak]
......
......@@ -1202,9 +1202,12 @@ tcInstSig sig_fn use_skols name
-------------------------------
data GeneralisationPlan
= NoGen -- No generalisation, no AbsBinds
| InferGen -- Implicit generalisation; there is an AbsBinds
Bool -- True <=> apply the MR; generalise only unconstrained type vars
Bool -- True <=> bindings mention only variables with closed types
-- See Note [Bindings with closed types] in TcRnTypes
| CheckGen TcSigInfo -- Explicit generalisation; there is an AbsBinds
-- A consequence of the no-AbsBinds choice (NoGen) is that there is
......@@ -1243,11 +1246,16 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
-- 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 (ATcId { tct_closed = cl }) <- lookupNameEnv type_env name
= isTopLevel cl -- This is the key line
| 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!
AThing {} -> pprPanic "is_closed_id" (ppr name)
| otherwise
= WARN( isInternalName name, ppr name ) True
-- The free-var set for a top level binding mentions
......
......@@ -546,7 +546,41 @@ pprTcTyThingCategory (AThing {}) = ptext (sLit "Kinded thing")
Note [Bindings with closed types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
TODO: write me. This is all to do with OutsideIn
Consider
f x = let g ys = map not ys
in ...
Can we generalise 'g' under the OutsideIn algorithm? Yes,
becuase all g's free variables are top-level; that is they themselves
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,
iff
a) all its free variables are imported, or are themselves closed
b) generalisation is not restricted by the monomorphism restriction
Under OutsideIn we are free to generalise a closed let-binding.
This is an extension compared to the JFP paper on OutsideIn, which
used "top-level" as a proxy for "closed". (It's not a good proxy
anyway -- the MR can make a top-level binding with a free type
variable.)
Note that:
* A top-level binding may not be closed, if it suffer from the MR
* A nested binding may be closed (eg 'g' in the example we started with)
Indeed, that's the point; whether a function is defined at top level
or nested is orthogonal to the question of whether or not it is closed
* A binding may be non-closed because it mentions a lexically scoped
*type variable* Eg
f :: forall a. blah
f x = let g y = ...(y::a)...
\begin{code}
type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, Message))
......
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