From: simonpj@microsoft.com <unknown>
Date: Fri, 29 May 2009 13:11:37 +0000 (+0000)
Subject: Implement -XMonoLocalBinds: a radical new flag
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=903831d5047482725f55581504d35feb1288e545

Implement -XMonoLocalBinds: a radical new flag

The new flag -XMonoLocalBinds tells GHC not to generalise nested
bindings in let or where clauses, unless there is a type signature,
in which case we use it.

I'm thinking about whether this might actually be a good direction for
Haskell go to in, although it seems pretty radical.  Anyway, the flag
is easy to implement (look at how few lines change), and having it
will allow us to experiement with and without.

Just for the record, below are the changes required in the boot
libraries -- ie the places where.  Not quite as minimal as I'd hoped,
but the changes fall into a few standard patterns, and most represent
(in my opinion) sytlistic improvements.  I will not push these patches,
however.

== running darcs what -s --repodir libraries/base
M ./Control/Arrow.hs -2 +4
M ./Data/Data.hs -7 +22
M ./System/IO/Error.hs +1
M ./Text/ParserCombinators/ReadP.hs +1
== running darcs what -s --repodir libraries/bytestring
M ./Data/ByteString/Char8.hs -1 +2
M ./Data/ByteString/Unsafe.hs +1
== running darcs what -s --repodir libraries/Cabal
M ./Distribution/PackageDescription.hs -2 +6
M ./Distribution/PackageDescription/Check.hs +3
M ./Distribution/PackageDescription/Configuration.hs -1 +3
M ./Distribution/ParseUtils.hs -2 +4
M ./Distribution/Simple/Command.hs -1 +4
M ./Distribution/Simple/Setup.hs -12 +24
M ./Distribution/Simple/UserHooks.hs -1 +5
== running darcs what -s --repodir libraries/containers
M ./Data/IntMap.hs -2 +2
== running darcs what -s --repodir libraries/dph
M ./dph-base/Data/Array/Parallel/Arr/BBArr.hs -1 +3
M ./dph-base/Data/Array/Parallel/Arr/BUArr.hs -2 +4
M ./dph-prim-par/Data/Array/Parallel/Unlifted/Distributed/Arrays.hs -6 +10
M ./dph-prim-par/Data/Array/Parallel/Unlifted/Distributed/Combinators.hs -3 +6
M ./dph-prim-seq/Data/Array/Parallel/Unlifted/Sequential/Flat/Permute.hs -2 +4
== running darcs what -s --repodir libraries/syb
M ./Data/Generics/Twins.hs -5 +18
---

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index d764b6d..d3887c1 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -198,6 +198,7 @@ data DynFlag
    | Opt_IncoherentInstances
    | Opt_MonomorphismRestriction
    | Opt_MonoPatBinds
+   | Opt_MonoLocalBinds
    | Opt_ExtendedDefaultRules           -- Use GHC's extended rules for defaulting
    | Opt_ForeignFunctionInterface
    | Opt_UnliftedFFITypes
@@ -1781,6 +1782,7 @@ xFlags = [
   ( "MonomorphismRestriction",          Opt_MonomorphismRestriction, const Supported ),
   -- On by default (which is not strictly H98):
   ( "MonoPatBinds",                     Opt_MonoPatBinds, const Supported ),
+  ( "MonoLocalBinds",                   Opt_MonoLocalBinds, const Supported ),
   ( "RelaxedPolyRec",                   Opt_RelaxedPolyRec, const Supported ),
   ( "ExtendedDefaultRules",             Opt_ExtendedDefaultRules, const Supported ),
   ( "ImplicitParams",                   Opt_ImplicitParams, const Supported ),
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 59cd315..4fd3ae0 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -734,7 +734,7 @@ generalise :: DynFlags -> TopLevelFlag
 -- The returned [TyVar] are all ready to quantify
 
 generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
-  | isMonoGroup dflags bind_list
+  | isMonoGroup dflags top_lvl bind_list sigs
   = do  { extendLIEs lie_req
         ; return ([], [], emptyBag) }
 
@@ -1157,10 +1157,12 @@ tcInstSig use_skols name
                               sig_loc = loc }) }
 
 -------------------
-isMonoGroup :: DynFlags -> [LHsBind Name] -> Bool
+isMonoGroup :: DynFlags -> TopLevelFlag -> [LHsBind Name]
+            -> [TcSigInfo] ->  Bool
 -- No generalisation at all
-isMonoGroup dflags binds
-  = dopt Opt_MonoPatBinds dflags && any is_pat_bind binds
+isMonoGroup dflags top_lvl binds sigs
+  =  (dopt Opt_MonoPatBinds dflags && any is_pat_bind binds)
+  || (dopt Opt_MonoLocalBinds dflags && null sigs && not (isTopLevel top_lvl))
   where
     is_pat_bind (L _ (PatBind {})) = True
     is_pat_bind _                  = False