Commit dc8e6861 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Fix the treatment of 'closed' definitions

The IdBindingInfo field of ATcId serves two purposes

- to control generalisation when we have -XMonoLocalBinds
- to check for floatability when dealing with (static e)

These are related, but not the same, and they'd becomme confused.
Trac #13804 showed this up via an example like this:

  f periph = let sr :: forall a. [a] -> [a]
                 sr = if periph then reverse else id

                 sr2 = sr
                 -- The question: is sr2 generalised?
                 -- It should be, because sr has a type sig
                 -- even though it has periph free
             in
             (sr2 [True], sr2 "c")

Here sr2 should be generalised, despite the free var 'periph'
in 'sr' because 'sr' has a closed type signature.

I documented all this very carefully this time, in TcRnTypes:
  Note [Meaning of IdBindingInfo]
  Note [Bindings with closed types: ClosedTypeId]
parent 98494031
......@@ -64,15 +64,9 @@ Here is a running example:
body are stored in AST at the location of the static form.
* The typechecker verifies that all free variables occurring in the
static form are closed (see Note [Bindings with closed types] in
TcRnTypes). In our example, 'k' is closed, even though it is bound
in a nested let, we are fine.
The typechecker also surrounds the static form with a call to
`GHC.StaticPtr.fromStaticPtr`.
f x = let k = map toUpper
in ...fromStaticPtr (static k)...
static form are floatable to top level (see Note [Meaning of
IdBindingInfo] in TcRnTypes). In our example, 'k' is floatable, even
though it is bound in a nested let, we are fine.
* The desugarer replaces the static form with an application of the
function 'makeStatic' (defined in module GHC.StaticPtr.Internal of
......
......@@ -409,7 +409,7 @@ tcValBinds top_lvl binds sigs thing_inside
-- declared with complete type signatures
-- Do not extend the TcIdBinderStack; instead
-- we extend it on a per-rhs basis in tcExtendForRhs
; tcExtendLetEnvIds top_lvl [(idName id, id) | id <- poly_ids] $ do
; tcExtendSigIds top_lvl poly_ids $ do
{ (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
{ thing <- thing_inside
-- See Note [Pattern synonym builders don't yield dependencies]
......@@ -435,7 +435,8 @@ tcBindGroups _ _ _ [] thing_inside
tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
= do { -- See Note [Closed binder groups]
closed <- isClosedBndrGroup $ snd group
type_env <- getLclTypeEnv
; let closed = isClosedBndrGroup type_env (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
......@@ -501,8 +502,9 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTcId, thing)
go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc
; (binds2, thing) <- tcExtendLetEnv top_lvl closed ids1
(go sccs)
; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn
closed ids1 $
go sccs
; return (binds1 `unionBags` binds2, thing) }
go [] = do { thing <- thing_inside; return (emptyBag, thing) }
......@@ -545,7 +547,7 @@ tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
NonRecursive NonRecursive
closed
[lbind]
; thing <- tcExtendLetEnv top_lvl closed ids thing_inside
; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside
; return (binds1, thing) }
------------------------
......@@ -563,7 +565,7 @@ mkEdges sig_fn binds
-- as explained in Note [Deterministic SCC] in Digraph.
where
no_sig :: Name -> Bool
no_sig n = noCompleteSig (sig_fn n)
no_sig n = not (hasCompleteSig sig_fn n)
keyd_binds = bagToList binds `zip` [0::BKey ..]
......@@ -1297,7 +1299,7 @@ tcMonoBinds _ sig_fn no_gen binds
; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
| (n,id) <- rhs_id_env]
; binds' <- tcExtendLetEnvIds NotTopLevel rhs_id_env $
; binds' <- tcExtendRecIds rhs_id_env $
mapM (wrapLocM tcRhs) tc_binds
; return (listToBag binds', mono_infos) }
......@@ -1617,7 +1619,7 @@ decideGeneralisationPlan
decideGeneralisationPlan dflags lbinds closed sig_fn
| has_partial_sigs = InferGen (and partial_sig_mrs)
| Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig
| mono_local_binds closed = NoGen
| do_not_generalise closed = NoGen
| otherwise = InferGen mono_restriction
where
binds = map unLoc lbinds
......@@ -1638,8 +1640,11 @@ decideGeneralisationPlan dflags lbinds closed sig_fn
mono_restriction = xopt LangExt.MonomorphismRestriction dflags
&& any restricted binds
mono_local_binds ClosedGroup = False
mono_local_binds _ = xopt LangExt.MonoLocalBinds dflags
do_not_generalise (IsGroupClosed _ True) = False
-- The 'True' means that all of the group's
-- free vars have ClosedTypeId=True; so we can ignore
-- -XMonoLocalBinds, and generalise anyway
do_not_generalise _ = xopt LangExt.MonoLocalBinds dflags
-- With OutsideIn, all nested bindings are monomorphic
-- except a single function binding with a signature
......@@ -1661,46 +1666,56 @@ decideGeneralisationPlan dflags lbinds closed sig_fn
-- No args => like a pattern binding
-- Some args => a function binding
no_sig n = noCompleteSig (sig_fn n)
no_sig n = not (hasCompleteSig sig_fn n)
isClosedBndrGroup :: Bag (LHsBind GhcRn) -> TcM IsGroupClosed
isClosedBndrGroup binds = do
type_env <- getLclTypeEnv
if foldUFM (is_closed_ns type_env) True fv_env
then return ClosedGroup
else return $ NonClosedGroup fv_env
isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed
isClosedBndrGroup type_env binds
= IsGroupClosed fv_env type_closed
where
type_closed = allUFM (nameSetAll is_closed_type_id) fv_env
fv_env :: NameEnv NameSet
fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
bindFvs :: HsBindLR GhcRn idR -> [(Name, NameSet)]
bindFvs (FunBind { fun_id = f, bind_fvs = fvs })
= [(unLoc f, fvs)]
bindFvs (FunBind { fun_id = L _ f, bind_fvs = fvs })
= let open_fvs = filterNameSet (not . is_closed) fvs
in [(f, open_fvs)]
bindFvs (PatBind { pat_lhs = pat, bind_fvs = fvs })
= [(b, fvs) | b <- collectPatBinders pat]
= let open_fvs = filterNameSet (not . is_closed) fvs
in [(b, open_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
-- ns are the Names referred to from the RHS of this bind
is_closed :: Name -> ClosedTypeId
is_closed name
| Just thing <- lookupNameEnv type_env name
= case thing of
AGlobal {} -> True
ATcId { tct_info = ClosedLet } -> True
_ -> False
| otherwise
= True -- The free-var set for a top level binding mentions
is_closed_id :: TcTypeEnv -> Name -> Bool
-- See Note [Bindings with closed types] in TcRnTypes
is_closed_id type_env name
is_closed_type_id :: Name -> Bool
-- We're already removed Global and ClosedLet Ids
is_closed_type_id name
| Just thing <- lookupNameEnv type_env name
= case thing of
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)
ATcId { tct_info = NonClosedLet _ cl } -> cl
ATcId { tct_info = NotLetBound } -> False
ATyVar {} -> False
-- In-scope type variables 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
= 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
{- *********************************************************************
* *
......
......@@ -28,7 +28,7 @@ module TcEnv(
-- Local environment
tcExtendKindEnv, tcExtendKindEnvList,
tcExtendTyVarEnv, tcExtendTyVarEnv2,
tcExtendLetEnv, tcExtendLetEnvIds,
tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
tcExtendIdBndrs, tcExtendLocalTypeEnv,
isTypeClosedLetBndr,
......@@ -101,7 +101,7 @@ import Encoding
import FastString
import ListSetOps
import Util
import Maybes( MaybeErr(..) )
import Maybes( MaybeErr(..), orElse )
import qualified GHC.LanguageExtensions as LangExt
import Data.IORef
......@@ -420,40 +420,51 @@ isTypeClosedLetBndr :: Id -> Bool
-- See Note [Bindings with closed types] in TcRnTypes
isTypeClosedLetBndr = noFreeVarsOfType . idType
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]
thing_inside
tcExtendLetEnvIds :: TopLevelFlag -> [(Name, TcId)] -> TcM a -> TcM a
-- Used for both top-level value bindings and and nested let/where-bindings
tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a
-- Used for binding the recurive uses of Ids in a binding
-- both top-level value bindings and and nested let/where-bindings
-- Does not extend the TcIdBinderStack
tcExtendLetEnvIds top_lvl
= tcExtendLetEnvIds' top_lvl ClosedGroup
tcExtendRecIds pairs thing_inside
= tc_extend_local_env NotTopLevel
[ (name, ATcId { tct_id = let_id
, tct_info = NonClosedLet emptyNameSet False })
| (name, let_id) <- pairs ] $
thing_inside
tcExtendLetEnvIds' :: TopLevelFlag -> IsGroupClosed
-> [(Name,TcId)] -> TcM a
-> TcM a
-- Used for both top-level value bindings and and nested let/where-bindings
tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
-- Used for binding the Ids that have a complete user type signature
-- Does not extend the TcIdBinderStack
tcExtendLetEnvIds' top_lvl closed_group pairs thing_inside
tcExtendSigIds top_lvl sig_ids thing_inside
= tc_extend_local_env top_lvl
[ (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 ] $
[ (idName id, ATcId { tct_id = id
, tct_info = info })
| id <- sig_ids
, let closed = isTypeClosedLetBndr id
info = NonClosedLet emptyNameSet closed ]
thing_inside
tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> 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 sig_fn (IsGroupClosed fvs fv_type_closed)
ids thing_inside
= tcExtendIdBndrs [TcIdBndr id top_lvl | id <- ids] $
tc_extend_local_env top_lvl
[ (idName id, ATcId { tct_id = id
, tct_info = mk_tct_info id })
| id <- ids ]
thing_inside
where
mk_tct_info id
| type_closed && isEmptyNameSet rhs_fvs = ClosedLet
| otherwise = NonClosedLet rhs_fvs type_closed
where
name = idName id
rhs_fvs = lookupNameEnv fvs name `orElse` emptyNameSet
type_closed = isTypeClosedLetBndr id &&
(fv_type_closed || hasCompleteSig sig_fn name)
tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
-- For lambda-bound and case-bound Ids
......@@ -470,14 +481,13 @@ tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
tcExtendIdEnv2 names_w_ids thing_inside
= tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel
| (_,mono_id) <- names_w_ids ] $
do { tc_extend_local_env NotTopLevel
[ (name, ATcId { tct_id = id
, tct_info = NotLetBound })
| (name,id) <- names_w_ids] $
thing_inside }
tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)]
-> TcM a -> TcM a
tc_extend_local_env NotTopLevel
[ (name, ATcId { tct_id = id
, tct_info = NotLetBound })
| (name,id) <- names_w_ids]
thing_inside
tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env top_lvl extra_env thing_inside
-- Precondition: the argument list extra_env has TcTyThings
-- that ATcId or ATyVar, but nothing else
......
This diff is collapsed.
......@@ -13,7 +13,7 @@ module TcSigs(
TcPatSynInfo(..),
TcSigFun,
isPartialSig, noCompleteSig, tcIdSigName, tcSigInfoName,
isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName,
completeSigPolyId_maybe,
tcTySigs, tcUserTypeSig, completeSigFromId,
......@@ -144,13 +144,6 @@ errors were dealt with by the renamer.
* *
********************************************************************* -}
type TcSigFun = Name -> Maybe TcSigInfo
-- | No signature or a partial signature
noCompleteSig :: Maybe TcSigInfo -> Bool
noCompleteSig (Just (TcIdSig (CompleteSig {}))) = False
noCompleteSig _ = True
tcIdSigName :: TcIdSigInfo -> Name
tcIdSigName (CompleteSig { sig_bndr = id }) = idName id
tcIdSigName (PartialSig { psig_name = n }) = n
......
{-# LANGUAGE RankNTypes, MonoLocalBinds #-}
module T13804 where
f periph = let sr :: forall a. [a] -> [a]
sr = if periph then reverse else id
sr2 = sr
-- The question: is sr2 generalised?
-- It should be, because sr has a type sig
-- even though it has periph free
in
(sr2 [True], sr2 "c")
......@@ -562,3 +562,4 @@ test('T13333', normal, compile, [''])
test('T13585', [extra_files(['T13585.hs', 'T13585a.hs', 'T13585b.hs'])], run_command, ['$MAKE -s --no-print-directory T13585'])
test('T13651', normal, compile, [''])
test('T13785', normal, compile, [''])
test('T13804', normal, compile, [''])
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