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 ( 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,mkForAllTys,getForAllTy_maybe,
35 getFunTyExpandingDicts_maybe,
36 isPrimType,typeKind,instantiateTy,splitSigmaTy,
37 mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
38 maybeAppDataTyConExpandingDicts, eqTy
39 -- ,expandTy -- ToDo:rm
41 import TyCon ( isPrimTyCon )
42 import TyVar ( tyVarKind, GenTyVar{-instances-} )
43 import UniqSet ( emptyUniqSet, mkUniqSet, intersectUniqSets,
44 unionUniqSets, elementOfUniqSet, UniqSet(..)
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 = _trace "lintCoreExpr:Coerce" $
191 lintCoreExpr expr `seqL` returnL (Just ty)
193 lintCoreExpr (Let binds body)
194 = lintCoreBinding binds `thenL` \binders ->
195 if (null binders) then
196 lintCoreExpr body -- Can't add a new source location
198 addLoc (BodyOfLetRec binders)
199 (addInScopeVars binders (lintCoreExpr body))
201 lintCoreExpr e@(Con con args)
202 = lintCoreArgs {-False-} e unoverloaded_ty args
203 -- Note: we don't check for primitive types in these arguments
205 -- Constructors are special in that they aren't passed their
206 -- dictionary arguments, so we swizzle them out of the
207 -- constructor type before handing over to lintCorArgs
208 unoverloaded_ty = mkForAllTys tyvars tau
209 (tyvars, theta, tau) = splitSigmaTy (idType con)
211 lintCoreExpr e@(Prim op args)
212 = lintCoreArgs {-True-} e (primOpType op) args
213 -- Note: we do check for primitive types in these arguments
215 lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
216 = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg {-False-} e ty arg
217 -- Note: we don't check for primitive types in argument to 'error'
219 lintCoreExpr e@(App fun arg)
220 = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg {-True-} e ty arg
221 -- Note: we do check for primitive types in this argument
223 lintCoreExpr (Lam (ValBinder var) expr)
224 = addLoc (LambdaBodyOf var)
225 (addInScopeVars [var]
226 (lintCoreExpr expr `thenMaybeL` \ty ->
227 returnL (Just (mkFunTy (idType var) ty))))
229 lintCoreExpr (Lam (TyBinder tyvar) expr)
230 = lintCoreExpr expr `thenMaybeL` \ty ->
231 returnL (Just(mkForAllTy tyvar ty))
232 -- ToDo: Should add in-scope type variable at this point
234 lintCoreExpr e@(Case scrut alts)
235 = lintCoreExpr scrut `thenMaybeL` \ty ->
239 %************************************************************************
241 \subsection[lintCoreArgs]{lintCoreArgs}
243 %************************************************************************
245 The boolean argument indicates whether we should flag type
246 applications to primitive types as being errors.
249 lintCoreArgs :: {-Bool ->-} CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
251 lintCoreArgs _ ty [] = returnL (Just ty)
252 lintCoreArgs e ty (a : args)
253 = lintCoreArg e ty a `thenMaybeL` \ res ->
254 lintCoreArgs e res args
257 %************************************************************************
259 \subsection[lintCoreArg]{lintCoreArg}
261 %************************************************************************
264 lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
266 lintCoreArg e ty (LitArg lit)
267 = -- Make sure function type matches argument
268 case (getFunTyExpandingDicts_maybe ty) of
269 Just (arg,res) | (lit_ty `eqTy` arg) -> returnL(Just res)
270 _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing
272 lit_ty = literalType lit
274 lintCoreArg e ty (VarArg v)
275 = -- Make sure variable is bound
276 checkInScope v `seqL`
277 -- Make sure function type matches argument
278 case (getFunTyExpandingDicts_maybe ty) of
279 Just (arg,res) | (var_ty `eqTy` arg) -> returnL(Just res)
280 _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing
284 lintCoreArg e ty a@(TyArg arg_ty)
285 = -- ToDo: Check that ty is well-kinded and has no unbound tyvars
286 checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a)
288 case (getForAllTy_maybe ty) of
289 Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
293 tyvar_kind = tyVarKind tyvar
294 argty_kind = typeKind arg_ty
296 if tyvar_kind == argty_kind
297 -- SUSPICIOUS! (tyvar_kind `isSubKindOf` argty_kind
298 -- || argty_kind `isSubKindOf` tyvar_kind)
300 returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
302 pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $
303 addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing
305 lintCoreArg e ty (UsageArg u)
306 = -- ToDo: Check that usage has no unbound usage variables
307 case (getForAllUsageTy ty) of
308 Just (uvar,bounds,body) ->
309 -- ToDo: Check argument satisfies bounds
310 returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body"))
311 _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing
314 %************************************************************************
316 \subsection[lintCoreAlts]{lintCoreAlts}
318 %************************************************************************
321 lintCoreAlts :: CoreCaseAlts
322 -> Type -- Type of scrutinee
323 -- -> TyCon -- TyCon pinned on the case
324 -> LintM (Maybe Type) -- Type of alternatives
326 lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon
327 = -- Check tycon is not a primitive tycon
328 -- addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
330 -- Check we are scrutinising a proper datatype
332 -- addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
335 `thenL` \maybe_deflt_ty ->
336 mapL (lintAlgAlt ty {-tycon-}) alts
337 `thenL` \maybe_alt_tys ->
338 -- Check the result types
339 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
340 [] -> returnL Nothing
342 (first_ty:tys) -> mapL check tys `seqL`
343 returnL (Just first_ty)
345 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
347 lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
348 = -- Check tycon is a primitive tycon
349 -- addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
351 mapL (lintPrimAlt ty) alts
352 `thenL` \maybe_alt_tys ->
354 `thenL` \maybe_deflt_ty ->
355 -- Check the result types
356 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
357 [] -> returnL Nothing
359 (first_ty:tys) -> mapL check tys `seqL`
360 returnL (Just first_ty)
362 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
364 lintAlgAlt scrut_ty {-tycon-ToDo: use it!-} (con,args,rhs)
365 = (case maybeAppDataTyConExpandingDicts scrut_ty of
367 addErrL (mkAlgAltMsg1 scrut_ty)
368 Just (tycon, tys_applied, cons) ->
370 arg_tys = dataConArgTys con tys_applied
372 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
373 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
375 mapL check (zipEqual "lintAlgAlt" arg_tys args) `seqL`
378 addInScopeVars args (
382 check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
384 -- elem: yes, the elem-list here can sometimes be long-ish,
385 -- but as it's use-once, probably not worth doing anything different
386 -- We give it its own copy, so it isn't overloaded.
388 elem x (y:ys) = x==y || elem x ys
390 lintPrimAlt ty alt@(lit,rhs)
391 = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
394 lintDeflt NoDefault _ = returnL Nothing
395 lintDeflt deflt@(BindDefault binder rhs) ty
396 = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
397 addInScopeVars [binder] (lintCoreExpr rhs)
400 %************************************************************************
402 \subsection[lint-monad]{The Lint monad}
404 %************************************************************************
407 type LintM a = Bool -- True <=> specialisation has been done
408 -> [LintLocInfo] -- Locations
409 -> UniqSet Id -- Local vars in scope
410 -> Bag ErrMsg -- Error messages so far
411 -> (a, Bag ErrMsg) -- Result and error messages (if any)
413 type ErrMsg = PprStyle -> Pretty
416 = RhsOf Id -- The variable bound
417 | LambdaBodyOf Id -- The lambda-binder
418 | BodyOfLetRec [Id] -- One of the binders
419 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
421 instance Outputable LintLocInfo where
423 = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
425 ppr sty (LambdaBodyOf b)
426 = ppBesides [ppr sty (getSrcLoc b),
427 ppStr ": [in body of lambda with binder ", pp_binder sty b, ppStr "]"]
429 ppr sty (BodyOfLetRec bs)
430 = ppBesides [ppr sty (getSrcLoc (head bs)),
431 ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"]
433 ppr sty (ImportedUnfolding locn)
434 = ppBeside (ppr sty locn) (ppStr ": [in an imported unfolding]")
436 pp_binders :: PprStyle -> [Id] -> Pretty
437 pp_binders sty bs = ppInterleave ppComma (map (pp_binder sty) bs)
439 pp_binder :: PprStyle -> Id -> Pretty
440 pp_binder sty b = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
444 initL :: LintM a -> Bool -> Maybe ErrMsg
446 = case (m spec_done [] emptyUniqSet emptyBag) of { (_, errs) ->
447 if isEmptyBag errs then
451 ppAboves [ msg sty | msg <- bagToList errs ]
455 returnL :: a -> LintM a
456 returnL r spec loc scope errs = (r, errs)
458 thenL :: LintM a -> (a -> LintM b) -> LintM b
459 thenL m k spec loc scope errs
460 = case m spec loc scope errs of
461 (r, errs') -> k r spec loc scope errs'
463 seqL :: LintM a -> LintM b -> LintM b
464 seqL m k spec loc scope errs
465 = case m spec loc scope errs of
466 (_, errs') -> k spec loc scope errs'
468 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
469 thenMaybeL m k spec loc scope errs
470 = case m spec loc scope errs of
471 (Nothing, errs2) -> (Nothing, errs2)
472 (Just r, errs2) -> k r spec loc scope errs2
474 seqMaybeL :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
475 seqMaybeL m k spec loc scope errs
476 = case m spec loc scope errs of
477 (Nothing, errs2) -> (Nothing, errs2)
478 (Just _, errs2) -> k spec loc scope errs2
480 mapL :: (a -> LintM b) -> [a] -> LintM [b]
481 mapL f [] = returnL []
484 mapL f xs `thenL` \ rs ->
487 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
488 -- Returns Nothing if anything fails
489 mapMaybeL f [] = returnL (Just [])
491 = f x `thenMaybeL` \ r ->
492 mapMaybeL f xs `thenMaybeL` \ rs ->
493 returnL (Just (r:rs))
497 checkL :: Bool -> ErrMsg -> LintM ()
498 checkL True msg spec loc scope errs = ((), errs)
499 checkL False msg spec loc scope errs = ((), addErr errs msg loc)
501 checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
502 checkIfSpecDoneL True msg spec loc scope errs = ((), errs)
503 checkIfSpecDoneL False msg True loc scope errs = ((), addErr errs msg loc)
504 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
507 = if pred then addErrL spec else returnL ()
509 addErrL :: ErrMsg -> LintM ()
510 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
512 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
514 addErr errs_so_far msg locs
515 = ASSERT (not (null locs))
516 errs_so_far `snocBag` ( \ sty ->
517 ppHang (ppr sty (head locs)) 4 (msg sty)
520 addLoc :: LintLocInfo -> LintM a -> LintM a
521 addLoc extra_loc m spec loc scope errs
522 = m spec (extra_loc:loc) scope errs
524 addInScopeVars :: [Id] -> LintM a -> LintM a
525 addInScopeVars ids m spec loc scope errs
526 = -- We check if these "new" ids are already
527 -- in scope, i.e., we have *shadowing* going on.
528 -- For now, it's just a "trace"; we may make
529 -- a real error out of it...
531 new_set = mkUniqSet ids
533 shadowed = scope `intersectUniqSets` new_set
535 -- After adding -fliberate-case, Simon decided he likes shadowed
536 -- names after all. WDP 94/07
537 -- (if isEmptyUniqSet shadowed
539 -- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
540 m spec loc (scope `unionUniqSets` new_set) errs
545 checkInScope :: Id -> LintM ()
546 checkInScope id spec loc scope errs
547 = if isLocallyDefined id && not (id `elementOfUniqSet` scope) then
548 ((),addErr errs (\sty -> ppCat [ppr sty id,ppStr "is out of scope"]) loc)
552 checkTys :: Type -> Type -> ErrMsg -> LintM ()
553 checkTys ty1 ty2 msg spec loc scope errs
554 = if ty1 `eqTy` ty2 then ((), errs) else ((), addErr errs msg loc)
558 mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
559 mkCaseAltMsg alts sty
560 = ppAbove (ppStr "Type of case alternatives not the same:")
563 mkCaseDataConMsg :: CoreExpr -> ErrMsg
564 mkCaseDataConMsg expr sty
565 = ppAbove (ppStr "A case scrutinee not of data constructor type:")
568 mkCaseNotPrimMsg :: TyCon -> ErrMsg
569 mkCaseNotPrimMsg tycon sty
570 = ppAbove (ppStr "A primitive case on a non-primitive type:")
573 mkCasePrimMsg :: TyCon -> ErrMsg
574 mkCasePrimMsg tycon sty
575 = ppAbove (ppStr "An algebraic case on a primitive type:")
578 mkCaseAbstractMsg :: TyCon -> ErrMsg
579 mkCaseAbstractMsg tycon sty
580 = ppAbove (ppStr "An algebraic case on some weird type:")
583 mkDefltMsg :: CoreCaseDefault -> ErrMsg
585 = ppAbove (ppStr "Binder in case default doesn't match type of scrutinee:")
588 mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
589 mkAppMsg fun arg expr sty
590 = ppAboves [ppStr "Argument value doesn't match argument type:",
591 ppHang (ppStr "Fun type:") 4 (ppr sty fun),
592 ppHang (ppStr "Arg type:") 4 (ppr sty arg),
593 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
595 mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg
596 mkTyAppMsg msg ty arg expr sty
597 = ppAboves [ppCat [ppPStr msg, ppStr "type application:"],
598 ppHang (ppStr "Exp type:") 4 (ppr sty ty),
599 ppHang (ppStr "Arg type:") 4 (ppr sty arg),
600 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
602 mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg
603 mkUsageAppMsg ty u expr sty
604 = ppAboves [ppStr "Illegal usage application:",
605 ppHang (ppStr "Exp type:") 4 (ppr sty ty),
606 ppHang (ppStr "Usage exp:") 4 (ppr sty u),
607 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
609 mkAlgAltMsg1 :: Type -> ErrMsg
611 = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
613 -- (ppAbove (ppr sty ty) (ppr sty (expandTy ty))) -- ToDo: rm
615 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
616 mkAlgAltMsg2 ty con sty
618 ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
623 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
624 mkAlgAltMsg3 con alts sty
626 ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:",
631 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
632 mkAlgAltMsg4 ty arg sty
634 ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
639 mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
642 (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
645 mkRhsMsg :: Id -> Type -> ErrMsg
646 mkRhsMsg binder ty sty
648 [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
650 ppCat [ppStr "Binder's type:", ppr sty (idType binder)],
651 ppCat [ppStr "Rhs type:", ppr sty ty]]
653 mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
654 mkRhsPrimMsg binder rhs sty
655 = ppAboves [ppCat [ppStr "The type of this binder is primitive:",
657 ppCat [ppStr "Binder's type:", ppr sty (idType binder)]
660 mkSpecTyAppMsg :: CoreArg -> ErrMsg
661 mkSpecTyAppMsg arg sty
663 (ppStr "Unboxed types in a type application (after specialisation):")
666 pp_expr :: PprStyle -> CoreExpr -> Pretty
668 = pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr