X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FStgLint.lhs;h=3692e06e422ee030a19628d84c7b56ef1be3f5f2;hb=17629712b35948e3751a39747dcc9ee0cbfb72aa;hp=6a72b9e9d821d8282ee1b5590456d8c31d251b14;hpb=ff755dd9a0a0ad2f106c323852553ea247f16141;p=ghc-hetmet.git

diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index 6a72b9e..3692e06 100644
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -10,19 +10,19 @@ module StgLint ( lintStgBindings ) where
 
 import StgSyn
 
-import Bag		( Bag, emptyBag, isEmptyBag, snocBag, foldBag )
-import Id		( Id, idType )
+import Bag		( Bag, emptyBag, isEmptyBag, snocBag )
+import Id		( Id, idType, isLocalId )
 import VarSet
 import DataCon		( DataCon, dataConArgTys, dataConRepType )
 import PrimOp		( primOpType )
 import Literal		( literalType, Literal )
 import Maybes		( catMaybes )
-import Name		( isLocallyDefined, getSrcLoc )
+import Name		( getSrcLoc )
 import ErrUtils		( ErrMsg, Message, addErrLocHdrLine, pprBagOfErrors, dontAddErrLoc )
-import Type		( mkFunTys, splitFunTys, splitAlgTyConApp_maybe, 
+import Type		( mkFunTys, splitFunTys, splitTyConApp_maybe,
 			  isUnLiftedType, isTyVarTy, splitForAllTys, Type
 			)
-import TyCon		( TyCon, isDataTyCon )
+import TyCon		( TyCon, isDataTyCon, tyConDataCons )
 import Util		( zipEqual )
 import Outputable
 
@@ -89,11 +89,11 @@ lintStgVar v  = checkInScope v	`thenL_`
 
 \begin{code}
 lintStgBinds :: StgBinding -> LintM [Id]		-- Returns the binders
-lintStgBinds (StgNonRec binder rhs)
+lintStgBinds (StgNonRec _srt binder rhs)
   = lint_binds_help (binder,rhs) 	`thenL_`
     returnL [binder]
 
-lintStgBinds (StgRec pairs)
+lintStgBinds (StgRec _srt pairs)
   = addInScopeVars binders (
 	mapL lint_binds_help pairs `thenL_`
 	returnL binders
@@ -127,10 +127,10 @@ lint_binds_help (binder, rhs)
 \begin{code}
 lintStgRhs :: StgRhs -> LintM (Maybe Type)
 
-lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr)
+lintStgRhs (StgRhsClosure _ _ _ _ [] expr)
   = lintStgExpr expr
 
-lintStgRhs (StgRhsClosure _ _ _ _ _ binders expr)
+lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
   = addLoc (LambdaBodyOf binders) (
     addInScopeVars binders (
 	lintStgExpr expr   `thenMaybeL` \ body_ty ->
@@ -166,7 +166,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
@@ -196,8 +202,13 @@ lintStgExpr (StgSCC _ expr)	= lintStgExpr expr
 
 lintStgExpr e@(StgCase scrut _ _ bndr _ alts)
   = lintStgExpr scrut		`thenMaybeL` \ _ ->
-    checkTys (idType bndr) scrut_ty (mkDefltMsg bndr) `thenL_`
 
+    (case alts of
+	StgPrimAlts tc _ _	 -> check_bndr tc
+	StgAlgAlts (Just tc) _ _ -> check_bndr tc
+	StgAlgAlts Nothing   _ _ -> returnL ()
+    )							`thenL_`
+	
     (trace (showSDoc (ppr e)) $ 
 	-- we only allow case of tail-call or primop.
     (case scrut of
@@ -206,12 +217,13 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts)
 	other -> addErrL (mkCaseOfCaseMsg e))   `thenL_`
 
     addInScopeVars [bndr] (lintStgAlts alts scrut_ty)
-  )
+    )
   where
-    scrut_ty = get_ty alts
-
-    get_ty (StgAlgAlts  ty _ _) = ty
-    get_ty (StgPrimAlts ty _ _) = ty
+    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
 \end{code}
 
 \begin{code}
@@ -241,11 +253,10 @@ lintStgAlts alts scrut_ty
 	  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) ->
+  = (case splitTyConApp_maybe scrut_ty of
+      Just (tycon, tys_applied) | isDataTyCon tycon ->
 	 let
+	   cons    = tyConDataCons tycon
 	   arg_tys = dataConArgTys con tys_applied
 		-- This almost certainly does not work for existential constructors
 	 in
@@ -254,6 +265,8 @@ lintAlgAlt scrut_ty (con, args, _, rhs)
 								 `thenL_`
 	 mapL check (zipEqual "lintAlgAlt:stg" arg_tys args)	 `thenL_`
 	 returnL ()
+      other ->
+	 addErrL (mkAlgAltMsg1 scrut_ty)
     )								 `thenL_`
     addInScopeVars args 	(
 	 lintStgExpr rhs
@@ -375,7 +388,7 @@ 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 []      = dontAddErrLoc msg
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
 addLoc extra_loc m loc scope errs
@@ -389,8 +402,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
@@ -415,7 +426,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
+    (_, de_forall_ty) 	       = splitForAllTys fun_ty
     (expected_arg_tys, res_ty) = splitFunTys de_forall_ty
 
     cfa res_ty expected []	-- Args have run out; that's fine
@@ -439,7 +450,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)