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