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)