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,
31 import SrcLoc ( SrcLoc, noSrcLoc )
32 import Type ( Type, tyVarsOfType, eqType,
33 splitFunTy_maybe, mkTyVarTy,
34 splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
35 isUnLiftedType, typeKind,
39 import TyCon ( isPrimTyCon )
40 import BasicTypes ( RecFlag(..), isNonRec )
43 import Util ( notNull )
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
120 Just bad_news -> printDump (display bad_news) >>
123 -- Put all the top-level binders in scope at the start
124 -- This is because transformation rules can bring something
125 -- into use 'unexpectedly'
126 lint_binds binds = addInScopeVars (bindersOfBinds binds) $
129 lint_bind (Rec prs) = mapL (lintSingleBinding Recursive) prs `seqL`
131 lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
133 done_lint = doIfSet (verbosity dflags >= 2)
134 (hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
137 = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
139 ptext SLIT("*** Offending Program ***"),
140 pprCoreBindings binds,
141 ptext SLIT("*** End of Offense ***")
145 %************************************************************************
147 \subsection[lintUnfolding]{lintUnfolding}
149 %************************************************************************
151 We use this to check all unfoldings that come in from interfaces
152 (it is very painful to catch errors otherwise):
155 lintUnfolding :: SrcLoc
156 -> [Var] -- Treat these as in scope
158 -> Maybe Message -- Nothing => OK
160 lintUnfolding locn vars expr
161 = initL (addLoc (ImportedUnfolding locn) $
162 addInScopeVars vars $
166 %************************************************************************
168 \subsection[lintCoreBinding]{lintCoreBinding}
170 %************************************************************************
172 Check a core binding, returning the list of variables bound.
175 lintSingleBinding rec_flag (binder,rhs)
176 = addLoc (RhsOf binder) $
179 lintCoreExpr rhs `thenL` \ ty ->
181 -- Check match to RHS type
182 lintBinder binder `seqL`
183 checkTys binder_ty ty (mkRhsMsg binder ty) `seqL`
185 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
186 checkL (not (isUnLiftedType binder_ty)
187 || (isNonRec rec_flag && exprOkForSpeculation rhs))
188 (mkRhsPrimMsg binder rhs) `seqL`
190 -- Check whether binder's specialisations contain any out-of-scope variables
191 mapL (checkBndrIdInScope binder) bndr_vars `seqL`
194 -- We should check the unfolding, if any, but this is tricky because
195 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
197 binder_ty = idType binder
198 bndr_vars = varSetElems (idFreeVars binder)
201 %************************************************************************
203 \subsection[lintCoreExpr]{lintCoreExpr}
205 %************************************************************************
208 lintCoreExpr :: CoreExpr -> LintM Type
210 lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
211 lintCoreExpr (Lit lit) = returnL (literalType lit)
213 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
214 = lintCoreExpr expr `thenL` \ expr_ty ->
216 lintTy from_ty `seqL`
217 checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
220 lintCoreExpr (Note other_note expr)
223 lintCoreExpr (Let (NonRec bndr rhs) body)
224 = lintSingleBinding NonRecursive (bndr,rhs) `seqL`
225 addLoc (BodyOfLetRec [bndr])
226 (addInScopeVars [bndr] (lintCoreExpr body))
228 lintCoreExpr (Let (Rec pairs) body)
229 = addInScopeVars bndrs $
230 mapL (lintSingleBinding Recursive) pairs `seqL`
231 addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
233 bndrs = map fst pairs
235 lintCoreExpr e@(App fun arg)
236 = lintCoreExpr fun `thenL` \ ty ->
240 lintCoreExpr (Lam var expr)
241 = addLoc (LambdaBodyOf var) $
243 checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
247 (addInScopeVars [var] $
248 lintCoreExpr expr `thenL` \ ty ->
250 returnL (mkPiType var ty))
252 lintCoreExpr e@(Case scrut var alts)
253 = -- Check the scrutinee
254 lintCoreExpr scrut `thenL` \ scrut_ty ->
257 lintBinder var `seqL`
259 -- If this is an unboxed tuple case, then the binder must be dead
261 checkL (if isUnboxedTupleType (idType var)
262 then isDeadBinder var
263 else True) (mkUnboxedTupleMsg var) `seqL`
266 checkTys (idType var) scrut_ty (mkScrutMsg var scrut_ty) `seqL`
268 addInScopeVars [var] (
270 -- Check the alternatives
271 checkCaseAlts e scrut_ty alts `seqL`
273 mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) ->
274 mapL (check alt_ty) alt_tys `seqL`
277 check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
279 lintCoreExpr e@(Type ty)
280 = addErrL (mkStrangeTyMsg e)
283 %************************************************************************
285 \subsection[lintCoreArgs]{lintCoreArgs}
287 %************************************************************************
289 The basic version of these functions checks that the argument is a
290 subtype of the required type, as one would expect.
293 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
294 lintCoreArgs = lintCoreArgs0 checkTys
296 lintCoreArg :: Type -> CoreArg -> LintM Type
297 lintCoreArg = lintCoreArg0 checkTys
300 The primitive version of these functions takes a check argument,
301 allowing a different comparison.
304 lintCoreArgs0 check_tys ty [] = returnL ty
305 lintCoreArgs0 check_tys ty (a : args)
306 = lintCoreArg0 check_tys ty a `thenL` \ res ->
307 lintCoreArgs0 check_tys res args
309 lintCoreArg0 check_tys ty a@(Type arg_ty)
310 = lintTy arg_ty `seqL`
313 lintCoreArg0 check_tys fun_ty arg
314 = -- Make sure function type matches argument
315 lintCoreExpr arg `thenL` \ arg_ty ->
317 err = mkAppMsg fun_ty arg_ty
319 case splitFunTy_maybe fun_ty of
320 Just (arg,res) -> check_tys arg arg_ty err `seqL`
327 = case splitForAllTy_maybe ty of
328 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
331 if not (isTyVar tyvar) then addErrL (mkTyAppMsg ty arg_ty) else
333 tyvar_kind = tyVarKind tyvar
334 argty_kind = typeKind arg_ty
336 if argty_kind `hasMoreBoxityInfo` tyvar_kind
337 -- Arg type might be boxed for a function with an uncommitted
338 -- tyvar; notably this is used so that we can give
339 -- error :: forall a:*. String -> a
340 -- and then apply it to both boxed and unboxed types.
342 returnL (substTyWith [tyvar] [arg_ty] body)
344 addErrL (mkKindErrMsg tyvar arg_ty)
349 lintTyApps fun_ty (arg_ty : arg_tys)
350 = lintTyApp fun_ty arg_ty `thenL` \ fun_ty' ->
351 lintTyApps fun_ty' arg_tys
356 %************************************************************************
358 \subsection[lintCoreAlts]{lintCoreAlts}
360 %************************************************************************
363 checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
364 -- a) Check that the alts are non-empty
365 -- b) Check that the DEFAULT comes first, if it exists
366 -- c) Check that there's a default for infinite types
367 -- NB: Algebraic cases are not necessarily exhaustive, because
368 -- the simplifer correctly eliminates case that can't
371 checkCaseAlts e ty []
372 = addErrL (mkNullAltsMsg e)
374 checkCaseAlts e ty alts
375 = checkL (all non_deflt con_alts) (mkNonDefltMsg e) `seqL`
376 checkL (isJust maybe_deflt || not is_infinite_ty)
377 (nonExhaustiveAltsMsg e)
379 (con_alts, maybe_deflt) = findDefault alts
381 non_deflt (DEFAULT, _, _) = False
384 is_infinite_ty = case splitTyConApp_maybe ty of
386 Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
390 lintCoreAlt :: Type -- Type of scrutinee
392 -> LintM Type -- Type of alternatives
394 lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs)
395 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
398 lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
399 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
400 checkTys lit_ty scrut_ty
401 (mkBadPatMsg lit_ty scrut_ty) `seqL`
404 lit_ty = literalType lit
406 lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
407 = addLoc (CaseAlt alt) (
409 mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
410 (mkUnboxedTupleMsg arg)) args `seqL`
412 addInScopeVars args (
415 -- Scrutinee type must be a tycon applicn; checked by caller
416 -- This code is remarkably compact considering what it does!
417 -- NB: args must be in scope here so that the lintCoreArgs line works.
418 -- NB: relies on existential type args coming *after* ordinary type args
419 case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) ->
420 lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type ->
421 lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
422 checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
429 mk_arg b | isTyVar b = Type (mkTyVarTy b)
431 | otherwise = pprPanic "lintCoreAlt:mk_arg " (ppr b)
434 %************************************************************************
436 \subsection[lint-types]{Types}
438 %************************************************************************
441 lintBinder :: Var -> LintM ()
443 -- ToDo: lint its type
444 -- ToDo: lint its rules
446 lintTy :: Type -> LintM ()
447 lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
449 -- ToDo: check the kind structure of the type
453 %************************************************************************
455 \subsection[lint-monad]{The Lint monad}
457 %************************************************************************
460 type LintM a = [LintLocInfo] -- Locations
461 -> IdSet -- Local vars in scope
462 -> Bag Message -- Error messages so far
463 -> (Maybe a, Bag Message) -- Result and error messages (if any)
466 = RhsOf Id -- The variable bound
467 | LambdaBodyOf Id -- The lambda-binder
468 | BodyOfLetRec [Id] -- One of the binders
469 | CaseAlt CoreAlt -- Pattern of a case alternative
470 | AnExpr CoreExpr -- Some expression
471 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
475 initL :: LintM a -> Maybe Message {- errors -}
477 = case m [] emptyVarSet emptyBag of
478 (_, errs) | isEmptyBag errs -> Nothing
479 | otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
481 returnL :: a -> LintM a
482 returnL r loc scope errs = (Just r, errs)
485 nopL loc scope errs = (Nothing, errs)
487 thenL :: LintM a -> (a -> LintM b) -> LintM b
488 thenL m k loc scope errs
489 = case m loc scope errs of
490 (Just r, errs') -> k r loc scope errs'
491 (Nothing, errs') -> (Nothing, errs')
493 seqL :: LintM a -> LintM b -> LintM b
494 seqL m k loc scope errs
495 = case m loc scope errs of
496 (_, errs') -> k loc scope errs'
498 mapL :: (a -> LintM b) -> [a] -> LintM [b]
499 mapL f [] = returnL []
502 mapL f xs `thenL` \ rs ->
507 checkL :: Bool -> Message -> LintM ()
508 checkL True msg = nopL
509 checkL False msg = addErrL msg
511 addErrL :: Message -> LintM a
512 addErrL msg loc scope errs = (Nothing, addErr errs msg loc)
514 addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
515 addErr errs_so_far msg locs
516 = ASSERT( notNull locs )
517 errs_so_far `snocBag` mk_msg msg
519 (loc, cxt1) = dumpLoc (head locs)
520 cxts = [snd (dumpLoc loc) | loc <- locs]
521 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
524 mk_msg msg = addErrLocHdrLine loc context msg
526 addLoc :: LintLocInfo -> LintM a -> LintM a
527 addLoc extra_loc m loc scope errs
528 = m (extra_loc:loc) scope errs
530 addInScopeVars :: [Var] -> LintM a -> LintM a
531 addInScopeVars ids m loc scope errs
532 = m loc (scope `unionVarSet` mkVarSet ids) errs
536 checkIdInScope :: Var -> LintM ()
538 = checkInScope (ptext SLIT("is out of scope")) id
540 checkBndrIdInScope :: Var -> Var -> LintM ()
541 checkBndrIdInScope binder id
542 = checkInScope msg id
544 msg = ptext SLIT("is out of scope inside info for") <+>
547 checkInScope :: SDoc -> Var -> LintM ()
548 checkInScope loc_msg var loc scope errs
549 | mustHaveLocalBinding var && not (var `elemVarSet` scope)
550 = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc)
552 = nopL loc scope errs
554 checkTys :: Type -> Type -> Message -> LintM ()
555 -- check ty2 is subtype of ty1 (ie, has same structure but usage
556 -- annotations need only be consistent, not equal)
558 | ty1 `eqType` ty2 = nopL
559 | otherwise = addErrL msg
563 %************************************************************************
565 \subsection{Error messages}
567 %************************************************************************
571 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
573 dumpLoc (LambdaBodyOf b)
574 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
576 dumpLoc (BodyOfLetRec [])
577 = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
579 dumpLoc (BodyOfLetRec bs@(_:_))
580 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
583 = (noSrcLoc, text "In the expression:" <+> ppr e)
585 dumpLoc (CaseAlt (con, args, rhs))
586 = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
588 dumpLoc (ImportedUnfolding locn)
589 = (locn, brackets (ptext SLIT("in an imported unfolding")))
591 pp_binders :: [Var] -> SDoc
592 pp_binders bs = sep (punctuate comma (map pp_binder bs))
594 pp_binder :: Var -> SDoc
595 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
596 | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
600 ------------------------------------------------------
601 -- Messages for case expressions
603 mkNullAltsMsg :: CoreExpr -> Message
605 = hang (text "Case expression with no alternatives:")
608 mkDefaultArgsMsg :: [Var] -> Message
609 mkDefaultArgsMsg args
610 = hang (text "DEFAULT case with binders")
613 mkCaseAltMsg :: CoreExpr -> Message
615 = hang (text "Type of case alternatives not the same:")
618 mkScrutMsg :: Id -> Type -> Message
619 mkScrutMsg var scrut_ty
620 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
621 text "Result binder type:" <+> ppr (idType var),
622 text "Scrutinee type:" <+> ppr scrut_ty]
626 = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
628 nonExhaustiveAltsMsg :: CoreExpr -> Message
629 nonExhaustiveAltsMsg e
630 = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
632 mkBadPatMsg :: Type -> Type -> Message
633 mkBadPatMsg con_result_ty scrut_ty
635 text "In a case alternative, pattern result type doesn't match scrutinee type:",
636 text "Pattern result type:" <+> ppr con_result_ty,
637 text "Scrutinee type:" <+> ppr scrut_ty
640 ------------------------------------------------------
641 -- Other error messages
643 mkAppMsg :: Type -> Type -> Message
645 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
646 hang (ptext SLIT("Fun type:")) 4 (ppr fun),
647 hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
649 mkKindErrMsg :: TyVar -> Type -> Message
650 mkKindErrMsg tyvar arg_ty
651 = vcat [ptext SLIT("Kinds don't match in type application:"),
652 hang (ptext SLIT("Type variable:"))
653 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
654 hang (ptext SLIT("Arg type:"))
655 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
657 mkTyAppMsg :: Type -> Type -> Message
659 = vcat [text "Illegal type application:",
660 hang (ptext SLIT("Exp type:"))
661 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
662 hang (ptext SLIT("Arg type:"))
663 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
665 mkRhsMsg :: Id -> Type -> Message
668 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
670 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
671 hsep [ptext SLIT("Rhs type:"), ppr ty]]
673 mkRhsPrimMsg :: Id -> CoreExpr -> Message
674 mkRhsPrimMsg binder rhs
675 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
677 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
680 mkUnboxedTupleMsg :: Id -> Message
681 mkUnboxedTupleMsg binder
682 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
683 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
685 mkCoerceErr from_ty expr_ty
686 = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
687 ptext SLIT("From-type:") <+> ppr from_ty,
688 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
692 = ptext SLIT("Type where expression expected:") <+> ppr e