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