Remove unused LiveVars and SRT fields of StgCase and StgLetNoEscape
[ghc.git] / compiler / stgSyn / StgLint.hs
index 5bd25e3..df3c4e5 100644 (file)
@@ -20,16 +20,11 @@ import Literal          ( literalType )
 import Maybes
 import Name             ( getSrcLoc )
 import ErrUtils         ( MsgDoc, Severity(..), mkLocMessage )
-import TypeRep
 import Type
 import TyCon
 import Util
 import SrcLoc
 import Outputable
-import FastString
-#if __GLASGOW_HASKELL__ < 709
-import Control.Applicative ( Applicative(..) )
-#endif
 import Control.Monad
 import Data.Function
 
@@ -68,12 +63,12 @@ lintStgBindings whodunnit binds
     case (initL (lint_binds binds)) of
       Nothing  -> binds
       Just msg -> pprPanic "" (vcat [
-                        ptext (sLit "*** Stg Lint ErrMsgs: in") <+>
-                              text whodunnit <+> ptext (sLit "***"),
+                        text "*** Stg Lint ErrMsgs: in" <+>
+                              text whodunnit <+> text "***",
                         msg,
-                        ptext (sLit "*** Offending Program ***"),
+                        text "*** Offending Program ***",
                         pprStgBindings binds,
-                        ptext (sLit "*** End of Offense ***")])
+                        text "*** End of Offense ***"])
   where
     lint_binds :: [StgBinding] -> LintM ()
 
@@ -110,8 +105,8 @@ lint_binds_help (binder, rhs)
         _maybe_rhs_ty <- lintStgRhs rhs
 
         -- Check binder doesn't have unlifted type
-        checkL (not (isUnLiftedType binder_ty))
-               (mkUnLiftedTyMsg binder rhs)
+        checkL (not (isUnliftedType binder_ty))
+               (mkUnliftedTyMsg binder rhs)
 
         -- Check match to RHS type
         -- Actually we *can't* check the RHS type, because
@@ -129,10 +124,10 @@ lint_binds_help (binder, rhs)
 
 lintStgRhs :: StgRhs -> LintM (Maybe Type)   -- Just ty => type is exact
 
-lintStgRhs (StgRhsClosure _ _ _ _ [] expr)
+lintStgRhs (StgRhsClosure _ _ _ _ [] expr)
   = lintStgExpr expr
 
-lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
+lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
   = addLoc (LambdaBodyOf binders) $
       addInScopeVars binders $ runMaybeT $ do
         body_ty <- MaybeT $ lintStgExpr expr
@@ -172,7 +167,7 @@ lintStgExpr (StgOpApp _ args res_ty) = runMaybeT $ do
     return res_ty
 
 lintStgExpr (StgLam bndrs _) = do
-    addErrL (ptext (sLit "Unexpected StgLam") <+> ppr bndrs)
+    addErrL (text "Unexpected StgLam" <+> ppr bndrs)
     return Nothing
 
 lintStgExpr (StgLet binds body) = do
@@ -181,15 +176,15 @@ lintStgExpr (StgLet binds body) = do
       addInScopeVars binders $
         lintStgExpr body
 
-lintStgExpr (StgLetNoEscape _ _ binds body) = do
+lintStgExpr (StgLetNoEscape binds body) = do
     binders <- lintStgBinds binds
     addLoc (BodyOfLetRec binders) $
       addInScopeVars binders $
         lintStgExpr body
 
-lintStgExpr (StgSCC _ _ _ expr) = lintStgExpr expr
+lintStgExpr (StgTick _ expr) = lintStgExpr expr
 
-lintStgExpr (StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
+lintStgExpr (StgCase scrut bndr alts_type alts) = runMaybeT $ do
     _ <- MaybeT $ lintStgExpr scrut
 
     in_scope <- MaybeT $ liftM Just $
@@ -210,8 +205,6 @@ lintStgExpr (StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
                   where
                      bad_bndr = mkDefltMsg bndr tc
 
-lintStgExpr e = pprPanic "lintStgExpr" (ppr e)
-
 lintStgAlts :: [StgAlt]
             -> Type               -- Type of scrutinee
             -> LintM (Maybe Type) -- Just ty => type is accurage
@@ -288,12 +281,12 @@ data LintLocInfo
 
 dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
 dumpLoc (RhsOf v) =
-  (srcLocSpan (getSrcLoc v), ptext (sLit " [RHS of ") <> pp_binders [v] <> char ']' )
+  (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' )
 dumpLoc (LambdaBodyOf bs) =
-  (srcLocSpan (getSrcLoc (head bs)), ptext (sLit " [in body of lambda with binders ") <> pp_binders bs <> char ']' )
+  (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' )
 
 dumpLoc (BodyOfLetRec bs) =
-  (srcLocSpan (getSrcLoc (head bs)), ptext (sLit " [in body of letrec with binders ") <> pp_binders bs <> char ']' )
+  (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' )
 
 
 pp_binders :: [Id] -> SDoc
@@ -316,13 +309,13 @@ instance Functor LintM where
       fmap = liftM
 
 instance Applicative LintM where
-      pure = return
+      pure a = LintM $ \_loc _scope errs -> (a, errs)
       (<*>) = ap
+      (*>)  = thenL_
 
 instance Monad LintM where
-    return a = LintM $ \_loc _scope errs -> (a, errs)
     (>>=) = thenL
-    (>>)  = thenL_
+    (>>)  = (*>)
 
 thenL :: LintM a -> (a -> LintM b) -> LintM b
 thenL m k = LintM $ \loc scope errs
@@ -457,7 +450,7 @@ stgEqType orig_ty1 orig_ty2
 checkInScope :: Id -> LintM ()
 checkInScope id = LintM $ \loc scope errs
  -> if isLocalId id && not (id `elemVarSet` scope) then
-        ((), addErr errs (hsep [ppr id, ptext (sLit "is out of scope")]) loc)
+        ((), addErr errs (hsep [ppr id, text "is out of scope"]) loc)
     else
         ((), errs)
 
@@ -474,21 +467,21 @@ _mkCaseAltMsg _alts
 
 mkDefltMsg :: Id -> TyCon -> MsgDoc
 mkDefltMsg bndr tc
-  = ($$) (ptext (sLit "Binder of a case expression doesn't match type of scrutinee:"))
+  = ($$) (text "Binder of a case expression doesn't match type of scrutinee:")
          (ppr bndr $$ ppr (idType bndr) $$ ppr tc)
 
 mkFunAppMsg :: Type -> [Type] -> StgExpr -> MsgDoc
 mkFunAppMsg fun_ty arg_tys expr
   = vcat [text "In a function application, function type doesn't match arg types:",
-              hang (ptext (sLit "Function type:")) 4 (ppr fun_ty),
-              hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys)),
-              hang (ptext (sLit "Expression:")) 4 (ppr expr)]
+              hang (text "Function type:") 4 (ppr fun_ty),
+              hang (text "Arg types:") 4 (vcat (map (ppr) arg_tys)),
+              hang (text "Expression:") 4 (ppr expr)]
 
 mkRhsConMsg :: Type -> [Type] -> MsgDoc
 mkRhsConMsg fun_ty arg_tys
   = vcat [text "In a RHS constructor application, con type doesn't match arg types:",
-              hang (ptext (sLit "Constructor type:")) 4 (ppr fun_ty),
-              hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys))]
+              hang (text "Constructor type:") 4 (ppr fun_ty),
+              hang (text "Arg types:") 4 (vcat (map (ppr) arg_tys))]
 
 mkAltMsg1 :: Type -> MsgDoc
 mkAltMsg1 ty
@@ -521,15 +514,15 @@ mkAlgAltMsg4 ty arg
 
 _mkRhsMsg :: Id -> Type -> MsgDoc
 _mkRhsMsg binder ty
-  = vcat [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"),
+  = vcat [hsep [text "The type of this binder doesn't match the type of its RHS:",
                      ppr binder],
-              hsep [ptext (sLit "Binder's type:"), ppr (idType binder)],
-              hsep [ptext (sLit "Rhs type:"), ppr ty]
+              hsep [text "Binder's type:", ppr (idType binder)],
+              hsep [text "Rhs type:", ppr ty]
              ]
 
-mkUnLiftedTyMsg :: Id -> StgRhs -> SDoc
-mkUnLiftedTyMsg binder rhs
-  = (ptext (sLit "Let(rec) binder") <+> quotes (ppr binder) <+>
-     ptext (sLit "has unlifted type") <+> quotes (ppr (idType binder)))
+mkUnliftedTyMsg :: Id -> StgRhs -> SDoc
+mkUnliftedTyMsg binder rhs
+  = (text "Let(rec) binder" <+> quotes (ppr binder) <+>
+     text "has unlifted type" <+> quotes (ppr (idType binder)))
     $$
-    (ptext (sLit "RHS:") <+> ppr rhs)
+    (text "RHS:" <+> ppr rhs)