2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[CoreLint]{A ``lint'' pass to check for Core correctness}
7 #include "HsVersions.h"
19 import Kind ( hasMoreBoxityInfo, Kind{-instance-} )
20 import Literal ( literalType, Literal{-instance-} )
21 import Id ( idType, isBottomingId,
22 dataConArgTys, GenId{-instances-},
23 emptyIdSet, mkIdSet, intersectIdSets,
24 unionIdSets, elementOfIdSet, IdSet(..)
26 import Maybes ( catMaybes )
27 import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-} )
28 import Outputable ( Outputable(..){-instance * []-} )
30 import PprStyle ( PprStyle(..) )
31 import PprType ( GenType, GenTyVar, TyCon )
33 import PrimOp ( primOpType, PrimOp(..) )
34 import PrimRep ( PrimRep(..) )
35 import SrcLoc ( SrcLoc )
36 import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,mkForAllTys,getForAllTy_maybe,
37 getFunTyExpandingDicts_maybe,
38 getForAllTyExpandingDicts_maybe,
39 isPrimType,typeKind,instantiateTy,splitSigmaTy,
40 mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
41 maybeAppDataTyConExpandingDicts, eqTy
42 -- ,expandTy -- ToDo:rm
44 import TyCon ( isPrimTyCon )
45 import TyVar ( tyVarKind, GenTyVar{-instances-} )
46 import Unique ( Unique )
47 import Usage ( GenUsage )
48 import Util ( zipEqual, pprTrace, pprPanic, assertPanic, panic )
50 infixr 9 `thenL`, `seqL`, `thenMaybeL`, `seqMaybeL`
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.
88 :: PprStyle -> String -> Bool -> [CoreBinding] -> [CoreBinding]
90 lintCoreBindings sty whoDunnit spec_done binds
91 = case (initL (lint_binds binds) spec_done) of
94 pprPanic "" (ppAboves [
95 ppStr ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"),
97 ppStr "*** Offending Program ***",
98 ppAboves (map (pprCoreBinding sty) binds),
99 ppStr "*** End of Offense ***"
102 lint_binds [] = returnL ()
103 lint_binds (bind:binds)
104 = lintCoreBinding bind `thenL` \binders ->
105 addInScopeVars binders (lint_binds binds)
108 %************************************************************************
110 \subsection[lintUnfolding]{lintUnfolding}
112 %************************************************************************
114 We use this to check all unfoldings that come in from interfaces
115 (it is very painful to catch errors otherwise):
118 lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
120 lintUnfolding locn expr
122 (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
123 True{-pretend spec done-})
127 pprTrace "WARNING: Discarded bad unfolding from interface:\n"
128 (ppAboves [msg PprForUser,
129 ppStr "*** Bad unfolding ***",
131 ppStr "*** End unfolding ***"])
135 %************************************************************************
137 \subsection[lintCoreBinding]{lintCoreBinding}
139 %************************************************************************
141 Check a core binding, returning the list of variables bound.
144 lintCoreBinding :: CoreBinding -> LintM [Id]
146 lintCoreBinding (NonRec binder rhs)
147 = lintSingleBinding (binder,rhs) `seqL` returnL [binder]
149 lintCoreBinding (Rec pairs)
150 = addInScopeVars binders (
151 mapL lintSingleBinding pairs `seqL` returnL binders
154 binders = [b | (b,_) <- pairs]
156 lintSingleBinding (binder,rhs)
157 = addLoc (RhsOf binder) (
162 -- Check match to RHS type
164 Nothing -> returnL ()
165 Just ty -> checkTys (idType binder) ty (mkRhsMsg binder ty))
168 -- Check (not isPrimType)
169 checkIfSpecDoneL (not (isPrimType (idType binder)))
170 (mkRhsPrimMsg binder rhs)
172 -- We should check the unfolding, if any, but this is tricky because
173 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
177 %************************************************************************
179 \subsection[lintCoreExpr]{lintCoreExpr}
181 %************************************************************************
184 lintCoreExpr :: CoreExpr -> LintM (Maybe Type) -- Nothing if error found
186 lintCoreExpr (Var var) = checkInScope var `seqL` returnL (Just (idType var))
187 lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
188 lintCoreExpr (SCC _ expr) = lintCoreExpr expr
189 lintCoreExpr (Coerce _ ty expr)
190 = lintCoreExpr expr `seqL` returnL (Just ty)
192 lintCoreExpr (Let binds body)
193 = lintCoreBinding binds `thenL` \binders ->
194 if (null binders) then
195 lintCoreExpr body -- Can't add a new source location
197 addLoc (BodyOfLetRec binders)
198 (addInScopeVars binders (lintCoreExpr body))
200 lintCoreExpr e@(Con con args)
201 = lintCoreArgs {-False-} e unoverloaded_ty args
202 -- Note: we don't check for primitive types in these arguments
204 -- Constructors are special in that they aren't passed their
205 -- dictionary arguments, so we swizzle them out of the
206 -- constructor type before handing over to lintCorArgs
207 unoverloaded_ty = mkForAllTys tyvars tau
208 (tyvars, theta, tau) = splitSigmaTy (idType con)
210 lintCoreExpr e@(Prim op args)
211 = lintCoreArgs {-True-} e (primOpType op) args
212 -- Note: we do check for primitive types in these arguments
214 lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
215 = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg {-False-} e ty arg
216 -- Note: we don't check for primitive types in argument to 'error'
218 lintCoreExpr e@(App fun arg)
219 = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg {-True-} e ty arg
220 -- Note: we do check for primitive types in this argument
222 lintCoreExpr (Lam (ValBinder var) expr)
223 = addLoc (LambdaBodyOf var)
224 (addInScopeVars [var]
225 (lintCoreExpr expr `thenMaybeL` \ty ->
226 returnL (Just (mkFunTy (idType var) ty))))
228 lintCoreExpr (Lam (TyBinder tyvar) expr)
229 = lintCoreExpr expr `thenMaybeL` \ty ->
230 returnL (Just(mkForAllTy tyvar ty))
231 -- ToDo: Should add in-scope type variable at this point
233 lintCoreExpr e@(Case scrut alts)
234 = lintCoreExpr scrut `thenMaybeL` \ty ->
238 %************************************************************************
240 \subsection[lintCoreArgs]{lintCoreArgs}
242 %************************************************************************
244 The boolean argument indicates whether we should flag type
245 applications to primitive types as being errors.
248 lintCoreArgs :: {-Bool ->-} CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
250 lintCoreArgs _ ty [] = returnL (Just ty)
251 lintCoreArgs e ty (a : args)
252 = lintCoreArg e ty a `thenMaybeL` \ res ->
253 lintCoreArgs e res args
256 %************************************************************************
258 \subsection[lintCoreArg]{lintCoreArg}
260 %************************************************************************
263 lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
265 lintCoreArg e ty (LitArg lit)
266 = -- Make sure function type matches argument
267 case (getFunTyExpandingDicts_maybe ty) of
268 Just (arg,res) | (lit_ty `eqTy` arg) -> returnL(Just res)
269 _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing
271 lit_ty = literalType lit
273 lintCoreArg e ty (VarArg v)
274 = -- Make sure variable is bound
275 checkInScope v `seqL`
276 -- Make sure function type matches argument
277 case (getFunTyExpandingDicts_maybe ty) of
278 Just (arg,res) | (var_ty `eqTy` arg) -> returnL(Just res)
279 _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing
283 lintCoreArg e ty a@(TyArg arg_ty)
284 = -- ToDo: Check that ty is well-kinded and has no unbound tyvars
285 checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a)
287 case (getForAllTyExpandingDicts_maybe ty) of
288 Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
292 tyvar_kind = tyVarKind tyvar
293 argty_kind = typeKind arg_ty
295 if argty_kind `hasMoreBoxityInfo` tyvar_kind
296 -- Arg type might be boxed for a function with an uncommitted
297 -- tyvar; notably this is used so that we can give
298 -- error :: forall a:*. String -> a
299 -- and then apply it to both boxed and unboxed types.
301 returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
303 pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $
304 addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing
306 lintCoreArg e ty (UsageArg u)
307 = -- ToDo: Check that usage has no unbound usage variables
308 case (getForAllUsageTy ty) of
309 Just (uvar,bounds,body) ->
310 -- ToDo: Check argument satisfies bounds
311 returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body"))
312 _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing
315 %************************************************************************
317 \subsection[lintCoreAlts]{lintCoreAlts}
319 %************************************************************************
322 lintCoreAlts :: CoreCaseAlts
323 -> Type -- Type of scrutinee
324 -- -> TyCon -- TyCon pinned on the case
325 -> LintM (Maybe Type) -- Type of alternatives
327 lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon
328 = -- Check tycon is not a primitive tycon
329 -- addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
331 -- Check we are scrutinising a proper datatype
333 -- addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
336 `thenL` \maybe_deflt_ty ->
337 mapL (lintAlgAlt ty {-tycon-}) alts
338 `thenL` \maybe_alt_tys ->
339 -- Check the result types
340 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
341 [] -> returnL Nothing
343 (first_ty:tys) -> mapL check tys `seqL`
344 returnL (Just first_ty)
346 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
348 lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
349 = -- Check tycon is a primitive tycon
350 -- addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
352 mapL (lintPrimAlt ty) alts
353 `thenL` \maybe_alt_tys ->
355 `thenL` \maybe_deflt_ty ->
356 -- Check the result types
357 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
358 [] -> returnL Nothing
360 (first_ty:tys) -> mapL check tys `seqL`
361 returnL (Just first_ty)
363 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
365 lintAlgAlt scrut_ty {-tycon-ToDo: use it!-} (con,args,rhs)
366 = (case maybeAppDataTyConExpandingDicts scrut_ty of
368 addErrL (mkAlgAltMsg1 scrut_ty)
369 Just (tycon, tys_applied, cons) ->
371 arg_tys = dataConArgTys con tys_applied
373 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
374 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
376 mapL check (zipEqual "lintAlgAlt" arg_tys args) `seqL`
379 addInScopeVars args (
383 check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
385 -- elem: yes, the elem-list here can sometimes be long-ish,
386 -- but as it's use-once, probably not worth doing anything different
387 -- We give it its own copy, so it isn't overloaded.
389 elem x (y:ys) = x==y || elem x ys
391 lintPrimAlt ty alt@(lit,rhs)
392 = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
395 lintDeflt NoDefault _ = returnL Nothing
396 lintDeflt deflt@(BindDefault binder rhs) ty
397 = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
398 addInScopeVars [binder] (lintCoreExpr rhs)
401 %************************************************************************
403 \subsection[lint-monad]{The Lint monad}
405 %************************************************************************
408 type LintM a = Bool -- True <=> specialisation has been done
409 -> [LintLocInfo] -- Locations
410 -> IdSet -- Local vars in scope
411 -> Bag ErrMsg -- Error messages so far
412 -> (a, Bag ErrMsg) -- Result and error messages (if any)
414 type ErrMsg = PprStyle -> Pretty
417 = RhsOf Id -- The variable bound
418 | LambdaBodyOf Id -- The lambda-binder
419 | BodyOfLetRec [Id] -- One of the binders
420 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
422 instance Outputable LintLocInfo where
424 = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
426 ppr sty (LambdaBodyOf b)
427 = ppBesides [ppr sty (getSrcLoc b),
428 ppStr ": [in body of lambda with binder ", pp_binder sty b, ppStr "]"]
430 ppr sty (BodyOfLetRec bs)
431 = ppBesides [ppr sty (getSrcLoc (head bs)),
432 ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"]
434 ppr sty (ImportedUnfolding locn)
435 = ppBeside (ppr sty locn) (ppStr ": [in an imported unfolding]")
437 pp_binders :: PprStyle -> [Id] -> Pretty
438 pp_binders sty bs = ppInterleave ppComma (map (pp_binder sty) bs)
440 pp_binder :: PprStyle -> Id -> Pretty
441 pp_binder sty b = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
445 initL :: LintM a -> Bool -> Maybe ErrMsg
447 = case (m spec_done [] emptyIdSet emptyBag) of { (_, errs) ->
448 if isEmptyBag errs then
452 ppAboves [ msg sty | msg <- bagToList errs ]
456 returnL :: a -> LintM a
457 returnL r spec loc scope errs = (r, errs)
459 thenL :: LintM a -> (a -> LintM b) -> LintM b
460 thenL m k spec loc scope errs
461 = case m spec loc scope errs of
462 (r, errs') -> k r spec loc scope errs'
464 seqL :: LintM a -> LintM b -> LintM b
465 seqL m k spec loc scope errs
466 = case m spec loc scope errs of
467 (_, errs') -> k spec loc scope errs'
469 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
470 thenMaybeL m k spec loc scope errs
471 = case m spec loc scope errs of
472 (Nothing, errs2) -> (Nothing, errs2)
473 (Just r, errs2) -> k r spec loc scope errs2
475 seqMaybeL :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
476 seqMaybeL m k spec loc scope errs
477 = case m spec loc scope errs of
478 (Nothing, errs2) -> (Nothing, errs2)
479 (Just _, errs2) -> k spec loc scope errs2
481 mapL :: (a -> LintM b) -> [a] -> LintM [b]
482 mapL f [] = returnL []
485 mapL f xs `thenL` \ rs ->
488 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
489 -- Returns Nothing if anything fails
490 mapMaybeL f [] = returnL (Just [])
492 = f x `thenMaybeL` \ r ->
493 mapMaybeL f xs `thenMaybeL` \ rs ->
494 returnL (Just (r:rs))
498 checkL :: Bool -> ErrMsg -> LintM ()
499 checkL True msg spec loc scope errs = ((), errs)
500 checkL False msg spec loc scope errs = ((), addErr errs msg loc)
502 checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
503 checkIfSpecDoneL True msg spec loc scope errs = ((), errs)
504 checkIfSpecDoneL False msg True loc scope errs = ((), addErr errs msg loc)
505 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
508 = if pred then addErrL spec else returnL ()
510 addErrL :: ErrMsg -> LintM ()
511 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
513 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
515 addErr errs_so_far msg locs
516 = ASSERT (not (null locs))
517 errs_so_far `snocBag` ( \ sty ->
518 ppHang (ppr sty (head locs)) 4 (msg sty)
521 addLoc :: LintLocInfo -> LintM a -> LintM a
522 addLoc extra_loc m spec loc scope errs
523 = m spec (extra_loc:loc) scope errs
525 addInScopeVars :: [Id] -> LintM a -> LintM a
526 addInScopeVars ids m spec loc scope errs
527 = -- We check if these "new" ids are already
528 -- in scope, i.e., we have *shadowing* going on.
529 -- For now, it's just a "trace"; we may make
530 -- a real error out of it...
532 new_set = mkIdSet ids
534 -- shadowed = scope `intersectIdSets` new_set
536 -- After adding -fliberate-case, Simon decided he likes shadowed
537 -- names after all. WDP 94/07
538 -- (if isEmptyUniqSet shadowed
540 -- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
541 m spec loc (scope `unionIdSets` new_set) errs
546 checkInScope :: Id -> LintM ()
547 checkInScope id spec loc scope errs
551 if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then
552 ((),addErr errs (\sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc)
556 checkTys :: Type -> Type -> ErrMsg -> LintM ()
557 checkTys ty1 ty2 msg spec loc scope errs
558 = if ty1 `eqTy` ty2 then ((), errs) else ((), addErr errs msg loc)
562 mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
563 mkCaseAltMsg alts sty
564 = ppAbove (ppStr "Type of case alternatives not the same:")
567 mkCaseDataConMsg :: CoreExpr -> ErrMsg
568 mkCaseDataConMsg expr sty
569 = ppAbove (ppStr "A case scrutinee not of data constructor type:")
572 mkCaseNotPrimMsg :: TyCon -> ErrMsg
573 mkCaseNotPrimMsg tycon sty
574 = ppAbove (ppStr "A primitive case on a non-primitive type:")
577 mkCasePrimMsg :: TyCon -> ErrMsg
578 mkCasePrimMsg tycon sty
579 = ppAbove (ppStr "An algebraic case on a primitive type:")
582 mkCaseAbstractMsg :: TyCon -> ErrMsg
583 mkCaseAbstractMsg tycon sty
584 = ppAbove (ppStr "An algebraic case on some weird type:")
587 mkDefltMsg :: CoreCaseDefault -> ErrMsg
589 = ppAbove (ppStr "Binder in case default doesn't match type of scrutinee:")
592 mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
593 mkAppMsg fun arg expr sty
594 = ppAboves [ppStr "Argument value doesn't match argument type:",
595 ppHang (ppStr "Fun type:") 4 (ppr sty fun),
596 ppHang (ppStr "Arg type:") 4 (ppr sty arg),
597 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
599 mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg
600 mkTyAppMsg msg ty arg expr sty
601 = ppAboves [ppCat [ppPStr msg, ppStr "type application:"],
602 ppHang (ppStr "Exp type:") 4 (ppr sty ty),
603 ppHang (ppStr "Arg type:") 4 (ppr sty arg),
604 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
606 mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg
607 mkUsageAppMsg ty u expr sty
608 = ppAboves [ppStr "Illegal usage application:",
609 ppHang (ppStr "Exp type:") 4 (ppr sty ty),
610 ppHang (ppStr "Usage exp:") 4 (ppr sty u),
611 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
613 mkAlgAltMsg1 :: Type -> ErrMsg
615 = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
617 -- (ppAbove (ppr sty ty) (ppr sty (expandTy ty))) -- ToDo: rm
619 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
620 mkAlgAltMsg2 ty con sty
622 ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
627 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
628 mkAlgAltMsg3 con alts sty
630 ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:",
635 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
636 mkAlgAltMsg4 ty arg sty
638 ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
643 mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
646 (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
649 mkRhsMsg :: Id -> Type -> ErrMsg
650 mkRhsMsg binder ty sty
652 [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
654 ppCat [ppStr "Binder's type:", ppr sty (idType binder)],
655 ppCat [ppStr "Rhs type:", ppr sty ty]]
657 mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
658 mkRhsPrimMsg binder rhs sty
659 = ppAboves [ppCat [ppStr "The type of this binder is primitive:",
661 ppCat [ppStr "Binder's type:", ppr sty (idType binder)]
664 mkSpecTyAppMsg :: CoreArg -> ErrMsg
665 mkSpecTyAppMsg arg sty
667 (ppStr "Unboxed types in a type application (after specialisation):")
670 pp_expr :: PprStyle -> CoreExpr -> Pretty
672 = pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr