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 )
17 import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug )
19 import Rules ( RuleBase, pprRuleBase )
20 import CoreFVs ( idFreeVars, mustHaveLocalBinding )
21 import CoreUtils ( exprOkForSpeculation, coreBindsSize, mkPiType )
24 import Literal ( literalType )
25 import DataCon ( dataConRepType )
26 import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId )
28 import Subst ( mkTyVarSubst, substTy )
29 import Name ( getSrcLoc )
31 import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message,
32 ErrMsg, addErrLocHdrLine, pprBagOfErrors,
33 WarnMsg, pprBagOfWarnings)
34 import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc )
35 import Type ( Type, tyVarsOfType,
36 splitFunTy_maybe, mkTyVarTy,
37 splitForAllTy_maybe, splitTyConApp_maybe,
38 isUnLiftedType, typeKind,
42 import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
43 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 stdout ("*** " ++ pass_name)
69 endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind]
70 endPass pass_name dump_flag binds
72 (binds, _) <- endPassWithRules pass_name dump_flag binds Nothing
75 endPassWithRules :: String -> Bool -> [CoreBind] -> Maybe RuleBase
76 -> IO ([CoreBind], Maybe RuleBase)
77 endPassWithRules 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 opt_D_show_passes 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 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 :: String -> [CoreBind] -> IO ()
135 lintCoreBindings whoDunnit binds
136 | not opt_DoCoreLinting
139 lintCoreBindings 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 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 :: SrcLoc
194 -> [Var] -- Treat these as in scope
196 -> (Maybe Message, Maybe Message) -- (Nothing,_) => OK
198 lintUnfolding locn vars expr
199 | not opt_DoCoreLinting
203 = initL (addLoc (ImportedUnfolding locn) $
204 addInScopeVars vars $
208 %************************************************************************
210 \subsection[lintCoreBinding]{lintCoreBinding}
212 %************************************************************************
214 Check a core binding, returning the list of variables bound.
217 lintSingleBinding rec_flag (binder,rhs)
218 = addLoc (RhsOf binder) $
221 lintCoreExpr rhs `thenL` \ ty ->
223 -- Check match to RHS type
224 lintBinder binder `seqL`
225 checkTys binder_ty ty (mkRhsMsg binder ty) `seqL`
227 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
228 checkL (not (isUnLiftedType binder_ty)
229 || (isNonRec rec_flag && exprOkForSpeculation rhs))
230 (mkRhsPrimMsg binder rhs) `seqL`
232 -- Check whether binder's specialisations contain any out-of-scope variables
233 mapL (checkBndrIdInScope binder) bndr_vars `seqL`
236 -- We should check the unfolding, if any, but this is tricky because
237 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
239 binder_ty = idType binder
240 bndr_vars = varSetElems (idFreeVars binder)
243 %************************************************************************
245 \subsection[lintCoreExpr]{lintCoreExpr}
247 %************************************************************************
250 lintCoreExpr :: CoreExpr -> LintM Type
252 lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
253 lintCoreExpr (Lit lit) = returnL (literalType lit)
255 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
256 = lintCoreExpr expr `thenL` \ expr_ty ->
258 lintTy from_ty `seqL`
259 checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
262 lintCoreExpr (Note other_note expr)
265 lintCoreExpr (Let (NonRec bndr rhs) body)
266 = lintSingleBinding NonRecursive (bndr,rhs) `seqL`
267 addLoc (BodyOfLetRec [bndr])
268 (addInScopeVars [bndr] (lintCoreExpr body))
270 lintCoreExpr (Let (Rec pairs) body)
271 = addInScopeVars bndrs $
272 mapL (lintSingleBinding Recursive) pairs `seqL`
273 addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
275 bndrs = map fst pairs
277 lintCoreExpr e@(App fun arg)
278 = lintCoreExpr fun `thenL` \ ty ->
282 lintCoreExpr (Lam var expr)
283 = addLoc (LambdaBodyOf var) $
285 checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
289 (addInScopeVars [var] $
290 lintCoreExpr expr `thenL` \ ty ->
292 returnL (mkPiType var ty))
294 lintCoreExpr e@(Case scrut var alts)
295 = -- Check the scrutinee
296 lintCoreExpr scrut `thenL` \ scrut_ty ->
299 lintBinder var `seqL`
301 -- If this is an unboxed tuple case, then the binder must be dead
303 checkL (if isUnboxedTupleType (idType var)
304 then isDeadBinder var
305 else True) (mkUnboxedTupleMsg var) `seqL`
308 checkTys (idType var) scrut_ty (mkScrutMsg var scrut_ty) `seqL`
310 addInScopeVars [var] (
312 -- Check the alternatives
313 checkAllCasesCovered e scrut_ty alts `seqL`
315 mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) ->
316 mapL (check alt_ty) alt_tys `seqL`
319 check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
321 lintCoreExpr e@(Type ty)
322 = addErrL (mkStrangeTyMsg e)
325 %************************************************************************
327 \subsection[lintCoreArgs]{lintCoreArgs}
329 %************************************************************************
331 The basic version of these functions checks that the argument is a
332 subtype of the required type, as one would expect.
335 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
336 lintCoreArgs = lintCoreArgs0 checkTys
338 lintCoreArg :: Type -> CoreArg -> LintM Type
339 lintCoreArg = lintCoreArg0 checkTys
342 The primitive version of these functions takes a check argument,
343 allowing a different comparison.
346 lintCoreArgs0 check_tys ty [] = returnL ty
347 lintCoreArgs0 check_tys ty (a : args)
348 = lintCoreArg0 check_tys ty a `thenL` \ res ->
349 lintCoreArgs0 check_tys res args
351 lintCoreArg0 check_tys ty a@(Type arg_ty)
352 = lintTy arg_ty `seqL`
355 lintCoreArg0 check_tys fun_ty arg
356 = -- Make sure function type matches argument
357 lintCoreExpr arg `thenL` \ arg_ty ->
359 err = mkAppMsg fun_ty arg_ty
361 case splitFunTy_maybe fun_ty of
362 Just (arg,res) -> check_tys arg arg_ty err `seqL`
369 = case splitForAllTy_maybe ty of
370 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
373 if not (isTyVar tyvar) then addErrL (mkTyAppMsg ty arg_ty) else
375 tyvar_kind = tyVarKind tyvar
376 argty_kind = typeKind arg_ty
378 if argty_kind `hasMoreBoxityInfo` tyvar_kind
379 -- Arg type might be boxed for a function with an uncommitted
380 -- tyvar; notably this is used so that we can give
381 -- error :: forall a:*. String -> a
382 -- and then apply it to both boxed and unboxed types.
384 returnL (substTy (mkTyVarSubst [tyvar] [arg_ty]) body)
386 addErrL (mkKindErrMsg tyvar arg_ty)
391 lintTyApps fun_ty (arg_ty : arg_tys)
392 = lintTyApp fun_ty arg_ty `thenL` \ fun_ty' ->
393 lintTyApps fun_ty' arg_tys
398 %************************************************************************
400 \subsection[lintCoreAlts]{lintCoreAlts}
402 %************************************************************************
405 checkAllCasesCovered :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
407 checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e)
409 checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL
411 checkAllCasesCovered e scrut_ty alts
412 = case splitTyConApp_maybe scrut_ty of {
413 Nothing -> addErrL (badAltsMsg e);
414 Just (tycon, tycon_arg_tys) ->
416 if isPrimTyCon tycon then
417 checkL (hasDefault alts) (nonExhaustiveAltsMsg e)
421 -- Algebraic cases are not necessarily exhaustive, because
422 -- the simplifer correctly eliminates case that can't
424 -- This code just emits a message to say so
426 missing_cons = filter not_in_alts (tyConDataCons tycon)
427 not_in_alts con = all (not_in_alt con) alts
428 not_in_alt con (DataCon con', _, _) = con /= con'
429 not_in_alt con other = True
431 case_bndr = case e of { Case _ bndr alts -> bndr }
433 if not (hasDefault alts || null missing_cons) then
434 pprTrace "Exciting (but not a problem)! Non-exhaustive case:"
435 (ppr case_bndr <+> ppr missing_cons)
442 hasDefault [] = False
443 hasDefault ((DEFAULT,_,_) : alts) = True
444 hasDefault (alt : alts) = hasDefault alts
448 lintCoreAlt :: Type -- Type of scrutinee
450 -> LintM Type -- Type of alternatives
452 lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs)
453 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
456 lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
457 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
458 checkTys lit_ty scrut_ty
459 (mkBadPatMsg lit_ty scrut_ty) `seqL`
462 lit_ty = literalType lit
464 lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
465 = addLoc (CaseAlt alt) (
467 mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
468 (mkUnboxedTupleMsg arg)) args `seqL`
470 addInScopeVars args (
473 -- Scrutinee type must be a tycon applicn; checked by caller
474 -- This code is remarkably compact considering what it does!
475 -- NB: args must be in scope here so that the lintCoreArgs line works.
476 case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) ->
477 lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type ->
478 lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
479 checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
486 mk_arg b | isTyVar b = Type (mkTyVarTy b)
488 | otherwise = pprPanic "lintCoreAlt:mk_arg " (ppr b)
491 %************************************************************************
493 \subsection[lint-types]{Types}
495 %************************************************************************
498 lintBinder :: Var -> LintM ()
500 -- ToDo: lint its type
501 -- ToDo: lint its rules
503 lintTy :: Type -> LintM ()
504 lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
506 -- ToDo: check the kind structure of the type
510 %************************************************************************
512 \subsection[lint-monad]{The Lint monad}
514 %************************************************************************
517 type LintM a = [LintLocInfo] -- Locations
518 -> IdSet -- Local vars in scope
519 -> Bag ErrMsg -- Error messages so far
520 -> Bag WarnMsg -- Warning messages so far
521 -> (Maybe a, Bag ErrMsg, Bag WarnMsg) -- Result and error/warning messages (if any)
524 = RhsOf Id -- The variable bound
525 | LambdaBodyOf Id -- The lambda-binder
526 | BodyOfLetRec [Id] -- One of the binders
527 | CaseAlt CoreAlt -- Pattern of a case alternative
528 | AnExpr CoreExpr -- Some expression
529 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
533 initL :: LintM a -> (Maybe Message {- errors -}, Maybe Message {- warnings -})
535 = case m [] emptyVarSet emptyBag emptyBag of
536 (_, errs, warns) -> (ifNonEmptyBag errs pprBagOfErrors,
537 ifNonEmptyBag warns pprBagOfWarnings)
539 ifNonEmptyBag bag f | isEmptyBag bag = Nothing
540 | otherwise = Just (f bag)
542 returnL :: a -> LintM a
543 returnL r loc scope errs warns = (Just r, errs, warns)
546 nopL loc scope errs warns = (Nothing, errs, warns)
548 thenL :: LintM a -> (a -> LintM b) -> LintM b
549 thenL m k loc scope errs warns
550 = case m loc scope errs warns of
551 (Just r, errs', warns') -> k r loc scope errs' warns'
552 (Nothing, errs', warns') -> (Nothing, errs', warns')
554 seqL :: LintM a -> LintM b -> LintM b
555 seqL m k loc scope errs warns
556 = case m loc scope errs warns of
557 (_, errs', warns') -> k loc scope errs' warns'
559 mapL :: (a -> LintM b) -> [a] -> LintM [b]
560 mapL f [] = returnL []
563 mapL f xs `thenL` \ rs ->
568 checkL :: Bool -> Message -> LintM ()
569 checkL True msg = nopL
570 checkL False msg = addErrL msg
572 addErrL :: Message -> LintM a
573 addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns)
575 addWarnL :: Message -> LintM a
576 addWarnL msg loc scope errs warns = (Nothing, errs, addErr warns msg loc)
578 addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
579 -- errors or warnings, actually... they're the same type.
580 addErr errs_so_far msg locs
581 = ASSERT( not (null locs) )
582 errs_so_far `snocBag` mk_msg msg
584 (loc, cxt1) = dumpLoc (head locs)
585 cxts = [snd (dumpLoc loc) | loc <- locs]
586 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
589 mk_msg msg = addErrLocHdrLine loc context msg
591 addLoc :: LintLocInfo -> LintM a -> LintM a
592 addLoc extra_loc m loc scope errs warns
593 = m (extra_loc:loc) scope errs warns
595 addInScopeVars :: [Var] -> LintM a -> LintM a
596 addInScopeVars ids m loc scope errs warns
597 = m loc (scope `unionVarSet` mkVarSet ids) errs warns
601 checkIdInScope :: Var -> LintM ()
603 = checkInScope (ptext SLIT("is out of scope")) id
605 checkBndrIdInScope :: Var -> Var -> LintM ()
606 checkBndrIdInScope binder id
607 = checkInScope msg id
609 msg = ptext SLIT("is out of scope inside info for") <+>
612 checkInScope :: SDoc -> Var -> LintM ()
613 checkInScope loc_msg var loc scope errs warns
614 | mustHaveLocalBinding var && not (var `elemVarSet` scope)
615 = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc, warns)
617 = nopL loc scope errs warns
619 checkTys :: Type -> Type -> Message -> LintM ()
620 -- check ty2 is subtype of ty1 (ie, has same structure but usage
621 -- annotations need only be consistent, not equal)
624 | otherwise = addErrL msg
628 %************************************************************************
630 \subsection{Error messages}
632 %************************************************************************
636 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
638 dumpLoc (LambdaBodyOf b)
639 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
641 dumpLoc (BodyOfLetRec [])
642 = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
644 dumpLoc (BodyOfLetRec bs@(_:_))
645 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
648 = (noSrcLoc, text "In the expression:" <+> ppr e)
650 dumpLoc (CaseAlt (con, args, rhs))
651 = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
653 dumpLoc (ImportedUnfolding locn)
654 = (locn, brackets (ptext SLIT("in an imported unfolding")))
656 pp_binders :: [Var] -> SDoc
657 pp_binders bs = sep (punctuate comma (map pp_binder bs))
659 pp_binder :: Var -> SDoc
660 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
661 | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
665 ------------------------------------------------------
666 -- Messages for case expressions
668 mkNullAltsMsg :: CoreExpr -> Message
670 = hang (text "Case expression with no alternatives:")
673 mkDefaultArgsMsg :: [Var] -> Message
674 mkDefaultArgsMsg args
675 = hang (text "DEFAULT case with binders")
678 mkCaseAltMsg :: CoreExpr -> Message
680 = hang (text "Type of case alternatives not the same:")
683 mkScrutMsg :: Id -> Type -> Message
684 mkScrutMsg var scrut_ty
685 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
686 text "Result binder type:" <+> ppr (idType var),
687 text "Scrutinee type:" <+> ppr scrut_ty]
689 badAltsMsg :: CoreExpr -> Message
691 = hang (text "Case statement scrutinee is not a data type:")
694 nonExhaustiveAltsMsg :: CoreExpr -> Message
695 nonExhaustiveAltsMsg e
696 = hang (text "Case expression with non-exhaustive alternatives")
699 mkBadPatMsg :: Type -> Type -> Message
700 mkBadPatMsg con_result_ty scrut_ty
702 text "In a case alternative, pattern result type doesn't match scrutinee type:",
703 text "Pattern result type:" <+> ppr con_result_ty,
704 text "Scrutinee type:" <+> ppr scrut_ty
707 ------------------------------------------------------
708 -- Other error messages
710 mkAppMsg :: Type -> Type -> Message
712 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
713 hang (ptext SLIT("Fun type:")) 4 (ppr fun),
714 hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
716 mkKindErrMsg :: TyVar -> Type -> Message
717 mkKindErrMsg tyvar arg_ty
718 = vcat [ptext SLIT("Kinds don't match in type application:"),
719 hang (ptext SLIT("Type variable:"))
720 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
721 hang (ptext SLIT("Arg type:"))
722 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
724 mkTyAppMsg :: Type -> Type -> Message
726 = vcat [text "Illegal type application:",
727 hang (ptext SLIT("Exp type:"))
728 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
729 hang (ptext SLIT("Arg type:"))
730 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
732 mkRhsMsg :: Id -> Type -> Message
735 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
737 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
738 hsep [ptext SLIT("Rhs type:"), ppr ty]]
740 mkRhsPrimMsg :: Id -> CoreExpr -> Message
741 mkRhsPrimMsg binder rhs
742 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
744 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
747 mkUnboxedTupleMsg :: Id -> Message
748 mkUnboxedTupleMsg binder
749 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
750 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
752 mkCoerceErr from_ty expr_ty
753 = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
754 ptext SLIT("From-type:") <+> ppr from_ty,
755 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
759 = ptext SLIT("Type where expression expected:") <+> ppr e