[project @ 1996-05-16 09:42:08 by partain]

[ghc-hetmet.git] / ghc / compiler / stgSyn / StgLint.lhs

diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index 74abea7..48263f5 100644 (file)
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -13,7 +13,7 @@ import Ubiq{-uitous-}
 import StgSyn
 
 import Bag             ( emptyBag, isEmptyBag, snocBag, foldBag )
-import Id              ( idType, isDataCon,
+import Id              ( idType, isDataCon, dataConArgTys,
                          emptyIdSet, isEmptyIdSet, elementOfIdSet,
                          mkIdSet, intersectIdSets,
                          unionIdSets, idSetToList, IdSet(..),
@@ -21,20 +21,19 @@ import Id           ( idType, isDataCon,
                        )
 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, maybeAppDataTyCon,
-                         isTyVarTy, eqTy
+import Type            ( mkFunTys, splitFunTy, maybeAppDataTyConExpandingDicts,
+                         isTyVarTy, eqTy, splitFunTyExpandingDicts
                        )
 import Util            ( zipEqual, pprPanic, panic, panic# )
 
 infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
 
-getInstantiatedDataConSig = panic "StgLint.getInstantiatedDataConSig (ToDo)"
-splitTypeWithDictsAsArgs = panic "StgLint.splitTypeWithDictsAsArgs (ToDo)"
 unDictifyTy = panic "StgLint.unDictifyTy (ToDo)"
 \end{code}
 
@@ -54,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 [
@@ -63,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 ()
 
@@ -181,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, _, _)
@@ -221,17 +219,17 @@ lintStgAlts alts scrut_ty case_tycon
          check ty = checkTys first_ty ty (mkCaseAltMsg alts)
 
 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        (
@@ -398,7 +396,7 @@ 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 (mkFunTys expected res_ty), errs)
@@ -524,13 +522,12 @@ pp_expr sty expr = ppr sty expr
 
 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 = mkFunTys tyargs1 tyres1
        ty22 = mkFunTys tyargs2 tyres2
     in
-    trace "StgLint.sleazy_cmp_ty" $
-    ty11 `eqTy` ty22
-    }}
+    ty11 `eqTy` ty22 }}
 \end{code}