X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreLint.lhs;h=03d4945fa414676860ddf8d56292c7ba1cd773ad;hb=6aa013b48b9a85b643672be56f89f0bd0108db1f;hp=df54d8f056fa90eb4cdbd6cec54d435bdfc01613;hpb=087fdd53c7d6bb6cb17574133abc2de4f1816c7e;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index df54d8f..03d4945 100644
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -7,41 +7,40 @@
 module CoreLint (
 	lintCoreBindings,
 	lintUnfolding, 
-	beginPass, endPass, endPassWithRules
+	showPass, endPass, endPassWithRules
     ) where
 
 #include "HsVersions.h"
 
 import IO		( hPutStr, hPutStrLn, stdout )
 
-import CmdLineOpts      ( DynFlags, dopt_D_show_passes, dopt_DoCoreLinting, 
-			  opt_PprStyle_Debug )
 import CoreSyn
 import Rules            ( RuleBase, pprRuleBase )
-import CoreFVs		( idFreeVars, mustHaveLocalBinding )
-import CoreUtils	( exprOkForSpeculation, coreBindsSize, mkPiType )
+import CoreFVs		( idFreeVars )
+import CoreUtils	( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
 
 import Bag
 import Literal		( literalType )
 import DataCon		( dataConRepType )
-import Var		( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId )
+import Var		( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding )
 import VarSet
-import Subst		( mkTyVarSubst, substTy )
+import Subst		( substTyWith )
 import Name		( getSrcLoc )
 import PprCore
-import ErrUtils		( doIfSet_dyn, dumpIfSet, ghcExit, Message, 
+import ErrUtils		( doIfSet, dumpIfSet_core, ghcExit, Message, showPass,
 			  ErrMsg, addErrLocHdrLine, pprBagOfErrors,
                           WarnMsg, pprBagOfWarnings)
 import SrcLoc		( SrcLoc, noSrcLoc )
-import Type		( Type, tyVarsOfType,
+import Type		( Type, tyVarsOfType, eqType,
 			  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
 
@@ -59,21 +58,14 @@ place for them.  They print out stuff before and after core passes,
 and do Core Lint when necessary.
 
 \begin{code}
-beginPass :: DynFlags -> String -> IO ()
-beginPass dflags pass_name
-  | dopt_D_show_passes dflags
-  = hPutStrLn stdout ("*** " ++ pass_name)
-  | otherwise
-  = return ()
-
-
-endPass :: DynFlags -> String -> Bool -> [CoreBind] -> IO [CoreBind]
+endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
 endPass dflags pass_name dump_flag binds
   = do  
         (binds, _) <- endPassWithRules dflags pass_name dump_flag binds Nothing
         return binds
 
-endPassWithRules :: DynFlags -> String -> Bool -> [CoreBind] -> Maybe RuleBase
+endPassWithRules :: DynFlags -> String -> DynFlag -> [CoreBind] 
+		 -> Maybe RuleBase
                  -> IO ([CoreBind], Maybe RuleBase)
 endPassWithRules dflags pass_name dump_flag binds rules
   = do 
@@ -81,13 +73,13 @@ endPassWithRules dflags pass_name dump_flag binds rules
 
 	-- Report result size if required
 	-- This has the side effect of forcing the intermediate to be evaluated
-	if dopt_D_show_passes dflags then
+	if verbosity dflags >= 2 then
 	   hPutStrLn stdout ("    Result size = " ++ show (coreBindsSize binds))
 	 else
 	   return ()
 
 	-- Report verbosely, if required
-	dumpIfSet dump_flag pass_name
+	dumpIfSet_core dflags dump_flag pass_name
 		  (pprCoreBindings binds $$ case rules of
                                               Nothing -> empty
                                               Just rb -> pprRuleBase rb)
@@ -134,7 +126,7 @@ Outstanding issues:
 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
 
 lintCoreBindings dflags whoDunnit binds
-  | not (dopt_DoCoreLinting dflags)
+  | not (dopt Opt_DoCoreLinting dflags)
   = return ()
 
 lintCoreBindings dflags whoDunnit binds
@@ -157,7 +149,7 @@ lintCoreBindings dflags whoDunnit binds
 				  returnL ()
     lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
 
-    done_lint = doIfSet_dyn dflags dopt_D_show_passes
+    done_lint = doIfSet (verbosity dflags >= 2)
 		        (hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
     warn warnings
       = vcat [
@@ -198,7 +190,7 @@ lintUnfolding :: DynFlags
 	      -> (Maybe Message, Maybe Message)		-- (Nothing,_) => OK
 
 lintUnfolding dflags locn vars expr
-  | not (dopt_DoCoreLinting dflags)
+  | not (dopt Opt_DoCoreLinting dflags)
   = (Nothing, Nothing)
 
   | otherwise
@@ -312,7 +304,7 @@ lintCoreExpr e@(Case scrut var alts)
    addInScopeVars [var]				(
 
 	-- Check the alternatives
-   checkAllCasesCovered e scrut_ty alts	`seqL`
+   checkCaseAlts e scrut_ty alts		`seqL`
 
    mapL (lintCoreAlt scrut_ty) alts		`thenL` \ (alt_ty : alt_tys) ->
    mapL (check alt_ty) alt_tys			`seqL`
@@ -383,7 +375,7 @@ lintTyApp ty arg_ty
 		-- 	error :: forall a:*. String -> a
 		-- and then apply it to both boxed and unboxed types.
 	 then
-	    returnL (substTy (mkTyVarSubst [tyvar] [arg_ty]) body)
+	    returnL (substTyWith [tyvar] [arg_ty] body)
 	else
 	    addErrL (mkKindErrMsg tyvar arg_ty)
 
@@ -404,46 +396,30 @@ lintTyApps fun_ty (arg_ty : arg_tys)
 %************************************************************************
 
 \begin{code}
-checkAllCasesCovered :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
-
-checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e)
-
-checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL
-
-checkAllCasesCovered e scrut_ty alts
-  = case splitTyConApp_maybe scrut_ty of {
-	Nothing	-> addErrL (badAltsMsg e);
-	Just (tycon, tycon_arg_tys) ->
-
-    if isPrimTyCon tycon then
-	checkL (hasDefault alts) (nonExhaustiveAltsMsg e)
-    else
-{-		No longer needed
-#ifdef DEBUG
-	-- Algebraic cases are not necessarily exhaustive, because
-	-- the simplifer correctly eliminates case that can't 
-	-- possibly match.
-	-- This code just emits a message to say so
-    let
-	missing_cons    = filter not_in_alts (tyConDataCons tycon)
-	not_in_alts con = all (not_in_alt con) alts
-	not_in_alt con (DataCon con', _, _) = con /= con'
-	not_in_alt con other		    = True
+checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
+-- a) Check that the alts are non-empty
+-- b) Check that the DEFAULT comes first, if it exists
+-- c) Check that there's a default for infinite types
+-- NB: Algebraic cases are not necessarily exhaustive, because
+--     the simplifer correctly eliminates case that can't 
+--     possibly match.
+
+checkCaseAlts e ty [] 
+  = addErrL (mkNullAltsMsg e)
+
+checkCaseAlts e ty alts
+  = checkL (all non_deflt con_alts) (mkNonDefltMsg e)	`seqL`
+    checkL (isJust maybe_deflt || not is_infinite_ty)
+	   (nonExhaustiveAltsMsg e)
+  where
+    (con_alts, maybe_deflt) = findDefault alts
 
-	case_bndr = case e of { Case _ bndr alts -> bndr }
-    in
-    if not (hasDefault alts || null missing_cons) then
-	pprTrace "Exciting (but not a problem)!  Non-exhaustive case:"
-		 (ppr case_bndr <+> ppr missing_cons)
-		 nopL
-    else
-#endif
--}
-    nopL }
-
-hasDefault []			  = False
-hasDefault ((DEFAULT,_,_) : alts) = True
-hasDefault (alt		  : alts) = hasDefault alts
+    non_deflt (DEFAULT, _, _) = False
+    non_deflt alt	      = True
+
+    is_infinite_ty = case splitTyConApp_maybe ty of
+			Nothing			    -> False
+			Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
 \end{code}
 
 \begin{code}
@@ -475,7 +451,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)
@@ -574,9 +550,6 @@ checkL False msg = addErrL msg
 addErrL :: Message -> LintM a
 addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns)
 
-addWarnL :: Message -> LintM a
-addWarnL msg loc scope errs warns = (Nothing, errs, addErr warns msg loc)
-
 addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
 -- errors or warnings, actually... they're the same type.
 addErr errs_so_far msg locs
@@ -622,8 +595,8 @@ checkTys :: Type -> Type -> Message -> LintM ()
 -- check ty2 is subtype of ty1 (ie, has same structure but usage
 -- annotations need only be consistent, not equal)
 checkTys ty1 ty2 msg
-  | ty1 == ty2 = nopL
-  | otherwise  = addErrL msg
+  | ty1 `eqType` ty2 = nopL
+  | otherwise        = addErrL msg
 \end{code}
 
 
@@ -688,15 +661,13 @@ mkScrutMsg var scrut_ty
 	  text "Result binder type:" <+> ppr (idType var),
 	  text "Scrutinee type:" <+> ppr scrut_ty]
 
-badAltsMsg :: CoreExpr -> Message
-badAltsMsg e
-  = hang (text "Case statement scrutinee is not a data type:")
-	 4 (ppr e)
+
+mkNonDefltMsg e
+  = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
 
 nonExhaustiveAltsMsg :: CoreExpr -> Message
 nonExhaustiveAltsMsg e
-  = hang (text "Case expression with non-exhaustive alternatives")
-	 4 (ppr e)
+  = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
 
 mkBadPatMsg :: Type -> Type -> Message
 mkBadPatMsg con_result_ty scrut_ty