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 ( hasMoreBoxityInfo, Kind{-instance-},
20 isTypeKind, isBoxedTypeKind {- TEMP --SOF -} )
21 import Literal ( literalType, Literal{-instance-} )
22 import Id ( idType, isBottomingId, dataConRepType,
23 dataConArgTys, GenId{-instances-},
24 emptyIdSet, mkIdSet, intersectIdSets,
25 unionIdSets, elementOfIdSet, SYN_IE(IdSet),
28 import Maybes ( catMaybes )
29 import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-},
31 import Outputable ( Outputable(..){-instance * []-} )
33 import PprStyle ( PprStyle(..) )
34 import PprType ( GenType, GenTyVar, TyCon )
36 import PrimOp ( primOpType, PrimOp(..) )
37 import PrimRep ( PrimRep(..) )
38 import SrcLoc ( SrcLoc )
39 import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,mkForAllTys,getForAllTy_maybe,
40 getFunTyExpandingDicts_maybe,
41 getForAllTyExpandingDicts_maybe,
42 isPrimType,typeKind,instantiateTy,splitSigmaTy,
43 mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
44 maybeAppDataTyConExpandingDicts, eqTy, SYN_IE(Type)
45 -- ,expandTy -- ToDo:rm
47 import TyCon ( isPrimTyCon )
48 import TyVar ( tyVarKind, GenTyVar{-instances-} )
49 import Unique ( Unique )
50 import Usage ( GenUsage, SYN_IE(Usage) )
51 import Util ( zipEqual, pprTrace, pprPanic, assertPanic, panic )
53 infixr 9 `thenL`, `seqL`, `thenMaybeL`, `seqMaybeL`
56 %************************************************************************
58 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
60 %************************************************************************
62 Checks that a set of core bindings is well-formed. The PprStyle and String
63 just control what we print in the event of an error. The Bool value
64 indicates whether we have done any specialisation yet (in which case we do
69 (b) Out-of-scope type variables
70 (c) Out-of-scope local variables
73 If we have done specialisation the we check that there are
74 (a) No top-level bindings of primitive (unboxed type)
79 -- Things are *not* OK if:
81 -- * Unsaturated type app before specialisation has been done;
83 -- * Oversaturated type app after specialisation (eta reduction
84 -- may well be happening...);
86 -- Note: checkTyApp is usually followed by a call to checkSpecTyApp.
91 :: PprStyle -> String -> Bool -> [CoreBinding] -> [CoreBinding]
93 lintCoreBindings sty whoDunnit spec_done binds
94 = case (initL (lint_binds binds) spec_done) of
98 text ("*** Core Lint Errors: in " ++ whoDunnit ++ " ***"),
100 ptext SLIT("*** Offending Program ***"),
101 vcat (map (pprCoreBinding sty) binds),
102 ptext SLIT("*** End of Offense ***")
105 lint_binds [] = returnL ()
106 lint_binds (bind:binds)
107 = lintCoreBinding bind `thenL` \binders ->
108 addInScopeVars binders (lint_binds binds)
111 %************************************************************************
113 \subsection[lintUnfolding]{lintUnfolding}
115 %************************************************************************
117 We use this to check all unfoldings that come in from interfaces
118 (it is very painful to catch errors otherwise):
121 lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
123 lintUnfolding locn expr
125 (initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
126 True{-pretend spec done-})
130 pprTrace "WARNING: Discarded bad unfolding from interface:\n"
131 (vcat [msg PprForUser,
132 ptext SLIT("*** Bad unfolding ***"),
134 ptext SLIT("*** End unfolding ***")])
138 %************************************************************************
140 \subsection[lintCoreBinding]{lintCoreBinding}
142 %************************************************************************
144 Check a core binding, returning the list of variables bound.
147 lintCoreBinding :: CoreBinding -> LintM [Id]
149 lintCoreBinding (NonRec binder rhs)
150 = lintSingleBinding (binder,rhs) `seqL` returnL [binder]
152 lintCoreBinding (Rec pairs)
153 = addInScopeVars binders (
154 mapL lintSingleBinding pairs `seqL` returnL binders
157 binders = [b | (b,_) <- pairs]
159 lintSingleBinding (binder,rhs)
160 = addLoc (RhsOf binder) (
165 -- Check match to RHS type
167 Nothing -> returnL ()
168 Just ty -> checkTys (idType binder) ty (mkRhsMsg binder ty))
171 -- Check (not isPrimType)
172 checkIfSpecDoneL (not (isPrimType (idType binder)))
173 (mkRhsPrimMsg binder rhs)
175 -- We should check the unfolding, if any, but this is tricky because
176 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
180 %************************************************************************
182 \subsection[lintCoreExpr]{lintCoreExpr}
184 %************************************************************************
187 lintCoreExpr :: CoreExpr -> LintM (Maybe Type) -- Nothing if error found
189 lintCoreExpr (Var var) = checkInScope var `seqL` returnL (Just (idType var))
190 lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
191 lintCoreExpr (SCC _ expr) = lintCoreExpr expr
192 lintCoreExpr (Coerce _ ty expr)
193 = lintCoreExpr expr `seqL` returnL (Just ty)
195 lintCoreExpr (Let binds body)
196 = lintCoreBinding binds `thenL` \binders ->
197 if (null binders) then
198 lintCoreExpr body -- Can't add a new source location
200 addLoc (BodyOfLetRec binders)
201 (addInScopeVars binders (lintCoreExpr body))
203 lintCoreExpr e@(Con con args)
204 = lintCoreArgs {-False-} e (dataConRepType con) args
205 -- Note: we don't check for primitive types in these arguments
207 lintCoreExpr e@(Prim op args)
208 = lintCoreArgs {-True-} e (primOpType op) args
209 -- Note: we do check for primitive types in these arguments
211 lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
212 = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg {-False-} e ty arg
213 -- Note: we don't check for primitive types in argument to 'error'
215 lintCoreExpr e@(App fun arg)
216 = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg {-True-} e ty arg
217 -- Note: we do check for primitive types in this argument
219 lintCoreExpr (Lam (ValBinder var) expr)
220 = addLoc (LambdaBodyOf var)
221 (addInScopeVars [var]
222 (lintCoreExpr expr `thenMaybeL` \ty ->
223 returnL (Just (mkFunTy (idType var) ty))))
225 lintCoreExpr (Lam (TyBinder tyvar) expr)
226 = lintCoreExpr expr `thenMaybeL` \ty ->
227 returnL (Just(mkForAllTy tyvar ty))
228 -- ToDo: Should add in-scope type variable at this point
230 lintCoreExpr e@(Case scrut alts)
231 = lintCoreExpr scrut `thenMaybeL` \ty ->
235 %************************************************************************
237 \subsection[lintCoreArgs]{lintCoreArgs}
239 %************************************************************************
241 The boolean argument indicates whether we should flag type
242 applications to primitive types as being errors.
245 lintCoreArgs :: {-Bool ->-} CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
247 lintCoreArgs _ ty [] = returnL (Just ty)
248 lintCoreArgs e ty (a : args)
249 = lintCoreArg e ty a `thenMaybeL` \ res ->
250 lintCoreArgs e res args
253 %************************************************************************
255 \subsection[lintCoreArg]{lintCoreArg}
257 %************************************************************************
260 lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
262 lintCoreArg e ty (LitArg lit)
263 = -- Make sure function type matches argument
264 case (getFunTyExpandingDicts_maybe False{-no peeking in newtypes-} ty) of
265 Just (arg,res) | (lit_ty `eqTy` arg) -> returnL(Just res)
266 _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing
268 lit_ty = literalType lit
270 lintCoreArg e ty (VarArg v)
271 = -- Make sure variable is bound
272 checkInScope v `seqL`
273 -- Make sure function type matches argument
274 case (getFunTyExpandingDicts_maybe False{-as above-} ty) of
275 Just (arg,res) | (var_ty `eqTy` arg) -> returnL(Just res)
276 _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing
280 lintCoreArg e ty a@(TyArg arg_ty)
281 = -- ToDo: Check that ty is well-kinded and has no unbound tyvars
282 case (getForAllTyExpandingDicts_maybe ty) of
283 Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
287 tyvar_kind = tyVarKind tyvar
288 argty_kind = typeKind arg_ty
290 if argty_kind `hasMoreBoxityInfo` tyvar_kind || -- Should the args be swapped here?
291 (isTypeKind argty_kind && isBoxedTypeKind tyvar_kind) -- (hackily) added SOF
292 -- Arg type might be boxed for a function with an uncommitted
293 -- tyvar; notably this is used so that we can give
294 -- error :: forall a:*. String -> a
295 -- and then apply it to both boxed and unboxed types.
297 returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
299 pprTrace "lintCoreArg:kinds:" (hsep [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $
300 addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing
302 lintCoreArg e ty (UsageArg u)
303 = -- ToDo: Check that usage has no unbound usage variables
304 case (getForAllUsageTy ty) of
305 Just (uvar,bounds,body) ->
306 -- ToDo: Check argument satisfies bounds
307 returnL(Just(panic "lintCoreArg:instantiateUsage uvar u body"))
308 _ -> addErrL (mkUsageAppMsg ty u e) `seqL` returnL Nothing
311 %************************************************************************
313 \subsection[lintCoreAlts]{lintCoreAlts}
315 %************************************************************************
318 lintCoreAlts :: CoreCaseAlts
319 -> Type -- Type of scrutinee
320 -- -> TyCon -- TyCon pinned on the case
321 -> LintM (Maybe Type) -- Type of alternatives
323 lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon
324 = -- Check tycon is not a primitive tycon
325 -- addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
327 -- Check we are scrutinising a proper datatype
329 -- addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
332 `thenL` \maybe_deflt_ty ->
333 mapL (lintAlgAlt ty {-tycon-}) alts
334 `thenL` \maybe_alt_tys ->
335 -- Check the result types
336 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
337 [] -> returnL Nothing
339 (first_ty:tys) -> mapL check tys `seqL`
340 returnL (Just first_ty)
342 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
344 lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
345 = -- Check tycon is a primitive tycon
346 -- addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
348 mapL (lintPrimAlt ty) alts
349 `thenL` \maybe_alt_tys ->
351 `thenL` \maybe_deflt_ty ->
352 -- Check the result types
353 case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
354 [] -> returnL Nothing
356 (first_ty:tys) -> mapL check tys `seqL`
357 returnL (Just first_ty)
359 check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
361 lintAlgAlt scrut_ty {-tycon-ToDo: use it!-} (con,args,rhs)
362 = (case maybeAppDataTyConExpandingDicts scrut_ty of
364 addErrL (mkAlgAltMsg1 scrut_ty)
365 Just (tycon, tys_applied, cons) ->
367 arg_tys = dataConArgTys con tys_applied
369 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
370 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
372 mapL check (zipEqual "lintAlgAlt" arg_tys args) `seqL`
375 addInScopeVars args (
379 check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
381 -- elem: yes, the elem-list here can sometimes be long-ish,
382 -- but as it's use-once, probably not worth doing anything different
383 -- We give it its own copy, so it isn't overloaded.
385 elem x (y:ys) = x==y || elem x ys
387 lintPrimAlt ty alt@(lit,rhs)
388 = checkTys (literalType lit) ty (mkPrimAltMsg alt) `seqL`
391 lintDeflt NoDefault _ = returnL Nothing
392 lintDeflt deflt@(BindDefault binder rhs) ty
393 = checkTys (idType binder) ty (mkDefltMsg deflt) `seqL`
394 addInScopeVars [binder] (lintCoreExpr rhs)
397 %************************************************************************
399 \subsection[lint-monad]{The Lint monad}
401 %************************************************************************
404 type LintM a = Bool -- True <=> specialisation has been done
405 -> [LintLocInfo] -- Locations
406 -> IdSet -- Local vars in scope
407 -> Bag ErrMsg -- Error messages so far
408 -> (a, Bag ErrMsg) -- Result and error messages (if any)
410 type ErrMsg = PprStyle -> Doc
413 = RhsOf Id -- The variable bound
414 | LambdaBodyOf Id -- The lambda-binder
415 | BodyOfLetRec [Id] -- One of the binders
416 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
418 instance Outputable LintLocInfo where
420 = hcat [ppr sty (getSrcLoc v), ptext SLIT(": [RHS of "), pp_binders sty [v], char ']']
422 ppr sty (LambdaBodyOf b)
423 = hcat [ppr sty (getSrcLoc b),
424 ptext SLIT(": [in body of lambda with binder "), pp_binder sty b, char ']']
426 ppr sty (BodyOfLetRec bs)
427 = hcat [ppr sty (getSrcLoc (head bs)),
428 ptext SLIT(": [in body of letrec with binders "), pp_binders sty bs, char ']']
430 ppr sty (ImportedUnfolding locn)
431 = (<>) (ppr sty locn) (ptext SLIT(": [in an imported unfolding]"))
433 pp_binders :: PprStyle -> [Id] -> Doc
434 pp_binders sty bs = sep (punctuate comma (map (pp_binder sty) bs))
436 pp_binder :: PprStyle -> Id -> Doc
437 pp_binder sty b = hsep [ppr sty b, text "::", ppr sty (idType b)]
441 initL :: LintM a -> Bool -> Maybe ErrMsg
443 = case (m spec_done [] emptyIdSet emptyBag) of { (_, errs) ->
444 if isEmptyBag errs then
448 vcat [ msg sty | msg <- bagToList errs ]
452 returnL :: a -> LintM a
453 returnL r spec loc scope errs = (r, errs)
455 thenL :: LintM a -> (a -> LintM b) -> LintM b
456 thenL m k spec loc scope errs
457 = case m spec loc scope errs of
458 (r, errs') -> k r spec loc scope errs'
460 seqL :: LintM a -> LintM b -> LintM b
461 seqL m k spec loc scope errs
462 = case m spec loc scope errs of
463 (_, errs') -> k spec loc scope errs'
465 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
466 thenMaybeL m k spec loc scope errs
467 = case m spec loc scope errs of
468 (Nothing, errs2) -> (Nothing, errs2)
469 (Just r, errs2) -> k r spec loc scope errs2
471 seqMaybeL :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
472 seqMaybeL m k spec loc scope errs
473 = case m spec loc scope errs of
474 (Nothing, errs2) -> (Nothing, errs2)
475 (Just _, errs2) -> k spec loc scope errs2
477 mapL :: (a -> LintM b) -> [a] -> LintM [b]
478 mapL f [] = returnL []
481 mapL f xs `thenL` \ rs ->
484 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
485 -- Returns Nothing if anything fails
486 mapMaybeL f [] = returnL (Just [])
488 = f x `thenMaybeL` \ r ->
489 mapMaybeL f xs `thenMaybeL` \ rs ->
490 returnL (Just (r:rs))
494 checkL :: Bool -> ErrMsg -> LintM ()
495 checkL True msg spec loc scope errs = ((), errs)
496 checkL False msg spec loc scope errs = ((), addErr errs msg loc)
498 checkIfSpecDoneL :: Bool -> ErrMsg -> LintM ()
499 checkIfSpecDoneL True msg spec loc scope errs = ((), errs)
500 checkIfSpecDoneL False msg True loc scope errs = ((), addErr errs msg loc)
501 checkIfSpecDoneL False msg False loc scope errs = ((), errs)
504 = if pred then addErrL spec else returnL ()
506 addErrL :: ErrMsg -> LintM ()
507 addErrL msg spec loc scope errs = ((), addErr errs msg loc)
509 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
511 addErr errs_so_far msg locs
512 = ASSERT (not (null locs))
513 errs_so_far `snocBag` ( \ sty ->
514 hang (ppr sty (head locs)) 4 (msg sty)
517 addLoc :: LintLocInfo -> LintM a -> LintM a
518 addLoc extra_loc m spec loc scope errs
519 = m spec (extra_loc:loc) scope errs
521 addInScopeVars :: [Id] -> LintM a -> LintM a
522 addInScopeVars ids m spec loc scope errs
523 = -- We check if these "new" ids are already
524 -- in scope, i.e., we have *shadowing* going on.
525 -- For now, it's just a "trace"; we may make
526 -- a real error out of it...
528 new_set = mkIdSet ids
530 -- shadowed = scope `intersectIdSets` new_set
532 -- After adding -fliberate-case, Simon decided he likes shadowed
533 -- names after all. WDP 94/07
534 -- (if isEmptyUniqSet shadowed
536 -- else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
537 m spec loc (scope `unionIdSets` new_set) errs
542 checkInScope :: Id -> LintM ()
543 checkInScope id spec loc scope errs
547 if isLocallyDefined id_name && not (id `elementOfIdSet` scope) then
548 ((),addErr errs (\sty -> hsep [ppr sty id, ptext SLIT("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 = ($$) (ptext SLIT("Type of case alternatives not the same:"))
563 mkCaseDataConMsg :: CoreExpr -> ErrMsg
564 mkCaseDataConMsg expr sty
565 = ($$) (ptext SLIT("A case scrutinee not of data constructor type:"))
568 mkCaseNotPrimMsg :: TyCon -> ErrMsg
569 mkCaseNotPrimMsg tycon sty
570 = ($$) (ptext SLIT("A primitive case on a non-primitive type:"))
573 mkCasePrimMsg :: TyCon -> ErrMsg
574 mkCasePrimMsg tycon sty
575 = ($$) (ptext SLIT("An algebraic case on a primitive type:"))
578 mkCaseAbstractMsg :: TyCon -> ErrMsg
579 mkCaseAbstractMsg tycon sty
580 = ($$) (ptext SLIT("An algebraic case on some weird type:"))
583 mkDefltMsg :: CoreCaseDefault -> ErrMsg
585 = ($$) (ptext SLIT("Binder in case default doesn't match type of scrutinee:"))
588 mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
589 mkAppMsg fun arg expr sty
590 = vcat [ptext SLIT("Argument value doesn't match argument type:"),
591 hang (ptext SLIT("Fun type:")) 4 (ppr sty fun),
592 hang (ptext SLIT("Arg type:")) 4 (ppr sty arg),
593 hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)]
595 mkTyAppMsg :: FAST_STRING -> Type -> Type -> CoreExpr -> ErrMsg
596 mkTyAppMsg msg ty arg expr sty
597 = vcat [hsep [ptext msg, ptext SLIT("type application:")],
598 hang (ptext SLIT("Exp type:")) 4 (ppr sty ty),
599 hang (ptext SLIT("Arg type:")) 4 (ppr sty arg),
600 hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)]
602 mkUsageAppMsg :: Type -> Usage -> CoreExpr -> ErrMsg
603 mkUsageAppMsg ty u expr sty
604 = vcat [ptext SLIT("Illegal usage application:"),
605 hang (ptext SLIT("Exp type:")) 4 (ppr sty ty),
606 hang (ptext SLIT("Usage exp:")) 4 (ppr sty u),
607 hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)]
609 mkAlgAltMsg1 :: Type -> ErrMsg
611 = ($$) (text "In some case statement, type of scrutinee is not a data type:")
613 -- (($$) (ppr sty ty) (ppr sty (expandTy ty))) -- ToDo: rm
615 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
616 mkAlgAltMsg2 ty con sty
618 text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
623 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
624 mkAlgAltMsg3 con alts sty
626 text "In some algebraic case alternative, number of arguments doesn't match constructor:",
631 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
632 mkAlgAltMsg4 ty arg sty
634 text "In some algebraic case alternative, type of argument doesn't match data constructor:",
639 mkPrimAltMsg :: (Literal, CoreExpr) -> ErrMsg
642 (text "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 [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
650 hsep [ptext SLIT("Binder's type:"), ppr sty (idType binder)],
651 hsep [ptext SLIT("Rhs type:"), ppr sty ty]]
653 mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
654 mkRhsPrimMsg binder rhs sty
655 = vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
657 hsep [ptext SLIT("Binder's type:"), ppr sty (idType binder)]
660 mkSpecTyAppMsg :: CoreArg -> ErrMsg
661 mkSpecTyAppMsg arg sty
663 (ptext SLIT("Unboxed types in a type application (after specialisation):"))
666 pp_expr :: PprStyle -> CoreExpr -> Doc
668 = pprCoreExpr sty (pprBigCoreBinder sty) (pprTypedCoreBinder sty) (pprTypedCoreBinder sty) expr