[project @ 2002-03-27 12:09:00 by simonpj]

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

diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index 59febdd..2b3f183 100644 (file)
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -19,11 +19,11 @@ import Literal              ( literalType, Literal )
 import Maybes          ( catMaybes )
 import Name            ( getSrcLoc )
 import ErrUtils                ( ErrMsg, Message, addErrLocHdrLine, pprBagOfErrors, dontAddErrLoc )
-import Type            ( mkFunTys, splitFunTys, splitAlgTyConApp_maybe, 
-                         isUnLiftedType, isTyVarTy, splitForAllTys, Type
+import Type            ( mkFunTys, splitFunTys, splitTyConApp_maybe,
+                         isUnLiftedType, isTyVarTy, dropForAlls, Type
                        )
-import TyCon           ( TyCon )
-import Util            ( zipEqual )
+import TyCon           ( TyCon, isAlgTyCon, isNewTyCon, tyConDataCons )
+import Util            ( zipEqual, equalLength )
 import Outputable
 
 infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
@@ -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,19 +253,21 @@ 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) | 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 (mkAlgAltMsg1 scrut_ty)
     )                                                           `thenL_`
     addInScopeVars args        (
         lintStgExpr rhs
@@ -413,8 +427,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)