Fix the trimming of bind_fvs (fixes Trac #5439)
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 1 Sep 2011 07:28:36 +0000 (08:28 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 1 Sep 2011 07:28:36 +0000 (08:28 +0100)
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.

compiler/hsSyn/HsBinds.lhs
compiler/rename/RnBinds.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcRnTypes.lhs

index 0a8ff7a..4a57727 100644 (file)
@@ -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
index 36fcfdb..2737752 100644 (file)
@@ -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]
index 2c713e0..0979e45 100644 (file)
@@ -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
index 9060346..5b944aa 100644 (file)
@@ -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))