2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[CoreLint]{A ``lint'' pass to check for Core correctness}
13 #include "HsVersions.h"
15 import IO ( hPutStr, hPutStrLn, stderr, stdout )
17 import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug )
19 import CoreFVs ( idFreeVars )
20 import CoreUtils ( exprOkForSpeculation, coreBindsSize )
23 import Literal ( Literal, literalType )
24 import DataCon ( DataCon, dataConRepType )
25 import Id ( mayHaveNoBinding, isDeadBinder )
26 import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId )
28 import Subst ( mkTyVarSubst, substTy )
29 import Name ( isLocallyDefined, getSrcLoc )
31 import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message,
32 ErrMsg, addErrLocHdrLine, pprBagOfErrors )
33 import PrimRep ( PrimRep(..) )
34 import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc )
35 import Type ( Type, Kind, tyVarsOfType,
36 splitFunTy_maybe, mkPiType, mkTyVarTy, unUsgTy,
37 splitForAllTy_maybe, splitTyConApp_maybe,
38 isUnLiftedType, typeKind,
39 splitAlgTyConApp_maybe,
43 import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
44 import BasicTypes ( RecFlag(..), isNonRec )
47 infixr 9 `thenL`, `seqL`
50 %************************************************************************
52 \subsection{Start and end pass}
54 %************************************************************************
56 @beginPass@ and @endPass@ don't really belong here, but it makes a convenient
57 place for them. They print out stuff before and after core passes,
58 and do Core Lint when necessary.
61 beginPass :: String -> IO ()
64 = hPutStrLn stderr ("*** " ++ pass_name)
69 endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind]
70 endPass pass_name dump_flag binds
72 -- Report result size if required
73 -- This has the side effect of forcing the intermediate to be evaluated
74 if opt_D_show_passes then
75 hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds))
79 -- Report verbosely, if required
80 dumpIfSet dump_flag pass_name
81 (pprCoreBindings binds)
84 lintCoreBindings pass_name binds
90 %************************************************************************
92 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
94 %************************************************************************
96 Checks that a set of core bindings is well-formed. The PprStyle and String
97 just control what we print in the event of an error. The Bool value
98 indicates whether we have done any specialisation yet (in which case we do
103 (b) Out-of-scope type variables
104 (c) Out-of-scope local variables
107 If we have done specialisation the we check that there are
108 (a) No top-level bindings of primitive (unboxed type)
113 -- Things are *not* OK if:
115 -- * Unsaturated type app before specialisation has been done;
117 -- * Oversaturated type app after specialisation (eta reduction
118 -- may well be happening...);
121 lintCoreBindings :: String -> [CoreBind] -> IO ()
123 lintCoreBindings whoDunnit binds
124 | not opt_DoCoreLinting
127 lintCoreBindings whoDunnit binds
128 = case (initL (lint_binds binds)) of
129 Nothing -> doIfSet opt_D_show_passes
130 (hPutStr stderr ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
132 Just bad_news -> printDump (display bad_news) >>
135 -- Put all the top-level binders in scope at the start
136 -- This is because transformation rules can bring something
137 -- into use 'unexpectedly'
138 lint_binds binds = addInScopeVars (bindersOfBinds binds) $
141 lint_bind (Rec prs) = mapL (lintSingleBinding Recursive) prs `seqL`
143 lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
147 text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
149 ptext SLIT("*** Offending Program ***"),
150 pprCoreBindings binds,
151 ptext SLIT("*** End of Offense ***")
155 %************************************************************************
157 \subsection[lintUnfolding]{lintUnfolding}
159 %************************************************************************
161 We use this to check all unfoldings that come in from interfaces
162 (it is very painful to catch errors otherwise):
165 lintUnfolding :: SrcLoc
166 -> [Var] -- Treat these as in scope
168 -> Maybe Message -- Nothing => OK
170 lintUnfolding locn vars expr
171 | not opt_DoCoreLinting
175 = initL (addLoc (ImportedUnfolding locn) $
176 addInScopeVars vars $
180 %************************************************************************
182 \subsection[lintCoreBinding]{lintCoreBinding}
184 %************************************************************************
186 Check a core binding, returning the list of variables bound.
189 lintSingleBinding rec_flag (binder,rhs)
190 = addLoc (RhsOf binder) $
193 lintCoreExpr rhs `thenL` \ ty ->
195 -- Check match to RHS type
196 lintBinder binder `seqL`
197 checkTys binder_ty ty (mkRhsMsg binder ty) `seqL`
199 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
200 checkL (not (isUnLiftedType binder_ty) || (isNonRec rec_flag && exprOkForSpeculation rhs))
201 (mkRhsPrimMsg binder rhs) `seqL`
203 -- Check whether binder's specialisations contain any out-of-scope variables
204 mapL (checkBndrIdInScope binder) bndr_vars `seqL`
207 -- We should check the unfolding, if any, but this is tricky because
208 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
210 binder_ty = idType binder
211 bndr_vars = varSetElems (idFreeVars binder)
214 %************************************************************************
216 \subsection[lintCoreExpr]{lintCoreExpr}
218 %************************************************************************
221 lintCoreExpr :: CoreExpr -> LintM Type
223 lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
224 lintCoreExpr (Lit lit) = returnL (literalType lit)
226 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
227 = lintCoreExpr expr `thenL` \ expr_ty ->
229 lintTy from_ty `seqL`
230 checkTys from_ty (unUsgTy expr_ty) (mkCoerceErr from_ty expr_ty) `seqL`
233 lintCoreExpr (Note other_note expr)
236 lintCoreExpr (Let (NonRec bndr rhs) body)
237 = lintSingleBinding NonRecursive (bndr,rhs) `seqL`
238 addLoc (BodyOfLetRec [bndr])
239 (addInScopeVars [bndr] (lintCoreExpr body))
241 lintCoreExpr (Let (Rec pairs) body)
242 = addInScopeVars bndrs $
243 mapL (lintSingleBinding Recursive) pairs `seqL`
244 addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
246 bndrs = map fst pairs
248 lintCoreExpr e@(App fun arg)
249 = lintCoreExpr fun `thenL` \ ty ->
253 lintCoreExpr (Lam var expr)
254 = addLoc (LambdaBodyOf var) $
255 checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
257 (addInScopeVars [var] $
258 lintCoreExpr expr `thenL` \ ty ->
259 returnL (mkPiType var ty))
261 lintCoreExpr e@(Case scrut var alts)
262 = -- Check the scrutinee
263 lintCoreExpr scrut `thenL` \ scrut_ty ->
266 lintBinder var `seqL`
268 -- If this is an unboxed tuple case, then the binder must be dead
270 checkL (if isUnboxedTupleType (idType var)
271 then isDeadBinder var
272 else True) (mkUnboxedTupleMsg var) `seqL`
275 checkTys (idType var) scrut_ty (mkScrutMsg var scrut_ty) `seqL`
277 addInScopeVars [var] (
279 -- Check the alternatives
280 checkAllCasesCovered e scrut_ty alts `seqL`
281 mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) ->
282 mapL (check alt_ty) alt_tys `seqL`
285 check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
287 lintCoreExpr e@(Type ty)
288 = addErrL (mkStrangeTyMsg e)
291 %************************************************************************
293 \subsection[lintCoreArgs]{lintCoreArgs}
295 %************************************************************************
297 The boolean argument indicates whether we should flag type
298 applications to primitive types as being errors.
301 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
303 lintCoreArgs ty [] = returnL ty
304 lintCoreArgs ty (a : args)
305 = lintCoreArg ty a `thenL` \ res ->
306 lintCoreArgs res args
310 lintCoreArg :: Type -> CoreArg -> LintM Type
312 lintCoreArg ty a@(Type arg_ty)
313 = lintTy arg_ty `seqL`
316 lintCoreArg fun_ty arg
317 = -- Make sure function type matches argument
318 lintCoreExpr arg `thenL` \ arg_ty ->
319 case (splitFunTy_maybe fun_ty) of
320 Just (arg,res) | (arg_ty == arg) -> returnL res
321 _ -> addErrL (mkAppMsg fun_ty arg_ty)
326 = case splitForAllTy_maybe ty of
327 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
331 tyvar_kind = tyVarKind tyvar
332 argty_kind = typeKind arg_ty
334 if argty_kind `hasMoreBoxityInfo` tyvar_kind
335 -- Arg type might be boxed for a function with an uncommitted
336 -- tyvar; notably this is used so that we can give
337 -- error :: forall a:*. String -> a
338 -- and then apply it to both boxed and unboxed types.
340 returnL (substTy (mkTyVarSubst [tyvar] [arg_ty]) body)
342 addErrL (mkKindErrMsg tyvar arg_ty)
347 lintTyApps fun_ty (arg_ty : arg_tys)
348 = lintTyApp fun_ty arg_ty `thenL` \ fun_ty' ->
349 lintTyApps fun_ty' arg_tys
354 %************************************************************************
356 \subsection[lintCoreAlts]{lintCoreAlts}
358 %************************************************************************
361 checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e)
363 checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL
365 checkAllCasesCovered e scrut_ty alts
366 = case splitTyConApp_maybe scrut_ty of {
367 Nothing -> addErrL (badAltsMsg e);
368 Just (tycon, tycon_arg_tys) ->
370 if isPrimTyCon tycon then
371 checkL (hasDefault alts) (nonExhaustiveAltsMsg e)
375 -- Algebraic cases are not necessarily exhaustive, because
376 -- the simplifer correctly eliminates case that can't
378 -- This code just emits a message to say so
380 missing_cons = filter not_in_alts (tyConDataCons tycon)
381 not_in_alts con = all (not_in_alt con) alts
382 not_in_alt con (DataCon con', _, _) = con /= con'
383 not_in_alt con other = True
385 case_bndr = case e of { Case _ bndr alts -> bndr }
387 if not (hasDefault alts || null missing_cons) then
388 pprTrace "Exciting (but not a problem)! Non-exhaustive case:"
389 (ppr case_bndr <+> ppr missing_cons)
396 hasDefault [] = False
397 hasDefault ((DEFAULT,_,_) : alts) = True
398 hasDefault (alt : alts) = hasDefault alts
402 lintCoreAlt :: Type -- Type of scrutinee
404 -> LintM Type -- Type of alternatives
406 lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs)
407 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
410 lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
411 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
412 checkTys lit_ty scrut_ty
413 (mkBadPatMsg lit_ty scrut_ty) `seqL`
416 lit_ty = literalType lit
418 lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
419 = addLoc (CaseAlt alt) (
421 mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
422 (mkUnboxedTupleMsg arg)) args `seqL`
424 addInScopeVars args (
427 -- Scrutinee type must be a tycon applicn; checked by caller
428 -- This code is remarkably compact considering what it does!
429 -- NB: args must be in scope here so that the lintCoreArgs line works.
430 case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) ->
431 lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type ->
432 lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
433 checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
440 mk_arg b | isTyVar b = Type (mkTyVarTy b)
444 %************************************************************************
446 \subsection[lint-types]{Types}
448 %************************************************************************
451 lintBinder :: Var -> LintM ()
453 -- ToDo: lint its type
455 lintTy :: Type -> LintM ()
456 lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
458 -- ToDo: check the kind structure of the type
462 %************************************************************************
464 \subsection[lint-monad]{The Lint monad}
466 %************************************************************************
469 type LintM a = [LintLocInfo] -- Locations
470 -> IdSet -- Local vars in scope
471 -> Bag ErrMsg -- Error messages so far
472 -> (Maybe a, Bag ErrMsg) -- Result and error messages (if any)
475 = RhsOf Id -- The variable bound
476 | LambdaBodyOf Id -- The lambda-binder
477 | BodyOfLetRec [Id] -- One of the binders
478 | CaseAlt CoreAlt -- Pattern of a case alternative
479 | AnExpr CoreExpr -- Some expression
480 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
484 initL :: LintM a -> Maybe Message
486 = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
487 if isEmptyBag errs then
490 Just (pprBagOfErrors errs)
493 returnL :: a -> LintM a
494 returnL r loc scope errs = (Just r, errs)
497 nopL loc scope errs = (Nothing, errs)
499 thenL :: LintM a -> (a -> LintM b) -> LintM b
500 thenL m k loc scope errs
501 = case m loc scope errs of
502 (Just r, errs') -> k r loc scope errs'
503 (Nothing, errs') -> (Nothing, errs')
505 seqL :: LintM a -> LintM b -> LintM b
506 seqL m k loc scope errs
507 = case m loc scope errs of
508 (_, errs') -> k loc scope errs'
510 mapL :: (a -> LintM b) -> [a] -> LintM [b]
511 mapL f [] = returnL []
514 mapL f xs `thenL` \ rs ->
519 checkL :: Bool -> Message -> LintM ()
520 checkL True msg loc scope errs = (Nothing, errs)
521 checkL False msg loc scope errs = (Nothing, addErr errs msg loc)
523 addErrL :: Message -> LintM a
524 addErrL msg loc scope errs = (Nothing, addErr errs msg loc)
526 addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
528 addErr errs_so_far msg locs
529 = ASSERT (not (null locs))
530 errs_so_far `snocBag` mk_msg msg
532 (loc, cxt1) = dumpLoc (head locs)
533 cxts = [snd (dumpLoc loc) | loc <- locs]
534 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
538 | isNoSrcLoc loc = (loc, hang context 4 msg)
539 | otherwise = addErrLocHdrLine loc context msg
541 addLoc :: LintLocInfo -> LintM a -> LintM a
542 addLoc extra_loc m loc scope errs
543 = m (extra_loc:loc) scope errs
545 addInScopeVars :: [Var] -> LintM a -> LintM a
546 addInScopeVars ids m loc scope errs
547 = m loc (scope `unionVarSet` mkVarSet ids) errs
551 checkIdInScope :: Var -> LintM ()
553 = checkInScope (ptext SLIT("is out of scope")) id
555 checkBndrIdInScope :: Var -> Var -> LintM ()
556 checkBndrIdInScope binder id
557 = checkInScope msg id
559 msg = ptext SLIT("is out of scope inside info for") <+>
562 checkInScope :: SDoc -> Var -> LintM ()
563 checkInScope loc_msg var loc scope errs
564 | isLocallyDefined var
565 && not (var `elemVarSet` scope)
566 && not (isId var && mayHaveNoBinding var)
567 -- Micro-hack here... Class decls generate applications of their
568 -- dictionary constructor, but don't generate a binding for the
569 -- constructor (since it would never be used). After a single round
570 -- of simplification, these dictionary constructors have been
571 -- inlined (from their UnfoldInfo) to CoCons. Just between
572 -- desugaring and simplfication, though, they appear as naked, unbound
573 -- variables as the function in an application.
574 -- The hack here simply doesn't check for out-of-scope-ness for
575 -- data constructors (at least, in a function position).
576 -- Ditto primitive Ids
577 = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc)
581 checkTys :: Type -> Type -> Message -> LintM ()
582 checkTys ty1 ty2 msg loc scope errs
583 | ty1 == ty2 = (Nothing, errs)
584 | otherwise = (Nothing, addErr errs msg loc)
588 %************************************************************************
590 \subsection{Error messages}
592 %************************************************************************
596 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
598 dumpLoc (LambdaBodyOf b)
599 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
601 dumpLoc (BodyOfLetRec bs)
602 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
605 = (noSrcLoc, text "In the expression:" <+> ppr e)
607 dumpLoc (CaseAlt (con, args, rhs))
608 = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
610 dumpLoc (ImportedUnfolding locn)
611 = (locn, brackets (ptext SLIT("in an imported unfolding")))
613 pp_binders :: [Id] -> SDoc
614 pp_binders bs = sep (punctuate comma (map pp_binder bs))
616 pp_binder :: Id -> SDoc
617 pp_binder b = hsep [ppr b, dcolon, ppr (idType b)]
621 ------------------------------------------------------
622 -- Messages for case expressions
624 mkNullAltsMsg :: CoreExpr -> Message
626 = hang (text "Case expression with no alternatives:")
629 mkDefaultArgsMsg :: [Var] -> Message
630 mkDefaultArgsMsg args
631 = hang (text "DEFAULT case with binders")
634 mkCaseAltMsg :: CoreExpr -> Message
636 = hang (text "Type of case alternatives not the same:")
639 mkScrutMsg :: Id -> Type -> Message
640 mkScrutMsg var scrut_ty
641 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
642 text "Result binder type:" <+> ppr (idType var),
643 text "Scrutinee type:" <+> ppr scrut_ty]
645 badAltsMsg :: CoreExpr -> Message
647 = hang (text "Case statement scrutinee is not a data type:")
650 nonExhaustiveAltsMsg :: CoreExpr -> Message
651 nonExhaustiveAltsMsg e
652 = hang (text "Case expression with non-exhaustive alternatives")
655 mkBadPatMsg :: Type -> Type -> Message
656 mkBadPatMsg con_result_ty scrut_ty
658 text "In a case alternative, pattern result type doesn't match scrutinee type:",
659 text "Pattern result type:" <+> ppr con_result_ty,
660 text "Scrutinee type:" <+> ppr scrut_ty
663 ------------------------------------------------------
664 -- Other error messages
667 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
668 hang (ptext SLIT("Fun type:")) 4 (ppr fun),
669 hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
671 mkKindErrMsg :: TyVar -> Type -> Message
672 mkKindErrMsg tyvar arg_ty
673 = vcat [ptext SLIT("Kinds don't match in type application:"),
674 hang (ptext SLIT("Type variable:"))
675 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
676 hang (ptext SLIT("Arg type:"))
677 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
679 mkTyAppMsg :: Type -> Type -> Message
681 = vcat [text "Illegal type application:",
682 hang (ptext SLIT("Exp type:"))
683 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
684 hang (ptext SLIT("Arg type:"))
685 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
687 mkRhsMsg :: Id -> Type -> Message
690 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
692 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
693 hsep [ptext SLIT("Rhs type:"), ppr ty]]
695 mkRhsPrimMsg :: Id -> CoreExpr -> Message
696 mkRhsPrimMsg binder rhs
697 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
699 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
702 mkUnboxedTupleMsg :: Id -> Message
703 mkUnboxedTupleMsg binder
704 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
705 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
707 mkCoerceErr from_ty expr_ty
708 = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
709 ptext SLIT("From-type:") <+> ppr from_ty,
710 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
714 = ptext SLIT("Type where expression expected:") <+> ppr e