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 getInstantiatedDataConSig, GenId{-instances-}
24 import Maybes ( catMaybes )
25 import Outputable ( Outputable(..) )
27 import PprStyle ( PprStyle(..) )
28 import PprType ( GenType, GenTyVar, TyCon )
30 import PrimOp ( primOpType, PrimOp(..) )
31 import PrimRep ( PrimRep(..) )
32 import SrcLoc ( SrcLoc )
33 import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,getForAllTy_maybe,
34 isPrimType,getTypeKind,instantiateTy,
35 mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
36 maybeAppDataTyCon, eqTy
38 import TyCon ( isPrimTyCon, tyConFamilySize )
39 import TyVar ( getTyVarKind, GenTyVar{-instances-} )
40 import UniqSet ( emptyUniqSet, mkUniqSet, intersectUniqSets,
41 unionUniqSets, elementOfUniqSet, UniqSet(..)
43 import Unique ( Unique )
44 import Usage ( GenUsage )
45 import Util ( zipEqual, pprTrace, pprPanic, assertPanic, panic )
47 infixr 9 `thenL`, `seqL`, `thenMaybeL`, `seqMaybeL`
50 %************************************************************************
52 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
54 %************************************************************************
56 Checks that a set of core bindings is well-formed. The PprStyle and String
57 just control what we print in the event of an error. The Bool value
58 indicates whether we have done any specialisation yet (in which case we do
63 (b) Out-of-scope type variables
64 (c) Out-of-scope local variables
67 If we have done specialisation the we check that there are
68 (a) No top-level bindings of primitive (unboxed type)
73 -- Things are *not* OK if:
75 -- * Unsaturated type app before specialisation has been done;
77 -- * Oversaturated type app after specialisation (eta reduction
78 -- may well be happening...);
80 -- Note: checkTyApp is usually followed by a call to checkSpecTyApp.
85 :: PprStyle -> String -> Bool -> [CoreBinding] -> [CoreBinding]
87 lintCoreBindings sty whoDunnit spec_done binds
88 = case (initL (lint_binds binds) spec_done) of
91 pprPanic "" (ppAboves [
92 ppStr ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"),
94 ppStr "*** Offending Program ***",
95 ppAboves (map (pprCoreBinding sty) binds),
96 ppStr "*** End of Offense ***"
99 lint_binds [] = returnL ()
100 lint_binds (bind:binds)
101 = lintCoreBinding bind `thenL` \binders ->
102 addInScopeVars binders (lint_binds binds)
105 %************************************************************************
107 \subsection[lintUnfolding]{lintUnfolding}
109 %************************************************************************
111 We use this to check all unfoldings that come in from interfaces
112 (it is very painful to catch errors otherwise):
115 lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
117 lintUnfolding locn expr
119 (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
120 True{-pretend spec done-})
124 pprTrace "WARNING: Discarded bad unfolding from interface:\n"
125 (ppAboves [msg PprForUser,
126 ppStr "*** Bad unfolding ***",
128 ppStr "*** End unfolding ***"])
132 %************************************************************************
134 \subsection[lintCoreBinding]{lintCoreBinding}
136 %************************************************************************
138 Check a core binding, returning the list of variables bound.
141 lintCoreBinding :: CoreBinding -> LintM [Id]
143 lintCoreBinding (NonRec binder rhs)
144 = lintSingleBinding (binder,rhs) `seqL` returnL [binder]
146 lintCoreBinding (Rec pairs)
147 = addInScopeVars binders (
148 mapL lintSingleBinding pairs `seqL` returnL binders
151 binders = [b | (b,_) <- pairs]
153 lintSingleBinding (binder,rhs)
154 = addLoc (RhsOf binder) (
159 -- Check match to RHS type
161 Nothing -> returnL ()
162 Just ty -> checkTys (idType binder) ty (mkRhsMsg binder ty))
165 -- Check (not isPrimType)
166 checkIfSpecDoneL (not (isPrimType (idType binder)))
167 (mkRhsPrimMsg binder rhs)
169 -- We should check the unfolding, if any, but this is tricky because
170 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
174 %************************************************************************
176 \subsection[lintCoreExpr]{lintCoreExpr}
178 %************************************************************************
181 lintCoreExpr :: CoreExpr -> LintM (Maybe Type) -- Nothing if error found
183 lintCoreExpr (Var var) = checkInScope var `seqL` returnL (Just (idType var))
184 lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
185 lintCoreExpr (SCC _ expr) = lintCoreExpr expr
187 lintCoreExpr (Let binds body)
188 = lintCoreBinding binds `thenL` \binders ->
189 if (null binders) then
190 lintCoreExpr body -- Can't add a new source location
192 addLoc (BodyOfLetRec binders)
193 (addInScopeVars binders (lintCoreExpr body))
195 lintCoreExpr e@(Con con args)
196 = lintCoreArgs False e (idType con) args
197 -- Note: we don't check for primitive types in these arguments
199 lintCoreExpr e@(Prim op args)
200 = lintCoreArgs True e (primOpType op) args
201 -- Note: we do check for primitive types in these arguments
203 lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
204 = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg False e ty arg
205 -- Note: we don't check for primitive types in argument to 'error'
207 lintCoreExpr e@(App fun arg)
208 = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg True e ty arg
209 -- Note: we do check for primitive types in this argument
211 lintCoreExpr (Lam (ValBinder var) expr)
212 = addLoc (LambdaBodyOf var)
213 (addInScopeVars [var]
214 (lintCoreExpr expr `thenMaybeL` \ty ->
215 returnL (Just (mkFunTy (idType var) ty))))
217 lintCoreExpr (Lam (TyBinder tyvar) expr)
218 = lintCoreExpr expr `thenMaybeL` \ty ->
219 returnL (Just(mkForAllTy tyvar ty))
220 -- TODO: Should add in-scope type variable at this point
222 lintCoreExpr e@(Case scrut alts)
223 = lintCoreExpr scrut `thenMaybeL` \ty ->
224 -- Check that it is a data type
225 case maybeAppDataTyCon ty of
226 Nothing -> addErrL (mkCaseDataConMsg e) `seqL` returnL Nothing
227 Just(tycon, _, _) -> lintCoreAlts alts ty tycon
230 %************************************************************************
232 \subsection[lintCoreArgs]{lintCoreArgs}
234 %************************************************************************
236 The boolean argument indicates whether we should flag type
237 applications to primitive types as being errors.
240 lintCoreArgs :: Bool -> CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
242 lintCoreArgs _ _ ty [] = returnL (Just ty)
243 lintCoreArgs checkTyApp e ty (a : args)
244 = lintCoreArg checkTyApp e ty a `thenMaybeL` \ res ->
245 lintCoreArgs checkTyApp e res args
248 %************************************************************************
250 \subsection[lintCoreArg]{lintCoreArg}
252 %************************************************************************
255 lintCoreArg :: Bool -> CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
257 lintCoreArg _ e ty (LitArg lit)
258 = -- Make sure function type matches argument
259 case (getFunTy_maybe ty) of
260 Just (arg,res) | (literalType lit `eqTy` arg) -> returnL(Just res)
261 _ -> addErrL (mkAppMsg ty (literalType lit) e) `seqL` returnL Nothing
263 lintCoreArg _ e ty (VarArg v)
264 = -- Make sure variable is bound
265 checkInScope v `seqL`
266 -- Make sure function type matches argument
267 case (getFunTy_maybe ty) of
268 Just (arg,res) | (idType v `eqTy` arg) -> returnL(Just res)
269 _ -> addErrL (mkAppMsg ty (idType v) e) `seqL` returnL Nothing
271 lintCoreArg checkTyApp e ty a@(TyArg arg_ty)
272 = -- TODO: Check that ty is well-kinded and has no unbound tyvars
273 checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a)
275 case (getForAllTy_maybe ty) of
276 Just (tyvar,body) | (getTyVarKind tyvar == getTypeKind arg_ty) ->
277 returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
278 _ -> addErrL (mkTyAppMsg ty arg_ty e) `seqL` returnL Nothing
280 lintCoreArg _ e ty (UsageArg u)
281 = -- TODO: Check that usage has no unbound usage variables
282 case (getForAllUsageTy ty) of
283 Just (uvar,bounds,body) ->
284 -- TODO Check argument satisfies bounds
285 returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body"))
286 _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing
289 %************************************************************************
291 \subsection[lintCoreAlts]{lintCoreAlts}
293 %************************************************************************
296 lintCoreAlts :: CoreCaseAlts
297 -> Type -- Type of scrutinee
298 -> TyCon -- TyCon pinned on the case
299 -> LintM (Maybe Type) -- Type of alternatives
301 lintCoreAlts whole_alts@(AlgAlts alts deflt) ty tycon
302 = -- Check tycon is not a primitive tycon
303 addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
305 -- Check we are scrutinising a proper datatype
307 addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
310 `thenL` \maybe_deflt_ty ->
311 mapL (lintAlgAlt ty tycon) alts
312 `thenL` \maybe_alt_tys ->
313 -- Check the result types
314 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
315 [] -> returnL Nothing
317 (first_ty:tys) -> mapL check tys `seqL`
318 returnL (Just first_ty)
320 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
322 lintCoreAlts whole_alts@(PrimAlts alts deflt) ty tycon
323 = -- Check tycon is a primitive tycon
324 addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
326 mapL (lintPrimAlt ty) alts
327 `thenL` \maybe_alt_tys ->
329 `thenL` \maybe_deflt_ty ->
330 -- Check the result types
331 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
332 [] -> returnL Nothing
334 (first_ty:tys) -> mapL check tys `seqL`
335 returnL (Just first_ty)
337 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
339 lintAlgAlt scrut_ty tycon{-ToDo: use it!-} (con,args,rhs)
340 = (case maybeAppDataTyCon scrut_ty of
342 addErrL (mkAlgAltMsg1 scrut_ty)
343 Just (tycon, tys_applied, cons) ->
345 (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
347 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
348 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
350 mapL check (arg_tys `zipEqual` args) `seqL`
353 addInScopeVars args (
357 check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
359 -- elem: yes, the elem-list here can sometimes be long-ish,
360 -- but as it's use-once, probably not worth doing anything different
361 -- We give it its own copy, so it isn't overloaded.
363 elem x (y:ys) = x==y || elem x ys
365 lintPrimAlt ty alt@(lit,rhs)
366 = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
369 lintDeflt NoDefault _ = returnL Nothing
370 lintDeflt deflt@(BindDefault binder rhs) ty
371 = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
372 addInScopeVars [binder] (lintCoreExpr rhs)
375 %************************************************************************
377 \subsection[lint-monad]{The Lint monad}
379 %************************************************************************
382 type LintM a = Bool -- True <=> specialisation has been done
383 -> [LintLocInfo] -- Locations
384 -> UniqSet Id -- Local vars in scope
385 -> Bag ErrMsg -- Error messages so far
386 -> (a, Bag ErrMsg) -- Result and error messages (if any)
388 type ErrMsg = PprStyle -> Pretty
391 = RhsOf Id -- The variable bound
392 | LambdaBodyOf Id -- The lambda-binder
393 | BodyOfLetRec [Id] -- One of the binders
394 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
396 instance Outputable LintLocInfo where
398 = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
400 ppr sty (LambdaBodyOf b)
401 = ppBesides [ppr sty (getSrcLoc b),
402 ppStr ": [in body of lambda with binder ", pp_binder sty b, ppStr "]"]
404 ppr sty (BodyOfLetRec bs)
405 = ppBesides [ppr sty (getSrcLoc (head bs)),
406 ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"]
408 ppr sty (ImportedUnfolding locn)
409 = ppBeside (ppr sty locn) (ppStr ": [in an imported unfolding]")
411 pp_binders :: PprStyle -> [Id] -> Pretty
412 pp_binders sty bs = ppInterleave ppComma (map (pp_binder sty) bs)
414 pp_binder :: PprStyle -> Id -> Pretty
415 pp_binder sty b = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
419 initL :: LintM a -> Bool -> Maybe ErrMsg
421 = case (m spec_done [] emptyUniqSet emptyBag) of { (_, errs) ->
422 if isEmptyBag errs then
426 ppAboves [ msg sty | msg <- bagToList errs ]
430 returnL :: a -> LintM a
431 returnL r spec loc scope errs = (r, errs)
433 thenL :: LintM a -> (a -> LintM b) -> LintM b
434 thenL m k spec loc scope errs
435 = case m spec loc scope errs of
436 (r, errs') -> k r spec loc scope errs'
438 seqL :: LintM a -> LintM b -> LintM b
439 seqL m k spec loc scope errs
440 = case m spec loc scope errs of
441 (_, errs') -> k spec loc scope errs'
443 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
444 thenMaybeL m k spec loc scope errs
445 = case m spec loc scope errs of
446 (Nothing, errs2) -> (Nothing, errs2)
447 (Just r, errs2) -> k r spec loc scope errs2
449 seqMaybeL :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
450 seqMaybeL m k spec loc scope errs
451 = case m spec loc scope errs of
452 (Nothing, errs2) -> (Nothing, errs2)
453 (Just _, errs2) -> k spec loc scope errs2
455 mapL :: (a -> LintM b) -> [a] -> LintM [b]
456 mapL f [] = returnL []
459 mapL f xs `thenL` \ rs ->
462 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
463 -- Returns Nothing if anything fails
464 mapMaybeL f [] = returnL (Just [])
466 = f x `thenMaybeL` \ r ->
467 mapMaybeL f xs `thenMaybeL` \ rs ->
468 returnL (Just (r:rs))
472 checkL :: Bool -> ErrMsg -> LintM ()
473 checkL True msg spec loc scope errs = ((), errs)
474 checkL False msg spec loc scope errs = ((), addErr errs msg loc)
476 checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
477 checkIfSpecDoneL True msg spec loc scope errs = ((), errs)
478 checkIfSpecDoneL False msg True loc scope errs = ((), addErr errs msg loc)
479 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
482 = if pred then addErrL spec else returnL ()
484 addErrL :: ErrMsg -> LintM ()
485 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
487 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
489 addErr errs_so_far msg locs
490 = ASSERT (not (null locs))
491 errs_so_far `snocBag` ( \ sty ->
492 ppHang (ppr sty (head locs)) 4 (msg sty)
495 addLoc :: LintLocInfo -> LintM a -> LintM a
496 addLoc extra_loc m spec loc scope errs
497 = m spec (extra_loc:loc) scope errs
499 addInScopeVars :: [Id] -> LintM a -> LintM a
500 addInScopeVars ids m spec loc scope errs
501 = -- We check if these "new" ids are already
502 -- in scope, i.e., we have *shadowing* going on.
503 -- For now, it's just a "trace"; we may make
504 -- a real error out of it...
506 new_set = mkUniqSet ids
508 shadowed = scope `intersectUniqSets` new_set
510 -- After adding -fliberate-case, Simon decided he likes shadowed
511 -- names after all. WDP 94/07
512 -- (if isEmptyUniqSet shadowed
514 -- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
515 m spec loc (scope `unionUniqSets` new_set) errs
520 checkInScope :: Id -> LintM ()
521 checkInScope id spec loc scope errs
522 = if isLocallyDefined id && not (id `elementOfUniqSet` scope) then
523 ((),addErr errs (\sty -> ppCat [ppr sty id,ppStr "is out of scope"]) loc)
527 checkTys :: Type -> Type -> ErrMsg -> LintM ()
528 checkTys ty1 ty2 msg spec loc scope errs
529 = if ty1 `eqTy` ty2 then ((), errs) else ((), addErr errs msg loc)
533 mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
534 mkCaseAltMsg alts sty
535 = ppAbove (ppStr "Type of case alternatives not the same:")
538 mkCaseDataConMsg :: CoreExpr -> ErrMsg
539 mkCaseDataConMsg expr sty
540 = ppAbove (ppStr "A case scrutinee not of data constructor type:")
543 mkCaseNotPrimMsg :: TyCon -> ErrMsg
544 mkCaseNotPrimMsg tycon sty
545 = ppAbove (ppStr "A primitive case on a non-primitive type:")
548 mkCasePrimMsg :: TyCon -> ErrMsg
549 mkCasePrimMsg tycon sty
550 = ppAbove (ppStr "An algebraic case on a primitive type:")
553 mkCaseAbstractMsg :: TyCon -> ErrMsg
554 mkCaseAbstractMsg tycon sty
555 = ppAbove (ppStr "An algebraic case on some weird type:")
558 mkDefltMsg :: CoreCaseDefault -> ErrMsg
560 = ppAbove (ppStr "Binder in case default doesn't match type of scrutinee:")
563 mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
564 mkAppMsg fun arg expr sty
565 = ppAboves [ppStr "Argument values doesn't match argument type:",
566 ppHang (ppStr "Fun type:") 4 (ppr sty fun),
567 ppHang (ppStr "Arg type:") 4 (ppr sty arg),
568 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
570 mkTyAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
571 mkTyAppMsg ty arg expr sty
574 = ppAboves [ppStr "Illegal type application:",
575 ppHang (ppStr "Exp type:") 4 (ppr sty exp),
576 ppHang (ppStr "Arg type:") 4 (ppr sty arg),
577 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
580 mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg
581 mkUsageAppMsg ty u expr sty
582 = ppAboves [ppStr "Illegal usage application:",
583 ppHang (ppStr "Exp type:") 4 (ppr sty ty),
584 ppHang (ppStr "Usage exp:") 4 (ppr sty u),
585 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
587 mkAlgAltMsg1 :: Type -> ErrMsg
589 = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
592 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
593 mkAlgAltMsg2 ty con sty
595 ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
600 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
601 mkAlgAltMsg3 con alts sty
603 ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:",
608 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
609 mkAlgAltMsg4 ty arg sty
611 ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
616 mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
619 (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
622 mkRhsMsg :: Id -> Type -> ErrMsg
623 mkRhsMsg binder ty sty
625 [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
627 ppCat [ppStr "Binder's type:", ppr sty (idType binder)],
628 ppCat [ppStr "Rhs type:", ppr sty ty]]
630 mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
631 mkRhsPrimMsg binder rhs sty
632 = ppAboves [ppCat [ppStr "The type of this binder is primitive:",
634 ppCat [ppStr "Binder's type:", ppr sty (idType binder)]
637 mkSpecTyAppMsg :: CoreArg -> ErrMsg
638 mkSpecTyAppMsg arg sty
640 (ppStr "Unboxed types in a type application (after specialisation):")
643 pp_expr :: PprStyle -> CoreExpr -> Pretty
645 = pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr