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, stderr, stdout )
17 import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug )
19 import CoreFVs ( idFreeVars )
20 import CoreUtils ( exprOkForSpeculation, coreBindsSize )
23 import Literal ( Literal, literalType )
24 import DataCon ( DataCon, dataConRepType )
25 import Id ( mayHaveNoBinding, isDeadBinder )
26 import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId )
28 import Subst ( mkTyVarSubst, substTy )
29 import Name ( isLocallyDefined, getSrcLoc )
31 import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message,
32 ErrMsg, addErrLocHdrLine, pprBagOfErrors )
33 import PrimRep ( PrimRep(..) )
34 import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc )
35 import Type ( Type, Kind, tyVarsOfType,
36 splitFunTy_maybe, mkPiType, mkTyVarTy, unUsgTy,
37 splitForAllTy_maybe, splitTyConApp_maybe,
38 isUnLiftedType, typeKind,
39 splitAlgTyConApp_maybe,
43 import PprType ( {- instance Outputable Type -} )
44 import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
45 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 :: String -> IO ()
65 = hPutStrLn stderr ("*** " ++ pass_name)
70 endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind]
71 endPass pass_name dump_flag binds
73 -- Report result size if required
74 -- This has the side effect of forcing the intermediate to be evaluated
75 if opt_D_show_passes then
76 hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds))
80 -- Report verbosely, if required
81 dumpIfSet dump_flag pass_name
82 (pprCoreBindings binds)
85 lintCoreBindings pass_name binds
91 %************************************************************************
93 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
95 %************************************************************************
97 Checks that a set of core bindings is well-formed. The PprStyle and String
98 just control what we print in the event of an error. The Bool value
99 indicates whether we have done any specialisation yet (in which case we do
104 (b) Out-of-scope type variables
105 (c) Out-of-scope local variables
108 If we have done specialisation the we check that there are
109 (a) No top-level bindings of primitive (unboxed type)
114 -- Things are *not* OK if:
116 -- * Unsaturated type app before specialisation has been done;
118 -- * Oversaturated type app after specialisation (eta reduction
119 -- may well be happening...);
122 lintCoreBindings :: String -> [CoreBind] -> IO ()
124 lintCoreBindings whoDunnit binds
125 | not opt_DoCoreLinting
128 lintCoreBindings whoDunnit binds
129 = case (initL (lint_binds binds)) of
130 Nothing -> doIfSet opt_D_show_passes
131 (hPutStr stderr ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
133 Just bad_news -> printDump (display bad_news) >>
136 -- Put all the top-level binders in scope at the start
137 -- This is because transformation rules can bring something
138 -- into use 'unexpectedly'
139 lint_binds binds = addInScopeVars (bindersOfBinds binds) $
142 lint_bind (Rec prs) = mapL (lintSingleBinding Recursive) prs `seqL`
144 lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
148 text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
150 ptext SLIT("*** Offending Program ***"),
151 pprCoreBindings binds,
152 ptext SLIT("*** End of Offense ***")
156 %************************************************************************
158 \subsection[lintUnfolding]{lintUnfolding}
160 %************************************************************************
162 We use this to check all unfoldings that come in from interfaces
163 (it is very painful to catch errors otherwise):
166 lintUnfolding :: SrcLoc
167 -> [Var] -- Treat these as in scope
169 -> Maybe Message -- Nothing => OK
171 lintUnfolding locn vars expr
172 | not opt_DoCoreLinting
176 = initL (addLoc (ImportedUnfolding locn) $
177 addInScopeVars vars $
181 %************************************************************************
183 \subsection[lintCoreBinding]{lintCoreBinding}
185 %************************************************************************
187 Check a core binding, returning the list of variables bound.
190 lintSingleBinding rec_flag (binder,rhs)
191 = addLoc (RhsOf binder) $
194 lintCoreExpr rhs `thenL` \ ty ->
196 -- Check match to RHS type
197 lintBinder binder `seqL`
198 checkTys binder_ty ty (mkRhsMsg binder ty) `seqL`
200 -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
201 checkL (not (isUnLiftedType binder_ty) || (isNonRec rec_flag && exprOkForSpeculation rhs))
202 (mkRhsPrimMsg binder rhs) `seqL`
204 -- Check whether binder's specialisations contain any out-of-scope variables
205 mapL (checkBndrIdInScope binder) bndr_vars `seqL`
208 -- We should check the unfolding, if any, but this is tricky because
209 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
211 binder_ty = idType binder
212 bndr_vars = varSetElems (idFreeVars binder)
215 %************************************************************************
217 \subsection[lintCoreExpr]{lintCoreExpr}
219 %************************************************************************
222 lintCoreExpr :: CoreExpr -> LintM Type
224 lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
225 lintCoreExpr (Lit lit) = returnL (literalType lit)
227 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
228 = lintCoreExpr expr `thenL` \ expr_ty ->
230 lintTy from_ty `seqL`
231 checkTys from_ty (unUsgTy expr_ty) (mkCoerceErr from_ty expr_ty) `seqL`
234 lintCoreExpr (Note other_note expr)
237 lintCoreExpr (Let (NonRec bndr rhs) body)
238 = lintSingleBinding NonRecursive (bndr,rhs) `seqL`
239 addLoc (BodyOfLetRec [bndr])
240 (addInScopeVars [bndr] (lintCoreExpr body))
242 lintCoreExpr (Let (Rec pairs) body)
243 = addInScopeVars bndrs $
244 mapL (lintSingleBinding Recursive) pairs `seqL`
245 addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
247 bndrs = map fst pairs
249 lintCoreExpr e@(App fun arg)
250 = lintCoreExpr fun `thenL` \ ty ->
254 lintCoreExpr (Lam var expr)
255 = addLoc (LambdaBodyOf var) $
256 checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
258 (addInScopeVars [var] $
259 lintCoreExpr expr `thenL` \ ty ->
260 returnL (mkPiType var ty))
262 lintCoreExpr e@(Case scrut var alts)
263 = -- Check the scrutinee
264 lintCoreExpr scrut `thenL` \ scrut_ty ->
267 lintBinder var `seqL`
269 -- If this is an unboxed tuple case, then the binder must be dead
271 checkL (if isUnboxedTupleType (idType var)
272 then isDeadBinder var
273 else True) (mkUnboxedTupleMsg var) `seqL`
276 checkTys (idType var) scrut_ty (mkScrutMsg var scrut_ty) `seqL`
278 addInScopeVars [var] (
280 -- Check the alternatives
281 checkAllCasesCovered e scrut_ty alts `seqL`
282 mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) ->
283 mapL (check alt_ty) alt_tys `seqL`
286 check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
288 lintCoreExpr e@(Type ty)
289 = addErrL (mkStrangeTyMsg e)
292 %************************************************************************
294 \subsection[lintCoreArgs]{lintCoreArgs}
296 %************************************************************************
298 The boolean argument indicates whether we should flag type
299 applications to primitive types as being errors.
302 lintCoreArgs :: Type -> [CoreArg] -> LintM Type
304 lintCoreArgs ty [] = returnL ty
305 lintCoreArgs ty (a : args)
306 = lintCoreArg ty a `thenL` \ res ->
307 lintCoreArgs res args
311 lintCoreArg :: Type -> CoreArg -> LintM Type
313 lintCoreArg ty a@(Type arg_ty)
314 = lintTy arg_ty `seqL`
317 lintCoreArg fun_ty arg
318 = -- Make sure function type matches argument
319 lintCoreExpr arg `thenL` \ arg_ty ->
320 case (splitFunTy_maybe fun_ty) of
321 Just (arg,res) | (arg_ty == arg) -> returnL res
322 _ -> addErrL (mkAppMsg fun_ty arg_ty)
327 = case splitForAllTy_maybe ty of
328 Nothing -> addErrL (mkTyAppMsg ty arg_ty)
332 tyvar_kind = tyVarKind tyvar
333 argty_kind = typeKind arg_ty
335 if argty_kind `hasMoreBoxityInfo` tyvar_kind
336 -- Arg type might be boxed for a function with an uncommitted
337 -- tyvar; notably this is used so that we can give
338 -- error :: forall a:*. String -> a
339 -- and then apply it to both boxed and unboxed types.
341 returnL (substTy (mkTyVarSubst [tyvar] [arg_ty]) body)
343 addErrL (mkKindErrMsg tyvar arg_ty)
348 lintTyApps fun_ty (arg_ty : arg_tys)
349 = lintTyApp fun_ty arg_ty `thenL` \ fun_ty' ->
350 lintTyApps fun_ty' arg_tys
355 %************************************************************************
357 \subsection[lintCoreAlts]{lintCoreAlts}
359 %************************************************************************
362 checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e)
364 checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL
366 checkAllCasesCovered e scrut_ty alts
367 = case splitTyConApp_maybe scrut_ty of {
368 Nothing -> addErrL (badAltsMsg e);
369 Just (tycon, tycon_arg_tys) ->
371 if isPrimTyCon tycon then
372 checkL (hasDefault alts) (nonExhaustiveAltsMsg e)
376 -- Algebraic cases are not necessarily exhaustive, because
377 -- the simplifer correctly eliminates case that can't
379 -- This code just emits a message to say so
381 missing_cons = filter not_in_alts (tyConDataCons tycon)
382 not_in_alts con = all (not_in_alt con) alts
383 not_in_alt con (DataCon con', _, _) = con /= con'
384 not_in_alt con other = True
386 case_bndr = case e of { Case _ bndr alts -> bndr }
388 if not (hasDefault alts || null missing_cons) then
389 pprTrace "Exciting (but not a problem)! Non-exhaustive case:"
390 (ppr case_bndr <+> ppr missing_cons)
397 hasDefault [] = False
398 hasDefault ((DEFAULT,_,_) : alts) = True
399 hasDefault (alt : alts) = hasDefault alts
403 lintCoreAlt :: Type -- Type of scrutinee
405 -> LintM Type -- Type of alternatives
407 lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs)
408 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
411 lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
412 = checkL (null args) (mkDefaultArgsMsg args) `seqL`
413 checkTys lit_ty scrut_ty
414 (mkBadPatMsg lit_ty scrut_ty) `seqL`
417 lit_ty = literalType lit
419 lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
420 = addLoc (CaseAlt alt) (
422 mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
423 (mkUnboxedTupleMsg arg)) args `seqL`
425 addInScopeVars args (
428 -- Scrutinee type must be a tycon applicn; checked by caller
429 -- This code is remarkably compact considering what it does!
430 -- NB: args must be in scope here so that the lintCoreArgs line works.
431 case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) ->
432 lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type ->
433 lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
434 checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
441 mk_arg b | isTyVar b = Type (mkTyVarTy b)
445 %************************************************************************
447 \subsection[lint-types]{Types}
449 %************************************************************************
452 lintBinder :: Var -> LintM ()
454 -- ToDo: lint its type
456 lintTy :: Type -> LintM ()
457 lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
459 -- ToDo: check the kind structure of the type
463 %************************************************************************
465 \subsection[lint-monad]{The Lint monad}
467 %************************************************************************
470 type LintM a = [LintLocInfo] -- Locations
471 -> IdSet -- Local vars in scope
472 -> Bag ErrMsg -- Error messages so far
473 -> (Maybe a, Bag ErrMsg) -- Result and error messages (if any)
476 = RhsOf Id -- The variable bound
477 | LambdaBodyOf Id -- The lambda-binder
478 | BodyOfLetRec [Id] -- One of the binders
479 | CaseAlt CoreAlt -- Pattern of a case alternative
480 | AnExpr CoreExpr -- Some expression
481 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
485 initL :: LintM a -> Maybe Message
487 = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
488 if isEmptyBag errs then
491 Just (pprBagOfErrors errs)
494 returnL :: a -> LintM a
495 returnL r loc scope errs = (Just r, errs)
498 nopL loc scope errs = (Nothing, errs)
500 thenL :: LintM a -> (a -> LintM b) -> LintM b
501 thenL m k loc scope errs
502 = case m loc scope errs of
503 (Just r, errs') -> k r loc scope errs'
504 (Nothing, errs') -> (Nothing, errs')
506 seqL :: LintM a -> LintM b -> LintM b
507 seqL m k loc scope errs
508 = case m loc scope errs of
509 (_, errs') -> k loc scope errs'
511 mapL :: (a -> LintM b) -> [a] -> LintM [b]
512 mapL f [] = returnL []
515 mapL f xs `thenL` \ rs ->
520 checkL :: Bool -> Message -> LintM ()
521 checkL True msg loc scope errs = (Nothing, errs)
522 checkL False msg loc scope errs = (Nothing, addErr errs msg loc)
524 addErrL :: Message -> LintM a
525 addErrL msg loc scope errs = (Nothing, addErr errs msg loc)
527 addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
529 addErr errs_so_far msg locs
530 = ASSERT (not (null locs))
531 errs_so_far `snocBag` mk_msg msg
533 (loc, cxt1) = dumpLoc (head locs)
534 cxts = [snd (dumpLoc loc) | loc <- locs]
535 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
539 | isNoSrcLoc loc = (loc, hang context 4 msg)
540 | otherwise = addErrLocHdrLine loc context msg
542 addLoc :: LintLocInfo -> LintM a -> LintM a
543 addLoc extra_loc m loc scope errs
544 = m (extra_loc:loc) scope errs
546 addInScopeVars :: [Var] -> LintM a -> LintM a
547 addInScopeVars ids m loc scope errs
548 = m loc (scope `unionVarSet` mkVarSet ids) errs
552 checkIdInScope :: Var -> LintM ()
554 = checkInScope (ptext SLIT("is out of scope")) id
556 checkBndrIdInScope :: Var -> Var -> LintM ()
557 checkBndrIdInScope binder id
558 = checkInScope msg id
560 msg = ptext SLIT("is out of scope inside info for") <+>
563 checkInScope :: SDoc -> Var -> LintM ()
564 checkInScope loc_msg var loc scope errs
565 | isLocallyDefined var
566 && not (var `elemVarSet` scope)
567 && not (isId var && mayHaveNoBinding var)
568 -- Micro-hack here... Class decls generate applications of their
569 -- dictionary constructor, but don't generate a binding for the
570 -- constructor (since it would never be used). After a single round
571 -- of simplification, these dictionary constructors have been
572 -- inlined (from their UnfoldInfo) to CoCons. Just between
573 -- desugaring and simplfication, though, they appear as naked, unbound
574 -- variables as the function in an application.
575 -- The hack here simply doesn't check for out-of-scope-ness for
576 -- data constructors (at least, in a function position).
577 -- Ditto primitive Ids
578 = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc)
582 checkTys :: Type -> Type -> Message -> LintM ()
583 checkTys ty1 ty2 msg loc scope errs
584 | ty1 == ty2 = (Nothing, errs)
585 | otherwise = (Nothing, addErr errs msg loc)
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 bs)
603 = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
606 = (noSrcLoc, text "In the expression:" <+> ppr e)
608 dumpLoc (CaseAlt (con, args, rhs))
609 = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
611 dumpLoc (ImportedUnfolding locn)
612 = (locn, brackets (ptext SLIT("in an imported unfolding")))
614 pp_binders :: [Id] -> SDoc
615 pp_binders bs = sep (punctuate comma (map pp_binder bs))
617 pp_binder :: Id -> SDoc
618 pp_binder b = hsep [ppr b, dcolon, ppr (idType b)]
622 ------------------------------------------------------
623 -- Messages for case expressions
625 mkNullAltsMsg :: CoreExpr -> Message
627 = hang (text "Case expression with no alternatives:")
630 mkDefaultArgsMsg :: [Var] -> Message
631 mkDefaultArgsMsg args
632 = hang (text "DEFAULT case with binders")
635 mkCaseAltMsg :: CoreExpr -> Message
637 = hang (text "Type of case alternatives not the same:")
640 mkScrutMsg :: Id -> Type -> Message
641 mkScrutMsg var scrut_ty
642 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
643 text "Result binder type:" <+> ppr (idType var),
644 text "Scrutinee type:" <+> ppr scrut_ty]
646 badAltsMsg :: CoreExpr -> Message
648 = hang (text "Case statement scrutinee is not a data type:")
651 nonExhaustiveAltsMsg :: CoreExpr -> Message
652 nonExhaustiveAltsMsg e
653 = hang (text "Case expression with non-exhaustive alternatives")
656 mkBadPatMsg :: Type -> Type -> Message
657 mkBadPatMsg con_result_ty scrut_ty
659 text "In a case alternative, pattern result type doesn't match scrutinee type:",
660 text "Pattern result type:" <+> ppr con_result_ty,
661 text "Scrutinee type:" <+> ppr scrut_ty
664 ------------------------------------------------------
665 -- Other error messages
668 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
669 hang (ptext SLIT("Fun type:")) 4 (ppr fun),
670 hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
672 mkKindErrMsg :: TyVar -> Type -> Message
673 mkKindErrMsg tyvar arg_ty
674 = vcat [ptext SLIT("Kinds don't match in type application:"),
675 hang (ptext SLIT("Type variable:"))
676 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
677 hang (ptext SLIT("Arg type:"))
678 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
680 mkTyAppMsg :: Type -> Type -> Message
682 = vcat [text "Illegal type application:",
683 hang (ptext SLIT("Exp type:"))
684 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
685 hang (ptext SLIT("Arg type:"))
686 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
688 mkRhsMsg :: Id -> Type -> Message
691 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
693 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
694 hsep [ptext SLIT("Rhs type:"), ppr ty]]
696 mkRhsPrimMsg :: Id -> CoreExpr -> Message
697 mkRhsPrimMsg binder rhs
698 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
700 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
703 mkUnboxedTupleMsg :: Id -> Message
704 mkUnboxedTupleMsg binder
705 = vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
706 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
708 mkCoerceErr from_ty expr_ty
709 = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
710 ptext SLIT("From-type:") <+> ppr from_ty,
711 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
715 = ptext SLIT("Type where expression expected:") <+> ppr e