CoreLint.hs 96.5 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

A ``lint'' pass to check for Core correctness
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

9
{-# LANGUAGE CPP #-}
Ian Lynagh's avatar
Ian Lynagh committed
10

11 12
module CoreLint (
    lintCoreBindings, lintUnfolding,
13
    lintPassResult, lintInteractiveExpr, lintExpr,
Peter Wortmann's avatar
Peter Wortmann committed
14
    lintAnnots,
15 16

    -- ** Debug output
17
    endPass, endPassIO,
18
    dumpPassResult,
19 20
    CoreLint.dumpIfSet,
 ) where
21

22
#include "HsVersions.h"
23 24

import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
25 26
import CoreFVs
import CoreUtils
27
import CoreStats   ( coreBindsStats )
28
import CoreMonad
29
import Bag
Simon Marlow's avatar
Simon Marlow committed
30 31 32
import Literal
import DataCon
import TysWiredIn
33
import TysPrim
Ben Gamari's avatar
Ben Gamari committed
34
import TcType ( isFloatingTy )
Simon Marlow's avatar
Simon Marlow committed
35 36
import Var
import VarEnv
37
import VarSet
Simon Marlow's avatar
Simon Marlow committed
38
import Name
39
import Id
lukemaurer's avatar
lukemaurer committed
40
import IdInfo
41
import PprCore
Simon Marlow's avatar
Simon Marlow committed
42
import ErrUtils
batterseapower's avatar
batterseapower committed
43
import Coercion
Simon Marlow's avatar
Simon Marlow committed
44
import SrcLoc
45
import Kind
Simon Marlow's avatar
Simon Marlow committed
46
import Type
47
import RepType
48
import TyCoRep       -- checks validity of types/coercions
Simon Marlow's avatar
Simon Marlow committed
49
import TyCon
50
import CoAxiom
Simon Marlow's avatar
Simon Marlow committed
51
import BasicTypes
52
import ErrUtils as Err
53
import ListSetOps
54
import PrelNames
55
import Outputable
56
import FastString
57
import Util
58
import InstEnv     ( instanceDFunId )
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
59
import OptCoercion ( checkAxInstCo )
Peter Wortmann's avatar
Peter Wortmann committed
60
import UniqSupply
61 62
import CoreArity ( typeArity )
import Demand ( splitStrictSig, isBotRes )
63 64 65

import HscTypes
import DynFlags
66
import Control.Monad
quchen's avatar
quchen committed
67 68 69
#if __GLASGOW_HASKELL__ > 710
import qualified Control.Monad.Fail as MonadFail
#endif
70
import MonadUtils
Simon Marlow's avatar
Simon Marlow committed
71
import Data.Maybe
72
import Pair
73
import qualified GHC.LanguageExtensions as LangExt
74

Austin Seipp's avatar
Austin Seipp committed
75
{-
76 77 78 79 80 81
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.
82
To this purpose, there is a document core-spec.pdf built in docs/core-spec that
83 84 85 86 87
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.

88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
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.

106 107
Summary of checks
~~~~~~~~~~~~~~~~~
108 109 110 111 112 113
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
114 115 116 117
        (a) type errors
        (b) Out-of-scope type variables
        (c) Out-of-scope local variables
        (d) Ill-kinded types
118
        (e) Incorrect unsafe coercions
119 120

If we have done specialisation the we check that there are
121
        (a) No top-level bindings of primitive (unboxed type)
122 123 124 125 126

Outstanding issues:

    -- Things are *not* OK if:
    --
127
    --  * Unsaturated type app before specialisation has been done;
128
    --
129
    --  * Oversaturated type app after specialisation (eta reduction
130
    --   may well be happening...);
131

132

Ben Gamari's avatar
Ben Gamari committed
133 134 135 136 137 138
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.

139 140
Note [Linting type lets]
~~~~~~~~~~~~~~~~~~~~~~~~
141
In the desugarer, it's very very convenient to be able to say (in effect)
142
        let a = Type Int in <body>
143 144 145
That is, use a type let.   See Note [Type let] in CoreSyn.

However, when linting <body> we need to remember that a=Int, else we might
146
reject a correct program.  So we carry a type substitution (in this example
147
[a -> Int]) and apply this substitution before comparing types.  The functin
148 149
        lintInTy :: Type -> LintM (Type, Kind)
returns a substituted type.
150 151 152 153

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

154
For Ids, the type-substituted Id is added to the in_scope set (which
155
itself is part of the TCvSubst we are carrying down), and when we
Gabor Greif's avatar
Gabor Greif committed
156
find an occurrence of an Id, we fetch it from the in-scope set.
157

158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
Note [Bad unsafe coercion]
~~~~~~~~~~~~~~~~~~~~~~~~~~
For discussion see https://ghc.haskell.org/trac/ghc/wiki/BadUnsafeCoercions
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
176 177 178 179
Note [Join points]
~~~~~~~~~~~~~~~~~~
We check the rules listed in Note [Invariants on join points] in CoreSyn. The
only one that causes any difficulty is the first: All occurrences must be tail
180 181
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
182 183 184 185 186 187 188 189

  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

190 191 192 193 194
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
195

196 197 198 199 200 201 202 203 204
************************************************************************
*                                                                      *
                 Beginning and ending passes
*                                                                      *
************************************************************************

These functions are not CoreM monad stuff, but they probably ought to
be, and it makes a conveneint place.  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
205
-}
206

207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239
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
240 241 242 243 244 245 246 247
  = do { forM_ mb_flag $ \flag ->
           Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc

         -- 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
       }
248 249 250 251 252 253 254

  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
255
                     , pprCoreBindingsWithSize binds
256 257
                     , ppUnless (null rules) pp_rules ]
    pp_rules = vcat [ blankLine
258
                    , text "------ Local rules for imported ids --------"
259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278
                    , 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
coreDumpFlag CoreDoStrictness         = Just Opt_D_dump_stranal
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
coreDumpFlag CoreDoVectorisation      = Just Opt_D_dump_vect
coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds
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
279
coreDumpFlag CoreOccurAnal            = Just Opt_D_dump_occur_anal
280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298

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
299
  = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds
300 301 302 303 304 305 306 307 308 309
       ; 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
310
  = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan
Sylvain Henry's avatar
Sylvain Henry committed
311
           (defaultDumpStyle dflags)
312
           (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
313
                 , text "*** Offending Program ***"
314
                 , pprCoreBindings binds
315
                 , text "*** End of Offense ***" ])
316 317 318
       ; Err.ghcExit dflags 1 }

  | not (isEmptyBag warns)
Sylvain Henry's avatar
Sylvain Henry committed
319
  , not (hasNoDebugOutput dflags)
320
  , showLintWarnings pass
321 322
  -- If the Core linter encounters an error, output to stderr instead of
  -- stdout (#13342)
Ben Gamari's avatar
Ben Gamari committed
323
  = putLogMsg dflags NoReason Err.SevInfo noSrcSpan
Sylvain Henry's avatar
Sylvain Henry committed
324
        (defaultDumpStyle dflags)
325
        (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))
326 327 328 329 330

  | otherwise = return ()
  where

lint_banner :: String -> SDoc -> SDoc
331 332 333
lint_banner string pass = text "*** Core Lint"      <+> text string
                          <+> text ": in result of" <+> pass
                          <+> text "***"
334 335 336 337 338 339 340 341 342 343 344

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 ()
345
  | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr
346 347 348 349 350 351 352 353
  = 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
354
      = do { putLogMsg dflags NoReason Err.SevDump
Sylvain Henry's avatar
Sylvain Henry committed
355
               noSrcSpan (defaultDumpStyle dflags)
356 357
               (vcat [ lint_banner "errors" (text what)
                     , err
358
                     , text "*** Offending Program ***"
359
                     , pprCoreExpr expr
360
                     , text "*** End of Offense ***" ])
361 362 363 364 365 366 367 368 369 370 371 372 373 374 375
           ; 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.
-- These are Local things (see Note [Interactively-bound Ids in GHCi] in HscTypes).
-- 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.
--
-- See Trac #8215 for an example
interactiveInScope hsc_env
niteria's avatar
niteria committed
376
  = tyvars ++ ids
377 378 379 380 381 382 383
  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
384
    tyvars = tyCoVarsOfTypesList $ map idType ids
385 386 387 388 389
              -- 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)

390
lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
391
--   Returns (warnings, errors)
392 393
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
394
lintCoreBindings dflags pass local_in_scope binds
395 396
  = initL dflags flags in_scope_set $
    addLoc TopLevelBindings         $
397
    lintLetBndrs TopLevel binders   $
398 399 400
        -- Put all the top-level binders in scope at the start
        -- This is because transformation rules can bring something
        -- into use 'unexpectedly'
401 402 403 404
    do { checkL (null dups) (dupVars dups)
       ; checkL (null ext_dups) (dupExtVars ext_dups)
       ; mapM lint_bind binds }
  where
405 406
    in_scope_set = mkInScopeSet (mkVarSet local_in_scope)

407
    flags = LF { lf_check_global_ids = check_globals
408 409
               , lf_check_inline_loop_breakers = check_lbs
               , lf_check_static_ptrs = check_static_ptrs }
410 411 412 413 414 415 416

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

417 418 419 420 421 422
    -- See Note [Checking for INLINE loop breakers]
    check_lbs = case pass of
                      CoreDesugar    -> False
                      CoreDesugarOpt -> False
                      _              -> True

423
    -- See Note [Checking StaticPtrs]
424 425 426 427 428 429
    check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere
                      | otherwise = case pass of
                          CoreDoFloatOutwards _ -> AllowAtTopLevel
                          CoreTidy              -> RejectEverywhere
                          CorePrep              -> AllowAtTopLevel
                          _                     -> AllowAnywhere
430

431 432 433 434 435 436 437 438
    binders = bindersOfBinds binds
    (_, 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
439
    -- because they both get the same linker symbol
440 441 442 443 444
    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
445

446 447
    -- If you edit this function, you may need to update the GHC formalism
    -- See Note [GHC Formalism]
448
    lint_bind (Rec prs)         = mapM_ (lintSingleBinding TopLevel Recursive) prs
449
    lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
450

Austin Seipp's avatar
Austin Seipp committed
451 452 453
{-
************************************************************************
*                                                                      *
454
\subsection[lintUnfolding]{lintUnfolding}
Austin Seipp's avatar
Austin Seipp committed
455 456
*                                                                      *
************************************************************************
457

458 459
We use this to check all unfoldings that come in from interfaces
(it is very painful to catch errors otherwise):
Austin Seipp's avatar
Austin Seipp committed
460
-}
461

462 463
lintUnfolding :: DynFlags
              -> SrcLoc
niteria's avatar
niteria committed
464
              -> VarSet         -- Treat these as in scope
465 466
              -> CoreExpr
              -> Maybe MsgDoc   -- Nothing => OK
467

468
lintUnfolding dflags locn vars expr
469
  | isEmptyBag errs = Nothing
470
  | otherwise       = Just (pprMessageBag errs)
471
  where
472 473
    in_scope = mkInScopeSet vars
    (_warns, errs) = initL dflags defaultLintFlags in_scope linter
474 475
    linter = addLoc (ImportedUnfolding locn) $
             lintCoreExpr expr
476

477 478
lintExpr :: DynFlags
         -> [Var]               -- Treat these as in scope
479 480
         -> CoreExpr
         -> Maybe MsgDoc        -- Nothing => OK
481

482
lintExpr dflags vars expr
483 484 485
  | isEmptyBag errs = Nothing
  | otherwise       = Just (pprMessageBag errs)
  where
486 487
    in_scope = mkInScopeSet (mkVarSet vars)
    (_warns, errs) = initL dflags defaultLintFlags in_scope linter
488 489
    linter = addLoc TopLevelBindings $
             lintCoreExpr expr
490

Austin Seipp's avatar
Austin Seipp committed
491 492 493
{-
************************************************************************
*                                                                      *
494
\subsection[lintCoreBinding]{lintCoreBinding}
Austin Seipp's avatar
Austin Seipp committed
495 496
*                                                                      *
************************************************************************
497

498
Check a core binding, returning the list of variables bound.
Austin Seipp's avatar
Austin Seipp committed
499
-}
500

twanvl's avatar
twanvl committed
501
lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
502 503
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
504
lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
505
  = addLoc (RhsOf binder) $
506
         -- Check the rhs
lukemaurer's avatar
lukemaurer committed
507
    do { ty <- lintRhs binder rhs
Simon Peyton Jones's avatar
Simon Peyton Jones committed
508
       ; binder_ty <- applySubstTy (idType binder)
509
       ; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty)
510

511 512 513 514 515 516 517
       -- Check that it's not levity-polymorphic
       -- Do this first, because otherwise isUnliftedType panics
       -- Annoyingly, this duplicates the test in lintIdBdr,
       -- because for non-rec lets we call lintSingleBinding first
       ; checkL (isJoinId binder || not (isTypeLevPoly binder_ty))
                (badBndrTyMsg binder (text "levity-polymorphic"))

518 519
        -- Check the let/app invariant
        -- See Note [CoreSyn let/app invariant] in CoreSyn
520 521 522 523 524
       ; checkL ( isJoinId binder
               || not (isUnliftedType binder_ty)
               || (isNonRec rec_flag && exprOkForSpeculation rhs)
               || exprIsLiteralString rhs)
           (badBndrTyMsg binder (text "unlifted"))
525

526 527 528
        -- Check that if the binder is top-level or recursive, it's not
        -- demanded. Primitive string literals are exempt as there is no
        -- computation to perform, see Note [CoreSyn top-level string literals].
529
       ; checkL (not (isStrictId binder)
530 531
            || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))
            || exprIsLiteralString rhs)
532
           (mkStrictMsg binder)
533

534 535 536 537 538 539 540
        -- Check that if the binder is at the top level and has type Addr#,
        -- that it is a string literal, see
        -- Note [CoreSyn top-level string literals].
       ; checkL (not (isTopLevel top_lvl_flag && binder_ty `eqType` addrPrimTy)
                 || exprIsLiteralString rhs)
           (mkTopNonLitStrMsg binder)

541
       ; flags <- getLintFlags
lukemaurer's avatar
lukemaurer committed
542

543 544 545 546 547 548
         -- 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
549

550 551 552
       ; when (lf_check_inline_loop_breakers flags
               && isStrongLoopBreaker (idOccInfo binder)
               && isInlinePragma (idInlinePragma binder))
553
              (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder))
554
              -- Only non-rule loop breakers inhibit inlining
555

556 557
      -- Check whether arity and demand type are consistent (only if demand analysis
      -- already happened)
558 559 560 561 562 563 564
      --
      -- Note (Apr 2014): this is actually ok.  See Note [Demand analysis for trivial right-hand sides]
      --                  in DmdAnal.  After eta-expansion in CorePrep the rhs is no longer trivial.
      --       ; let dmdTy = idStrictness binder
      --       ; checkL (case dmdTy of
      --                  StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs)
      --           (mkArityMsg binder)
565

566 567 568 569
       -- 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]
       ; checkL (idArity binder <= length (typeArity (idType binder)))
570 571
           (text "idArity" <+> ppr (idArity binder) <+>
           text "exceeds typeArity" <+>
572 573 574 575 576 577
           ppr (length (typeArity (idType binder))) <> colon <+>
           ppr binder)

       ; case splitStrictSig (idStrictness binder) of
           (demands, result_info) | isBotRes result_info ->
             checkL (idArity binder <= length demands)
578 579
               (text "idArity" <+> ppr (idArity binder) <+>
               text "exceeds arity imposed by the strictness signature" <+>
580 581 582 583
               ppr (idStrictness binder) <> colon <+>
               ppr binder)
           _ -> return ()

lukemaurer's avatar
lukemaurer committed
584
       ; mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
585 586 587

       ; addLoc (UnfoldingOf binder) $
         lintIdUnfolding binder binder_ty (idUnfolding binder) }
588 589 590

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

lukemaurer's avatar
lukemaurer committed
592
-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr'
593
-- in that it doesn't reject occurrences of the function 'makeStatic' when they
lukemaurer's avatar
lukemaurer committed
594 595 596
-- 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.
597 598
--
-- See Note [Checking StaticPtrs].
lukemaurer's avatar
lukemaurer committed
599 600 601 602 603 604 605 606 607
lintRhs :: Id -> CoreExpr -> LintM OutType
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
608

lukemaurer's avatar
lukemaurer committed
609 610
    lint_join_lams n tot enforce (Lam var expr)
      = addLoc (LambdaBodyOf var) $
611
        lintBinder LambdaBind var $ \ var' ->
lukemaurer's avatar
lukemaurer committed
612 613
        do { body_ty <- lint_join_lams (n-1) tot enforce expr
           ; return $ mkLamType var' body_ty }
614

lukemaurer's avatar
lukemaurer committed
615
    lint_join_lams n tot True _other
Simon Peyton Jones's avatar
Simon Peyton Jones committed
616
      = failWithL $ mkBadJoinArityMsg bndr tot (tot-n) rhs
lukemaurer's avatar
lukemaurer committed
617 618 619 620 621 622 623 624
    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
625 626 627 628 629 630
  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
631 632
      = markAllJoinsBad $
        foldr
633
        -- imitate @lintCoreExpr (Lam ...)@
634 635
        (\var loopBinders ->
          addLoc (LambdaBodyOf var) $
636
            lintBinder LambdaBind var $ \var' ->
637 638 639
              do { body_ty <- loopBinders
                 ; return $ mkLamType var' body_ty }
        )
640
        -- imitate @lintCoreExpr (App ...)@
641 642 643 644
        (do fun_ty <- lintCoreExpr fun
            addLoc (AnExpr rhs') $ lintCoreArgs fun_ty [Type t, info, e]
        )
        binders0
lukemaurer's avatar
lukemaurer committed
645
    go _ = markAllJoinsBad $ lintCoreExpr rhs
646

647 648 649
lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
  | isStableSource src
lukemaurer's avatar
lukemaurer committed
650
  = do { ty <- lintRhs bndr rhs
651
       ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
652 653 654

lintIdUnfolding bndr bndr_ty (DFunUnfolding { df_con = con, df_bndrs = bndrs
                                            , df_args = args })
655
  = do { ty <- lintBinders LambdaBind bndrs $ \ bndrs' ->
Simon Peyton Jones's avatar
Simon Peyton Jones committed
656 657 658 659
               do { res_ty <- lintCoreArgs (dataConRepType con) args
                  ; return (mkLamTypes bndrs' res_ty) }
       ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "dfun unfolding") ty) }

660
lintIdUnfolding  _ _ _
Gabor Greif's avatar
Gabor Greif committed
661
  = return ()       -- Do not Lint unstable unfoldings, because that leads
Simon Peyton Jones's avatar
Simon Peyton Jones committed
662
                    -- to exponential behaviour; c.f. CoreFVs.idUnfoldingVars
663

Austin Seipp's avatar
Austin Seipp committed
664
{-
665 666 667 668 669
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
670
that form a mutually recursive group.  Only after a round of
671 672 673
simplification are they unravelled.  So we suppress the test for
the desugarer.

Austin Seipp's avatar
Austin Seipp committed
674 675
************************************************************************
*                                                                      *
676
\subsection[lintCoreExpr]{lintCoreExpr}
Austin Seipp's avatar
Austin Seipp committed
677 678 679
*                                                                      *
************************************************************************
-}
680

681 682
-- For OutType, OutKind, the substitution has been applied,
--                       but has not been linted yet
683 684

type LintedType  = Type -- Substitution applied, and type is linted
685
type LintedKind  = Kind
686

687
lintCoreExpr :: CoreExpr -> LintM OutType
688
-- The returned type has the substitution from the monad
689
-- already applied to it:
690
--      lintCoreExpr e subst = exprType (subst e)
691 692
--
-- The returned "type" can be a kind, if the expression is (Type ty)
693

694 695
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
696
lintCoreExpr (Var var)
697
  = lintVarOcc var 0
698

699 700
lintCoreExpr (Lit lit)
  = return (literalType lit)
701

702
lintCoreExpr (Cast expr co)
lukemaurer's avatar
lukemaurer committed
703
  = do { expr_ty <- markAllJoinsBad $ lintCoreExpr expr
704
       ; co' <- applySubstCo co
705 706
       ; (_, k2, from_ty, to_ty, r) <- lintCoercion co'
       ; lintL (classifiesTypeWithValues k2)
707
               (text "Target of cast not # or *:" <+> ppr co)
708 709
       ; lintRole co' Representational r
       ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)
710
       ; return to_ty }
711

lukemaurer's avatar
lukemaurer committed
712 713 714 715 716 717 718 719 720 721 722 723 724 725
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).
726

727
lintCoreExpr (Let (NonRec tv (Type ty)) body)
728
  | isTyVar tv
729 730 731
  =     -- See Note [Linting type lets]
    do  { ty' <- applySubstTy ty
        ; lintTyBndr tv              $ \ tv' ->
732
    do  { addLoc (RhsOf tv) $ lintTyKind tv' ty'
733 734
                -- Now extend the substitution so we
                -- take advantage of it in the body
lukemaurer's avatar
lukemaurer committed
735
        ; extendSubstL tv ty'        $
736
          addLoc (BodyOfLetRec [tv]) $
737
          lintCoreExpr body } }
738

739
lintCoreExpr (Let (NonRec bndr rhs) body)
740
  | isId bndr
741 742
  = do  { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
        ; addLoc (BodyOfLetRec [bndr])
743
                 (lintIdBndr NotTopLevel LetBind bndr $ \_ ->
744 745
                  addGoodJoins [bndr] $
                  lintCoreExpr body) }
746

747
  | otherwise
748
  = failWithL (mkLetErr bndr rhs)       -- Not quite accurate
749

750 751
lintCoreExpr e@(Let (Rec pairs) body)
  = lintLetBndrs NotTopLevel bndrs $
752
    addGoodJoins bndrs             $
753 754 755 756 757 758 759
    do  { -- Check that the list of pairs is non-empty
          checkL (not (null pairs)) (emptyRec e)

          -- Check that there are no duplicated binders
        ; checkL (null dups) (dupVars dups)

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

763 764
        ; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
        ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
765 766
  where
    bndrs = map fst pairs
767
    (_, dups) = removeDups compare bndrs
768

batterseapower's avatar
batterseapower committed
769
lintCoreExpr e@(App _ _)
lukemaurer's avatar
lukemaurer committed
770 771 772
  = addLoc (AnExpr e) $
    do { fun_ty <- lintCoreFun fun (length args)
       ; lintCoreArgs fun_ty args }
batterseapower's avatar
batterseapower committed
773 774
  where
    (fun, args) = collectArgs e
775 776

lintCoreExpr (Lam var expr)
777
  = addLoc (LambdaBodyOf var) $
lukemaurer's avatar
lukemaurer committed
778
    markAllJoinsBad $
779
    lintBinder LambdaBind var $ \ var' ->
780
    do { body_ty <- lintCoreExpr expr
Simon Peyton Jones's avatar
Simon Peyton Jones committed
781
       ; return $ mkLamType var' body_ty }
782 783 784

lintCoreExpr e@(Case scrut var alt_ty alts) =
       -- Check the scrutinee
785
  do { let scrut_diverges = exprIsBottom scrut
lukemaurer's avatar
lukemaurer committed
786
     ; scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut
787 788
     ; (alt_ty, _) <- lintInTy alt_ty
     ; (var_ty, _) <- lintInTy (idType var)
789

790
     -- See Note [No alternatives lint check]
791 792
     ; when (null alts) $
     do { checkL (not (exprIsHNF scrut))
793
          (text "No alternatives for a case scrutinee in head-normal form:" <+> ppr scrut)
794
        ; checkWarnL scrut_diverges
795
          (text "No alternatives for a case scrutinee not known to diverge for sure:" <+> ppr scrut)
796
        }
797

Ben Gamari's avatar
Ben Gamari committed
798 799 800 801 802 803 804 805 806
     -- See Note [Rules for floating-point comparisons] in PrelRules
     ; let isLitPat (LitAlt _, _ , _) = True
           isLitPat _                 = False
     ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts)
         (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++
                        "expression with literal pattern in case " ++
                        "analysis (see Trac #9238).")
          $$ text "scrut" <+> ppr scrut)

807
     ; case tyConAppTyCon_maybe (idType var) of
808
         Just tycon
809 810 811 812 813 814
              | debugIsOn
              , isAlgTyCon tycon
              , not (isAbstractTyCon tycon)
              , null (tyConDataCons tycon)
              , not scrut_diverges
              -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
815
                        -- This can legitimately happen for type families
816 817 818
                      $ return ()
         _otherwise -> return ()

819
        -- Don't use lintIdBndr on var, because unboxed tuple is legitimate
820

821 822
     ; subst <- getTCvSubst
     ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
823

824
     ; lintIdBndr NotTopLevel CaseBind var $ \_ ->
825
       do { -- Check the alternatives
826
            mapM_ (lintCoreAlt scrut_ty alt_ty) alts
827
          ; checkCaseAlts e scrut_ty alts
828
          ; return alt_ty } }
829

830 831
-- This case can't happen; linting types in expressions gets routed through
-- lintCoreArgs
832
lintCoreExpr (Type ty)
833
  = failWithL (text "Type found as expression" <+> ppr ty)
834 835

lintCoreExpr (Coercion co)
836 837
  = do { (k1, k2, ty1, ty2, role) <- lintInCo co
       ; return (mkHeteroCoercionType role k1 k2 ty1 ty2) }
838

839 840
----------------------
lintVarOcc :: Var -> Int -- Number of arguments (type or value) being passed
lukemaurer's avatar
lukemaurer committed
841
            -> LintM Type -- returns type of the *variable*
842
lintVarOcc var nargs
lukemaurer's avatar
lukemaurer committed
843 844 845
  = do  { checkL (isNonCoVarId var)
                 (text "Non term variable" <+> ppr var)

846 847 848 849 850 851 852
        -- Cneck that the type of the occurrence is the same
        -- as the type of the binding site
        ; ty   <- applySubstTy (idType var)
        ; var' <- lookupIdInScope var
        ; let ty' = idType var'
        ; ensureEqTys ty ty' $ mkBndrOccTypeMismatchMsg var' var ty' ty

lukemaurer's avatar
lukemaurer committed
853 854
          -- Check for a nested occurrence of the StaticPtr constructor.
          -- See Note [Checking StaticPtrs].
855
        ; lf <- getLintFlags
lukemaurer's avatar
lukemaurer committed
856 857 858 859 860
        ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $
            checkL (idName var /= makeStaticName) $
              text "Found makeStatic nested in an expression"

        ; checkDeadIdOcc var
861 862
        ; checkJoinOcc var nargs

lukemaurer's avatar
lukemaurer committed
863 864
        ; return (idType var') }

865 866 867
lintCoreFun :: CoreExpr
            -> Int        -- Number of arguments (type or val) being passed
            -> LintM Type -- Returns type of the *function*
lukemaurer's avatar
lukemaurer committed
868
lintCoreFun (Var var) nargs
869 870
  = lintVarOcc var nargs

lukemaurer's avatar
lukemaurer committed
871 872 873 874 875
lintCoreFun (Lam var body) nargs
  -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; see
  -- Note [Beta redexes]
  | nargs /= 0
  = addLoc (LambdaBodyOf var) $
876
    lintBinder LambdaBind var $ \ var' ->