module GHC.Stg.Lint ( lintStgTopBindings ) where
import GHC.Prelude
import GHC.Stg.Syntax
import GHC.Stg.Utils
import GHC.Core.Lint ( interactiveInScope )
import GHC.Core.DataCon
import GHC.Core ( AltCon(..) )
import GHC.Core.Type
import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel, isMarkedCbv )
import GHC.Types.CostCentre ( isCurrentCCS )
import GHC.Types.Error ( DiagnosticReason(WarningWithoutFlag) )
import GHC.Types.Id
import GHC.Types.Var.Set
import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom )
import GHC.Types.RepType
import GHC.Types.SrcLoc
import GHC.Utils.Logger
import GHC.Utils.Outputable
import GHC.Utils.Error ( mkLocMessage, DiagOpts )
import qualified GHC.Utils.Error as Err
import GHC.Unit.Module ( Module )
import GHC.Runtime.Context ( InteractiveContext )
import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
import Control.Applicative ((<|>))
import Control.Monad
import Data.Maybe
import GHC.Utils.Misc
import GHC.Core.Multiplicity (scaledThing)
import GHC.Settings (Platform)
import GHC.Core.TyCon (primRepCompatible, primRepsCompatible)
import GHC.Utils.Panic.Plain (panic)
lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
=> Platform
-> Logger
-> DiagOpts
-> StgPprOpts
-> InteractiveContext
-> Module
-> Bool
-> String
-> [GenStgTopBinding a]
-> IO ()
lintStgTopBindings platform logger diag_opts opts ictxt this_mod unarised whodunnit binds
=
case initL platform diag_opts this_mod unarised opts top_level_binds (lint_binds binds) of
Nothing ->
return ()
Just msg -> do
logMsg logger Err.MCDump noSrcSpan
$ withPprStyle defaultDumpStyle
(vcat [ text "*** Stg Lint ErrMsgs: in" <+>
text whodunnit <+> text "***",
msg,
text "*** Offending Program ***",
pprGenStgTopBindings opts binds,
text "*** End of Offense ***"])
Err.ghcExit logger 1
where
top_level_binds = extendVarSetList (mkVarSet (bindersOfTopBinds binds))
(interactiveInScope ictxt)
lint_binds :: [GenStgTopBinding a] -> LintM ()
lint_binds [] = return ()
lint_binds (bind:binds) = do
binders <- lint_bind bind
addInScopeVars binders $
lint_binds binds
lint_bind (StgTopLifted bind) = lintStgBinds TopLevel 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
:: (OutputablePass a, BinderP a ~ Id)
=> TopLevelFlag -> GenStgBinding a -> LintM [Id]
lintStgBinds top_lvl (StgNonRec binder rhs) = do
lint_binds_help top_lvl (binder,rhs)
return [binder]
lintStgBinds top_lvl (StgRec pairs)
= addInScopeVars binders $ do
mapM_ (lint_binds_help top_lvl) pairs
return binders
where
binders = [b | (b,_) <- pairs]
lint_binds_help
:: (OutputablePass a, BinderP a ~ Id)
=> TopLevelFlag
-> (Id, GenStgRhs a)
-> LintM ()
lint_binds_help top_lvl (binder, rhs)
= addLoc (RhsOf binder) $ do
when (isTopLevel top_lvl) (checkNoCurrentCCS rhs)
lintStgRhs rhs
opts <- getStgPprOpts
checkL ( isJoinId binder
|| not (isUnliftedType (idType binder))
|| isDataConWorkId binder || isDataConWrapId binder)
(mkUnliftedTyMsg opts binder rhs)
checkNoCurrentCCS
:: (OutputablePass a, BinderP a ~ Id)
=> GenStgRhs a
-> LintM ()
checkNoCurrentCCS rhs = do
opts <- getStgPprOpts
let rhs' = pprStgRhs opts rhs
case rhs of
StgRhsClosure _ ccs _ _ _
| isCurrentCCS ccs
-> addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ rhs')
StgRhsCon ccs _ _ _ _
| isCurrentCCS ccs
-> addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ rhs')
_ -> return ()
lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()
lintStgRhs (StgRhsClosure _ _ _ [] expr)
= lintStgExpr expr
lintStgRhs (StgRhsClosure _ _ _ binders expr)
= addLoc (LambdaBodyOf binders) $
addInScopeVars binders $
lintStgExpr expr
lintStgRhs rhs@(StgRhsCon _ con _ _ args) = do
opts <- getStgPprOpts
when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do
addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
pprStgRhs opts rhs)
lintConApp con args (pprStgRhs opts rhs)
mapM_ lintStgArg args
mapM_ checkPostUnariseConArg args
lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM ()
lintStgExpr (StgLit _) = return ()
lintStgExpr e@(StgApp fun args) = do
lintStgVar fun
mapM_ lintStgArg args
lintAppCbvMarks e
lintStgAppReps fun args
lintStgExpr app@(StgConApp con _n args _arg_tys) = do
lf <- getLintFlags
opts <- getStgPprOpts
when (lf_unarised lf && isUnboxedSumDataCon con) $ do
addErrL (text "Unboxed sum after unarise:" $$
pprStgExpr opts app)
lintConApp con args (pprStgExpr opts app)
mapM_ lintStgArg args
mapM_ checkPostUnariseConArg args
lintStgExpr (StgOpApp _ args _) =
mapM_ lintStgArg args
lintStgExpr (StgLet _ binds body) = do
binders <- lintStgBinds NotTopLevel binds
addLoc (BodyOfLetRec binders) $
addInScopeVars binders $
lintStgExpr body
lintStgExpr (StgLetNoEscape _ binds body) = do
binders <- lintStgBinds NotTopLevel 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
:: (OutputablePass a, BinderP a ~ Id)
=> GenStgAlt a -> LintM ()
lintAlt GenStgAlt{ alt_con = DEFAULT
, alt_bndrs = _
, alt_rhs = rhs} = lintStgExpr rhs
lintAlt GenStgAlt{ alt_con = LitAlt _
, alt_bndrs = _
, alt_rhs = rhs} = lintStgExpr rhs
lintAlt GenStgAlt{ alt_con = DataAlt _
, alt_bndrs = bndrs
, alt_rhs = rhs} =
do
mapM_ checkPostUnariseBndr bndrs
addInScopeVars bndrs (lintStgExpr rhs)
lintConApp :: Foldable t => DataCon -> t a -> SDoc -> LintM ()
lintConApp con args app = do
unarised <- lf_unarised <$> getLintFlags
when (unarised &&
not (isUnboxedTupleDataCon con) &&
length (dataConRuntimeRepStrictness con) /= length args) $ do
addErrL (text "Constructor applied to incorrect number of arguments:" $$
text "Application:" <> app)
lintStgAppReps :: Id -> [StgArg] -> LintM ()
lintStgAppReps _fun [] = return ()
lintStgAppReps fun args = do
lf <- getLintFlags
let platform = lf_platform lf
(fun_arg_tys, _res) = splitFunTys (idType fun)
fun_arg_tys' = map scaledThing fun_arg_tys :: [Type]
fun_arg_tys_reps, actual_arg_reps :: [Maybe [PrimRep]]
fun_arg_tys_reps = map typePrimRep_maybe fun_arg_tys'
actual_arg_reps = map (typePrimRep_maybe . stgArgType) args
match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
match_args (Nothing:_) _ = return ()
match_args (_) (Nothing:_) = return ()
match_args (Just actual_rep:actual_reps_left) (Just expected_rep:expected_reps_left)
| actual_rep == expected_rep
= match_args actual_reps_left expected_reps_left
| isVoidRep actual_rep && isVoidRep expected_rep
= match_args actual_reps_left expected_reps_left
| primRepsCompatible platform actual_rep expected_rep
= match_args actual_reps_left expected_reps_left
| Just (actual,actuals) <- getOneRep actual_rep actual_reps_left
, Just (expected,expecteds) <- getOneRep expected_rep expected_reps_left
, primRepCompatible platform actual expected
= match_args actuals expecteds
| otherwise = addErrL $ hang (text "Function type reps and function argument reps mismatched") 2 $
(text "In application " <> ppr fun <+> ppr args $$
text "argument rep:" <> ppr actual_arg_reps $$
text "expected rep:" <> ppr fun_arg_tys_reps $$
text "unarised?:" <> ppr (lf_unarised lf))
where
isVoidRep [] = True
isVoidRep [VoidRep] = True
isVoidRep _ = False
getOneRep :: [PrimRep] -> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]])
getOneRep [] _rest = Nothing
getOneRep [rep] rest = Just (rep,rest)
getOneRep (rep:reps) rest = Just (rep,Just reps:rest)
match_args _ _ = return ()
match_args actual_arg_reps fun_arg_tys_reps
lintAppCbvMarks :: OutputablePass pass
=> GenStgExpr pass -> LintM ()
lintAppCbvMarks e@(StgApp fun args) = do
lf <- getLintFlags
when (lf_unarised lf) $ do
let marks = fromMaybe [] $ idCbvMarks_maybe fun
when (length (dropWhileEndLE (not . isMarkedCbv) marks) > length args) $ do
addErrL $ hang (text "Undersatured cbv marked ID in App" <+> ppr e ) 2 $
(text "marks" <> ppr marks $$
text "args" <> ppr args $$
text "arity" <> ppr (idArity fun) $$
text "join_arity" <> ppr (isJoinId_maybe fun))
lintAppCbvMarks _ = panic "impossible - lintAppCbvMarks"
newtype LintM a = LintM
{ unLintM :: Module
-> LintFlags
-> DiagOpts
-> StgPprOpts
-> [LintLocInfo]
-> IdSet
-> Bag SDoc
-> (a, Bag SDoc)
}
deriving (Functor)
data LintFlags = LintFlags { lf_unarised :: !Bool
, lf_platform :: !Platform
}
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 :: Platform -> DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
initL platform diag_opts this_mod unarised opts locals (LintM m) = do
let (_, errs) = m this_mod (LintFlags unarised platform) diag_opts opts [] locals emptyBag
if isEmptyBag errs then
Nothing
else
Just (vcat (punctuate blankLine (bagToList errs)))
instance Applicative LintM where
pure a = LintM $ \_mod _lf _df _opts _loc _scope errs -> (a, errs)
(<*>) = ap
(*>) = thenL_
instance Monad LintM where
(>>=) = thenL
(>>) = (*>)
thenL :: LintM a -> (a -> LintM b) -> LintM b
thenL m k = LintM $ \mod lf diag_opts opts loc scope errs
-> case unLintM m mod lf diag_opts opts loc scope errs of
(r, errs') -> unLintM (k r) mod lf diag_opts opts loc scope errs'
thenL_ :: LintM a -> LintM b -> LintM b
thenL_ m k = LintM $ \mod lf diag_opts opts loc scope errs
-> case unLintM m mod lf diag_opts opts loc scope errs of
(_, errs') -> unLintM k mod lf diag_opts opts loc scope errs'
checkL :: Bool -> SDoc -> 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 (isZeroBitTy id_ty) >> return "void"
in
is_sum <|> is_tuple <|> is_void
addErrL :: SDoc -> LintM ()
addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc)
addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
addErr diag_opts errs_so_far msg locs
= errs_so_far `snocBag` mk_msg locs
where
mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
in mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag)
l (hdr $$ msg)
mk_msg [] = msg
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m = LintM $ \mod lf diag_opts opts loc scope errs
-> unLintM m mod lf diag_opts opts (extra_loc:loc) scope errs
addInScopeVars :: [Id] -> LintM a -> LintM a
addInScopeVars ids m = LintM $ \mod lf diag_opts opts loc scope errs
-> let
new_set = mkVarSet ids
in unLintM m mod lf diag_opts opts loc (scope `unionVarSet` new_set) errs
getLintFlags :: LintM LintFlags
getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs)
getStgPprOpts :: LintM StgPprOpts
getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs)
checkInScope :: Id -> LintM ()
checkInScope id = LintM $ \mod _lf diag_opts _opts loc scope errs
-> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then
((), addErr diag_opts errs (hsep [ppr id, dcolon, ppr (idType id),
text "is out of scope"]) loc)
else
((), errs)
mkUnliftedTyMsg :: OutputablePass a => StgPprOpts -> Id -> GenStgRhs a -> SDoc
mkUnliftedTyMsg opts binder rhs
= (text "Let(rec) binder" <+> quotes (ppr binder) <+>
text "has unlifted type" <+> quotes (ppr (idType binder)))
$$
(text "RHS:" <+> pprStgRhs opts rhs)