1{- |
2(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
4A 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
15Because we don't have types and coercions in STG we can't really check types
16here.
17
18Some history:
19
20StgLint used to check types, but it never worked and so it was disabled in 2000
21with 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
30Since 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
32basic properties listed above.
33-}
34
35{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies,
36  DeriveFunctor #-}
37
38module StgLint ( lintStgTopBindings ) where
39
40import GhcPrelude
41
42import StgSyn
43
44import DynFlags
45import Bag              ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
46import BasicTypes       ( TopLevelFlag(..), isTopLevel )
47import CostCentre       ( isCurrentCCS )
48import Id               ( Id, idType, isJoinId, idName )
49import VarSet
50import DataCon
51import CoreSyn          ( AltCon(..) )
52import Name             ( getSrcLoc, nameIsLocalOrFrom )
53import ErrUtils         ( MsgDoc, Severity(..), mkLocMessage )
54import Type
55import RepType
56import SrcLoc
57import Outputable
58import Module           ( Module )
59import qualified ErrUtils as Err
60import Control.Applicative ((<|>))
61import Control.Monad
62
63lintStgTopBindings :: 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
71lintStgTopBindings 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
102lintStgArg :: StgArg -> LintM ()
103lintStgArg (StgLitArg _) = return ()
104lintStgArg (StgVarArg v) = lintStgVar v
105
106lintStgVar :: Id -> LintM ()
107lintStgVar id = checkInScope id
108
109lintStgBinds
110    :: (OutputablePass a, BinderP a ~ Id)
111    => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders
112lintStgBinds top_lvl (StgNonRec binder rhs) = do
113    lint_binds_help top_lvl (binder,rhs)
114    return [binder]
115
116lintStgBinds 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
123lint_binds_help
124    :: (OutputablePass a, BinderP a ~ Id)
125    => TopLevelFlag
126    -> (Id, GenStgRhs a)
127    -> LintM ()
128lint_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.
138checkNoCurrentCCS
139    :: (OutputablePass a, BinderP a ~ Id)
140    => GenStgRhs a
141    -> LintM ()
142checkNoCurrentCCS rhs@(StgRhsClosure _ ccs _ _ _)
143  | isCurrentCCS ccs
144  = addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ ppr rhs)
145checkNoCurrentCCS rhs@(StgRhsCon ccs _ _)
146  | isCurrentCCS ccs
147  = addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ ppr rhs)
148checkNoCurrentCCS _
149  = return ()
150
151lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()
152
153lintStgRhs (StgRhsClosure _ _ _ [] expr)
154  = lintStgExpr expr
155
156lintStgRhs (StgRhsClosure _ _ _ binders expr)
157  = addLoc (LambdaBodyOf binders) $
158      addInScopeVars binders $
159        lintStgExpr expr
160
161lintStgRhs 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
168lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM ()
169
170lintStgExpr (StgLit _) = return ()
171
172lintStgExpr (StgApp fun args) = do
173    lintStgVar fun
174    mapM_ lintStgArg args
175
176lintStgExpr 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
185lintStgExpr (StgOpApp _ args _) =
186    mapM_ lintStgArg args
187
188lintStgExpr lam@(StgLam _ _) =
189    addErrL (text "Unexpected StgLam" <+> ppr lam)
190
191lintStgExpr (StgLet _ binds body) = do
192    binders <- lintStgBinds NotTopLevel binds
193    addLoc (BodyOfLetRec binders) $
194      addInScopeVars binders $
195        lintStgExpr body
196
197lintStgExpr (StgLetNoEscape _ binds body) = do
198    binders <- lintStgBinds NotTopLevel binds
199    addLoc (BodyOfLetRec binders) $
200      addInScopeVars binders $
201        lintStgExpr body
202
203lintStgExpr (StgTick _ expr) = lintStgExpr expr
204
205lintStgExpr (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
213lintAlt
214    :: (OutputablePass a, BinderP a ~ Id)
215    => (AltCon, [Id], GenStgExpr a) -> LintM ()
216
217lintAlt (DEFAULT, _, rhs) =
218    lintStgExpr rhs
219
220lintAlt (LitAlt _, _, rhs) =
221    lintStgExpr rhs
222
223lintAlt (DataAlt _, bndrs, rhs) = do
224    mapM_ checkPostUnariseBndr bndrs
225    addInScopeVars bndrs (lintStgExpr rhs)
226
227{-
228************************************************************************
229*                                                                      *
230Utilities
231*                                                                      *
232************************************************************************
233-}
234
235bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id]
236bindersOf (StgNonRec binder _) = [binder]
237bindersOf (StgRec pairs)       = [binder | (binder, _) <- pairs]
238
239bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id]
240bindersOfTop (StgTopLifted bind) = bindersOf bind
241bindersOfTop (StgTopStringLit binder _) = [binder]
242
243bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id]
244bindersOfTopBinds = foldr ((++) . bindersOfTop) []
245
246{-
247************************************************************************
248*                                                                      *
249The Lint monad
250*                                                                      *
251************************************************************************
252-}
253
254newtype 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
264data LintFlags = LintFlags { lf_unarised :: !Bool
265                             -- ^ have we run the unariser yet?
266                           }
267
268data LintLocInfo
269  = RhsOf Id            -- The variable bound
270  | LambdaBodyOf [Id]   -- The lambda-binder
271  | BodyOfLetRec [Id]   -- One of the binders
272
273dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
274dumpLoc (RhsOf v) =
275  (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' )
276dumpLoc (LambdaBodyOf bs) =
277  (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' )
278
279dumpLoc (BodyOfLetRec bs) =
280  (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' )
281
282
283pp_binders :: [Id] -> SDoc
284pp_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
290initL :: Module -> Bool -> IdSet -> LintM a -> Maybe MsgDoc
291initL 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
298instance Applicative LintM where
299      pure a = LintM $ \_mod _lf _loc _scope errs -> (a, errs)
300      (<*>) = ap
301      (*>)  = thenL_
302
303instance Monad LintM where
304    (>>=) = thenL
305    (>>)  = (*>)
306
307thenL :: LintM a -> (a -> LintM b) -> LintM b
308thenL 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
312thenL_ :: LintM a -> LintM b -> LintM b
313thenL_ 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
317checkL :: Bool -> MsgDoc -> LintM ()
318checkL True  _   = return ()
319checkL False msg = addErrL msg
320
321-- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders.
322checkPostUnariseBndr :: Id -> LintM ()
323checkPostUnariseBndr 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.
333checkPostUnariseConArg :: StgArg -> LintM ()
334checkPostUnariseConArg 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.
348checkPostUnariseId :: Id -> Maybe String
349checkPostUnariseId 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
359addErrL :: MsgDoc -> LintM ()
360addErrL msg = LintM $ \_mod _lf loc _scope errs -> ((), addErr errs msg loc)
361
362addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
363addErr 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
370addLoc :: LintLocInfo -> LintM a -> LintM a
371addLoc extra_loc m = LintM $ \mod lf loc scope errs
372   -> unLintM m mod lf (extra_loc:loc) scope errs
373
374addInScopeVars :: [Id] -> LintM a -> LintM a
375addInScopeVars 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
380getLintFlags :: LintM LintFlags
381getLintFlags = LintM $ \_mod lf _loc _scope errs -> (lf, errs)
382
383checkInScope :: Id -> LintM ()
384checkInScope 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
391mkUnliftedTyMsg :: OutputablePass a => Id -> GenStgRhs a -> SDoc
392mkUnliftedTyMsg 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)
397