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, hPutStrLn, stdout )
18 import CoreFVs ( idFreeVars )
19 import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
22 import Literal ( literalType )
23 import DataCon ( dataConRepType )
24 import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding )
26 import Subst ( substTyWith )
27 import Name ( getSrcLoc )
29 import ErrUtils ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass,
30 ErrMsg, addErrLocHdrLine, pprBagOfErrors,
31 WarnMsg, pprBagOfWarnings)
32 import SrcLoc ( SrcLoc, noSrcLoc )
33 import Type ( Type, tyVarsOfType, eqType,
34 splitFunTy_maybe, mkTyVarTy,
35 splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
36 isUnLiftedType, typeKind,
40 import TyCon ( isPrimTyCon )
41 import BasicTypes ( RecFlag(..), isNonRec )
46 infixr 9 `thenL`, `seqL`
49 %************************************************************************
53 %************************************************************************
55 @showPass@ and @endPass@ don't really belong here, but it makes a convenient
56 place for them. They print out stuff before and after core passes,
57 and do Core Lint when necessary.
60 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
61 endPass dflags pass_name dump_flag binds
63 -- Report result size if required
64 -- This has the side effect of forcing the intermediate to be evaluated
65 if verbosity dflags >= 2 then
66 hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds))
70 -- Report verbosely, if required
71 dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
74 lintCoreBindings dflags 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 :: DynFlags -> String -> [CoreBind] -> IO ()
113 lintCoreBindings dflags whoDunnit binds
114 | not (dopt Opt_DoCoreLinting dflags)
117 lintCoreBindings dflags whoDunnit binds
118 = case (initL (lint_binds binds)) of
119 (Nothing, Nothing) -> done_lint
121 (Nothing, Just warnings) -> printDump (warn warnings) >>
124 (Just bad_news, warns) -> printDump (display bad_news warns) >>
127 -- Put all the top-level binders in scope at the start
128 -- This is because transformation rules can bring something
129 -- into use 'unexpectedly'
130 lint_binds binds = addInScopeVars (bindersOfBinds binds) $
133 lint_bind (Rec prs) = mapL (lintSingleBinding Recursive) prs `seqL`
135 lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
137 done_lint = doIfSet (verbosity dflags >= 2)
138 (hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
141 text ("*** Core Lint Warnings: in result of " ++ whoDunnit ++ " ***"),
146 display bad_news warns
148 text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
150 maybe offender warn warns -- either offender or warnings (with offender)
155 ptext SLIT("*** Offending Program ***"),
156 pprCoreBindings binds,
157 ptext SLIT("*** End of Offense ***")
161 %************************************************************************
163 \subsection[lintUnfolding]{lintUnfolding}
165 %************************************************************************
167 We use this to check all unfoldings that come in from interfaces
168 (it is very painful to catch errors otherwise):
171 lintUnfolding :: DynFlags
173 -> [Var] -- Treat these as in scope
175 -> (Maybe Message, Maybe Message) -- (Nothing,_) => OK
177 lintUnfolding dflags locn vars expr
178 | not (dopt Opt_DoCoreLinting dflags)
182 = initL (addLoc (ImportedUnfolding locn) $
183 addInScopeVars vars $
187 %************************************************************************
189 \subsection[lintCoreBinding]{lintCoreBinding}
191 %************************************************************************
193 Check a core binding, returning the list of variables bound.
196 lintSingleBinding rec_flag (binder,rhs)
197 = addLoc (RhsOf binder) $
200 lintCoreExpr rhs `thenL` \ ty ->
202 -- Check match to RHS type
203 lintBinder binder `seqL`
204 checkTys binder_ty ty (mkRhsMsg binder ty) `seqL`
206 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
207 checkL (not (isUnLiftedType binder_ty)
208 || (isNonRec rec_flag && exprOkForSpeculation rhs))
209 (mkRhsPrimMsg binder rhs) `seqL`
211 -- Check whether binder's specialisations contain any out-of-scope variables
212 mapL (checkBndrIdInScope binder) bndr_vars `seqL`
215 -- We should check the unfolding, if any, but this is tricky because
216 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
218 binder_ty = idType binder
219 bndr_vars = varSetElems (idFreeVars binder)
222 %************************************************************************
224 \subsection[lintCoreExpr]{lintCoreExpr}
226 %************************************************************************
229 lintCoreExpr :: CoreExpr -> LintM Type
231 lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
232 lintCoreExpr (Lit lit) = returnL (literalType lit)
234 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
235 = lintCoreExpr expr `thenL` \ expr_ty ->
237 lintTy from_ty `seqL`
238 checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
241 lintCoreExpr (Note other_note expr)
244 lintCoreExpr (Let (NonRec bndr rhs) body)
245 = lintSingleBinding NonRecursive (bndr,rhs) `seqL`
246 addLoc (BodyOfLetRec [bndr])
247 (addInScopeVars [bndr] (lintCoreExpr body))
249 lintCoreExpr (Let (Rec pairs) body)
250 = addInScopeVars bndrs $
251 mapL (lintSingleBinding Recursive) pairs `seqL`
252 addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
254 bndrs = map fst pairs
256 lintCoreExpr e@(App fun arg)
257 = lintCoreExpr fun `thenL` \ ty ->
261 lintCoreExpr (Lam var expr)
262 = addLoc (LambdaBodyOf var) $
264 checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
268 (addInScopeVars [var] $
269 lintCoreExpr expr `thenL` \ ty ->
271 returnL (mkPiType var ty))
273 lintCoreExpr e@(Case scrut var alts)
274 = -- Check the scrutinee
275 lintCoreExpr scrut `thenL` \ scrut_ty ->
278 lintBinder var `seqL`
280 -- If this is an unboxed tuple case, then the binder must be dead
282 checkL (if isUnboxedTupleType (idType var)
283 then isDeadBinder var
284 else True) (mkUnboxedTupleMsg var) `seqL`
287 checkTys (idType var) scrut_ty (mkScrutMsg var scrut_ty) `seqL`
289 addInScopeVars [var] (
291 -- Check the alternatives
292 checkCaseAlts e scrut_ty alts `seqL`
294 mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) ->
295 mapL (check alt_ty) alt_tys `seqL`
298 check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
300 lintCoreExpr e@(Type ty)
301 = addErrL (mkStrangeTyMsg e)
304 %************************************************************************
306 \subsection[lintCoreArgs]{lintCoreArgs}
308 %************************************************************************
310 The basic version of these functions checks that the argument is a
311 subtype of the required type, as one would expect.
314 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
315 lintCoreArgs = lintCoreArgs0 checkTys
317 lintCoreArg :: Type -> CoreArg -> LintM Type
318 lintCoreArg = lintCoreArg0 checkTys
321 The primitive version of these functions takes a check argument,
322 allowing a different comparison.
325 lintCoreArgs0 check_tys ty [] = returnL ty
326 lintCoreArgs0 check_tys ty (a : args)
327 = lintCoreArg0 check_tys ty a `thenL` \ res ->
328 lintCoreArgs0 check_tys res args
330 lintCoreArg0 check_tys ty a@(Type arg_ty)
331 = lintTy arg_ty `seqL`
334 lintCoreArg0 check_tys fun_ty arg
335 = -- Make sure function type matches argument
336 lintCoreExpr arg `thenL` \ arg_ty ->
338 err = mkAppMsg fun_ty arg_ty
340 case splitFunTy_maybe fun_ty of
341 Just (arg,res) -> check_tys arg arg_ty err `seqL`
348 = case splitForAllTy_maybe ty of
349 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
352 if not (isTyVar tyvar) then addErrL (mkTyAppMsg ty arg_ty) else
354 tyvar_kind = tyVarKind tyvar
355 argty_kind = typeKind arg_ty
357 if argty_kind `hasMoreBoxityInfo` tyvar_kind
358 -- Arg type might be boxed for a function with an uncommitted
359 -- tyvar; notably this is used so that we can give
360 -- error :: forall a:*. String -> a
361 -- and then apply it to both boxed and unboxed types.
363 returnL (substTyWith [tyvar] [arg_ty] body)
365 addErrL (mkKindErrMsg tyvar arg_ty)
370 lintTyApps fun_ty (arg_ty : arg_tys)
371 = lintTyApp fun_ty arg_ty `thenL` \ fun_ty' ->
372 lintTyApps fun_ty' arg_tys
377 %************************************************************************
379 \subsection[lintCoreAlts]{lintCoreAlts}
381 %************************************************************************
384 checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
385 -- a) Check that the alts are non-empty
386 -- b) Check that the DEFAULT comes first, if it exists
387 -- c) Check that there's a default for infinite types
388 -- NB: Algebraic cases are not necessarily exhaustive, because
389 -- the simplifer correctly eliminates case that can't
392 checkCaseAlts e ty []
393 = addErrL (mkNullAltsMsg e)
395 checkCaseAlts e ty alts
396 = checkL (all non_deflt con_alts) (mkNonDefltMsg e) `seqL`
397 checkL (isJust maybe_deflt || not is_infinite_ty)
398 (nonExhaustiveAltsMsg e)
400 (con_alts, maybe_deflt) = findDefault alts
402 non_deflt (DEFAULT, _, _) = False
405 is_infinite_ty = case splitTyConApp_maybe ty of
407 Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
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@(LitAlt lit, args, rhs)
420 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
421 checkTys lit_ty scrut_ty
422 (mkBadPatMsg lit_ty scrut_ty) `seqL`
425 lit_ty = literalType lit
427 lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
428 = addLoc (CaseAlt alt) (
430 mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
431 (mkUnboxedTupleMsg arg)) args `seqL`
433 addInScopeVars args (
436 -- Scrutinee type must be a tycon applicn; checked by caller
437 -- This code is remarkably compact considering what it does!
438 -- NB: args must be in scope here so that the lintCoreArgs line works.
439 -- NB: relies on existential type args coming *after* ordinary type args
440 case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) ->
441 lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type ->
442 lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
443 checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
450 mk_arg b | isTyVar b = Type (mkTyVarTy b)
452 | otherwise = pprPanic "lintCoreAlt:mk_arg " (ppr b)
455 %************************************************************************
457 \subsection[lint-types]{Types}
459 %************************************************************************
462 lintBinder :: Var -> LintM ()
464 -- ToDo: lint its type
465 -- ToDo: lint its rules
467 lintTy :: Type -> LintM ()
468 lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
470 -- ToDo: check the kind structure of the type
474 %************************************************************************
476 \subsection[lint-monad]{The Lint monad}
478 %************************************************************************
481 type LintM a = [LintLocInfo] -- Locations
482 -> IdSet -- Local vars in scope
483 -> Bag ErrMsg -- Error messages so far
484 -> Bag WarnMsg -- Warning messages so far
485 -> (Maybe a, Bag ErrMsg, Bag WarnMsg) -- Result and error/warning messages (if any)
488 = RhsOf Id -- The variable bound
489 | LambdaBodyOf Id -- The lambda-binder
490 | BodyOfLetRec [Id] -- One of the binders
491 | CaseAlt CoreAlt -- Pattern of a case alternative
492 | AnExpr CoreExpr -- Some expression
493 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
497 initL :: LintM a -> (Maybe Message {- errors -}, Maybe Message {- warnings -})
499 = case m [] emptyVarSet emptyBag emptyBag of
500 (_, errs, warns) -> (ifNonEmptyBag errs pprBagOfErrors,
501 ifNonEmptyBag warns pprBagOfWarnings)
503 ifNonEmptyBag bag f | isEmptyBag bag = Nothing
504 | otherwise = Just (f bag)
506 returnL :: a -> LintM a
507 returnL r loc scope errs warns = (Just r, errs, warns)
510 nopL loc scope errs warns = (Nothing, errs, warns)
512 thenL :: LintM a -> (a -> LintM b) -> LintM b
513 thenL m k loc scope errs warns
514 = case m loc scope errs warns of
515 (Just r, errs', warns') -> k r loc scope errs' warns'
516 (Nothing, errs', warns') -> (Nothing, errs', warns')
518 seqL :: LintM a -> LintM b -> LintM b
519 seqL m k loc scope errs warns
520 = case m loc scope errs warns of
521 (_, errs', warns') -> k loc scope errs' warns'
523 mapL :: (a -> LintM b) -> [a] -> LintM [b]
524 mapL f [] = returnL []
527 mapL f xs `thenL` \ rs ->
532 checkL :: Bool -> Message -> LintM ()
533 checkL True msg = nopL
534 checkL False msg = addErrL msg
536 addErrL :: Message -> LintM a
537 addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns)
539 addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
540 -- errors or warnings, actually... they're the same type.
541 addErr errs_so_far msg locs
542 = ASSERT( not (null locs) )
543 errs_so_far `snocBag` mk_msg msg
545 (loc, cxt1) = dumpLoc (head locs)
546 cxts = [snd (dumpLoc loc) | loc <- locs]
547 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
550 mk_msg msg = addErrLocHdrLine loc context msg
552 addLoc :: LintLocInfo -> LintM a -> LintM a
553 addLoc extra_loc m loc scope errs warns
554 = m (extra_loc:loc) scope errs warns
556 addInScopeVars :: [Var] -> LintM a -> LintM a
557 addInScopeVars ids m loc scope errs warns
558 = m loc (scope `unionVarSet` mkVarSet ids) errs warns
562 checkIdInScope :: Var -> LintM ()
564 = checkInScope (ptext SLIT("is out of scope")) id
566 checkBndrIdInScope :: Var -> Var -> LintM ()
567 checkBndrIdInScope binder id
568 = checkInScope msg id
570 msg = ptext SLIT("is out of scope inside info for") <+>
573 checkInScope :: SDoc -> Var -> LintM ()
574 checkInScope loc_msg var loc scope errs warns
575 | mustHaveLocalBinding var && not (var `elemVarSet` scope)
576 = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc, warns)
578 = nopL loc scope errs warns
580 checkTys :: Type -> Type -> Message -> LintM ()
581 -- check ty2 is subtype of ty1 (ie, has same structure but usage
582 -- annotations need only be consistent, not equal)
584 | ty1 `eqType` ty2 = nopL
585 | otherwise = addErrL msg
589 %************************************************************************
591 \subsection{Error messages}
593 %************************************************************************
597 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
599 dumpLoc (LambdaBodyOf b)
600 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
602 dumpLoc (BodyOfLetRec [])
603 = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
605 dumpLoc (BodyOfLetRec bs@(_:_))
606 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
609 = (noSrcLoc, text "In the expression:" <+> ppr e)
611 dumpLoc (CaseAlt (con, args, rhs))
612 = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
614 dumpLoc (ImportedUnfolding locn)
615 = (locn, brackets (ptext SLIT("in an imported unfolding")))
617 pp_binders :: [Var] -> SDoc
618 pp_binders bs = sep (punctuate comma (map pp_binder bs))
620 pp_binder :: Var -> SDoc
621 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
622 | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
626 ------------------------------------------------------
627 -- Messages for case expressions
629 mkNullAltsMsg :: CoreExpr -> Message
631 = hang (text "Case expression with no alternatives:")
634 mkDefaultArgsMsg :: [Var] -> Message
635 mkDefaultArgsMsg args
636 = hang (text "DEFAULT case with binders")
639 mkCaseAltMsg :: CoreExpr -> Message
641 = hang (text "Type of case alternatives not the same:")
644 mkScrutMsg :: Id -> Type -> Message
645 mkScrutMsg var scrut_ty
646 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
647 text "Result binder type:" <+> ppr (idType var),
648 text "Scrutinee type:" <+> ppr scrut_ty]
652 = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
654 nonExhaustiveAltsMsg :: CoreExpr -> Message
655 nonExhaustiveAltsMsg e
656 = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
658 mkBadPatMsg :: Type -> Type -> Message
659 mkBadPatMsg con_result_ty scrut_ty
661 text "In a case alternative, pattern result type doesn't match scrutinee type:",
662 text "Pattern result type:" <+> ppr con_result_ty,
663 text "Scrutinee type:" <+> ppr scrut_ty
666 ------------------------------------------------------
667 -- Other error messages
669 mkAppMsg :: Type -> Type -> Message
671 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
672 hang (ptext SLIT("Fun type:")) 4 (ppr fun),
673 hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
675 mkKindErrMsg :: TyVar -> Type -> Message
676 mkKindErrMsg tyvar arg_ty
677 = vcat [ptext SLIT("Kinds don't match in type application:"),
678 hang (ptext SLIT("Type variable:"))
679 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
680 hang (ptext SLIT("Arg type:"))
681 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
683 mkTyAppMsg :: Type -> Type -> Message
685 = vcat [text "Illegal type application:",
686 hang (ptext SLIT("Exp type:"))
687 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
688 hang (ptext SLIT("Arg type:"))
689 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
691 mkRhsMsg :: Id -> Type -> Message
694 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
696 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
697 hsep [ptext SLIT("Rhs type:"), ppr ty]]
699 mkRhsPrimMsg :: Id -> CoreExpr -> Message
700 mkRhsPrimMsg binder rhs
701 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
703 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
706 mkUnboxedTupleMsg :: Id -> Message
707 mkUnboxedTupleMsg binder
708 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
709 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
711 mkCoerceErr from_ty expr_ty
712 = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
713 ptext SLIT("From-type:") <+> ppr from_ty,
714 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
718 = ptext SLIT("Type where expression expected:") <+> ppr e