module StgLint ( lintStgTopBindings ) where
import GhcPrelude
import StgSyn
import DynFlags
import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
import Id ( Id, idType, isLocalId, isJoinId )
import VarSet
import DataCon
import CoreSyn ( AltCon(..) )
import Name ( getSrcLoc )
import ErrUtils ( MsgDoc, Severity(..), mkLocMessage )
import Type
import RepType
import SrcLoc
import Outputable
import qualified ErrUtils as Err
import Control.Applicative ((<|>))
import Control.Monad
lintStgTopBindings :: DynFlags
-> Bool
-> String
-> [StgTopBinding]
-> IO ()
lintStgTopBindings dflags unarised whodunnit binds
=
case initL unarised (lint_binds binds) of
Nothing ->
return ()
Just msg -> do
putLogMsg dflags NoReason Err.SevDump noSrcSpan
(defaultDumpStyle dflags)
(vcat [ text "*** Stg Lint ErrMsgs: in" <+>
text whodunnit <+> text "***",
msg,
text "*** Offending Program ***",
pprStgTopBindings binds,
text "*** End of Offense ***"])
Err.ghcExit dflags 1
where
lint_binds :: [StgTopBinding] -> LintM ()
lint_binds [] = return ()
lint_binds (bind:binds) = do
binders <- lint_bind bind
addInScopeVars binders $
lint_binds binds
lint_bind (StgTopLifted bind) = lintStgBinds bind
lint_bind (StgTopStringLit v _) = return [v]
lintStgArg :: StgArg -> LintM ()
lintStgArg (StgLitArg _) = return ()
lintStgArg (StgVarArg v) = lintStgVar v
lintStgVar :: Id -> LintM ()
lintStgVar id = checkInScope id
lintStgBinds :: StgBinding -> LintM [Id]
lintStgBinds (StgNonRec binder rhs) = do
lint_binds_help (binder,rhs)
return [binder]
lintStgBinds (StgRec pairs)
= addInScopeVars binders $ do
mapM_ lint_binds_help pairs
return binders
where
binders = [b | (b,_) <- pairs]
lint_binds_help :: (Id, StgRhs) -> LintM ()
lint_binds_help (binder, rhs)
= addLoc (RhsOf binder) $ do
lintStgRhs rhs
checkL (isJoinId binder || not (isUnliftedType (idType binder)))
(mkUnliftedTyMsg binder rhs)
lintStgRhs :: StgRhs -> LintM ()
lintStgRhs (StgRhsClosure _ _ _ _ [] expr)
= lintStgExpr expr
lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
= addLoc (LambdaBodyOf binders) $
addInScopeVars binders $
lintStgExpr expr
lintStgRhs rhs@(StgRhsCon _ con args) = do
when (isUnboxedTupleCon con || isUnboxedSumCon con) $
addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
ppr rhs)
mapM_ lintStgArg args
mapM_ checkPostUnariseConArg args
lintStgExpr :: StgExpr -> LintM ()
lintStgExpr (StgLit _) = return ()
lintStgExpr (StgApp fun args) = do
lintStgVar fun
mapM_ lintStgArg args
lintStgExpr app@(StgConApp con args _arg_tys) = do
lf <- getLintFlags
when (lf_unarised lf && isUnboxedSumCon con) $
addErrL (text "Unboxed sum after unarise:" $$
ppr app)
mapM_ lintStgArg args
mapM_ checkPostUnariseConArg args
lintStgExpr (StgOpApp _ args _) =
mapM_ lintStgArg args
lintStgExpr lam@(StgLam _ _) =
addErrL (text "Unexpected StgLam" <+> ppr lam)
lintStgExpr (StgLet binds body) = do
binders <- lintStgBinds binds
addLoc (BodyOfLetRec binders) $
addInScopeVars binders $
lintStgExpr body
lintStgExpr (StgLetNoEscape binds body) = do
binders <- lintStgBinds binds
addLoc (BodyOfLetRec binders) $
addInScopeVars binders $
lintStgExpr body
lintStgExpr (StgTick _ expr) = lintStgExpr expr
lintStgExpr (StgCase scrut bndr alts_type alts) = do
lintStgExpr scrut
lf <- getLintFlags
let in_scope = stgCaseBndrInScope alts_type (lf_unarised lf)
addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts)
lintAlt :: (AltCon, [Id], StgExpr) -> LintM ()
lintAlt (DEFAULT, _, rhs) =
lintStgExpr rhs
lintAlt (LitAlt _, _, rhs) =
lintStgExpr rhs
lintAlt (DataAlt _, bndrs, rhs) = do
mapM_ checkPostUnariseBndr bndrs
addInScopeVars bndrs (lintStgExpr rhs)
newtype LintM a = LintM
{ unLintM :: LintFlags
-> [LintLocInfo]
-> IdSet
-> Bag MsgDoc
-> (a, Bag MsgDoc)
}
data LintFlags = LintFlags { lf_unarised :: !Bool
}
data LintLocInfo
= RhsOf Id
| LambdaBodyOf [Id]
| BodyOfLetRec [Id]
dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
dumpLoc (RhsOf v) =
(srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' )
dumpLoc (LambdaBodyOf bs) =
(srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' )
dumpLoc (BodyOfLetRec bs) =
(srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' )
pp_binders :: [Id] -> SDoc
pp_binders bs
= sep (punctuate comma (map pp_binder bs))
where
pp_binder b
= hsep [ppr b, dcolon, ppr (idType b)]
initL :: Bool -> LintM a -> Maybe MsgDoc
initL unarised (LintM m)
= case (m lf [] emptyVarSet emptyBag) of { (_, errs) ->
if isEmptyBag errs then
Nothing
else
Just (vcat (punctuate blankLine (bagToList errs)))
}
where
lf = LintFlags unarised
instance Functor LintM where
fmap = liftM
instance Applicative LintM where
pure a = LintM $ \_lf _loc _scope errs -> (a, errs)
(<*>) = ap
(*>) = thenL_
instance Monad LintM where
(>>=) = thenL
(>>) = (*>)
thenL :: LintM a -> (a -> LintM b) -> LintM b
thenL m k = LintM $ \lf loc scope errs
-> case unLintM m lf loc scope errs of
(r, errs') -> unLintM (k r) lf loc scope errs'
thenL_ :: LintM a -> LintM b -> LintM b
thenL_ m k = LintM $ \lf loc scope errs
-> case unLintM m lf loc scope errs of
(_, errs') -> unLintM k lf loc scope errs'
checkL :: Bool -> MsgDoc -> LintM ()
checkL True _ = return ()
checkL False msg = addErrL msg
checkPostUnariseBndr :: Id -> LintM ()
checkPostUnariseBndr bndr = do
lf <- getLintFlags
when (lf_unarised lf) $
forM_ (checkPostUnariseId bndr) $ \unexpected ->
addErrL $
text "After unarisation, binder " <>
ppr bndr <> text " has " <> text unexpected <> text " type " <>
ppr (idType bndr)
checkPostUnariseConArg :: StgArg -> LintM ()
checkPostUnariseConArg arg = case arg of
StgLitArg _ ->
return ()
StgVarArg id -> do
lf <- getLintFlags
when (lf_unarised lf) $
forM_ (checkPostUnariseId id) $ \unexpected ->
addErrL $
text "After unarisation, arg " <>
ppr id <> text " has " <> text unexpected <> text " type " <>
ppr (idType id)
checkPostUnariseId :: Id -> Maybe String
checkPostUnariseId id =
let
id_ty = idType id
is_sum, is_tuple, is_void :: Maybe String
is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum"
is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple"
is_void = guard (isVoidTy id_ty) >> return "void"
in
is_sum <|> is_tuple <|> is_void
addErrL :: MsgDoc -> LintM ()
addErrL msg = LintM $ \_lf loc _scope errs -> ((), addErr errs msg loc)
addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
addErr errs_so_far msg locs
= errs_so_far `snocBag` mk_msg locs
where
mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
in mkLocMessage SevWarning l (hdr $$ msg)
mk_msg [] = msg
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m = LintM $ \lf loc scope errs
-> unLintM m lf (extra_loc:loc) scope errs
addInScopeVars :: [Id] -> LintM a -> LintM a
addInScopeVars ids m = LintM $ \lf loc scope errs
-> let
new_set = mkVarSet ids
in unLintM m lf loc (scope `unionVarSet` new_set) errs
getLintFlags :: LintM LintFlags
getLintFlags = LintM $ \lf _loc _scope errs -> (lf, errs)
checkInScope :: Id -> LintM ()
checkInScope id = LintM $ \_lf loc scope errs
-> if isLocalId id && not (id `elemVarSet` scope) then
((), addErr errs (hsep [ppr id, dcolon, ppr (idType id),
text "is out of scope"]) loc)
else
((), errs)
mkUnliftedTyMsg :: Id -> StgRhs -> SDoc
mkUnliftedTyMsg binder rhs
= (text "Let(rec) binder" <+> quotes (ppr binder) <+>
text "has unlifted type" <+> quotes (ppr (idType binder)))
$$
(text "RHS:" <+> ppr rhs)