Split stripTicks into expression editing and tick collection
[ghc.git] / compiler / coreSyn / CoreLint.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4
5
6 A ``lint'' pass to check for Core correctness
7 -}
8
9 {-# LANGUAGE CPP #-}
10 {-# OPTIONS_GHC -fprof-auto #-}
11
12 module CoreLint (
13 lintCoreBindings, lintUnfolding,
14 lintPassResult, lintInteractiveExpr, lintExpr,
15 lintAnnots,
16
17 -- ** Debug output
18 CoreLint.showPass, showPassIO, endPass, endPassIO,
19 dumpPassResult,
20 CoreLint.dumpIfSet,
21 ) where
22
23 #include "HsVersions.h"
24
25 import CoreSyn
26 import CoreFVs
27 import CoreUtils
28 import CoreMonad
29 import Bag
30 import Literal
31 import DataCon
32 import TysWiredIn
33 import TysPrim
34 import Var
35 import VarEnv
36 import VarSet
37 import Name
38 import Id
39 import PprCore
40 import ErrUtils
41 import Coercion
42 import SrcLoc
43 import Kind
44 import Type
45 import TypeRep
46 import TyCon
47 import CoAxiom
48 import BasicTypes
49 import ErrUtils as Err
50 import StaticFlags
51 import ListSetOps
52 import PrelNames
53 import Outputable
54 import FastString
55 import Util
56 import InstEnv ( instanceDFunId )
57 import OptCoercion ( checkAxInstCo )
58 import UniqSupply
59
60 import HscTypes
61 import DynFlags
62 import Control.Monad
63 import MonadUtils
64 import Data.Maybe
65 import Pair
66
67 {-
68 Note [GHC Formalism]
69 ~~~~~~~~~~~~~~~~~~~~
70 This file implements the type-checking algorithm for System FC, the "official"
71 name of the Core language. Type safety of FC is heart of the claim that
72 executables produced by GHC do not have segmentation faults. Thus, it is
73 useful to be able to reason about System FC independently of reading the code.
74 To this purpose, there is a document ghc.pdf built in docs/core-spec that
75 contains a formalism of the types and functions dealt with here. If you change
76 just about anything in this file or you change other types/functions throughout
77 the Core language (all signposted to this note), you should update that
78 formalism. See docs/core-spec/README for more info about how to do so.
79
80 Summary of checks
81 ~~~~~~~~~~~~~~~~~
82 Checks that a set of core bindings is well-formed. The PprStyle and String
83 just control what we print in the event of an error. The Bool value
84 indicates whether we have done any specialisation yet (in which case we do
85 some extra checks).
86
87 We check for
88 (a) type errors
89 (b) Out-of-scope type variables
90 (c) Out-of-scope local variables
91 (d) Ill-kinded types
92
93 If we have done specialisation the we check that there are
94 (a) No top-level bindings of primitive (unboxed type)
95
96 Outstanding issues:
97
98 -- Things are *not* OK if:
99 --
100 -- * Unsaturated type app before specialisation has been done;
101 --
102 -- * Oversaturated type app after specialisation (eta reduction
103 -- may well be happening...);
104
105
106 Note [Linting type lets]
107 ~~~~~~~~~~~~~~~~~~~~~~~~
108 In the desugarer, it's very very convenient to be able to say (in effect)
109 let a = Type Int in <body>
110 That is, use a type let. See Note [Type let] in CoreSyn.
111
112 However, when linting <body> we need to remember that a=Int, else we might
113 reject a correct program. So we carry a type substitution (in this example
114 [a -> Int]) and apply this substitution before comparing types. The functin
115 lintInTy :: Type -> LintM Type
116 returns a substituted type; that's the only reason it returns anything.
117
118 When we encounter a binder (like x::a) we must apply the substitution
119 to the type of the binding variable. lintBinders does this.
120
121 For Ids, the type-substituted Id is added to the in_scope set (which
122 itself is part of the TvSubst we are carrying down), and when we
123 find an occurrence of an Id, we fetch it from the in-scope set.
124
125 ************************************************************************
126 * *
127 Beginning and ending passes
128 * *
129 ************************************************************************
130
131 These functions are not CoreM monad stuff, but they probably ought to
132 be, and it makes a conveneint place. place for them. They print out
133 stuff before and after core passes, and do Core Lint when necessary.
134 -}
135
136 showPass :: CoreToDo -> CoreM ()
137 showPass pass = do { dflags <- getDynFlags
138 ; liftIO $ showPassIO dflags pass }
139
140 showPassIO :: DynFlags -> CoreToDo -> IO ()
141 showPassIO dflags pass = Err.showPass dflags (showPpr dflags pass)
142
143 endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
144 endPass pass binds rules
145 = do { hsc_env <- getHscEnv
146 ; print_unqual <- getPrintUnqualified
147 ; liftIO $ endPassIO hsc_env print_unqual pass binds rules }
148
149 endPassIO :: HscEnv -> PrintUnqualified
150 -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
151 -- Used by the IO-is CorePrep too
152 endPassIO hsc_env print_unqual pass binds rules
153 = do { dumpPassResult dflags print_unqual mb_flag
154 (ppr pass) (pprPassDetails pass) binds rules
155 ; lintPassResult hsc_env pass binds }
156 where
157 dflags = hsc_dflags hsc_env
158 mb_flag = case coreDumpFlag pass of
159 Just flag | dopt flag dflags -> Just flag
160 | dopt Opt_D_verbose_core2core dflags -> Just flag
161 _ -> Nothing
162
163 dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
164 dumpIfSet dflags dump_me pass extra_info doc
165 = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc
166
167 dumpPassResult :: DynFlags
168 -> PrintUnqualified
169 -> Maybe DumpFlag -- Just df => show details in a file whose
170 -- name is specified by df
171 -> SDoc -- Header
172 -> SDoc -- Extra info to appear after header
173 -> CoreProgram -> [CoreRule]
174 -> IO ()
175 dumpPassResult dflags unqual mb_flag hdr extra_info binds rules
176 | Just flag <- mb_flag
177 = Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc
178
179 | otherwise
180 = Err.debugTraceMsg dflags 2 size_doc
181 -- Report result size
182 -- This has the side effect of forcing the intermediate to be evaluated
183
184 where
185 size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]
186
187 dump_doc = vcat [ nest 2 extra_info
188 , size_doc
189 , blankLine
190 , pprCoreBindings binds
191 , ppUnless (null rules) pp_rules ]
192 pp_rules = vcat [ blankLine
193 , ptext (sLit "------ Local rules for imported ids --------")
194 , pprRules rules ]
195
196 coreDumpFlag :: CoreToDo -> Maybe DumpFlag
197 coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core
198 coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core
199 coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core
200 coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
201 coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core
202 coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core
203 coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity
204 coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal
205 coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper
206 coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
207 coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
208 coreDumpFlag CoreCSE = Just Opt_D_dump_cse
209 coreDumpFlag CoreDoVectorisation = Just Opt_D_dump_vect
210 coreDumpFlag CoreDesugar = Just Opt_D_dump_ds
211 coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds
212 coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
213 coreDumpFlag CorePrep = Just Opt_D_dump_prep
214
215 coreDumpFlag CoreDoPrintCore = Nothing
216 coreDumpFlag (CoreDoRuleCheck {}) = Nothing
217 coreDumpFlag CoreDoNothing = Nothing
218 coreDumpFlag (CoreDoPasses {}) = Nothing
219
220 {-
221 ************************************************************************
222 * *
223 Top-level interfaces
224 * *
225 ************************************************************************
226 -}
227
228 lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()
229 lintPassResult hsc_env pass binds
230 | not (gopt Opt_DoCoreLinting dflags)
231 = return ()
232 | otherwise
233 = do { let (warns, errs) = lintCoreBindings pass (interactiveInScope hsc_env) binds
234 ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)
235 ; displayLintResults dflags pass warns errs binds }
236 where
237 dflags = hsc_dflags hsc_env
238
239 displayLintResults :: DynFlags -> CoreToDo
240 -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram
241 -> IO ()
242 displayLintResults dflags pass warns errs binds
243 | not (isEmptyBag errs)
244 = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
245 (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
246 , ptext (sLit "*** Offending Program ***")
247 , pprCoreBindings binds
248 , ptext (sLit "*** End of Offense ***") ])
249 ; Err.ghcExit dflags 1 }
250
251 | not (isEmptyBag warns)
252 , not opt_NoDebugOutput
253 , showLintWarnings pass
254 = log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
255 (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag warns)
256
257 | otherwise = return ()
258 where
259
260 lint_banner :: String -> SDoc -> SDoc
261 lint_banner string pass = ptext (sLit "*** Core Lint") <+> text string
262 <+> ptext (sLit ": in result of") <+> pass
263 <+> ptext (sLit "***")
264
265 showLintWarnings :: CoreToDo -> Bool
266 -- Disable Lint warnings on the first simplifier pass, because
267 -- there may be some INLINE knots still tied, which is tiresomely noisy
268 showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
269 showLintWarnings _ = True
270
271 lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO ()
272 lintInteractiveExpr what hsc_env expr
273 | not (gopt Opt_DoCoreLinting dflags)
274 = return ()
275 | Just err <- lintExpr (interactiveInScope hsc_env) expr
276 = do { display_lint_err err
277 ; Err.ghcExit dflags 1 }
278 | otherwise
279 = return ()
280 where
281 dflags = hsc_dflags hsc_env
282
283 display_lint_err err
284 = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
285 (vcat [ lint_banner "errors" (text what)
286 , err
287 , ptext (sLit "*** Offending Program ***")
288 , pprCoreExpr expr
289 , ptext (sLit "*** End of Offense ***") ])
290 ; Err.ghcExit dflags 1 }
291
292 interactiveInScope :: HscEnv -> [Var]
293 -- In GHCi we may lint expressions, or bindings arising from 'deriving'
294 -- clauses, that mention variables bound in the interactive context.
295 -- These are Local things (see Note [Interactively-bound Ids in GHCi] in HscTypes).
296 -- So we have to tell Lint about them, lest it reports them as out of scope.
297 --
298 -- We do this by find local-named things that may appear free in interactive
299 -- context. This function is pretty revolting and quite possibly not quite right.
300 -- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty
301 -- so this is a (cheap) no-op.
302 --
303 -- See Trac #8215 for an example
304 interactiveInScope hsc_env
305 = varSetElems tyvars ++ ids
306 where
307 -- C.f. TcRnDriver.setInteractiveContext, Desugar.deSugarExpr
308 ictxt = hsc_IC hsc_env
309 (cls_insts, _fam_insts) = ic_instances ictxt
310 te1 = mkTypeEnvWithImplicits (ic_tythings ictxt)
311 te = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts)
312 ids = typeEnvIds te
313 tyvars = mapUnionVarSet (tyVarsOfType . idType) ids
314 -- Why the type variables? How can the top level envt have free tyvars?
315 -- I think it's because of the GHCi debugger, which can bind variables
316 -- f :: [t] -> [t]
317 -- where t is a RuntimeUnk (see TcType)
318
319 lintCoreBindings :: CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
320 -- Returns (warnings, errors)
321 -- If you edit this function, you may need to update the GHC formalism
322 -- See Note [GHC Formalism]
323 lintCoreBindings pass local_in_scope binds
324 = initL flags $
325 addLoc TopLevelBindings $
326 addInScopeVars local_in_scope $
327 addInScopeVars binders $
328 -- Put all the top-level binders in scope at the start
329 -- This is because transformation rules can bring something
330 -- into use 'unexpectedly'
331 do { checkL (null dups) (dupVars dups)
332 ; checkL (null ext_dups) (dupExtVars ext_dups)
333 ; mapM lint_bind binds }
334 where
335 flags = LF { lf_check_global_ids = check_globals
336 , lf_check_inline_loop_breakers = check_lbs }
337
338 -- See Note [Checking for global Ids]
339 check_globals = case pass of
340 CoreTidy -> False
341 CorePrep -> False
342 _ -> True
343
344 -- See Note [Checking for INLINE loop breakers]
345 check_lbs = case pass of
346 CoreDesugar -> False
347 CoreDesugarOpt -> False
348 _ -> True
349
350 binders = bindersOfBinds binds
351 (_, dups) = removeDups compare binders
352
353 -- dups_ext checks for names with different uniques
354 -- but but the same External name M.n. We don't
355 -- allow this at top level:
356 -- M.n{r3} = ...
357 -- M.n{r29} = ...
358 -- because they both get the same linker symbol
359 ext_dups = snd (removeDups ord_ext (map Var.varName binders))
360 ord_ext n1 n2 | Just m1 <- nameModule_maybe n1
361 , Just m2 <- nameModule_maybe n2
362 = compare (m1, nameOccName n1) (m2, nameOccName n2)
363 | otherwise = LT
364
365 -- If you edit this function, you may need to update the GHC formalism
366 -- See Note [GHC Formalism]
367 lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs
368 lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
369
370 {-
371 ************************************************************************
372 * *
373 \subsection[lintUnfolding]{lintUnfolding}
374 * *
375 ************************************************************************
376
377 We use this to check all unfoldings that come in from interfaces
378 (it is very painful to catch errors otherwise):
379 -}
380
381 lintUnfolding :: SrcLoc
382 -> [Var] -- Treat these as in scope
383 -> CoreExpr
384 -> Maybe MsgDoc -- Nothing => OK
385
386 lintUnfolding locn vars expr
387 | isEmptyBag errs = Nothing
388 | otherwise = Just (pprMessageBag errs)
389 where
390 (_warns, errs) = initL defaultLintFlags linter
391 linter = addLoc (ImportedUnfolding locn) $
392 addInScopeVars vars $
393 lintCoreExpr expr
394
395 lintExpr :: [Var] -- Treat these as in scope
396 -> CoreExpr
397 -> Maybe MsgDoc -- Nothing => OK
398
399 lintExpr vars expr
400 | isEmptyBag errs = Nothing
401 | otherwise = Just (pprMessageBag errs)
402 where
403 (_warns, errs) = initL defaultLintFlags linter
404 linter = addLoc TopLevelBindings $
405 addInScopeVars vars $
406 lintCoreExpr expr
407
408 {-
409 ************************************************************************
410 * *
411 \subsection[lintCoreBinding]{lintCoreBinding}
412 * *
413 ************************************************************************
414
415 Check a core binding, returning the list of variables bound.
416 -}
417
418 lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
419 -- If you edit this function, you may need to update the GHC formalism
420 -- See Note [GHC Formalism]
421 lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
422 = addLoc (RhsOf binder) $
423 -- Check the rhs
424 do { ty <- lintCoreExpr rhs
425 ; lintBinder binder -- Check match to RHS type
426 ; binder_ty <- applySubstTy binder_ty
427 ; checkTys binder_ty ty (mkRhsMsg binder (ptext (sLit "RHS")) ty)
428
429 -- Check the let/app invariant
430 -- See Note [CoreSyn let/app invariant] in CoreSyn
431 ; checkL (not (isUnLiftedType binder_ty)
432 || (isNonRec rec_flag && exprOkForSpeculation rhs))
433 (mkRhsPrimMsg binder rhs)
434
435 -- Check that if the binder is top-level or recursive, it's not demanded
436 ; checkL (not (isStrictId binder)
437 || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)))
438 (mkStrictMsg binder)
439
440 -- Check that if the binder is local, it is not marked as exported
441 ; checkL (not (isExportedId binder) || isTopLevel top_lvl_flag)
442 (mkNonTopExportedMsg binder)
443
444 -- Check that if the binder is local, it does not have an external name
445 ; checkL (not (isExternalName (Var.varName binder)) || isTopLevel top_lvl_flag)
446 (mkNonTopExternalNameMsg binder)
447
448 -- Check whether binder's specialisations contain any out-of-scope variables
449 ; mapM_ (checkBndrIdInScope binder) bndr_vars
450
451 ; flags <- getLintFlags
452 ; when (lf_check_inline_loop_breakers flags
453 && isStrongLoopBreaker (idOccInfo binder)
454 && isInlinePragma (idInlinePragma binder))
455 (addWarnL (ptext (sLit "INLINE binder is (non-rule) loop breaker:") <+> ppr binder))
456 -- Only non-rule loop breakers inhibit inlining
457
458 -- Check whether arity and demand type are consistent (only if demand analysis
459 -- already happened)
460 --
461 -- Note (Apr 2014): this is actually ok. See Note [Demand analysis for trivial right-hand sides]
462 -- in DmdAnal. After eta-expansion in CorePrep the rhs is no longer trivial.
463 -- ; let dmdTy = idStrictness binder
464 -- ; checkL (case dmdTy of
465 -- StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs)
466 -- (mkArityMsg binder)
467
468 ; lintIdUnfolding binder binder_ty (idUnfolding binder) }
469
470 -- We should check the unfolding, if any, but this is tricky because
471 -- the unfolding is a SimplifiableCoreExpr. Give up for now.
472 where
473 binder_ty = idType binder
474 bndr_vars = varSetElems (idFreeVars binder)
475
476 -- If you edit this function, you may need to update the GHC formalism
477 -- See Note [GHC Formalism]
478 lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
479 | otherwise = return ()
480
481 lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
482 lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
483 | isStableSource src
484 = do { ty <- lintCoreExpr rhs
485 ; checkTys bndr_ty ty (mkRhsMsg bndr (ptext (sLit "unfolding")) ty) }
486 lintIdUnfolding _ _ _
487 = return () -- We could check more
488
489 {-
490 Note [Checking for INLINE loop breakers]
491 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
492 It's very suspicious if a strong loop breaker is marked INLINE.
493
494 However, the desugarer generates instance methods with INLINE pragmas
495 that form a mutually recursive group. Only after a round of
496 simplification are they unravelled. So we suppress the test for
497 the desugarer.
498
499 ************************************************************************
500 * *
501 \subsection[lintCoreExpr]{lintCoreExpr}
502 * *
503 ************************************************************************
504 -}
505
506 --type InKind = Kind -- Substitution not yet applied
507 type InType = Type
508 type InCoercion = Coercion
509 type InVar = Var
510 type InTyVar = TyVar
511
512 type OutKind = Kind -- Substitution has been applied to this,
513 -- but has not been linted yet
514 type LintedKind = Kind -- Substitution applied, and type is linted
515
516 type OutType = Type -- Substitution has been applied to this,
517 -- but has not been linted yet
518
519 type LintedType = Type -- Substitution applied, and type is linted
520
521 type OutCoercion = Coercion
522 type OutVar = Var
523 type OutTyVar = TyVar
524
525 lintCoreExpr :: CoreExpr -> LintM OutType
526 -- The returned type has the substitution from the monad
527 -- already applied to it:
528 -- lintCoreExpr e subst = exprType (subst e)
529 --
530 -- The returned "type" can be a kind, if the expression is (Type ty)
531
532 -- If you edit this function, you may need to update the GHC formalism
533 -- See Note [GHC Formalism]
534 lintCoreExpr (Var var)
535 = do { checkL (not (var == oneTupleDataConId))
536 (ptext (sLit "Illegal one-tuple"))
537
538 ; checkL (isId var && not (isCoVar var))
539 (ptext (sLit "Non term variable") <+> ppr var)
540
541 ; checkDeadIdOcc var
542 ; var' <- lookupIdInScope var
543 ; return (idType var') }
544
545 lintCoreExpr (Lit lit)
546 = return (literalType lit)
547
548 lintCoreExpr (Cast expr co)
549 = do { expr_ty <- lintCoreExpr expr
550 ; co' <- applySubstCo co
551 ; (_, from_ty, to_ty, r) <- lintCoercion co'
552 ; checkRole co' Representational r
553 ; checkTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)
554 ; return to_ty }
555
556 lintCoreExpr (Tick (Breakpoint _ ids) expr)
557 = do forM_ ids $ \id -> do
558 checkDeadIdOcc id
559 lookupIdInScope id
560 lintCoreExpr expr
561
562 lintCoreExpr (Tick _other_tickish expr)
563 = lintCoreExpr expr
564
565 lintCoreExpr (Let (NonRec tv (Type ty)) body)
566 | isTyVar tv
567 = -- See Note [Linting type lets]
568 do { ty' <- applySubstTy ty
569 ; lintTyBndr tv $ \ tv' ->
570 do { addLoc (RhsOf tv) $ checkTyKind tv' ty'
571 -- Now extend the substitution so we
572 -- take advantage of it in the body
573 ; extendSubstL tv' ty' $
574 addLoc (BodyOfLetRec [tv]) $
575 lintCoreExpr body } }
576
577 lintCoreExpr (Let (NonRec bndr rhs) body)
578 | isId bndr
579 = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
580 ; addLoc (BodyOfLetRec [bndr])
581 (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
582
583 | otherwise
584 = failWithL (mkLetErr bndr rhs) -- Not quite accurate
585
586 lintCoreExpr (Let (Rec pairs) body)
587 = lintAndScopeIds bndrs $ \_ ->
588 do { checkL (null dups) (dupVars dups)
589 ; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
590 ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
591 where
592 bndrs = map fst pairs
593 (_, dups) = removeDups compare bndrs
594
595 lintCoreExpr e@(App _ _)
596 = do { fun_ty <- lintCoreExpr fun
597 ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args }
598 where
599 (fun, args) = collectArgs e
600
601 lintCoreExpr (Lam var expr)
602 = addLoc (LambdaBodyOf var) $
603 lintBinder var $ \ var' ->
604 do { body_ty <- lintCoreExpr expr
605 ; if isId var' then
606 return (mkFunTy (idType var') body_ty)
607 else
608 return (mkForAllTy var' body_ty)
609 }
610 -- The applySubstTy is needed to apply the subst to var
611
612 lintCoreExpr e@(Case scrut var alt_ty alts) =
613 -- Check the scrutinee
614 do { scrut_ty <- lintCoreExpr scrut
615 ; alt_ty <- lintInTy alt_ty
616 ; var_ty <- lintInTy (idType var)
617
618 ; case tyConAppTyCon_maybe (idType var) of
619 Just tycon
620 | debugIsOn &&
621 isAlgTyCon tycon &&
622 not (isFamilyTyCon tycon || isAbstractTyCon tycon) &&
623 null (tyConDataCons tycon) ->
624 pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
625 -- This can legitimately happen for type families
626 $ return ()
627 _otherwise -> return ()
628
629 -- Don't use lintIdBndr on var, because unboxed tuple is legitimate
630
631 ; subst <- getTvSubst
632 ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
633
634 ; lintAndScopeId var $ \_ ->
635 do { -- Check the alternatives
636 mapM_ (lintCoreAlt scrut_ty alt_ty) alts
637 ; checkCaseAlts e scrut_ty alts
638 ; return alt_ty } }
639
640 -- This case can't happen; linting types in expressions gets routed through
641 -- lintCoreArgs
642 lintCoreExpr (Type ty)
643 = pprPanic "lintCoreExpr" (ppr ty)
644
645 lintCoreExpr (Coercion co)
646 = do { (_kind, ty1, ty2, role) <- lintInCo co
647 ; return (mkCoercionType role ty1 ty2) }
648
649 {-
650 Note [Kind instantiation in coercions]
651 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
652 Consider the following coercion axiom:
653 ax_co [(k_ag :: BOX), (f_aa :: k_ag -> Constraint)] :: T k_ag f_aa ~ f_aa
654
655 Consider the following instantiation:
656 ax_co <* -> *> <Monad>
657
658 We need to split the co_ax_tvs into kind and type variables in order
659 to find out the coercion kind instantiations. Those can only be Refl
660 since we don't have kind coercions. This is just a way to represent
661 kind instantiation.
662
663 We use the number of kind variables to know how to split the coercions
664 instantiations between kind coercions and type coercions. We lint the
665 kind coercions and produce the following substitution which is to be
666 applied in the type variables:
667 k_ag ~~> * -> *
668
669 ************************************************************************
670 * *
671 \subsection[lintCoreArgs]{lintCoreArgs}
672 * *
673 ************************************************************************
674
675 The basic version of these functions checks that the argument is a
676 subtype of the required type, as one would expect.
677 -}
678
679 lintCoreArg :: OutType -> CoreArg -> LintM OutType
680 lintCoreArg fun_ty (Type arg_ty)
681 = do { arg_ty' <- applySubstTy arg_ty
682 ; lintTyApp fun_ty arg_ty' }
683
684 lintCoreArg fun_ty arg
685 = do { arg_ty <- lintCoreExpr arg
686 ; checkL (not (isUnLiftedType arg_ty) || exprOkForSpeculation arg)
687 (mkLetAppMsg arg)
688 ; lintValApp arg fun_ty arg_ty }
689
690 -----------------
691 lintAltBinders :: OutType -- Scrutinee type
692 -> OutType -- Constructor type
693 -> [OutVar] -- Binders
694 -> LintM ()
695 -- If you edit this function, you may need to update the GHC formalism
696 -- See Note [GHC Formalism]
697 lintAltBinders scrut_ty con_ty []
698 = checkTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty)
699 lintAltBinders scrut_ty con_ty (bndr:bndrs)
700 | isTyVar bndr
701 = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)
702 ; lintAltBinders scrut_ty con_ty' bndrs }
703 | otherwise
704 = do { con_ty' <- lintValApp (Var bndr) con_ty (idType bndr)
705 ; lintAltBinders scrut_ty con_ty' bndrs }
706
707 -----------------
708 lintTyApp :: OutType -> OutType -> LintM OutType
709 lintTyApp fun_ty arg_ty
710 | Just (tyvar,body_ty) <- splitForAllTy_maybe fun_ty
711 , isTyVar tyvar
712 = do { checkTyKind tyvar arg_ty
713 ; return (substTyWith [tyvar] [arg_ty] body_ty) }
714
715 | otherwise
716 = failWithL (mkTyAppMsg fun_ty arg_ty)
717
718 -----------------
719 lintValApp :: CoreExpr -> OutType -> OutType -> LintM OutType
720 lintValApp arg fun_ty arg_ty
721 | Just (arg,res) <- splitFunTy_maybe fun_ty
722 = do { checkTys arg arg_ty err1
723 ; return res }
724 | otherwise
725 = failWithL err2
726 where
727 err1 = mkAppMsg fun_ty arg_ty arg
728 err2 = mkNonFunAppMsg fun_ty arg_ty arg
729
730 checkTyKind :: OutTyVar -> OutType -> LintM ()
731 -- Both args have had substitution applied
732
733 -- If you edit this function, you may need to update the GHC formalism
734 -- See Note [GHC Formalism]
735 checkTyKind tyvar arg_ty
736 | isSuperKind tyvar_kind -- kind forall
737 = lintKind arg_ty
738 -- Arg type might be boxed for a function with an uncommitted
739 -- tyvar; notably this is used so that we can give
740 -- error :: forall a:*. String -> a
741 -- and then apply it to both boxed and unboxed types.
742 | otherwise -- type forall
743 = do { arg_kind <- lintType arg_ty
744 ; unless (arg_kind `isSubKind` tyvar_kind)
745 (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "xx" <+> ppr arg_kind))) }
746 where
747 tyvar_kind = tyVarKind tyvar
748
749 checkDeadIdOcc :: Id -> LintM ()
750 -- Occurrences of an Id should never be dead....
751 -- except when we are checking a case pattern
752 checkDeadIdOcc id
753 | isDeadOcc (idOccInfo id)
754 = do { in_case <- inCasePat
755 ; checkL in_case
756 (ptext (sLit "Occurrence of a dead Id") <+> ppr id) }
757 | otherwise
758 = return ()
759
760 {-
761 ************************************************************************
762 * *
763 \subsection[lintCoreAlts]{lintCoreAlts}
764 * *
765 ************************************************************************
766 -}
767
768 checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
769 -- a) Check that the alts are non-empty
770 -- b1) Check that the DEFAULT comes first, if it exists
771 -- b2) Check that the others are in increasing order
772 -- c) Check that there's a default for infinite types
773 -- NB: Algebraic cases are not necessarily exhaustive, because
774 -- the simplifer correctly eliminates case that can't
775 -- possibly match.
776
777 checkCaseAlts e ty alts =
778 do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
779 ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
780
781 -- For types Int#, Word# with an infinite (well, large!) number of
782 -- possible values, there should usually be a DEFAULT case
783 -- But (see Note [Empty case alternatives] in CoreSyn) it's ok to
784 -- have *no* case alternatives.
785 -- In effect, this is a kind of partial test. I suppose it's possible
786 -- that we might *know* that 'x' was 1 or 2, in which case
787 -- case x of { 1 -> e1; 2 -> e2 }
788 -- would be fine.
789 ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts)
790 (nonExhaustiveAltsMsg e) }
791 where
792 (con_alts, maybe_deflt) = findDefault alts
793
794 -- Check that successive alternatives have increasing tags
795 increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
796 increasing_tag _ = True
797
798 non_deflt (DEFAULT, _, _) = False
799 non_deflt _ = True
800
801 is_infinite_ty = case tyConAppTyCon_maybe ty of
802 Nothing -> False
803 Just tycon -> isPrimTyCon tycon
804
805 checkAltExpr :: CoreExpr -> OutType -> LintM ()
806 checkAltExpr expr ann_ty
807 = do { actual_ty <- lintCoreExpr expr
808 ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
809
810 lintCoreAlt :: OutType -- Type of scrutinee
811 -> OutType -- Type of the alternative
812 -> CoreAlt
813 -> LintM ()
814 -- If you edit this function, you may need to update the GHC formalism
815 -- See Note [GHC Formalism]
816 lintCoreAlt _ alt_ty (DEFAULT, args, rhs) =
817 do { checkL (null args) (mkDefaultArgsMsg args)
818 ; checkAltExpr rhs alt_ty }
819
820 lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs)
821 | litIsLifted lit
822 = failWithL integerScrutinisedMsg
823 | otherwise
824 = do { checkL (null args) (mkDefaultArgsMsg args)
825 ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
826 ; checkAltExpr rhs alt_ty }
827 where
828 lit_ty = literalType lit
829
830 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
831 | isNewTyCon (dataConTyCon con)
832 = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
833 | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
834 = addLoc (CaseAlt alt) $ do
835 { -- First instantiate the universally quantified
836 -- type variables of the data constructor
837 -- We've already check
838 checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
839 ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys
840
841 -- And now bring the new binders into scope
842 ; lintBinders args $ \ args' -> do
843 { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args')
844 ; checkAltExpr rhs alt_ty } }
845
846 | otherwise -- Scrut-ty is wrong shape
847 = addErrL (mkBadAltMsg scrut_ty alt)
848
849 {-
850 ************************************************************************
851 * *
852 \subsection[lint-types]{Types}
853 * *
854 ************************************************************************
855 -}
856
857 -- When we lint binders, we (one at a time and in order):
858 -- 1. Lint var types or kinds (possibly substituting)
859 -- 2. Add the binder to the in scope set, and if its a coercion var,
860 -- we may extend the substitution to reflect its (possibly) new kind
861 lintBinders :: [Var] -> ([Var] -> LintM a) -> LintM a
862 lintBinders [] linterF = linterF []
863 lintBinders (var:vars) linterF = lintBinder var $ \var' ->
864 lintBinders vars $ \ vars' ->
865 linterF (var':vars')
866
867 -- If you edit this function, you may need to update the GHC formalism
868 -- See Note [GHC Formalism]
869 lintBinder :: Var -> (Var -> LintM a) -> LintM a
870 lintBinder var linterF
871 | isId var = lintIdBndr var linterF
872 | otherwise = lintTyBndr var linterF
873
874 lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a
875 lintTyBndr tv thing_inside
876 = do { subst <- getTvSubst
877 ; let (subst', tv') = Type.substTyVarBndr subst tv
878 ; lintTyBndrKind tv'
879 ; updateTvSubst subst' (thing_inside tv') }
880
881 lintIdBndr :: Id -> (Id -> LintM a) -> LintM a
882 -- Do substitution on the type of a binder and add the var with this
883 -- new type to the in-scope set of the second argument
884 -- ToDo: lint its rules
885
886 lintIdBndr id linterF
887 = do { lintAndScopeId id $ \id' -> linterF id' }
888
889 lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a
890 lintAndScopeIds ids linterF
891 = go ids
892 where
893 go [] = linterF []
894 go (id:ids) = lintAndScopeId id $ \id ->
895 lintAndScopeIds ids $ \ids ->
896 linterF (id:ids)
897
898 lintAndScopeId :: InVar -> (OutVar -> LintM a) -> LintM a
899 lintAndScopeId id linterF
900 = do { flags <- getLintFlags
901 ; checkL (not (lf_check_global_ids flags) || isLocalId id)
902 (ptext (sLit "Non-local Id binder") <+> ppr id)
903 -- See Note [Checking for global Ids]
904 ; ty <- lintInTy (idType id)
905 ; let id' = setIdType id ty
906 ; addInScopeVar id' $ (linterF id') }
907
908 {-
909 ************************************************************************
910 * *
911 Types and kinds
912 * *
913 ************************************************************************
914
915 We have a single linter for types and kinds. That is convenient
916 because sometimes it's not clear whether the thing we are looking
917 at is a type or a kind.
918 -}
919
920 lintInTy :: InType -> LintM LintedType
921 -- Types only, not kinds
922 -- Check the type, and apply the substitution to it
923 -- See Note [Linting type lets]
924 lintInTy ty
925 = addLoc (InType ty) $
926 do { ty' <- applySubstTy ty
927 ; _k <- lintType ty'
928 ; return ty' }
929
930 -------------------
931 lintTyBndrKind :: OutTyVar -> LintM ()
932 -- Handles both type and kind foralls.
933 lintTyBndrKind tv = lintKind (tyVarKind tv)
934
935 -------------------
936 lintType :: OutType -> LintM LintedKind
937 -- The returned Kind has itself been linted
938
939 -- If you edit this function, you may need to update the GHC formalism
940 -- See Note [GHC Formalism]
941 lintType (TyVarTy tv)
942 = do { checkTyCoVarInScope tv
943 ; return (tyVarKind tv) }
944 -- We checked its kind when we added it to the envt
945
946 lintType ty@(AppTy t1 t2)
947 = do { k1 <- lintType t1
948 ; k2 <- lintType t2
949 ; lint_ty_app ty k1 [(t2,k2)] }
950
951 lintType ty@(FunTy t1 t2) -- (->) has two different rules, for types and kinds
952 = do { k1 <- lintType t1
953 ; k2 <- lintType t2
954 ; lintArrow (ptext (sLit "type or kind") <+> quotes (ppr ty)) k1 k2 }
955
956 lintType ty@(TyConApp tc tys)
957 | Just ty' <- coreView ty
958 = lintType ty' -- Expand type synonyms, so that we do not bogusly complain
959 -- about un-saturated type synonyms
960
961 | isUnLiftedTyCon tc || isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
962 -- See Note [The kind invariant] in TypeRep
963 -- Also type synonyms and type families
964 , length tys < tyConArity tc
965 = failWithL (hang (ptext (sLit "Un-saturated type application")) 2 (ppr ty))
966
967 | otherwise
968 = do { ks <- mapM lintType tys
969 ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) }
970
971 lintType (ForAllTy tv ty)
972 = do { lintTyBndrKind tv
973 ; addInScopeVar tv (lintType ty) }
974
975 lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty)
976
977 lintKind :: OutKind -> LintM ()
978 -- If you edit this function, you may need to update the GHC formalism
979 -- See Note [GHC Formalism]
980 lintKind k = do { sk <- lintType k
981 ; unless (isSuperKind sk)
982 (addErrL (hang (ptext (sLit "Ill-kinded kind:") <+> ppr k)
983 2 (ptext (sLit "has kind:") <+> ppr sk))) }
984
985 lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind
986 -- If you edit this function, you may need to update the GHC formalism
987 -- See Note [GHC Formalism]
988 lintArrow what k1 k2 -- Eg lintArrow "type or kind `blah'" k1 k2
989 -- or lintarrow "coercion `blah'" k1 k2
990 | isSuperKind k1
991 = return superKind
992 | otherwise
993 = do { unless (okArrowArgKind k1) (addErrL (msg (ptext (sLit "argument")) k1))
994 ; unless (okArrowResultKind k2) (addErrL (msg (ptext (sLit "result")) k2))
995 ; return liftedTypeKind }
996 where
997 msg ar k
998 = vcat [ hang (ptext (sLit "Ill-kinded") <+> ar)
999 2 (ptext (sLit "in") <+> what)
1000 , what <+> ptext (sLit "kind:") <+> ppr k ]
1001
1002 lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind
1003 lint_ty_app ty k tys
1004 = lint_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys
1005
1006 ----------------
1007 lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind
1008 lint_co_app ty k tys
1009 = lint_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys
1010
1011 ----------------
1012 lintTyLit :: TyLit -> LintM ()
1013 lintTyLit (NumTyLit n)
1014 | n >= 0 = return ()
1015 | otherwise = failWithL msg
1016 where msg = ptext (sLit "Negative type literal:") <+> integer n
1017 lintTyLit (StrTyLit _) = return ()
1018
1019 lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind
1020 -- (lint_app d fun_kind arg_tys)
1021 -- We have an application (f arg_ty1 .. arg_tyn),
1022 -- where f :: fun_kind
1023 -- Takes care of linting the OutTypes
1024
1025 -- If you edit this function, you may need to update the GHC formalism
1026 -- See Note [GHC Formalism]
1027 lint_app doc kfn kas
1028 = foldlM go_app kfn kas
1029 where
1030 fail_msg = vcat [ hang (ptext (sLit "Kind application error in")) 2 doc
1031 , nest 2 (ptext (sLit "Function kind =") <+> ppr kfn)
1032 , nest 2 (ptext (sLit "Arg kinds =") <+> ppr kas) ]
1033
1034 go_app kfn ka
1035 | Just kfn' <- coreView kfn
1036 = go_app kfn' ka
1037
1038 go_app (FunTy kfa kfb) (_,ka)
1039 = do { unless (ka `isSubKind` kfa) (addErrL fail_msg)
1040 ; return kfb }
1041
1042 go_app (ForAllTy kv kfn) (ta,ka)
1043 = do { unless (ka `isSubKind` tyVarKind kv) (addErrL fail_msg)
1044 ; return (substKiWith [kv] [ta] kfn) }
1045
1046 go_app _ _ = failWithL fail_msg
1047
1048 {-
1049 ************************************************************************
1050 * *
1051 Linting coercions
1052 * *
1053 ************************************************************************
1054 -}
1055
1056 lintInCo :: InCoercion -> LintM (LintedKind, LintedType, LintedType, Role)
1057 -- Check the coercion, and apply the substitution to it
1058 -- See Note [Linting type lets]
1059 lintInCo co
1060 = addLoc (InCo co) $
1061 do { co' <- applySubstCo co
1062 ; lintCoercion co' }
1063
1064 lintCoercion :: OutCoercion -> LintM (LintedKind, LintedType, LintedType, Role)
1065 -- Check the kind of a coercion term, returning the kind
1066 -- Post-condition: the returned OutTypes are lint-free
1067 -- and have the same kind as each other
1068
1069 -- If you edit this function, you may need to update the GHC formalism
1070 -- See Note [GHC Formalism]
1071 lintCoercion (Refl r ty)
1072 = do { k <- lintType ty
1073 ; return (k, ty, ty, r) }
1074
1075 lintCoercion co@(TyConAppCo r tc cos)
1076 | tc `hasKey` funTyConKey
1077 , [co1,co2] <- cos
1078 = do { (k1,s1,t1,r1) <- lintCoercion co1
1079 ; (k2,s2,t2,r2) <- lintCoercion co2
1080 ; rk <- lintArrow (ptext (sLit "coercion") <+> quotes (ppr co)) k1 k2
1081 ; checkRole co1 r r1
1082 ; checkRole co2 r r2
1083 ; return (rk, mkFunTy s1 s2, mkFunTy t1 t2, r) }
1084
1085 | Just {} <- synTyConDefn_maybe tc
1086 = failWithL (ptext (sLit "Synonym in TyConAppCo:") <+> ppr co)
1087
1088 | otherwise
1089 = do { (ks,ss,ts,rs) <- mapAndUnzip4M lintCoercion cos
1090 ; rk <- lint_co_app co (tyConKind tc) (ss `zip` ks)
1091 ; _ <- zipWith3M checkRole cos (tyConRolesX r tc) rs
1092 ; return (rk, mkTyConApp tc ss, mkTyConApp tc ts, r) }
1093
1094 lintCoercion co@(AppCo co1 co2)
1095 = do { (k1,s1,t1,r1) <- lintCoercion co1
1096 ; (k2,s2,t2,r2) <- lintCoercion co2
1097 ; rk <- lint_co_app co k1 [(s2,k2)]
1098 ; if r1 == Phantom
1099 then checkL (r2 == Phantom || r2 == Nominal)
1100 (ptext (sLit "Second argument in AppCo cannot be R:") $$
1101 ppr co)
1102 else checkRole co Nominal r2
1103 ; return (rk, mkAppTy s1 s2, mkAppTy t1 t2, r1) }
1104
1105 lintCoercion (ForAllCo tv co)
1106 = do { lintTyBndrKind tv
1107 ; (k, s, t, r) <- addInScopeVar tv (lintCoercion co)
1108 ; return (k, mkForAllTy tv s, mkForAllTy tv t, r) }
1109
1110 lintCoercion (CoVarCo cv)
1111 | not (isCoVar cv)
1112 = failWithL (hang (ptext (sLit "Bad CoVarCo:") <+> ppr cv)
1113 2 (ptext (sLit "With offending type:") <+> ppr (varType cv)))
1114 | otherwise
1115 = do { checkTyCoVarInScope cv
1116 ; cv' <- lookupIdInScope cv
1117 ; let (s,t) = coVarKind cv'
1118 k = typeKind s
1119 r = coVarRole cv'
1120 ; when (isSuperKind k) $
1121 do { checkL (r == Nominal) (hang (ptext (sLit "Non-nominal kind equality"))
1122 2 (ppr cv))
1123 ; checkL (s `eqKind` t) (hang (ptext (sLit "Non-refl kind equality"))
1124 2 (ppr cv)) }
1125 ; return (k, s, t, r) }
1126
1127 lintCoercion (UnivCo _prov r ty1 ty2)
1128 = do { k1 <- lintType ty1
1129 ; _k2 <- lintType ty2
1130 -- ; unless (k1 `eqKind` k2) $
1131 -- failWithL (hang (ptext (sLit "Unsafe coercion changes kind"))
1132 -- 2 (ppr co))
1133 ; return (k1, ty1, ty2, r) }
1134
1135 lintCoercion (SymCo co)
1136 = do { (k, ty1, ty2, r) <- lintCoercion co
1137 ; return (k, ty2, ty1, r) }
1138
1139 lintCoercion co@(TransCo co1 co2)
1140 = do { (k1, ty1a, ty1b, r1) <- lintCoercion co1
1141 ; (_, ty2a, ty2b, r2) <- lintCoercion co2
1142 ; checkL (ty1b `eqType` ty2a)
1143 (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co)
1144 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b]))
1145 ; checkRole co r1 r2
1146 ; return (k1, ty1a, ty2b, r1) }
1147
1148 lintCoercion the_co@(NthCo n co)
1149 = do { (_,s,t,r) <- lintCoercion co
1150 ; case (splitTyConApp_maybe s, splitTyConApp_maybe t) of
1151 (Just (tc_s, tys_s), Just (tc_t, tys_t))
1152 | tc_s == tc_t
1153 , tys_s `equalLength` tys_t
1154 , n < length tys_s
1155 -> return (ks, ts, tt, tr)
1156 where
1157 ts = getNth tys_s n
1158 tt = getNth tys_t n
1159 tr = nthRole r tc_s n
1160 ks = typeKind ts
1161
1162 _ -> failWithL (hang (ptext (sLit "Bad getNth:"))
1163 2 (ppr the_co $$ ppr s $$ ppr t)) }
1164
1165 lintCoercion the_co@(LRCo lr co)
1166 = do { (_,s,t,r) <- lintCoercion co
1167 ; checkRole co Nominal r
1168 ; case (splitAppTy_maybe s, splitAppTy_maybe t) of
1169 (Just s_pr, Just t_pr)
1170 -> return (k, s_pick, t_pick, Nominal)
1171 where
1172 s_pick = pickLR lr s_pr
1173 t_pick = pickLR lr t_pr
1174 k = typeKind s_pick
1175
1176 _ -> failWithL (hang (ptext (sLit "Bad LRCo:"))
1177 2 (ppr the_co $$ ppr s $$ ppr t)) }
1178
1179 lintCoercion (InstCo co arg_ty)
1180 = do { (k,s,t,r) <- lintCoercion co
1181 ; arg_kind <- lintType arg_ty
1182 ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of
1183 (Just (tv1,ty1), Just (tv2,ty2))
1184 | arg_kind `isSubKind` tyVarKind tv1
1185 -> return (k, substTyWith [tv1] [arg_ty] ty1,
1186 substTyWith [tv2] [arg_ty] ty2, r)
1187 | otherwise
1188 -> failWithL (ptext (sLit "Kind mis-match in inst coercion"))
1189 _ -> failWithL (ptext (sLit "Bad argument of inst")) }
1190
1191 lintCoercion co@(AxiomInstCo con ind cos)
1192 = do { unless (0 <= ind && ind < brListLength (coAxiomBranches con))
1193 (bad_ax (ptext (sLit "index out of range")))
1194 -- See Note [Kind instantiation in coercions]
1195 ; let CoAxBranch { cab_tvs = ktvs
1196 , cab_roles = roles
1197 , cab_lhs = lhs
1198 , cab_rhs = rhs } = coAxiomNthBranch con ind
1199 ; unless (equalLength ktvs cos) (bad_ax (ptext (sLit "lengths")))
1200 ; in_scope <- getInScope
1201 ; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv
1202 ; (subst_l, subst_r) <- foldlM check_ki
1203 (empty_subst, empty_subst)
1204 (zip3 ktvs roles cos)
1205 ; let lhs' = Type.substTys subst_l lhs
1206 rhs' = Type.substTy subst_r rhs
1207 ; case checkAxInstCo co of
1208 Just bad_branch -> bad_ax $ ptext (sLit "inconsistent with") <+> (pprCoAxBranch (coAxiomTyCon con) bad_branch)
1209 Nothing -> return ()
1210 ; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs', coAxiomRole con) }
1211 where
1212 bad_ax what = addErrL (hang (ptext (sLit "Bad axiom application") <+> parens what)
1213 2 (ppr co))
1214
1215 check_ki (subst_l, subst_r) (ktv, role, co)
1216 = do { (k, t1, t2, r) <- lintCoercion co
1217 ; checkRole co role r
1218 ; let ktv_kind = Type.substTy subst_l (tyVarKind ktv)
1219 -- Using subst_l is ok, because subst_l and subst_r
1220 -- must agree on kind equalities
1221 ; unless (k `isSubKind` ktv_kind)
1222 (bad_ax (ptext (sLit "check_ki2") <+> vcat [ ppr co, ppr k, ppr ktv, ppr ktv_kind ] ))
1223 ; return (Type.extendTvSubst subst_l ktv t1,
1224 Type.extendTvSubst subst_r ktv t2) }
1225
1226 lintCoercion co@(SubCo co')
1227 = do { (k,s,t,r) <- lintCoercion co'
1228 ; checkRole co Nominal r
1229 ; return (k,s,t,Representational) }
1230
1231
1232 lintCoercion this@(AxiomRuleCo co ts cs)
1233 = do _ks <- mapM lintType ts
1234 eqs <- mapM lintCoercion cs
1235
1236 let tyNum = length ts
1237
1238 case compare (coaxrTypeArity co) tyNum of
1239 EQ -> return ()
1240 LT -> err "Too many type arguments"
1241 [ txt "expected" <+> int (coaxrTypeArity co)
1242 , txt "provided" <+> int tyNum ]
1243 GT -> err "Not enough type arguments"
1244 [ txt "expected" <+> int (coaxrTypeArity co)
1245 , txt "provided" <+> int tyNum ]
1246 checkRoles 0 (coaxrAsmpRoles co) eqs
1247
1248 case coaxrProves co ts [ Pair l r | (_,l,r,_) <- eqs ] of
1249 Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ]
1250 Just (Pair l r) ->
1251 do kL <- lintType l
1252 kR <- lintType r
1253 unless (eqKind kL kR)
1254 $ err "Kind error in CoAxiomRule"
1255 [ppr kL <+> txt "/=" <+> ppr kR]
1256 return (kL, l, r, coaxrRole co)
1257 where
1258 txt = ptext . sLit
1259 err m xs = failWithL $
1260 hang (txt m) 2 $ vcat (txt "Rule:" <+> ppr (coaxrName co) : xs)
1261
1262 checkRoles n (e : es) ((_,_,_,r) : rs)
1263 | e == r = checkRoles (n+1) es rs
1264 | otherwise = err "Argument roles mismatch"
1265 [ txt "In argument:" <+> int (n+1)
1266 , txt "Expected:" <+> ppr e
1267 , txt "Found:" <+> ppr r ]
1268 checkRoles _ [] [] = return ()
1269 checkRoles n [] rs = err "Too many coercion arguments"
1270 [ txt "Expected:" <+> int n
1271 , txt "Provided:" <+> int (n + length rs) ]
1272
1273 checkRoles n es [] = err "Not enough coercion arguments"
1274 [ txt "Expected:" <+> int (n + length es)
1275 , txt "Provided:" <+> int n ]
1276
1277 {-
1278 ************************************************************************
1279 * *
1280 \subsection[lint-monad]{The Lint monad}
1281 * *
1282 ************************************************************************
1283 -}
1284
1285 -- If you edit this type, you may need to update the GHC formalism
1286 -- See Note [GHC Formalism]
1287 data LintEnv
1288 = LE { le_flags :: LintFlags -- Linting the result of this pass
1289 , le_loc :: [LintLocInfo] -- Locations
1290 , le_subst :: TvSubst -- Current type substitution; we also use this
1291 } -- to keep track of all the variables in scope,
1292 -- both Ids and TyVars
1293
1294 data LintFlags
1295 = LF { lf_check_global_ids :: Bool -- See Note [Checking for global Ids]
1296 , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers]
1297 }
1298
1299 defaultLintFlags :: LintFlags
1300 defaultLintFlags = LF { lf_check_global_ids = False
1301 , lf_check_inline_loop_breakers = True }
1302
1303 newtype LintM a =
1304 LintM { unLintM ::
1305 LintEnv ->
1306 WarnsAndErrs -> -- Error and warning messages so far
1307 (Maybe a, WarnsAndErrs) } -- Result and messages (if any)
1308
1309 type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)
1310
1311 {- Note [Checking for global Ids]
1312 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1313 Before CoreTidy, all locally-bound Ids must be LocalIds, even
1314 top-level ones. See Note [Exported LocalIds] and Trac #9857.
1315
1316 Note [Type substitution]
1317 ~~~~~~~~~~~~~~~~~~~~~~~~
1318 Why do we need a type substitution? Consider
1319 /\(a:*). \(x:a). /\(a:*). id a x
1320 This is ill typed, because (renaming variables) it is really
1321 /\(a:*). \(x:a). /\(b:*). id b x
1322 Hence, when checking an application, we can't naively compare x's type
1323 (at its binding site) with its expected type (at a use site). So we
1324 rename type binders as we go, maintaining a substitution.
1325
1326 The same substitution also supports let-type, current expressed as
1327 (/\(a:*). body) ty
1328 Here we substitute 'ty' for 'a' in 'body', on the fly.
1329 -}
1330
1331 instance Functor LintM where
1332 fmap = liftM
1333
1334 instance Applicative LintM where
1335 pure = return
1336 (<*>) = ap
1337
1338 instance Monad LintM where
1339 return x = LintM (\ _ errs -> (Just x, errs))
1340 fail err = failWithL (text err)
1341 m >>= k = LintM (\ env errs ->
1342 let (res, errs') = unLintM m env errs in
1343 case res of
1344 Just r -> unLintM (k r) env errs'
1345 Nothing -> (Nothing, errs'))
1346
1347 data LintLocInfo
1348 = RhsOf Id -- The variable bound
1349 | LambdaBodyOf Id -- The lambda-binder
1350 | BodyOfLetRec [Id] -- One of the binders
1351 | CaseAlt CoreAlt -- Case alternative
1352 | CasePat CoreAlt -- The *pattern* of the case alternative
1353 | AnExpr CoreExpr -- Some expression
1354 | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
1355 | TopLevelBindings
1356 | InType Type -- Inside a type
1357 | InCo Coercion -- Inside a coercion
1358
1359 initL :: LintFlags -> LintM a -> WarnsAndErrs -- Errors and warnings
1360 initL flags m
1361 = case unLintM m env (emptyBag, emptyBag) of
1362 (_, errs) -> errs
1363 where
1364 env = LE { le_flags = flags, le_subst = emptyTvSubst, le_loc = [] }
1365
1366 getLintFlags :: LintM LintFlags
1367 getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs)
1368
1369 checkL :: Bool -> MsgDoc -> LintM ()
1370 checkL True _ = return ()
1371 checkL False msg = failWithL msg
1372
1373 failWithL :: MsgDoc -> LintM a
1374 failWithL msg = LintM $ \ env (warns,errs) ->
1375 (Nothing, (warns, addMsg env errs msg))
1376
1377 addErrL :: MsgDoc -> LintM ()
1378 addErrL msg = LintM $ \ env (warns,errs) ->
1379 (Just (), (warns, addMsg env errs msg))
1380
1381 addWarnL :: MsgDoc -> LintM ()
1382 addWarnL msg = LintM $ \ env (warns,errs) ->
1383 (Just (), (addMsg env warns msg, errs))
1384
1385 addMsg :: LintEnv -> Bag MsgDoc -> MsgDoc -> Bag MsgDoc
1386 addMsg env msgs msg
1387 = ASSERT( notNull locs )
1388 msgs `snocBag` mk_msg msg
1389 where
1390 locs = le_loc env
1391 (loc, cxt1) = dumpLoc (head locs)
1392 cxts = [snd (dumpLoc loc) | loc <- locs]
1393 context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
1394 ptext (sLit "Substitution:") <+> ppr (le_subst env)
1395 | otherwise = cxt1
1396
1397 mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg)
1398
1399 addLoc :: LintLocInfo -> LintM a -> LintM a
1400 addLoc extra_loc m
1401 = LintM $ \ env errs ->
1402 unLintM m (env { le_loc = extra_loc : le_loc env }) errs
1403
1404 inCasePat :: LintM Bool -- A slight hack; see the unique call site
1405 inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs)
1406 where
1407 is_case_pat (LE { le_loc = CasePat {} : _ }) = True
1408 is_case_pat _other = False
1409
1410 addInScopeVars :: [Var] -> LintM a -> LintM a
1411 addInScopeVars vars m
1412 = LintM $ \ env errs ->
1413 unLintM m (env { le_subst = extendTvInScopeList (le_subst env) vars })
1414 errs
1415
1416 addInScopeVar :: Var -> LintM a -> LintM a
1417 addInScopeVar var m
1418 = LintM $ \ env errs ->
1419 unLintM m (env { le_subst = extendTvInScope (le_subst env) var }) errs
1420
1421 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
1422 extendSubstL tv ty m
1423 = LintM $ \ env errs ->
1424 unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs
1425
1426 updateTvSubst :: TvSubst -> LintM a -> LintM a
1427 updateTvSubst subst' m
1428 = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs
1429
1430 getTvSubst :: LintM TvSubst
1431 getTvSubst = LintM (\ env errs -> (Just (le_subst env), errs))
1432
1433 getInScope :: LintM InScopeSet
1434 getInScope = LintM (\ env errs -> (Just (getTvInScope (le_subst env)), errs))
1435
1436 applySubstTy :: InType -> LintM OutType
1437 applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) }
1438
1439 applySubstCo :: InCoercion -> LintM OutCoercion
1440 applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co) }
1441
1442 lookupIdInScope :: Id -> LintM Id
1443 lookupIdInScope id
1444 | not (mustHaveLocalBinding id)
1445 = return id -- An imported Id
1446 | otherwise
1447 = do { subst <- getTvSubst
1448 ; case lookupInScope (getTvInScope subst) id of
1449 Just v -> return v
1450 Nothing -> do { addErrL out_of_scope
1451 ; return id } }
1452 where
1453 out_of_scope = pprBndr LetBind id <+> ptext (sLit "is out of scope")
1454
1455
1456 oneTupleDataConId :: Id -- Should not happen
1457 oneTupleDataConId = dataConWorkId (tupleCon BoxedTuple 1)
1458
1459 checkBndrIdInScope :: Var -> Var -> LintM ()
1460 checkBndrIdInScope binder id
1461 = checkInScope msg id
1462 where
1463 msg = ptext (sLit "is out of scope inside info for") <+>
1464 ppr binder
1465
1466 checkTyCoVarInScope :: Var -> LintM ()
1467 checkTyCoVarInScope v = checkInScope (ptext (sLit "is out of scope")) v
1468
1469 checkInScope :: SDoc -> Var -> LintM ()
1470 checkInScope loc_msg var =
1471 do { subst <- getTvSubst
1472 ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
1473 (hsep [pprBndr LetBind var, loc_msg]) }
1474
1475 checkTys :: OutType -> OutType -> MsgDoc -> LintM ()
1476 -- check ty2 is subtype of ty1 (ie, has same structure but usage
1477 -- annotations need only be consistent, not equal)
1478 -- Assumes ty1,ty2 are have alrady had the substitution applied
1479 checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg
1480
1481 checkRole :: Coercion
1482 -> Role -- expected
1483 -> Role -- actual
1484 -> LintM ()
1485 checkRole co r1 r2
1486 = checkL (r1 == r2)
1487 (ptext (sLit "Role incompatibility: expected") <+> ppr r1 <> comma <+>
1488 ptext (sLit "got") <+> ppr r2 $$
1489 ptext (sLit "in") <+> ppr co)
1490
1491 {-
1492 ************************************************************************
1493 * *
1494 \subsection{Error messages}
1495 * *
1496 ************************************************************************
1497 -}
1498
1499 dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)
1500
1501 dumpLoc (RhsOf v)
1502 = (getSrcLoc v, brackets (ptext (sLit "RHS of") <+> pp_binders [v]))
1503
1504 dumpLoc (LambdaBodyOf b)
1505 = (getSrcLoc b, brackets (ptext (sLit "in body of lambda with binder") <+> pp_binder b))
1506
1507 dumpLoc (BodyOfLetRec [])
1508 = (noSrcLoc, brackets (ptext (sLit "In body of a letrec with no binders")))
1509
1510 dumpLoc (BodyOfLetRec bs@(_:_))
1511 = ( getSrcLoc (head bs), brackets (ptext (sLit "in body of letrec with binders") <+> pp_binders bs))
1512
1513 dumpLoc (AnExpr e)
1514 = (noSrcLoc, text "In the expression:" <+> ppr e)
1515
1516 dumpLoc (CaseAlt (con, args, _))
1517 = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))
1518
1519 dumpLoc (CasePat (con, args, _))
1520 = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
1521
1522 dumpLoc (ImportedUnfolding locn)
1523 = (locn, brackets (ptext (sLit "in an imported unfolding")))
1524 dumpLoc TopLevelBindings
1525 = (noSrcLoc, Outputable.empty)
1526 dumpLoc (InType ty)
1527 = (noSrcLoc, text "In the type" <+> quotes (ppr ty))
1528 dumpLoc (InCo co)
1529 = (noSrcLoc, text "In the coercion" <+> quotes (ppr co))
1530
1531 pp_binders :: [Var] -> SDoc
1532 pp_binders bs = sep (punctuate comma (map pp_binder bs))
1533
1534 pp_binder :: Var -> SDoc
1535 pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
1536 | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)]
1537
1538 ------------------------------------------------------
1539 -- Messages for case expressions
1540
1541 mkDefaultArgsMsg :: [Var] -> MsgDoc
1542 mkDefaultArgsMsg args
1543 = hang (text "DEFAULT case with binders")
1544 4 (ppr args)
1545
1546 mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc
1547 mkCaseAltMsg e ty1 ty2
1548 = hang (text "Type of case alternatives not the same as the annotation on case:")
1549 4 (vcat [ppr ty1, ppr ty2, ppr e])
1550
1551 mkScrutMsg :: Id -> Type -> Type -> TvSubst -> MsgDoc
1552 mkScrutMsg var var_ty scrut_ty subst
1553 = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
1554 text "Result binder type:" <+> ppr var_ty,--(idType var),
1555 text "Scrutinee type:" <+> ppr scrut_ty,
1556 hsep [ptext (sLit "Current TV subst"), ppr subst]]
1557
1558 mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc
1559 mkNonDefltMsg e
1560 = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
1561 mkNonIncreasingAltsMsg e
1562 = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
1563
1564 nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc
1565 nonExhaustiveAltsMsg e
1566 = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
1567
1568 mkBadConMsg :: TyCon -> DataCon -> MsgDoc
1569 mkBadConMsg tycon datacon
1570 = vcat [
1571 text "In a case alternative, data constructor isn't in scrutinee type:",
1572 text "Scrutinee type constructor:" <+> ppr tycon,
1573 text "Data con:" <+> ppr datacon
1574 ]
1575
1576 mkBadPatMsg :: Type -> Type -> MsgDoc
1577 mkBadPatMsg con_result_ty scrut_ty
1578 = vcat [
1579 text "In a case alternative, pattern result type doesn't match scrutinee type:",
1580 text "Pattern result type:" <+> ppr con_result_ty,
1581 text "Scrutinee type:" <+> ppr scrut_ty
1582 ]
1583
1584 integerScrutinisedMsg :: MsgDoc
1585 integerScrutinisedMsg
1586 = text "In a LitAlt, the literal is lifted (probably Integer)"
1587
1588 mkBadAltMsg :: Type -> CoreAlt -> MsgDoc
1589 mkBadAltMsg scrut_ty alt
1590 = vcat [ text "Data alternative when scrutinee is not a tycon application",
1591 text "Scrutinee type:" <+> ppr scrut_ty,
1592 text "Alternative:" <+> pprCoreAlt alt ]
1593
1594 mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc
1595 mkNewTyDataConAltMsg scrut_ty alt
1596 = vcat [ text "Data alternative for newtype datacon",
1597 text "Scrutinee type:" <+> ppr scrut_ty,
1598 text "Alternative:" <+> pprCoreAlt alt ]
1599
1600
1601 ------------------------------------------------------
1602 -- Other error messages
1603
1604 mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc
1605 mkAppMsg fun_ty arg_ty arg
1606 = vcat [ptext (sLit "Argument value doesn't match argument type:"),
1607 hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
1608 hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
1609 hang (ptext (sLit "Arg:")) 4 (ppr arg)]
1610
1611 mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc
1612 mkNonFunAppMsg fun_ty arg_ty arg
1613 = vcat [ptext (sLit "Non-function type in function position"),
1614 hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
1615 hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
1616 hang (ptext (sLit "Arg:")) 4 (ppr arg)]
1617
1618 mkLetErr :: TyVar -> CoreExpr -> MsgDoc
1619 mkLetErr bndr rhs
1620 = vcat [ptext (sLit "Bad `let' binding:"),
1621 hang (ptext (sLit "Variable:"))
1622 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)),
1623 hang (ptext (sLit "Rhs:"))
1624 4 (ppr rhs)]
1625
1626 mkTyAppMsg :: Type -> Type -> MsgDoc
1627 mkTyAppMsg ty arg_ty
1628 = vcat [text "Illegal type application:",
1629 hang (ptext (sLit "Exp type:"))
1630 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
1631 hang (ptext (sLit "Arg type:"))
1632 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
1633
1634 mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc
1635 mkRhsMsg binder what ty
1636 = vcat
1637 [hsep [ptext (sLit "The type of this binder doesn't match the type of its") <+> what <> colon,
1638 ppr binder],
1639 hsep [ptext (sLit "Binder's type:"), ppr (idType binder)],
1640 hsep [ptext (sLit "Rhs type:"), ppr ty]]
1641
1642 mkLetAppMsg :: CoreExpr -> MsgDoc
1643 mkLetAppMsg e
1644 = hang (ptext (sLit "This argument does not satisfy the let/app invariant:"))
1645 2 (ppr e)
1646
1647 mkRhsPrimMsg :: Id -> CoreExpr -> MsgDoc
1648 mkRhsPrimMsg binder _rhs
1649 = vcat [hsep [ptext (sLit "The type of this binder is primitive:"),
1650 ppr binder],
1651 hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]
1652 ]
1653
1654 mkStrictMsg :: Id -> MsgDoc
1655 mkStrictMsg binder
1656 = vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"),
1657 ppr binder],
1658 hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)]
1659 ]
1660
1661 mkNonTopExportedMsg :: Id -> MsgDoc
1662 mkNonTopExportedMsg binder
1663 = hsep [ptext (sLit "Non-top-level binder is marked as exported:"), ppr binder]
1664
1665 mkNonTopExternalNameMsg :: Id -> MsgDoc
1666 mkNonTopExternalNameMsg binder
1667 = hsep [ptext (sLit "Non-top-level binder has an external name:"), ppr binder]
1668
1669 mkKindErrMsg :: TyVar -> Type -> MsgDoc
1670 mkKindErrMsg tyvar arg_ty
1671 = vcat [ptext (sLit "Kinds don't match in type application:"),
1672 hang (ptext (sLit "Type variable:"))
1673 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
1674 hang (ptext (sLit "Arg type:"))
1675 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
1676
1677 {- Not needed now
1678 mkArityMsg :: Id -> MsgDoc
1679 mkArityMsg binder
1680 = vcat [hsep [ptext (sLit "Demand type has"),
1681 ppr (dmdTypeDepth dmd_ty),
1682 ptext (sLit "arguments, rhs has"),
1683 ppr (idArity binder),
1684 ptext (sLit "arguments,"),
1685 ppr binder],
1686 hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty]
1687
1688 ]
1689 where (StrictSig dmd_ty) = idStrictness binder
1690 -}
1691 mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc
1692 mkCastErr expr co from_ty expr_ty
1693 = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"),
1694 ptext (sLit "From-type:") <+> ppr from_ty,
1695 ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty,
1696 ptext (sLit "Actual enclosed expr:") <+> ppr expr,
1697 ptext (sLit "Coercion used in cast:") <+> ppr co
1698 ]
1699
1700 dupVars :: [[Var]] -> MsgDoc
1701 dupVars vars
1702 = hang (ptext (sLit "Duplicate variables brought into scope"))
1703 2 (ppr vars)
1704
1705 dupExtVars :: [[Name]] -> MsgDoc
1706 dupExtVars vars
1707 = hang (ptext (sLit "Duplicate top-level variables with the same qualified name"))
1708 2 (ppr vars)
1709
1710 {-
1711 ************************************************************************
1712 * *
1713 \subsection{Annotation Linting}
1714 * *
1715 ************************************************************************
1716 -}
1717
1718 -- | This checks whether a pass correctly looks through debug
1719 -- annotations (@SourceNote@). This works a bit different from other
1720 -- consistency checks: We check this by running the given task twice,
1721 -- noting all differences between the results.
1722 lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
1723 lintAnnots pname pass guts = do
1724 -- Run the pass as we normally would
1725 dflags <- getDynFlags
1726 when (gopt Opt_DoAnnotationLinting dflags) $
1727 liftIO $ Err.showPass dflags "Annotation linting - first run"
1728 nguts <- pass guts
1729 -- If appropriate re-run it without debug annotations to make sure
1730 -- that they made no difference.
1731 when (gopt Opt_DoAnnotationLinting dflags) $ do
1732 liftIO $ Err.showPass dflags "Annotation linting - second run"
1733 nguts' <- withoutAnnots pass guts
1734 -- Finally compare the resulting bindings
1735 liftIO $ Err.showPass dflags "Annotation linting - comparison"
1736 let binds = flattenBinds $ mg_binds nguts
1737 binds' = flattenBinds $ mg_binds nguts'
1738 (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds'
1739 when (not (null diffs)) $ CoreMonad.putMsg $ vcat
1740 [ lint_banner "warning" pname
1741 , text "Core changes with annotations:"
1742 , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs
1743 ]
1744 -- Return actual new guts
1745 return nguts
1746
1747 -- | Run the given pass without annotations. This means that we both
1748 -- remove the @Opt_Debug@ flag from the environment as well as all
1749 -- annotations from incoming modules.
1750 withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
1751 withoutAnnots pass guts = do
1752 -- Remove debug flag from environment.
1753 dflags <- getDynFlags
1754 let removeFlag env = env{hsc_dflags = gopt_unset dflags Opt_Debug}
1755 withoutFlag corem =
1756 liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>
1757 getUniqueSupplyM <*> getModule <*>
1758 getPrintUnqualified <*> pure corem
1759 -- Nuke existing ticks in module.
1760 -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes
1761 -- them in absence of @Opt_Debug@?
1762 let nukeTicks = stripTicksE (not . tickishIsCode)
1763 nukeAnnotsBind :: CoreBind -> CoreBind
1764 nukeAnnotsBind bind = case bind of
1765 Rec bs -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs
1766 NonRec b e -> NonRec b $ nukeTicks e
1767 nukeAnnotsMod mg@ModGuts{mg_binds=binds}
1768 = mg{mg_binds = map nukeAnnotsBind binds}
1769 -- Perform pass with all changes applied
1770 fmap fst $ withoutFlag $ pass (nukeAnnotsMod guts)