2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
4 \section[StgLint]{A ``lint'' pass to check for Stg correctness}
7 #include "HsVersions.h"
9 module StgLint ( lintStgBindings ) where
11 import PrelInfo ( primOpType, mkFunTy, PrimOp(..), PrimRep
12 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
13 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
17 import Literal ( literalType, Literal )
18 import Id ( idType, isDataCon,
19 getInstantiatedDataConSig
24 import SrcLoc ( SrcLoc )
29 infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
33 (a) *some* type errors
34 (b) locally-defined variables used but not defined
36 %************************************************************************
38 \subsection{``lint'' for various constructs}
40 %************************************************************************
42 @lintStgBindings@ is the top-level interface function.
45 lintStgBindings :: PprStyle -> String -> [StgBinding] -> [StgBinding]
47 lintStgBindings sty whodunnit binds
49 case (initL (lint_binds binds)) of
51 Just msg -> pprPanic "" (ppAboves [
52 ppStr ("*** Stg Lint Errors: in "++whodunnit++" ***"),
54 ppStr "*** Offending Program ***",
55 ppAboves (map (pprPlainStgBinding sty) binds),
56 ppStr "*** End of Offense ***"])
59 lint_binds :: [StgBinding] -> LintM ()
61 lint_binds [] = returnL ()
62 lint_binds (bind:binds)
63 = lintStgBinds bind `thenL` \ binders ->
64 addInScopeVars binders (
71 lintStgArg :: StgArg -> LintM (Maybe Type)
73 lintStgArg (StgLitArg lit) = returnL (Just (literalType lit))
74 lintStgArg a@(StgVarArg v)
75 = checkInScope v `thenL_`
76 returnL (Just (idType v))
80 lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders
81 lintStgBinds (StgNonRec binder rhs)
82 = lint_binds_help (binder,rhs) `thenL_`
85 lintStgBinds (StgRec pairs)
86 = addInScopeVars binders (
87 mapL lint_binds_help pairs `thenL_`
91 binders = [b | (b,_) <- pairs]
93 lint_binds_help (binder, rhs)
94 = addLoc (RhsOf binder) (
96 lintStgRhs rhs `thenL` \ maybe_rhs_ty ->
98 -- Check match to RHS type
100 Nothing -> returnL ()
101 Just rhs_ty -> checkTys (idType binder)
103 (mkRhsMsg binder rhs_ty)
111 lintStgRhs :: StgRhs -> LintM (Maybe Type)
113 lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
114 = addLoc (LambdaBodyOf binders) (
115 addInScopeVars binders (
116 lintStgExpr expr `thenMaybeL` \ body_ty ->
117 returnL (Just (foldr (mkFunTy . idType) body_ty binders))
120 lintStgRhs (StgRhsCon _ con args)
121 = mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys ->
122 case maybe_arg_tys of
123 Nothing -> returnL Nothing
124 Just arg_tys -> checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
130 lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Nothing if error found
132 lintStgExpr e@(StgApp fun args _)
133 = lintStgArg fun `thenMaybeL` \ fun_ty ->
134 mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys ->
135 case maybe_arg_tys of
136 Nothing -> returnL Nothing
137 Just arg_tys -> checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
139 lintStgExpr e@(StgCon con args _)
140 = mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys ->
141 case maybe_arg_tys of
142 Nothing -> returnL Nothing
143 Just arg_tys -> checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e)
147 lintStgExpr e@(StgPrim op args _)
148 = mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys ->
149 case maybe_arg_tys of
150 Nothing -> returnL Nothing
151 Just arg_tys -> checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e)
153 op_ty = primOpType op
155 lintStgExpr (StgLet binds body)
156 = lintStgBinds binds `thenL` \ binders ->
157 addLoc (BodyOfLetRec binders) (
158 addInScopeVars binders (
162 lintStgExpr (StgLetNoEscape _ _ binds body)
163 = lintStgBinds binds `thenL` \ binders ->
164 addLoc (BodyOfLetRec binders) (
165 addInScopeVars binders (
169 lintStgExpr (StgSCC _ _ expr) = lintStgExpr expr
171 lintStgExpr e@(StgCase scrut _ _ _ alts)
172 = lintStgExpr scrut `thenMaybeL` \ _ ->
174 -- Check that it is a data type
175 case maybeDataTyCon scrut_ty of
176 Nothing -> addErrL (mkCaseDataConMsg e) `thenL_`
179 -> lintStgAlts alts scrut_ty tycon
181 scrut_ty = get_ty alts
183 get_ty (StgAlgAlts ty _ _) = ty
184 get_ty (StgPrimAlts ty _ _) = ty
188 lintStgAlts :: StgCaseAlts
189 -> Type -- Type of scrutinee
190 -> TyCon -- TyCon pinned on the case
191 -> LintM (Maybe Type) -- Type of alternatives
193 lintStgAlts alts scrut_ty case_tycon
195 StgAlgAlts _ alg_alts deflt ->
196 chk_non_abstract_type case_tycon `thenL_`
197 mapL (lintAlgAlt scrut_ty) alg_alts `thenL` \ maybe_alt_tys ->
198 lintDeflt deflt scrut_ty `thenL` \ maybe_deflt_ty ->
199 returnL (maybe_deflt_ty : maybe_alt_tys)
201 StgPrimAlts _ prim_alts deflt ->
202 mapL (lintPrimAlt scrut_ty) prim_alts `thenL` \ maybe_alt_tys ->
203 lintDeflt deflt scrut_ty `thenL` \ maybe_deflt_ty ->
204 returnL (maybe_deflt_ty : maybe_alt_tys)
205 ) `thenL` \ maybe_result_tys ->
206 -- Check the result types
207 case catMaybes (maybe_result_tys) of
208 [] -> returnL Nothing
210 (first_ty:tys) -> mapL check tys `thenL_`
211 returnL (Just first_ty)
213 check ty = checkTys first_ty ty (mkCaseAltMsg alts)
215 chk_non_abstract_type tycon
216 = case (getTyConFamilySize tycon) of
217 Nothing -> addErrL (mkCaseAbstractMsg tycon)
218 Just _ -> returnL () -- that's cool
220 lintAlgAlt scrut_ty (con, args, _, rhs)
221 = (case maybeDataTyCon scrut_ty of
223 addErrL (mkAlgAltMsg1 scrut_ty)
224 Just (tycon, tys_applied, cons) ->
226 (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
228 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
229 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
231 mapL check (arg_tys `zipEqual` args) `thenL_`
234 addInScopeVars args (
238 check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
240 -- elem: yes, the elem-list here can sometimes be long-ish,
241 -- but as it's use-once, probably not worth doing anything different
242 -- We give it its own copy, so it isn't overloaded.
244 elem x (y:ys) = x==y || elem x ys
246 lintPrimAlt scrut_ty alt@(lit,rhs)
247 = checkTys (literalType lit) scrut_ty (mkPrimAltMsg alt) `thenL_`
250 lintDeflt StgNoDefault scrut_ty = returnL Nothing
251 lintDeflt deflt@(StgBindDefault binder _ rhs) scrut_ty
252 = checkTys (idType binder) scrut_ty (mkDefltMsg deflt) `thenL_`
253 addInScopeVars [binder] (
259 %************************************************************************
261 \subsection[lint-monad]{The Lint monad}
263 %************************************************************************
266 type LintM a = [LintLocInfo] -- Locations
267 -> UniqSet Id -- Local vars in scope
268 -> Bag ErrMsg -- Error messages so far
269 -> (a, Bag ErrMsg) -- Result and error messages (if any)
271 type ErrMsg = PprStyle -> Pretty
274 = RhsOf Id -- The variable bound
275 | LambdaBodyOf [Id] -- The lambda-binder
276 | BodyOfLetRec [Id] -- One of the binders
278 instance Outputable LintLocInfo where
280 = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
282 ppr sty (LambdaBodyOf bs)
283 = ppBesides [ppr sty (getSrcLoc (head bs)),
284 ppStr ": [in body of lambda with binders ", pp_binders sty bs, ppStr "]"]
286 ppr sty (BodyOfLetRec bs)
287 = ppBesides [ppr sty (getSrcLoc (head bs)),
288 ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"]
290 pp_binders :: PprStyle -> [Id] -> Pretty
292 = ppInterleave ppComma (map pp_binder bs)
295 = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
299 initL :: LintM a -> Maybe ErrMsg
301 = case (m [] emptyUniqSet emptyBag) of { (_, errs) ->
302 if isEmptyBag errs then
306 ppAboves [ msg sty | msg <- bagToList errs ]
310 returnL :: a -> LintM a
311 returnL r loc scope errs = (r, errs)
313 thenL :: LintM a -> (a -> LintM b) -> LintM b
314 thenL m k loc scope errs
315 = case m loc scope errs of
316 (r, errs') -> k r loc scope errs'
318 thenL_ :: LintM a -> LintM b -> LintM b
319 thenL_ m k loc scope errs
320 = case m loc scope errs of
321 (_, errs') -> k loc scope errs'
323 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
324 thenMaybeL m k loc scope errs
325 = case m loc scope errs of
326 (Nothing, errs2) -> (Nothing, errs2)
327 (Just r, errs2) -> k r loc scope errs2
329 thenMaybeL_ :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
330 thenMaybeL_ m k loc scope errs
331 = case m loc scope errs of
332 (Nothing, errs2) -> (Nothing, errs2)
333 (Just _, errs2) -> k loc scope errs2
335 mapL :: (a -> LintM b) -> [a] -> LintM [b]
336 mapL f [] = returnL []
339 mapL f xs `thenL` \ rs ->
342 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
343 -- Returns Nothing if anything fails
344 mapMaybeL f [] = returnL (Just [])
346 = f x `thenMaybeL` \ r ->
347 mapMaybeL f xs `thenMaybeL` \ rs ->
348 returnL (Just (r:rs))
352 checkL :: Bool -> ErrMsg -> LintM ()
353 checkL True msg loc scope errs = ((), errs)
354 checkL False msg loc scope errs = ((), addErr errs msg loc)
356 addErrL :: ErrMsg -> LintM ()
357 addErrL msg loc scope errs = ((), addErr errs msg loc)
359 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
361 addErr errs_so_far msg locs
362 = errs_so_far `snocBag` ( \ sty ->
363 ppHang (ppr sty (head locs)) 4 (msg sty)
366 addLoc :: LintLocInfo -> LintM a -> LintM a
367 addLoc extra_loc m loc scope errs
368 = m (extra_loc:loc) scope errs
370 addInScopeVars :: [Id] -> LintM a -> LintM a
371 addInScopeVars ids m loc scope errs
372 = -- We check if these "new" ids are already
373 -- in scope, i.e., we have *shadowing* going on.
374 -- For now, it's just a "trace"; we may make
375 -- a real error out of it...
377 new_set = mkUniqSet ids
379 shadowed = scope `intersectUniqSets` new_set
381 -- After adding -fliberate-case, Simon decided he likes shadowed
382 -- names after all. WDP 94/07
383 -- (if isEmptyUniqSet shadowed
385 -- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
386 m loc (scope `unionUniqSets` new_set) errs
391 checkFunApp :: Type -- The function type
392 -> [Type] -- The arg type(s)
393 -> ErrMsg -- Error messgae
394 -> LintM (Maybe Type) -- The result type
396 checkFunApp fun_ty arg_tys msg loc scope errs
397 = cfa res_ty expected_arg_tys arg_tys
399 (_, expected_arg_tys, res_ty) = splitTypeWithDictsAsArgs fun_ty
401 cfa res_ty expected [] -- Args have run out; that's fine
402 = (Just (glueTyArgs expected res_ty), errs)
404 cfa res_ty [] arg_tys -- Expected arg tys ran out first;
405 -- first see if res_ty is a tyvar template;
406 -- otherwise, maybe res_ty is a
407 -- dictionary type which is actually a function?
408 | isTyVarTemplateTy res_ty
409 = (Just res_ty, errs)
411 = case splitTyArgs (unDictifyTy res_ty) of
412 ([], _) -> (Nothing, addErr errs msg loc) -- Too many args
413 (new_expected, new_res) -> cfa new_res new_expected arg_tys
415 cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys)
416 = case (sleazy_cmp_ty expected_arg_ty arg_ty) of
417 EQ_ -> cfa res_ty expected_arg_tys arg_tys
418 _ -> (Nothing, addErr errs msg loc) -- Arg mis-match
422 checkInScope :: Id -> LintM ()
423 checkInScope id loc scope errs
424 = if isLocallyDefined id && not (isDataCon id) && not (id `elementOfUniqSet` scope) then
425 ((), addErr errs (\ sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc)
429 checkTys :: Type -> Type -> ErrMsg -> LintM ()
430 checkTys ty1 ty2 msg loc scope errs
431 = case (sleazy_cmp_ty ty1 ty2) of
433 other -> ((), addErr errs msg loc)
437 mkCaseAltMsg :: StgCaseAlts -> ErrMsg
438 mkCaseAltMsg alts sty
439 = ppAbove (ppStr "In some case alternatives, type of alternatives not all same:")
440 -- LATER: (ppr sty alts)
441 (panic "mkCaseAltMsg")
443 mkCaseDataConMsg :: StgExpr -> ErrMsg
444 mkCaseDataConMsg expr sty
445 = ppAbove (ppStr "A case scrutinee not a type-constructor type:")
448 mkCaseAbstractMsg :: TyCon -> ErrMsg
449 mkCaseAbstractMsg tycon sty
450 = ppAbove (ppStr "An algebraic case on an abstract type:")
453 mkDefltMsg :: StgCaseDefault -> ErrMsg
455 = ppAbove (ppStr "Binder in default case of a case expression doesn't match type of scrutinee:")
456 --LATER: (ppr sty deflt)
459 mkFunAppMsg :: Type -> [Type] -> StgExpr -> ErrMsg
460 mkFunAppMsg fun_ty arg_tys expr sty
461 = ppAboves [ppStr "In a function application, function type doesn't match arg types:",
462 ppHang (ppStr "Function type:") 4 (ppr sty fun_ty),
463 ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys)),
464 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
466 mkRhsConMsg :: Type -> [Type] -> ErrMsg
467 mkRhsConMsg fun_ty arg_tys sty
468 = ppAboves [ppStr "In a RHS constructor application, con type doesn't match arg types:",
469 ppHang (ppStr "Constructor type:") 4 (ppr sty fun_ty),
470 ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys))]
472 mkUnappTyMsg :: Id -> Type -> ErrMsg
473 mkUnappTyMsg var ty sty
474 = ppAboves [ppStr "Variable has a for-all type, but isn't applied to any types.",
475 ppBeside (ppStr "Var: ") (ppr sty var),
476 ppBeside (ppStr "Its type: ") (ppr sty ty)]
478 mkAlgAltMsg1 :: Type -> ErrMsg
480 = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
483 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
484 mkAlgAltMsg2 ty con sty
486 ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
491 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
492 mkAlgAltMsg3 con alts sty
494 ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:",
499 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
500 mkAlgAltMsg4 ty arg sty
502 ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
507 mkPrimAltMsg :: (Literal, StgExpr) -> ErrMsg
509 = ppAbove (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
512 mkRhsMsg :: Id -> Type -> ErrMsg
513 mkRhsMsg binder ty sty
514 = ppAboves [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
516 ppCat [ppStr "Binder's type:", ppr sty (idType binder)],
517 ppCat [ppStr "Rhs type:", ppr sty ty]
520 pp_expr :: PprStyle -> StgExpr -> Pretty
521 pp_expr sty expr = ppr sty expr
523 sleazy_cmp_ty ty1 ty2
524 -- NB: probably severe overkill (WDP 95/04)
525 = case (splitTypeWithDictsAsArgs ty1) of { (_,tyargs1,tyres1) ->
526 case (splitTypeWithDictsAsArgs ty2) of { (_,tyargs2,tyres2) ->
528 ty11 = glueTyArgs tyargs1 tyres1
529 ty22 = glueTyArgs tyargs2 tyres2
531 cmpUniType False{-!!!NOT PROPERLY!!!-} ty11 ty22