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 | pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug (getTyVarKind tyvar), ppr PprDebug (getTypeKind arg_ty)]) False -> panic "impossible"
280 _ -> addErrL (mkTyAppMsg ty arg_ty e) `seqL` returnL Nothing
282 lintCoreArg _ e ty (UsageArg u)
283 = -- ToDo: Check that usage has no unbound usage variables
284 case (getForAllUsageTy ty) of
285 Just (uvar,bounds,body) ->
286 -- ToDo: Check argument satisfies bounds
287 returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body"))
288 _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing
291 %************************************************************************
293 \subsection[lintCoreAlts]{lintCoreAlts}
295 %************************************************************************
298 lintCoreAlts :: CoreCaseAlts
299 -> Type -- Type of scrutinee
300 -> TyCon -- TyCon pinned on the case
301 -> LintM (Maybe Type) -- Type of alternatives
303 lintCoreAlts whole_alts@(AlgAlts alts deflt) ty tycon
304 = -- Check tycon is not a primitive tycon
305 addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
307 -- Check we are scrutinising a proper datatype
309 addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
312 `thenL` \maybe_deflt_ty ->
313 mapL (lintAlgAlt ty tycon) alts
314 `thenL` \maybe_alt_tys ->
315 -- Check the result types
316 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
317 [] -> returnL Nothing
319 (first_ty:tys) -> mapL check tys `seqL`
320 returnL (Just first_ty)
322 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
324 lintCoreAlts whole_alts@(PrimAlts alts deflt) ty tycon
325 = -- Check tycon is a primitive tycon
326 addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
328 mapL (lintPrimAlt ty) alts
329 `thenL` \maybe_alt_tys ->
331 `thenL` \maybe_deflt_ty ->
332 -- Check the result types
333 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
334 [] -> returnL Nothing
336 (first_ty:tys) -> mapL check tys `seqL`
337 returnL (Just first_ty)
339 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
341 lintAlgAlt scrut_ty tycon{-ToDo: use it!-} (con,args,rhs)
342 = (case maybeAppDataTyCon scrut_ty of
344 addErrL (mkAlgAltMsg1 scrut_ty)
345 Just (tycon, tys_applied, cons) ->
347 arg_tys = dataConArgTys con tys_applied
349 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
350 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
352 mapL check (arg_tys `zipEqual` args) `seqL`
355 addInScopeVars args (
359 check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
361 -- elem: yes, the elem-list here can sometimes be long-ish,
362 -- but as it's use-once, probably not worth doing anything different
363 -- We give it its own copy, so it isn't overloaded.
365 elem x (y:ys) = x==y || elem x ys
367 lintPrimAlt ty alt@(lit,rhs)
368 = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
371 lintDeflt NoDefault _ = returnL Nothing
372 lintDeflt deflt@(BindDefault binder rhs) ty
373 = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
374 addInScopeVars [binder] (lintCoreExpr rhs)
377 %************************************************************************
379 \subsection[lint-monad]{The Lint monad}
381 %************************************************************************
384 type LintM a = Bool -- True <=> specialisation has been done
385 -> [LintLocInfo] -- Locations
386 -> UniqSet Id -- Local vars in scope
387 -> Bag ErrMsg -- Error messages so far
388 -> (a, Bag ErrMsg) -- Result and error messages (if any)
390 type ErrMsg = PprStyle -> Pretty
393 = RhsOf Id -- The variable bound
394 | LambdaBodyOf Id -- The lambda-binder
395 | BodyOfLetRec [Id] -- One of the binders
396 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
398 instance Outputable LintLocInfo where
400 = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
402 ppr sty (LambdaBodyOf b)
403 = ppBesides [ppr sty (getSrcLoc b),
404 ppStr ": [in body of lambda with binder ", pp_binder sty b, ppStr "]"]
406 ppr sty (BodyOfLetRec bs)
407 = ppBesides [ppr sty (getSrcLoc (head bs)),
408 ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"]
410 ppr sty (ImportedUnfolding locn)
411 = ppBeside (ppr sty locn) (ppStr ": [in an imported unfolding]")
413 pp_binders :: PprStyle -> [Id] -> Pretty
414 pp_binders sty bs = ppInterleave ppComma (map (pp_binder sty) bs)
416 pp_binder :: PprStyle -> Id -> Pretty
417 pp_binder sty b = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
421 initL :: LintM a -> Bool -> Maybe ErrMsg
423 = case (m spec_done [] emptyUniqSet emptyBag) of { (_, errs) ->
424 if isEmptyBag errs then
428 ppAboves [ msg sty | msg <- bagToList errs ]
432 returnL :: a -> LintM a
433 returnL r spec loc scope errs = (r, errs)
435 thenL :: LintM a -> (a -> LintM b) -> LintM b
436 thenL m k spec loc scope errs
437 = case m spec loc scope errs of
438 (r, errs') -> k r spec loc scope errs'
440 seqL :: LintM a -> LintM b -> LintM b
441 seqL m k spec loc scope errs
442 = case m spec loc scope errs of
443 (_, errs') -> k spec loc scope errs'
445 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
446 thenMaybeL m k spec loc scope errs
447 = case m spec loc scope errs of
448 (Nothing, errs2) -> (Nothing, errs2)
449 (Just r, errs2) -> k r spec loc scope errs2
451 seqMaybeL :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
452 seqMaybeL m k spec loc scope errs
453 = case m spec loc scope errs of
454 (Nothing, errs2) -> (Nothing, errs2)
455 (Just _, errs2) -> k spec loc scope errs2
457 mapL :: (a -> LintM b) -> [a] -> LintM [b]
458 mapL f [] = returnL []
461 mapL f xs `thenL` \ rs ->
464 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
465 -- Returns Nothing if anything fails
466 mapMaybeL f [] = returnL (Just [])
468 = f x `thenMaybeL` \ r ->
469 mapMaybeL f xs `thenMaybeL` \ rs ->
470 returnL (Just (r:rs))
474 checkL :: Bool -> ErrMsg -> LintM ()
475 checkL True msg spec loc scope errs = ((), errs)
476 checkL False msg spec loc scope errs = ((), addErr errs msg loc)
478 checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
479 checkIfSpecDoneL True msg spec loc scope errs = ((), errs)
480 checkIfSpecDoneL False msg True loc scope errs = ((), addErr errs msg loc)
481 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
484 = if pred then addErrL spec else returnL ()
486 addErrL :: ErrMsg -> LintM ()
487 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
489 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
491 addErr errs_so_far msg locs
492 = ASSERT (not (null locs))
493 errs_so_far `snocBag` ( \ sty ->
494 ppHang (ppr sty (head locs)) 4 (msg sty)
497 addLoc :: LintLocInfo -> LintM a -> LintM a
498 addLoc extra_loc m spec loc scope errs
499 = m spec (extra_loc:loc) scope errs
501 addInScopeVars :: [Id] -> LintM a -> LintM a
502 addInScopeVars ids m spec loc scope errs
503 = -- We check if these "new" ids are already
504 -- in scope, i.e., we have *shadowing* going on.
505 -- For now, it's just a "trace"; we may make
506 -- a real error out of it...
508 new_set = mkUniqSet ids
510 shadowed = scope `intersectUniqSets` new_set
512 -- After adding -fliberate-case, Simon decided he likes shadowed
513 -- names after all. WDP 94/07
514 -- (if isEmptyUniqSet shadowed
516 -- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
517 m spec loc (scope `unionUniqSets` new_set) errs
522 checkInScope :: Id -> LintM ()
523 checkInScope id spec loc scope errs
524 = if isLocallyDefined id && not (id `elementOfUniqSet` scope) then
525 ((),addErr errs (\sty -> ppCat [ppr sty id,ppStr "is out of scope"]) loc)
529 checkTys :: Type -> Type -> ErrMsg -> LintM ()
530 checkTys ty1 ty2 msg spec loc scope errs
531 = if ty1 `eqTy` ty2 then ((), errs) else ((), addErr errs msg loc)
535 mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
536 mkCaseAltMsg alts sty
537 = ppAbove (ppStr "Type of case alternatives not the same:")
540 mkCaseDataConMsg :: CoreExpr -> ErrMsg
541 mkCaseDataConMsg expr sty
542 = ppAbove (ppStr "A case scrutinee not of data constructor type:")
545 mkCaseNotPrimMsg :: TyCon -> ErrMsg
546 mkCaseNotPrimMsg tycon sty
547 = ppAbove (ppStr "A primitive case on a non-primitive type:")
550 mkCasePrimMsg :: TyCon -> ErrMsg
551 mkCasePrimMsg tycon sty
552 = ppAbove (ppStr "An algebraic case on a primitive type:")
555 mkCaseAbstractMsg :: TyCon -> ErrMsg
556 mkCaseAbstractMsg tycon sty
557 = ppAbove (ppStr "An algebraic case on some weird type:")
560 mkDefltMsg :: CoreCaseDefault -> ErrMsg
562 = ppAbove (ppStr "Binder in case default doesn't match type of scrutinee:")
565 mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
566 mkAppMsg fun arg expr sty
567 = ppAboves [ppStr "Argument values doesn't match argument type:",
568 ppHang (ppStr "Fun type:") 4 (ppr sty fun),
569 ppHang (ppStr "Arg type:") 4 (ppr sty arg),
570 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
572 mkTyAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
573 mkTyAppMsg ty arg expr sty
574 = ppAboves [ppStr "Illegal type application:",
575 ppHang (ppStr "Exp type:") 4 (ppr sty ty),
576 ppHang (ppStr "Arg type:") 4 (ppr sty arg),
577 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
579 mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg
580 mkUsageAppMsg ty u expr sty
581 = ppAboves [ppStr "Illegal usage application:",
582 ppHang (ppStr "Exp type:") 4 (ppr sty ty),
583 ppHang (ppStr "Usage exp:") 4 (ppr sty u),
584 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
586 mkAlgAltMsg1 :: Type -> ErrMsg
588 = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
591 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
592 mkAlgAltMsg2 ty con sty
594 ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
599 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
600 mkAlgAltMsg3 con alts sty
602 ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:",
607 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
608 mkAlgAltMsg4 ty arg sty
610 ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
615 mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
618 (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
621 mkRhsMsg :: Id -> Type -> ErrMsg
622 mkRhsMsg binder ty sty
624 [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
626 ppCat [ppStr "Binder's type:", ppr sty (idType binder)],
627 ppCat [ppStr "Rhs type:", ppr sty ty]]
629 mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
630 mkRhsPrimMsg binder rhs sty
631 = ppAboves [ppCat [ppStr "The type of this binder is primitive:",
633 ppCat [ppStr "Binder's type:", ppr sty (idType binder)]
636 mkSpecTyAppMsg :: CoreArg -> ErrMsg
637 mkSpecTyAppMsg arg sty
639 (ppStr "Unboxed types in a type application (after specialisation):")
642 pp_expr :: PprStyle -> CoreExpr -> Pretty
644 = pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr