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, stderr )
17 import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting )
19 import CoreUtils ( idFreeVars )
22 import Const ( Con(..), DataCon, conType, conOkForApp, conOkForAlt )
23 import Id ( isConstantId, idMustBeINLINEd )
24 import Var ( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar )
26 import VarEnv ( mkVarEnv )
27 import Name ( isLocallyDefined, getSrcLoc )
29 import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message,
30 ErrMsg, addErrLocHdrLine, pprBagOfErrors )
31 import PrimRep ( PrimRep(..) )
32 import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc )
33 import Type ( Type, Kind, tyVarsOfType,
34 splitFunTy_maybe, mkPiType, mkTyVarTy,
35 splitForAllTy_maybe, splitTyConApp_maybe,
36 isUnLiftedType, typeKind, substTy,
37 splitAlgTyConApp_maybe,
41 import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
44 infixr 9 `thenL`, `seqL`
47 %************************************************************************
49 \subsection{Start and end pass}
51 %************************************************************************
53 @beginPass@ and @endPass@ don't really belong here, but it makes a convenient
54 place for them. They print out stuff before and after core passes,
55 and do Core Lint when necessary.
58 beginPass :: String -> IO ()
61 = hPutStr stderr ("*** " ++ pass_name ++ "\n")
66 endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind]
67 endPass pass_name dump_flag binds
69 -- Report verbosely, if required
70 dumpIfSet dump_flag pass_name
71 (pprCoreBindings binds)
74 lintCoreBindings pass_name binds
80 %************************************************************************
82 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
84 %************************************************************************
86 Checks that a set of core bindings is well-formed. The PprStyle and String
87 just control what we print in the event of an error. The Bool value
88 indicates whether we have done any specialisation yet (in which case we do
93 (b) Out-of-scope type variables
94 (c) Out-of-scope local variables
97 If we have done specialisation the we check that there are
98 (a) No top-level bindings of primitive (unboxed type)
103 -- Things are *not* OK if:
105 -- * Unsaturated type app before specialisation has been done;
107 -- * Oversaturated type app after specialisation (eta reduction
108 -- may well be happening...);
111 lintCoreBindings :: String -> [CoreBind] -> IO ()
113 lintCoreBindings whoDunnit binds
114 | not opt_DoCoreLinting
117 lintCoreBindings whoDunnit binds
118 = case (initL (lint_binds binds)) of
119 Nothing -> doIfSet opt_D_show_passes
120 (hPutStr stderr ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
122 Just bad_news -> printDump (display bad_news) >>
125 lint_binds [] = returnL ()
126 lint_binds (bind:binds)
127 = lintCoreBinding bind `thenL` \binders ->
128 addInScopeVars binders (lint_binds binds)
132 text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
134 ptext SLIT("*** Offending Program ***"),
135 pprCoreBindings binds,
136 ptext SLIT("*** End of Offense ***")
140 %************************************************************************
142 \subsection[lintUnfolding]{lintUnfolding}
144 %************************************************************************
146 We use this to check all unfoldings that come in from interfaces
147 (it is very painful to catch errors otherwise):
150 lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
152 lintUnfolding locn expr
154 initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
158 pprTrace "WARNING: Discarded bad unfolding from interface:\n"
160 ptext SLIT("*** Bad unfolding ***"),
162 ptext SLIT("*** End unfolding ***")])
166 %************************************************************************
168 \subsection[lintCoreBinding]{lintCoreBinding}
170 %************************************************************************
172 Check a core binding, returning the list of variables bound.
175 lintCoreBinding :: CoreBind -> LintM [Id]
177 lintCoreBinding (NonRec binder rhs)
178 = lintSingleBinding (binder,rhs) `seqL` returnL [binder]
180 lintCoreBinding (Rec pairs)
181 = addInScopeVars binders (
182 mapL lintSingleBinding pairs `seqL` returnL binders
185 binders = map fst pairs
187 lintSingleBinding (binder,rhs)
188 = addLoc (RhsOf binder) $
191 lintCoreExpr rhs `thenL` \ ty ->
193 -- Check match to RHS type
194 lintBinder binder `seqL`
195 checkTys binder_ty ty (mkRhsMsg binder ty) `seqL`
197 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
198 checkL (not (isUnLiftedType binder_ty))
199 (mkRhsPrimMsg binder rhs) `seqL`
201 -- Check whether binder's specialisations contain any out-of-scope variables
202 mapL (checkBndrIdInScope binder) bndr_vars `seqL`
205 -- We should check the unfolding, if any, but this is tricky because
206 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
208 binder_ty = idType binder
209 bndr_vars = varSetElems (idFreeVars binder)
212 %************************************************************************
214 \subsection[lintCoreExpr]{lintCoreExpr}
216 %************************************************************************
219 lintCoreExpr :: CoreExpr -> LintM Type
221 lintCoreExpr (Var var)
222 | isConstantId var = returnL (idType var)
223 -- Micro-hack here... Class decls generate applications of their
224 -- dictionary constructor, but don't generate a binding for the
225 -- constructor (since it would never be used). After a single round
226 -- of simplification, these dictionary constructors have been
227 -- inlined (from their UnfoldInfo) to CoCons. Just between
228 -- desugaring and simplfication, though, they appear as naked, unbound
229 -- variables as the function in an application.
230 -- The hack here simply doesn't check for out-of-scope-ness for
231 -- data constructors (at least, in a function position).
232 -- Ditto primitive Ids
234 | otherwise = checkIdInScope var `seqL` returnL (idType var)
236 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
237 = lintCoreExpr expr `thenL` \ expr_ty ->
239 lintTy from_ty `seqL`
240 checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
243 lintCoreExpr (Note other_note expr)
246 lintCoreExpr (Let binds body)
247 = lintCoreBinding binds `thenL` \binders ->
248 if (null binders) then
249 lintCoreExpr body -- Can't add a new source location
251 addLoc (BodyOfLetRec binders)
252 (addInScopeVars binders (lintCoreExpr body))
254 lintCoreExpr e@(Con con args)
255 = addLoc (AnExpr e) $
256 checkL (conOkForApp con) (mkConAppMsg e) `seqL`
257 lintCoreArgs (conType con) args
259 lintCoreExpr e@(App fun arg)
260 = lintCoreExpr fun `thenL` \ ty ->
264 lintCoreExpr (Lam var expr)
265 = addLoc (LambdaBodyOf var) $
266 checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
268 (addInScopeVars [var] $
269 lintCoreExpr expr `thenL` \ ty ->
270 returnL (mkPiType var ty))
272 lintCoreExpr e@(Case scrut var alts)
273 = -- Check the scrutinee
274 lintCoreExpr scrut `thenL` \ scrut_ty ->
277 lintBinder var `seqL`
279 -- If this is an unboxed tuple case, then the binder must be dead
281 checkL (if isUnboxedTupleType (idType var)
282 then isDeadBinder var
283 else True) (mkUnboxedTupleMsg var) `seqL`
286 checkTys (idType var) scrut_ty (mkScrutMsg var scrut_ty) `seqL`
288 addInScopeVars [var] (
290 -- Check the alternatives
291 checkAllCasesCovered e scrut_ty alts `seqL`
292 mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) ->
293 mapL (check alt_ty) alt_tys `seqL`
296 check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
298 lintCoreExpr e@(Type ty)
299 = addErrL (mkStrangeTyMsg e)
302 %************************************************************************
304 \subsection[lintCoreArgs]{lintCoreArgs}
306 %************************************************************************
308 The boolean argument indicates whether we should flag type
309 applications to primitive types as being errors.
312 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
314 lintCoreArgs ty [] = returnL ty
315 lintCoreArgs ty (a : args)
316 = lintCoreArg ty a `thenL` \ res ->
317 lintCoreArgs res args
321 lintCoreArg :: Type -> CoreArg -> LintM Type
323 lintCoreArg ty a@(Type arg_ty)
324 = lintTy arg_ty `seqL`
327 lintCoreArg fun_ty arg
328 = -- Make sure function type matches argument
329 lintCoreExpr arg `thenL` \ arg_ty ->
330 case (splitFunTy_maybe fun_ty) of
331 Just (arg,res) | (arg_ty == arg) -> returnL res
332 _ -> addErrL (mkAppMsg fun_ty arg_ty)
337 = case splitForAllTy_maybe ty of
338 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
342 tyvar_kind = tyVarKind tyvar
343 argty_kind = typeKind arg_ty
345 if argty_kind `hasMoreBoxityInfo` tyvar_kind
346 -- Arg type might be boxed for a function with an uncommitted
347 -- tyvar; notably this is used so that we can give
348 -- error :: forall a:*. String -> a
349 -- and then apply it to both boxed and unboxed types.
351 returnL (substTy (mkVarEnv [(tyvar,arg_ty)]) body)
353 addErrL (mkKindErrMsg tyvar arg_ty)
358 lintTyApps fun_ty (arg_ty : arg_tys)
359 = lintTyApp fun_ty arg_ty `thenL` \ fun_ty' ->
360 lintTyApps fun_ty' arg_tys
365 %************************************************************************
367 \subsection[lintCoreAlts]{lintCoreAlts}
369 %************************************************************************
372 checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e)
374 checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL
376 checkAllCasesCovered e scrut_ty alts
377 = case splitTyConApp_maybe scrut_ty of {
378 Nothing -> addErrL (badAltsMsg e);
379 Just (tycon, tycon_arg_tys) ->
381 if isPrimTyCon tycon then
382 checkL (hasDefault alts) (nonExhaustiveAltsMsg e)
385 -- Algebraic cases are not necessarily exhaustive, because
386 -- the simplifer correctly eliminates case that can't
388 -- This code just emits a message to say so
390 missing_cons = filter not_in_alts (tyConDataCons tycon)
391 not_in_alts con = all (not_in_alt con) alts
392 not_in_alt con (DataCon con', _, _) = con /= con'
393 not_in_alt con other = True
395 case_bndr = case e of { Case _ bndr alts -> bndr }
397 if not (hasDefault alts || null missing_cons) then
398 pprTrace "Exciting (but not a problem)! Non-exhaustive case:"
399 (ppr case_bndr <+> ppr missing_cons)
405 hasDefault [] = False
406 hasDefault ((DEFAULT,_,_) : alts) = True
407 hasDefault (alt : alts) = hasDefault alts
411 lintCoreAlt :: Type -- Type of scrutinee
413 -> LintM Type -- Type of alternatives
415 lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs)
416 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
419 lintCoreAlt scrut_ty alt@(con, args, rhs)
420 = addLoc (CaseAlt alt) (
422 checkL (conOkForAlt con) (mkConAltMsg con) `seqL`
424 mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
425 (mkUnboxedTupleMsg arg)) args `seqL`
427 addInScopeVars args (
430 -- Scrutinee type must be a tycon applicn; checked by caller
431 -- This code is remarkably compact considering what it does!
432 -- NB: args must be in scope here so that the lintCoreArgs line works.
433 case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) ->
434 lintTyApps (conType con) tycon_arg_tys `thenL` \ con_type ->
435 lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
436 checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
443 mk_arg b | isTyVar b = Type (mkTyVarTy b)
447 %************************************************************************
449 \subsection[lint-types]{Types}
451 %************************************************************************
454 lintBinder :: IdOrTyVar -> LintM ()
456 -- ToDo: lint its type
458 lintTy :: Type -> LintM ()
459 lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
461 -- ToDo: check the kind structure of the type
465 %************************************************************************
467 \subsection[lint-monad]{The Lint monad}
469 %************************************************************************
472 type LintM a = [LintLocInfo] -- Locations
473 -> IdSet -- Local vars in scope
474 -> Bag ErrMsg -- Error messages so far
475 -> (Maybe a, Bag ErrMsg) -- Result and error messages (if any)
478 = RhsOf Id -- The variable bound
479 | LambdaBodyOf Id -- The lambda-binder
480 | BodyOfLetRec [Id] -- One of the binders
481 | CaseAlt CoreAlt -- Pattern of a case alternative
482 | AnExpr CoreExpr -- Some expression
483 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
487 initL :: LintM a -> Maybe Message
489 = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
490 if isEmptyBag errs then
493 Just (pprBagOfErrors errs)
496 returnL :: a -> LintM a
497 returnL r loc scope errs = (Just r, errs)
500 nopL loc scope errs = (Nothing, errs)
502 thenL :: LintM a -> (a -> LintM b) -> LintM b
503 thenL m k loc scope errs
504 = case m loc scope errs of
505 (Just r, errs') -> k r loc scope errs'
506 (Nothing, errs') -> (Nothing, errs')
508 seqL :: LintM a -> LintM b -> LintM b
509 seqL m k loc scope errs
510 = case m loc scope errs of
511 (_, errs') -> k loc scope errs'
513 mapL :: (a -> LintM b) -> [a] -> LintM [b]
514 mapL f [] = returnL []
517 mapL f xs `thenL` \ rs ->
522 checkL :: Bool -> Message -> LintM ()
523 checkL True msg loc scope errs = (Nothing, errs)
524 checkL False msg loc scope errs = (Nothing, addErr errs msg loc)
526 addErrL :: Message -> LintM a
527 addErrL msg loc scope errs = (Nothing, addErr errs msg loc)
529 addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
531 addErr errs_so_far msg locs
532 = ASSERT (not (null locs))
533 errs_so_far `snocBag` mk_msg msg
535 (loc, pref) = dumpLoc (head locs)
538 | isNoSrcLoc loc = (loc, hang pref 4 msg)
539 | otherwise = addErrLocHdrLine loc pref 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 :: [IdOrTyVar] -> LintM a -> LintM a
546 addInScopeVars ids m loc scope errs
547 = m loc (scope `unionVarSet` mkVarSet ids) errs
551 checkIdInScope :: IdOrTyVar -> LintM ()
553 = checkInScope (ptext SLIT("is out of scope")) id
555 checkBndrIdInScope :: IdOrTyVar -> IdOrTyVar -> LintM ()
556 checkBndrIdInScope binder id
557 = checkInScope msg id
559 msg = ptext SLIT("is out of scope inside info for") <+>
562 checkInScope :: SDoc -> IdOrTyVar -> LintM ()
563 checkInScope loc_msg id loc scope errs
564 | isLocallyDefined id
565 && not (id `elemVarSet` scope)
566 && not (idMustBeINLINEd id) -- Constructors and dict selectors
567 -- don't have bindings,
568 -- just MustInline prags
569 = (Nothing, addErr errs (hsep [ppr id, loc_msg]) loc)
573 checkTys :: Type -> Type -> Message -> LintM ()
574 checkTys ty1 ty2 msg loc scope errs
575 | ty1 == ty2 = (Nothing, errs)
576 | otherwise = (Nothing, addErr errs msg loc)
580 %************************************************************************
582 \subsection{Error messages}
584 %************************************************************************
588 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
590 dumpLoc (LambdaBodyOf b)
591 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
593 dumpLoc (BodyOfLetRec bs)
594 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
597 = (noSrcLoc, text "In the expression:" <+> ppr e)
599 dumpLoc (CaseAlt (con, args, rhs))
600 = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
602 dumpLoc (ImportedUnfolding locn)
603 = (locn, brackets (ptext SLIT("in an imported unfolding")))
605 pp_binders :: [Id] -> SDoc
606 pp_binders bs = sep (punctuate comma (map pp_binder bs))
608 pp_binder :: Id -> SDoc
609 pp_binder b = hsep [ppr b, dcolon, ppr (idType b)]
613 ------------------------------------------------------
614 -- Messages for case expressions
616 mkConAppMsg :: CoreExpr -> Message
618 = hang (text "Application of newtype constructor:")
621 mkConAltMsg :: Con -> Message
623 = text "PrimOp in case pattern:" <+> ppr con
625 mkNullAltsMsg :: CoreExpr -> Message
627 = hang (text "Case expression with no alternatives:")
630 mkDefaultArgsMsg :: [IdOrTyVar] -> Message
631 mkDefaultArgsMsg args
632 = hang (text "DEFAULT case with binders")
635 mkCaseAltMsg :: CoreExpr -> Message
637 = hang (text "Type of case alternatives not the same:")
640 mkScrutMsg :: Id -> Type -> Message
641 mkScrutMsg var scrut_ty
642 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
643 text "Result binder type:" <+> ppr (idType var),
644 text "Scrutinee type:" <+> ppr scrut_ty]
646 badAltsMsg :: CoreExpr -> Message
648 = hang (text "Case statement scrutinee is not a data type:")
651 nonExhaustiveAltsMsg :: CoreExpr -> Message
652 nonExhaustiveAltsMsg e
653 = hang (text "Case expression with non-exhaustive alternatives")
656 mkBadPatMsg :: Type -> Type -> Message
657 mkBadPatMsg con_result_ty scrut_ty
659 text "In a case alternative, pattern result type doesn't match scrutinee type:",
660 text "Pattern result type:" <+> ppr con_result_ty,
661 text "Scrutinee type:" <+> ppr scrut_ty
664 ------------------------------------------------------
665 -- Other error messages
667 mkAppMsg :: Type -> Type -> Message
669 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
670 hang (ptext SLIT("Fun type:")) 4 (ppr fun),
671 hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
673 mkKindErrMsg :: TyVar -> Type -> Message
674 mkKindErrMsg tyvar arg_ty
675 = vcat [ptext SLIT("Kinds don't match in type application:"),
676 hang (ptext SLIT("Type variable:"))
677 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
678 hang (ptext SLIT("Arg type:"))
679 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
681 mkTyAppMsg :: Type -> Type -> Message
683 = vcat [text "Illegal type application:",
684 hang (ptext SLIT("Exp type:"))
685 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
686 hang (ptext SLIT("Arg type:"))
687 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
689 mkRhsMsg :: Id -> Type -> Message
692 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
694 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
695 hsep [ptext SLIT("Rhs type:"), ppr ty]]
697 mkRhsPrimMsg :: Id -> CoreExpr -> Message
698 mkRhsPrimMsg binder rhs
699 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
701 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
704 mkUnboxedTupleMsg :: Id -> Message
705 mkUnboxedTupleMsg binder
706 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
707 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
709 mkCoerceErr from_ty expr_ty
710 = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
711 ptext SLIT("From-type:") <+> ppr from_ty,
712 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
716 = ptext SLIT("Type where expression expected:") <+> ppr e