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, isNewCon, isAlgCon,
23 dataConArgTys, GenId{-instances-},
25 unionIdSets, elementOfIdSet, IdSet,
28 import Maybes ( catMaybes )
29 import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-},
32 import ErrUtils ( doIfSet, ghcExit )
33 import PprType ( GenType, GenTyVar, TyCon )
34 import PrimOp ( primOpType )
35 import PrimRep ( PrimRep(..) )
36 import SrcLoc ( SrcLoc )
37 import Type ( mkFunTy, splitFunTy_maybe, mkForAllTy,
39 isUnpointedType, typeKind, instantiateTy,
40 splitAlgTyConApp_maybe, Type
42 import TyCon ( isPrimTyCon, isDataTyCon )
43 import TyVar ( TyVar, tyVarKind, mkTyVarEnv )
44 import ErrUtils ( ErrMsg )
45 import Unique ( Unique )
46 import Util ( zipEqual )
49 infixr 9 `thenL`, `seqL`, `thenMaybeL`
52 %************************************************************************
54 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
56 %************************************************************************
58 Checks that a set of core bindings is well-formed. The PprStyle and String
59 just control what we print in the event of an error. The Bool value
60 indicates whether we have done any specialisation yet (in which case we do
65 (b) Out-of-scope type variables
66 (c) Out-of-scope local variables
69 If we have done specialisation the we check that there are
70 (a) No top-level bindings of primitive (unboxed type)
75 -- Things are *not* OK if:
77 -- * Unsaturated type app before specialisation has been done;
79 -- * Oversaturated type app after specialisation (eta reduction
80 -- may well be happening...);
82 -- Note: checkTyApp is usually followed by a call to checkSpecTyApp.
86 lintCoreBindings :: String -> Bool -> [CoreBinding] -> IO ()
88 lintCoreBindings whoDunnit spec_done binds
89 | not opt_DoCoreLinting
92 lintCoreBindings whoDunnit spec_done binds
93 = case (initL (lint_binds binds) spec_done) of
94 Nothing -> doIfSet opt_D_show_passes
95 (hPutStr stderr ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
97 Just bad_news -> printDump (display bad_news) >>
100 lint_binds [] = returnL ()
101 lint_binds (bind:binds)
102 = lintCoreBinding bind `thenL` \binders ->
103 addInScopeVars binders (lint_binds binds)
107 text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
109 ptext SLIT("*** Offending Program ***"),
110 pprCoreBindings binds,
111 ptext SLIT("*** End of Offense ***")
115 %************************************************************************
117 \subsection[lintUnfolding]{lintUnfolding}
119 %************************************************************************
121 We use this to check all unfoldings that come in from interfaces
122 (it is very painful to catch errors otherwise):
125 lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
127 lintUnfolding locn expr
129 (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
130 True{-pretend spec done-})
134 pprTrace "WARNING: Discarded bad unfolding from interface:\n"
136 ptext SLIT("*** Bad unfolding ***"),
138 ptext SLIT("*** End unfolding ***")])
142 %************************************************************************
144 \subsection[lintCoreBinding]{lintCoreBinding}
146 %************************************************************************
148 Check a core binding, returning the list of variables bound.
151 lintCoreBinding :: CoreBinding -> LintM [Id]
153 lintCoreBinding (NonRec binder rhs)
154 = lintSingleBinding (binder,rhs) `seqL` returnL [binder]
156 lintCoreBinding (Rec pairs)
157 = addInScopeVars binders (
158 mapL lintSingleBinding pairs `seqL` returnL binders
161 binders = [b | (b,_) <- pairs]
163 lintSingleBinding (binder,rhs)
164 = addLoc (RhsOf binder) (
169 -- Check match to RHS type
171 Nothing -> returnL ()
172 Just ty -> checkTys (idType binder) ty (mkRhsMsg binder ty))
175 -- Check (not isUnpointedType)
176 checkIfSpecDoneL (not (isUnpointedType (idType binder)))
177 (mkRhsPrimMsg binder rhs)
179 -- We should check the unfolding, if any, but this is tricky because
180 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
184 %************************************************************************
186 \subsection[lintCoreExpr]{lintCoreExpr}
188 %************************************************************************
191 lintCoreExpr :: CoreExpr -> LintM (Maybe Type) -- Nothing if error found
193 lintCoreExpr (Var var)
194 | isAlgCon var = returnL (Just (idType var))
195 -- Micro-hack here... Class decls generate applications of their
196 -- dictionary constructor, but don't generate a binding for the
197 -- constructor (since it would never be used). After a single round
198 -- of simplification, these dictionary constructors have been
199 -- inlined (from their UnfoldInfo) to CoCons. Just between
200 -- desugaring and simplfication, though, they appear as naked, unbound
201 -- variables as the function in an application.
202 -- The hack here simply doesn't check for out-of-scope-ness for
203 -- data constructors (at least, in a function position).
205 | otherwise = checkInScope var `seqL` returnL (Just (idType var))
207 lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
208 lintCoreExpr (SCC _ expr) = lintCoreExpr expr
209 lintCoreExpr e@(Coerce coercion ty expr)
210 = lintCoercion e coercion `seqL`
211 lintCoreExpr expr `seqL` returnL (Just ty)
213 lintCoreExpr (Let binds body)
214 = lintCoreBinding binds `thenL` \binders ->
215 if (null binders) then
216 lintCoreExpr body -- Can't add a new source location
218 addLoc (BodyOfLetRec binders)
219 (addInScopeVars binders (lintCoreExpr body))
221 lintCoreExpr e@(Con con args)
222 = checkL (isDataCon con) (mkConErrMsg e) `seqL`
223 lintCoreArgs {-False-} e (dataConRepType con) args
224 -- Note: we don't check for primitive types in these arguments
226 lintCoreExpr e@(Prim op args)
227 = lintCoreArgs {-True-} e (primOpType op) args
228 -- Note: we do check for primitive types in these arguments
230 lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
231 = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg {-False-} e ty arg
232 -- Note: we don't check for primitive types in argument to 'error'
234 lintCoreExpr e@(App fun arg)
235 = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg {-True-} e ty arg
236 -- Note: we do check for primitive types in this argument
238 lintCoreExpr (Lam (ValBinder var) expr)
239 = addLoc (LambdaBodyOf var)
240 (addInScopeVars [var]
241 (lintCoreExpr expr `thenMaybeL` \ty ->
242 returnL (Just (mkFunTy (idType var) ty))))
244 lintCoreExpr (Lam (TyBinder tyvar) expr)
245 = lintCoreExpr expr `thenMaybeL` \ty ->
246 returnL (Just(mkForAllTy tyvar ty))
247 -- ToDo: Should add in-scope type variable at this point
249 lintCoreExpr e@(Case scrut alts)
250 = lintCoreExpr scrut `thenMaybeL` \ty ->
254 %************************************************************************
256 \subsection[lintCoreArgs]{lintCoreArgs}
258 %************************************************************************
260 The boolean argument indicates whether we should flag type
261 applications to primitive types as being errors.
264 lintCoreArgs :: {-Bool ->-} CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
266 lintCoreArgs _ ty [] = returnL (Just ty)
267 lintCoreArgs e ty (a : args)
268 = lintCoreArg e ty a `thenMaybeL` \ res ->
269 lintCoreArgs e res args
272 %************************************************************************
274 \subsection[lintCoreArg]{lintCoreArg}
276 %************************************************************************
279 lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
281 lintCoreArg e ty (LitArg lit)
282 = -- Make sure function type matches argument
283 case (splitFunTy_maybe ty) of
284 Just (arg,res) | (lit_ty == arg) -> returnL(Just res)
285 _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing
287 lit_ty = literalType lit
289 lintCoreArg e ty (VarArg v)
290 = -- Make sure variable is bound
291 checkInScope v `seqL`
292 -- Make sure function type matches argument
293 case (splitFunTy_maybe ty) of
294 Just (arg,res) | (var_ty == arg) -> returnL(Just res)
295 _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing
299 lintCoreArg e ty a@(TyArg arg_ty)
300 = -- ToDo: Check that ty is well-kinded and has no unbound tyvars
301 case (splitForAllTy_maybe ty) of
302 Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
306 tyvar_kind = tyVarKind tyvar
307 argty_kind = typeKind arg_ty
309 if argty_kind `hasMoreBoxityInfo` tyvar_kind
310 -- Arg type might be boxed for a function with an uncommitted
311 -- tyvar; notably this is used so that we can give
312 -- error :: forall a:*. String -> a
313 -- and then apply it to both boxed and unboxed types.
315 returnL(Just(instantiateTy (mkTyVarEnv [(tyvar,arg_ty)]) body))
317 pprTrace "lintCoreArg:kinds:" (hsep [ppr tyvar_kind, ppr argty_kind]) $
318 addErrL (mkKindErrMsg tyvar arg_ty e) `seqL` returnL Nothing
321 %************************************************************************
323 \subsection[lintCoreAlts]{lintCoreAlts}
325 %************************************************************************
328 lintCoreAlts :: CoreCaseAlts
329 -> Type -- Type of scrutinee
330 -- -> TyCon -- TyCon pinned on the case
331 -> LintM (Maybe Type) -- Type of alternatives
333 lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon
334 = -- Check tycon is not a primitive tycon
335 -- addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
337 -- Check we are scrutinising a proper datatype
339 -- addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
342 `thenL` \maybe_deflt_ty ->
343 mapL (lintAlgAlt ty {-tycon-}) alts
344 `thenL` \maybe_alt_tys ->
345 -- Check the result types
346 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
347 [] -> returnL Nothing
349 (first_ty:tys) -> mapL check tys `seqL`
350 returnL (Just first_ty)
352 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
354 lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
355 = -- Check tycon is a primitive tycon
356 -- addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
358 mapL (lintPrimAlt ty) alts
359 `thenL` \maybe_alt_tys ->
361 `thenL` \maybe_deflt_ty ->
362 -- Check the result types
363 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
364 [] -> returnL Nothing
366 (first_ty:tys) -> mapL check tys `seqL`
367 returnL (Just first_ty)
369 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
371 lintAlgAlt scrut_ty (con,args,rhs)
372 = (case splitAlgTyConApp_maybe scrut_ty of
373 Just (tycon, tys_applied, cons) | isDataTyCon tycon ->
375 arg_tys = dataConArgTys con tys_applied
377 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
378 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
380 mapL check (zipEqual "lintAlgAlt" arg_tys args) `seqL`
383 other -> addErrL (mkAlgAltMsg1 scrut_ty)
385 addInScopeVars args (
389 check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
391 -- elem: yes, the elem-list here can sometimes be long-ish,
392 -- but as it's use-once, probably not worth doing anything different
393 -- We give it its own copy, so it isn't overloaded.
395 elem x (y:ys) = x==y || elem x ys
397 lintPrimAlt ty alt@(lit,rhs)
398 = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
401 lintDeflt NoDefault _ = returnL Nothing
402 lintDeflt deflt@(BindDefault binder rhs) ty
403 = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
404 addInScopeVars [binder] (lintCoreExpr rhs)
407 %************************************************************************
409 \subsection[lint-coercion]{Coercion}
411 %************************************************************************
414 lintCoercion e (CoerceIn con) = check_con e con
415 lintCoercion e (CoerceOut con) = check_con e con
417 check_con e con = checkL (isNewCon con)
422 %************************************************************************
424 \subsection[lint-monad]{The Lint monad}
426 %************************************************************************
429 type LintM a = Bool -- True <=> specialisation has been done
430 -> [LintLocInfo] -- Locations
431 -> IdSet -- Local vars in scope
432 -> Bag ErrMsg -- Error messages so far
433 -> (a, Bag ErrMsg) -- Result and error messages (if any)
436 = RhsOf Id -- The variable bound
437 | LambdaBodyOf Id -- The lambda-binder
438 | BodyOfLetRec [Id] -- One of the binders
439 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
441 instance Outputable LintLocInfo where
443 = ppr (getSrcLoc v) <> colon <+>
444 brackets (ptext SLIT("RHS of") <+> pp_binders [v])
447 = ppr (getSrcLoc b) <> colon <+>
448 brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b)
450 ppr (BodyOfLetRec bs)
451 = ppr (getSrcLoc (head bs)) <> colon <+>
452 brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs)
454 ppr (ImportedUnfolding locn)
455 = ppr locn <> colon <+>
456 brackets (ptext SLIT("in an imported unfolding"))
458 pp_binders :: [Id] -> SDoc
459 pp_binders bs = sep (punctuate comma (map pp_binder bs))
461 pp_binder :: Id -> SDoc
462 pp_binder b = hsep [ppr b, text "::", ppr (idType b)]
466 initL :: LintM a -> Bool -> Maybe ErrMsg
468 = case (m spec_done [] emptyIdSet emptyBag) of { (_, errs) ->
469 if isEmptyBag errs then
472 Just (vcat (bagToList errs))
475 returnL :: a -> LintM a
476 returnL r spec loc scope errs = (r, errs)
478 thenL :: LintM a -> (a -> LintM b) -> LintM b
479 thenL m k spec loc scope errs
480 = case m spec loc scope errs of
481 (r, errs') -> k r spec loc scope errs'
483 seqL :: LintM a -> LintM b -> LintM b
484 seqL m k spec loc scope errs
485 = case m spec loc scope errs of
486 (_, errs') -> k spec loc scope errs'
488 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
489 thenMaybeL m k spec loc scope errs
490 = case m spec loc scope errs of
491 (Nothing, errs2) -> (Nothing, errs2)
492 (Just r, errs2) -> k r spec loc scope errs2
494 mapL :: (a -> LintM b) -> [a] -> LintM [b]
495 mapL f [] = returnL []
498 mapL f xs `thenL` \ rs ->
501 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
502 -- Returns Nothing if anything fails
503 mapMaybeL f [] = returnL (Just [])
505 = f x `thenMaybeL` \ r ->
506 mapMaybeL f xs `thenMaybeL` \ rs ->
507 returnL (Just (r:rs))
511 checkL :: Bool -> ErrMsg -> LintM ()
512 checkL True msg spec loc scope errs = ((), errs)
513 checkL False msg spec loc scope errs = ((), addErr errs msg loc)
515 checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
516 checkIfSpecDoneL True msg spec loc scope errs = ((), errs)
517 checkIfSpecDoneL False msg True loc scope errs = ((), addErr errs msg loc)
518 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
520 addErrL :: ErrMsg -> LintM ()
521 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
523 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
525 addErr errs_so_far msg locs
526 = ASSERT (not (null locs))
527 errs_so_far `snocBag` (hang (ppr (head locs)) 4 msg)
529 addLoc :: LintLocInfo -> LintM a -> LintM a
530 addLoc extra_loc m spec loc scope errs
531 = m spec (extra_loc:loc) scope errs
533 addInScopeVars :: [Id] -> LintM a -> LintM a
534 addInScopeVars ids m spec loc scope errs
535 = -- We check if these "new" ids are already
536 -- in scope, i.e., we have *shadowing* going on.
537 -- For now, it's just a "trace"; we may make
538 -- a real error out of it...
540 new_set = mkIdSet ids
542 -- shadowed = scope `intersectIdSets` new_set
544 -- After adding -fliberate-case, Simon decided he likes shadowed
545 -- names after all. WDP 94/07
546 -- (if isEmptyUniqSet shadowed
548 -- else pprTrace "Shadowed vars:" (ppr (uniqSetToList shadowed))) (
549 m spec loc (scope `unionIdSets` new_set) errs
554 checkInScope :: Id -> LintM ()
555 checkInScope id spec loc scope errs
559 if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then
560 ((), addErr errs (hsep [ppr id, ptext SLIT("is out of scope")]) loc)
564 checkTys :: Type -> Type -> ErrMsg -> LintM ()
565 checkTys ty1 ty2 msg spec loc scope errs
566 = if ty1 == ty2 then ((), errs) else ((), addErr errs msg loc)
571 = ($$) (ptext SLIT("Application of newtype constructor:"))
575 = ($$) (ptext SLIT("Coercion using a datatype constructor:"))
579 mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
581 = ($$) (ptext SLIT("Type of case alternatives not the same:"))
584 mkCaseAbstractMsg :: TyCon -> ErrMsg
585 mkCaseAbstractMsg tycon
586 = ($$) (ptext SLIT("An algebraic case on some weird type:"))
589 mkDefltMsg :: CoreCaseDefault -> ErrMsg
591 = ($$) (ptext SLIT("Binder in case default doesn't match type of scrutinee:"))
594 mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
595 mkAppMsg fun arg expr
596 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
597 hang (ptext SLIT("Fun type:")) 4 (ppr fun),
598 hang (ptext SLIT("Arg type:")) 4 (ppr arg),
599 hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)]
601 mkKindErrMsg :: TyVar -> Type -> CoreExpr -> ErrMsg
602 mkKindErrMsg tyvar arg_ty expr
603 = vcat [ptext SLIT("Kinds don't match in type application:"),
604 hang (ptext SLIT("Type variable:"))
605 4 (ppr tyvar <+> ptext SLIT("::") <+> ppr (tyVarKind tyvar)),
606 hang (ptext SLIT("Arg type:"))
607 4 (ppr arg_ty <+> ptext SLIT("::") <+> ppr (typeKind arg_ty)),
608 hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)]
610 mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg
611 mkTyAppMsg msg ty arg expr
612 = vcat [hsep [ptext msg, ptext SLIT("type application:")],
613 hang (ptext SLIT("Exp type:"))
614 4 (ppr ty <+> ptext SLIT("::") <+> ppr (typeKind ty)),
615 hang (ptext SLIT("Arg type:"))
616 4 (ppr arg <+> ptext SLIT("::") <+> ppr (typeKind arg)),
617 hang (ptext SLIT("Expression:")) 4 (pprCoreExpr expr)]
619 mkAlgAltMsg1 :: Type -> ErrMsg
621 = ($$) (text "In some case statement, type of scrutinee is not a data type:")
624 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
627 text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
632 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
633 mkAlgAltMsg3 con alts
635 text "In some algebraic case alternative, number of arguments doesn't match constructor:",
640 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
643 text "In some algebraic case alternative, type of argument doesn't match data constructor:",
648 mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
651 (text "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
654 mkRhsMsg :: Id -> Type -> ErrMsg
657 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
659 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
660 hsep [ptext SLIT("Rhs type:"), ppr ty]]
662 mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
663 mkRhsPrimMsg binder rhs
664 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
666 hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]