From: sof <unknown>
Date: Tue, 30 Mar 1999 11:26:24 +0000 (+0000)
Subject: [project @ 1999-03-30 11:26:18 by sof]
X-Git-Tag: Approximately_9120_patches~6337
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=db85bf1cc51d2e428175ccf2f3608014e9459ba8;p=ghc-hetmet.git

[project @ 1999-03-30 11:26:18 by sof]
New compiler option -fignore-asserts: Causes

    (PrelGHC.assert pred expr)

to be rewritten to (expr).
---

diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 821882c..08aa38f 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -60,6 +60,7 @@ module CmdLineOpts (
 	opt_HiMap,
 	opt_HiVersion,
 	opt_IgnoreIfacePragmas,
+	opt_IgnoreAsserts,
 	opt_IrrefutableTuples,
 	opt_LiberateCaseThreshold,
         opt_MaxContextReductionDepth,
@@ -328,6 +329,7 @@ opt_GlasgowExts			= lookUp  SLIT("-fglasgow-exts")
 opt_HiMap 			= lookup_str "-himap="       -- file saying where to look for .hi files
 opt_HiVersion			= lookup_def_int "-fhi-version=" 0 -- what version we're compiling.
 opt_IgnoreIfacePragmas		= lookUp  SLIT("-fignore-interface-pragmas")
+opt_IgnoreAsserts               = lookUp  SLIT("-fignore-asserts")
 opt_IrrefutableTuples		= lookUp  SLIT("-firrefutable-tuples")
 opt_MaxContextReductionDepth	= lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH
 opt_MultiParamClasses		= opt_GlasgowExts
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index b990ab7..16f9da4 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -25,7 +25,7 @@ import RdrHsSyn
 import RnHsSyn
 import RnMonad
 import RnEnv
-import CmdLineOpts	( opt_GlasgowExts )
+import CmdLineOpts	( opt_GlasgowExts, opt_IgnoreAsserts )
 import BasicTypes	( Fixity(..), FixityDirection(..) )
 import PrelInfo		( numClass_RDR, fractionalClass_RDR, eqClass_RDR, 
 			  ccallableClass_RDR, creturnableClass_RDR, 
@@ -36,7 +36,9 @@ import PrelInfo		( numClass_RDR, fractionalClass_RDR, eqClass_RDR,
 import TysPrim		( charPrimTyCon, addrPrimTyCon, intPrimTyCon, 
 			  floatPrimTyCon, doublePrimTyCon
 			)
-import Name		( nameUnique, isLocallyDefined, NamedThing(..) )
+import Name		( nameUnique, isLocallyDefined, NamedThing(..)
+                        , mkSysLocalName, nameSrcLoc
+			)
 import NameSet
 import UniqFM		( isNullUFM )
 import FiniteMap	( elemFM )
@@ -741,11 +743,30 @@ mkAssertExpr =
   newImportedGlobalFromRdrName assertErr_RDR	`thenRn` \ name ->
   addOccurrenceName name				`thenRn_`
   getSrcLocRn           				`thenRn` \ sloc ->
-  let
-   expr = HsApp (HsVar name)
+
+    -- if we're ignoring asserts, return (\ _ e -> e)
+    -- if not, return (assertError "src-loc")
+
+  if opt_IgnoreAsserts then
+    getUniqRn				`thenRn` \ uniq ->
+    let
+     vname = mkSysLocalName uniq SLIT("v")
+     expr  = HsLam ignorePredMatch
+     loc   = nameSrcLoc vname
+     ignorePredMatch = Match [] [WildPatIn, VarPatIn vname] Nothing 
+                             (GRHSs [GRHS [ExprStmt (HsVar vname) loc] loc]
+			            EmptyBinds Nothing)
+    in
+    returnRn expr
+  else
+    let
+     expr = 
+          HsApp (HsVar name)
 	        (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
-  in
-  returnRn expr
+
+    in
+    returnRn expr
+
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 456ce08..1d3578a 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -705,6 +705,15 @@ newInstUniq key (RnDown {rn_ns = names_var}) l_down
     in
     writeMutVarSST names_var (us, mapInst', cache)	`thenSST_`
     returnSST uniq
+
+getUniqRn :: RnM s d Unique
+getUniqRn (RnDown {rn_ns = names_var}) l_down
+ = readMutVarSST names_var `thenSST` \ (us, mapInst, cache) ->
+   let
+     (us1,us') = splitUniqSupply us
+   in
+   writeMutVarSST names_var (us', mapInst, cache)  `thenSST_`
+   returnSST (uniqFromSupply us1)
 \end{code}
 
 ================  Occurrences =====================
diff --git a/ghc/docs/users_guide/glasgow_exts.vsgml b/ghc/docs/users_guide/glasgow_exts.vsgml
index 07f2049..9d0afcd 100644
--- a/ghc/docs/users_guide/glasgow_exts.vsgml
+++ b/ghc/docs/users_guide/glasgow_exts.vsgml
@@ -1,5 +1,5 @@
 % 
-% $Id: glasgow_exts.vsgml,v 1.7 1999/03/26 19:50:31 sof Exp $
+% $Id: glasgow_exts.vsgml,v 1.8 1999/03/30 11:26:24 sof Exp $
 %
 % GHC Language Extensions.
 %
@@ -1493,8 +1493,8 @@ stands, unless there are convincing reasons to change it.
 <label id="sec:assertions">
 <p>
 
-If you want to use assertions in your standard Haskell code, you
-could define something like the following:
+If you want to make use of assertions in your standard Haskell code, you
+could define a function like the following:
 
 <tscreen><verb>
 assert :: Bool -> a -> a
@@ -1503,7 +1503,7 @@ assert _     x = x
 </verb></tscreen>
 
 which works, but gives you back a less than useful error message --
-an assertion failed, but which?
+an assertion failed, but which and where?
 
 One way out is to define an extended <tt/assert/ function which also
 takes a descriptive string to include in the error message and
@@ -1522,13 +1522,17 @@ Ghc will rewrite this to also include the source location where the
 assertion was made, 
 
 <tscreen><verb>
-assert pred val ==> assertError "Main.hs,15" pred val
+assert pred val ==> assertError "Main.hs|15" pred val
 </verb></tscreen>
 
 The rewrite is only performed by the compiler when applications of
 <tt>Exception.assert</tt> are spotted, so you can still define and use
 your own versions of <tt/assert/, should you so wish. If not, import
-<tt/Exception/ to use <tt/assert/ in your code.
+<tt/Exception/ to make use <tt/assert/ in your code.
+
+To have the compiler ignore uses of assert, use the compiler option
+@-fignore-asserts@. <nidx>-fignore-asserts option</nidx> That is,
+expressions of the form @assert pred e@ will be rewritten to @e@.
 
 Assertion failures can be caught, see the documentation for the
 Hugs/GHC Exception library for information of how.
diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl
index abcef32..10415f2 100644
--- a/ghc/driver/ghc.lprl
+++ b/ghc/driver/ghc.lprl
@@ -3055,6 +3055,7 @@ arg: while($_ = $Args[0]) {
     /^-keep-s-files?-too$/	&& do { $Keep_s_file_too = 1;  next arg; };
 
     /^-fignore-interface-pragmas$/ && do { push(@HsC_flags, $_); next arg; };
+    /^-fignore-asserts$/           && do { push(@HsC_flags, $_); next arg; };
 
     /^-fno-implicit-prelude$/      && do { $NoImplicitPrelude= 1; push(@HsC_flags, $_); next arg; };