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"
16 import CoreFVs ( idFreeVars )
17 import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
20 import Literal ( literalType )
21 import DataCon ( dataConRepType )
22 import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding )
24 import Subst ( substTyWith )
25 import Name ( getSrcLoc )
27 import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass,
28 mkLocMessage, debugTraceMsg )
29 import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan )
30 import Type ( Type, tyVarsOfType, eqType,
31 splitFunTy_maybe, mkTyVarTy,
32 splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
33 isUnLiftedType, typeKind,
37 import TyCon ( isPrimTyCon )
38 import BasicTypes ( RecFlag(..), isNonRec )
43 import Util ( notNull )
48 infixr 9 `thenL`, `seqL`
51 %************************************************************************
55 %************************************************************************
57 @showPass@ 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 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
63 endPass dflags pass_name dump_flag binds
65 -- Report result size if required
66 -- This has the side effect of forcing the intermediate to be evaluated
67 debugTraceMsg dflags $
68 " 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 -> showPass dflags ("Core Linted result of " ++ whoDunnit)
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)
134 = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
136 ptext SLIT("*** Offending Program ***"),
137 pprCoreBindings binds,
138 ptext SLIT("*** End of Offense ***")
142 %************************************************************************
144 \subsection[lintUnfolding]{lintUnfolding}
146 %************************************************************************
148 We use this to check all unfoldings that come in from interfaces
149 (it is very painful to catch errors otherwise):
152 lintUnfolding :: SrcLoc
153 -> [Var] -- Treat these as in scope
155 -> Maybe Message -- Nothing => OK
157 lintUnfolding locn vars expr
158 = initL (addLoc (ImportedUnfolding locn) $
159 addInScopeVars vars $
163 %************************************************************************
165 \subsection[lintCoreBinding]{lintCoreBinding}
167 %************************************************************************
169 Check a core binding, returning the list of variables bound.
172 lintSingleBinding rec_flag (binder,rhs)
173 = addLoc (RhsOf binder) $
176 lintCoreExpr rhs `thenL` \ ty ->
178 -- Check match to RHS type
179 lintBinder binder `seqL`
180 checkTys binder_ty ty (mkRhsMsg binder ty) `seqL`
182 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
183 checkL (not (isUnLiftedType binder_ty)
184 || (isNonRec rec_flag && exprOkForSpeculation rhs))
185 (mkRhsPrimMsg binder rhs) `seqL`
187 -- Check whether binder's specialisations contain any out-of-scope variables
188 mapL (checkBndrIdInScope binder) bndr_vars `seqL`
191 -- We should check the unfolding, if any, but this is tricky because
192 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
194 binder_ty = idType binder
195 bndr_vars = varSetElems (idFreeVars binder)
198 %************************************************************************
200 \subsection[lintCoreExpr]{lintCoreExpr}
202 %************************************************************************
205 lintCoreExpr :: CoreExpr -> LintM Type
207 lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
208 lintCoreExpr (Lit lit) = returnL (literalType lit)
210 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
211 = lintCoreExpr expr `thenL` \ expr_ty ->
213 lintTy from_ty `seqL`
214 checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
217 lintCoreExpr (Note other_note expr)
220 lintCoreExpr (Let (NonRec bndr rhs) body)
221 = lintSingleBinding NonRecursive (bndr,rhs) `seqL`
222 addLoc (BodyOfLetRec [bndr])
223 (addInScopeVars [bndr] (lintCoreExpr body))
225 lintCoreExpr (Let (Rec pairs) body)
226 = addInScopeVars bndrs $
227 mapL (lintSingleBinding Recursive) pairs `seqL`
228 addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
230 bndrs = map fst pairs
232 lintCoreExpr e@(App fun arg)
233 = lintCoreExpr fun `thenL` \ ty ->
237 lintCoreExpr (Lam var expr)
238 = addLoc (LambdaBodyOf var) $
240 checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
244 (addInScopeVars [var] $
245 lintCoreExpr expr `thenL` \ ty ->
247 returnL (mkPiType var ty))
249 lintCoreExpr e@(Case scrut var alts)
250 = -- Check the scrutinee
251 lintCoreExpr scrut `thenL` \ scrut_ty ->
254 lintBinder var `seqL`
256 -- If this is an unboxed tuple case, then the binder must be dead
258 checkL (if isUnboxedTupleType (idType var)
259 then isDeadBinder var
260 else True) (mkUnboxedTupleMsg var) `seqL`
263 checkTys (idType var) scrut_ty (mkScrutMsg var scrut_ty) `seqL`
265 addInScopeVars [var] (
267 -- Check the alternatives
268 checkCaseAlts e scrut_ty alts `seqL`
270 mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) ->
271 mapL (check alt_ty) alt_tys `seqL`
274 check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
276 lintCoreExpr e@(Type ty)
277 = addErrL (mkStrangeTyMsg e)
280 %************************************************************************
282 \subsection[lintCoreArgs]{lintCoreArgs}
284 %************************************************************************
286 The basic version of these functions checks that the argument is a
287 subtype of the required type, as one would expect.
290 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
291 lintCoreArgs = lintCoreArgs0 checkTys
293 lintCoreArg :: Type -> CoreArg -> LintM Type
294 lintCoreArg = lintCoreArg0 checkTys
297 The primitive version of these functions takes a check argument,
298 allowing a different comparison.
301 lintCoreArgs0 check_tys ty [] = returnL ty
302 lintCoreArgs0 check_tys ty (a : args)
303 = lintCoreArg0 check_tys ty a `thenL` \ res ->
304 lintCoreArgs0 check_tys res args
306 lintCoreArg0 check_tys ty a@(Type arg_ty)
307 = lintTy arg_ty `seqL`
310 lintCoreArg0 check_tys fun_ty arg
311 = -- Make sure function type matches argument
312 lintCoreExpr arg `thenL` \ arg_ty ->
314 err = mkAppMsg fun_ty arg_ty
316 case splitFunTy_maybe fun_ty of
317 Just (arg,res) -> check_tys arg arg_ty err `seqL`
324 = case splitForAllTy_maybe ty of
325 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
328 if not (isTyVar tyvar) then addErrL (mkTyAppMsg ty arg_ty) else
330 tyvar_kind = tyVarKind tyvar
331 argty_kind = typeKind arg_ty
333 if argty_kind `isSubKind` tyvar_kind
334 -- Arg type might be boxed for a function with an uncommitted
335 -- tyvar; notably this is used so that we can give
336 -- error :: forall a:*. String -> a
337 -- and then apply it to both boxed and unboxed types.
339 returnL (substTyWith [tyvar] [arg_ty] body)
341 addErrL (mkKindErrMsg tyvar arg_ty)
346 lintTyApps fun_ty (arg_ty : arg_tys)
347 = lintTyApp fun_ty arg_ty `thenL` \ fun_ty' ->
348 lintTyApps fun_ty' arg_tys
353 %************************************************************************
355 \subsection[lintCoreAlts]{lintCoreAlts}
357 %************************************************************************
360 checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
361 -- a) Check that the alts are non-empty
362 -- b) Check that the DEFAULT comes first, if it exists
363 -- c) Check that there's a default for infinite types
364 -- NB: Algebraic cases are not necessarily exhaustive, because
365 -- the simplifer correctly eliminates case that can't
368 checkCaseAlts e ty []
369 = addErrL (mkNullAltsMsg e)
371 checkCaseAlts e ty alts
372 = checkL (all non_deflt con_alts) (mkNonDefltMsg e) `seqL`
373 checkL (isJust maybe_deflt || not is_infinite_ty)
374 (nonExhaustiveAltsMsg e)
376 (con_alts, maybe_deflt) = findDefault alts
378 non_deflt (DEFAULT, _, _) = False
381 is_infinite_ty = case splitTyConApp_maybe ty of
383 Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
387 lintCoreAlt :: Type -- Type of scrutinee
389 -> LintM Type -- Type of alternatives
391 lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs)
392 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
395 lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
396 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
397 checkTys lit_ty scrut_ty
398 (mkBadPatMsg lit_ty scrut_ty) `seqL`
401 lit_ty = literalType lit
403 lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
404 = addLoc (CaseAlt alt) (
406 mapL (\arg -> checkL (not (isId arg && isUnboxedTupleType (idType arg)))
407 (mkUnboxedTupleMsg arg)) args `seqL`
409 addInScopeVars args (
412 -- Scrutinee type must be a tycon applicn; checked by caller
413 -- This code is remarkably compact considering what it does!
414 -- NB: args must be in scope here so that the lintCoreArgs line works.
415 -- NB: relies on existential type args coming *after* ordinary type args
416 case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) ->
417 lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type ->
418 lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
419 checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
426 mk_arg b | isTyVar b = Type (mkTyVarTy b)
428 | otherwise = pprPanic "lintCoreAlt:mk_arg " (ppr b)
431 %************************************************************************
433 \subsection[lint-types]{Types}
435 %************************************************************************
438 lintBinder :: Var -> LintM ()
440 -- ToDo: lint its type
441 -- ToDo: lint its rules
443 lintTy :: Type -> LintM ()
444 lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
446 -- ToDo: check the kind structure of the type
450 %************************************************************************
452 \subsection[lint-monad]{The Lint monad}
454 %************************************************************************
457 type LintM a = [LintLocInfo] -- Locations
458 -> IdSet -- Local vars in scope
459 -> Bag Message -- Error messages so far
460 -> (Maybe a, Bag Message) -- Result and error messages (if any)
463 = RhsOf Id -- The variable bound
464 | LambdaBodyOf Id -- The lambda-binder
465 | BodyOfLetRec [Id] -- One of the binders
466 | CaseAlt CoreAlt -- Pattern of a case alternative
467 | AnExpr CoreExpr -- Some expression
468 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
472 initL :: LintM a -> Maybe Message {- errors -}
474 = case m [] emptyVarSet emptyBag of
475 (_, errs) | isEmptyBag errs -> Nothing
476 | otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
478 returnL :: a -> LintM a
479 returnL r loc scope errs = (Just r, errs)
482 nopL loc scope errs = (Nothing, errs)
484 thenL :: LintM a -> (a -> LintM b) -> LintM b
485 thenL m k loc scope errs
486 = case m loc scope errs of
487 (Just r, errs') -> k r loc scope errs'
488 (Nothing, errs') -> (Nothing, errs')
490 seqL :: LintM a -> LintM b -> LintM b
491 seqL m k loc scope errs
492 = case m loc scope errs of
493 (_, errs') -> k loc scope errs'
495 mapL :: (a -> LintM b) -> [a] -> LintM [b]
496 mapL f [] = returnL []
499 mapL f xs `thenL` \ rs ->
504 checkL :: Bool -> Message -> LintM ()
505 checkL True msg = nopL
506 checkL False msg = addErrL msg
508 addErrL :: Message -> LintM a
509 addErrL msg loc scope errs = (Nothing, addErr errs msg loc)
511 addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
512 addErr errs_so_far msg locs
513 = ASSERT( notNull locs )
514 errs_so_far `snocBag` mk_msg msg
516 (loc, cxt1) = dumpLoc (head locs)
517 cxts = [snd (dumpLoc loc) | loc <- locs]
518 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
521 mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
523 addLoc :: LintLocInfo -> LintM a -> LintM a
524 addLoc extra_loc m loc scope errs
525 = m (extra_loc:loc) scope errs
527 addInScopeVars :: [Var] -> LintM a -> LintM a
528 addInScopeVars ids m loc scope errs
529 = m loc (extendVarSetList scope ids) errs
533 checkIdInScope :: Var -> LintM ()
535 = checkInScope (ptext SLIT("is out of scope")) id
537 checkBndrIdInScope :: Var -> Var -> LintM ()
538 checkBndrIdInScope binder id
539 = checkInScope msg id
541 msg = ptext SLIT("is out of scope inside info for") <+>
544 checkInScope :: SDoc -> Var -> LintM ()
545 checkInScope loc_msg var loc scope errs
546 | mustHaveLocalBinding var && not (var `elemVarSet` scope)
547 = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc)
549 = nopL loc scope errs
551 checkTys :: Type -> Type -> Message -> LintM ()
552 -- check ty2 is subtype of ty1 (ie, has same structure but usage
553 -- annotations need only be consistent, not equal)
555 | ty1 `eqType` ty2 = nopL
556 | otherwise = addErrL msg
560 %************************************************************************
562 \subsection{Error messages}
564 %************************************************************************
568 = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
570 dumpLoc (LambdaBodyOf b)
571 = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
573 dumpLoc (BodyOfLetRec [])
574 = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
576 dumpLoc (BodyOfLetRec bs@(_:_))
577 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
580 = (noSrcLoc, text "In the expression:" <+> ppr e)
582 dumpLoc (CaseAlt (con, args, rhs))
583 = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
585 dumpLoc (ImportedUnfolding locn)
586 = (locn, brackets (ptext SLIT("in an imported unfolding")))
588 pp_binders :: [Var] -> SDoc
589 pp_binders bs = sep (punctuate comma (map pp_binder bs))
591 pp_binder :: Var -> SDoc
592 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
593 | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
597 ------------------------------------------------------
598 -- Messages for case expressions
600 mkNullAltsMsg :: CoreExpr -> Message
602 = hang (text "Case expression with no alternatives:")
605 mkDefaultArgsMsg :: [Var] -> Message
606 mkDefaultArgsMsg args
607 = hang (text "DEFAULT case with binders")
610 mkCaseAltMsg :: CoreExpr -> Message
612 = hang (text "Type of case alternatives not the same:")
615 mkScrutMsg :: Id -> Type -> Message
616 mkScrutMsg var scrut_ty
617 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
618 text "Result binder type:" <+> ppr (idType var),
619 text "Scrutinee type:" <+> ppr scrut_ty]
623 = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
625 nonExhaustiveAltsMsg :: CoreExpr -> Message
626 nonExhaustiveAltsMsg e
627 = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
629 mkBadPatMsg :: Type -> Type -> Message
630 mkBadPatMsg con_result_ty scrut_ty
632 text "In a case alternative, pattern result type doesn't match scrutinee type:",
633 text "Pattern result type:" <+> ppr con_result_ty,
634 text "Scrutinee type:" <+> ppr scrut_ty
637 ------------------------------------------------------
638 -- Other error messages
640 mkAppMsg :: Type -> Type -> Message
642 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
643 hang (ptext SLIT("Fun type:")) 4 (ppr fun),
644 hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
646 mkKindErrMsg :: TyVar -> Type -> Message
647 mkKindErrMsg tyvar arg_ty
648 = vcat [ptext SLIT("Kinds don't match in type application:"),
649 hang (ptext SLIT("Type variable:"))
650 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
651 hang (ptext SLIT("Arg type:"))
652 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
654 mkTyAppMsg :: Type -> Type -> Message
656 = vcat [text "Illegal type application:",
657 hang (ptext SLIT("Exp type:"))
658 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
659 hang (ptext SLIT("Arg type:"))
660 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
662 mkRhsMsg :: Id -> Type -> Message
665 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
667 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
668 hsep [ptext SLIT("Rhs type:"), ppr ty]]
670 mkRhsPrimMsg :: Id -> CoreExpr -> Message
671 mkRhsPrimMsg binder rhs
672 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
674 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
677 mkUnboxedTupleMsg :: Id -> Message
678 mkUnboxedTupleMsg binder
679 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
680 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
682 mkCoerceErr from_ty expr_ty
683 = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
684 ptext SLIT("From-type:") <+> ppr from_ty,
685 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
689 = ptext SLIT("Type where expression expected:") <+> ppr e