[project @ 2005-10-25 12:48:35 by simonmar]

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

diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index 059b351..fc25c9a 100644 (file)
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -14,7 +14,7 @@ module CoreLint (
 
 import CoreSyn
 import CoreFVs         ( idFreeVars )
-import CoreUtils       ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
+import CoreUtils       ( findDefault, exprOkForSpeculation, coreBindsSize )
 import Unify           ( coreRefineTys )
 import Bag
 import Literal         ( literalType )
@@ -30,15 +30,16 @@ import SrcLoc               ( SrcLoc, noSrcLoc, mkSrcSpan )
 import Type            ( Type, tyVarsOfType, coreEqType,
                          splitFunTy_maybe, mkTyVarTys,
                          splitForAllTy_maybe, splitTyConApp_maybe,
-                         isUnLiftedType, typeKind, 
+                         isUnLiftedType, typeKind, mkForAllTy, mkFunTy,
                          isUnboxedTupleType, isSubKind,
                          substTyWith, emptyTvSubst, extendTvInScope, 
-                         TvSubst, TvSubstEnv, setTvSubstEnv, substTy,
+                         TvSubst, TvSubstEnv, mkTvSubst, setTvSubstEnv, substTy,
                          extendTvSubst, composeTvSubst, isInScope,
                          getTvSubstEnv, getTvInScope )
 import TyCon           ( isPrimTyCon )
 import BasicTypes      ( RecFlag(..), Boxity(..), isNonRec )
-import CmdLineOpts
+import StaticFlags     ( opt_PprStyle_Debug )
+import DynFlags                ( DynFlags, DynFlag(..), dopt )
 import Outputable
 
 #ifdef DEBUG
@@ -65,8 +66,8 @@ endPass dflags pass_name dump_flag binds
   = do 
        -- Report result size if required
        -- This has the side effect of forcing the intermediate to be evaluated
-       debugTraceMsg dflags $
-               "    Result size = " ++ show (coreBindsSize binds)
+       debugTraceMsg dflags 2 $
+               (text "    Result size =" <+> int (coreBindsSize binds))
 
        -- Report verbosely, if required
        dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
@@ -103,9 +104,9 @@ Outstanding issues:
     --
     -- Things are *not* OK if:
     --
-    -- * Unsaturated type app before specialisation has been done;
+    --  * Unsaturated type app before specialisation has been done;
     --
-    -- * Oversaturated type app after specialisation (eta reduction
+    --  * Oversaturated type app after specialisation (eta reduction
     --   may well be happening...);
 
 \begin{code}
@@ -119,7 +120,7 @@ lintCoreBindings dflags whoDunnit binds
   = case (initL (lint_binds binds)) of
       Nothing       -> showPass dflags ("Core Linted result of " ++ whoDunnit)
       Just bad_news -> printDump (display bad_news)    >>
-                      ghcExit 1
+                      ghcExit dflags 1
   where
        -- Put all the top-level binders in scope at the start
        -- This is because transformation rules can bring something
@@ -197,8 +198,10 @@ lintSingleBinding rec_flag (binder,rhs)
 %************************************************************************
 
 \begin{code}
+type InType  = Type    -- Substitution not yet applied
+type OutType = Type    -- Substitution has been applied to this
 
-lintCoreExpr :: CoreExpr -> LintM Type
+lintCoreExpr :: CoreExpr -> LintM OutType
 -- The returned type has the substitution from the monad 
 -- already applied to it:
 --     lintCoreExpr e subst = exprType (subst e)
@@ -281,10 +284,14 @@ lintCoreExpr e@(App fun arg)
 
 lintCoreExpr (Lam var expr)
   = addLoc (LambdaBodyOf var) $
-    do { lintBinder var        
-       ; ty <- addInScopeVars [var] $
-                lintCoreExpr expr
-       ; applySubst (mkPiType var ty) }
+    do { body_ty <- addInScopeVars [var] $
+                     lintCoreExpr expr
+       ; if isId var then do
+               { var_ty <- lintId var  
+               ; return (mkFunTy var_ty body_ty) }
+         else
+               return (mkForAllTy var body_ty)
+       }
        -- The applySubst is needed to apply the subst to var
 
 lintCoreExpr e@(Case scrut var alt_ty alts) =
@@ -381,7 +388,7 @@ checkKinds tyvar arg_ty
 %************************************************************************
 
 \begin{code}
-checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
+checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
 -- a) Check that the alts are non-empty
 -- b1) Check that the DEFAULT comes first, if it exists
 -- b2) Check that the others are in increasing order
@@ -414,15 +421,13 @@ checkCaseAlts e ty alts =
 \end{code}
 
 \begin{code}
-checkAltExpr :: CoreExpr -> Type -> LintM ()
-checkAltExpr expr ty   
+checkAltExpr :: CoreExpr -> OutType -> LintM ()
+checkAltExpr expr ann_ty
   = do { actual_ty <- lintCoreExpr expr 
-       ; ty' <- applySubst ty
-       ; checkTys actual_ty ty' (mkCaseAltMsg expr actual_ty ty') }
+       ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
 
-lintCoreAlt :: Type                    -- Type of scrutinee; a fixed point of 
-                                       --                    the substitution
-            -> Type                     -- Type of the alternative
+lintCoreAlt :: OutType                 -- Type of scrutinee
+            -> OutType          -- Type of the alternative
            -> CoreAlt
            -> LintM ()
 
@@ -432,8 +437,7 @@ lintCoreAlt scrut_ty alt_ty alt@(DEFAULT, args, rhs) =
 
 lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) = 
   do { checkL (null args) (mkDefaultArgsMsg args)
-     ; checkTys lit_ty scrut_ty
-         (mkBadPatMsg lit_ty scrut_ty) 
+     ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)  
      ; checkAltExpr rhs alt_ty } 
   where
     lit_ty = literalType lit
@@ -472,7 +476,11 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
        ; con_type <- lintTyApps (dataConRepType con) tvs'
        ; mapM lintBinder ids   -- Lint Ids in the refined world
        ; lintCoreArgs con_type (map Var ids)
-       ; checkAltExpr rhs alt_ty
+       ; let refined_alt_ty = substTy (mkTvSubst in_scope refine) alt_ty
+               -- alt_ty is already an OutType, so don't re-apply 
+               -- the current substitution.  But we must apply the
+               -- refinement so that the check in checkAltExpr is ok
+       ; checkAltExpr rhs refined_alt_ty
     } } }
 
   | otherwise  -- Scrut-ty is wrong shape
@@ -490,7 +498,7 @@ lintBinder :: Var -> LintM ()
 lintBinder var | isId var  = lintId var >> return ()
               | otherwise = return ()
 
-lintId :: Var -> LintM Type
+lintId :: Var -> LintM OutType
 -- ToDo: lint its rules
 lintId id
   = do         { checkL (not (isUnboxedTupleType (idType id))) 
@@ -498,7 +506,7 @@ lintId id
                -- No variable can be bound to an unboxed tuple.
        ; lintTy (idType id) }
 
-lintTy :: Type -> LintM Type
+lintTy :: InType -> LintM OutType
 -- Check the type, and apply the substitution to it
 -- ToDo: check the kind structure of the type
 lintTy ty