[project @ 2002-04-05 23:24:25 by sof]

[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreLint.lhs

diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index e5744e1..768cead 100644 (file)
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -7,7 +7,7 @@
 module CoreLint (
        lintCoreBindings,
        lintUnfolding, 
-       showPass, endPass, endPassWithRules
+       showPass, endPass
     ) where
 
 #include "HsVersions.h"
@@ -15,7 +15,6 @@ module CoreLint (
 import IO              ( hPutStr, hPutStrLn, stdout )
 
 import CoreSyn
-import Rules            ( RuleBase, pprRuleBase )
 import CoreFVs         ( idFreeVars )
 import CoreUtils       ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
 
@@ -24,7 +23,7 @@ import Literal                ( literalType )
 import DataCon         ( dataConRepType )
 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, dumpIfSet_core, ghcExit, Message, showPass,
@@ -49,28 +48,18 @@ infixr 9 `thenL`, `seqL`
 
 %************************************************************************
 %*                                                                     *
-\subsection{Start and end pass}
+\subsection{End pass}
 %*                                                                     *
 %************************************************************************
 
-@beginPass@ and @endPass@ don't really belong here, but it makes a convenient
+@showPass@ and @endPass@ don't really belong here, but it makes a convenient
 place for them.  They print out stuff before and after core passes,
 and do Core Lint when necessary.
 
 \begin{code}
 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 -> DynFlag -> [CoreBind] 
-                -> Maybe RuleBase
-                 -> IO ([CoreBind], Maybe RuleBase)
-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 verbosity dflags >= 2 then
@@ -79,16 +68,12 @@ endPassWithRules dflags pass_name dump_flag binds rules
           return ()
 
        -- Report verbosely, if required
-       dumpIfSet_core dflags dump_flag pass_name
-                 (pprCoreBindings binds $$ case rules of
-                                              Nothing -> empty
-                                              Just rb -> pprRuleBase rb)
+       dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
 
        -- Type check
        lintCoreBindings dflags pass_name binds
-        -- ToDo: lint the rules
 
-       return (binds, rules)
+       return binds
 \end{code}
 
 
@@ -375,7 +360,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)
 
@@ -451,6 +436,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.
+       -- NB: relies on existential type args coming *after* ordinary type args
     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 ->
@@ -553,7 +539,7 @@ addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns)
 addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
 -- errors or warnings, actually... they're the same type.
 addErr errs_so_far msg locs
-  = ASSERT( not (null locs) )
+  = ASSERT( notNull locs )
     errs_so_far `snocBag` mk_msg msg
   where
    (loc, cxt1) = dumpLoc (head locs)