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