[project @ 2005-10-14 11:22:41 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 31cc98a..326cd44 100644 (file)
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -13,18 +13,19 @@ import StgSyn
 import Bag             ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
 import Id              ( Id, idType, isLocalId )
 import VarSet
-import DataCon         ( DataCon, dataConArgTys, dataConRepType )
+import DataCon         ( DataCon, dataConInstArgTys, dataConRepType )
 import CoreSyn         ( AltCon(..) )
 import PrimOp          ( primOpType )
 import Literal         ( literalType )
 import Maybes          ( catMaybes )
 import Name            ( getSrcLoc )
-import ErrUtils                ( Message, addErrLocHdrLine )
+import ErrUtils                ( Message, mkLocMessage )
 import Type            ( mkFunTys, splitFunTys, splitTyConApp_maybe,
                          isUnLiftedType, isTyVarTy, dropForAlls, Type
                        )
 import TyCon           ( isAlgTyCon, isNewTyCon, tyConDataCons )
 import Util            ( zipEqual, equalLength )
+import SrcLoc          ( srcLocSpan )
 import Outputable
 
 infixr 9 `thenL`, `thenL_`, `thenMaybeL`
@@ -58,7 +59,7 @@ generation.  Solution: don't use it!  (KSW 2000-05).
 lintStgBindings :: String -> [StgBinding] -> [StgBinding]
 
 lintStgBindings whodunnit binds
-  = _scc_ "StgLint"
+  = {-# SCC "StgLint" #-}
     case (initL (lint_binds binds)) of
       Nothing  -> binds
       Just msg -> pprPanic "" (vcat [
@@ -216,6 +217,7 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts)
     (case scrut of
        StgApp _ _    -> returnL ()
        StgConApp _ _ -> returnL ()
+       StgOpApp _ _ _ -> returnL ()
        other -> addErrL (mkCaseOfCaseMsg e))   `thenL_`
 
     addInScopeVars [bndr] (lintStgAlts alts scrut_ty)
@@ -257,7 +259,7 @@ lintAlt scrut_ty (DataAlt con, args, _, rhs)
                                  not (isNewTyCon tycon) ->
         let
           cons    = tyConDataCons tycon
-          arg_tys = dataConArgTys con tys_applied
+          arg_tys = dataConInstArgTys con tys_applied
                -- This almost certainly does not work for existential constructors
         in
         checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
@@ -300,12 +302,12 @@ data LintLocInfo
   | BodyOfLetRec [Id]  -- One of the binders
 
 dumpLoc (RhsOf v) =
-  (getSrcLoc v, ptext SLIT(" [RHS of ") <> pp_binders [v] <> char ']' )
+  (srcLocSpan (getSrcLoc v), ptext SLIT(" [RHS of ") <> pp_binders [v] <> char ']' )
 dumpLoc (LambdaBodyOf bs) =
-  (getSrcLoc (head bs), ptext SLIT(" [in body of lambda with binders ") <> pp_binders bs <> char ']' )
+  (srcLocSpan (getSrcLoc (head bs)), ptext SLIT(" [in body of lambda with binders ") <> pp_binders bs <> char ']' )
 
 dumpLoc (BodyOfLetRec bs) =
-  (getSrcLoc (head bs), ptext SLIT(" [in body of letrec with binders ") <> pp_binders bs <> char ']' )
+  (srcLocSpan (getSrcLoc (head bs)), ptext SLIT(" [in body of letrec with binders ") <> pp_binders bs <> char ']' )
 
 
 pp_binders :: [Id] -> SDoc
@@ -375,7 +377,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
+                    in  mkLocMessage l (hdr $$ msg)
     mk_msg []      = msg
 
 addLoc :: LintLocInfo -> LintM a -> LintM a