X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FStgLint.lhs;h=f634185c0c68eaaaf1bec00e2771a94732b679e1;hb=a24ede81b6ddb6e5dde72d947437baf319968ff9;hp=24bad62f184a218b55b2eff542147cebbbaf3412;hpb=4db8c54487404a0647985ba98c3a7a116c831636;p=ghc-hetmet.git

diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index 24bad62..f634185 100644
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -10,21 +10,21 @@ module StgLint ( lintStgBindings ) where
 
 import StgSyn
 
-import Bag		( Bag, emptyBag, isEmptyBag, snocBag, foldBag )
-import Id		( Id, idType )
+import Bag		( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
+import Id		( Id, idType, isLocalId )
 import VarSet
 import DataCon		( DataCon, dataConArgTys, dataConRepType )
+import CoreSyn		( AltCon(..) )
 import PrimOp		( primOpType )
-import Literal		( literalType, Literal )
+import Literal		( literalType )
 import Maybes		( catMaybes )
-import Name		( isLocallyDefined, getSrcLoc )
-import ErrUtils		( ErrMsg, Message, addErrLocHdrLine, pprBagOfErrors, dontAddErrLoc )
-import Type		( mkFunTys, splitFunTys, splitAlgTyConApp_maybe, 
-			  isUnLiftedType, isTyVarTy, splitForAllTys, Type
+import Name		( getSrcLoc )
+import ErrUtils		( Message, addErrLocHdrLine )
+import Type		( mkFunTys, splitFunTys, splitTyConApp_maybe,
+			  isUnLiftedType, isTyVarTy, dropForAlls, Type
 			)
-import PprType		( {- instance Outputable Type -} )
-import TyCon		( TyCon, isDataTyCon )
-import Util		( zipEqual )
+import TyCon		( TyCon, isAlgTyCon, isNewTyCon, tyConDataCons )
+import Util		( zipEqual, equalLength )
 import Outputable
 
 infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
@@ -167,7 +167,13 @@ lintStgExpr e@(StgConApp con args)
   where
     con_ty = dataConRepType con
 
-lintStgExpr e@(StgPrimApp op args _)
+lintStgExpr e@(StgOpApp (StgFCallOp _ _) args res_ty)
+  = 	-- We don't have enough type information to check
+	-- the application; ToDo
+    mapMaybeL lintStgArg args	`thenL` \ maybe_arg_tys ->
+    returnL (Just res_ty)
+
+lintStgExpr e@(StgOpApp (StgPrimOp op) args _)
   = mapMaybeL lintStgArg args	`thenL` \ maybe_arg_tys ->
     case maybe_arg_tys of
       Nothing 	    -> returnL Nothing
@@ -195,10 +201,16 @@ lintStgExpr (StgLetNoEscape _ _ binds body)
 
 lintStgExpr (StgSCC _ expr)	= lintStgExpr expr
 
-lintStgExpr e@(StgCase scrut _ _ bndr _ alts)
+lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts)
   = lintStgExpr scrut		`thenMaybeL` \ _ ->
-    checkTys (idType bndr) scrut_ty (mkDefltMsg bndr) `thenL_`
 
+    (case alts_type of
+	AlgAlt tc    -> check_bndr tc
+	PrimAlt tc   -> check_bndr tc
+	UbxTupAlt tc -> check_bndr tc
+	PolyAlt      -> returnL ()
+    )							`thenL_`
+	
     (trace (showSDoc (ppr e)) $ 
 	-- we only allow case of tail-call or primop.
     (case scrut of
@@ -207,31 +219,22 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts)
 	other -> addErrL (mkCaseOfCaseMsg e))   `thenL_`
 
     addInScopeVars [bndr] (lintStgAlts alts scrut_ty)
-  )
+    )
   where
-    scrut_ty = get_ty alts
+    scrut_ty	  = idType bndr
+    bad_bndr      = mkDefltMsg bndr
+    check_bndr tc = case splitTyConApp_maybe scrut_ty of
+			Just (bndr_tc, _) -> checkL (tc == bndr_tc) bad_bndr
+			Nothing		  -> addErrL bad_bndr
 
-    get_ty (StgAlgAlts  ty _ _) = ty
-    get_ty (StgPrimAlts ty _ _) = ty
-\end{code}
 
-\begin{code}
-lintStgAlts :: StgCaseAlts
-	     -> Type 		-- Type of scrutinee
-	     -> LintM (Maybe Type)	-- Type of alternatives
+lintStgAlts :: [StgAlt]
+	    -> Type 		-- Type of scrutinee
+	    -> LintM (Maybe Type)	-- Type of alternatives
 
 lintStgAlts alts scrut_ty
-  = (case alts of
-	 StgAlgAlts _ alg_alts deflt ->
-	   mapL (lintAlgAlt scrut_ty) alg_alts 	`thenL` \ maybe_alt_tys ->
-	   lintDeflt deflt scrut_ty		`thenL` \ maybe_deflt_ty ->
-	   returnL (maybe_deflt_ty : maybe_alt_tys)
-
-	 StgPrimAlts _ prim_alts deflt ->
-	   mapL (lintPrimAlt scrut_ty) prim_alts `thenL` \ maybe_alt_tys ->
-	   lintDeflt deflt scrut_ty		 `thenL` \ maybe_deflt_ty ->
-	   returnL (maybe_deflt_ty : maybe_alt_tys)
-    )						 `thenL` \ maybe_result_tys ->
+  = mapL (lintAlt scrut_ty) alts 	`thenL` \ maybe_result_tys ->
+
 	 -- Check the result types
     case catMaybes (maybe_result_tys) of
       []	     -> returnL Nothing
@@ -241,20 +244,29 @@ lintStgAlts alts scrut_ty
 	where
 	  check ty = checkTys first_ty ty (mkCaseAltMsg alts)
 
-lintAlgAlt scrut_ty (con, args, _, rhs)
-  = (case splitAlgTyConApp_maybe scrut_ty of
-      Nothing ->
-	 addErrL (mkAlgAltMsg1 scrut_ty)
-      Just (tycon, tys_applied, cons) ->
+lintAlt scrut_ty (DEFAULT, _, _, rhs)
+ = lintStgExpr rhs
+
+lintAlt scrut_ty (LitAlt lit, _, _, rhs)
+ = checkTys (literalType lit) scrut_ty (mkAltMsg1 scrut_ty)	`thenL_`
+   lintStgExpr rhs
+
+lintAlt scrut_ty (DataAlt con, args, _, rhs)
+  = (case splitTyConApp_maybe scrut_ty of
+      Just (tycon, tys_applied) | isAlgTyCon tycon && 
+				  not (isNewTyCon tycon) ->
 	 let
+	   cons    = tyConDataCons tycon
 	   arg_tys = dataConArgTys con tys_applied
 		-- This almost certainly does not work for existential constructors
 	 in
 	 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
-	 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
+	 checkL (equalLength arg_tys args) (mkAlgAltMsg3 con args)
 								 `thenL_`
 	 mapL check (zipEqual "lintAlgAlt:stg" arg_tys args)	 `thenL_`
 	 returnL ()
+      other ->
+	 addErrL (mkAltMsg1 scrut_ty)
     )								 `thenL_`
     addInScopeVars args 	(
 	 lintStgExpr rhs
@@ -267,13 +279,6 @@ lintAlgAlt scrut_ty (con, args, _, rhs)
     -- We give it its own copy, so it isn't overloaded.
     elem _ []	    = False
     elem x (y:ys)   = x==y || elem x ys
-
-lintPrimAlt scrut_ty alt@(lit,rhs)
- = checkTys (literalType lit) scrut_ty (mkPrimAltMsg alt)	`thenL_`
-   lintStgExpr rhs
-
-lintDeflt StgNoDefault scrut_ty = returnL Nothing
-lintDeflt deflt@(StgBindDefault rhs) scrut_ty = lintStgExpr rhs
 \end{code}
 
 
@@ -286,8 +291,8 @@ lintDeflt deflt@(StgBindDefault rhs) scrut_ty = lintStgExpr rhs
 \begin{code}
 type LintM a = [LintLocInfo] 	-- Locations
 	    -> IdSet		-- Local vars in scope
-	    -> Bag ErrMsg	-- Error messages so far
-	    -> (a, Bag ErrMsg)	-- Result and error messages (if any)
+	    -> Bag Message	-- Error messages so far
+	    -> (a, Bag Message)	-- Result and error messages (if any)
 
 data LintLocInfo
   = RhsOf Id		-- The variable bound
@@ -318,7 +323,7 @@ initL m
     if isEmptyBag errs then
 	Nothing
     else
-	Just (pprBagOfErrors errs)
+	Just (vcat (punctuate (text "") (bagToList errs)))
     }
 
 returnL :: a -> LintM a
@@ -370,13 +375,14 @@ checkL False msg loc scope errs = ((), addErr errs msg loc)
 addErrL :: Message -> LintM ()
 addErrL msg loc scope errs = ((), addErr errs msg loc)
 
-addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
+addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
 
 addErr errs_so_far msg locs
   = errs_so_far `snocBag` mk_msg locs
   where
-    mk_msg (loc:_) = let (l,hdr) = dumpLoc loc in addErrLocHdrLine l hdr msg
-    mk_msg []      = dontAddErrLoc "" msg
+    mk_msg (loc:_) = let (l,hdr) = dumpLoc loc 
+		     in addErrLocHdrLine l hdr msg
+    mk_msg []      = msg
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
 addLoc extra_loc m loc scope errs
@@ -390,8 +396,6 @@ addInScopeVars ids m loc scope errs
     -- a real error out of it...
     let
 	new_set = mkVarSet ids
-
-	shadowed = scope `intersectVarSet` new_set
     in
 --  After adding -fliberate-case, Simon decided he likes shadowed
 --  names after all.  WDP 94/07
@@ -416,8 +420,7 @@ checkFunApp :: Type 		    -- The function type
 checkFunApp fun_ty arg_tys msg loc scope errs
   = cfa res_ty expected_arg_tys arg_tys
   where
-    (_, de_forall_ty)   = splitForAllTys fun_ty
-    (expected_arg_tys, res_ty) = splitFunTys de_forall_ty
+    (expected_arg_tys, res_ty) = splitFunTys (dropForAlls fun_ty)
 
     cfa res_ty expected []	-- Args have run out; that's fine
       = (Just (mkFunTys expected res_ty), errs)
@@ -440,7 +443,7 @@ checkFunApp fun_ty arg_tys msg loc scope errs
 \begin{code}
 checkInScope :: Id -> LintM ()
 checkInScope id loc scope errs
-  = if isLocallyDefined id && not (id `elemVarSet` scope) then
+  = if isLocalId id && not (id `elemVarSet` scope) then
 	((), addErr errs (hsep [ppr id, ptext SLIT("is out of scope")]) loc)
     else
 	((), errs)
@@ -453,7 +456,7 @@ checkTys ty1 ty2 msg loc scope errs
 \end{code}
 
 \begin{code}
-mkCaseAltMsg :: StgCaseAlts -> Message
+mkCaseAltMsg :: [StgAlt] -> Message
 mkCaseAltMsg alts
   = ($$) (text "In some case alternatives, type of alternatives not all same:")
 	    (empty) -- LATER: ppr alts
@@ -487,10 +490,10 @@ mkUnappTyMsg var ty
 	      (<>) (ptext SLIT("Var:      ")) (ppr var),
 	      (<>) (ptext SLIT("Its type: ")) (ppr ty)]
 
-mkAlgAltMsg1 :: Type -> Message
-mkAlgAltMsg1 ty
-  = ($$) (text "In some case statement, type of scrutinee is not a data type:")
-	    (ppr ty)
+mkAltMsg1 :: Type -> Message
+mkAltMsg1 ty
+  = ($$) (text "In a case expression, type of scrutinee does not match patterns")
+	 (ppr ty)
 
 mkAlgAltMsg2 :: Type -> DataCon -> Message
 mkAlgAltMsg2 ty con
@@ -516,11 +519,6 @@ mkAlgAltMsg4 ty arg
 	ppr arg
     ]
 
-mkPrimAltMsg :: (Literal, StgExpr) -> Message
-mkPrimAltMsg alt
-  = text "In a primitive case alternative, type of literal doesn't match type of scrutinee:"
-    $$ ppr alt
-
 mkCaseOfCaseMsg :: StgExpr -> Message
 mkCaseOfCaseMsg e
   = text "Case of non-tail-call:" $$ ppr e