X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreLint.lhs;h=5a0c140c6911af9d73808b5dfbd031d4358f5248;hb=a5f9c20a13e80f10a36246f1b4dbdae0f1a93187;hp=6bf156d2524986957df5f592de2b8a07969e5d4b;hpb=76050f0005db82e8de3f13c71d298e14f8d868c2;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index 6bf156d..5a0c140 100644
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -7,14 +7,13 @@
 module CoreLint (
 	lintCoreBindings,
 	lintUnfolding, 
-	beginPass, endPass, endPassWithRules
+	showPass, endPass, endPassWithRules
     ) where
 
 #include "HsVersions.h"
 
-import IO	( hPutStr, hPutStrLn, stdout )
+import IO		( hPutStr, hPutStrLn, stdout )
 
-import CmdLineOpts      ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug )
 import CoreSyn
 import Rules            ( RuleBase, pprRuleBase )
 import CoreFVs		( idFreeVars, mustHaveLocalBinding )
@@ -28,19 +27,20 @@ import VarSet
 import Subst		( mkTyVarSubst, substTy )
 import Name		( getSrcLoc )
 import PprCore
-import ErrUtils		( doIfSet, dumpIfSet, ghcExit, Message, 
+import ErrUtils		( doIfSet_dyn, dumpIfSet, ghcExit, Message, showPass,
 			  ErrMsg, addErrLocHdrLine, pprBagOfErrors,
                           WarnMsg, pprBagOfWarnings)
-import SrcLoc		( SrcLoc, noSrcLoc, isNoSrcLoc )
+import SrcLoc		( SrcLoc, noSrcLoc )
 import Type		( Type, tyVarsOfType,
 			  splitFunTy_maybe, mkTyVarTy,
-			  splitForAllTy_maybe, splitTyConApp_maybe,
+			  splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
 			  isUnLiftedType, typeKind, 
 			  isUnboxedTupleType,
 			  hasMoreBoxityInfo
 			)
-import TyCon		( TyCon, isPrimTyCon, tyConDataCons )
+import TyCon		( isPrimTyCon )
 import BasicTypes	( RecFlag(..), isNonRec )
+import CmdLineOpts
 import Maybe
 import Outputable
 
@@ -58,29 +58,21 @@ place for them.  They print out stuff before and after core passes,
 and do Core Lint when necessary.
 
 \begin{code}
-beginPass :: String -> IO ()
-beginPass pass_name
-  | opt_D_show_passes
-  = hPutStrLn stdout ("*** " ++ pass_name)
-  | otherwise
-  = return ()
-
-
-endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind]
-endPass pass_name dump_flag binds
+endPass :: DynFlags -> String -> Bool -> [CoreBind] -> IO [CoreBind]
+endPass dflags pass_name dump_flag binds
   = do  
-        (binds, _) <- endPassWithRules pass_name dump_flag binds Nothing
+        (binds, _) <- endPassWithRules dflags pass_name dump_flag binds Nothing
         return binds
 
-endPassWithRules :: String -> Bool -> [CoreBind] -> Maybe RuleBase
+endPassWithRules :: DynFlags -> String -> Bool -> [CoreBind] -> Maybe RuleBase
                  -> IO ([CoreBind], Maybe RuleBase)
-endPassWithRules pass_name dump_flag binds rules
+endPassWithRules dflags pass_name dump_flag binds rules
   = do 
         -- ToDo: force the rules?
 
 	-- Report result size if required
 	-- This has the side effect of forcing the intermediate to be evaluated
-	if opt_D_show_passes then
+	if dopt Opt_D_show_passes dflags then
 	   hPutStrLn stdout ("    Result size = " ++ show (coreBindsSize binds))
 	 else
 	   return ()
@@ -92,7 +84,7 @@ endPassWithRules pass_name dump_flag binds rules
                                               Just rb -> pprRuleBase rb)
 
 	-- Type check
-	lintCoreBindings pass_name binds
+	lintCoreBindings dflags pass_name binds
         -- ToDo: lint the rules
 
 	return (binds, rules)
@@ -130,13 +122,13 @@ Outstanding issues:
     --   may well be happening...);
 
 \begin{code}
-lintCoreBindings :: String -> [CoreBind] -> IO ()
+lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
 
-lintCoreBindings whoDunnit binds
-  | not opt_DoCoreLinting
+lintCoreBindings dflags whoDunnit binds
+  | not (dopt Opt_DoCoreLinting dflags)
   = return ()
 
-lintCoreBindings whoDunnit binds
+lintCoreBindings dflags whoDunnit binds
   = case (initL (lint_binds binds)) of
       (Nothing, Nothing)       -> done_lint
 
@@ -156,7 +148,7 @@ lintCoreBindings whoDunnit binds
 				  returnL ()
     lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
 
-    done_lint = doIfSet opt_D_show_passes
+    done_lint = doIfSet_dyn dflags Opt_D_show_passes
 		        (hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
     warn warnings
       = vcat [
@@ -190,19 +182,20 @@ We use this to check all unfoldings that come in from interfaces
 (it is very painful to catch errors otherwise):
 
 \begin{code}
-lintUnfolding :: SrcLoc
+lintUnfolding :: DynFlags 
+	      -> SrcLoc
 	      -> [Var]		-- Treat these as in scope
 	      -> CoreExpr
 	      -> (Maybe Message, Maybe Message)		-- (Nothing,_) => OK
 
-lintUnfolding locn vars expr
-  | not opt_DoCoreLinting
+lintUnfolding dflags locn vars expr
+  | not (dopt Opt_DoCoreLinting dflags)
   = (Nothing, Nothing)
 
   | otherwise
   = initL (addLoc (ImportedUnfolding locn) $
-	     addInScopeVars vars	     $
-	     lintCoreExpr expr)
+	   addInScopeVars vars	           $
+	   lintCoreExpr expr)
 \end{code}
 
 %************************************************************************
@@ -473,7 +466,7 @@ lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
 	-- Scrutinee type must be a tycon applicn; checked by caller
 	-- This code is remarkably compact considering what it does!
 	-- NB: args must be in scope here so that the lintCoreArgs line works.
-    case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) ->
+    case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) ->
 	lintTyApps (dataConRepType con) tycon_arg_tys	`thenL` \ con_type ->
 	lintCoreArgs con_type (map mk_arg args)		`thenL` \ con_result_ty ->
 	checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
@@ -586,9 +579,7 @@ addErr errs_so_far msg locs
    context     | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
 	       | otherwise	    = cxt1
  
-   mk_msg msg
-     | isNoSrcLoc loc = (loc, hang context 4 msg)
-     | otherwise      = addErrLocHdrLine loc context msg
+   mk_msg msg = addErrLocHdrLine loc context msg
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
 addLoc extra_loc m loc scope errs warns