testsuite: Assert that testsuite ways are known
[ghc.git] / compiler / stgSyn / StgLint.hs
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 [CoreSyn 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
31 #14787. 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 StgLint ( lintStgTopBindings ) where
39
40 import GhcPrelude
41
42 import StgSyn
43
44 import DynFlags
45 import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
46 import BasicTypes ( TopLevelFlag(..), isTopLevel )
47 import CostCentre ( isCurrentCCS )
48 import Id ( Id, idType, isJoinId, idName )
49 import VarSet
50 import DataCon
51 import CoreSyn ( AltCon(..) )
52 import Name ( getSrcLoc, nameIsLocalOrFrom )
53 import ErrUtils ( MsgDoc, Severity(..), mkLocMessage )
54 import Type
55 import RepType
56 import SrcLoc
57 import Outputable
58 import Module ( Module )
59 import qualified ErrUtils as Err
60 import Control.Applicative ((<|>))
61 import Control.Monad
62
63 lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
64 => DynFlags
65 -> Module -- ^ module being compiled
66 -> Bool -- ^ have we run Unarise yet?
67 -> String -- ^ who produced the STG?
68 -> [GenStgTopBinding a]
69 -> IO ()
70
71 lintStgTopBindings dflags this_mod unarised whodunnit binds
72 = {-# SCC "StgLint" #-}
73 case initL this_mod unarised top_level_binds (lint_binds binds) of
74 Nothing ->
75 return ()
76 Just msg -> do
77 putLogMsg dflags NoReason Err.SevDump noSrcSpan
78 (defaultDumpStyle dflags)
79 (vcat [ text "*** Stg Lint ErrMsgs: in" <+>
80 text whodunnit <+> text "***",
81 msg,
82 text "*** Offending Program ***",
83 pprGenStgTopBindings binds,
84 text "*** End of Offense ***"])
85 Err.ghcExit dflags 1
86 where
87 -- Bring all top-level binds into scope because CoreToStg does not generate
88 -- bindings in dependency order (so we may see a use before its definition).
89 top_level_binds = mkVarSet (bindersOfTopBinds binds)
90
91 lint_binds :: [GenStgTopBinding a] -> LintM ()
92
93 lint_binds [] = return ()
94 lint_binds (bind:binds) = do
95 binders <- lint_bind bind
96 addInScopeVars binders $
97 lint_binds binds
98
99 lint_bind (StgTopLifted bind) = lintStgBinds TopLevel bind
100 lint_bind (StgTopStringLit v _) = return [v]
101
102 lintStgArg :: StgArg -> LintM ()
103 lintStgArg (StgLitArg _) = return ()
104 lintStgArg (StgVarArg v) = lintStgVar v
105
106 lintStgVar :: Id -> LintM ()
107 lintStgVar id = checkInScope id
108
109 lintStgBinds
110 :: (OutputablePass a, BinderP a ~ Id)
111 => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders
112 lintStgBinds top_lvl (StgNonRec binder rhs) = do
113 lint_binds_help top_lvl (binder,rhs)
114 return [binder]
115
116 lintStgBinds top_lvl (StgRec pairs)
117 = addInScopeVars binders $ do
118 mapM_ (lint_binds_help top_lvl) pairs
119 return binders
120 where
121 binders = [b | (b,_) <- pairs]
122
123 lint_binds_help
124 :: (OutputablePass a, BinderP a ~ Id)
125 => TopLevelFlag
126 -> (Id, GenStgRhs a)
127 -> LintM ()
128 lint_binds_help top_lvl (binder, rhs)
129 = addLoc (RhsOf binder) $ do
130 when (isTopLevel top_lvl) (checkNoCurrentCCS rhs)
131 lintStgRhs rhs
132 -- Check binder doesn't have unlifted type or it's a join point
133 checkL (isJoinId binder || not (isUnliftedType (idType binder)))
134 (mkUnliftedTyMsg binder rhs)
135
136 -- | Top-level bindings can't inherit the cost centre stack from their
137 -- (static) allocation site.
138 checkNoCurrentCCS
139 :: (OutputablePass a, BinderP a ~ Id)
140 => GenStgRhs a
141 -> LintM ()
142 checkNoCurrentCCS rhs@(StgRhsClosure _ ccs _ _ _)
143 | isCurrentCCS ccs
144 = addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ ppr rhs)
145 checkNoCurrentCCS rhs@(StgRhsCon ccs _ _)
146 | isCurrentCCS ccs
147 = addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ ppr rhs)
148 checkNoCurrentCCS _
149 = return ()
150
151 lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()
152
153 lintStgRhs (StgRhsClosure _ _ _ [] expr)
154 = lintStgExpr expr
155
156 lintStgRhs (StgRhsClosure _ _ _ binders expr)
157 = addLoc (LambdaBodyOf binders) $
158 addInScopeVars binders $
159 lintStgExpr expr
160
161 lintStgRhs rhs@(StgRhsCon _ con args) = do
162 when (isUnboxedTupleCon con || isUnboxedSumCon con) $
163 addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
164 ppr rhs)
165 mapM_ lintStgArg args
166 mapM_ checkPostUnariseConArg args
167
168 lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM ()
169
170 lintStgExpr (StgLit _) = return ()
171
172 lintStgExpr (StgApp fun args) = do
173 lintStgVar fun
174 mapM_ lintStgArg args
175
176 lintStgExpr app@(StgConApp con args _arg_tys) = do
177 -- unboxed sums should vanish during unarise
178 lf <- getLintFlags
179 when (lf_unarised lf && isUnboxedSumCon con) $
180 addErrL (text "Unboxed sum after unarise:" $$
181 ppr app)
182 mapM_ lintStgArg args
183 mapM_ checkPostUnariseConArg args
184
185 lintStgExpr (StgOpApp _ args _) =
186 mapM_ lintStgArg args
187
188 lintStgExpr lam@(StgLam _ _) =
189 addErrL (text "Unexpected StgLam" <+> ppr lam)
190
191 lintStgExpr (StgLet _ binds body) = do
192 binders <- lintStgBinds NotTopLevel binds
193 addLoc (BodyOfLetRec binders) $
194 addInScopeVars binders $
195 lintStgExpr body
196
197 lintStgExpr (StgLetNoEscape _ binds body) = do
198 binders <- lintStgBinds NotTopLevel binds
199 addLoc (BodyOfLetRec binders) $
200 addInScopeVars binders $
201 lintStgExpr body
202
203 lintStgExpr (StgTick _ expr) = lintStgExpr expr
204
205 lintStgExpr (StgCase scrut bndr alts_type alts) = do
206 lintStgExpr scrut
207
208 lf <- getLintFlags
209 let in_scope = stgCaseBndrInScope alts_type (lf_unarised lf)
210
211 addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts)
212
213 lintAlt
214 :: (OutputablePass a, BinderP a ~ Id)
215 => (AltCon, [Id], GenStgExpr a) -> LintM ()
216
217 lintAlt (DEFAULT, _, rhs) =
218 lintStgExpr rhs
219
220 lintAlt (LitAlt _, _, rhs) =
221 lintStgExpr rhs
222
223 lintAlt (DataAlt _, bndrs, rhs) = do
224 mapM_ checkPostUnariseBndr bndrs
225 addInScopeVars bndrs (lintStgExpr rhs)
226
227 {-
228 ************************************************************************
229 * *
230 Utilities
231 * *
232 ************************************************************************
233 -}
234
235 bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id]
236 bindersOf (StgNonRec binder _) = [binder]
237 bindersOf (StgRec pairs) = [binder | (binder, _) <- pairs]
238
239 bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id]
240 bindersOfTop (StgTopLifted bind) = bindersOf bind
241 bindersOfTop (StgTopStringLit binder _) = [binder]
242
243 bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id]
244 bindersOfTopBinds = foldr ((++) . bindersOfTop) []
245
246 {-
247 ************************************************************************
248 * *
249 The Lint monad
250 * *
251 ************************************************************************
252 -}
253
254 newtype LintM a = LintM
255 { unLintM :: Module
256 -> LintFlags
257 -> [LintLocInfo] -- Locations
258 -> IdSet -- Local vars in scope
259 -> Bag MsgDoc -- Error messages so far
260 -> (a, Bag MsgDoc) -- Result and error messages (if any)
261 }
262 deriving (Functor)
263
264 data LintFlags = LintFlags { lf_unarised :: !Bool
265 -- ^ have we run the unariser yet?
266 }
267
268 data LintLocInfo
269 = RhsOf Id -- The variable bound
270 | LambdaBodyOf [Id] -- The lambda-binder
271 | BodyOfLetRec [Id] -- One of the binders
272
273 dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
274 dumpLoc (RhsOf v) =
275 (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' )
276 dumpLoc (LambdaBodyOf bs) =
277 (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' )
278
279 dumpLoc (BodyOfLetRec bs) =
280 (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' )
281
282
283 pp_binders :: [Id] -> SDoc
284 pp_binders bs
285 = sep (punctuate comma (map pp_binder bs))
286 where
287 pp_binder b
288 = hsep [ppr b, dcolon, ppr (idType b)]
289
290 initL :: Module -> Bool -> IdSet -> LintM a -> Maybe MsgDoc
291 initL this_mod unarised locals (LintM m) = do
292 let (_, errs) = m this_mod (LintFlags unarised) [] locals emptyBag
293 if isEmptyBag errs then
294 Nothing
295 else
296 Just (vcat (punctuate blankLine (bagToList errs)))
297
298 instance Applicative LintM where
299 pure a = LintM $ \_mod _lf _loc _scope errs -> (a, errs)
300 (<*>) = ap
301 (*>) = thenL_
302
303 instance Monad LintM where
304 (>>=) = thenL
305 (>>) = (*>)
306
307 thenL :: LintM a -> (a -> LintM b) -> LintM b
308 thenL m k = LintM $ \mod lf loc scope errs
309 -> case unLintM m mod lf loc scope errs of
310 (r, errs') -> unLintM (k r) mod lf loc scope errs'
311
312 thenL_ :: LintM a -> LintM b -> LintM b
313 thenL_ m k = LintM $ \mod lf loc scope errs
314 -> case unLintM m mod lf loc scope errs of
315 (_, errs') -> unLintM k mod lf loc scope errs'
316
317 checkL :: Bool -> MsgDoc -> LintM ()
318 checkL True _ = return ()
319 checkL False msg = addErrL msg
320
321 -- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders.
322 checkPostUnariseBndr :: Id -> LintM ()
323 checkPostUnariseBndr bndr = do
324 lf <- getLintFlags
325 when (lf_unarised lf) $
326 forM_ (checkPostUnariseId bndr) $ \unexpected ->
327 addErrL $
328 text "After unarisation, binder " <>
329 ppr bndr <> text " has " <> text unexpected <> text " type " <>
330 ppr (idType bndr)
331
332 -- Arguments shouldn't have sum, tuple, or void types.
333 checkPostUnariseConArg :: StgArg -> LintM ()
334 checkPostUnariseConArg arg = case arg of
335 StgLitArg _ ->
336 return ()
337 StgVarArg id -> do
338 lf <- getLintFlags
339 when (lf_unarised lf) $
340 forM_ (checkPostUnariseId id) $ \unexpected ->
341 addErrL $
342 text "After unarisation, arg " <>
343 ppr id <> text " has " <> text unexpected <> text " type " <>
344 ppr (idType id)
345
346 -- Post-unarisation args and case alt binders should not have unboxed tuple,
347 -- unboxed sum, or void types. Return what the binder is if it is one of these.
348 checkPostUnariseId :: Id -> Maybe String
349 checkPostUnariseId id =
350 let
351 id_ty = idType id
352 is_sum, is_tuple, is_void :: Maybe String
353 is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum"
354 is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple"
355 is_void = guard (isVoidTy id_ty) >> return "void"
356 in
357 is_sum <|> is_tuple <|> is_void
358
359 addErrL :: MsgDoc -> LintM ()
360 addErrL msg = LintM $ \_mod _lf loc _scope errs -> ((), addErr errs msg loc)
361
362 addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
363 addErr errs_so_far msg locs
364 = errs_so_far `snocBag` mk_msg locs
365 where
366 mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
367 in mkLocMessage SevWarning l (hdr $$ msg)
368 mk_msg [] = msg
369
370 addLoc :: LintLocInfo -> LintM a -> LintM a
371 addLoc extra_loc m = LintM $ \mod lf loc scope errs
372 -> unLintM m mod lf (extra_loc:loc) scope errs
373
374 addInScopeVars :: [Id] -> LintM a -> LintM a
375 addInScopeVars ids m = LintM $ \mod lf loc scope errs
376 -> let
377 new_set = mkVarSet ids
378 in unLintM m mod lf loc (scope `unionVarSet` new_set) errs
379
380 getLintFlags :: LintM LintFlags
381 getLintFlags = LintM $ \_mod lf _loc _scope errs -> (lf, errs)
382
383 checkInScope :: Id -> LintM ()
384 checkInScope id = LintM $ \mod _lf loc scope errs
385 -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then
386 ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id),
387 text "is out of scope"]) loc)
388 else
389 ((), errs)
390
391 mkUnliftedTyMsg :: OutputablePass a => Id -> GenStgRhs a -> SDoc
392 mkUnliftedTyMsg binder rhs
393 = (text "Let(rec) binder" <+> quotes (ppr binder) <+>
394 text "has unlifted type" <+> quotes (ppr (idType binder)))
395 $$
396 (text "RHS:" <+> ppr rhs)