From: simonmar <unknown>
Date: Fri, 25 Jan 2002 10:28:15 +0000 (+0000)
Subject: [project @ 2002-01-25 10:28:12 by simonmar]
X-Git-Tag: Approximately_9120_patches~257
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=893a774d698f90cd2915cd5305b15bc02e1afb40

[project @ 2002-01-25 10:28:12 by simonmar]
Convert -fno-monomorphism-restriction into a dynamic flag.  Fixes bug
#508177.
---

diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 529bbae..e6fadc0 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -66,7 +66,6 @@ module CmdLineOpts (
 	opt_NumbersStrict,
 	opt_Parallel,
 	opt_SMP,
-	opt_NoMonomorphismRestriction,
 	opt_RuntimeTypes,
 
 	-- optimisation opts
@@ -286,6 +285,7 @@ data DynFlag
    | Opt_AllowOverlappingInstances
    | Opt_AllowUndecidableInstances
    | Opt_AllowIncoherentInstances
+   | Opt_NoMonomorphismRestriction
    | Opt_GlasgowExts
    | Opt_Generics
    | Opt_NoImplicitPrelude 
@@ -559,7 +559,6 @@ opt_DoTickyProfiling		= lookUp  SLIT("-fticky-ticky")
 
 -- language opts
 opt_AllStrict			= lookUp  SLIT("-fall-strict")
-opt_NoMonomorphismRestriction	= lookUp  SLIT("-fno-monomorphism-restriction")
 opt_DictsStrict			= lookUp  SLIT("-fdicts-strict")
 opt_IrrefutableTuples		= lookUp  SLIT("-firrefutable-tuples")
 opt_MaxContextReductionDepth	= lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH
diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs
index 8927080..a507e8f 100644
--- a/ghc/compiler/main/DriverFlags.hs
+++ b/ghc/compiler/main/DriverFlags.hs
@@ -1,7 +1,7 @@
 {-# OPTIONS -#include "hschooks.h" #-}
 
 -----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.84 2002/01/04 16:02:04 simonmar Exp $
+-- $Id: DriverFlags.hs,v 1.85 2002/01/25 10:28:14 simonmar Exp $
 --
 -- Driver flags
 --
@@ -418,6 +418,8 @@ dynamic_flags = [
 
 	-- "active negatives"
   ,  ( "fno-implicit-prelude",  NoArg (setDynFlag Opt_NoImplicitPrelude) )
+  ,  ( "fno-monomorphism-restriction",	
+			NoArg (setDynFlag Opt_NoMonomorphismRestriction) )
 
 	-- the rest of the -f* and -fno-* flags
   ,  ( "fno-", 		PrefixPred (\f -> isFFlag f) (\f -> unSetDynFlag (getFFlag f)) )
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 35f3923..8dad853 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -12,7 +12,7 @@ module TcBinds ( tcBindsAndThen, tcTopBinds,
 import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
 import {-# SOURCE #-} TcExpr  ( tcExpr )
 
-import CmdLineOpts	( opt_NoMonomorphismRestriction )
+import CmdLineOpts	( DynFlag(Opt_NoMonomorphismRestriction) )
 import HsSyn		( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), 
 			  Match(..), HsMatchContext(..), 
 			  collectMonoBinders, andMonoBinds,
@@ -412,9 +412,16 @@ is doing.
 %************************************************************************
 
 \begin{code}
-generalise binder_names mbind tau_tvs lie_req sigs
-  | not is_unrestricted 	-- RESTRICTED CASE
-  = 	-- Check signature contexts are empty 
+generalise binder_names mbind tau_tvs lie_req sigs =
+
+  -- check for -fno-monomorphism-restriction
+  doptsTc Opt_NoMonomorphismRestriction		`thenTc` \ no_MR ->
+  let is_unrestricted | no_MR 	  = True
+		      | otherwise = isUnRestrictedGroup tysig_names mbind
+  in
+
+  if not is_unrestricted then 	-- RESTRICTED CASE
+   	-- Check signature contexts are empty 
     checkTc (all is_mono_sig sigs)
 	    (restrictedBindCtxtErr binder_names)	`thenTc_`
 
@@ -427,13 +434,13 @@ generalise binder_names mbind tau_tvs lie_req sigs
 
     returnTc (qtvs, lie_free, binds, [])
 
-  | null sigs			-- UNRESTRICTED CASE, NO TYPE SIGS
-  = tcSimplifyInfer doc tau_tvs lie_req
+  else if null sigs then	-- UNRESTRICTED CASE, NO TYPE SIGS
+    tcSimplifyInfer doc tau_tvs lie_req
 
-  | otherwise			-- UNRESTRICTED CASE, WITH TYPE SIGS
-  = 	-- CHECKING CASE: Unrestricted group, there are type signatures
+  else 				-- UNRESTRICTED CASE, WITH TYPE SIGS
+   	-- CHECKING CASE: Unrestricted group, there are type signatures
 	-- Check signature contexts are empty 
-    checkSigsCtxts sigs				`thenTc` \ (sig_avails, sig_dicts) ->
+    checkSigsCtxts sigs			`thenTc` \ (sig_avails, sig_dicts) ->
     
 	-- Check that the needed dicts can be
 	-- expressed in terms of the signature ones
@@ -445,9 +452,6 @@ generalise binder_names mbind tau_tvs lie_req sigs
     returnTc (forall_tvs, lie_free, dict_binds, sig_dicts)
 
   where
-    is_unrestricted | opt_NoMonomorphismRestriction = True
-		    | otherwise			    = isUnRestrictedGroup tysig_names mbind
-
     tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- sigs]
     is_mono_sig (TySigInfo _ _ _ theta _ _ _ _) = null theta