[project @ 2000-02-08 15:34:36 by sewardj]

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

diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index 95d4118..b3de053 100644 (file)
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -12,7 +12,7 @@ module CoreLint (
 
 #include "HsVersions.h"
 
-import IO      ( hPutStr, stderr )
+import IO      ( hPutStr, hPutStrLn, stderr )
 
 import CmdLineOpts      ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug )
 import CoreSyn
@@ -21,7 +21,7 @@ import CoreUtils      ( exprOkForSpeculation )
 
 import Bag
 import Const           ( Con(..), DataCon, conType, conOkForApp, conOkForAlt )
-import Id              ( isConstantId, idMustBeINLINEd )
+import Id              ( mayHaveNoBinding )
 import Var             ( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar, isId )
 import VarSet
 import Subst           ( mkTyVarSubst, substTy )
@@ -32,7 +32,7 @@ import ErrUtils               ( doIfSet, dumpIfSet, ghcExit, Message,
 import PrimRep         ( PrimRep(..) )
 import SrcLoc          ( SrcLoc, noSrcLoc, isNoSrcLoc )
 import Type            ( Type, Kind, tyVarsOfType,
-                         splitFunTy_maybe, mkPiType, mkTyVarTy,
+                         splitFunTy_maybe, mkPiType, mkTyVarTy, unUsgTy,
                          splitForAllTy_maybe, splitTyConApp_maybe,
                          isUnLiftedType, typeKind, 
                          splitAlgTyConApp_maybe,
@@ -60,7 +60,7 @@ and do Core Lint when necessary.
 beginPass :: String -> IO ()
 beginPass pass_name
   | opt_D_show_passes
-  = hPutStr stderr ("*** " ++ pass_name ++ "\n")
+  = hPutStrLn stderr ("*** " ++ pass_name)
   | otherwise
   = return ()
 
@@ -68,6 +68,13 @@ beginPass pass_name
 endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind]
 endPass pass_name dump_flag binds
   = do 
+       -- Report result size if required
+       -- This has the side effect of forcing the intermediate to be evaluated
+       if opt_D_show_passes then
+          hPutStrLn stderr ("    Result size = " ++ show (coreBindsSize binds))
+        else
+          return ()
+
        -- Report verbosely, if required
        dumpIfSet dump_flag pass_name
                  (pprCoreBindings binds)
@@ -212,26 +219,13 @@ lintSingleBinding rec_flag (binder,rhs)
 \begin{code}
 lintCoreExpr :: CoreExpr -> LintM Type
 
-lintCoreExpr (Var var) 
-  | isConstantId var = returnL (idType var)
-       -- Micro-hack here... Class decls generate applications of their
-       -- dictionary constructor, but don't generate a binding for the
-       -- constructor (since it would never be used).  After a single round
-       -- of simplification, these dictionary constructors have been
-       -- inlined (from their UnfoldInfo) to CoCons.  Just between
-       -- desugaring and simplfication, though, they appear as naked, unbound
-       -- variables as the function in an application.
-       -- The hack here simply doesn't check for out-of-scope-ness for
-       -- data constructors (at least, in a function position).
-       -- Ditto primitive Ids
-
-  | otherwise    = checkIdInScope var `seqL` returnL (idType var)
+lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
 
 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
   = lintCoreExpr expr  `thenL` \ expr_ty ->
     lintTy to_ty       `seqL`
     lintTy from_ty     `seqL`
-    checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)     `seqL`
+    checkTys from_ty (unUsgTy expr_ty) (mkCoerceErr from_ty expr_ty)   `seqL`
     returnL to_ty
 
 lintCoreExpr (Note other_note expr)
@@ -566,9 +560,17 @@ checkInScope :: SDoc -> IdOrTyVar -> LintM ()
 checkInScope loc_msg var loc scope errs
   |  isLocallyDefined var 
   && not (var `elemVarSet` scope)
-  && not (isId var && idMustBeINLINEd var)     -- Constructors and dict selectors 
-                                               -- don't have bindings, 
-                                               -- just MustInline prags
+  && not (isId var && mayHaveNoBinding var)
+       -- Micro-hack here... Class decls generate applications of their
+       -- dictionary constructor, but don't generate a binding for the
+       -- constructor (since it would never be used).  After a single round
+       -- of simplification, these dictionary constructors have been
+       -- inlined (from their UnfoldInfo) to CoCons.  Just between
+       -- desugaring and simplfication, though, they appear as naked, unbound
+       -- variables as the function in an application.
+       -- The hack here simply doesn't check for out-of-scope-ness for
+       -- data constructors (at least, in a function position).
+       -- Ditto primitive Ids
   = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc)
   | otherwise
   = (Nothing,errs)