[project @ 2005-01-31 13:22:57 by simonpj]

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

diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index 724907b..ee5efb7 100644 (file)
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -18,24 +18,26 @@ import CoreUtils    ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
 import Unify           ( coreRefineTys )
 import Bag
 import Literal         ( literalType )
-import DataCon         ( dataConRepType, isVanillaDataCon, dataConTyCon, dataConResTy )
-import Var             ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding )
+import DataCon         ( dataConRepType, isVanillaDataCon, dataConTyCon, dataConResTy, dataConWorkId )
+import TysWiredIn      ( tupleCon )
+import Var             ( Var, Id, TyVar, idType, tyVarKind, mustHaveLocalBinding )
 import VarSet
 import Name            ( getSrcLoc )
 import PprCore
 import ErrUtils                ( dumpIfSet_core, ghcExit, Message, showPass,
                          mkLocMessage, debugTraceMsg )
 import SrcLoc          ( SrcLoc, noSrcLoc, mkSrcSpan )
-import Type            ( Type, tyVarsOfType, eqType,
+import Type            ( Type, tyVarsOfType, coreEqType,
                          splitFunTy_maybe, mkTyVarTys,
                          splitForAllTy_maybe, splitTyConApp_maybe,
                          isUnLiftedType, typeKind, 
                          isUnboxedTupleType, isSubKind,
                          substTyWith, emptyTvSubst, extendTvInScope, 
                          TvSubst, TvSubstEnv, setTvSubstEnv, substTy,
-                         extendTvSubst, isInScope )
-import TyCon           ( isPrimTyCon, TyCon )
-import BasicTypes      ( RecFlag(..), isNonRec )
+                         extendTvSubst, composeTvSubst, isInScope,
+                         getTvSubstEnv, getTvInScope )
+import TyCon           ( isPrimTyCon )
+import BasicTypes      ( RecFlag(..), Boxity(..), isNonRec )
 import CmdLineOpts
 import Outputable
 
@@ -199,7 +201,7 @@ lintSingleBinding rec_flag (binder,rhs)
 lintCoreExpr :: CoreExpr -> LintM Type
 -- The returned type has the substitution from the monad 
 -- already applied to it:
---     lintCoreExpr e subst = exprTpye (subst e)
+--     lintCoreExpr e subst = exprType (subst e)
 
 lintCoreExpr (Var var)
   = do { checkIdInScope var 
@@ -381,7 +383,8 @@ checkKinds tyvar arg_ty
 \begin{code}
 checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
 -- a) Check that the alts are non-empty
--- b) Check that the DEFAULT comes first, if it exists
+-- b1) Check that the DEFAULT comes first, if it exists
+-- b2) Check that the others are in increasing order
 -- 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 
@@ -392,11 +395,16 @@ checkCaseAlts e ty []
 
 checkCaseAlts e ty alts = 
   do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
+     ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
      ; checkL (isJust maybe_deflt || not is_infinite_ty)
           (nonExhaustiveAltsMsg e) }
   where
     (con_alts, maybe_deflt) = findDefault alts
 
+       -- Check that successive alternatives have increasing tags 
+    increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
+    increasing_tag other                    = True
+
     non_deflt (DEFAULT, _, _) = False
     non_deflt alt            = True
 
@@ -412,7 +420,8 @@ checkAltExpr expr ty
        ; ty' <- applySubst ty
        ; checkTys actual_ty ty' (mkCaseAltMsg expr actual_ty ty') }
 
-lintCoreAlt :: Type                    -- Type of scrutinee
+lintCoreAlt :: Type                    -- Type of scrutinee; a fixed point of 
+                                       --                    the substitution
             -> Type                     -- Type of the alternative
            -> CoreAlt
            -> LintM ()
@@ -456,9 +465,11 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
              pat_res_ty = dataConResTy con (mkTyVarTys tvs)          
 
         ; subst <- getTvSubst 
-        ; case coreRefineTys tvs subst pat_res_ty scrut_ty of {
-             Nothing   -> return () ;  -- Alternative is dead code
-             Just senv -> updateTvSubstEnv senv $
+       ; let in_scope  = getTvInScope subst
+             subst_env = getTvSubstEnv subst
+        ; case coreRefineTys in_scope tvs pat_res_ty scrut_ty of {
+             Nothing     -> return () ;        -- Alternative is dead code
+             Just refine -> updateTvSubstEnv (composeTvSubst in_scope refine subst_env) $
     do         { tvs'     <- mapM lintTy (mkTyVarTys tvs)
        ; con_type <- lintTyApps (dataConRepType con) tvs'
        ; mapM lintBinder ids   -- Lint Ids in the refined world
@@ -571,7 +582,6 @@ addInScopeVars :: [Var] -> LintM a -> LintM a
 addInScopeVars vars m = 
   LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
 
--- gaw 2004
 updateTvSubstEnv :: TvSubstEnv -> LintM a -> LintM a
 updateTvSubstEnv substenv m = 
   LintM (\ loc subst errs -> unLintM m loc (setTvSubstEnv subst substenv) errs)
@@ -590,7 +600,12 @@ extendSubstL tv ty m
 \begin{code}
 checkIdInScope :: Var -> LintM ()
 checkIdInScope id 
-  = checkInScope (ptext SLIT("is out of scope")) id
+  = do { checkL (not (id == oneTupleDataConId))
+               (ptext SLIT("Illegal one-tuple"))
+       ; checkInScope (ptext SLIT("is out of scope")) id }
+
+oneTupleDataConId :: Id        -- Should not happen
+oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
 
 checkBndrIdInScope :: Var -> Var -> LintM ()
 checkBndrIdInScope binder id 
@@ -609,7 +624,7 @@ checkTys :: Type -> Type -> Message -> LintM ()
 -- check ty2 is subtype of ty1 (ie, has same structure but usage
 -- annotations need only be consistent, not equal)
 -- Assumes ty1,ty2 are have alrady had the substitution applied
-checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg
+checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
 \end{code}
 
 %************************************************************************
@@ -676,6 +691,8 @@ mkScrutMsg var scrut_ty
 
 mkNonDefltMsg e
   = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
+mkNonIncreasingAltsMsg e
+  = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
 
 nonExhaustiveAltsMsg :: CoreExpr -> Message
 nonExhaustiveAltsMsg e