Lint.hs 112 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4

Simon Marlow's avatar
Simon Marlow committed
5

6 7
A ``lint'' pass to check for Core correctness.
See Note [Core Lint guarantee].
Austin Seipp's avatar
Austin Seipp committed
8
-}
9

10
{-# LANGUAGE CPP #-}
11
{-# LANGUAGE ScopedTypeVariables, DeriveFunctor #-}
Ian Lynagh's avatar
Ian Lynagh committed
12

Sylvain Henry's avatar
Sylvain Henry committed
13
module GHC.Core.Lint (
14
    lintCoreBindings, lintUnfolding,
15
    lintPassResult, lintInteractiveExpr, lintExpr,
Ryan Scott's avatar
Ryan Scott committed
16
    lintAnnots, lintTypes,
17 18

    -- ** Debug output
19
    endPass, endPassIO,
20
    dumpPassResult,
Sylvain Henry's avatar
Sylvain Henry committed
21
    GHC.Core.Lint.dumpIfSet,
22
 ) where
23

24
#include "HsVersions.h"
25

26 27
import GhcPrelude

Sylvain Henry's avatar
Sylvain Henry committed
28 29 30 31
import GHC.Core
import GHC.Core.FVs
import GHC.Core.Utils
import GHC.Core.Stats ( coreBindsStats )
32
import GHC.Core.Op.Monad
33
import Bag
Simon Marlow's avatar
Simon Marlow committed
34
import Literal
Sylvain Henry's avatar
Sylvain Henry committed
35
import GHC.Core.DataCon
36
import TysPrim
Ben Gamari's avatar
Ben Gamari committed
37
import TcType ( isFloatingTy )
Simon Marlow's avatar
Simon Marlow committed
38 39
import Var
import VarEnv
40
import VarSet
Simon Peyton Jones's avatar
Simon Peyton Jones committed
41
import UniqSet( nonDetEltsUniqSet )
Simon Marlow's avatar
Simon Marlow committed
42
import Name
43
import Id
lukemaurer's avatar
lukemaurer committed
44
import IdInfo
Sylvain Henry's avatar
Sylvain Henry committed
45
import GHC.Core.Ppr
Simon Marlow's avatar
Simon Marlow committed
46
import ErrUtils
Sylvain Henry's avatar
Sylvain Henry committed
47
import GHC.Core.Coercion
Simon Marlow's avatar
Simon Marlow committed
48
import SrcLoc
Sylvain Henry's avatar
Sylvain Henry committed
49
import GHC.Core.Type as Type
Sylvain Henry's avatar
Sylvain Henry committed
50
import GHC.Types.RepType
Sylvain Henry's avatar
Sylvain Henry committed
51 52 53 54 55 56
import GHC.Core.TyCo.Rep   -- checks validity of types/coercions
import GHC.Core.TyCo.Subst
import GHC.Core.TyCo.FVs
import GHC.Core.TyCo.Ppr ( pprTyVar )
import GHC.Core.TyCon as TyCon
import GHC.Core.Coercion.Axiom
Simon Marlow's avatar
Simon Marlow committed
57
import BasicTypes
58
import ErrUtils as Err
59
import ListSetOps
60
import PrelNames
61
import Outputable
62
import FastString
63
import Util
Sylvain Henry's avatar
Sylvain Henry committed
64 65 66
import GHC.Core.InstEnv      ( instanceDFunId )
import GHC.Core.Coercion.Opt ( checkAxInstCo )
import GHC.Core.Arity        ( typeArity )
67
import Demand ( splitStrictSig, isBotDiv )
68

Sylvain Henry's avatar
Sylvain Henry committed
69 70
import GHC.Driver.Types
import GHC.Driver.Session
71
import Control.Monad
quchen's avatar
quchen committed
72
import qualified Control.Monad.Fail as MonadFail
73
import MonadUtils
74 75
import Data.Foldable      ( toList )
import Data.List.NonEmpty ( NonEmpty )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
76
import Data.List          ( partition )
Simon Marlow's avatar
Simon Marlow committed
77
import Data.Maybe
78
import Pair
79
import qualified GHC.LanguageExtensions as LangExt
80

Austin Seipp's avatar
Austin Seipp committed
81
{-
82 83 84 85 86 87
Note [Core Lint guarantee]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Core Lint is the type-checker for Core. Using it, we get the following guarantee:

If all of:
1. Core Lint passes,
88
2. there are no unsafe coercions (i.e. unsafeEqualityProof),
89 90 91 92 93 94 95
3. all plugin-supplied coercions (i.e. PluginProv) are valid, and
4. all case-matches are complete
then running the compiled program will not seg-fault, assuming no bugs downstream
(e.g. in the code generator). This guarantee is quite powerful, in that it allows us
to decouple the safety of the resulting program from the type inference algorithm.

However, do note point (4) above. Core Lint does not check for incomplete case-matches;
Sylvain Henry's avatar
Sylvain Henry committed
96
see Note [Case expression invariants] in GHC.Core, invariant (4). As explained there,
97 98
an incomplete case-match might slip by Core Lint and cause trouble at runtime.

99 100 101 102 103 104
Note [GHC Formalism]
~~~~~~~~~~~~~~~~~~~~
This file implements the type-checking algorithm for System FC, the "official"
name of the Core language. Type safety of FC is heart of the claim that
executables produced by GHC do not have segmentation faults. Thus, it is
useful to be able to reason about System FC independently of reading the code.
105
To this purpose, there is a document core-spec.pdf built in docs/core-spec that
106 107 108 109 110
contains a formalism of the types and functions dealt with here. If you change
just about anything in this file or you change other types/functions throughout
the Core language (all signposted to this note), you should update that
formalism. See docs/core-spec/README for more info about how to do so.

111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128
Note [check vs lint]
~~~~~~~~~~~~~~~~~~~~
This file implements both a type checking algorithm and also general sanity
checking. For example, the "sanity checking" checks for TyConApp on the left
of an AppTy, which should never happen. These sanity checks don't really
affect any notion of type soundness. Yet, it is convenient to do the sanity
checks at the same time as the type checks. So, we use the following naming
convention:

- Functions that begin with 'lint'... are involved in type checking. These
  functions might also do some sanity checking.

- Functions that begin with 'check'... are *not* involved in type checking.
  They exist only for sanity checking.

Issues surrounding variable naming, shadowing, and such are considered *not*
to be part of type checking, as the formalism omits these details.

129 130
Summary of checks
~~~~~~~~~~~~~~~~~
131 132 133 134 135 136
Checks that a set of core bindings is well-formed.  The PprStyle and String
just control what we print in the event of an error.  The Bool value
indicates whether we have done any specialisation yet (in which case we do
some extra checks).

We check for
137 138 139 140
        (a) type errors
        (b) Out-of-scope type variables
        (c) Out-of-scope local variables
        (d) Ill-kinded types
141
        (e) Incorrect unsafe coercions
142 143

If we have done specialisation the we check that there are
144
        (a) No top-level bindings of primitive (unboxed type)
145 146 147 148 149

Outstanding issues:

    -- Things are *not* OK if:
    --
150
    --  * Unsaturated type app before specialisation has been done;
151
    --
152
    --  * Oversaturated type app after specialisation (eta reduction
153
    --   may well be happening...);
154

155

Ben Gamari's avatar
Ben Gamari committed
156 157 158 159 160 161
Note [Linting function types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As described in Note [Representation of function types], all saturated
applications of funTyCon are represented with the FunTy constructor. We check
this invariant in lintType.

162 163
Note [Linting type lets]
~~~~~~~~~~~~~~~~~~~~~~~~
164
In the desugarer, it's very very convenient to be able to say (in effect)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
165 166 167 168
        let a = Type Bool in
        let x::a = True in <body>
That is, use a type let.   See Note [Type let] in CoreSyn.
One place it is used is in mkWwArgs; see Note [Join points and beta-redexes]
169
in GHC.Core.Op.WorkWrap.Lib.  (Maybe there are other "clients" of this feature; I'm not sure).
170

Simon Peyton Jones's avatar
Simon Peyton Jones committed
171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186
* Hence when linting <body> we need to remember that a=Int, else we
  might reject a correct program.  So we carry a type substitution (in
  this example [a -> Bool]) and apply this substitution before
  comparing types. In effect, in Lint, type equality is always
  equality-moduolo-le-subst.  This is in the le_subst field of
  LintEnv.  But nota bene:

  (SI1) The le_subst substitution is applied to types and coercions only

  (SI2) The result of that substitution is used only to check for type
        equality, to check well-typed-ness, /but is then discarded/.
        The result of substittion does not outlive the CoreLint pass.

  (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders.

* The function
187
        lintInTy :: Type -> LintM (Type, Kind)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
188 189 190 191 192 193 194 195 196 197 198
  returns a substituted type.

* When we encounter a binder (like x::a) we must apply the substitution
  to the type of the binding variable.  lintBinders does this.

* Clearly we need to clone tyvar binders as we go.

* But take care (#17590)! We must also clone CoVar binders:
    let a = TYPE (ty |> cv)
    in \cv -> blah
  blindly substituting for `a` might capture `cv`.
199

Simon Peyton Jones's avatar
Simon Peyton Jones committed
200 201 202 203 204 205
* Alas, when cloning a coercion variable we might choose a unique
  that happens to clash with an inner Id, thus
      \cv_66 -> let wild_X7 = blah in blah
  We decide to clone `cv_66` becuase it's already in scope.  Fine,
  choose a new unique.  Aha, X7 looks good.  So we check the lambda
  body with le_subst of [cv_66 :-> cv_X7]
206

Simon Peyton Jones's avatar
Simon Peyton Jones committed
207 208 209 210 211 212 213 214 215 216 217 218
  This is all fine, even though we use the same unique as wild_X7.
  As (SI2) says, we do /not/ return a new lambda
     (\cv_X7 -> let wild_X7 = blah in ...)
  We simply use the le_subst subsitution in types/coercions only, when
  checking for equality.

* We still need to check that Id occurrences are bound by some
  enclosing binding.  We do /not/ use the InScopeSet for the le_subst
  for this purpose -- it contains only TyCoVars.  Instead we have a separate
  le_ids for the in-scope Id binders.

Sigh.  We might want to explore getting rid of type-let!
219

220 221
Note [Bad unsafe coercion]
~~~~~~~~~~~~~~~~~~~~~~~~~~
222
For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions
223 224 225 226 227 228 229 230 231 232 233 234 235 236 237
Linter introduces additional rules that checks improper coercion between
different types, called bad coercions. Following coercions are forbidden:

  (a) coercions between boxed and unboxed values;
  (b) coercions between unlifted values of the different sizes, here
      active size is checked, i.e. size of the actual value but not
      the space allocated for value;
  (c) coercions between floating and integral boxed values, this check
      is not yet supported for unboxed tuples, as no semantics were
      specified for that;
  (d) coercions from / to vector type
  (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be
      coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules
      (a-e) holds.

lukemaurer's avatar
lukemaurer committed
238 239
Note [Join points]
~~~~~~~~~~~~~~~~~~
Sylvain Henry's avatar
Sylvain Henry committed
240
We check the rules listed in Note [Invariants on join points] in GHC.Core. The
lukemaurer's avatar
lukemaurer committed
241
only one that causes any difficulty is the first: All occurrences must be tail
242 243
calls. To this end, along with the in-scope set, we remember in le_joins the
subset of in-scope Ids that are valid join ids. For example:
lukemaurer's avatar
lukemaurer committed
244 245 246 247 248 249 250 251

  join j x = ... in
  case e of
    A -> jump j y -- good
    B -> case (jump j z) of -- BAD
           C -> join h = jump j w in ... -- good
           D -> let x = jump j v in ... -- BAD

252 253 254 255 256
A join point remains valid in case branches, so when checking the A
branch, j is still valid. When we check the scrutinee of the inner
case, however, we set le_joins to empty, and catch the
error. Similarly, join points can occur free in RHSes of other join
points but not the RHSes of value bindings (thunks and functions).
lukemaurer's avatar
lukemaurer committed
257

258 259 260 261 262 263 264
************************************************************************
*                                                                      *
                 Beginning and ending passes
*                                                                      *
************************************************************************

These functions are not CoreM monad stuff, but they probably ought to
265 266
be, and it makes a convenient place for them.  They print out stuff
before and after core passes, and do Core Lint when necessary.
Austin Seipp's avatar
Austin Seipp committed
267
-}
268

269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301
endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
endPass pass binds rules
  = do { hsc_env <- getHscEnv
       ; print_unqual <- getPrintUnqualified
       ; liftIO $ endPassIO hsc_env print_unqual pass binds rules }

endPassIO :: HscEnv -> PrintUnqualified
          -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
-- Used by the IO-is CorePrep too
endPassIO hsc_env print_unqual pass binds rules
  = do { dumpPassResult dflags print_unqual mb_flag
                        (ppr pass) (pprPassDetails pass) binds rules
       ; lintPassResult hsc_env pass binds }
  where
    dflags  = hsc_dflags hsc_env
    mb_flag = case coreDumpFlag pass of
                Just flag | dopt flag dflags                    -> Just flag
                          | dopt Opt_D_verbose_core2core dflags -> Just flag
                _ -> Nothing

dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
dumpIfSet dflags dump_me pass extra_info doc
  = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc

dumpPassResult :: DynFlags
               -> PrintUnqualified
               -> Maybe DumpFlag        -- Just df => show details in a file whose
                                        --            name is specified by df
               -> SDoc                  -- Header
               -> SDoc                  -- Extra info to appear after header
               -> CoreProgram -> [CoreRule]
               -> IO ()
dumpPassResult dflags unqual mb_flag hdr extra_info binds rules
Sylvain Henry's avatar
Sylvain Henry committed
302 303 304 305
  = do { forM_ mb_flag $ \flag -> do
           let sty = mkDumpStyle dflags unqual
           dumpAction dflags sty (dumpOptionsFromFlag flag)
              (showSDoc dflags hdr) FormatCore dump_doc
306 307 308 309 310 311

         -- Report result size
         -- This has the side effect of forcing the intermediate to be evaluated
         -- if it's not already forced by a -ddump flag.
       ; Err.debugTraceMsg dflags 2 size_doc
       }
312 313 314 315 316 317 318

  where
    size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]

    dump_doc  = vcat [ nest 2 extra_info
                     , size_doc
                     , blankLine
319
                     , pprCoreBindingsWithSize binds
320 321
                     , ppUnless (null rules) pp_rules ]
    pp_rules = vcat [ blankLine
322
                    , text "------ Local rules for imported ids --------"
323 324 325 326 327 328 329 330 331 332
                    , pprRules rules ]

coreDumpFlag :: CoreToDo -> Maybe DumpFlag
coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_verbose_core2core
coreDumpFlag (CoreDoPluginPass {})    = Just Opt_D_verbose_core2core
coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core
coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
coreDumpFlag CoreDoStaticArgs         = Just Opt_D_verbose_core2core
coreDumpFlag CoreDoCallArity          = Just Opt_D_dump_call_arity
333
coreDumpFlag CoreDoExitify            = Just Opt_D_dump_exitify
334 335
coreDumpFlag CoreDoDemand             = Just Opt_D_dump_stranal
coreDumpFlag CoreDoCpr                = Just Opt_D_dump_cpranal
336 337 338 339
coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse
Simon Peyton Jones's avatar
Simon Peyton Jones committed
340
coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds_preopt
341 342 343
coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds
coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
lukemaurer's avatar
lukemaurer committed
344
coreDumpFlag CoreOccurAnal            = Just Opt_D_dump_occur_anal
345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363

coreDumpFlag CoreDoPrintCore          = Nothing
coreDumpFlag (CoreDoRuleCheck {})     = Nothing
coreDumpFlag CoreDoNothing            = Nothing
coreDumpFlag (CoreDoPasses {})        = Nothing

{-
************************************************************************
*                                                                      *
                 Top-level interfaces
*                                                                      *
************************************************************************
-}

lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()
lintPassResult hsc_env pass binds
  | not (gopt Opt_DoCoreLinting dflags)
  = return ()
  | otherwise
364
  = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds
365 366 367 368 369 370 371 372 373 374
       ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)
       ; displayLintResults dflags pass warns errs binds  }
  where
    dflags = hsc_dflags hsc_env

displayLintResults :: DynFlags -> CoreToDo
                   -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram
                   -> IO ()
displayLintResults dflags pass warns errs binds
  | not (isEmptyBag errs)
Ben Gamari's avatar
Ben Gamari committed
375
  = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan
Sylvain Henry's avatar
Sylvain Henry committed
376
           (defaultDumpStyle dflags)
377
           (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
378
                 , text "*** Offending Program ***"
379
                 , pprCoreBindings binds
380
                 , text "*** End of Offense ***" ])
381 382 383
       ; Err.ghcExit dflags 1 }

  | not (isEmptyBag warns)
Sylvain Henry's avatar
Sylvain Henry committed
384
  , not (hasNoDebugOutput dflags)
385
  , showLintWarnings pass
386 387
  -- If the Core linter encounters an error, output to stderr instead of
  -- stdout (#13342)
Ben Gamari's avatar
Ben Gamari committed
388
  = putLogMsg dflags NoReason Err.SevInfo noSrcSpan
Sylvain Henry's avatar
Sylvain Henry committed
389
        (defaultDumpStyle dflags)
390
        (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))
391 392 393 394 395

  | otherwise = return ()
  where

lint_banner :: String -> SDoc -> SDoc
396 397 398
lint_banner string pass = text "*** Core Lint"      <+> text string
                          <+> text ": in result of" <+> pass
                          <+> text "***"
399 400 401 402 403 404 405 406 407 408 409

showLintWarnings :: CoreToDo -> Bool
-- Disable Lint warnings on the first simplifier pass, because
-- there may be some INLINE knots still tied, which is tiresomely noisy
showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
showLintWarnings _ = True

lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr what hsc_env expr
  | not (gopt Opt_DoCoreLinting dflags)
  = return ()
410
  | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr
411 412 413 414 415 416 417 418
  = do { display_lint_err err
       ; Err.ghcExit dflags 1 }
  | otherwise
  = return ()
  where
    dflags = hsc_dflags hsc_env

    display_lint_err err
Ben Gamari's avatar
Ben Gamari committed
419
      = do { putLogMsg dflags NoReason Err.SevDump
Sylvain Henry's avatar
Sylvain Henry committed
420
               noSrcSpan (defaultDumpStyle dflags)
421 422
               (vcat [ lint_banner "errors" (text what)
                     , err
423
                     , text "*** Offending Program ***"
424
                     , pprCoreExpr expr
425
                     , text "*** End of Offense ***" ])
426 427 428 429 430
           ; Err.ghcExit dflags 1 }

interactiveInScope :: HscEnv -> [Var]
-- In GHCi we may lint expressions, or bindings arising from 'deriving'
-- clauses, that mention variables bound in the interactive context.
Sylvain Henry's avatar
Sylvain Henry committed
431
-- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types).
432 433 434 435 436 437 438
-- So we have to tell Lint about them, lest it reports them as out of scope.
--
-- We do this by find local-named things that may appear free in interactive
-- context.  This function is pretty revolting and quite possibly not quite right.
-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty
-- so this is a (cheap) no-op.
--
439
-- See #8215 for an example
440
interactiveInScope hsc_env
niteria's avatar
niteria committed
441
  = tyvars ++ ids
442 443 444 445 446 447 448
  where
    -- C.f. TcRnDriver.setInteractiveContext, Desugar.deSugarExpr
    ictxt                   = hsc_IC hsc_env
    (cls_insts, _fam_insts) = ic_instances ictxt
    te1    = mkTypeEnvWithImplicits (ic_tythings ictxt)
    te     = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts)
    ids    = typeEnvIds te
niteria's avatar
niteria committed
449
    tyvars = tyCoVarsOfTypesList $ map idType ids
450 451 452 453 454
              -- Why the type variables?  How can the top level envt have free tyvars?
              -- I think it's because of the GHCi debugger, which can bind variables
              --   f :: [t] -> [t]
              -- where t is a RuntimeUnk (see TcType)

455
-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].
456
lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
457
--   Returns (warnings, errors)
458 459
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
460
lintCoreBindings dflags pass local_in_scope binds
Simon Peyton Jones's avatar
Simon Peyton Jones committed
461 462
  = initL dflags flags local_in_scope $
    addLoc TopLevelBindings           $
463 464
    do { checkL (null dups) (dupVars dups)
       ; checkL (null ext_dups) (dupExtVars ext_dups)
465 466
       ; lintRecBindings TopLevel all_pairs $
         return () }
467
  where
468 469 470 471 472 473
    all_pairs = flattenBinds binds
     -- Put all the top-level binders in scope at the start
     -- This is because transformation rules can bring something
     -- into use 'unexpectedly'; see Note [Glomming] in OccurAnal
    binders = map fst all_pairs

Ryan Scott's avatar
Ryan Scott committed
474 475
    flags = defaultLintFlags
               { lf_check_global_ids = check_globals
476 477
               , lf_check_inline_loop_breakers = check_lbs
               , lf_check_static_ptrs = check_static_ptrs }
478 479 480 481 482 483 484

    -- See Note [Checking for global Ids]
    check_globals = case pass of
                      CoreTidy -> False
                      CorePrep -> False
                      _        -> True

485 486 487 488 489 490
    -- See Note [Checking for INLINE loop breakers]
    check_lbs = case pass of
                      CoreDesugar    -> False
                      CoreDesugarOpt -> False
                      _              -> True

491
    -- See Note [Checking StaticPtrs]
492 493 494 495 496 497
    check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere
                      | otherwise = case pass of
                          CoreDoFloatOutwards _ -> AllowAtTopLevel
                          CoreTidy              -> RejectEverywhere
                          CorePrep              -> AllowAtTopLevel
                          _                     -> AllowAnywhere
498

499 500 501 502 503 504 505
    (_, dups) = removeDups compare binders

    -- dups_ext checks for names with different uniques
    -- but but the same External name M.n.  We don't
    -- allow this at top level:
    --    M.n{r3}  = ...
    --    M.n{r29} = ...
Gabor Greif's avatar
typos  
Gabor Greif committed
506
    -- because they both get the same linker symbol
507 508 509 510 511
    ext_dups = snd (removeDups ord_ext (map Var.varName binders))
    ord_ext n1 n2 | Just m1 <- nameModule_maybe n1
                  , Just m2 <- nameModule_maybe n2
                  = compare (m1, nameOccName n1) (m2, nameOccName n2)
                  | otherwise = LT
512

Austin Seipp's avatar
Austin Seipp committed
513 514 515
{-
************************************************************************
*                                                                      *
516
\subsection[lintUnfolding]{lintUnfolding}
Austin Seipp's avatar
Austin Seipp committed
517 518
*                                                                      *
************************************************************************
519

520 521 522 523 524 525 526 527
Note [Linting Unfoldings from Interfaces]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

We use this to check all top-level unfoldings that come in from interfaces
(it is very painful to catch errors otherwise).

We do not need to call lintUnfolding on unfoldings that are nested within
top-level unfoldings; they are linted when we lint the top-level unfolding;
528
hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore.
529

Austin Seipp's avatar
Austin Seipp committed
530
-}
531

532 533
lintUnfolding :: Bool           -- True <=> is a compulsory unfolding
              -> DynFlags
534
              -> SrcLoc
niteria's avatar
niteria committed
535
              -> VarSet         -- Treat these as in scope
536 537
              -> CoreExpr
              -> Maybe MsgDoc   -- Nothing => OK
538

Simon Peyton Jones's avatar
Simon Peyton Jones committed
539
lintUnfolding is_compulsory dflags locn var_set expr
540
  | isEmptyBag errs = Nothing
541
  | otherwise       = Just (pprMessageBag errs)
542
  where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
543 544
    vars = nonDetEltsUniqSet var_set
    (_warns, errs) = initL dflags defaultLintFlags vars $
545 546 547 548
                     if is_compulsory
                       -- See Note [Checking for levity polymorphism]
                     then noLPChecks linter
                     else linter
549 550
    linter = addLoc (ImportedUnfolding locn) $
             lintCoreExpr expr
551

552 553
lintExpr :: DynFlags
         -> [Var]               -- Treat these as in scope
554 555
         -> CoreExpr
         -> Maybe MsgDoc        -- Nothing => OK
556

557
lintExpr dflags vars expr
558 559 560
  | isEmptyBag errs = Nothing
  | otherwise       = Just (pprMessageBag errs)
  where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
561
    (_warns, errs) = initL dflags defaultLintFlags vars linter
562 563
    linter = addLoc TopLevelBindings $
             lintCoreExpr expr
564

Austin Seipp's avatar
Austin Seipp committed
565 566 567
{-
************************************************************************
*                                                                      *
568
\subsection[lintCoreBinding]{lintCoreBinding}
Austin Seipp's avatar
Austin Seipp committed
569 570
*                                                                      *
************************************************************************
571

572
Check a core binding, returning the list of variables bound.
Austin Seipp's avatar
Austin Seipp committed
573
-}
574

575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594
lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)]
                -> LintM a -> LintM a
lintRecBindings top_lvl pairs thing_inside
  = lintIdBndrs top_lvl bndrs $ \ bndrs' ->
    do { zipWithM_ lint_pair bndrs' rhss
       ; thing_inside }
  where
    (bndrs, rhss) = unzip pairs
    lint_pair bndr' rhs
      = addLoc (RhsOf bndr') $
        do { rhs_ty <- lintRhs bndr' rhs         -- Check the rhs
           ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty }

lintLetBind :: TopLevelFlag -> RecFlag -> LintedId
              -> CoreExpr -> LintedType -> LintM ()
-- Binder's type, and the RHS, have already been linted
-- This function checks other invariants
lintLetBind top_lvl rec_flag binder rhs rhs_ty
  = do { let binder_ty = idType binder
       ; ensureEqTys binder_ty rhs_ty (mkRhsMsg binder (text "RHS") rhs_ty)
595

596
       -- If the binding is for a CoVar, the RHS should be (Coercion co)
Sylvain Henry's avatar
Sylvain Henry committed
597
       -- See Note [Core type and coercion invariant] in GHC.Core
598 599 600
       ; checkL (not (isCoVar binder) || isCoArg rhs)
                (mkLetErr binder rhs)

601
        -- Check the let/app invariant
Sylvain Henry's avatar
Sylvain Henry committed
602
        -- See Note [Core let/app invariant] in GHC.Core
603 604 605
       ; checkL ( isJoinId binder
               || not (isUnliftedType binder_ty)
               || (isNonRec rec_flag && exprOkForSpeculation rhs)
606
               || exprIsTickedString rhs)
607
           (badBndrTyMsg binder (text "unlifted"))
608

609 610
        -- Check that if the binder is top-level or recursive, it's not
        -- demanded. Primitive string literals are exempt as there is no
Sylvain Henry's avatar
Sylvain Henry committed
611
        -- computation to perform, see Note [Core top-level string literals].
612
       ; checkL (not (isStrictId binder)
613
            || (isNonRec rec_flag && not (isTopLevel top_lvl))
614
            || exprIsTickedString rhs)
615
           (mkStrictMsg binder)
616

617 618
        -- Check that if the binder is at the top level and has type Addr#,
        -- that it is a string literal, see
Sylvain Henry's avatar
Sylvain Henry committed
619
        -- Note [Core top-level string literals].
620
       ; checkL (not (isTopLevel top_lvl && binder_ty `eqType` addrPrimTy)
621
                 || exprIsTickedString rhs)
622 623
           (mkTopNonLitStrMsg binder)

624
       ; flags <- getLintFlags
lukemaurer's avatar
lukemaurer committed
625

626 627 628 629 630 631
         -- Check that a join-point binder has a valid type
         -- NB: lintIdBinder has checked that it is not top-level bound
       ; case isJoinId_maybe binder of
            Nothing    -> return ()
            Just arity ->  checkL (isValidJoinPointType arity binder_ty)
                                  (mkInvalidJoinPointMsg binder binder_ty)
lukemaurer's avatar
lukemaurer committed
632

633
       ; when (lf_check_inline_loop_breakers flags
634
               && isStableUnfolding (realIdUnfolding binder)
635 636
               && isStrongLoopBreaker (idOccInfo binder)
               && isInlinePragma (idInlinePragma binder))
637
              (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder))
638
              -- Only non-rule loop breakers inhibit inlining
639

640 641
       -- We used to check that the dmdTypeDepth of a demand signature never
       -- exceeds idArity, but that is an unnecessary complication, see
642
       -- Note [idArity varies independently of dmdTypeDepth] in GHC.Core.Op.DmdAnal
643

644 645 646
       -- Check that the binder's arity is within the bounds imposed by
       -- the type and the strictness signature. See Note [exprArity invariant]
       -- and Note [Trimming arity]
647
       ; checkL (typeArity (idType binder) `lengthAtLeast` idArity binder)
648 649
           (text "idArity" <+> ppr (idArity binder) <+>
           text "exceeds typeArity" <+>
650 651 652 653
           ppr (length (typeArity (idType binder))) <> colon <+>
           ppr binder)

       ; case splitStrictSig (idStrictness binder) of
654
           (demands, result_info) | isBotDiv result_info ->
655
             checkL (demands `lengthAtLeast` idArity binder)
656 657
               (text "idArity" <+> ppr (idArity binder) <+>
               text "exceeds arity imposed by the strictness signature" <+>
658 659 660 661
               ppr (idStrictness binder) <> colon <+>
               ppr binder)
           _ -> return ()

lukemaurer's avatar
lukemaurer committed
662
       ; mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
663 664 665

       ; addLoc (UnfoldingOf binder) $
         lintIdUnfolding binder binder_ty (idUnfolding binder) }
666 667 668

        -- We should check the unfolding, if any, but this is tricky because
        -- the unfolding is a SimplifiableCoreExpr. Give up for now.
669

lukemaurer's avatar
lukemaurer committed
670
-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr'
671
-- in that it doesn't reject occurrences of the function 'makeStatic' when they
lukemaurer's avatar
lukemaurer committed
672 673 674
-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and
-- for join points, it skips the outer lambdas that take arguments to the
-- join point.
675 676
--
-- See Note [Checking StaticPtrs].
677 678 679
lintRhs :: Id -> CoreExpr -> LintM LintedType
-- NB: the Id can be Linted or not -- it's only used for
--     its OccInfo and join-pointer-hood
lukemaurer's avatar
lukemaurer committed
680 681 682 683 684 685 686 687
lintRhs bndr rhs
    | Just arity <- isJoinId_maybe bndr
    = lint_join_lams arity arity True rhs
    | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)
    = lint_join_lams arity arity False rhs
  where
    lint_join_lams 0 _ _ rhs
      = lintCoreExpr rhs
688

lukemaurer's avatar
lukemaurer committed
689
    lint_join_lams n tot enforce (Lam var expr)
690
      = lintLambda var $ lint_join_lams (n-1) tot enforce expr
691

lukemaurer's avatar
lukemaurer committed
692
    lint_join_lams n tot True _other
Simon Peyton Jones's avatar
Simon Peyton Jones committed
693
      = failWithL $ mkBadJoinArityMsg bndr tot (tot-n) rhs
lukemaurer's avatar
lukemaurer committed
694 695 696 697 698 699 700 701
    lint_join_lams _ _ False rhs
      = markAllJoinsBad $ lintCoreExpr rhs
          -- Future join point, not yet eta-expanded
          -- Body is not a tail position

-- Allow applications of the data constructor @StaticPtr@ at the top
-- but produce errors otherwise.
lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go
702 703 704 705 706 707
  where
    -- Allow occurrences of 'makeStatic' at the top-level but produce errors
    -- otherwise.
    go AllowAtTopLevel
      | (binders0, rhs') <- collectTyBinders rhs
      , Just (fun, t, info, e) <- collectMakeStaticArgs rhs'
lukemaurer's avatar
lukemaurer committed
708 709
      = markAllJoinsBad $
        foldr
710
        -- imitate @lintCoreExpr (Lam ...)@
711
        lintLambda
712
        -- imitate @lintCoreExpr (App ...)@
713
        (do fun_ty <- lintCoreExpr fun
Simon Peyton Jones's avatar
Simon Peyton Jones committed
714
            lintCoreArgs fun_ty [Type t, info, e]
715 716
        )
        binders0
lukemaurer's avatar
lukemaurer committed
717
    go _ = markAllJoinsBad $ lintCoreExpr rhs
718

719
lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
Matthew Pickering's avatar
Matthew Pickering committed
720 721 722
lintIdUnfolding bndr bndr_ty uf
  | isStableUnfolding uf
  , Just rhs <- maybeUnfoldingTemplate uf
723 724 725 726
  = do { ty <- if isCompulsoryUnfolding uf
               then noLPChecks $ lintRhs bndr rhs
                     -- See Note [Checking for levity polymorphism]
               else lintRhs bndr rhs
727
       ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) }
728
lintIdUnfolding  _ _ _
Gabor Greif's avatar
Gabor Greif committed
729
  = return ()       -- Do not Lint unstable unfoldings, because that leads
Sylvain Henry's avatar
Sylvain Henry committed
730
                    -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars
731

Austin Seipp's avatar
Austin Seipp committed
732
{-
733 734 735 736 737
Note [Checking for INLINE loop breakers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's very suspicious if a strong loop breaker is marked INLINE.

However, the desugarer generates instance methods with INLINE pragmas
Gabor Greif's avatar
Gabor Greif committed
738
that form a mutually recursive group.  Only after a round of
739 740 741
simplification are they unravelled.  So we suppress the test for
the desugarer.

742 743 744
Note [Checking for levity polymorphism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We ordinarily want to check for bad levity polymorphism. See
Sylvain Henry's avatar
Sylvain Henry committed
745
Note [Levity polymorphism invariants] in GHC.Core. However, we do *not*
746 747 748 749 750 751 752 753 754 755 756 757 758
want to do this in a compulsory unfolding. Compulsory unfoldings arise
only internally, for things like newtype wrappers, dictionaries, and
(notably) unsafeCoerce#. These might legitimately be levity-polymorphic;
indeed levity-polyorphic unfoldings are a primary reason for the
very existence of compulsory unfoldings (we can't compile code for
the original, levity-poly, binding).

It is vitally important that we do levity-polymorphism checks *after*
performing the unfolding, but not beforehand. This is all safe because
we will check any unfolding after it has been unfolded; checking the
unfolding beforehand is merely an optimization, and one that actively
hurts us here.

Austin Seipp's avatar
Austin Seipp committed
759 760
************************************************************************
*                                                                      *
761
\subsection[lintCoreExpr]{lintCoreExpr}
Austin Seipp's avatar
Austin Seipp committed
762 763 764
*                                                                      *
************************************************************************
-}
765

766 767 768 769 770 771
-- Linted things: substitution applied, and type is linted
type LintedType     = Type
type LintedKind     = Kind
type LintedCoercion = Coercion
type LintedTyCoVar  = TyCoVar
type LintedId       = Id
772

773
lintCoreExpr :: CoreExpr -> LintM LintedType
774
-- The returned type has the substitution from the monad
775
-- already applied to it:
776
--      lintCoreExpr e subst = exprType (subst e)
777 778
--
-- The returned "type" can be a kind, if the expression is (Type ty)
779

780 781
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
782

783
lintCoreExpr (Var var)
784
  = lintIdOcc var 0
785

786 787
lintCoreExpr (Lit lit)
  = return (literalType lit)
788

789
lintCoreExpr (Cast expr co)
lukemaurer's avatar
lukemaurer committed
790
  = do { expr_ty <- markAllJoinsBad $ lintCoreExpr expr
791 792 793 794 795
       ; co' <- lintCoercion co
       ; let (Pair from_ty to_ty, role) = coercionKindRole co'
       ; checkValueType to_ty $
         text "target of cast" <+> quotes (ppr co')
       ; lintRole co' Representational role
796
       ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)
797
       ; return to_ty }
798

lukemaurer's avatar
lukemaurer committed
799 800 801 802 803 804 805 806 807 808 809 810 811 812
lintCoreExpr (Tick tickish expr)
  = do case tickish of
         Breakpoint _ ids -> forM_ ids $ \id -> do
                               checkDeadIdOcc id
                               lookupIdInScope id
         _                -> return ()
       markAllJoinsBadIf block_joins $ lintCoreExpr expr
  where
    block_joins = not (tickish `tickishScopesLike` SoftScope)
      -- TODO Consider whether this is the correct rule. It is consistent with
      -- the simplifier's behaviour - cost-centre-scoped ticks become part of
      -- the continuation, and thus they behave like part of an evaluation
      -- context, but soft-scoped and non-scoped ticks simply wrap the result
      -- (see Simplify.simplTick).
813

814
lintCoreExpr (Let (NonRec tv (Type ty)) body)
815
  | isTyVar tv
816
  =     -- See Note [Linting type lets]
817
    do  { ty' <- lintType ty
818
        ; lintTyBndr tv              $ \ tv' ->
819
    do  { addLoc (RhsOf tv) $ lintTyKind tv' ty'
820 821
                -- Now extend the substitution so we
                -- take advantage of it in the body
Simon Peyton Jones's avatar
Simon Peyton Jones committed
822
        ; extendTvSubstL tv ty'        $
823
          addLoc (BodyOfLetRec [tv]) $
824
          lintCoreExpr body } }
825

826
lintCoreExpr (Let (NonRec bndr rhs) body)
827
  | isId bndr
828 829 830 831 832 833 834
  = do { -- First Lint the RHS, before bringing the binder into scope
         rhs_ty <- lintRhs bndr rhs

         -- Now lint the binder
       ; lintBinder LetBind bndr $ \bndr' ->
    do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty
       ; addLoc (BodyOfLetRec [bndr]) (lintCoreExpr body) } }
835

836
  | otherwise
837
  = failWithL (mkLetErr bndr rhs)       -- Not quite accurate
838

839
lintCoreExpr e@(Let (Rec pairs) body)
840
  = do  { -- Check that the list of pairs is non-empty
841 842 843
          checkL (not (null pairs)) (emptyRec e)

          -- Check that there are no duplicated binders
844
        ; let (_, dups) = removeDups compare bndrs
845 846 847
        ; checkL (null dups) (dupVars dups)

          -- Check that either all the binders are joins, or none
lukemaurer's avatar
lukemaurer committed
848
        ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $
849
          mkInconsistentRecMsg bndrs
850

851 852 853
        ; lintRecBindings NotTopLevel pairs $
          addLoc (BodyOfLetRec bndrs)       $
          lintCoreExpr body }
854 855
  where
    bndrs = map fst pairs
856

batterseapower's avatar
batterseapower committed
857
lintCoreExpr e@(App _ _)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
858
  = do { fun_ty <- lintCoreFun fun (length args)
lukemaurer's avatar
lukemaurer committed
859
       ; lintCoreArgs fun_ty args }
batterseapower's avatar
batterseapower committed
860 861
  where
    (fun, args) = collectArgs e
862 863

lintCoreExpr (Lam var expr)
864 865
  = markAllJoinsBad $
    lintLambda var $ lintCoreExpr expr
866

867 868
lintCoreExpr (Case scrut var alt_ty alts)
  = lintCaseExpr scrut var alt_ty alts
869

870 871
-- This case can't happen; linting types in expressions gets routed through
-- lintCoreArgs
872
lintCoreExpr (Type ty)
873
  = failWithL (text "Type found as expression" <+> ppr ty)
874 875

lintCoreExpr (Coercion co)
876 877 878
  = do { co' <- addLoc (InCo co) $
                lintCoercion co
       ; return (coercionType co') }
879

880
----------------------
881 882 883 884 885
lintIdOcc :: Var -> Int -- Number of arguments (type or value) being passed
           -> LintM LintedType -- returns type of the *variable*
lintIdOcc var nargs
  = addLoc (OccOf var) $
    do  { checkL (isNonCoVarId var)
lukemaurer's avatar
lukemaurer committed
886
                 (text "Non term variable" <+> ppr var)
Sylvain Henry's avatar
Sylvain Henry committed
887
                 -- See GHC.Core Note [Variable occurrences in Core]
lukemaurer's avatar
lukemaurer committed
888

889
        -- Check that the type of the occurrence is the same
890 891 892 893 894 895 896 897 898 899 900 901 902 903 904
        -- as the type of the binding site.  The inScopeIds are
        -- /un-substituted/, so this checks that the occurrence type
        -- is identical to the binder type.
        -- This makes things much easier for things like:
        --    /\a. \(x::Maybe a). /\a. ...(x::Maybe a)...
        -- The "::Maybe a" on the occurrence is referring to the /outer/ a.
        -- If we compared /substituted/ types we'd risk comparing
        -- (Maybe a) from the binding site with bogus (Maybe a1) from
        -- the occurrence site.  Comparing un-substituted types finesses
        -- this altogether
        ; (bndr, linted_bndr_ty) <- lookupIdInScope var
        ; let occ_ty  = idType var
              bndr_ty = idType bndr
        ; ensureEqTys occ_ty bndr_ty $
          mkBndrOccTypeMismatchMsg bndr var bndr_ty occ_ty
905

lukemaurer's avatar
lukemaurer committed
906 907
          -- Check for a nested occurrence of the StaticPtr constructor.
          -- See Note [Checking StaticPtrs].
908
        ; lf <- getLintFlags
lukemaurer's avatar
lukemaurer committed
909 910 911 912 913
        ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $
            checkL (idName var /= makeStaticName) $
              text "Found makeStatic nested in an expression"

        ; checkDeadIdOcc var
914 915
        ; checkJoinOcc var nargs

916
        ; return linted_bndr_ty }
lukemaurer's avatar
lukemaurer committed
917

918
lintCoreFun :: CoreExpr
919 920
            -> Int              -- Number of arguments (type or val) being passed
            -> LintM LintedType -- Returns type of the *function*
lukemaurer's avatar
lukemaurer committed
921
lintCoreFun (Var var) nargs
922
  = lintIdOcc var nargs
923

lukemaurer's avatar
lukemaurer committed
924 925 926 927
lintCoreFun (Lam var body) nargs
  -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; see
  -- Note [Beta redexes]
  | nargs /= 0
928
  = lintLambda var $ lintCoreFun body (nargs - 1)
929

lukemaurer's avatar
lukemaurer committed
930 931
lintCoreFun expr nargs
  = markAllJoinsBadIf (nargs /= 0) $
932
      -- See Note [Join points are less general than the paper]
lukemaurer's avatar
lukemaurer committed
933
    lintCoreExpr expr
934 935 936 937 938 939 940
------------------
lintLambda :: Var -> LintM Type -> LintM Type
lintLambda var lintBody =
    addLoc (LambdaBodyOf var) $
    lintBinder LambdaBind var $ \ var' ->
      do { body_ty <- lintBody
         ; return (mkLamType var' body_ty) }
941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961
------------------
checkDeadIdOcc :: Id -> LintM ()
-- Occurrences of an Id should never be dead....
-- except when we are checking a case pattern
checkDeadIdOcc id
  | isDeadOcc (idOccInfo id)
  = do { in_case <- inCasePat
       ; checkL in_case
                (text "Occurrence of a dead Id" <+> ppr id) }
  | otherwise
  = return ()

------------------
checkJoinOcc :: Id -> JoinArity -> LintM ()
-- Check that if the occurrence is a JoinId, then so is the
-- binding site, and it's a valid join Id
checkJoinOcc var n_args
  | Just join_arity_occ <- isJoinId_maybe var
  = do { mb_join_arity_bndr <- lookupJoinId var
       ; case mb_join_arity_bndr of {
           Nothing -> -- Binder is not a join point
962 963 964
                      do { join_set <- getValidJoins
                         ; addErrL (text "join set " <+> ppr join_set $$
                                    invalidJoinOcc var) } ;
965 966 967 968 969 970 971 972 973 974 975 976 977 978

           Just join_arity_bndr ->

    do { checkL (join_arity_bndr == join_arity_occ) $
           -- Arity differs at binding site and occurrence
         mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ

       ; checkL (n_args == join_arity_occ) $
           -- Arity doesn't match #args
         mkBadJumpMsg var join_arity_occ n_args } } }

  | otherwise
  = return ()

Austin Seipp's avatar
Austin Seipp committed
979
{-
980 981
Note [No alternatives lint check]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
982
Case expressions with no alternatives are odd beasts, and it would seem
983
like they would worth be looking at in the linter (cf #10180). We
984
used to check two things:
985

986 987
* exprIsHNF is false: it would *seem* to be terribly wrong if
  the scrutinee was already in head normal form.
988 989 990 991

* exprIsBottom is true: we should be able to see why GHC believes the
  scrutinee is diverging for sure.