2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
4 \section[CoreLint]{A ``lint'' pass to check for Core correctness}
7 #include "HsVersions.h"
19 import Kind ( Kind{-instance-} )
20 import Literal ( literalType, Literal{-instance-} )
21 import Id ( idType, isBottomingId,
22 dataConArgTys, GenId{-instances-}
24 import Maybes ( catMaybes )
25 import Name ( isLocallyDefined, getSrcLoc )
26 import Outputable ( Outputable(..){-instance * []-} )
28 import PprStyle ( PprStyle(..) )
29 import PprType ( GenType, GenTyVar, TyCon )
31 import PrimOp ( primOpType, PrimOp(..) )
32 import PrimRep ( PrimRep(..) )
33 import SrcLoc ( SrcLoc )
34 import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,getForAllTy_maybe,
35 isPrimType,getTypeKind,instantiateTy,
36 mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
37 maybeAppDataTyCon, eqTy
39 import TyCon ( isPrimTyCon, tyConFamilySize )
40 import TyVar ( getTyVarKind, GenTyVar{-instances-} )
41 import UniqSet ( emptyUniqSet, mkUniqSet, intersectUniqSets,
42 unionUniqSets, elementOfUniqSet, UniqSet(..)
44 import Unique ( Unique )
45 import Usage ( GenUsage )
46 import Util ( zipEqual, pprTrace, pprPanic, assertPanic, panic )
48 infixr 9 `thenL`, `seqL`, `thenMaybeL`, `seqMaybeL`
51 %************************************************************************
53 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
55 %************************************************************************
57 Checks that a set of core bindings is well-formed. The PprStyle and String
58 just control what we print in the event of an error. The Bool value
59 indicates whether we have done any specialisation yet (in which case we do
64 (b) Out-of-scope type variables
65 (c) Out-of-scope local variables
68 If we have done specialisation the we check that there are
69 (a) No top-level bindings of primitive (unboxed type)
74 -- Things are *not* OK if:
76 -- * Unsaturated type app before specialisation has been done;
78 -- * Oversaturated type app after specialisation (eta reduction
79 -- may well be happening...);
81 -- Note: checkTyApp is usually followed by a call to checkSpecTyApp.
86 :: PprStyle -> String -> Bool -> [CoreBinding] -> [CoreBinding]
88 lintCoreBindings sty whoDunnit spec_done binds
89 = case (initL (lint_binds binds) spec_done) of
92 pprPanic "" (ppAboves [
93 ppStr ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"),
95 ppStr "*** Offending Program ***",
96 ppAboves (map (pprCoreBinding sty) binds),
97 ppStr "*** End of Offense ***"
100 lint_binds [] = returnL ()
101 lint_binds (bind:binds)
102 = lintCoreBinding bind `thenL` \binders ->
103 addInScopeVars binders (lint_binds binds)
106 %************************************************************************
108 \subsection[lintUnfolding]{lintUnfolding}
110 %************************************************************************
112 We use this to check all unfoldings that come in from interfaces
113 (it is very painful to catch errors otherwise):
116 lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
118 lintUnfolding locn expr
120 (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
121 True{-pretend spec done-})
125 pprTrace "WARNING: Discarded bad unfolding from interface:\n"
126 (ppAboves [msg PprForUser,
127 ppStr "*** Bad unfolding ***",
129 ppStr "*** End unfolding ***"])
133 %************************************************************************
135 \subsection[lintCoreBinding]{lintCoreBinding}
137 %************************************************************************
139 Check a core binding, returning the list of variables bound.
142 lintCoreBinding :: CoreBinding -> LintM [Id]
144 lintCoreBinding (NonRec binder rhs)
145 = lintSingleBinding (binder,rhs) `seqL` returnL [binder]
147 lintCoreBinding (Rec pairs)
148 = addInScopeVars binders (
149 mapL lintSingleBinding pairs `seqL` returnL binders
152 binders = [b | (b,_) <- pairs]
154 lintSingleBinding (binder,rhs)
155 = addLoc (RhsOf binder) (
160 -- Check match to RHS type
162 Nothing -> returnL ()
163 Just ty -> checkTys (idType binder) ty (mkRhsMsg binder ty))
166 -- Check (not isPrimType)
167 checkIfSpecDoneL (not (isPrimType (idType binder)))
168 (mkRhsPrimMsg binder rhs)
170 -- We should check the unfolding, if any, but this is tricky because
171 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
175 %************************************************************************
177 \subsection[lintCoreExpr]{lintCoreExpr}
179 %************************************************************************
182 lintCoreExpr :: CoreExpr -> LintM (Maybe Type) -- Nothing if error found
184 lintCoreExpr (Var var) = checkInScope var `seqL` returnL (Just (idType var))
185 lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
186 lintCoreExpr (SCC _ expr) = lintCoreExpr expr
188 lintCoreExpr (Let binds body)
189 = lintCoreBinding binds `thenL` \binders ->
190 if (null binders) then
191 lintCoreExpr body -- Can't add a new source location
193 addLoc (BodyOfLetRec binders)
194 (addInScopeVars binders (lintCoreExpr body))
196 lintCoreExpr e@(Con con args)
197 = lintCoreArgs False e (idType con) args
198 -- Note: we don't check for primitive types in these arguments
200 lintCoreExpr e@(Prim op args)
201 = lintCoreArgs True e (primOpType op) args
202 -- Note: we do check for primitive types in these arguments
204 lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
205 = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg False e ty arg
206 -- Note: we don't check for primitive types in argument to 'error'
208 lintCoreExpr e@(App fun arg)
209 = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg True e ty arg
210 -- Note: we do check for primitive types in this argument
212 lintCoreExpr (Lam (ValBinder var) expr)
213 = addLoc (LambdaBodyOf var)
214 (addInScopeVars [var]
215 (lintCoreExpr expr `thenMaybeL` \ty ->
216 returnL (Just (mkFunTy (idType var) ty))))
218 lintCoreExpr (Lam (TyBinder tyvar) expr)
219 = lintCoreExpr expr `thenMaybeL` \ty ->
220 returnL (Just(mkForAllTy tyvar ty))
221 -- TODO: Should add in-scope type variable at this point
223 lintCoreExpr e@(Case scrut alts)
224 = lintCoreExpr scrut `thenMaybeL` \ty ->
225 -- Check that it is a data type
226 case maybeAppDataTyCon ty of
227 Nothing -> addErrL (mkCaseDataConMsg e) `seqL` returnL Nothing
228 Just(tycon, _, _) -> lintCoreAlts alts ty tycon
231 %************************************************************************
233 \subsection[lintCoreArgs]{lintCoreArgs}
235 %************************************************************************
237 The boolean argument indicates whether we should flag type
238 applications to primitive types as being errors.
241 lintCoreArgs :: Bool -> CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
243 lintCoreArgs _ _ ty [] = returnL (Just ty)
244 lintCoreArgs checkTyApp e ty (a : args)
245 = lintCoreArg checkTyApp e ty a `thenMaybeL` \ res ->
246 lintCoreArgs checkTyApp e res args
249 %************************************************************************
251 \subsection[lintCoreArg]{lintCoreArg}
253 %************************************************************************
256 lintCoreArg :: Bool -> CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
258 lintCoreArg _ e ty (LitArg lit)
259 = -- Make sure function type matches argument
260 case (getFunTy_maybe ty) of
261 Just (arg,res) | (literalType lit `eqTy` arg) -> returnL(Just res)
262 _ -> addErrL (mkAppMsg ty (literalType lit) e) `seqL` returnL Nothing
264 lintCoreArg _ e ty (VarArg v)
265 = -- Make sure variable is bound
266 checkInScope v `seqL`
267 -- Make sure function type matches argument
268 case (getFunTy_maybe ty) of
269 Just (arg,res) | (idType v `eqTy` arg) -> returnL(Just res)
270 _ -> addErrL (mkAppMsg ty (idType v) e) `seqL` returnL Nothing
272 lintCoreArg checkTyApp e ty a@(TyArg arg_ty)
273 = -- TODO: Check that ty is well-kinded and has no unbound tyvars
274 checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a)
276 case (getForAllTy_maybe ty) of
277 Just (tyvar,body) | (getTyVarKind tyvar == getTypeKind arg_ty) ->
278 returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
279 _ -> addErrL (mkTyAppMsg ty arg_ty e) `seqL` returnL Nothing
281 lintCoreArg _ e ty (UsageArg u)
282 = -- TODO: Check that usage has no unbound usage variables
283 case (getForAllUsageTy ty) of
284 Just (uvar,bounds,body) ->
285 -- TODO Check argument satisfies bounds
286 returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body"))
287 _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing
290 %************************************************************************
292 \subsection[lintCoreAlts]{lintCoreAlts}
294 %************************************************************************
297 lintCoreAlts :: CoreCaseAlts
298 -> Type -- Type of scrutinee
299 -> TyCon -- TyCon pinned on the case
300 -> LintM (Maybe Type) -- Type of alternatives
302 lintCoreAlts whole_alts@(AlgAlts alts deflt) ty tycon
303 = -- Check tycon is not a primitive tycon
304 addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
306 -- Check we are scrutinising a proper datatype
308 addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
311 `thenL` \maybe_deflt_ty ->
312 mapL (lintAlgAlt ty tycon) alts
313 `thenL` \maybe_alt_tys ->
314 -- Check the result types
315 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
316 [] -> returnL Nothing
318 (first_ty:tys) -> mapL check tys `seqL`
319 returnL (Just first_ty)
321 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
323 lintCoreAlts whole_alts@(PrimAlts alts deflt) ty tycon
324 = -- Check tycon is a primitive tycon
325 addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
327 mapL (lintPrimAlt ty) alts
328 `thenL` \maybe_alt_tys ->
330 `thenL` \maybe_deflt_ty ->
331 -- Check the result types
332 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
333 [] -> returnL Nothing
335 (first_ty:tys) -> mapL check tys `seqL`
336 returnL (Just first_ty)
338 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
340 lintAlgAlt scrut_ty tycon{-ToDo: use it!-} (con,args,rhs)
341 = (case maybeAppDataTyCon scrut_ty of
343 addErrL (mkAlgAltMsg1 scrut_ty)
344 Just (tycon, tys_applied, cons) ->
346 arg_tys = dataConArgTys con tys_applied
348 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
349 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
351 mapL check (arg_tys `zipEqual` args) `seqL`
354 addInScopeVars args (
358 check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
360 -- elem: yes, the elem-list here can sometimes be long-ish,
361 -- but as it's use-once, probably not worth doing anything different
362 -- We give it its own copy, so it isn't overloaded.
364 elem x (y:ys) = x==y || elem x ys
366 lintPrimAlt ty alt@(lit,rhs)
367 = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
370 lintDeflt NoDefault _ = returnL Nothing
371 lintDeflt deflt@(BindDefault binder rhs) ty
372 = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
373 addInScopeVars [binder] (lintCoreExpr rhs)
376 %************************************************************************
378 \subsection[lint-monad]{The Lint monad}
380 %************************************************************************
383 type LintM a = Bool -- True <=> specialisation has been done
384 -> [LintLocInfo] -- Locations
385 -> UniqSet Id -- Local vars in scope
386 -> Bag ErrMsg -- Error messages so far
387 -> (a, Bag ErrMsg) -- Result and error messages (if any)
389 type ErrMsg = PprStyle -> Pretty
392 = RhsOf Id -- The variable bound
393 | LambdaBodyOf Id -- The lambda-binder
394 | BodyOfLetRec [Id] -- One of the binders
395 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
397 instance Outputable LintLocInfo where
399 = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
401 ppr sty (LambdaBodyOf b)
402 = ppBesides [ppr sty (getSrcLoc b),
403 ppStr ": [in body of lambda with binder ", pp_binder sty b, ppStr "]"]
405 ppr sty (BodyOfLetRec bs)
406 = ppBesides [ppr sty (getSrcLoc (head bs)),
407 ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"]
409 ppr sty (ImportedUnfolding locn)
410 = ppBeside (ppr sty locn) (ppStr ": [in an imported unfolding]")
412 pp_binders :: PprStyle -> [Id] -> Pretty
413 pp_binders sty bs = ppInterleave ppComma (map (pp_binder sty) bs)
415 pp_binder :: PprStyle -> Id -> Pretty
416 pp_binder sty b = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
420 initL :: LintM a -> Bool -> Maybe ErrMsg
422 = case (m spec_done [] emptyUniqSet emptyBag) of { (_, errs) ->
423 if isEmptyBag errs then
427 ppAboves [ msg sty | msg <- bagToList errs ]
431 returnL :: a -> LintM a
432 returnL r spec loc scope errs = (r, errs)
434 thenL :: LintM a -> (a -> LintM b) -> LintM b
435 thenL m k spec loc scope errs
436 = case m spec loc scope errs of
437 (r, errs') -> k r spec loc scope errs'
439 seqL :: LintM a -> LintM b -> LintM b
440 seqL m k spec loc scope errs
441 = case m spec loc scope errs of
442 (_, errs') -> k spec loc scope errs'
444 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
445 thenMaybeL m k spec loc scope errs
446 = case m spec loc scope errs of
447 (Nothing, errs2) -> (Nothing, errs2)
448 (Just r, errs2) -> k r spec loc scope errs2
450 seqMaybeL :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
451 seqMaybeL m k spec loc scope errs
452 = case m spec loc scope errs of
453 (Nothing, errs2) -> (Nothing, errs2)
454 (Just _, errs2) -> k spec loc scope errs2
456 mapL :: (a -> LintM b) -> [a] -> LintM [b]
457 mapL f [] = returnL []
460 mapL f xs `thenL` \ rs ->
463 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
464 -- Returns Nothing if anything fails
465 mapMaybeL f [] = returnL (Just [])
467 = f x `thenMaybeL` \ r ->
468 mapMaybeL f xs `thenMaybeL` \ rs ->
469 returnL (Just (r:rs))
473 checkL :: Bool -> ErrMsg -> LintM ()
474 checkL True msg spec loc scope errs = ((), errs)
475 checkL False msg spec loc scope errs = ((), addErr errs msg loc)
477 checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
478 checkIfSpecDoneL True msg spec loc scope errs = ((), errs)
479 checkIfSpecDoneL False msg True loc scope errs = ((), addErr errs msg loc)
480 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
483 = if pred then addErrL spec else returnL ()
485 addErrL :: ErrMsg -> LintM ()
486 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
488 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
490 addErr errs_so_far msg locs
491 = ASSERT (not (null locs))
492 errs_so_far `snocBag` ( \ sty ->
493 ppHang (ppr sty (head locs)) 4 (msg sty)
496 addLoc :: LintLocInfo -> LintM a -> LintM a
497 addLoc extra_loc m spec loc scope errs
498 = m spec (extra_loc:loc) scope errs
500 addInScopeVars :: [Id] -> LintM a -> LintM a
501 addInScopeVars ids m spec loc scope errs
502 = -- We check if these "new" ids are already
503 -- in scope, i.e., we have *shadowing* going on.
504 -- For now, it's just a "trace"; we may make
505 -- a real error out of it...
507 new_set = mkUniqSet ids
509 shadowed = scope `intersectUniqSets` new_set
511 -- After adding -fliberate-case, Simon decided he likes shadowed
512 -- names after all. WDP 94/07
513 -- (if isEmptyUniqSet shadowed
515 -- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
516 m spec loc (scope `unionUniqSets` new_set) errs
521 checkInScope :: Id -> LintM ()
522 checkInScope id spec loc scope errs
523 = if isLocallyDefined id && not (id `elementOfUniqSet` scope) then
524 ((),addErr errs (\sty -> ppCat [ppr sty id,ppStr "is out of scope"]) loc)
528 checkTys :: Type -> Type -> ErrMsg -> LintM ()
529 checkTys ty1 ty2 msg spec loc scope errs
530 = if ty1 `eqTy` ty2 then ((), errs) else ((), addErr errs msg loc)
534 mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
535 mkCaseAltMsg alts sty
536 = ppAbove (ppStr "Type of case alternatives not the same:")
539 mkCaseDataConMsg :: CoreExpr -> ErrMsg
540 mkCaseDataConMsg expr sty
541 = ppAbove (ppStr "A case scrutinee not of data constructor type:")
544 mkCaseNotPrimMsg :: TyCon -> ErrMsg
545 mkCaseNotPrimMsg tycon sty
546 = ppAbove (ppStr "A primitive case on a non-primitive type:")
549 mkCasePrimMsg :: TyCon -> ErrMsg
550 mkCasePrimMsg tycon sty
551 = ppAbove (ppStr "An algebraic case on a primitive type:")
554 mkCaseAbstractMsg :: TyCon -> ErrMsg
555 mkCaseAbstractMsg tycon sty
556 = ppAbove (ppStr "An algebraic case on some weird type:")
559 mkDefltMsg :: CoreCaseDefault -> ErrMsg
561 = ppAbove (ppStr "Binder in case default doesn't match type of scrutinee:")
564 mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
565 mkAppMsg fun arg expr sty
566 = ppAboves [ppStr "Argument values doesn't match argument type:",
567 ppHang (ppStr "Fun type:") 4 (ppr sty fun),
568 ppHang (ppStr "Arg type:") 4 (ppr sty arg),
569 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
571 mkTyAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
572 mkTyAppMsg ty arg expr sty
573 = ppAboves [ppStr "Illegal type application:",
574 ppHang (ppStr "Exp type:") 4 (ppr sty ty),
575 ppHang (ppStr "Arg type:") 4 (ppr sty arg),
576 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
578 mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg
579 mkUsageAppMsg ty u expr sty
580 = ppAboves [ppStr "Illegal usage application:",
581 ppHang (ppStr "Exp type:") 4 (ppr sty ty),
582 ppHang (ppStr "Usage exp:") 4 (ppr sty u),
583 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
585 mkAlgAltMsg1 :: Type -> ErrMsg
587 = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
590 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
591 mkAlgAltMsg2 ty con sty
593 ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
598 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
599 mkAlgAltMsg3 con alts sty
601 ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:",
606 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
607 mkAlgAltMsg4 ty arg sty
609 ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
614 mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
617 (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
620 mkRhsMsg :: Id -> Type -> ErrMsg
621 mkRhsMsg binder ty sty
623 [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
625 ppCat [ppStr "Binder's type:", ppr sty (idType binder)],
626 ppCat [ppStr "Rhs type:", ppr sty ty]]
628 mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
629 mkRhsPrimMsg binder rhs sty
630 = ppAboves [ppCat [ppStr "The type of this binder is primitive:",
632 ppCat [ppStr "Binder's type:", ppr sty (idType binder)]
635 mkSpecTyAppMsg :: CoreArg -> ErrMsg
636 mkSpecTyAppMsg arg sty
638 (ppStr "Unboxed types in a type application (after specialisation):")
641 pp_expr :: PprStyle -> CoreExpr -> Pretty
643 = pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr