2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[CoreLint]{A ``lint'' pass to check for Core correctness}
10 showPass, 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, dumpIfSet_core, ghcExit, Message, showPass,
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, splitTyConApp,
37 isUnLiftedType, typeKind,
41 import TyCon ( isPrimTyCon )
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 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
62 endPass dflags pass_name dump_flag binds
64 (binds, _) <- endPassWithRules dflags pass_name dump_flag binds Nothing
67 endPassWithRules :: DynFlags -> String -> DynFlag -> [CoreBind]
69 -> IO ([CoreBind], Maybe RuleBase)
70 endPassWithRules dflags pass_name dump_flag binds rules
72 -- ToDo: force the rules?
74 -- Report result size if required
75 -- This has the side effect of forcing the intermediate to be evaluated
76 if verbosity dflags >= 2 then
77 hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds))
81 -- Report verbosely, if required
82 dumpIfSet_core dflags dump_flag pass_name
83 (pprCoreBindings binds $$ case rules of
85 Just rb -> pprRuleBase rb)
88 lintCoreBindings dflags pass_name binds
89 -- ToDo: lint the rules
95 %************************************************************************
97 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
99 %************************************************************************
101 Checks that a set of core bindings is well-formed. The PprStyle and String
102 just control what we print in the event of an error. The Bool value
103 indicates whether we have done any specialisation yet (in which case we do
108 (b) Out-of-scope type variables
109 (c) Out-of-scope local variables
112 If we have done specialisation the we check that there are
113 (a) No top-level bindings of primitive (unboxed type)
118 -- Things are *not* OK if:
120 -- * Unsaturated type app before specialisation has been done;
122 -- * Oversaturated type app after specialisation (eta reduction
123 -- may well be happening...);
126 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
128 lintCoreBindings dflags whoDunnit binds
129 | not (dopt Opt_DoCoreLinting dflags)
132 lintCoreBindings dflags whoDunnit binds
133 = case (initL (lint_binds binds)) of
134 (Nothing, Nothing) -> done_lint
136 (Nothing, Just warnings) -> printDump (warn warnings) >>
139 (Just bad_news, warns) -> printDump (display bad_news warns) >>
142 -- Put all the top-level binders in scope at the start
143 -- This is because transformation rules can bring something
144 -- into use 'unexpectedly'
145 lint_binds binds = addInScopeVars (bindersOfBinds binds) $
148 lint_bind (Rec prs) = mapL (lintSingleBinding Recursive) prs `seqL`
150 lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
152 done_lint = doIfSet (verbosity dflags >= 2)
153 (hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
156 text ("*** Core Lint Warnings: in result of " ++ whoDunnit ++ " ***"),
161 display bad_news warns
163 text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
165 maybe offender warn warns -- either offender or warnings (with offender)
170 ptext SLIT("*** Offending Program ***"),
171 pprCoreBindings binds,
172 ptext SLIT("*** End of Offense ***")
176 %************************************************************************
178 \subsection[lintUnfolding]{lintUnfolding}
180 %************************************************************************
182 We use this to check all unfoldings that come in from interfaces
183 (it is very painful to catch errors otherwise):
186 lintUnfolding :: DynFlags
188 -> [Var] -- Treat these as in scope
190 -> (Maybe Message, Maybe Message) -- (Nothing,_) => OK
192 lintUnfolding dflags locn vars expr
193 | not (dopt Opt_DoCoreLinting dflags)
197 = initL (addLoc (ImportedUnfolding locn) $
198 addInScopeVars vars $
202 %************************************************************************
204 \subsection[lintCoreBinding]{lintCoreBinding}
206 %************************************************************************
208 Check a core binding, returning the list of variables bound.
211 lintSingleBinding rec_flag (binder,rhs)
212 = addLoc (RhsOf binder) $
215 lintCoreExpr rhs `thenL` \ ty ->
217 -- Check match to RHS type
218 lintBinder binder `seqL`
219 checkTys binder_ty ty (mkRhsMsg binder ty) `seqL`
221 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
222 checkL (not (isUnLiftedType binder_ty)
223 || (isNonRec rec_flag && exprOkForSpeculation rhs))
224 (mkRhsPrimMsg binder rhs) `seqL`
226 -- Check whether binder's specialisations contain any out-of-scope variables
227 mapL (checkBndrIdInScope binder) bndr_vars `seqL`
230 -- We should check the unfolding, if any, but this is tricky because
231 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
233 binder_ty = idType binder
234 bndr_vars = varSetElems (idFreeVars binder)
237 %************************************************************************
239 \subsection[lintCoreExpr]{lintCoreExpr}
241 %************************************************************************
244 lintCoreExpr :: CoreExpr -> LintM Type
246 lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
247 lintCoreExpr (Lit lit) = returnL (literalType lit)
249 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
250 = lintCoreExpr expr `thenL` \ expr_ty ->
252 lintTy from_ty `seqL`
253 checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
256 lintCoreExpr (Note other_note expr)
259 lintCoreExpr (Let (NonRec bndr rhs) body)
260 = lintSingleBinding NonRecursive (bndr,rhs) `seqL`
261 addLoc (BodyOfLetRec [bndr])
262 (addInScopeVars [bndr] (lintCoreExpr body))
264 lintCoreExpr (Let (Rec pairs) body)
265 = addInScopeVars bndrs $
266 mapL (lintSingleBinding Recursive) pairs `seqL`
267 addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
269 bndrs = map fst pairs
271 lintCoreExpr e@(App fun arg)
272 = lintCoreExpr fun `thenL` \ ty ->
276 lintCoreExpr (Lam var expr)
277 = addLoc (LambdaBodyOf var) $
279 checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
283 (addInScopeVars [var] $
284 lintCoreExpr expr `thenL` \ ty ->
286 returnL (mkPiType var ty))
288 lintCoreExpr e@(Case scrut var alts)
289 = -- Check the scrutinee
290 lintCoreExpr scrut `thenL` \ scrut_ty ->
293 lintBinder var `seqL`
295 -- If this is an unboxed tuple case, then the binder must be dead
297 checkL (if isUnboxedTupleType (idType var)
298 then isDeadBinder var
299 else True) (mkUnboxedTupleMsg var) `seqL`
302 checkTys (idType var) scrut_ty (mkScrutMsg var scrut_ty) `seqL`
304 addInScopeVars [var] (
306 -- Check the alternatives
307 checkAllCasesCovered e scrut_ty alts `seqL`
309 mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) ->
310 mapL (check alt_ty) alt_tys `seqL`
313 check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
315 lintCoreExpr e@(Type ty)
316 = addErrL (mkStrangeTyMsg e)
319 %************************************************************************
321 \subsection[lintCoreArgs]{lintCoreArgs}
323 %************************************************************************
325 The basic version of these functions checks that the argument is a
326 subtype of the required type, as one would expect.
329 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
330 lintCoreArgs = lintCoreArgs0 checkTys
332 lintCoreArg :: Type -> CoreArg -> LintM Type
333 lintCoreArg = lintCoreArg0 checkTys
336 The primitive version of these functions takes a check argument,
337 allowing a different comparison.
340 lintCoreArgs0 check_tys ty [] = returnL ty
341 lintCoreArgs0 check_tys ty (a : args)
342 = lintCoreArg0 check_tys ty a `thenL` \ res ->
343 lintCoreArgs0 check_tys res args
345 lintCoreArg0 check_tys ty a@(Type arg_ty)
346 = lintTy arg_ty `seqL`
349 lintCoreArg0 check_tys fun_ty arg
350 = -- Make sure function type matches argument
351 lintCoreExpr arg `thenL` \ arg_ty ->
353 err = mkAppMsg fun_ty arg_ty
355 case splitFunTy_maybe fun_ty of
356 Just (arg,res) -> check_tys arg arg_ty err `seqL`
363 = case splitForAllTy_maybe ty of
364 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
367 if not (isTyVar tyvar) then addErrL (mkTyAppMsg ty arg_ty) else
369 tyvar_kind = tyVarKind tyvar
370 argty_kind = typeKind arg_ty
372 if argty_kind `hasMoreBoxityInfo` tyvar_kind
373 -- Arg type might be boxed for a function with an uncommitted
374 -- tyvar; notably this is used so that we can give
375 -- error :: forall a:*. String -> a
376 -- and then apply it to both boxed and unboxed types.
378 returnL (substTy (mkTyVarSubst [tyvar] [arg_ty]) body)
380 addErrL (mkKindErrMsg tyvar arg_ty)
385 lintTyApps fun_ty (arg_ty : arg_tys)
386 = lintTyApp fun_ty arg_ty `thenL` \ fun_ty' ->
387 lintTyApps fun_ty' arg_tys
392 %************************************************************************
394 \subsection[lintCoreAlts]{lintCoreAlts}
396 %************************************************************************
399 checkAllCasesCovered :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
401 checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e)
403 checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL
405 checkAllCasesCovered e scrut_ty alts
406 = case splitTyConApp_maybe scrut_ty of {
407 Nothing -> addErrL (badAltsMsg e);
408 Just (tycon, tycon_arg_tys) ->
410 if isPrimTyCon tycon then
411 checkL (hasDefault alts) (nonExhaustiveAltsMsg e)
415 -- Algebraic cases are not necessarily exhaustive, because
416 -- the simplifer correctly eliminates case that can't
418 -- This code just emits a message to say so
420 missing_cons = filter not_in_alts (tyConDataCons tycon)
421 not_in_alts con = all (not_in_alt con) alts
422 not_in_alt con (DataCon con', _, _) = con /= con'
423 not_in_alt con other = True
425 case_bndr = case e of { Case _ bndr alts -> bndr }
427 if not (hasDefault alts || null missing_cons) then
428 pprTrace "Exciting (but not a problem)! Non-exhaustive case:"
429 (ppr case_bndr <+> ppr missing_cons)
436 hasDefault [] = False
437 hasDefault ((DEFAULT,_,_) : alts) = True
438 hasDefault (alt : alts) = hasDefault alts
442 lintCoreAlt :: Type -- Type of scrutinee
444 -> LintM Type -- Type of alternatives
446 lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs)
447 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
450 lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
451 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
452 checkTys lit_ty scrut_ty
453 (mkBadPatMsg lit_ty scrut_ty) `seqL`
456 lit_ty = literalType lit
458 lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
459 = addLoc (CaseAlt alt) (
461 mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
462 (mkUnboxedTupleMsg arg)) args `seqL`
464 addInScopeVars args (
467 -- Scrutinee type must be a tycon applicn; checked by caller
468 -- This code is remarkably compact considering what it does!
469 -- NB: args must be in scope here so that the lintCoreArgs line works.
470 case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) ->
471 lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type ->
472 lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
473 checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
480 mk_arg b | isTyVar b = Type (mkTyVarTy b)
482 | otherwise = pprPanic "lintCoreAlt:mk_arg " (ppr b)
485 %************************************************************************
487 \subsection[lint-types]{Types}
489 %************************************************************************
492 lintBinder :: Var -> LintM ()
494 -- ToDo: lint its type
495 -- ToDo: lint its rules
497 lintTy :: Type -> LintM ()
498 lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
500 -- ToDo: check the kind structure of the type
504 %************************************************************************
506 \subsection[lint-monad]{The Lint monad}
508 %************************************************************************
511 type LintM a = [LintLocInfo] -- Locations
512 -> IdSet -- Local vars in scope
513 -> Bag ErrMsg -- Error messages so far
514 -> Bag WarnMsg -- Warning messages so far
515 -> (Maybe a, Bag ErrMsg, Bag WarnMsg) -- Result and error/warning messages (if any)
518 = RhsOf Id -- The variable bound
519 | LambdaBodyOf Id -- The lambda-binder
520 | BodyOfLetRec [Id] -- One of the binders
521 | CaseAlt CoreAlt -- Pattern of a case alternative
522 | AnExpr CoreExpr -- Some expression
523 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
527 initL :: LintM a -> (Maybe Message {- errors -}, Maybe Message {- warnings -})
529 = case m [] emptyVarSet emptyBag emptyBag of
530 (_, errs, warns) -> (ifNonEmptyBag errs pprBagOfErrors,
531 ifNonEmptyBag warns pprBagOfWarnings)
533 ifNonEmptyBag bag f | isEmptyBag bag = Nothing
534 | otherwise = Just (f bag)
536 returnL :: a -> LintM a
537 returnL r loc scope errs warns = (Just r, errs, warns)
540 nopL loc scope errs warns = (Nothing, errs, warns)
542 thenL :: LintM a -> (a -> LintM b) -> LintM b
543 thenL m k loc scope errs warns
544 = case m loc scope errs warns of
545 (Just r, errs', warns') -> k r loc scope errs' warns'
546 (Nothing, errs', warns') -> (Nothing, errs', warns')
548 seqL :: LintM a -> LintM b -> LintM b
549 seqL m k loc scope errs warns
550 = case m loc scope errs warns of
551 (_, errs', warns') -> k loc scope errs' warns'
553 mapL :: (a -> LintM b) -> [a] -> LintM [b]
554 mapL f [] = returnL []
557 mapL f xs `thenL` \ rs ->
562 checkL :: Bool -> Message -> LintM ()
563 checkL True msg = nopL
564 checkL False msg = addErrL msg
566 addErrL :: Message -> LintM a
567 addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns)
569 addWarnL :: Message -> LintM a
570 addWarnL msg loc scope errs warns = (Nothing, errs, addErr warns msg loc)
572 addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
573 -- errors or warnings, actually... they're the same type.
574 addErr errs_so_far msg locs
575 = ASSERT( not (null locs) )
576 errs_so_far `snocBag` mk_msg msg
578 (loc, cxt1) = dumpLoc (head locs)
579 cxts = [snd (dumpLoc loc) | loc <- locs]
580 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
583 mk_msg msg = addErrLocHdrLine loc context msg
585 addLoc :: LintLocInfo -> LintM a -> LintM a
586 addLoc extra_loc m loc scope errs warns
587 = m (extra_loc:loc) scope errs warns
589 addInScopeVars :: [Var] -> LintM a -> LintM a
590 addInScopeVars ids m loc scope errs warns
591 = m loc (scope `unionVarSet` mkVarSet ids) errs warns
595 checkIdInScope :: Var -> LintM ()
597 = checkInScope (ptext SLIT("is out of scope")) id
599 checkBndrIdInScope :: Var -> Var -> LintM ()
600 checkBndrIdInScope binder id
601 = checkInScope msg id
603 msg = ptext SLIT("is out of scope inside info for") <+>
606 checkInScope :: SDoc -> Var -> LintM ()
607 checkInScope loc_msg var loc scope errs warns
608 | mustHaveLocalBinding var && not (var `elemVarSet` scope)
609 = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc, warns)
611 = nopL loc scope errs warns
613 checkTys :: Type -> Type -> Message -> LintM ()
614 -- check ty2 is subtype of ty1 (ie, has same structure but usage
615 -- annotations need only be consistent, not equal)
618 | otherwise = addErrL msg
622 %************************************************************************
624 \subsection{Error messages}
626 %************************************************************************
630 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
632 dumpLoc (LambdaBodyOf b)
633 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
635 dumpLoc (BodyOfLetRec [])
636 = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
638 dumpLoc (BodyOfLetRec bs@(_:_))
639 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
642 = (noSrcLoc, text "In the expression:" <+> ppr e)
644 dumpLoc (CaseAlt (con, args, rhs))
645 = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
647 dumpLoc (ImportedUnfolding locn)
648 = (locn, brackets (ptext SLIT("in an imported unfolding")))
650 pp_binders :: [Var] -> SDoc
651 pp_binders bs = sep (punctuate comma (map pp_binder bs))
653 pp_binder :: Var -> SDoc
654 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
655 | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
659 ------------------------------------------------------
660 -- Messages for case expressions
662 mkNullAltsMsg :: CoreExpr -> Message
664 = hang (text "Case expression with no alternatives:")
667 mkDefaultArgsMsg :: [Var] -> Message
668 mkDefaultArgsMsg args
669 = hang (text "DEFAULT case with binders")
672 mkCaseAltMsg :: CoreExpr -> Message
674 = hang (text "Type of case alternatives not the same:")
677 mkScrutMsg :: Id -> Type -> Message
678 mkScrutMsg var scrut_ty
679 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
680 text "Result binder type:" <+> ppr (idType var),
681 text "Scrutinee type:" <+> ppr scrut_ty]
683 badAltsMsg :: CoreExpr -> Message
685 = hang (text "Case statement scrutinee is not a data type:")
688 nonExhaustiveAltsMsg :: CoreExpr -> Message
689 nonExhaustiveAltsMsg e
690 = hang (text "Case expression with non-exhaustive alternatives")
693 mkBadPatMsg :: Type -> Type -> Message
694 mkBadPatMsg con_result_ty scrut_ty
696 text "In a case alternative, pattern result type doesn't match scrutinee type:",
697 text "Pattern result type:" <+> ppr con_result_ty,
698 text "Scrutinee type:" <+> ppr scrut_ty
701 ------------------------------------------------------
702 -- Other error messages
704 mkAppMsg :: Type -> Type -> Message
706 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
707 hang (ptext SLIT("Fun type:")) 4 (ppr fun),
708 hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
710 mkKindErrMsg :: TyVar -> Type -> Message
711 mkKindErrMsg tyvar arg_ty
712 = vcat [ptext SLIT("Kinds don't match in type application:"),
713 hang (ptext SLIT("Type variable:"))
714 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
715 hang (ptext SLIT("Arg type:"))
716 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
718 mkTyAppMsg :: Type -> Type -> Message
720 = vcat [text "Illegal type application:",
721 hang (ptext SLIT("Exp type:"))
722 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
723 hang (ptext SLIT("Arg type:"))
724 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
726 mkRhsMsg :: Id -> Type -> Message
729 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
731 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
732 hsep [ptext SLIT("Rhs type:"), ppr ty]]
734 mkRhsPrimMsg :: Id -> CoreExpr -> Message
735 mkRhsPrimMsg binder rhs
736 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
738 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
741 mkUnboxedTupleMsg :: Id -> Message
742 mkUnboxedTupleMsg binder
743 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
744 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
746 mkCoerceErr from_ty expr_ty
747 = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
748 ptext SLIT("From-type:") <+> ppr from_ty,
749 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
753 = ptext SLIT("Type where expression expected:") <+> ppr e