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