[project @ 1999-06-24 12:27:58 by simonmar]

Some fixes to this (still non-working) pass.

diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index d844e9d..631218a 100644 (file)
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -19,7 +19,7 @@ import Maybes         ( catMaybes )
 import Name            ( isLocallyDefined, getSrcLoc )
 import ErrUtils                ( ErrMsg, Message, addErrLocHdrLine, pprBagOfErrors, dontAddErrLoc )
 import Type            ( mkFunTys, splitFunTys, splitAlgTyConApp_maybe, 
-                         isUnLiftedType, isTyVarTy, Type
+                         isUnLiftedType, isTyVarTy, splitForAllTys, Type
                        )
 import TyCon           ( TyCon, isDataTyCon )
 import Util            ( zipEqual )
@@ -114,6 +114,9 @@ lint_binds_help (binder, rhs)
 \begin{code}
 lintStgRhs :: StgRhs -> LintM (Maybe Type)
 
+lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr)
+  = lintStgExpr expr
+
 lintStgRhs (StgRhsClosure _ _ _ _ _ binders expr)
   = addLoc (LambdaBodyOf binders) (
     addInScopeVars binders (
@@ -172,12 +175,15 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts)
   = lintStgExpr scrut          `thenMaybeL` \ _ ->
     checkTys (idType bndr) scrut_ty (mkDefltMsg bndr) `thenL_`
 
-       -- Check that it is a data type
-    case (splitAlgTyConApp_maybe scrut_ty) of
-      Just (tycon, _, _) | isDataTyCon tycon
-             -> addInScopeVars [bndr] (lintStgAlts alts scrut_ty tycon)
-      other   -> addErrL (mkCaseDataConMsg e)  `thenL_`
-                returnL Nothing
+    (trace (showSDoc (ppr e)) $ 
+       -- we only allow case of tail-call or primop.
+    (case scrut of
+       StgApp _ _ -> returnL ()
+       StgCon _ _ _ -> returnL ()
+       other -> addErrL (mkCaseOfCaseMsg e))   `thenL_`
+
+    addInScopeVars [bndr] (lintStgAlts alts scrut_ty)
+  )
   where
     scrut_ty = get_ty alts
 
@@ -188,10 +194,9 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts)
 \begin{code}
 lintStgAlts :: StgCaseAlts
             -> Type            -- Type of scrutinee
-            -> TyCon                   -- TyCon pinned on the case
             -> LintM (Maybe Type)      -- Type of alternatives
 
-lintStgAlts alts scrut_ty case_tycon
+lintStgAlts alts scrut_ty
   = (case alts of
         StgAlgAlts _ alg_alts deflt ->
           mapL (lintAlgAlt scrut_ty) alg_alts  `thenL` \ maybe_alt_tys ->
@@ -371,6 +376,12 @@ addInScopeVars ids m loc scope errs
     m loc (scope `unionVarSet` new_set) errs
 \end{code}
 
+Checking function applications: we only check that the type has the
+right *number* of arrows, we don't actually compare the types.  This
+is because we can't expect the types to be equal - the type
+applications and type lambdas that we use to calculate accurate types
+have long since disappeared.
+
 \begin{code}
 checkFunApp :: Type                -- The function type
            -> [Type]               -- The arg type(s)
@@ -380,7 +391,8 @@ 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) = splitFunTys 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
       = (Just (mkFunTys expected res_ty), errs)
@@ -397,9 +409,7 @@ checkFunApp fun_ty arg_tys msg loc scope errs
          (new_expected, new_res) -> cfa new_res new_expected arg_tys
 
     cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys)
-      = if (expected_arg_ty == arg_ty)
-       then cfa res_ty expected_arg_tys arg_tys
-       else (Nothing, addErr errs msg loc) -- Arg mis-match
+      = cfa res_ty expected_arg_tys arg_tys
 \end{code}
 
 \begin{code}
@@ -412,22 +422,16 @@ checkInScope id loc scope errs
 
 checkTys :: Type -> Type -> Message -> LintM ()
 checkTys ty1 ty2 msg loc scope errs
-  = if (ty1 == ty2)
-    then ((), errs)
-    else ((), addErr errs msg loc)
+  = -- if (ty1 == ty2) then
+    ((), errs)
+    -- else ((), addErr errs msg loc)
 \end{code}
 
 \begin{code}
 mkCaseAltMsg :: StgCaseAlts -> Message
 mkCaseAltMsg alts
   = ($$) (text "In some case alternatives, type of alternatives not all same:")
-           -- LATER: (ppr alts)
-           (panic "mkCaseAltMsg")
-
-mkCaseDataConMsg :: StgExpr -> Message
-mkCaseDataConMsg expr
-  = ($$) (ptext SLIT("A case scrutinee not a type-constructor type:"))
-           (ppr expr)
+           (empty) -- LATER: ppr alts
 
 mkCaseAbstractMsg :: TyCon -> Message
 mkCaseAbstractMsg tycon
@@ -492,6 +496,10 @@ 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
+
 mkRhsMsg :: Id -> Type -> Message
 mkRhsMsg binder ty
   = vcat [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),