X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FStgLint.lhs;h=48263f514276063b538d84102063e2bbccf78cdd;hb=5cf27e8f1731c52fe63a5b9615f927484164c61b;hp=b97ef11d10d79f0822ec036596487138761ec088;hpb=0596517a9b4b2b32e5d375a986351102ac4540fc;p=ghc-hetmet.git

diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index b97ef11..48263f5 100644
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
 %
 \section[StgLint]{A ``lint'' pass to check for Stg correctness}
 
@@ -8,25 +8,33 @@
 
 module StgLint ( lintStgBindings ) where
 
-import PrelInfo		( primOpType, mkFunTy, PrimOp(..), PrimRep
-			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+import Ubiq{-uitous-}
+
+import StgSyn
+
+import Bag		( emptyBag, isEmptyBag, snocBag, foldBag )
+import Id		( idType, isDataCon, dataConArgTys,
+			  emptyIdSet, isEmptyIdSet, elementOfIdSet,
+			  mkIdSet, intersectIdSets,
+			  unionIdSets, idSetToList, IdSet(..),
+			  GenId{-instanced NamedThing-}
 			)
-import Type
-import Bag
-import Literal		( literalType, Literal )
-import Id		( idType, isDataCon,
-			  getInstantiatedDataConSig
+import Literal		( literalType, Literal{-instance Outputable-} )
+import Maybes		( catMaybes )
+import Name		( isLocallyDefined, getSrcLoc )
+import Outputable	( Outputable(..){-instance * []-} )
+import PprType		( GenType{-instance Outputable-}, TyCon )
+import Pretty		-- quite a bit of it
+import PrimOp		( primOpType )
+import SrcLoc		( SrcLoc{-instance Outputable-} )
+import Type		( mkFunTys, splitFunTy, maybeAppDataTyConExpandingDicts,
+			  isTyVarTy, eqTy, splitFunTyExpandingDicts
 			)
-import Maybes
-import Outputable
-import Pretty
-import SrcLoc		( SrcLoc )
-import StgSyn
-import UniqSet
-import Util
+import Util		( zipEqual, pprPanic, panic, panic# )
 
 infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
+
+unDictifyTy = panic "StgLint.unDictifyTy (ToDo)"
 \end{code}
 
 Checks for
@@ -45,7 +53,7 @@ Checks for
 lintStgBindings :: PprStyle -> String -> [StgBinding] -> [StgBinding]
 
 lintStgBindings sty whodunnit binds
-  = BSCC("StgLint")
+  = _scc_ "StgLint"
     case (initL (lint_binds binds)) of
       Nothing  -> binds
       Just msg -> pprPanic "" (ppAboves [
@@ -54,7 +62,6 @@ lintStgBindings sty whodunnit binds
 			ppStr "*** Offending Program ***",
 			ppAboves (map (pprPlainStgBinding sty) binds),
 			ppStr "*** End of Offense ***"])
-    ESCC
   where
     lint_binds :: [StgBinding] -> LintM ()
 
@@ -114,7 +121,7 @@ lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
   = addLoc (LambdaBodyOf binders) (
     addInScopeVars binders (
 	lintStgExpr expr   `thenMaybeL` \ body_ty ->
-	returnL (Just (foldr (mkFunTy . idType) body_ty binders))
+	returnL (Just (mkFunTys (map idType binders) body_ty))
     ))
 
 lintStgRhs (StgRhsCon _ con args)
@@ -172,7 +179,7 @@ lintStgExpr e@(StgCase scrut _ _ _ alts)
   = lintStgExpr scrut		`thenMaybeL` \ _ ->
 
 	-- Check that it is a data type
-    case maybeAppDataTyCon scrut_ty of
+    case (maybeAppDataTyConExpandingDicts scrut_ty) of
       Nothing -> addErrL (mkCaseDataConMsg e)	`thenL_`
 		 returnL Nothing
       Just (tycon, _, _)
@@ -193,7 +200,6 @@ lintStgAlts :: StgCaseAlts
 lintStgAlts alts scrut_ty case_tycon
   = (case alts of
 	 StgAlgAlts _ alg_alts deflt ->
-	   chk_non_abstract_type case_tycon	`thenL_`
 	   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)
@@ -211,24 +217,19 @@ lintStgAlts alts scrut_ty case_tycon
 			returnL (Just first_ty)
 	where
 	  check ty = checkTys first_ty ty (mkCaseAltMsg alts)
-  where
-    chk_non_abstract_type tycon
-      = case (getTyConFamilySize tycon) of
-	  Nothing -> addErrL (mkCaseAbstractMsg tycon)
-	  Just  _ -> returnL () -- that's cool
 
 lintAlgAlt scrut_ty (con, args, _, rhs)
-  = (case maybeAppDataTyCon scrut_ty of
+  = (case maybeAppDataTyConExpandingDicts scrut_ty of
       Nothing ->
 	 addErrL (mkAlgAltMsg1 scrut_ty)
       Just (tycon, tys_applied, cons) ->
 	 let
-	   (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
+	   arg_tys = dataConArgTys con tys_applied
 	 in
 	 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
 	 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
 								 `thenL_`
-	 mapL check (arg_tys `zipEqual` args)			 `thenL_`
+	 mapL check (zipEqual "lintAlgAlt:stg" arg_tys args)	 `thenL_`
 	 returnL ()
     )								 `thenL_`
     addInScopeVars args 	(
@@ -264,7 +265,7 @@ lintDeflt deflt@(StgBindDefault binder _ rhs) scrut_ty
 
 \begin{code}
 type LintM a = [LintLocInfo] 	-- Locations
-	    -> UniqSet Id	-- Local vars in scope
+	    -> IdSet		-- Local vars in scope
 	    -> Bag ErrMsg	-- Error messages so far
 	    -> (a, Bag ErrMsg)	-- Result and error messages (if any)
 
@@ -298,12 +299,12 @@ pp_binders sty bs
 \begin{code}
 initL :: LintM a -> Maybe ErrMsg
 initL m
-  = case (m [] emptyUniqSet emptyBag) of { (_, errs) ->
+  = case (m [] emptyIdSet emptyBag) of { (_, errs) ->
     if isEmptyBag errs then
 	Nothing
     else
 	Just ( \ sty ->
-	  ppAboves [ msg sty | msg <- bagToList errs ]
+	  foldBag ppAbove ( \ msg -> msg sty ) ppNil errs
 	)
     }
 
@@ -374,17 +375,16 @@ addInScopeVars ids m loc scope errs
     -- For now, it's just a "trace"; we may make
     -- a real error out of it...
     let
-	new_set = mkUniqSet ids
+	new_set = mkIdSet ids
 
-	shadowed = scope `intersectUniqSets` new_set
+	shadowed = scope `intersectIdSets` new_set
     in
 --  After adding -fliberate-case, Simon decided he likes shadowed
 --  names after all.  WDP 94/07
---  (if isEmptyUniqSet shadowed
+--  (if isEmptyIdSet shadowed
 --  then id
---  else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
-    m loc (scope `unionUniqSets` new_set) errs
---  )
+--  else pprTrace "Shadowed vars:" (ppr PprDebug (idSetToList shadowed))) $
+    m loc (scope `unionIdSets` new_set) errs
 \end{code}
 
 \begin{code}
@@ -396,41 +396,41 @@ checkFunApp :: Type 		-- The function type
 checkFunApp fun_ty arg_tys msg loc scope errs
   = cfa res_ty expected_arg_tys arg_tys
   where
-    (_, expected_arg_tys, res_ty) = splitTypeWithDictsAsArgs fun_ty
+    (expected_arg_tys, res_ty) = splitFunTyExpandingDicts fun_ty
 
     cfa res_ty expected []	-- Args have run out; that's fine
-      = (Just (glueTyArgs expected res_ty), errs)
+      = (Just (mkFunTys expected res_ty), errs)
 
     cfa res_ty [] arg_tys	-- Expected arg tys ran out first;
 				-- first see if res_ty is a tyvar template;
 				-- otherwise, maybe res_ty is a
 				-- dictionary type which is actually a function?
-      | isTyVarTemplateTy res_ty
+      | isTyVarTy res_ty
       = (Just res_ty, errs)
       | otherwise
-      = case splitTyArgs (unDictifyTy res_ty) of
+      = case splitFunTy (unDictifyTy res_ty) of
 	  ([], _) 		  -> (Nothing, addErr errs msg loc)	-- Too many args
 	  (new_expected, new_res) -> cfa new_res new_expected arg_tys
 
     cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys)
-      = case (sleazy_cmp_ty expected_arg_ty arg_ty) of
-	  EQ_ -> cfa res_ty expected_arg_tys arg_tys
-	  _   -> (Nothing, addErr errs msg loc) -- Arg mis-match
+      = if (sleazy_eq_ty expected_arg_ty arg_ty)
+	then cfa res_ty expected_arg_tys arg_tys
+	else (Nothing, addErr errs msg loc) -- Arg mis-match
 \end{code}
 
 \begin{code}
 checkInScope :: Id -> LintM ()
 checkInScope id loc scope errs
-  = if isLocallyDefined id && not (isDataCon id) && not (id `elementOfUniqSet` scope) then
+  = if isLocallyDefined id && not (isDataCon id) && not (id `elementOfIdSet` scope) then
 	((), addErr errs (\ sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc)
     else
 	((), errs)
 
 checkTys :: Type -> Type -> ErrMsg -> LintM ()
 checkTys ty1 ty2 msg loc scope errs
-  = case (sleazy_cmp_ty ty1 ty2) of
-      EQ_   -> ((), errs)
-      other -> ((), addErr errs msg loc)
+  = if (sleazy_eq_ty ty1 ty2)
+    then ((), errs)
+    else ((), addErr errs msg loc)
 \end{code}
 
 \begin{code}
@@ -520,14 +520,14 @@ mkRhsMsg binder ty sty
 pp_expr :: PprStyle -> StgExpr -> Pretty
 pp_expr sty expr = ppr sty expr
 
-sleazy_cmp_ty ty1 ty2
+sleazy_eq_ty ty1 ty2
 	-- NB: probably severe overkill (WDP 95/04)
-  = case (splitTypeWithDictsAsArgs ty1) of { (_,tyargs1,tyres1) ->
-    case (splitTypeWithDictsAsArgs ty2) of { (_,tyargs2,tyres2) ->
+  = _trace "StgLint.sleazy_eq_ty:use eqSimplTy?" $
+    case (splitFunTyExpandingDicts ty1) of { (tyargs1,tyres1) ->
+    case (splitFunTyExpandingDicts ty2) of { (tyargs2,tyres2) ->
     let
-	ty11 = glueTyArgs tyargs1 tyres1
-	ty22 = glueTyArgs tyargs2 tyres2
+	ty11 = mkFunTys tyargs1 tyres1
+	ty22 = mkFunTys tyargs2 tyres2
     in
-    cmpUniType False{-!!!NOT PROPERLY!!!-} ty11 ty22
-    }}
+    ty11 `eqTy` ty22 }}
 \end{code}