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