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 ( DynFlags, dopt_D_show_passes, dopt_DoCoreLinting,
20 import Rules ( RuleBase, pprRuleBase )
21 import CoreFVs ( idFreeVars, mustHaveLocalBinding )
22 import CoreUtils ( exprOkForSpeculation, coreBindsSize, mkPiType )
25 import Literal ( literalType )
26 import DataCon ( dataConRepType )
27 import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId )
29 import Subst ( mkTyVarSubst, substTy )
30 import Name ( getSrcLoc )
32 import ErrUtils ( doIfSet_dyn, dumpIfSet, ghcExit, Message,
33 ErrMsg, addErrLocHdrLine, pprBagOfErrors,
34 WarnMsg, pprBagOfWarnings)
35 import SrcLoc ( SrcLoc, noSrcLoc )
36 import Type ( Type, tyVarsOfType,
37 splitFunTy_maybe, mkTyVarTy,
38 splitForAllTy_maybe, splitTyConApp_maybe,
39 isUnLiftedType, typeKind,
43 import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
44 import BasicTypes ( RecFlag(..), isNonRec )
48 infixr 9 `thenL`, `seqL`
51 %************************************************************************
53 \subsection{Start and end pass}
55 %************************************************************************
57 @beginPass@ and @endPass@ don't really belong here, but it makes a convenient
58 place for them. They print out stuff before and after core passes,
59 and do Core Lint when necessary.
62 beginPass :: DynFlags -> String -> IO ()
63 beginPass dflags pass_name
64 | dopt_D_show_passes dflags
65 = hPutStrLn stdout ("*** " ++ pass_name)
70 endPass :: DynFlags -> String -> Bool -> [CoreBind] -> IO [CoreBind]
71 endPass dflags pass_name dump_flag binds
73 (binds, _) <- endPassWithRules dflags pass_name dump_flag binds Nothing
76 endPassWithRules :: DynFlags -> String -> Bool -> [CoreBind] -> Maybe RuleBase
77 -> IO ([CoreBind], Maybe RuleBase)
78 endPassWithRules dflags pass_name dump_flag binds rules
80 -- ToDo: force the rules?
82 -- Report result size if required
83 -- This has the side effect of forcing the intermediate to be evaluated
84 if dopt_D_show_passes dflags then
85 hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds))
89 -- Report verbosely, if required
90 dumpIfSet dump_flag pass_name
91 (pprCoreBindings binds $$ case rules of
93 Just rb -> pprRuleBase rb)
96 lintCoreBindings dflags pass_name binds
97 -- ToDo: lint the rules
103 %************************************************************************
105 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
107 %************************************************************************
109 Checks that a set of core bindings is well-formed. The PprStyle and String
110 just control what we print in the event of an error. The Bool value
111 indicates whether we have done any specialisation yet (in which case we do
116 (b) Out-of-scope type variables
117 (c) Out-of-scope local variables
120 If we have done specialisation the we check that there are
121 (a) No top-level bindings of primitive (unboxed type)
126 -- Things are *not* OK if:
128 -- * Unsaturated type app before specialisation has been done;
130 -- * Oversaturated type app after specialisation (eta reduction
131 -- may well be happening...);
134 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
136 lintCoreBindings dflags whoDunnit binds
137 | not (dopt_DoCoreLinting dflags)
140 lintCoreBindings dflags whoDunnit binds
141 = case (initL (lint_binds binds)) of
142 (Nothing, Nothing) -> done_lint
144 (Nothing, Just warnings) -> printDump (warn warnings) >>
147 (Just bad_news, warns) -> printDump (display bad_news warns) >>
150 -- Put all the top-level binders in scope at the start
151 -- This is because transformation rules can bring something
152 -- into use 'unexpectedly'
153 lint_binds binds = addInScopeVars (bindersOfBinds binds) $
156 lint_bind (Rec prs) = mapL (lintSingleBinding Recursive) prs `seqL`
158 lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
160 done_lint = doIfSet_dyn dflags dopt_D_show_passes
161 (hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
164 text ("*** Core Lint Warnings: in result of " ++ whoDunnit ++ " ***"),
169 display bad_news warns
171 text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
173 maybe offender warn warns -- either offender or warnings (with offender)
178 ptext SLIT("*** Offending Program ***"),
179 pprCoreBindings binds,
180 ptext SLIT("*** End of Offense ***")
184 %************************************************************************
186 \subsection[lintUnfolding]{lintUnfolding}
188 %************************************************************************
190 We use this to check all unfoldings that come in from interfaces
191 (it is very painful to catch errors otherwise):
194 lintUnfolding :: DynFlags
196 -> [Var] -- Treat these as in scope
198 -> (Maybe Message, Maybe Message) -- (Nothing,_) => OK
200 lintUnfolding dflags locn vars expr
201 | not (dopt_DoCoreLinting dflags)
205 = initL (addLoc (ImportedUnfolding locn) $
206 addInScopeVars vars $
210 %************************************************************************
212 \subsection[lintCoreBinding]{lintCoreBinding}
214 %************************************************************************
216 Check a core binding, returning the list of variables bound.
219 lintSingleBinding rec_flag (binder,rhs)
220 = addLoc (RhsOf binder) $
223 lintCoreExpr rhs `thenL` \ ty ->
225 -- Check match to RHS type
226 lintBinder binder `seqL`
227 checkTys binder_ty ty (mkRhsMsg binder ty) `seqL`
229 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
230 checkL (not (isUnLiftedType binder_ty)
231 || (isNonRec rec_flag && exprOkForSpeculation rhs))
232 (mkRhsPrimMsg binder rhs) `seqL`
234 -- Check whether binder's specialisations contain any out-of-scope variables
235 mapL (checkBndrIdInScope binder) bndr_vars `seqL`
238 -- We should check the unfolding, if any, but this is tricky because
239 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
241 binder_ty = idType binder
242 bndr_vars = varSetElems (idFreeVars binder)
245 %************************************************************************
247 \subsection[lintCoreExpr]{lintCoreExpr}
249 %************************************************************************
252 lintCoreExpr :: CoreExpr -> LintM Type
254 lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
255 lintCoreExpr (Lit lit) = returnL (literalType lit)
257 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
258 = lintCoreExpr expr `thenL` \ expr_ty ->
260 lintTy from_ty `seqL`
261 checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
264 lintCoreExpr (Note other_note expr)
267 lintCoreExpr (Let (NonRec bndr rhs) body)
268 = lintSingleBinding NonRecursive (bndr,rhs) `seqL`
269 addLoc (BodyOfLetRec [bndr])
270 (addInScopeVars [bndr] (lintCoreExpr body))
272 lintCoreExpr (Let (Rec pairs) body)
273 = addInScopeVars bndrs $
274 mapL (lintSingleBinding Recursive) pairs `seqL`
275 addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
277 bndrs = map fst pairs
279 lintCoreExpr e@(App fun arg)
280 = lintCoreExpr fun `thenL` \ ty ->
284 lintCoreExpr (Lam var expr)
285 = addLoc (LambdaBodyOf var) $
287 checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
291 (addInScopeVars [var] $
292 lintCoreExpr expr `thenL` \ ty ->
294 returnL (mkPiType var ty))
296 lintCoreExpr e@(Case scrut var alts)
297 = -- Check the scrutinee
298 lintCoreExpr scrut `thenL` \ scrut_ty ->
301 lintBinder var `seqL`
303 -- If this is an unboxed tuple case, then the binder must be dead
305 checkL (if isUnboxedTupleType (idType var)
306 then isDeadBinder var
307 else True) (mkUnboxedTupleMsg var) `seqL`
310 checkTys (idType var) scrut_ty (mkScrutMsg var scrut_ty) `seqL`
312 addInScopeVars [var] (
314 -- Check the alternatives
315 checkAllCasesCovered e scrut_ty alts `seqL`
317 mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) ->
318 mapL (check alt_ty) alt_tys `seqL`
321 check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
323 lintCoreExpr e@(Type ty)
324 = addErrL (mkStrangeTyMsg e)
327 %************************************************************************
329 \subsection[lintCoreArgs]{lintCoreArgs}
331 %************************************************************************
333 The basic version of these functions checks that the argument is a
334 subtype of the required type, as one would expect.
337 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
338 lintCoreArgs = lintCoreArgs0 checkTys
340 lintCoreArg :: Type -> CoreArg -> LintM Type
341 lintCoreArg = lintCoreArg0 checkTys
344 The primitive version of these functions takes a check argument,
345 allowing a different comparison.
348 lintCoreArgs0 check_tys ty [] = returnL ty
349 lintCoreArgs0 check_tys ty (a : args)
350 = lintCoreArg0 check_tys ty a `thenL` \ res ->
351 lintCoreArgs0 check_tys res args
353 lintCoreArg0 check_tys ty a@(Type arg_ty)
354 = lintTy arg_ty `seqL`
357 lintCoreArg0 check_tys fun_ty arg
358 = -- Make sure function type matches argument
359 lintCoreExpr arg `thenL` \ arg_ty ->
361 err = mkAppMsg fun_ty arg_ty
363 case splitFunTy_maybe fun_ty of
364 Just (arg,res) -> check_tys arg arg_ty err `seqL`
371 = case splitForAllTy_maybe ty of
372 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
375 if not (isTyVar tyvar) then addErrL (mkTyAppMsg ty arg_ty) else
377 tyvar_kind = tyVarKind tyvar
378 argty_kind = typeKind arg_ty
380 if argty_kind `hasMoreBoxityInfo` tyvar_kind
381 -- Arg type might be boxed for a function with an uncommitted
382 -- tyvar; notably this is used so that we can give
383 -- error :: forall a:*. String -> a
384 -- and then apply it to both boxed and unboxed types.
386 returnL (substTy (mkTyVarSubst [tyvar] [arg_ty]) body)
388 addErrL (mkKindErrMsg tyvar arg_ty)
393 lintTyApps fun_ty (arg_ty : arg_tys)
394 = lintTyApp fun_ty arg_ty `thenL` \ fun_ty' ->
395 lintTyApps fun_ty' arg_tys
400 %************************************************************************
402 \subsection[lintCoreAlts]{lintCoreAlts}
404 %************************************************************************
407 checkAllCasesCovered :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
409 checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e)
411 checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL
413 checkAllCasesCovered e scrut_ty alts
414 = case splitTyConApp_maybe scrut_ty of {
415 Nothing -> addErrL (badAltsMsg e);
416 Just (tycon, tycon_arg_tys) ->
418 if isPrimTyCon tycon then
419 checkL (hasDefault alts) (nonExhaustiveAltsMsg e)
423 -- Algebraic cases are not necessarily exhaustive, because
424 -- the simplifer correctly eliminates case that can't
426 -- This code just emits a message to say so
428 missing_cons = filter not_in_alts (tyConDataCons tycon)
429 not_in_alts con = all (not_in_alt con) alts
430 not_in_alt con (DataCon con', _, _) = con /= con'
431 not_in_alt con other = True
433 case_bndr = case e of { Case _ bndr alts -> bndr }
435 if not (hasDefault alts || null missing_cons) then
436 pprTrace "Exciting (but not a problem)! Non-exhaustive case:"
437 (ppr case_bndr <+> ppr missing_cons)
444 hasDefault [] = False
445 hasDefault ((DEFAULT,_,_) : alts) = True
446 hasDefault (alt : alts) = hasDefault alts
450 lintCoreAlt :: Type -- Type of scrutinee
452 -> LintM Type -- Type of alternatives
454 lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs)
455 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
458 lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
459 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
460 checkTys lit_ty scrut_ty
461 (mkBadPatMsg lit_ty scrut_ty) `seqL`
464 lit_ty = literalType lit
466 lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
467 = addLoc (CaseAlt alt) (
469 mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
470 (mkUnboxedTupleMsg arg)) args `seqL`
472 addInScopeVars args (
475 -- Scrutinee type must be a tycon applicn; checked by caller
476 -- This code is remarkably compact considering what it does!
477 -- NB: args must be in scope here so that the lintCoreArgs line works.
478 case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) ->
479 lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type ->
480 lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
481 checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
488 mk_arg b | isTyVar b = Type (mkTyVarTy b)
490 | otherwise = pprPanic "lintCoreAlt:mk_arg " (ppr b)
493 %************************************************************************
495 \subsection[lint-types]{Types}
497 %************************************************************************
500 lintBinder :: Var -> LintM ()
502 -- ToDo: lint its type
503 -- ToDo: lint its rules
505 lintTy :: Type -> LintM ()
506 lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
508 -- ToDo: check the kind structure of the type
512 %************************************************************************
514 \subsection[lint-monad]{The Lint monad}
516 %************************************************************************
519 type LintM a = [LintLocInfo] -- Locations
520 -> IdSet -- Local vars in scope
521 -> Bag ErrMsg -- Error messages so far
522 -> Bag WarnMsg -- Warning messages so far
523 -> (Maybe a, Bag ErrMsg, Bag WarnMsg) -- Result and error/warning messages (if any)
526 = RhsOf Id -- The variable bound
527 | LambdaBodyOf Id -- The lambda-binder
528 | BodyOfLetRec [Id] -- One of the binders
529 | CaseAlt CoreAlt -- Pattern of a case alternative
530 | AnExpr CoreExpr -- Some expression
531 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
535 initL :: LintM a -> (Maybe Message {- errors -}, Maybe Message {- warnings -})
537 = case m [] emptyVarSet emptyBag emptyBag of
538 (_, errs, warns) -> (ifNonEmptyBag errs pprBagOfErrors,
539 ifNonEmptyBag warns pprBagOfWarnings)
541 ifNonEmptyBag bag f | isEmptyBag bag = Nothing
542 | otherwise = Just (f bag)
544 returnL :: a -> LintM a
545 returnL r loc scope errs warns = (Just r, errs, warns)
548 nopL loc scope errs warns = (Nothing, errs, warns)
550 thenL :: LintM a -> (a -> LintM b) -> LintM b
551 thenL m k loc scope errs warns
552 = case m loc scope errs warns of
553 (Just r, errs', warns') -> k r loc scope errs' warns'
554 (Nothing, errs', warns') -> (Nothing, errs', warns')
556 seqL :: LintM a -> LintM b -> LintM b
557 seqL m k loc scope errs warns
558 = case m loc scope errs warns of
559 (_, errs', warns') -> k loc scope errs' warns'
561 mapL :: (a -> LintM b) -> [a] -> LintM [b]
562 mapL f [] = returnL []
565 mapL f xs `thenL` \ rs ->
570 checkL :: Bool -> Message -> LintM ()
571 checkL True msg = nopL
572 checkL False msg = addErrL msg
574 addErrL :: Message -> LintM a
575 addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns)
577 addWarnL :: Message -> LintM a
578 addWarnL msg loc scope errs warns = (Nothing, errs, addErr warns msg loc)
580 addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
581 -- errors or warnings, actually... they're the same type.
582 addErr errs_so_far msg locs
583 = ASSERT( not (null locs) )
584 errs_so_far `snocBag` mk_msg msg
586 (loc, cxt1) = dumpLoc (head locs)
587 cxts = [snd (dumpLoc loc) | loc <- locs]
588 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
591 mk_msg msg = addErrLocHdrLine loc context msg
593 addLoc :: LintLocInfo -> LintM a -> LintM a
594 addLoc extra_loc m loc scope errs warns
595 = m (extra_loc:loc) scope errs warns
597 addInScopeVars :: [Var] -> LintM a -> LintM a
598 addInScopeVars ids m loc scope errs warns
599 = m loc (scope `unionVarSet` mkVarSet ids) errs warns
603 checkIdInScope :: Var -> LintM ()
605 = checkInScope (ptext SLIT("is out of scope")) id
607 checkBndrIdInScope :: Var -> Var -> LintM ()
608 checkBndrIdInScope binder id
609 = checkInScope msg id
611 msg = ptext SLIT("is out of scope inside info for") <+>
614 checkInScope :: SDoc -> Var -> LintM ()
615 checkInScope loc_msg var loc scope errs warns
616 | mustHaveLocalBinding var && not (var `elemVarSet` scope)
617 = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc, warns)
619 = nopL loc scope errs warns
621 checkTys :: Type -> Type -> Message -> LintM ()
622 -- check ty2 is subtype of ty1 (ie, has same structure but usage
623 -- annotations need only be consistent, not equal)
626 | otherwise = addErrL msg
630 %************************************************************************
632 \subsection{Error messages}
634 %************************************************************************
638 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
640 dumpLoc (LambdaBodyOf b)
641 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
643 dumpLoc (BodyOfLetRec [])
644 = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
646 dumpLoc (BodyOfLetRec bs@(_:_))
647 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
650 = (noSrcLoc, text "In the expression:" <+> ppr e)
652 dumpLoc (CaseAlt (con, args, rhs))
653 = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
655 dumpLoc (ImportedUnfolding locn)
656 = (locn, brackets (ptext SLIT("in an imported unfolding")))
658 pp_binders :: [Var] -> SDoc
659 pp_binders bs = sep (punctuate comma (map pp_binder bs))
661 pp_binder :: Var -> SDoc
662 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
663 | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
667 ------------------------------------------------------
668 -- Messages for case expressions
670 mkNullAltsMsg :: CoreExpr -> Message
672 = hang (text "Case expression with no alternatives:")
675 mkDefaultArgsMsg :: [Var] -> Message
676 mkDefaultArgsMsg args
677 = hang (text "DEFAULT case with binders")
680 mkCaseAltMsg :: CoreExpr -> Message
682 = hang (text "Type of case alternatives not the same:")
685 mkScrutMsg :: Id -> Type -> Message
686 mkScrutMsg var scrut_ty
687 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
688 text "Result binder type:" <+> ppr (idType var),
689 text "Scrutinee type:" <+> ppr scrut_ty]
691 badAltsMsg :: CoreExpr -> Message
693 = hang (text "Case statement scrutinee is not a data type:")
696 nonExhaustiveAltsMsg :: CoreExpr -> Message
697 nonExhaustiveAltsMsg e
698 = hang (text "Case expression with non-exhaustive alternatives")
701 mkBadPatMsg :: Type -> Type -> Message
702 mkBadPatMsg con_result_ty scrut_ty
704 text "In a case alternative, pattern result type doesn't match scrutinee type:",
705 text "Pattern result type:" <+> ppr con_result_ty,
706 text "Scrutinee type:" <+> ppr scrut_ty
709 ------------------------------------------------------
710 -- Other error messages
712 mkAppMsg :: Type -> Type -> Message
714 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
715 hang (ptext SLIT("Fun type:")) 4 (ppr fun),
716 hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
718 mkKindErrMsg :: TyVar -> Type -> Message
719 mkKindErrMsg tyvar arg_ty
720 = vcat [ptext SLIT("Kinds don't match in type application:"),
721 hang (ptext SLIT("Type variable:"))
722 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
723 hang (ptext SLIT("Arg type:"))
724 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
726 mkTyAppMsg :: Type -> Type -> Message
728 = vcat [text "Illegal type application:",
729 hang (ptext SLIT("Exp type:"))
730 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
731 hang (ptext SLIT("Arg type:"))
732 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
734 mkRhsMsg :: Id -> Type -> Message
737 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
739 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
740 hsep [ptext SLIT("Rhs type:"), ppr ty]]
742 mkRhsPrimMsg :: Id -> CoreExpr -> Message
743 mkRhsPrimMsg binder rhs
744 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
746 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
749 mkUnboxedTupleMsg :: Id -> Message
750 mkUnboxedTupleMsg binder
751 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
752 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
754 mkCoerceErr from_ty expr_ty
755 = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
756 ptext SLIT("From-type:") <+> ppr from_ty,
757 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
761 = ptext SLIT("Type where expression expected:") <+> ppr e