2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[StgLint]{A ``lint'' pass to check for Stg correctness}
7 #include "HsVersions.h"
9 module StgLint ( lintStgBindings ) where
15 import Bag ( emptyBag, isEmptyBag, snocBag, foldBag )
16 import Id ( idType, isDataCon,
17 emptyIdSet, isEmptyIdSet, elementOfIdSet,
18 mkIdSet, intersectIdSets,
19 unionIdSets, idSetToList, IdSet(..),
20 GenId{-instanced NamedThing-}
22 import Literal ( literalType, Literal{-instance Outputable-} )
23 import Maybes ( catMaybes )
24 import Outputable ( Outputable(..){-instance * []-},
25 isLocallyDefined, getSrcLoc
27 import PprType ( GenType{-instance Outputable-}, TyCon )
28 import Pretty -- quite a bit of it
29 import PrimOp ( primOpType )
30 import SrcLoc ( SrcLoc{-instance Outputable-} )
31 import Type ( mkFunTys, splitFunTy, maybeAppDataTyCon,
34 import Util ( zipEqual, pprPanic, panic, panic# )
36 infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
38 getInstantiatedDataConSig = panic "StgLint.getInstantiatedDataConSig (ToDo)"
39 splitTypeWithDictsAsArgs = panic "StgLint.splitTypeWithDictsAsArgs (ToDo)"
40 unDictifyTy = panic "StgLint.unDictifyTy (ToDo)"
44 (a) *some* type errors
45 (b) locally-defined variables used but not defined
47 %************************************************************************
49 \subsection{``lint'' for various constructs}
51 %************************************************************************
53 @lintStgBindings@ is the top-level interface function.
56 lintStgBindings :: PprStyle -> String -> [StgBinding] -> [StgBinding]
58 lintStgBindings sty whodunnit binds
60 case (initL (lint_binds binds)) of
62 Just msg -> pprPanic "" (ppAboves [
63 ppStr ("*** Stg Lint Errors: in "++whodunnit++" ***"),
65 ppStr "*** Offending Program ***",
66 ppAboves (map (pprPlainStgBinding sty) binds),
67 ppStr "*** End of Offense ***"])
70 lint_binds :: [StgBinding] -> LintM ()
72 lint_binds [] = returnL ()
73 lint_binds (bind:binds)
74 = lintStgBinds bind `thenL` \ binders ->
75 addInScopeVars binders (
82 lintStgArg :: StgArg -> LintM (Maybe Type)
84 lintStgArg (StgLitArg lit) = returnL (Just (literalType lit))
85 lintStgArg a@(StgVarArg v)
86 = checkInScope v `thenL_`
87 returnL (Just (idType v))
91 lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders
92 lintStgBinds (StgNonRec binder rhs)
93 = lint_binds_help (binder,rhs) `thenL_`
96 lintStgBinds (StgRec pairs)
97 = addInScopeVars binders (
98 mapL lint_binds_help pairs `thenL_`
102 binders = [b | (b,_) <- pairs]
104 lint_binds_help (binder, rhs)
105 = addLoc (RhsOf binder) (
107 lintStgRhs rhs `thenL` \ maybe_rhs_ty ->
109 -- Check match to RHS type
110 (case maybe_rhs_ty of
111 Nothing -> returnL ()
112 Just rhs_ty -> checkTys (idType binder)
114 (mkRhsMsg binder rhs_ty)
122 lintStgRhs :: StgRhs -> LintM (Maybe Type)
124 lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
125 = addLoc (LambdaBodyOf binders) (
126 addInScopeVars binders (
127 lintStgExpr expr `thenMaybeL` \ body_ty ->
128 returnL (Just (mkFunTys (map idType binders) body_ty))
131 lintStgRhs (StgRhsCon _ con args)
132 = mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys ->
133 case maybe_arg_tys of
134 Nothing -> returnL Nothing
135 Just arg_tys -> checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
141 lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Nothing if error found
143 lintStgExpr e@(StgApp fun args _)
144 = lintStgArg fun `thenMaybeL` \ fun_ty ->
145 mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys ->
146 case maybe_arg_tys of
147 Nothing -> returnL Nothing
148 Just arg_tys -> checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
150 lintStgExpr e@(StgCon con args _)
151 = mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys ->
152 case maybe_arg_tys of
153 Nothing -> returnL Nothing
154 Just arg_tys -> checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e)
158 lintStgExpr e@(StgPrim op args _)
159 = mapMaybeL lintStgArg args `thenL` \ maybe_arg_tys ->
160 case maybe_arg_tys of
161 Nothing -> returnL Nothing
162 Just arg_tys -> checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e)
164 op_ty = primOpType op
166 lintStgExpr (StgLet binds body)
167 = lintStgBinds binds `thenL` \ binders ->
168 addLoc (BodyOfLetRec binders) (
169 addInScopeVars binders (
173 lintStgExpr (StgLetNoEscape _ _ binds body)
174 = lintStgBinds binds `thenL` \ binders ->
175 addLoc (BodyOfLetRec binders) (
176 addInScopeVars binders (
180 lintStgExpr (StgSCC _ _ expr) = lintStgExpr expr
182 lintStgExpr e@(StgCase scrut _ _ _ alts)
183 = lintStgExpr scrut `thenMaybeL` \ _ ->
185 -- Check that it is a data type
186 case maybeAppDataTyCon scrut_ty of
187 Nothing -> addErrL (mkCaseDataConMsg e) `thenL_`
190 -> lintStgAlts alts scrut_ty tycon
192 scrut_ty = get_ty alts
194 get_ty (StgAlgAlts ty _ _) = ty
195 get_ty (StgPrimAlts ty _ _) = ty
199 lintStgAlts :: StgCaseAlts
200 -> Type -- Type of scrutinee
201 -> TyCon -- TyCon pinned on the case
202 -> LintM (Maybe Type) -- Type of alternatives
204 lintStgAlts alts scrut_ty case_tycon
206 StgAlgAlts _ alg_alts deflt ->
207 mapL (lintAlgAlt scrut_ty) alg_alts `thenL` \ maybe_alt_tys ->
208 lintDeflt deflt scrut_ty `thenL` \ maybe_deflt_ty ->
209 returnL (maybe_deflt_ty : maybe_alt_tys)
211 StgPrimAlts _ prim_alts deflt ->
212 mapL (lintPrimAlt scrut_ty) prim_alts `thenL` \ maybe_alt_tys ->
213 lintDeflt deflt scrut_ty `thenL` \ maybe_deflt_ty ->
214 returnL (maybe_deflt_ty : maybe_alt_tys)
215 ) `thenL` \ maybe_result_tys ->
216 -- Check the result types
217 case catMaybes (maybe_result_tys) of
218 [] -> returnL Nothing
220 (first_ty:tys) -> mapL check tys `thenL_`
221 returnL (Just first_ty)
223 check ty = checkTys first_ty ty (mkCaseAltMsg alts)
225 lintAlgAlt scrut_ty (con, args, _, rhs)
226 = (case maybeAppDataTyCon scrut_ty of
228 addErrL (mkAlgAltMsg1 scrut_ty)
229 Just (tycon, tys_applied, cons) ->
231 (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
233 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
234 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
236 mapL check (arg_tys `zipEqual` args) `thenL_`
239 addInScopeVars args (
243 check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
245 -- elem: yes, the elem-list here can sometimes be long-ish,
246 -- but as it's use-once, probably not worth doing anything different
247 -- We give it its own copy, so it isn't overloaded.
249 elem x (y:ys) = x==y || elem x ys
251 lintPrimAlt scrut_ty alt@(lit,rhs)
252 = checkTys (literalType lit) scrut_ty (mkPrimAltMsg alt) `thenL_`
255 lintDeflt StgNoDefault scrut_ty = returnL Nothing
256 lintDeflt deflt@(StgBindDefault binder _ rhs) scrut_ty
257 = checkTys (idType binder) scrut_ty (mkDefltMsg deflt) `thenL_`
258 addInScopeVars [binder] (
264 %************************************************************************
266 \subsection[lint-monad]{The Lint monad}
268 %************************************************************************
271 type LintM a = [LintLocInfo] -- Locations
272 -> IdSet -- Local vars in scope
273 -> Bag ErrMsg -- Error messages so far
274 -> (a, Bag ErrMsg) -- Result and error messages (if any)
276 type ErrMsg = PprStyle -> Pretty
279 = RhsOf Id -- The variable bound
280 | LambdaBodyOf [Id] -- The lambda-binder
281 | BodyOfLetRec [Id] -- One of the binders
283 instance Outputable LintLocInfo where
285 = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
287 ppr sty (LambdaBodyOf bs)
288 = ppBesides [ppr sty (getSrcLoc (head bs)),
289 ppStr ": [in body of lambda with binders ", pp_binders sty bs, ppStr "]"]
291 ppr sty (BodyOfLetRec bs)
292 = ppBesides [ppr sty (getSrcLoc (head bs)),
293 ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"]
295 pp_binders :: PprStyle -> [Id] -> Pretty
297 = ppInterleave ppComma (map pp_binder bs)
300 = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
304 initL :: LintM a -> Maybe ErrMsg
306 = case (m [] emptyIdSet emptyBag) of { (_, errs) ->
307 if isEmptyBag errs then
311 foldBag ppAbove ( \ msg -> msg sty ) ppNil errs
315 returnL :: a -> LintM a
316 returnL r loc scope errs = (r, errs)
318 thenL :: LintM a -> (a -> LintM b) -> LintM b
319 thenL m k loc scope errs
320 = case m loc scope errs of
321 (r, errs') -> k r loc scope errs'
323 thenL_ :: LintM a -> LintM b -> LintM b
324 thenL_ m k loc scope errs
325 = case m loc scope errs of
326 (_, errs') -> k loc scope errs'
328 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
329 thenMaybeL m k loc scope errs
330 = case m loc scope errs of
331 (Nothing, errs2) -> (Nothing, errs2)
332 (Just r, errs2) -> k r loc scope errs2
334 thenMaybeL_ :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
335 thenMaybeL_ m k loc scope errs
336 = case m loc scope errs of
337 (Nothing, errs2) -> (Nothing, errs2)
338 (Just _, errs2) -> k loc scope errs2
340 mapL :: (a -> LintM b) -> [a] -> LintM [b]
341 mapL f [] = returnL []
344 mapL f xs `thenL` \ rs ->
347 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
348 -- Returns Nothing if anything fails
349 mapMaybeL f [] = returnL (Just [])
351 = f x `thenMaybeL` \ r ->
352 mapMaybeL f xs `thenMaybeL` \ rs ->
353 returnL (Just (r:rs))
357 checkL :: Bool -> ErrMsg -> LintM ()
358 checkL True msg loc scope errs = ((), errs)
359 checkL False msg loc scope errs = ((), addErr errs msg loc)
361 addErrL :: ErrMsg -> LintM ()
362 addErrL msg loc scope errs = ((), addErr errs msg loc)
364 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
366 addErr errs_so_far msg locs
367 = errs_so_far `snocBag` ( \ sty ->
368 ppHang (ppr sty (head locs)) 4 (msg sty)
371 addLoc :: LintLocInfo -> LintM a -> LintM a
372 addLoc extra_loc m loc scope errs
373 = m (extra_loc:loc) scope errs
375 addInScopeVars :: [Id] -> LintM a -> LintM a
376 addInScopeVars ids m loc scope errs
377 = -- We check if these "new" ids are already
378 -- in scope, i.e., we have *shadowing* going on.
379 -- For now, it's just a "trace"; we may make
380 -- a real error out of it...
382 new_set = mkIdSet ids
384 shadowed = scope `intersectIdSets` new_set
386 -- After adding -fliberate-case, Simon decided he likes shadowed
387 -- names after all. WDP 94/07
388 -- (if isEmptyIdSet shadowed
390 -- else pprTrace "Shadowed vars:" (ppr PprDebug (idSetToList shadowed))) $
391 m loc (scope `unionIdSets` new_set) errs
395 checkFunApp :: Type -- The function type
396 -> [Type] -- The arg type(s)
397 -> ErrMsg -- Error messgae
398 -> LintM (Maybe Type) -- The result type
400 checkFunApp fun_ty arg_tys msg loc scope errs
401 = cfa res_ty expected_arg_tys arg_tys
403 (_, expected_arg_tys, res_ty) = splitTypeWithDictsAsArgs fun_ty
405 cfa res_ty expected [] -- Args have run out; that's fine
406 = (Just (mkFunTys expected res_ty), errs)
408 cfa res_ty [] arg_tys -- Expected arg tys ran out first;
409 -- first see if res_ty is a tyvar template;
410 -- otherwise, maybe res_ty is a
411 -- dictionary type which is actually a function?
413 = (Just res_ty, errs)
415 = case splitFunTy (unDictifyTy res_ty) of
416 ([], _) -> (Nothing, addErr errs msg loc) -- Too many args
417 (new_expected, new_res) -> cfa new_res new_expected arg_tys
419 cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys)
420 = if (sleazy_eq_ty expected_arg_ty arg_ty)
421 then cfa res_ty expected_arg_tys arg_tys
422 else (Nothing, addErr errs msg loc) -- Arg mis-match
426 checkInScope :: Id -> LintM ()
427 checkInScope id loc scope errs
428 = if isLocallyDefined id && not (isDataCon id) && not (id `elementOfIdSet` scope) then
429 ((), addErr errs (\ sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc)
433 checkTys :: Type -> Type -> ErrMsg -> LintM ()
434 checkTys ty1 ty2 msg loc scope errs
435 = if (sleazy_eq_ty ty1 ty2)
437 else ((), addErr errs msg loc)
441 mkCaseAltMsg :: StgCaseAlts -> ErrMsg
442 mkCaseAltMsg alts sty
443 = ppAbove (ppStr "In some case alternatives, type of alternatives not all same:")
444 -- LATER: (ppr sty alts)
445 (panic "mkCaseAltMsg")
447 mkCaseDataConMsg :: StgExpr -> ErrMsg
448 mkCaseDataConMsg expr sty
449 = ppAbove (ppStr "A case scrutinee not a type-constructor type:")
452 mkCaseAbstractMsg :: TyCon -> ErrMsg
453 mkCaseAbstractMsg tycon sty
454 = ppAbove (ppStr "An algebraic case on an abstract type:")
457 mkDefltMsg :: StgCaseDefault -> ErrMsg
459 = ppAbove (ppStr "Binder in default case of a case expression doesn't match type of scrutinee:")
460 --LATER: (ppr sty deflt)
463 mkFunAppMsg :: Type -> [Type] -> StgExpr -> ErrMsg
464 mkFunAppMsg fun_ty arg_tys expr sty
465 = ppAboves [ppStr "In a function application, function type doesn't match arg types:",
466 ppHang (ppStr "Function type:") 4 (ppr sty fun_ty),
467 ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys)),
468 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
470 mkRhsConMsg :: Type -> [Type] -> ErrMsg
471 mkRhsConMsg fun_ty arg_tys sty
472 = ppAboves [ppStr "In a RHS constructor application, con type doesn't match arg types:",
473 ppHang (ppStr "Constructor type:") 4 (ppr sty fun_ty),
474 ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys))]
476 mkUnappTyMsg :: Id -> Type -> ErrMsg
477 mkUnappTyMsg var ty sty
478 = ppAboves [ppStr "Variable has a for-all type, but isn't applied to any types.",
479 ppBeside (ppStr "Var: ") (ppr sty var),
480 ppBeside (ppStr "Its type: ") (ppr sty ty)]
482 mkAlgAltMsg1 :: Type -> ErrMsg
484 = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
487 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
488 mkAlgAltMsg2 ty con sty
490 ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
495 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
496 mkAlgAltMsg3 con alts sty
498 ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:",
503 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
504 mkAlgAltMsg4 ty arg sty
506 ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
511 mkPrimAltMsg :: (Literal, StgExpr) -> ErrMsg
513 = ppAbove (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
516 mkRhsMsg :: Id -> Type -> ErrMsg
517 mkRhsMsg binder ty sty
518 = ppAboves [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
520 ppCat [ppStr "Binder's type:", ppr sty (idType binder)],
521 ppCat [ppStr "Rhs type:", ppr sty ty]
524 pp_expr :: PprStyle -> StgExpr -> Pretty
525 pp_expr sty expr = ppr sty expr
528 -- NB: probably severe overkill (WDP 95/04)
529 = case (splitTypeWithDictsAsArgs ty1) of { (_,tyargs1,tyres1) ->
530 case (splitTypeWithDictsAsArgs ty2) of { (_,tyargs2,tyres2) ->
532 ty11 = mkFunTys tyargs1 tyres1
533 ty22 = mkFunTys tyargs2 tyres2
535 trace "StgLint.sleazy_cmp_ty" $