X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreLint.lhs;h=b3de053517497ffd381bcfc848d71f4691f73dad;hb=70f68d805ea528a9f3aba3987f4f63e78d32e4f8;hp=95d411808dff25a9cb8a09a0a892f1da5b5bc430;hpb=f016a43fcbcca53a284e8d6206705ed468a97736;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index 95d4118..b3de053 100644
--- 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)