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 ( isSubKindOf, 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,typeKind,instantiateTy,
36 mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
37 maybeAppDataTyCon, eqTy
39 import TyCon ( isPrimTyCon, tyConFamilySize )
40 import TyVar ( tyVarKind, 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 Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
280 if (tyVarKind tyvar `isSubKindOf` typeKind arg_ty) then
281 returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
283 pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug (tyVarKind tyvar), ppr PprDebug (typeKind arg_ty)]) $
284 addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing
286 lintCoreArg _ e ty (UsageArg u)
287 = -- ToDo: Check that usage has no unbound usage variables
288 case (getForAllUsageTy ty) of
289 Just (uvar,bounds,body) ->
290 -- ToDo: Check argument satisfies bounds
291 returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body"))
292 _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing
295 %************************************************************************
297 \subsection[lintCoreAlts]{lintCoreAlts}
299 %************************************************************************
302 lintCoreAlts :: CoreCaseAlts
303 -> Type -- Type of scrutinee
304 -> TyCon -- TyCon pinned on the case
305 -> LintM (Maybe Type) -- Type of alternatives
307 lintCoreAlts whole_alts@(AlgAlts alts deflt) ty tycon
308 = -- Check tycon is not a primitive tycon
309 addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
311 -- Check we are scrutinising a proper datatype
313 addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
316 `thenL` \maybe_deflt_ty ->
317 mapL (lintAlgAlt ty tycon) alts
318 `thenL` \maybe_alt_tys ->
319 -- Check the result types
320 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
321 [] -> returnL Nothing
323 (first_ty:tys) -> mapL check tys `seqL`
324 returnL (Just first_ty)
326 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
328 lintCoreAlts whole_alts@(PrimAlts alts deflt) ty tycon
329 = -- Check tycon is a primitive tycon
330 addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
332 mapL (lintPrimAlt ty) alts
333 `thenL` \maybe_alt_tys ->
335 `thenL` \maybe_deflt_ty ->
336 -- Check the result types
337 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
338 [] -> returnL Nothing
340 (first_ty:tys) -> mapL check tys `seqL`
341 returnL (Just first_ty)
343 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
345 lintAlgAlt scrut_ty tycon{-ToDo: use it!-} (con,args,rhs)
346 = (case maybeAppDataTyCon scrut_ty of
348 addErrL (mkAlgAltMsg1 scrut_ty)
349 Just (tycon, tys_applied, cons) ->
351 arg_tys = dataConArgTys con tys_applied
353 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
354 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
356 mapL check (arg_tys `zipEqual` args) `seqL`
359 addInScopeVars args (
363 check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
365 -- elem: yes, the elem-list here can sometimes be long-ish,
366 -- but as it's use-once, probably not worth doing anything different
367 -- We give it its own copy, so it isn't overloaded.
369 elem x (y:ys) = x==y || elem x ys
371 lintPrimAlt ty alt@(lit,rhs)
372 = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
375 lintDeflt NoDefault _ = returnL Nothing
376 lintDeflt deflt@(BindDefault binder rhs) ty
377 = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
378 addInScopeVars [binder] (lintCoreExpr rhs)
381 %************************************************************************
383 \subsection[lint-monad]{The Lint monad}
385 %************************************************************************
388 type LintM a = Bool -- True <=> specialisation has been done
389 -> [LintLocInfo] -- Locations
390 -> UniqSet Id -- Local vars in scope
391 -> Bag ErrMsg -- Error messages so far
392 -> (a, Bag ErrMsg) -- Result and error messages (if any)
394 type ErrMsg = PprStyle -> Pretty
397 = RhsOf Id -- The variable bound
398 | LambdaBodyOf Id -- The lambda-binder
399 | BodyOfLetRec [Id] -- One of the binders
400 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
402 instance Outputable LintLocInfo where
404 = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
406 ppr sty (LambdaBodyOf b)
407 = ppBesides [ppr sty (getSrcLoc b),
408 ppStr ": [in body of lambda with binder ", pp_binder sty b, ppStr "]"]
410 ppr sty (BodyOfLetRec bs)
411 = ppBesides [ppr sty (getSrcLoc (head bs)),
412 ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"]
414 ppr sty (ImportedUnfolding locn)
415 = ppBeside (ppr sty locn) (ppStr ": [in an imported unfolding]")
417 pp_binders :: PprStyle -> [Id] -> Pretty
418 pp_binders sty bs = ppInterleave ppComma (map (pp_binder sty) bs)
420 pp_binder :: PprStyle -> Id -> Pretty
421 pp_binder sty b = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
425 initL :: LintM a -> Bool -> Maybe ErrMsg
427 = case (m spec_done [] emptyUniqSet emptyBag) of { (_, errs) ->
428 if isEmptyBag errs then
432 ppAboves [ msg sty | msg <- bagToList errs ]
436 returnL :: a -> LintM a
437 returnL r spec loc scope errs = (r, errs)
439 thenL :: LintM a -> (a -> LintM b) -> LintM b
440 thenL m k spec loc scope errs
441 = case m spec loc scope errs of
442 (r, errs') -> k r spec loc scope errs'
444 seqL :: LintM a -> LintM b -> LintM b
445 seqL m k spec loc scope errs
446 = case m spec loc scope errs of
447 (_, errs') -> k spec loc scope errs'
449 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
450 thenMaybeL m k spec loc scope errs
451 = case m spec loc scope errs of
452 (Nothing, errs2) -> (Nothing, errs2)
453 (Just r, errs2) -> k r spec loc scope errs2
455 seqMaybeL :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
456 seqMaybeL m k spec loc scope errs
457 = case m spec loc scope errs of
458 (Nothing, errs2) -> (Nothing, errs2)
459 (Just _, errs2) -> k spec loc scope errs2
461 mapL :: (a -> LintM b) -> [a] -> LintM [b]
462 mapL f [] = returnL []
465 mapL f xs `thenL` \ rs ->
468 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
469 -- Returns Nothing if anything fails
470 mapMaybeL f [] = returnL (Just [])
472 = f x `thenMaybeL` \ r ->
473 mapMaybeL f xs `thenMaybeL` \ rs ->
474 returnL (Just (r:rs))
478 checkL :: Bool -> ErrMsg -> LintM ()
479 checkL True msg spec loc scope errs = ((), errs)
480 checkL False msg spec loc scope errs = ((), addErr errs msg loc)
482 checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
483 checkIfSpecDoneL True msg spec loc scope errs = ((), errs)
484 checkIfSpecDoneL False msg True loc scope errs = ((), addErr errs msg loc)
485 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
488 = if pred then addErrL spec else returnL ()
490 addErrL :: ErrMsg -> LintM ()
491 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
493 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
495 addErr errs_so_far msg locs
496 = ASSERT (not (null locs))
497 errs_so_far `snocBag` ( \ sty ->
498 ppHang (ppr sty (head locs)) 4 (msg sty)
501 addLoc :: LintLocInfo -> LintM a -> LintM a
502 addLoc extra_loc m spec loc scope errs
503 = m spec (extra_loc:loc) scope errs
505 addInScopeVars :: [Id] -> LintM a -> LintM a
506 addInScopeVars ids m spec loc scope errs
507 = -- We check if these "new" ids are already
508 -- in scope, i.e., we have *shadowing* going on.
509 -- For now, it's just a "trace"; we may make
510 -- a real error out of it...
512 new_set = mkUniqSet ids
514 shadowed = scope `intersectUniqSets` new_set
516 -- After adding -fliberate-case, Simon decided he likes shadowed
517 -- names after all. WDP 94/07
518 -- (if isEmptyUniqSet shadowed
520 -- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
521 m spec loc (scope `unionUniqSets` new_set) errs
526 checkInScope :: Id -> LintM ()
527 checkInScope id spec loc scope errs
528 = if isLocallyDefined id && not (id `elementOfUniqSet` scope) then
529 ((),addErr errs (\sty -> ppCat [ppr sty id,ppStr "is out of scope"]) loc)
533 checkTys :: Type -> Type -> ErrMsg -> LintM ()
534 checkTys ty1 ty2 msg spec loc scope errs
535 = if ty1 `eqTy` ty2 then ((), errs) else ((), addErr errs msg loc)
539 mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
540 mkCaseAltMsg alts sty
541 = ppAbove (ppStr "Type of case alternatives not the same:")
544 mkCaseDataConMsg :: CoreExpr -> ErrMsg
545 mkCaseDataConMsg expr sty
546 = ppAbove (ppStr "A case scrutinee not of data constructor type:")
549 mkCaseNotPrimMsg :: TyCon -> ErrMsg
550 mkCaseNotPrimMsg tycon sty
551 = ppAbove (ppStr "A primitive case on a non-primitive type:")
554 mkCasePrimMsg :: TyCon -> ErrMsg
555 mkCasePrimMsg tycon sty
556 = ppAbove (ppStr "An algebraic case on a primitive type:")
559 mkCaseAbstractMsg :: TyCon -> ErrMsg
560 mkCaseAbstractMsg tycon sty
561 = ppAbove (ppStr "An algebraic case on some weird type:")
564 mkDefltMsg :: CoreCaseDefault -> ErrMsg
566 = ppAbove (ppStr "Binder in case default doesn't match type of scrutinee:")
569 mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
570 mkAppMsg fun arg expr sty
571 = ppAboves [ppStr "Argument values doesn't match argument type:",
572 ppHang (ppStr "Fun type:") 4 (ppr sty fun),
573 ppHang (ppStr "Arg type:") 4 (ppr sty arg),
574 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
576 mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg
577 mkTyAppMsg msg ty arg expr sty
578 = ppAboves [ppCat [ppPStr msg, ppStr "type application:"],
579 ppHang (ppStr "Exp type:") 4 (ppr sty ty),
580 ppHang (ppStr "Arg type:") 4 (ppr sty arg),
581 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
583 mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg
584 mkUsageAppMsg ty u expr sty
585 = ppAboves [ppStr "Illegal usage application:",
586 ppHang (ppStr "Exp type:") 4 (ppr sty ty),
587 ppHang (ppStr "Usage exp:") 4 (ppr sty u),
588 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
590 mkAlgAltMsg1 :: Type -> ErrMsg
592 = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
595 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
596 mkAlgAltMsg2 ty con sty
598 ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
603 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
604 mkAlgAltMsg3 con alts sty
606 ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:",
611 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
612 mkAlgAltMsg4 ty arg sty
614 ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
619 mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
622 (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
625 mkRhsMsg :: Id -> Type -> ErrMsg
626 mkRhsMsg binder ty sty
628 [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
630 ppCat [ppStr "Binder's type:", ppr sty (idType binder)],
631 ppCat [ppStr "Rhs type:", ppr sty ty]]
633 mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
634 mkRhsPrimMsg binder rhs sty
635 = ppAboves [ppCat [ppStr "The type of this binder is primitive:",
637 ppCat [ppStr "Binder's type:", ppr sty (idType binder)]
640 mkSpecTyAppMsg :: CoreArg -> ErrMsg
641 mkSpecTyAppMsg arg sty
643 (ppStr "Unboxed types in a type application (after specialisation):")
646 pp_expr :: PprStyle -> CoreExpr -> Pretty
648 = pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr