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 getForAllTyExpandingDicts_maybe,
37 isPrimType,typeKind,instantiateTy,splitSigmaTy,
38 mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
39 maybeAppDataTyConExpandingDicts, eqTy
40 -- ,expandTy -- ToDo:rm
42 import TyCon ( isPrimTyCon )
43 import TyVar ( tyVarKind, GenTyVar{-instances-} )
44 import UniqSet ( emptyUniqSet, mkUniqSet, intersectUniqSets,
45 unionUniqSets, elementOfUniqSet, UniqSet(..)
47 import Unique ( Unique )
48 import Usage ( GenUsage )
49 import Util ( zipEqual, pprTrace, pprPanic, assertPanic, panic )
51 infixr 9 `thenL`, `seqL`, `thenMaybeL`, `seqMaybeL`
54 %************************************************************************
56 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
58 %************************************************************************
60 Checks that a set of core bindings is well-formed. The PprStyle and String
61 just control what we print in the event of an error. The Bool value
62 indicates whether we have done any specialisation yet (in which case we do
67 (b) Out-of-scope type variables
68 (c) Out-of-scope local variables
71 If we have done specialisation the we check that there are
72 (a) No top-level bindings of primitive (unboxed type)
77 -- Things are *not* OK if:
79 -- * Unsaturated type app before specialisation has been done;
81 -- * Oversaturated type app after specialisation (eta reduction
82 -- may well be happening...);
84 -- Note: checkTyApp is usually followed by a call to checkSpecTyApp.
89 :: PprStyle -> String -> Bool -> [CoreBinding] -> [CoreBinding]
91 lintCoreBindings sty whoDunnit spec_done binds
92 = case (initL (lint_binds binds) spec_done) of
95 pprPanic "" (ppAboves [
96 ppStr ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"),
98 ppStr "*** Offending Program ***",
99 ppAboves (map (pprCoreBinding sty) binds),
100 ppStr "*** End of Offense ***"
103 lint_binds [] = returnL ()
104 lint_binds (bind:binds)
105 = lintCoreBinding bind `thenL` \binders ->
106 addInScopeVars binders (lint_binds binds)
109 %************************************************************************
111 \subsection[lintUnfolding]{lintUnfolding}
113 %************************************************************************
115 We use this to check all unfoldings that come in from interfaces
116 (it is very painful to catch errors otherwise):
119 lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
121 lintUnfolding locn expr
123 (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
124 True{-pretend spec done-})
128 pprTrace "WARNING: Discarded bad unfolding from interface:\n"
129 (ppAboves [msg PprForUser,
130 ppStr "*** Bad unfolding ***",
132 ppStr "*** End unfolding ***"])
136 %************************************************************************
138 \subsection[lintCoreBinding]{lintCoreBinding}
140 %************************************************************************
142 Check a core binding, returning the list of variables bound.
145 lintCoreBinding :: CoreBinding -> LintM [Id]
147 lintCoreBinding (NonRec binder rhs)
148 = lintSingleBinding (binder,rhs) `seqL` returnL [binder]
150 lintCoreBinding (Rec pairs)
151 = addInScopeVars binders (
152 mapL lintSingleBinding pairs `seqL` returnL binders
155 binders = [b | (b,_) <- pairs]
157 lintSingleBinding (binder,rhs)
158 = addLoc (RhsOf binder) (
163 -- Check match to RHS type
165 Nothing -> returnL ()
166 Just ty -> checkTys (idType binder) ty (mkRhsMsg binder ty))
169 -- Check (not isPrimType)
170 checkIfSpecDoneL (not (isPrimType (idType binder)))
171 (mkRhsPrimMsg binder rhs)
173 -- We should check the unfolding, if any, but this is tricky because
174 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
178 %************************************************************************
180 \subsection[lintCoreExpr]{lintCoreExpr}
182 %************************************************************************
185 lintCoreExpr :: CoreExpr -> LintM (Maybe Type) -- Nothing if error found
187 lintCoreExpr (Var var) = checkInScope var `seqL` returnL (Just (idType var))
188 lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
189 lintCoreExpr (SCC _ expr) = lintCoreExpr expr
190 lintCoreExpr (Coerce _ ty expr)
191 = _trace "lintCoreExpr:Coerce" $
192 lintCoreExpr expr `seqL` returnL (Just ty)
194 lintCoreExpr (Let binds body)
195 = lintCoreBinding binds `thenL` \binders ->
196 if (null binders) then
197 lintCoreExpr body -- Can't add a new source location
199 addLoc (BodyOfLetRec binders)
200 (addInScopeVars binders (lintCoreExpr body))
202 lintCoreExpr e@(Con con args)
203 = lintCoreArgs {-False-} e unoverloaded_ty args
204 -- Note: we don't check for primitive types in these arguments
206 -- Constructors are special in that they aren't passed their
207 -- dictionary arguments, so we swizzle them out of the
208 -- constructor type before handing over to lintCorArgs
209 unoverloaded_ty = mkForAllTys tyvars tau
210 (tyvars, theta, tau) = splitSigmaTy (idType con)
212 lintCoreExpr e@(Prim op args)
213 = lintCoreArgs {-True-} e (primOpType op) args
214 -- Note: we do check for primitive types in these arguments
216 lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
217 = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg {-False-} e ty arg
218 -- Note: we don't check for primitive types in argument to 'error'
220 lintCoreExpr e@(App fun arg)
221 = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg {-True-} e ty arg
222 -- Note: we do check for primitive types in this argument
224 lintCoreExpr (Lam (ValBinder var) expr)
225 = addLoc (LambdaBodyOf var)
226 (addInScopeVars [var]
227 (lintCoreExpr expr `thenMaybeL` \ty ->
228 returnL (Just (mkFunTy (idType var) ty))))
230 lintCoreExpr (Lam (TyBinder tyvar) expr)
231 = lintCoreExpr expr `thenMaybeL` \ty ->
232 returnL (Just(mkForAllTy tyvar ty))
233 -- ToDo: Should add in-scope type variable at this point
235 lintCoreExpr e@(Case scrut alts)
236 = lintCoreExpr scrut `thenMaybeL` \ty ->
240 %************************************************************************
242 \subsection[lintCoreArgs]{lintCoreArgs}
244 %************************************************************************
246 The boolean argument indicates whether we should flag type
247 applications to primitive types as being errors.
250 lintCoreArgs :: {-Bool ->-} CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
252 lintCoreArgs _ ty [] = returnL (Just ty)
253 lintCoreArgs e ty (a : args)
254 = lintCoreArg e ty a `thenMaybeL` \ res ->
255 lintCoreArgs e res args
258 %************************************************************************
260 \subsection[lintCoreArg]{lintCoreArg}
262 %************************************************************************
265 lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
267 lintCoreArg e ty (LitArg lit)
268 = -- Make sure function type matches argument
269 case (getFunTyExpandingDicts_maybe ty) of
270 Just (arg,res) | (lit_ty `eqTy` arg) -> returnL(Just res)
271 _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing
273 lit_ty = literalType lit
275 lintCoreArg e ty (VarArg v)
276 = -- Make sure variable is bound
277 checkInScope v `seqL`
278 -- Make sure function type matches argument
279 case (getFunTyExpandingDicts_maybe ty) of
280 Just (arg,res) | (var_ty `eqTy` arg) -> returnL(Just res)
281 _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing
285 lintCoreArg e ty a@(TyArg arg_ty)
286 = -- ToDo: Check that ty is well-kinded and has no unbound tyvars
287 checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a)
289 case (getForAllTyExpandingDicts_maybe ty) of
290 Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
294 tyvar_kind = tyVarKind tyvar
295 argty_kind = typeKind arg_ty
297 if tyvar_kind == argty_kind
298 -- SUSPICIOUS! (tyvar_kind `isSubKindOf` argty_kind
299 -- || argty_kind `isSubKindOf` tyvar_kind)
301 returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
303 pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $
304 addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing
306 lintCoreArg e ty (UsageArg u)
307 = -- ToDo: Check that usage has no unbound usage variables
308 case (getForAllUsageTy ty) of
309 Just (uvar,bounds,body) ->
310 -- ToDo: Check argument satisfies bounds
311 returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body"))
312 _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing
315 %************************************************************************
317 \subsection[lintCoreAlts]{lintCoreAlts}
319 %************************************************************************
322 lintCoreAlts :: CoreCaseAlts
323 -> Type -- Type of scrutinee
324 -- -> TyCon -- TyCon pinned on the case
325 -> LintM (Maybe Type) -- Type of alternatives
327 lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon
328 = -- Check tycon is not a primitive tycon
329 -- addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
331 -- Check we are scrutinising a proper datatype
333 -- addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
336 `thenL` \maybe_deflt_ty ->
337 mapL (lintAlgAlt ty {-tycon-}) alts
338 `thenL` \maybe_alt_tys ->
339 -- Check the result types
340 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
341 [] -> returnL Nothing
343 (first_ty:tys) -> mapL check tys `seqL`
344 returnL (Just first_ty)
346 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
348 lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
349 = -- Check tycon is a primitive tycon
350 -- addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
352 mapL (lintPrimAlt ty) alts
353 `thenL` \maybe_alt_tys ->
355 `thenL` \maybe_deflt_ty ->
356 -- Check the result types
357 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
358 [] -> returnL Nothing
360 (first_ty:tys) -> mapL check tys `seqL`
361 returnL (Just first_ty)
363 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
365 lintAlgAlt scrut_ty {-tycon-ToDo: use it!-} (con,args,rhs)
366 = (case maybeAppDataTyConExpandingDicts scrut_ty of
368 addErrL (mkAlgAltMsg1 scrut_ty)
369 Just (tycon, tys_applied, cons) ->
371 arg_tys = dataConArgTys con tys_applied
373 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
374 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
376 mapL check (zipEqual "lintAlgAlt" arg_tys args) `seqL`
379 addInScopeVars args (
383 check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
385 -- elem: yes, the elem-list here can sometimes be long-ish,
386 -- but as it's use-once, probably not worth doing anything different
387 -- We give it its own copy, so it isn't overloaded.
389 elem x (y:ys) = x==y || elem x ys
391 lintPrimAlt ty alt@(lit,rhs)
392 = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
395 lintDeflt NoDefault _ = returnL Nothing
396 lintDeflt deflt@(BindDefault binder rhs) ty
397 = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
398 addInScopeVars [binder] (lintCoreExpr rhs)
401 %************************************************************************
403 \subsection[lint-monad]{The Lint monad}
405 %************************************************************************
408 type LintM a = Bool -- True <=> specialisation has been done
409 -> [LintLocInfo] -- Locations
410 -> UniqSet Id -- Local vars in scope
411 -> Bag ErrMsg -- Error messages so far
412 -> (a, Bag ErrMsg) -- Result and error messages (if any)
414 type ErrMsg = PprStyle -> Pretty
417 = RhsOf Id -- The variable bound
418 | LambdaBodyOf Id -- The lambda-binder
419 | BodyOfLetRec [Id] -- One of the binders
420 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
422 instance Outputable LintLocInfo where
424 = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
426 ppr sty (LambdaBodyOf b)
427 = ppBesides [ppr sty (getSrcLoc b),
428 ppStr ": [in body of lambda with binder ", pp_binder sty b, ppStr "]"]
430 ppr sty (BodyOfLetRec bs)
431 = ppBesides [ppr sty (getSrcLoc (head bs)),
432 ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"]
434 ppr sty (ImportedUnfolding locn)
435 = ppBeside (ppr sty locn) (ppStr ": [in an imported unfolding]")
437 pp_binders :: PprStyle -> [Id] -> Pretty
438 pp_binders sty bs = ppInterleave ppComma (map (pp_binder sty) bs)
440 pp_binder :: PprStyle -> Id -> Pretty
441 pp_binder sty b = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
445 initL :: LintM a -> Bool -> Maybe ErrMsg
447 = case (m spec_done [] emptyUniqSet emptyBag) of { (_, errs) ->
448 if isEmptyBag errs then
452 ppAboves [ msg sty | msg <- bagToList errs ]
456 returnL :: a -> LintM a
457 returnL r spec loc scope errs = (r, errs)
459 thenL :: LintM a -> (a -> LintM b) -> LintM b
460 thenL m k spec loc scope errs
461 = case m spec loc scope errs of
462 (r, errs') -> k r spec loc scope errs'
464 seqL :: LintM a -> LintM b -> LintM b
465 seqL m k spec loc scope errs
466 = case m spec loc scope errs of
467 (_, errs') -> k spec loc scope errs'
469 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
470 thenMaybeL m k spec loc scope errs
471 = case m spec loc scope errs of
472 (Nothing, errs2) -> (Nothing, errs2)
473 (Just r, errs2) -> k r spec loc scope errs2
475 seqMaybeL :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
476 seqMaybeL m k spec loc scope errs
477 = case m spec loc scope errs of
478 (Nothing, errs2) -> (Nothing, errs2)
479 (Just _, errs2) -> k spec loc scope errs2
481 mapL :: (a -> LintM b) -> [a] -> LintM [b]
482 mapL f [] = returnL []
485 mapL f xs `thenL` \ rs ->
488 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
489 -- Returns Nothing if anything fails
490 mapMaybeL f [] = returnL (Just [])
492 = f x `thenMaybeL` \ r ->
493 mapMaybeL f xs `thenMaybeL` \ rs ->
494 returnL (Just (r:rs))
498 checkL :: Bool -> ErrMsg -> LintM ()
499 checkL True msg spec loc scope errs = ((), errs)
500 checkL False msg spec loc scope errs = ((), addErr errs msg loc)
502 checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
503 checkIfSpecDoneL True msg spec loc scope errs = ((), errs)
504 checkIfSpecDoneL False msg True loc scope errs = ((), addErr errs msg loc)
505 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
508 = if pred then addErrL spec else returnL ()
510 addErrL :: ErrMsg -> LintM ()
511 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
513 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
515 addErr errs_so_far msg locs
516 = ASSERT (not (null locs))
517 errs_so_far `snocBag` ( \ sty ->
518 ppHang (ppr sty (head locs)) 4 (msg sty)
521 addLoc :: LintLocInfo -> LintM a -> LintM a
522 addLoc extra_loc m spec loc scope errs
523 = m spec (extra_loc:loc) scope errs
525 addInScopeVars :: [Id] -> LintM a -> LintM a
526 addInScopeVars ids m spec loc scope errs
527 = -- We check if these "new" ids are already
528 -- in scope, i.e., we have *shadowing* going on.
529 -- For now, it's just a "trace"; we may make
530 -- a real error out of it...
532 new_set = mkUniqSet ids
534 shadowed = scope `intersectUniqSets` new_set
536 -- After adding -fliberate-case, Simon decided he likes shadowed
537 -- names after all. WDP 94/07
538 -- (if isEmptyUniqSet shadowed
540 -- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
541 m spec loc (scope `unionUniqSets` new_set) errs
546 checkInScope :: Id -> LintM ()
547 checkInScope id spec loc scope errs
548 = if isLocallyDefined id && not (id `elementOfUniqSet` scope) then
549 ((),addErr errs (\sty -> ppCat [ppr sty id,ppStr "is out of scope"]) loc)
553 checkTys :: Type -> Type -> ErrMsg -> LintM ()
554 checkTys ty1 ty2 msg spec loc scope errs
555 = if ty1 `eqTy` ty2 then ((), errs) else ((), addErr errs msg loc)
559 mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
560 mkCaseAltMsg alts sty
561 = ppAbove (ppStr "Type of case alternatives not the same:")
564 mkCaseDataConMsg :: CoreExpr -> ErrMsg
565 mkCaseDataConMsg expr sty
566 = ppAbove (ppStr "A case scrutinee not of data constructor type:")
569 mkCaseNotPrimMsg :: TyCon -> ErrMsg
570 mkCaseNotPrimMsg tycon sty
571 = ppAbove (ppStr "A primitive case on a non-primitive type:")
574 mkCasePrimMsg :: TyCon -> ErrMsg
575 mkCasePrimMsg tycon sty
576 = ppAbove (ppStr "An algebraic case on a primitive type:")
579 mkCaseAbstractMsg :: TyCon -> ErrMsg
580 mkCaseAbstractMsg tycon sty
581 = ppAbove (ppStr "An algebraic case on some weird type:")
584 mkDefltMsg :: CoreCaseDefault -> ErrMsg
586 = ppAbove (ppStr "Binder in case default doesn't match type of scrutinee:")
589 mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
590 mkAppMsg fun arg expr sty
591 = ppAboves [ppStr "Argument value doesn't match argument type:",
592 ppHang (ppStr "Fun type:") 4 (ppr sty fun),
593 ppHang (ppStr "Arg type:") 4 (ppr sty arg),
594 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
596 mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg
597 mkTyAppMsg msg ty arg expr sty
598 = ppAboves [ppCat [ppPStr msg, ppStr "type application:"],
599 ppHang (ppStr "Exp type:") 4 (ppr sty ty),
600 ppHang (ppStr "Arg type:") 4 (ppr sty arg),
601 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
603 mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg
604 mkUsageAppMsg ty u expr sty
605 = ppAboves [ppStr "Illegal usage application:",
606 ppHang (ppStr "Exp type:") 4 (ppr sty ty),
607 ppHang (ppStr "Usage exp:") 4 (ppr sty u),
608 ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
610 mkAlgAltMsg1 :: Type -> ErrMsg
612 = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
614 -- (ppAbove (ppr sty ty) (ppr sty (expandTy ty))) -- ToDo: rm
616 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
617 mkAlgAltMsg2 ty con sty
619 ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
624 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
625 mkAlgAltMsg3 con alts sty
627 ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:",
632 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
633 mkAlgAltMsg4 ty arg sty
635 ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
640 mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
643 (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
646 mkRhsMsg :: Id -> Type -> ErrMsg
647 mkRhsMsg binder ty sty
649 [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
651 ppCat [ppStr "Binder's type:", ppr sty (idType binder)],
652 ppCat [ppStr "Rhs type:", ppr sty ty]]
654 mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
655 mkRhsPrimMsg binder rhs sty
656 = ppAboves [ppCat [ppStr "The type of this binder is primitive:",
658 ppCat [ppStr "Binder's type:", ppr sty (idType binder)]
661 mkSpecTyAppMsg :: CoreArg -> ErrMsg
662 mkSpecTyAppMsg arg sty
664 (ppStr "Unboxed types in a type application (after specialisation):")
667 pp_expr :: PprStyle -> CoreExpr -> Pretty
669 = pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr