2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[CoreLint]{A ``lint'' pass to check for Core correctness}
10 beginPass, endPass, endPassWithRules
13 #include "HsVersions.h"
15 import IO ( hPutStr, hPutStrLn, stdout )
18 import Rules ( RuleBase, pprRuleBase )
19 import CoreFVs ( idFreeVars, mustHaveLocalBinding )
20 import CoreUtils ( exprOkForSpeculation, coreBindsSize, mkPiType )
23 import Literal ( literalType )
24 import DataCon ( dataConRepType )
25 import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId )
27 import Subst ( mkTyVarSubst, substTy )
28 import Name ( getSrcLoc )
30 import ErrUtils ( doIfSet_dyn, dumpIfSet, ghcExit, Message,
31 ErrMsg, addErrLocHdrLine, pprBagOfErrors,
32 WarnMsg, pprBagOfWarnings)
33 import SrcLoc ( SrcLoc, noSrcLoc )
34 import Type ( Type, tyVarsOfType,
35 splitFunTy_maybe, mkTyVarTy,
36 splitForAllTy_maybe, splitTyConApp_maybe,
37 isUnLiftedType, typeKind,
41 import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
42 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 :: DynFlags -> String -> IO ()
62 beginPass dflags pass_name
63 | dopt Opt_D_show_passes dflags
64 = hPutStrLn stdout ("*** " ++ pass_name)
69 endPass :: DynFlags -> String -> Bool -> [CoreBind] -> IO [CoreBind]
70 endPass dflags pass_name dump_flag binds
72 (binds, _) <- endPassWithRules dflags pass_name dump_flag binds Nothing
75 endPassWithRules :: DynFlags -> String -> Bool -> [CoreBind] -> Maybe RuleBase
76 -> IO ([CoreBind], Maybe RuleBase)
77 endPassWithRules dflags pass_name dump_flag binds rules
79 -- ToDo: force the rules?
81 -- Report result size if required
82 -- This has the side effect of forcing the intermediate to be evaluated
83 if dopt Opt_D_show_passes dflags then
84 hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds))
88 -- Report verbosely, if required
89 dumpIfSet dump_flag pass_name
90 (pprCoreBindings binds $$ case rules of
92 Just rb -> pprRuleBase rb)
95 lintCoreBindings dflags pass_name binds
96 -- ToDo: lint the rules
102 %************************************************************************
104 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
106 %************************************************************************
108 Checks that a set of core bindings is well-formed. The PprStyle and String
109 just control what we print in the event of an error. The Bool value
110 indicates whether we have done any specialisation yet (in which case we do
115 (b) Out-of-scope type variables
116 (c) Out-of-scope local variables
119 If we have done specialisation the we check that there are
120 (a) No top-level bindings of primitive (unboxed type)
125 -- Things are *not* OK if:
127 -- * Unsaturated type app before specialisation has been done;
129 -- * Oversaturated type app after specialisation (eta reduction
130 -- may well be happening...);
133 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
135 lintCoreBindings dflags whoDunnit binds
136 | not (dopt Opt_DoCoreLinting dflags)
139 lintCoreBindings dflags whoDunnit binds
140 = case (initL (lint_binds binds)) of
141 (Nothing, Nothing) -> done_lint
143 (Nothing, Just warnings) -> printDump (warn warnings) >>
146 (Just bad_news, warns) -> printDump (display bad_news warns) >>
149 -- Put all the top-level binders in scope at the start
150 -- This is because transformation rules can bring something
151 -- into use 'unexpectedly'
152 lint_binds binds = addInScopeVars (bindersOfBinds binds) $
155 lint_bind (Rec prs) = mapL (lintSingleBinding Recursive) prs `seqL`
157 lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
159 done_lint = doIfSet_dyn dflags (dopt Opt_D_show_passes)
160 (hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
163 text ("*** Core Lint Warnings: in result of " ++ whoDunnit ++ " ***"),
168 display bad_news warns
170 text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
172 maybe offender warn warns -- either offender or warnings (with offender)
177 ptext SLIT("*** Offending Program ***"),
178 pprCoreBindings binds,
179 ptext SLIT("*** End of Offense ***")
183 %************************************************************************
185 \subsection[lintUnfolding]{lintUnfolding}
187 %************************************************************************
189 We use this to check all unfoldings that come in from interfaces
190 (it is very painful to catch errors otherwise):
193 lintUnfolding :: DynFlags
195 -> [Var] -- Treat these as in scope
197 -> (Maybe Message, Maybe Message) -- (Nothing,_) => OK
199 lintUnfolding dflags locn vars expr
200 | not (dopt Opt_DoCoreLinting dflags)
204 = initL (addLoc (ImportedUnfolding locn) $
205 addInScopeVars vars $
209 %************************************************************************
211 \subsection[lintCoreBinding]{lintCoreBinding}
213 %************************************************************************
215 Check a core binding, returning the list of variables bound.
218 lintSingleBinding rec_flag (binder,rhs)
219 = addLoc (RhsOf binder) $
222 lintCoreExpr rhs `thenL` \ ty ->
224 -- Check match to RHS type
225 lintBinder binder `seqL`
226 checkTys binder_ty ty (mkRhsMsg binder ty) `seqL`
228 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
229 checkL (not (isUnLiftedType binder_ty)
230 || (isNonRec rec_flag && exprOkForSpeculation rhs))
231 (mkRhsPrimMsg binder rhs) `seqL`
233 -- Check whether binder's specialisations contain any out-of-scope variables
234 mapL (checkBndrIdInScope binder) bndr_vars `seqL`
237 -- We should check the unfolding, if any, but this is tricky because
238 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
240 binder_ty = idType binder
241 bndr_vars = varSetElems (idFreeVars binder)
244 %************************************************************************
246 \subsection[lintCoreExpr]{lintCoreExpr}
248 %************************************************************************
251 lintCoreExpr :: CoreExpr -> LintM Type
253 lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
254 lintCoreExpr (Lit lit) = returnL (literalType lit)
256 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
257 = lintCoreExpr expr `thenL` \ expr_ty ->
259 lintTy from_ty `seqL`
260 checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
263 lintCoreExpr (Note other_note expr)
266 lintCoreExpr (Let (NonRec bndr rhs) body)
267 = lintSingleBinding NonRecursive (bndr,rhs) `seqL`
268 addLoc (BodyOfLetRec [bndr])
269 (addInScopeVars [bndr] (lintCoreExpr body))
271 lintCoreExpr (Let (Rec pairs) body)
272 = addInScopeVars bndrs $
273 mapL (lintSingleBinding Recursive) pairs `seqL`
274 addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
276 bndrs = map fst pairs
278 lintCoreExpr e@(App fun arg)
279 = lintCoreExpr fun `thenL` \ ty ->
283 lintCoreExpr (Lam var expr)
284 = addLoc (LambdaBodyOf var) $
286 checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
290 (addInScopeVars [var] $
291 lintCoreExpr expr `thenL` \ ty ->
293 returnL (mkPiType var ty))
295 lintCoreExpr e@(Case scrut var alts)
296 = -- Check the scrutinee
297 lintCoreExpr scrut `thenL` \ scrut_ty ->
300 lintBinder var `seqL`
302 -- If this is an unboxed tuple case, then the binder must be dead
304 checkL (if isUnboxedTupleType (idType var)
305 then isDeadBinder var
306 else True) (mkUnboxedTupleMsg var) `seqL`
309 checkTys (idType var) scrut_ty (mkScrutMsg var scrut_ty) `seqL`
311 addInScopeVars [var] (
313 -- Check the alternatives
314 checkAllCasesCovered e scrut_ty alts `seqL`
316 mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) ->
317 mapL (check alt_ty) alt_tys `seqL`
320 check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
322 lintCoreExpr e@(Type ty)
323 = addErrL (mkStrangeTyMsg e)
326 %************************************************************************
328 \subsection[lintCoreArgs]{lintCoreArgs}
330 %************************************************************************
332 The basic version of these functions checks that the argument is a
333 subtype of the required type, as one would expect.
336 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
337 lintCoreArgs = lintCoreArgs0 checkTys
339 lintCoreArg :: Type -> CoreArg -> LintM Type
340 lintCoreArg = lintCoreArg0 checkTys
343 The primitive version of these functions takes a check argument,
344 allowing a different comparison.
347 lintCoreArgs0 check_tys ty [] = returnL ty
348 lintCoreArgs0 check_tys ty (a : args)
349 = lintCoreArg0 check_tys ty a `thenL` \ res ->
350 lintCoreArgs0 check_tys res args
352 lintCoreArg0 check_tys ty a@(Type arg_ty)
353 = lintTy arg_ty `seqL`
356 lintCoreArg0 check_tys fun_ty arg
357 = -- Make sure function type matches argument
358 lintCoreExpr arg `thenL` \ arg_ty ->
360 err = mkAppMsg fun_ty arg_ty
362 case splitFunTy_maybe fun_ty of
363 Just (arg,res) -> check_tys arg arg_ty err `seqL`
370 = case splitForAllTy_maybe ty of
371 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
374 if not (isTyVar tyvar) then addErrL (mkTyAppMsg ty arg_ty) else
376 tyvar_kind = tyVarKind tyvar
377 argty_kind = typeKind arg_ty
379 if argty_kind `hasMoreBoxityInfo` tyvar_kind
380 -- Arg type might be boxed for a function with an uncommitted
381 -- tyvar; notably this is used so that we can give
382 -- error :: forall a:*. String -> a
383 -- and then apply it to both boxed and unboxed types.
385 returnL (substTy (mkTyVarSubst [tyvar] [arg_ty]) body)
387 addErrL (mkKindErrMsg tyvar arg_ty)
392 lintTyApps fun_ty (arg_ty : arg_tys)
393 = lintTyApp fun_ty arg_ty `thenL` \ fun_ty' ->
394 lintTyApps fun_ty' arg_tys
399 %************************************************************************
401 \subsection[lintCoreAlts]{lintCoreAlts}
403 %************************************************************************
406 checkAllCasesCovered :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
408 checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e)
410 checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL
412 checkAllCasesCovered e scrut_ty alts
413 = case splitTyConApp_maybe scrut_ty of {
414 Nothing -> addErrL (badAltsMsg e);
415 Just (tycon, tycon_arg_tys) ->
417 if isPrimTyCon tycon then
418 checkL (hasDefault alts) (nonExhaustiveAltsMsg e)
422 -- Algebraic cases are not necessarily exhaustive, because
423 -- the simplifer correctly eliminates case that can't
425 -- This code just emits a message to say so
427 missing_cons = filter not_in_alts (tyConDataCons tycon)
428 not_in_alts con = all (not_in_alt con) alts
429 not_in_alt con (DataCon con', _, _) = con /= con'
430 not_in_alt con other = True
432 case_bndr = case e of { Case _ bndr alts -> bndr }
434 if not (hasDefault alts || null missing_cons) then
435 pprTrace "Exciting (but not a problem)! Non-exhaustive case:"
436 (ppr case_bndr <+> ppr missing_cons)
443 hasDefault [] = False
444 hasDefault ((DEFAULT,_,_) : alts) = True
445 hasDefault (alt : alts) = hasDefault alts
449 lintCoreAlt :: Type -- Type of scrutinee
451 -> LintM Type -- Type of alternatives
453 lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs)
454 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
457 lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
458 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
459 checkTys lit_ty scrut_ty
460 (mkBadPatMsg lit_ty scrut_ty) `seqL`
463 lit_ty = literalType lit
465 lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
466 = addLoc (CaseAlt alt) (
468 mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
469 (mkUnboxedTupleMsg arg)) args `seqL`
471 addInScopeVars args (
474 -- Scrutinee type must be a tycon applicn; checked by caller
475 -- This code is remarkably compact considering what it does!
476 -- NB: args must be in scope here so that the lintCoreArgs line works.
477 case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) ->
478 lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type ->
479 lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
480 checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
487 mk_arg b | isTyVar b = Type (mkTyVarTy b)
489 | otherwise = pprPanic "lintCoreAlt:mk_arg " (ppr b)
492 %************************************************************************
494 \subsection[lint-types]{Types}
496 %************************************************************************
499 lintBinder :: Var -> LintM ()
501 -- ToDo: lint its type
502 -- ToDo: lint its rules
504 lintTy :: Type -> LintM ()
505 lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
507 -- ToDo: check the kind structure of the type
511 %************************************************************************
513 \subsection[lint-monad]{The Lint monad}
515 %************************************************************************
518 type LintM a = [LintLocInfo] -- Locations
519 -> IdSet -- Local vars in scope
520 -> Bag ErrMsg -- Error messages so far
521 -> Bag WarnMsg -- Warning messages so far
522 -> (Maybe a, Bag ErrMsg, Bag WarnMsg) -- Result and error/warning messages (if any)
525 = RhsOf Id -- The variable bound
526 | LambdaBodyOf Id -- The lambda-binder
527 | BodyOfLetRec [Id] -- One of the binders
528 | CaseAlt CoreAlt -- Pattern of a case alternative
529 | AnExpr CoreExpr -- Some expression
530 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
534 initL :: LintM a -> (Maybe Message {- errors -}, Maybe Message {- warnings -})
536 = case m [] emptyVarSet emptyBag emptyBag of
537 (_, errs, warns) -> (ifNonEmptyBag errs pprBagOfErrors,
538 ifNonEmptyBag warns pprBagOfWarnings)
540 ifNonEmptyBag bag f | isEmptyBag bag = Nothing
541 | otherwise = Just (f bag)
543 returnL :: a -> LintM a
544 returnL r loc scope errs warns = (Just r, errs, warns)
547 nopL loc scope errs warns = (Nothing, errs, warns)
549 thenL :: LintM a -> (a -> LintM b) -> LintM b
550 thenL m k loc scope errs warns
551 = case m loc scope errs warns of
552 (Just r, errs', warns') -> k r loc scope errs' warns'
553 (Nothing, errs', warns') -> (Nothing, errs', warns')
555 seqL :: LintM a -> LintM b -> LintM b
556 seqL m k loc scope errs warns
557 = case m loc scope errs warns of
558 (_, errs', warns') -> k loc scope errs' warns'
560 mapL :: (a -> LintM b) -> [a] -> LintM [b]
561 mapL f [] = returnL []
564 mapL f xs `thenL` \ rs ->
569 checkL :: Bool -> Message -> LintM ()
570 checkL True msg = nopL
571 checkL False msg = addErrL msg
573 addErrL :: Message -> LintM a
574 addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns)
576 addWarnL :: Message -> LintM a
577 addWarnL msg loc scope errs warns = (Nothing, errs, addErr warns msg loc)
579 addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
580 -- errors or warnings, actually... they're the same type.
581 addErr errs_so_far msg locs
582 = ASSERT( not (null locs) )
583 errs_so_far `snocBag` mk_msg msg
585 (loc, cxt1) = dumpLoc (head locs)
586 cxts = [snd (dumpLoc loc) | loc <- locs]
587 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
590 mk_msg msg = addErrLocHdrLine loc context msg
592 addLoc :: LintLocInfo -> LintM a -> LintM a
593 addLoc extra_loc m loc scope errs warns
594 = m (extra_loc:loc) scope errs warns
596 addInScopeVars :: [Var] -> LintM a -> LintM a
597 addInScopeVars ids m loc scope errs warns
598 = m loc (scope `unionVarSet` mkVarSet ids) errs warns
602 checkIdInScope :: Var -> LintM ()
604 = checkInScope (ptext SLIT("is out of scope")) id
606 checkBndrIdInScope :: Var -> Var -> LintM ()
607 checkBndrIdInScope binder id
608 = checkInScope msg id
610 msg = ptext SLIT("is out of scope inside info for") <+>
613 checkInScope :: SDoc -> Var -> LintM ()
614 checkInScope loc_msg var loc scope errs warns
615 | mustHaveLocalBinding var && not (var `elemVarSet` scope)
616 = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc, warns)
618 = nopL loc scope errs warns
620 checkTys :: Type -> Type -> Message -> LintM ()
621 -- check ty2 is subtype of ty1 (ie, has same structure but usage
622 -- annotations need only be consistent, not equal)
625 | otherwise = addErrL msg
629 %************************************************************************
631 \subsection{Error messages}
633 %************************************************************************
637 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
639 dumpLoc (LambdaBodyOf b)
640 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
642 dumpLoc (BodyOfLetRec [])
643 = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
645 dumpLoc (BodyOfLetRec bs@(_:_))
646 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
649 = (noSrcLoc, text "In the expression:" <+> ppr e)
651 dumpLoc (CaseAlt (con, args, rhs))
652 = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
654 dumpLoc (ImportedUnfolding locn)
655 = (locn, brackets (ptext SLIT("in an imported unfolding")))
657 pp_binders :: [Var] -> SDoc
658 pp_binders bs = sep (punctuate comma (map pp_binder bs))
660 pp_binder :: Var -> SDoc
661 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
662 | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
666 ------------------------------------------------------
667 -- Messages for case expressions
669 mkNullAltsMsg :: CoreExpr -> Message
671 = hang (text "Case expression with no alternatives:")
674 mkDefaultArgsMsg :: [Var] -> Message
675 mkDefaultArgsMsg args
676 = hang (text "DEFAULT case with binders")
679 mkCaseAltMsg :: CoreExpr -> Message
681 = hang (text "Type of case alternatives not the same:")
684 mkScrutMsg :: Id -> Type -> Message
685 mkScrutMsg var scrut_ty
686 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
687 text "Result binder type:" <+> ppr (idType var),
688 text "Scrutinee type:" <+> ppr scrut_ty]
690 badAltsMsg :: CoreExpr -> Message
692 = hang (text "Case statement scrutinee is not a data type:")
695 nonExhaustiveAltsMsg :: CoreExpr -> Message
696 nonExhaustiveAltsMsg e
697 = hang (text "Case expression with non-exhaustive alternatives")
700 mkBadPatMsg :: Type -> Type -> Message
701 mkBadPatMsg con_result_ty scrut_ty
703 text "In a case alternative, pattern result type doesn't match scrutinee type:",
704 text "Pattern result type:" <+> ppr con_result_ty,
705 text "Scrutinee type:" <+> ppr scrut_ty
708 ------------------------------------------------------
709 -- Other error messages
711 mkAppMsg :: Type -> Type -> Message
713 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
714 hang (ptext SLIT("Fun type:")) 4 (ppr fun),
715 hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
717 mkKindErrMsg :: TyVar -> Type -> Message
718 mkKindErrMsg tyvar arg_ty
719 = vcat [ptext SLIT("Kinds don't match in type application:"),
720 hang (ptext SLIT("Type variable:"))
721 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
722 hang (ptext SLIT("Arg type:"))
723 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
725 mkTyAppMsg :: Type -> Type -> Message
727 = vcat [text "Illegal type application:",
728 hang (ptext SLIT("Exp type:"))
729 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
730 hang (ptext SLIT("Arg type:"))
731 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
733 mkRhsMsg :: Id -> Type -> Message
736 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
738 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
739 hsep [ptext SLIT("Rhs type:"), ppr ty]]
741 mkRhsPrimMsg :: Id -> CoreExpr -> Message
742 mkRhsPrimMsg binder rhs
743 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
745 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
748 mkUnboxedTupleMsg :: Id -> Message
749 mkUnboxedTupleMsg binder
750 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
751 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
753 mkCoerceErr from_ty expr_ty
754 = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
755 ptext SLIT("From-type:") <+> ppr from_ty,
756 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
760 = ptext SLIT("Type where expression expected:") <+> ppr e