never executed always true always false
    1 {- |
    2 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
    3 
    4 A lint pass to check basic STG invariants:
    5 
    6 - Variables should be defined before used.
    7 
    8 - Let bindings should not have unboxed types (unboxed bindings should only
    9   appear in case), except when they're join points (see Note [Core let/app
   10   invariant] and #14117).
   11 
   12 - If linting after unarisation, invariants listed in Note [Post-unarisation
   13   invariants].
   14 
   15 Because we don't have types and coercions in STG we can't really check types
   16 here.
   17 
   18 Some history:
   19 
   20 StgLint used to check types, but it never worked and so it was disabled in 2000
   21 with this note:
   22 
   23     WARNING:
   24     ~~~~~~~~
   25 
   26     This module has suffered bit-rot; it is likely to yield lint errors
   27     for Stg code that is currently perfectly acceptable for code
   28     generation.  Solution: don't use it!  (KSW 2000-05).
   29 
   30 Since then there were some attempts at enabling it again, as summarised in #14787.
   31 It's finally decided that we remove all type checking and only look for
   32 basic properties listed above.
   33 -}
   34 
   35 {-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies,
   36   DeriveFunctor #-}
   37 
   38 module GHC.Stg.Lint ( lintStgTopBindings ) where
   39 
   40 import GHC.Prelude
   41 
   42 import GHC.Stg.Syntax
   43 
   44 import GHC.Driver.Session
   45 import GHC.Driver.Config.Diagnostic
   46 
   47 import GHC.Core.Lint        ( interactiveInScope )
   48 import GHC.Core.DataCon
   49 import GHC.Core             ( AltCon(..) )
   50 import GHC.Core.Type
   51 
   52 import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel )
   53 import GHC.Types.CostCentre ( isCurrentCCS )
   54 import GHC.Types.Id
   55 import GHC.Types.Var.Set
   56 import GHC.Types.Name       ( getSrcLoc, nameIsLocalOrFrom )
   57 import GHC.Types.RepType
   58 import GHC.Types.SrcLoc
   59 
   60 import GHC.Utils.Logger
   61 import GHC.Utils.Outputable
   62 import GHC.Utils.Error      ( mkLocMessage, DiagOpts )
   63 import qualified GHC.Utils.Error as Err
   64 
   65 import GHC.Unit.Module            ( Module )
   66 import GHC.Runtime.Context        ( InteractiveContext )
   67 
   68 import GHC.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
   69 
   70 import Control.Applicative ((<|>))
   71 import Control.Monad
   72 
   73 lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
   74                    => Logger
   75                    -> DynFlags
   76                    -> InteractiveContext
   77                    -> Module -- ^ module being compiled
   78                    -> Bool   -- ^ have we run Unarise yet?
   79                    -> String -- ^ who produced the STG?
   80                    -> [GenStgTopBinding a]
   81                    -> IO ()
   82 
   83 lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds
   84   = {-# SCC "StgLint" #-}
   85     case initL diag_opts this_mod unarised opts top_level_binds (lint_binds binds) of
   86       Nothing  ->
   87         return ()
   88       Just msg -> do
   89         logMsg logger Err.MCDump noSrcSpan
   90           $ withPprStyle defaultDumpStyle
   91           (vcat [ text "*** Stg Lint ErrMsgs: in" <+>
   92                         text whodunnit <+> text "***",
   93                   msg,
   94                   text "*** Offending Program ***",
   95                   pprGenStgTopBindings opts binds,
   96                   text "*** End of Offense ***"])
   97         Err.ghcExit logger 1
   98   where
   99     diag_opts = initDiagOpts dflags
  100     opts = initStgPprOpts dflags
  101     -- Bring all top-level binds into scope because CoreToStg does not generate
  102     -- bindings in dependency order (so we may see a use before its definition).
  103     top_level_binds = extendVarSetList (mkVarSet (bindersOfTopBinds binds))
  104                                        (interactiveInScope ictxt)
  105 
  106     lint_binds :: [GenStgTopBinding a] -> LintM ()
  107 
  108     lint_binds [] = return ()
  109     lint_binds (bind:binds) = do
  110         binders <- lint_bind bind
  111         addInScopeVars binders $
  112             lint_binds binds
  113 
  114     lint_bind (StgTopLifted bind) = lintStgBinds TopLevel bind
  115     lint_bind (StgTopStringLit v _) = return [v]
  116 
  117 lintStgArg :: StgArg -> LintM ()
  118 lintStgArg (StgLitArg _) = return ()
  119 lintStgArg (StgVarArg v) = lintStgVar v
  120 
  121 lintStgVar :: Id -> LintM ()
  122 lintStgVar id = checkInScope id
  123 
  124 lintStgBinds
  125     :: (OutputablePass a, BinderP a ~ Id)
  126     => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders
  127 lintStgBinds top_lvl (StgNonRec binder rhs) = do
  128     lint_binds_help top_lvl (binder,rhs)
  129     return [binder]
  130 
  131 lintStgBinds top_lvl (StgRec pairs)
  132   = addInScopeVars binders $ do
  133         mapM_ (lint_binds_help top_lvl) pairs
  134         return binders
  135   where
  136     binders = [b | (b,_) <- pairs]
  137 
  138 lint_binds_help
  139     :: (OutputablePass a, BinderP a ~ Id)
  140     => TopLevelFlag
  141     -> (Id, GenStgRhs a)
  142     -> LintM ()
  143 lint_binds_help top_lvl (binder, rhs)
  144   = addLoc (RhsOf binder) $ do
  145         when (isTopLevel top_lvl) (checkNoCurrentCCS rhs)
  146         lintStgRhs rhs
  147         opts <- getStgPprOpts
  148         -- Check binder doesn't have unlifted type or it's a join point
  149         checkL ( isJoinId binder
  150               || not (isUnliftedType (idType binder))
  151               || isDataConWorkId binder || isDataConWrapId binder) -- until #17521 is fixed
  152           (mkUnliftedTyMsg opts binder rhs)
  153 
  154 -- | Top-level bindings can't inherit the cost centre stack from their
  155 -- (static) allocation site.
  156 checkNoCurrentCCS
  157     :: (OutputablePass a, BinderP a ~ Id)
  158     => GenStgRhs a
  159     -> LintM ()
  160 checkNoCurrentCCS rhs = do
  161    opts <- getStgPprOpts
  162    let rhs' = pprStgRhs opts rhs
  163    case rhs of
  164       StgRhsClosure _ ccs _ _ _
  165          | isCurrentCCS ccs
  166          -> addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ rhs')
  167       StgRhsCon ccs _ _ _ _
  168          | isCurrentCCS ccs
  169          -> addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ rhs')
  170       _ -> return ()
  171 
  172 lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()
  173 
  174 lintStgRhs (StgRhsClosure _ _ _ [] expr)
  175   = lintStgExpr expr
  176 
  177 lintStgRhs (StgRhsClosure _ _ _ binders expr)
  178   = addLoc (LambdaBodyOf binders) $
  179       addInScopeVars binders $
  180         lintStgExpr expr
  181 
  182 lintStgRhs rhs@(StgRhsCon _ con _ _ args) = do
  183     when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do
  184       opts <- getStgPprOpts
  185       addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
  186                pprStgRhs opts rhs)
  187     mapM_ lintStgArg args
  188     mapM_ checkPostUnariseConArg args
  189 
  190 lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM ()
  191 
  192 lintStgExpr (StgLit _) = return ()
  193 
  194 lintStgExpr (StgApp fun args) = do
  195     lintStgVar fun
  196     mapM_ lintStgArg args
  197 
  198 lintStgExpr app@(StgConApp con _n args _arg_tys) = do
  199     -- unboxed sums should vanish during unarise
  200     lf <- getLintFlags
  201     when (lf_unarised lf && isUnboxedSumDataCon con) $ do
  202       opts <- getStgPprOpts
  203       addErrL (text "Unboxed sum after unarise:" $$
  204                pprStgExpr opts app)
  205     mapM_ lintStgArg args
  206     mapM_ checkPostUnariseConArg args
  207 
  208 lintStgExpr (StgOpApp _ args _) =
  209     mapM_ lintStgArg args
  210 
  211 lintStgExpr (StgLet _ binds body) = do
  212     binders <- lintStgBinds NotTopLevel binds
  213     addLoc (BodyOfLetRec binders) $
  214       addInScopeVars binders $
  215         lintStgExpr body
  216 
  217 lintStgExpr (StgLetNoEscape _ binds body) = do
  218     binders <- lintStgBinds NotTopLevel binds
  219     addLoc (BodyOfLetRec binders) $
  220       addInScopeVars binders $
  221         lintStgExpr body
  222 
  223 lintStgExpr (StgTick _ expr) = lintStgExpr expr
  224 
  225 lintStgExpr (StgCase scrut bndr alts_type alts) = do
  226     lintStgExpr scrut
  227 
  228     lf <- getLintFlags
  229     let in_scope = stgCaseBndrInScope alts_type (lf_unarised lf)
  230 
  231     addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts)
  232 
  233 lintAlt
  234     :: (OutputablePass a, BinderP a ~ Id)
  235     => (AltCon, [Id], GenStgExpr a) -> LintM ()
  236 
  237 lintAlt (DEFAULT, _, rhs) =
  238     lintStgExpr rhs
  239 
  240 lintAlt (LitAlt _, _, rhs) =
  241     lintStgExpr rhs
  242 
  243 lintAlt (DataAlt _, bndrs, rhs) = do
  244     mapM_ checkPostUnariseBndr bndrs
  245     addInScopeVars bndrs (lintStgExpr rhs)
  246 
  247 {-
  248 ************************************************************************
  249 *                                                                      *
  250 The Lint monad
  251 *                                                                      *
  252 ************************************************************************
  253 -}
  254 
  255 newtype LintM a = LintM
  256     { unLintM :: Module
  257               -> LintFlags
  258               -> DiagOpts          -- Diagnostic options
  259               -> StgPprOpts        -- Pretty-printing options
  260               -> [LintLocInfo]     -- Locations
  261               -> IdSet             -- Local vars in scope
  262               -> Bag SDoc        -- Error messages so far
  263               -> (a, Bag SDoc)   -- Result and error messages (if any)
  264     }
  265     deriving (Functor)
  266 
  267 data LintFlags = LintFlags { lf_unarised :: !Bool
  268                              -- ^ have we run the unariser yet?
  269                            }
  270 
  271 data LintLocInfo
  272   = RhsOf Id            -- The variable bound
  273   | LambdaBodyOf [Id]   -- The lambda-binder
  274   | BodyOfLetRec [Id]   -- One of the binders
  275 
  276 dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
  277 dumpLoc (RhsOf v) =
  278   (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' )
  279 dumpLoc (LambdaBodyOf bs) =
  280   (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' )
  281 
  282 dumpLoc (BodyOfLetRec bs) =
  283   (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' )
  284 
  285 
  286 pp_binders :: [Id] -> SDoc
  287 pp_binders bs
  288   = sep (punctuate comma (map pp_binder bs))
  289   where
  290     pp_binder b
  291       = hsep [ppr b, dcolon, ppr (idType b)]
  292 
  293 initL :: DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
  294 initL diag_opts this_mod unarised opts locals (LintM m) = do
  295   let (_, errs) = m this_mod (LintFlags unarised) diag_opts opts [] locals emptyBag
  296   if isEmptyBag errs then
  297       Nothing
  298   else
  299       Just (vcat (punctuate blankLine (bagToList errs)))
  300 
  301 instance Applicative LintM where
  302       pure a = LintM $ \_mod _lf _df _opts _loc _scope errs -> (a, errs)
  303       (<*>) = ap
  304       (*>)  = thenL_
  305 
  306 instance Monad LintM where
  307     (>>=) = thenL
  308     (>>)  = (*>)
  309 
  310 thenL :: LintM a -> (a -> LintM b) -> LintM b
  311 thenL m k = LintM $ \mod lf diag_opts opts loc scope errs
  312   -> case unLintM m mod lf diag_opts opts loc scope errs of
  313       (r, errs') -> unLintM (k r) mod lf diag_opts opts loc scope errs'
  314 
  315 thenL_ :: LintM a -> LintM b -> LintM b
  316 thenL_ m k = LintM $ \mod lf diag_opts opts loc scope errs
  317   -> case unLintM m mod lf diag_opts opts loc scope errs of
  318       (_, errs') -> unLintM k mod lf diag_opts opts loc scope errs'
  319 
  320 checkL :: Bool -> SDoc -> LintM ()
  321 checkL True  _   = return ()
  322 checkL False msg = addErrL msg
  323 
  324 -- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders.
  325 checkPostUnariseBndr :: Id -> LintM ()
  326 checkPostUnariseBndr bndr = do
  327     lf <- getLintFlags
  328     when (lf_unarised lf) $
  329       forM_ (checkPostUnariseId bndr) $ \unexpected ->
  330         addErrL $
  331           text "After unarisation, binder " <>
  332           ppr bndr <> text " has " <> text unexpected <> text " type " <>
  333           ppr (idType bndr)
  334 
  335 -- Arguments shouldn't have sum, tuple, or void types.
  336 checkPostUnariseConArg :: StgArg -> LintM ()
  337 checkPostUnariseConArg arg = case arg of
  338     StgLitArg _ ->
  339       return ()
  340     StgVarArg id -> do
  341       lf <- getLintFlags
  342       when (lf_unarised lf) $
  343         forM_ (checkPostUnariseId id) $ \unexpected ->
  344           addErrL $
  345             text "After unarisation, arg " <>
  346             ppr id <> text " has " <> text unexpected <> text " type " <>
  347             ppr (idType id)
  348 
  349 -- Post-unarisation args and case alt binders should not have unboxed tuple,
  350 -- unboxed sum, or void types. Return what the binder is if it is one of these.
  351 checkPostUnariseId :: Id -> Maybe String
  352 checkPostUnariseId id =
  353     let
  354       id_ty = idType id
  355       is_sum, is_tuple, is_void :: Maybe String
  356       is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum"
  357       is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple"
  358       is_void = guard (isVoidTy id_ty) >> return "void"
  359     in
  360       is_sum <|> is_tuple <|> is_void
  361 
  362 addErrL :: SDoc -> LintM ()
  363 addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc)
  364 
  365 addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
  366 addErr diag_opts errs_so_far msg locs
  367   = errs_so_far `snocBag` mk_msg locs
  368   where
  369     mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
  370                      in  mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag)
  371                                       l (hdr $$ msg)
  372     mk_msg []      = msg
  373 
  374 addLoc :: LintLocInfo -> LintM a -> LintM a
  375 addLoc extra_loc m = LintM $ \mod lf diag_opts opts loc scope errs
  376    -> unLintM m mod lf diag_opts opts (extra_loc:loc) scope errs
  377 
  378 addInScopeVars :: [Id] -> LintM a -> LintM a
  379 addInScopeVars ids m = LintM $ \mod lf diag_opts opts loc scope errs
  380  -> let
  381         new_set = mkVarSet ids
  382     in unLintM m mod lf diag_opts opts loc (scope `unionVarSet` new_set) errs
  383 
  384 getLintFlags :: LintM LintFlags
  385 getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs)
  386 
  387 getStgPprOpts :: LintM StgPprOpts
  388 getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs)
  389 
  390 checkInScope :: Id -> LintM ()
  391 checkInScope id = LintM $ \mod _lf diag_opts _opts loc scope errs
  392  -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then
  393         ((), addErr diag_opts errs (hsep [ppr id, dcolon, ppr (idType id),
  394                                     text "is out of scope"]) loc)
  395     else
  396         ((), errs)
  397 
  398 mkUnliftedTyMsg :: OutputablePass a => StgPprOpts -> Id -> GenStgRhs a -> SDoc
  399 mkUnliftedTyMsg opts binder rhs
  400   = (text "Let(rec) binder" <+> quotes (ppr binder) <+>
  401      text "has unlifted type" <+> quotes (ppr (idType binder)))
  402     $$
  403     (text "RHS:" <+> pprStgRhs opts rhs)