[project @ 2001-03-01 17:06:53 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 631218a..bfae295 100644 (file)
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -10,18 +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, dataConType )
-import Const           ( literalType, conType, Literal )
+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, splitAlgTyConApp_maybe, splitTyConApp_maybe,
                          isUnLiftedType, isTyVarTy, splitForAllTys, Type
                        )
-import TyCon           ( TyCon, isDataTyCon )
+import TyCon           ( TyCon )
 import Util            ( zipEqual )
 import Outputable
 
@@ -32,6 +33,18 @@ Checks for
        (a) *some* type errors
        (b) locally-defined variables used but not defined
 
+
+Note: unless -dverbose-stg is on, display of lint errors will result
+in "panic: bOGUS_LVs".
+
+WARNING: 
+~~~~~~~~
+
+This module has suffered bit-rot; it is likely to yield lint errors
+for Stg code that is currently perfectly acceptable for code
+generation.  Solution: don't use it!  (KSW 2000-05).
+
+
 %************************************************************************
 %*                                                                     *
 \subsection{``lint'' for various constructs}
@@ -67,7 +80,7 @@ lintStgBindings whodunnit binds
 
 \begin{code}
 lintStgArg :: StgArg -> LintM (Maybe Type)
-lintStgArg (StgConArg con) = returnL (Just (conType con))
+lintStgArg (StgLitArg lit) = returnL (Just (literalType lit))
 lintStgArg (StgVarArg v)   = lintStgVar v
 
 lintStgVar v  = checkInScope v `thenL_`
@@ -130,12 +143,14 @@ lintStgRhs (StgRhsCon _ con args)
       Nothing      -> returnL Nothing
       Just arg_tys  -> checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
   where
-    con_ty = dataConType con
+    con_ty = dataConRepType con
 \end{code}
 
 \begin{code}
 lintStgExpr :: StgExpr -> LintM (Maybe Type)   -- Nothing if error found
 
+lintStgExpr (StgLit l) = returnL (Just (literalType l))
+
 lintStgExpr e@(StgApp fun args)
   = lintStgVar fun             `thenMaybeL` \ fun_ty  ->
     mapMaybeL lintStgArg args  `thenL`      \ maybe_arg_tys ->
@@ -143,13 +158,21 @@ lintStgExpr e@(StgApp fun args)
       Nothing      -> returnL Nothing
       Just arg_tys  -> checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
 
-lintStgExpr e@(StgCon con args _)
+lintStgExpr e@(StgConApp con args)
   = mapMaybeL lintStgArg args  `thenL` \ maybe_arg_tys ->
     case maybe_arg_tys of
       Nothing      -> returnL Nothing
       Just arg_tys  -> checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e)
   where
-    con_ty = conType con
+    con_ty = dataConRepType con
+
+lintStgExpr e@(StgPrimApp op args _)
+  = mapMaybeL lintStgArg args  `thenL` \ maybe_arg_tys ->
+    case maybe_arg_tys of
+      Nothing      -> returnL Nothing
+      Just arg_tys  -> checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e)
+  where
+    op_ty = primOpType op
 
 lintStgExpr (StgLam _ bndrs _)
   = addErrL (ptext SLIT("Unexpected StgLam") <+> ppr bndrs)    `thenL_`
@@ -173,22 +196,28 @@ 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
-       StgApp _ _ -> returnL ()
-       StgCon _ _ _ -> returnL ()
+       StgApp _ _    -> returnL ()
+       StgConApp _ _ -> returnL ()
        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}
@@ -224,6 +253,7 @@ lintAlgAlt scrut_ty (con, args, _, rhs)
       Just (tycon, tys_applied, cons) ->
         let
           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)
@@ -351,7 +381,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
@@ -365,8 +395,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 +443,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)