2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[CoreLint]{A ``lint'' pass to check for Core correctness}
12 #include "HsVersions.h"
14 import IO ( hPutStr, stderr )
16 import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting )
20 import Kind ( hasMoreBoxityInfo, Kind{-instance-} )
21 import Literal ( literalType, Literal{-instance-} )
22 import Id ( idType, isBottomingId, dataConRepType, isDataCon, isAlgCon,
23 dataConArgTys, GenId{-instances-},
25 unionIdSets, elementOfIdSet, IdSet,
28 import Maybes ( catMaybes )
29 import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-},
33 import ErrUtils ( doIfSet, ghcExit )
34 import PrimOp ( primOpType )
35 import PrimRep ( PrimRep(..) )
36 import Specialise ( idSpecVars )
37 import SrcLoc ( SrcLoc )
38 import Type ( mkFunTy, splitFunTy_maybe, mkForAllTy,
40 isUnpointedType, typeKind, instantiateTy,
41 splitAlgTyConApp_maybe, Type
43 import TyCon ( TyCon, isPrimTyCon, isDataTyCon )
44 import TyVar ( TyVar, tyVarKind, mkTyVarEnv )
45 import ErrUtils ( ErrMsg )
46 import Unique ( Unique )
47 import Util ( zipEqual )
50 infixr 9 `thenL`, `seqL`, `thenMaybeL`
53 %************************************************************************
55 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
57 %************************************************************************
59 Checks that a set of core bindings is well-formed. The PprStyle and String
60 just control what we print in the event of an error. The Bool value
61 indicates whether we have done any specialisation yet (in which case we do
66 (b) Out-of-scope type variables
67 (c) Out-of-scope local variables
70 If we have done specialisation the we check that there are
71 (a) No top-level bindings of primitive (unboxed type)
76 -- Things are *not* OK if:
78 -- * Unsaturated type app before specialisation has been done;
80 -- * Oversaturated type app after specialisation (eta reduction
81 -- may well be happening...);
83 -- Note: checkTyApp is usually followed by a call to checkSpecTyApp.
87 lintCoreBindings :: String -> Bool -> [CoreBinding] -> IO ()
89 lintCoreBindings whoDunnit spec_done binds
90 | not opt_DoCoreLinting
93 lintCoreBindings whoDunnit spec_done binds
94 = case (initL (lint_binds binds) spec_done) of
95 Nothing -> doIfSet opt_D_show_passes
96 (hPutStr stderr ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
98 Just bad_news -> printDump (display bad_news) >>
101 lint_binds [] = returnL ()
102 lint_binds (bind:binds)
103 = lintCoreBinding bind `thenL` \binders ->
104 addInScopeVars binders (lint_binds binds)
108 text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
110 ptext SLIT("*** Offending Program ***"),
111 pprCoreBindings binds,
112 ptext SLIT("*** End of Offense ***")
116 %************************************************************************
118 \subsection[lintUnfolding]{lintUnfolding}
120 %************************************************************************
122 We use this to check all unfoldings that come in from interfaces
123 (it is very painful to catch errors otherwise):
126 lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
128 lintUnfolding locn expr
130 (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
131 True{-pretend spec done-})
135 pprTrace "WARNING: Discarded bad unfolding from interface:\n"
137 ptext SLIT("*** Bad unfolding ***"),
139 ptext SLIT("*** End unfolding ***")])
143 %************************************************************************
145 \subsection[lintCoreBinding]{lintCoreBinding}
147 %************************************************************************
149 Check a core binding, returning the list of variables bound.
152 lintCoreBinding :: CoreBinding -> LintM [Id]
154 lintCoreBinding (NonRec binder rhs)
155 = lintSingleBinding (binder,rhs) `seqL` returnL [binder]
157 lintCoreBinding (Rec pairs)
158 = addInScopeVars binders (
159 mapL lintSingleBinding pairs `seqL` returnL binders
162 binders = [b | (b,_) <- pairs]
164 lintSingleBinding (binder,rhs)
165 = addLoc (RhsOf binder) (
170 -- Check match to RHS type
172 Nothing -> returnL ()
173 Just ty -> checkTys (idType binder) ty (mkRhsMsg binder ty))
176 -- Check (not isUnpointedType)
177 checkIfSpecDoneL (not (isUnpointedType (idType binder)))
178 (mkRhsPrimMsg binder rhs) `seqL`
180 -- Check whether binder's specialisations contain any out-of-scope variables
181 ifSpecDoneL (mapL (checkSpecIdInScope binder) spec_vars `seqL` returnL ())
183 -- We should check the unfolding, if any, but this is tricky because
184 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
187 spec_vars = idSpecVars binder
191 %************************************************************************
193 \subsection[lintCoreExpr]{lintCoreExpr}
195 %************************************************************************
198 lintCoreExpr :: CoreExpr -> LintM (Maybe Type) -- Nothing if error found
200 lintCoreExpr (Var var)
201 | isAlgCon var = returnL (Just (idType var))
202 -- Micro-hack here... Class decls generate applications of their
203 -- dictionary constructor, but don't generate a binding for the
204 -- constructor (since it would never be used). After a single round
205 -- of simplification, these dictionary constructors have been
206 -- inlined (from their UnfoldInfo) to CoCons. Just between
207 -- desugaring and simplfication, though, they appear as naked, unbound
208 -- variables as the function in an application.
209 -- The hack here simply doesn't check for out-of-scope-ness for
210 -- data constructors (at least, in a function position).
212 | otherwise = checkIdInScope var `seqL` returnL (Just (idType var))
214 lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
216 lintCoreExpr (Note (Coerce to_ty from_ty) expr)
217 = lintCoreExpr expr `thenMaybeL` \ expr_ty ->
219 lintTy from_ty `seqL`
220 checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
223 lintCoreExpr (Note other_note expr)
226 lintCoreExpr (Let binds body)
227 = lintCoreBinding binds `thenL` \binders ->
228 if (null binders) then
229 lintCoreExpr body -- Can't add a new source location
231 addLoc (BodyOfLetRec binders)
232 (addInScopeVars binders (lintCoreExpr body))
234 lintCoreExpr e@(Con con args)
235 = checkL (isDataCon con) (mkConErrMsg e) `seqL`
236 lintCoreArgs {-False-} e (dataConRepType con) args
237 -- Note: we don't check for primitive types in these arguments
239 lintCoreExpr e@(Prim op args)
240 = lintCoreArgs {-True-} e (primOpType op) args
241 -- Note: we do check for primitive types in these arguments
243 lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
244 = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg {-False-} e ty arg
245 -- Note: we don't check for primitive types in argument to 'error'
247 lintCoreExpr e@(App fun arg)
248 = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg {-True-} e ty arg
249 -- Note: we do check for primitive types in this argument
251 lintCoreExpr (Lam (ValBinder var) expr)
252 = addLoc (LambdaBodyOf var)
253 (addInScopeVars [var]
254 (lintCoreExpr expr `thenMaybeL` \ty ->
255 returnL (Just (mkFunTy (idType var) ty))))
257 lintCoreExpr (Lam (TyBinder tyvar) expr)
258 = lintCoreExpr expr `thenMaybeL` \ty ->
259 returnL (Just(mkForAllTy tyvar ty))
260 -- ToDo: Should add in-scope type variable at this point
262 lintCoreExpr e@(Case scrut alts)
263 = lintCoreExpr scrut `thenMaybeL` \ty ->
267 %************************************************************************
269 \subsection[lintCoreArgs]{lintCoreArgs}
271 %************************************************************************
273 The boolean argument indicates whether we should flag type
274 applications to primitive types as being errors.
277 lintCoreArgs :: {-Bool ->-} CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
279 lintCoreArgs _ ty [] = returnL (Just ty)
280 lintCoreArgs e ty (a : args)
281 = lintCoreArg e ty a `thenMaybeL` \ res ->
282 lintCoreArgs e res args
285 %************************************************************************
287 \subsection[lintCoreArg]{lintCoreArg}
289 %************************************************************************
292 lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
294 lintCoreArg e ty (LitArg lit)
295 = -- Make sure function type matches argument
296 case (splitFunTy_maybe ty) of
297 Just (arg,res) | (lit_ty == arg) -> returnL(Just res)
298 _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing
300 lit_ty = literalType lit
302 lintCoreArg e ty (VarArg v)
303 = -- Make sure variable is bound
304 checkIdInScope v `seqL`
305 -- Make sure function type matches argument
306 case (splitFunTy_maybe ty) of
307 Just (arg,res) | (var_ty == arg) -> returnL(Just res)
308 _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing
312 lintCoreArg e ty a@(TyArg arg_ty)
313 = lintTy arg_ty `seqL`
315 case (splitForAllTy_maybe ty) of
316 Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
320 tyvar_kind = tyVarKind tyvar
321 argty_kind = typeKind arg_ty
323 if argty_kind `hasMoreBoxityInfo` tyvar_kind
324 -- Arg type might be boxed for a function with an uncommitted
325 -- tyvar; notably this is used so that we can give
326 -- error :: forall a:*. String -> a
327 -- and then apply it to both boxed and unboxed types.
329 returnL(Just(instantiateTy (mkTyVarEnv [(tyvar,arg_ty)]) body))
331 pprTrace "lintCoreArg:kinds:" (hsep [ppr tyvar_kind, ppr argty_kind]) $
332 addErrL (mkKindErrMsg tyvar arg_ty e) `seqL` returnL Nothing
335 %************************************************************************
337 \subsection[lintCoreAlts]{lintCoreAlts}
339 %************************************************************************
342 lintCoreAlts :: CoreCaseAlts
343 -> Type -- Type of scrutinee
344 -- -> TyCon -- TyCon pinned on the case
345 -> LintM (Maybe Type) -- Type of alternatives
347 lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon
348 = -- Check tycon is not a primitive tycon
349 -- addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
351 -- Check we are scrutinising a proper datatype
353 -- addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
356 `thenL` \maybe_deflt_ty ->
357 mapL (lintAlgAlt ty {-tycon-}) alts
358 `thenL` \maybe_alt_tys ->
359 -- Check the result types
360 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
361 [] -> returnL Nothing
363 (first_ty:tys) -> mapL check tys `seqL`
364 returnL (Just first_ty)
366 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
368 lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
369 = -- Check tycon is a primitive tycon
370 -- addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
372 mapL (lintPrimAlt ty) alts
373 `thenL` \maybe_alt_tys ->
375 `thenL` \maybe_deflt_ty ->
376 -- Check the result types
377 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
378 [] -> returnL Nothing
380 (first_ty:tys) -> mapL check tys `seqL`
381 returnL (Just first_ty)
383 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
385 lintAlgAlt scrut_ty (con,args,rhs)
386 = (case splitAlgTyConApp_maybe scrut_ty of
387 Just (tycon, tys_applied, cons) | isDataTyCon tycon ->
389 arg_tys = dataConArgTys con tys_applied
391 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
392 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
394 mapL check (zipEqual "lintAlgAlt" arg_tys args) `seqL`
397 other -> addErrL (mkAlgAltMsg1 scrut_ty)
399 addInScopeVars args (
403 check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
405 -- elem: yes, the elem-list here can sometimes be long-ish,
406 -- but as it's use-once, probably not worth doing anything different
407 -- We give it its own copy, so it isn't overloaded.
409 elem x (y:ys) = x==y || elem x ys
411 lintPrimAlt ty alt@(lit,rhs)
412 = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
415 lintDeflt NoDefault _ = returnL Nothing
416 lintDeflt deflt@(BindDefault binder rhs) ty
417 = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
418 addInScopeVars [binder] (lintCoreExpr rhs)
421 %************************************************************************
423 \subsection[lint-types]{Types}
425 %************************************************************************
428 lintTy :: Type -> LintM ()
429 lintTy ty = returnL ()
430 -- ToDo: Check that ty is well-kinded and has no unbound tyvars
434 %************************************************************************
436 \subsection[lint-monad]{The Lint monad}
438 %************************************************************************
441 type LintM a = Bool -- True <=> specialisation has been done
442 -> [LintLocInfo] -- Locations
443 -> IdSet -- Local vars in scope
444 -> Bag ErrMsg -- Error messages so far
445 -> (a, Bag ErrMsg) -- Result and error messages (if any)
448 = RhsOf Id -- The variable bound
449 | LambdaBodyOf Id -- The lambda-binder
450 | BodyOfLetRec [Id] -- One of the binders
451 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
453 instance Outputable LintLocInfo where
455 = ppr (getSrcLoc v) <> colon <+>
456 brackets (ptext SLIT("RHS of") <+> pp_binders [v])
459 = ppr (getSrcLoc b) <> colon <+>
460 brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b)
462 ppr (BodyOfLetRec bs)
463 = ppr (getSrcLoc (head bs)) <> colon <+>
464 brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs)
466 ppr (ImportedUnfolding locn)
467 = ppr locn <> colon <+>
468 brackets (ptext SLIT("in an imported unfolding"))
470 pp_binders :: [Id] -> SDoc
471 pp_binders bs = sep (punctuate comma (map pp_binder bs))
473 pp_binder :: Id -> SDoc
474 pp_binder b = hsep [ppr b, text "::", ppr (idType b)]
478 initL :: LintM a -> Bool -> Maybe ErrMsg
480 = case (m spec_done [] emptyIdSet emptyBag) of { (_, errs) ->
481 if isEmptyBag errs then
484 Just (vcat (bagToList errs))
487 returnL :: a -> LintM a
488 returnL r spec loc scope errs = (r, errs)
490 thenL :: LintM a -> (a -> LintM b) -> LintM b
491 thenL m k spec loc scope errs
492 = case m spec loc scope errs of
493 (r, errs') -> k r spec loc scope errs'
495 seqL :: LintM a -> LintM b -> LintM b
496 seqL m k spec loc scope errs
497 = case m spec loc scope errs of
498 (_, errs') -> k spec loc scope errs'
500 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
501 thenMaybeL m k spec loc scope errs
502 = case m spec loc scope errs of
503 (Nothing, errs2) -> (Nothing, errs2)
504 (Just r, errs2) -> k r spec loc scope errs2
506 mapL :: (a -> LintM b) -> [a] -> LintM [b]
507 mapL f [] = returnL []
510 mapL f xs `thenL` \ rs ->
513 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
514 -- Returns Nothing if anything fails
515 mapMaybeL f [] = returnL (Just [])
517 = f x `thenMaybeL` \ r ->
518 mapMaybeL f xs `thenMaybeL` \ rs ->
519 returnL (Just (r:rs))
523 checkL :: Bool -> ErrMsg -> LintM ()
524 checkL True msg spec loc scope errs = ((), errs)
525 checkL False msg spec loc scope errs = ((), addErr errs msg loc)
527 checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
528 checkIfSpecDoneL True msg spec loc scope errs = ((), errs)
529 checkIfSpecDoneL False msg True loc scope errs = ((), addErr errs msg loc)
530 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
532 ifSpecDoneL :: LintM () -> LintM ()
533 ifSpecDoneL m False loc scope errs = ((), errs)
534 ifSpecDoneL m True loc scope errs = m True loc scope errs
536 addErrL :: ErrMsg -> LintM ()
537 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
539 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
541 addErr errs_so_far msg locs
542 = ASSERT (not (null locs))
543 errs_so_far `snocBag` (hang (ppr (head locs)) 4 msg)
545 addLoc :: LintLocInfo -> LintM a -> LintM a
546 addLoc extra_loc m spec loc scope errs
547 = m spec (extra_loc:loc) scope errs
549 addInScopeVars :: [Id] -> LintM a -> LintM a
550 addInScopeVars ids m spec loc scope errs
551 = -- We check if these "new" ids are already
552 -- in scope, i.e., we have *shadowing* going on.
553 -- For now, it's just a "trace"; we may make
554 -- a real error out of it...
556 new_set = mkIdSet ids
558 -- shadowed = scope `intersectIdSets` new_set
560 -- After adding -fliberate-case, Simon decided he likes shadowed
561 -- names after all. WDP 94/07
562 -- (if isEmptyUniqSet shadowed
564 -- else pprTrace "Shadowed vars:" (ppr (uniqSetToList shadowed))) (
565 m spec loc (scope `unionIdSets` new_set) errs
570 checkIdInScope :: Id -> LintM ()
572 = checkInScope (ptext SLIT("is out of scope")) id
574 checkSpecIdInScope :: Id -> Id -> LintM ()
575 checkSpecIdInScope binder id
576 = checkInScope msg id
578 msg = ptext SLIT("is out of scope inside specialisation info for") <+>
581 checkInScope :: SDoc -> Id -> LintM ()
582 checkInScope loc_msg id spec loc scope errs
586 if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then
587 ((), addErr errs (hsep [ppr id, loc_msg]) loc)
591 checkTys :: Type -> Type -> ErrMsg -> LintM ()
592 checkTys ty1 ty2 msg spec loc scope errs
593 = if ty1 == ty2 then ((), errs) else ((), addErr errs msg loc)
598 = ($$) (ptext SLIT("Application of newtype constructor:"))
602 mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
604 = ($$) (ptext SLIT("Type of case alternatives not the same:"))
607 mkCaseAbstractMsg :: TyCon -> ErrMsg
608 mkCaseAbstractMsg tycon
609 = ($$) (ptext SLIT("An algebraic case on some weird type:"))
612 mkDefltMsg :: CoreCaseDefault -> ErrMsg
614 = ($$) (ptext SLIT("Binder in case default doesn't match type of scrutinee:"))
617 mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
618 mkAppMsg fun arg expr
619 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
620 hang (ptext SLIT("Fun type:")) 4 (ppr fun),
621 hang (ptext SLIT("Arg type:")) 4 (ppr arg),
622 hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)]
624 mkKindErrMsg :: TyVar -> Type -> CoreExpr -> ErrMsg
625 mkKindErrMsg tyvar arg_ty expr
626 = vcat [ptext SLIT("Kinds don't match in type application:"),
627 hang (ptext SLIT("Type variable:"))
628 4 (ppr tyvar <+> ptext SLIT("::") <+> ppr (tyVarKind tyvar)),
629 hang (ptext SLIT("Arg type:"))
630 4 (ppr arg_ty <+> ptext SLIT("::") <+> ppr (typeKind arg_ty)),
631 hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)]
633 mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg
634 mkTyAppMsg msg ty arg expr
635 = vcat [hsep [ptext msg, ptext SLIT("type application:")],
636 hang (ptext SLIT("Exp type:"))
637 4 (ppr ty <+> ptext SLIT("::") <+> ppr (typeKind ty)),
638 hang (ptext SLIT("Arg type:"))
639 4 (ppr arg <+> ptext SLIT("::") <+> ppr (typeKind arg)),
640 hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)]
642 mkAlgAltMsg1 :: Type -> ErrMsg
644 = ($$) (text "In some case statement, type of scrutinee is not a data type:")
647 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
650 text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
655 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
656 mkAlgAltMsg3 con alts
658 text "In some algebraic case alternative, number of arguments doesn't match constructor:",
663 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
666 text "In some algebraic case alternative, type of argument doesn't match data constructor:",
671 mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
674 (text "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
677 mkRhsMsg :: Id -> Type -> ErrMsg
680 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
682 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
683 hsep [ptext SLIT("Rhs type:"), ppr ty]]
685 mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
686 mkRhsPrimMsg binder rhs
687 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
689 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
692 mkCoerceErr from_ty expr_ty
693 = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
694 ptext SLIT("From-type:") <+> ppr from_ty,
695 ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty