From 10ffe4f78dc4bd53d5bc2da1deb8a67669ccb476 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Sat, 22 Jul 2006 10:22:45 +0000
Subject: [PATCH] Add -fmono-pat-binds, and make it the default

In Haskell 98, pattern bindings are generalised.  Thus in
	(f,g) = (\x->x, \y->y)
both f and g will get polymorphic types.  I have become convinced
that generalisation for pattern-bound variables is just a bridge
toof far. It is (I claim) almost never needed, and it adds significant
complication.  (All the more so if we add bang patterns.)

So the flag -fmono-pat-binds switches off generalisation for pattern
bindings.  (A single variable is treated as a degnerate funtction
binding.)

Furthremore, as an experiment, I'm making it the default.  I want
to see how many progarms fail with monomorphic pattern bindings.

You can recover the standard behaviour with -fno-mono-pa-binds.
---
 compiler/main/DynFlags.hs      |    6 ++++++
 compiler/typecheck/TcBinds.lhs |   34 ++++++++++++++++++++++++----------
 2 files changed, 30 insertions(+), 10 deletions(-)

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 6c5bfd6..731ac29 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -145,6 +145,7 @@ data DynFlag
    | Opt_AllowUndecidableInstances
    | Opt_AllowIncoherentInstances
    | Opt_MonomorphismRestriction
+   | Opt_MonoPatBinds
    | Opt_GlasgowExts
    | Opt_FFI
    | Opt_PArr			       -- syntactic support for parallel arrays
@@ -392,6 +393,10 @@ defaultDynFlags =
     	    Opt_RecompChecking,
     	    Opt_ReadUserPackageConf,
     
+	    Opt_MonoPatBinds, 	-- Experimentally, I'm making this non-standard
+				-- behaviour the default, to see if anyone notices
+				-- SLPJ July 06
+
     	    Opt_ImplicitPrelude,
     	    Opt_MonomorphismRestriction,
     	    Opt_Strictness,
@@ -992,6 +997,7 @@ fFlags = [
   ( "scoped-type-variables",  		Opt_ScopedTypeVariables ),
   ( "bang-patterns",	  		Opt_BangPatterns ),
   ( "monomorphism-restriction",		Opt_MonomorphismRestriction ),
+  ( "mono-pat-binds",			Opt_MonoPatBinds ),
   ( "implicit-params",			Opt_ImplicitParams ),
   ( "allow-overlapping-instances", 	Opt_AllowOverlappingInstances ),
   ( "allow-undecidable-instances", 	Opt_AllowUndecidableInstances ),
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index d115f34..d9b76d2 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -15,7 +15,8 @@ module TcBinds ( tcLocalBinds, tcTopBinds,
 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
 import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
 
-import DynFlags		( DynFlag(Opt_MonomorphismRestriction, Opt_GlasgowExts) )
+import DynFlags		( dopt, DynFlags,
+			  DynFlag(Opt_MonomorphismRestriction, Opt_MonoPatBinds, Opt_GlasgowExts) )
 import HsSyn		( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..),
 			  HsLocalBinds(..), HsValBinds(..), HsIPBinds(..),
 			  LSig, Match(..), IPBind(..), Prag(..),
@@ -363,10 +364,10 @@ tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds
 		   [poly_id | (_, poly_id, _, _) <- exports]) }	-- Guaranteed zonked
 
     else do	-- The normal lifted case: GENERALISE
-  { is_unres <- isUnRestrictedGroup bind_list sig_fn
+  { dflags <- getDOpts 
   ; (tyvars_to_gen, dict_binds, dict_ids)
 	<- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
-	   generalise top_lvl is_unres mono_bind_infos lie_req
+	   generalise dflags top_lvl bind_list sig_fn mono_bind_infos lie_req
 
 	-- FINALISE THE QUANTIFIED TYPE VARIABLES
 	-- The quantified type variables often include meta type variables
@@ -699,11 +700,15 @@ getMonoBindInfo tc_binds
 %************************************************************************
 
 \begin{code}
-generalise :: TopLevelFlag -> Bool 
+generalise :: DynFlags -> TopLevelFlag 
+	   -> [LHsBind Name] -> TcSigFun 
 	   -> [MonoBindInfo] -> [Inst]
 	   -> TcM ([TcTyVar], TcDictBinds, [TcId])
-generalise top_lvl is_unrestricted mono_infos lie_req
-  | not is_unrestricted	-- RESTRICTED CASE
+generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
+  | isMonoGroup dflags bind_list
+  = do { extendLIEs lie_req; return ([], emptyBag, []) }
+
+  | isRestrictedGroup dflags bind_list sig_fn 	-- RESTRICTED CASE
   = 	-- Check signature contexts are empty 
     do	{ checkTc (all is_mono_sig sigs)
 	  	  (restrictedBindCtxtErr bndrs)
@@ -1070,11 +1075,20 @@ tcInstSig use_skols name scoped_names
 		       | otherwise = []
 
 -------------------
-isUnRestrictedGroup :: [LHsBind Name] -> TcSigFun -> TcM Bool
-isUnRestrictedGroup binds sig_fn
-  = do	{ mono_restriction <- doptM Opt_MonomorphismRestriction
-	; return (not mono_restriction || all_unrestricted) }
+isMonoGroup :: DynFlags -> [LHsBind Name] -> Bool
+-- No generalisation at all
+isMonoGroup dflags binds
+  = dopt Opt_MonoPatBinds dflags && any is_pat_bind binds
+  where
+    is_pat_bind (L _ (PatBind {})) = True
+    is_pat_bind other	           = False
+
+-------------------
+isRestrictedGroup :: DynFlags -> [LHsBind Name] -> TcSigFun -> Bool
+isRestrictedGroup dflags binds sig_fn
+  = mono_restriction && not all_unrestricted
   where 
+    mono_restriction = dopt Opt_MonomorphismRestriction dflags
     all_unrestricted = all (unrestricted . unLoc) binds
     has_sig n = isJust (sig_fn n)
 
-- 
1.7.10.4