compiler/coreSyn/CoreLint.lhs

   1
   2 %
   3 % (c) The University of Glasgow 2006
   4 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   5 %
   6
   7 A ``lint'' pass to check for Core correctness
   8
   9 \begin{code}
  10 module CoreLint (
  11         lintCoreBindings,
  12         lintUnfolding,
  13         showPass, endPass, endPassIf, endIteration
  14     ) where
  15
  16 #include "HsVersions.h"
  17
  18 import NewDemand
  19 import CoreSyn
  20 import CoreFVs
  21 import CoreUtils
  22 import Bag
  23 import Literal
  24 import DataCon
  25 import TysWiredIn
  26 import Var
  27 import VarEnv
  28 import VarSet
  29 import Name
  30 import Id
  31 import IdInfo
  32 import PprCore
  33 import ErrUtils
  34 import SrcLoc
  35 import Type
  36 import Coercion
  37 import TyCon
  38 import BasicTypes
  39 import StaticFlags
  40 import ListSetOps
  41 import DynFlags
  42 import Outputable
  43 import FastString
  44 import Util
  45 import Data.Maybe
  46 \end{code}
  47
  48 %************************************************************************
  49 %*                                                                      *
  50 \subsection{End pass}
  51 %*                                                                      *
  52 %************************************************************************
  53
  54 @showPass@ and @endPass@ don't really belong here, but it makes a convenient
  55 place for them.  They print out stuff before and after core passes,
  56 and do Core Lint when necessary.
  57
  58 \begin{code}
  59 endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
  60 endPass = dumpAndLint dumpIfSet_core
  61
  62 endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
  63 endPassIf cond = dumpAndLint (dumpIf_core cond)
  64
  65 endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
  66 endIteration = dumpAndLint dumpIfSet_dyn
  67
  68 dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
  69             -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO ()
  70 dumpAndLint dump dflags pass_name dump_flag binds
  71   = do
  72         -- Report result size if required
  73         -- This has the side effect of forcing the intermediate to be evaluated
  74         debugTraceMsg dflags 2 $
  75                 (text "    Result size =" <+> int (coreBindsSize binds))
  76
  77         -- Report verbosely, if required
  78         dump dflags dump_flag pass_name (pprCoreBindings binds)
  79
  80         -- Type check
  81         lintCoreBindings dflags pass_name binds
  82 \end{code}
  83
  84
  85 %************************************************************************
  86 %*                                                                      *
  87 \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface}
  88 %*                                                                      *
  89 %************************************************************************
  90
  91 Checks that a set of core bindings is well-formed.  The PprStyle and String
  92 just control what we print in the event of an error.  The Bool value
  93 indicates whether we have done any specialisation yet (in which case we do
  94 some extra checks).
  95
  96 We check for
  97         (a) type errors
  98         (b) Out-of-scope type variables
  99         (c) Out-of-scope local variables
 100         (d) Ill-kinded types
 101
 102 If we have done specialisation the we check that there are
 103         (a) No top-level bindings of primitive (unboxed type)
 104
 105 Outstanding issues:
 106
 107     --
 108     -- Things are *not* OK if:
 109     --
 110     --  * Unsaturated type app before specialisation has been done;
 111     --
 112     --  * Oversaturated type app after specialisation (eta reduction
 113     --   may well be happening...);
 114
 115
 116 Note [Linting type lets]
 117 ~~~~~~~~~~~~~~~~~~~~~~~~
 118 In the desugarer, it's very very convenient to be able to say (in effect)
 119         let a = Type Int in <body>
 120 That is, use a type let.   See Note [Type let] in CoreSyn.
 121
 122 However, when linting <body> we need to remember that a=Int, else we might
 123 reject a correct program.  So we carry a type substitution (in this example
 124 [a -> Int]) and apply this substitution before comparing types.  The functin
 125         lintTy :: Type -> LintM Type
 126 returns a substituted type; that's the only reason it returns anything.
 127
 128 When we encounter a binder (like x::a) we must apply the substitution
 129 to the type of the binding variable.  lintBinders does this.
 130
 131 For Ids, the type-substituted Id is added to the in_scope set (which
 132 itself is part of the TvSubst we are carrying down), and when we
 133 find an occurence of an Id, we fetch it from the in-scope set.
 134
 135
 136 \begin{code}
 137 lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
 138
 139 lintCoreBindings dflags _whoDunnit _binds
 140   | not (dopt Opt_DoCoreLinting dflags)
 141   = return ()
 142
 143 lintCoreBindings dflags whoDunnit binds
 144   = case (initL (lint_binds binds)) of
 145       Nothing       -> showPass dflags ("Core Linted result of " ++ whoDunnit)
 146       Just bad_news -> printDump (display bad_news)     >>
 147                        ghcExit dflags 1
 148   where
 149         -- Put all the top-level binders in scope at the start
 150         -- This is because transformation rules can bring something
 151         -- into use 'unexpectedly'
 152     lint_binds binds = addLoc TopLevelBindings $
 153                        addInScopeVars (bindersOfBinds binds) $
 154                        mapM lint_bind binds
 155
 156     lint_bind (Rec prs)         = mapM_ (lintSingleBinding TopLevel Recursive) prs
 157     lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
 158
 159     display bad_news
 160       = vcat [  text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
 161                 bad_news,
 162                 ptext (sLit "*** Offending Program ***"),
 163                 pprCoreBindings binds,
 164                 ptext (sLit "*** End of Offense ***")
 165         ]
 166 \end{code}
 167
 168 %************************************************************************
 169 %*                                                                      *
 170 \subsection[lintUnfolding]{lintUnfolding}
 171 %*                                                                      *
 172 %************************************************************************
 173
 174 We use this to check all unfoldings that come in from interfaces
 175 (it is very painful to catch errors otherwise):
 176
 177 \begin{code}
 178 lintUnfolding :: SrcLoc
 179               -> [Var]          -- Treat these as in scope
 180               -> CoreExpr
 181               -> Maybe Message  -- Nothing => OK
 182
 183 lintUnfolding locn vars expr
 184   = initL (addLoc (ImportedUnfolding locn) $
 185            addInScopeVars vars             $
 186            lintCoreExpr expr)
 187 \end{code}
 188
 189 %************************************************************************
 190 %*                                                                      *
 191 \subsection[lintCoreBinding]{lintCoreBinding}
 192 %*                                                                      *
 193 %************************************************************************
 194
 195 Check a core binding, returning the list of variables bound.
 196
 197 \begin{code}
 198 lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
 199 lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
 200   = addLoc (RhsOf binder) $
 201          -- Check the rhs
 202     do { ty <- lintCoreExpr rhs
 203        ; lintBinder binder -- Check match to RHS type
 204        ; binder_ty <- applySubst binder_ty
 205        ; checkTys binder_ty ty (mkRhsMsg binder ty)
 206         -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
 207        ; checkL (not (isUnLiftedType binder_ty)
 208             || (isNonRec rec_flag && exprOkForSpeculation rhs))
 209            (mkRhsPrimMsg binder rhs)
 210         -- Check that if the binder is top-level or recursive, it's not demanded
 211        ; checkL (not (isStrictId binder)
 212             || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)))
 213            (mkStrictMsg binder)
 214         -- Check whether binder's specialisations contain any out-of-scope variables
 215        ; mapM_ (checkBndrIdInScope binder) bndr_vars
 216
 217       -- Check whether arity and demand type are consistent (only if demand analysis
 218       -- already happened)
 219        ; checkL (case maybeDmdTy of
 220                   Just (StrictSig dmd_ty) -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs
 221                   Nothing -> True)
 222            (mkArityMsg binder) }
 223
 224         -- We should check the unfolding, if any, but this is tricky because
 225         -- the unfolding is a SimplifiableCoreExpr. Give up for now.
 226    where
 227     binder_ty                  = idType binder
 228     maybeDmdTy                 = idNewStrictness_maybe binder
 229     bndr_vars                  = varSetElems (idFreeVars binder `unionVarSet` wkr_vars)
 230     wkr_vars | workerExists wkr_info = unitVarSet (workerId wkr_info)
 231              | otherwise             = emptyVarSet
 232     wkr_info = idWorkerInfo binder
 233     lintBinder var | isId var  = lintIdBndr var $ \_ -> (return ())
 234                    | otherwise = return ()
 235 \end{code}
 236
 237 %************************************************************************
 238 %*                                                                      *
 239 \subsection[lintCoreExpr]{lintCoreExpr}
 240 %*                                                                      *
 241 %************************************************************************
 242
 243 \begin{code}
 244 type InType  = Type     -- Substitution not yet applied
 245 type OutType = Type     -- Substitution has been applied to this
 246
 247 lintCoreExpr :: CoreExpr -> LintM OutType
 248 -- The returned type has the substitution from the monad
 249 -- already applied to it:
 250 --      lintCoreExpr e subst = exprType (subst e)
 251 --
 252 -- The returned "type" can be a kind, if the expression is (Type ty)
 253
 254 lintCoreExpr (Var var)
 255   = do  { checkL (not (var == oneTupleDataConId))
 256                  (ptext (sLit "Illegal one-tuple"))
 257
 258         ; checkDeadIdOcc var
 259         ; var' <- lookupIdInScope var
 260         ; return (idType var')
 261         }
 262
 263 lintCoreExpr (Lit lit)
 264   = return (literalType lit)
 265
 266 --lintCoreExpr (Note (Coerce to_ty from_ty) expr)
 267 --  = do        { expr_ty <- lintCoreExpr expr
 268 --      ; to_ty <- lintTy to_ty
 269 --      ; from_ty <- lintTy from_ty
 270 --      ; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty)
 271 --      ; return to_ty }
 272
 273 lintCoreExpr (Cast expr co)
 274   = do { expr_ty <- lintCoreExpr expr
 275        ; co' <- lintTy co
 276        ; let (from_ty, to_ty) = coercionKind co'
 277        ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty)
 278        ; return to_ty }
 279
 280 lintCoreExpr (Note _ expr)
 281   = lintCoreExpr expr
 282
 283 lintCoreExpr (Let (NonRec tv (Type ty)) body)
 284   =     -- See Note [Type let] in CoreSyn
 285     do  { checkL (isTyVar tv) (mkKindErrMsg tv ty)      -- Not quite accurate
 286         ; ty' <- lintTy ty
 287         ; kind' <- lintTy (tyVarKind tv)
 288         ; let tv' = setTyVarKind tv kind'
 289         ; checkKinds tv' ty'
 290                 -- Now extend the substitution so we
 291                 -- take advantage of it in the body
 292         ; addLoc (BodyOfLetRec [tv]) $
 293           addInScopeVars [tv'] $
 294           extendSubstL tv' ty' $
 295           lintCoreExpr body }
 296
 297 lintCoreExpr (Let (NonRec bndr rhs) body)
 298   = do  { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
 299         ; addLoc (BodyOfLetRec [bndr])
 300                  (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
 301
 302 lintCoreExpr (Let (Rec pairs) body)
 303   = lintAndScopeIds bndrs       $ \_ ->
 304     do  { mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
 305         ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
 306   where
 307     bndrs = map fst pairs
 308
 309 lintCoreExpr e@(App fun arg)
 310   = do  { fun_ty <- lintCoreExpr fun
 311         ; addLoc (AnExpr e) $
 312           lintCoreArg fun_ty arg }
 313
 314 lintCoreExpr (Lam var expr)
 315   = addLoc (LambdaBodyOf var) $
 316     lintBinders [var] $ \[var'] ->
 317     do { body_ty <- lintCoreExpr expr
 318        ; if isId var' then
 319              return (mkFunTy (idType var') body_ty)
 320          else
 321              return (mkForAllTy var' body_ty)
 322        }
 323         -- The applySubst is needed to apply the subst to var
 324
 325 lintCoreExpr e@(Case scrut var alt_ty alts) =
 326        -- Check the scrutinee
 327   do { scrut_ty <- lintCoreExpr scrut
 328      ; alt_ty   <- lintTy alt_ty
 329      ; var_ty   <- lintTy (idType var)
 330
 331      ; let mb_tc_app = splitTyConApp_maybe (idType var)
 332      ; case mb_tc_app of
 333          Just (tycon, _)
 334               | debugIsOn &&
 335                 isAlgTyCon tycon &&
 336                 not (isOpenTyCon tycon) &&
 337                 null (tyConDataCons tycon) ->
 338                   pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
 339                         -- This can legitimately happen for type families
 340                       $ return ()
 341          _otherwise -> return ()
 342
 343         -- Don't use lintIdBndr on var, because unboxed tuple is legitimate
 344
 345      ; subst <- getTvSubst
 346      ; checkTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
 347
 348      -- If the binder is an unboxed tuple type, don't put it in scope
 349      ; let scope = if (isUnboxedTupleType (idType var)) then
 350                        pass_var
 351                    else lintAndScopeId var
 352      ; scope $ \_ ->
 353        do { -- Check the alternatives
 354             mapM_ (lintCoreAlt scrut_ty alt_ty) alts
 355           ; checkCaseAlts e scrut_ty alts
 356           ; return alt_ty } }
 357   where
 358     pass_var f = f var
 359
 360 lintCoreExpr (Type ty)
 361   = do { ty' <- lintTy ty
 362        ; return (typeKind ty') }
 363 \end{code}
 364
 365 %************************************************************************
 366 %*                                                                      *
 367 \subsection[lintCoreArgs]{lintCoreArgs}
 368 %*                                                                      *
 369 %************************************************************************
 370
 371 The basic version of these functions checks that the argument is a
 372 subtype of the required type, as one would expect.
 373
 374 \begin{code}
 375 lintCoreArgs :: OutType -> [CoreArg] -> LintM OutType
 376 lintCoreArg  :: OutType -> CoreArg   -> LintM OutType
 377 -- First argument has already had substitution applied to it
 378 \end{code}
 379
 380 \begin{code}
 381 lintCoreArgs ty [] = return ty
 382 lintCoreArgs ty (a : args) =
 383   do { res <- lintCoreArg ty a
 384      ; lintCoreArgs res args }
 385
 386 lintCoreArg fun_ty (Type arg_ty) =
 387   do { arg_ty <- lintTy arg_ty
 388      ; lintTyApp fun_ty arg_ty }
 389
 390 lintCoreArg fun_ty arg =
 391        -- Make sure function type matches argument
 392   do { arg_ty <- lintCoreExpr arg
 393      ; let err1 =  mkAppMsg fun_ty arg_ty arg
 394            err2 = mkNonFunAppMsg fun_ty arg_ty arg
 395      ; case splitFunTy_maybe fun_ty of
 396         Just (arg,res) ->
 397           do { checkTys arg arg_ty err1
 398              ; return res }
 399         _ -> addErrL err2 }
 400 \end{code}
 401
 402 \begin{code}
 403 -- Both args have had substitution applied
 404 lintTyApp :: OutType -> OutType -> LintM OutType
 405 lintTyApp ty arg_ty
 406   = case splitForAllTy_maybe ty of
 407       Nothing -> addErrL (mkTyAppMsg ty arg_ty)
 408
 409       Just (tyvar,body)
 410         -> do   { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty)
 411                 ; checkKinds tyvar arg_ty
 412                 ; return (substTyWith [tyvar] [arg_ty] body) }
 413
 414 checkKinds :: Var -> Type -> LintM ()
 415 checkKinds tyvar arg_ty
 416         -- Arg type might be boxed for a function with an uncommitted
 417         -- tyvar; notably this is used so that we can give
 418         --      error :: forall a:*. String -> a
 419         -- and then apply it to both boxed and unboxed types.
 420   = checkL (arg_kind `isSubKind` tyvar_kind)
 421            (mkKindErrMsg tyvar arg_ty)
 422   where
 423     tyvar_kind = tyVarKind tyvar
 424     arg_kind | isCoVar tyvar = coercionKindPredTy arg_ty
 425              | otherwise     = typeKind arg_ty
 426
 427 checkDeadIdOcc :: Id -> LintM ()
 428 -- Occurrences of an Id should never be dead....
 429 -- except when we are checking a case pattern
 430 checkDeadIdOcc id
 431   | isDeadOcc (idOccInfo id)
 432   = do { in_case <- inCasePat
 433        ; checkL in_case
 434                 (ptext (sLit "Occurrence of a dead Id") <+> ppr id) }
 435   | otherwise
 436   = return ()
 437 \end{code}
 438
 439
 440 %************************************************************************
 441 %*                                                                      *
 442 \subsection[lintCoreAlts]{lintCoreAlts}
 443 %*                                                                      *
 444 %************************************************************************
 445
 446 \begin{code}
 447 checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
 448 -- a) Check that the alts are non-empty
 449 -- b1) Check that the DEFAULT comes first, if it exists
 450 -- b2) Check that the others are in increasing order
 451 -- c) Check that there's a default for infinite types
 452 -- NB: Algebraic cases are not necessarily exhaustive, because
 453 --     the simplifer correctly eliminates case that can't
 454 --     possibly match.
 455
 456 checkCaseAlts e _ []
 457   = addErrL (mkNullAltsMsg e)
 458
 459 checkCaseAlts e ty alts =
 460   do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
 461      ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
 462      ; checkL (isJust maybe_deflt || not is_infinite_ty)
 463            (nonExhaustiveAltsMsg e) }
 464   where
 465     (con_alts, maybe_deflt) = findDefault alts
 466
 467         -- Check that successive alternatives have increasing tags
 468     increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
 469     increasing_tag _                         = True
 470
 471     non_deflt (DEFAULT, _, _) = False
 472     non_deflt _               = True
 473
 474     is_infinite_ty = case splitTyConApp_maybe ty of
 475                         Nothing         -> False
 476                         Just (tycon, _) -> isPrimTyCon tycon
 477 \end{code}
 478
 479 \begin{code}
 480 checkAltExpr :: CoreExpr -> OutType -> LintM ()
 481 checkAltExpr expr ann_ty
 482   = do { actual_ty <- lintCoreExpr expr
 483        ; checkTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
 484
 485 lintCoreAlt :: OutType          -- Type of scrutinee
 486             -> OutType          -- Type of the alternative
 487             -> CoreAlt
 488             -> LintM ()
 489
 490 lintCoreAlt _ alt_ty (DEFAULT, args, rhs) =
 491   do { checkL (null args) (mkDefaultArgsMsg args)
 492      ; checkAltExpr rhs alt_ty }
 493
 494 lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs) =
 495   do { checkL (null args) (mkDefaultArgsMsg args)
 496      ; checkTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
 497      ; checkAltExpr rhs alt_ty }
 498   where
 499     lit_ty = literalType lit
 500
 501 lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
 502   | isNewTyCon (dataConTyCon con) = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
 503   | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
 504   = addLoc (CaseAlt alt) $  do
 505     {   -- First instantiate the universally quantified
 506         -- type variables of the data constructor
 507         -- We've already check
 508       checkL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
 509     ; let con_payload_ty = applyTys (dataConRepType con) tycon_arg_tys
 510
 511         -- And now bring the new binders into scope
 512     ; lintBinders args $ \ args -> do
 513     { addLoc (CasePat alt) $ do
 514           {    -- Check the pattern
 515                  -- Scrutinee type must be a tycon applicn; checked by caller
 516                  -- This code is remarkably compact considering what it does!
 517                  -- NB: args must be in scope here so that the lintCoreArgs
 518                  --     line works.
 519                  -- NB: relies on existential type args coming *after*
 520                  --     ordinary type args
 521           ; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args)
 522           ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
 523           }
 524                -- Check the RHS
 525     ; checkAltExpr rhs alt_ty } }
 526
 527   | otherwise   -- Scrut-ty is wrong shape
 528   = addErrL (mkBadAltMsg scrut_ty alt)
 529 \end{code}
 530
 531 %************************************************************************
 532 %*                                                                      *
 533 \subsection[lint-types]{Types}
 534 %*                                                                      *
 535 %************************************************************************
 536
 537 \begin{code}
 538 -- When we lint binders, we (one at a time and in order):
 539 --  1. Lint var types or kinds (possibly substituting)
 540 --  2. Add the binder to the in scope set, and if its a coercion var,
 541 --     we may extend the substitution to reflect its (possibly) new kind
 542 lintBinders :: [Var] -> ([Var] -> LintM a) -> LintM a
 543 lintBinders [] linterF = linterF []
 544 lintBinders (var:vars) linterF = lintBinder var $ \var' ->
 545                                  lintBinders vars $ \ vars' ->
 546                                  linterF (var':vars')
 547
 548 lintBinder :: Var -> (Var -> LintM a) -> LintM a
 549 lintBinder var linterF
 550   | isTyVar var = lint_ty_bndr
 551   | otherwise   = lintIdBndr var linterF
 552   where
 553     lint_ty_bndr = do { _ <- lintTy (tyVarKind var)
 554                       ; subst <- getTvSubst
 555                       ; let (subst', tv') = substTyVarBndr subst var
 556                       ; updateTvSubst subst' (linterF tv') }
 557
 558 lintIdBndr :: Var -> (Var -> LintM a) -> LintM a
 559 -- Do substitution on the type of a binder and add the var with this
 560 -- new type to the in-scope set of the second argument
 561 -- ToDo: lint its rules
 562 lintIdBndr id linterF
 563   = do  { checkL (not (isUnboxedTupleType (idType id)))
 564                  (mkUnboxedTupleMsg id)
 565                 -- No variable can be bound to an unboxed tuple.
 566         ; lintAndScopeId id $ \id' -> linterF id'
 567         }
 568
 569 lintAndScopeIds :: [Var] -> ([Var] -> LintM a) -> LintM a
 570 lintAndScopeIds ids linterF
 571   = go ids
 572   where
 573     go []       = linterF []
 574     go (id:ids) = do { lintAndScopeId id $ \id ->
 575                            lintAndScopeIds ids $ \ids ->
 576                            linterF (id:ids) }
 577
 578 lintAndScopeId :: Var -> (Var -> LintM a) -> LintM a
 579 lintAndScopeId id linterF
 580   = do { ty <- lintTy (idType id)
 581        ; let id' = setIdType id ty
 582        ; addInScopeVars [id'] $ (linterF id')
 583        }
 584
 585 lintTy :: InType -> LintM OutType
 586 -- Check the type, and apply the substitution to it
 587 -- See Note [Linting type lets]
 588 -- ToDo: check the kind structure of the type
 589 lintTy ty
 590   = do  { ty' <- applySubst ty
 591         ; mapM_ checkTyVarInScope (varSetElems (tyVarsOfType ty'))
 592         ; return ty' }
 593 \end{code}
 594
 595
 596 %************************************************************************
 597 %*                                                                      *
 598 \subsection[lint-monad]{The Lint monad}
 599 %*                                                                      *
 600 %************************************************************************
 601
 602 \begin{code}
 603 newtype LintM a =
 604    LintM { unLintM ::
 605             [LintLocInfo] ->         -- Locations
 606             TvSubst ->               -- Current type substitution; we also use this
 607                                      -- to keep track of all the variables in scope,
 608                                      -- both Ids and TyVars
 609             Bag Message ->           -- Error messages so far
 610             (Maybe a, Bag Message) } -- Result and error messages (if any)
 611
 612 {-      Note [Type substitution]
 613         ~~~~~~~~~~~~~~~~~~~~~~~~
 614 Why do we need a type substitution?  Consider
 615         /\(a:*). \(x:a). /\(a:*). id a x
 616 This is ill typed, because (renaming variables) it is really
 617         /\(a:*). \(x:a). /\(b:*). id b x
 618 Hence, when checking an application, we can't naively compare x's type
 619 (at its binding site) with its expected type (at a use site).  So we
 620 rename type binders as we go, maintaining a substitution.
 621
 622 The same substitution also supports let-type, current expressed as
 623         (/\(a:*). body) ty
 624 Here we substitute 'ty' for 'a' in 'body', on the fly.
 625 -}
 626
 627 instance Monad LintM where
 628   return x = LintM (\ _   _     errs -> (Just x, errs))
 629   fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc))
 630   m >>= k  = LintM (\ loc subst errs ->
 631                        let (res, errs') = unLintM m loc subst errs in
 632                          case res of
 633                            Just r -> unLintM (k r) loc subst errs'
 634                            Nothing -> (Nothing, errs'))
 635
 636 data LintLocInfo
 637   = RhsOf Id            -- The variable bound
 638   | LambdaBodyOf Id     -- The lambda-binder
 639   | BodyOfLetRec [Id]   -- One of the binders
 640   | CaseAlt CoreAlt     -- Case alternative
 641   | CasePat CoreAlt     -- The *pattern* of the case alternative
 642   | AnExpr CoreExpr     -- Some expression
 643   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
 644   | TopLevelBindings
 645 \end{code}
 646
 647
 648 \begin{code}
 649 initL :: LintM a -> Maybe Message {- errors -}
 650 initL m
 651   = case unLintM m [] emptyTvSubst emptyBag of
 652       (_, errs) | isEmptyBag errs -> Nothing
 653                 | otherwise       -> Just (vcat (punctuate (text "") (bagToList errs)))
 654 \end{code}
 655
 656 \begin{code}
 657 checkL :: Bool -> Message -> LintM ()
 658 checkL True  _   = return ()
 659 checkL False msg = addErrL msg
 660
 661 addErrL :: Message -> LintM a
 662 addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc))
 663
 664 addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message
 665 addErr subst errs_so_far msg locs
 666   = ASSERT( notNull locs )
 667     errs_so_far `snocBag` mk_msg msg
 668   where
 669    (loc, cxt1) = dumpLoc (head locs)
 670    cxts        = [snd (dumpLoc loc) | loc <- locs]
 671    context     | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$
 672                                       ptext (sLit "Substitution:") <+> ppr subst
 673                | otherwise          = cxt1
 674
 675    mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
 676
 677 addLoc :: LintLocInfo -> LintM a -> LintM a
 678 addLoc extra_loc m =
 679   LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
 680
 681 inCasePat :: LintM Bool         -- A slight hack; see the unique call site
 682 inCasePat = LintM $ \ loc _ errs -> (Just (is_case_pat loc), errs)
 683   where
 684     is_case_pat (CasePat {} : _) = True
 685     is_case_pat _other           = False
 686
 687 addInScopeVars :: [Var] -> LintM a -> LintM a
 688 addInScopeVars vars m
 689   | null dups
 690   = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
 691   | otherwise
 692   = addErrL (dupVars dups)
 693   where
 694     (_, dups) = removeDups compare vars
 695
 696 updateTvSubst :: TvSubst -> LintM a -> LintM a
 697 updateTvSubst subst' m =
 698   LintM (\ loc _ errs -> unLintM m loc subst' errs)
 699
 700 getTvSubst :: LintM TvSubst
 701 getTvSubst = LintM (\ _ subst errs -> (Just subst, errs))
 702
 703 applySubst :: Type -> LintM Type
 704 applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
 705
 706 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
 707 extendSubstL tv ty m
 708   = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
 709 \end{code}
 710
 711 \begin{code}
 712 lookupIdInScope :: Id -> LintM Id
 713 lookupIdInScope id
 714   | not (mustHaveLocalBinding id)
 715   = return id   -- An imported Id
 716   | otherwise
 717   = do  { subst <- getTvSubst
 718         ; case lookupInScope (getTvInScope subst) id of
 719                 Just v  -> return v
 720                 Nothing -> do { _ <- addErrL out_of_scope
 721                               ; return id } }
 722   where
 723     out_of_scope = ppr id <+> ptext (sLit "is out of scope")
 724
 725
 726 oneTupleDataConId :: Id -- Should not happen
 727 oneTupleDataConId = dataConWorkId (tupleCon Boxed 1)
 728
 729 checkBndrIdInScope :: Var -> Var -> LintM ()
 730 checkBndrIdInScope binder id
 731   = checkInScope msg id
 732     where
 733      msg = ptext (sLit "is out of scope inside info for") <+>
 734            ppr binder
 735
 736 checkTyVarInScope :: TyVar -> LintM ()
 737 checkTyVarInScope tv = checkInScope (ptext (sLit "is out of scope")) tv
 738
 739 checkInScope :: SDoc -> Var -> LintM ()
 740 checkInScope loc_msg var =
 741  do { subst <- getTvSubst
 742     ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
 743              (hsep [ppr var, loc_msg]) }
 744
 745 checkTys :: Type -> Type -> Message -> LintM ()
 746 -- check ty2 is subtype of ty1 (ie, has same structure but usage
 747 -- annotations need only be consistent, not equal)
 748 -- Assumes ty1,ty2 are have alrady had the substitution applied
 749 checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
 750 \end{code}
 751
 752 %************************************************************************
 753 %*                                                                      *
 754 \subsection{Error messages}
 755 %*                                                                      *
 756 %************************************************************************
 757
 758 \begin{code}
 759 dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)
 760
 761 dumpLoc (RhsOf v)
 762   = (getSrcLoc v, brackets (ptext (sLit "RHS of") <+> pp_binders [v]))
 763
 764 dumpLoc (LambdaBodyOf b)
 765   = (getSrcLoc b, brackets (ptext (sLit "in body of lambda with binder") <+> pp_binder b))
 766
 767 dumpLoc (BodyOfLetRec [])
 768   = (noSrcLoc, brackets (ptext (sLit "In body of a letrec with no binders")))
 769
 770 dumpLoc (BodyOfLetRec bs@(_:_))
 771   = ( getSrcLoc (head bs), brackets (ptext (sLit "in body of letrec with binders") <+> pp_binders bs))
 772
 773 dumpLoc (AnExpr e)
 774   = (noSrcLoc, text "In the expression:" <+> ppr e)
 775
 776 dumpLoc (CaseAlt (con, args, _))
 777   = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))
 778
 779 dumpLoc (CasePat (con, args, _))
 780   = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
 781
 782 dumpLoc (ImportedUnfolding locn)
 783   = (locn, brackets (ptext (sLit "in an imported unfolding")))
 784 dumpLoc TopLevelBindings
 785   = (noSrcLoc, empty)
 786
 787 pp_binders :: [Var] -> SDoc
 788 pp_binders bs = sep (punctuate comma (map pp_binder bs))
 789
 790 pp_binder :: Var -> SDoc
 791 pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]
 792             | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)]
 793 \end{code}
 794
 795 \begin{code}
 796 ------------------------------------------------------
 797 --      Messages for case expressions
 798
 799 mkNullAltsMsg :: CoreExpr -> Message
 800 mkNullAltsMsg e
 801   = hang (text "Case expression with no alternatives:")
 802          4 (ppr e)
 803
 804 mkDefaultArgsMsg :: [Var] -> Message
 805 mkDefaultArgsMsg args
 806   = hang (text "DEFAULT case with binders")
 807          4 (ppr args)
 808
 809 mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message
 810 mkCaseAltMsg e ty1 ty2
 811   = hang (text "Type of case alternatives not the same as the annotation on case:")
 812          4 (vcat [ppr ty1, ppr ty2, ppr e])
 813
 814 mkScrutMsg :: Id -> Type -> Type -> TvSubst -> Message
 815 mkScrutMsg var var_ty scrut_ty subst
 816   = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
 817           text "Result binder type:" <+> ppr var_ty,--(idType var),
 818           text "Scrutinee type:" <+> ppr scrut_ty,
 819      hsep [ptext (sLit "Current TV subst"), ppr subst]]
 820
 821 mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> Message
 822 mkNonDefltMsg e
 823   = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
 824 mkNonIncreasingAltsMsg e
 825   = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
 826
 827 nonExhaustiveAltsMsg :: CoreExpr -> Message
 828 nonExhaustiveAltsMsg e
 829   = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
 830
 831 mkBadConMsg :: TyCon -> DataCon -> Message
 832 mkBadConMsg tycon datacon
 833   = vcat [
 834         text "In a case alternative, data constructor isn't in scrutinee type:",
 835         text "Scrutinee type constructor:" <+> ppr tycon,
 836         text "Data con:" <+> ppr datacon
 837     ]
 838
 839 mkBadPatMsg :: Type -> Type -> Message
 840 mkBadPatMsg con_result_ty scrut_ty
 841   = vcat [
 842         text "In a case alternative, pattern result type doesn't match scrutinee type:",
 843         text "Pattern result type:" <+> ppr con_result_ty,
 844         text "Scrutinee type:" <+> ppr scrut_ty
 845     ]
 846
 847 mkBadAltMsg :: Type -> CoreAlt -> Message
 848 mkBadAltMsg scrut_ty alt
 849   = vcat [ text "Data alternative when scrutinee is not a tycon application",
 850            text "Scrutinee type:" <+> ppr scrut_ty,
 851            text "Alternative:" <+> pprCoreAlt alt ]
 852
 853 mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message
 854 mkNewTyDataConAltMsg scrut_ty alt
 855   = vcat [ text "Data alternative for newtype datacon",
 856            text "Scrutinee type:" <+> ppr scrut_ty,
 857            text "Alternative:" <+> pprCoreAlt alt ]
 858
 859
 860 ------------------------------------------------------
 861 --      Other error messages
 862
 863 mkAppMsg :: Type -> Type -> CoreExpr -> Message
 864 mkAppMsg fun_ty arg_ty arg
 865   = vcat [ptext (sLit "Argument value doesn't match argument type:"),
 866               hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
 867               hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
 868               hang (ptext (sLit "Arg:")) 4 (ppr arg)]
 869
 870 mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message
 871 mkNonFunAppMsg fun_ty arg_ty arg
 872   = vcat [ptext (sLit "Non-function type in function position"),
 873               hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty),
 874               hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
 875               hang (ptext (sLit "Arg:")) 4 (ppr arg)]
 876
 877 mkKindErrMsg :: TyVar -> Type -> Message
 878 mkKindErrMsg tyvar arg_ty
 879   = vcat [ptext (sLit "Kinds don't match in type application:"),
 880           hang (ptext (sLit "Type variable:"))
 881                  4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
 882           hang (ptext (sLit "Arg type:"))
 883                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 884
 885 mkTyAppMsg :: Type -> Type -> Message
 886 mkTyAppMsg ty arg_ty
 887   = vcat [text "Illegal type application:",
 888               hang (ptext (sLit "Exp type:"))
 889                  4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
 890               hang (ptext (sLit "Arg type:"))
 891                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
 892
 893 mkRhsMsg :: Id -> Type -> Message
 894 mkRhsMsg binder ty
 895   = vcat
 896     [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"),
 897             ppr binder],
 898      hsep [ptext (sLit "Binder's type:"), ppr (idType binder)],
 899      hsep [ptext (sLit "Rhs type:"), ppr ty]]
 900
 901 mkRhsPrimMsg :: Id -> CoreExpr -> Message
 902 mkRhsPrimMsg binder _rhs
 903   = vcat [hsep [ptext (sLit "The type of this binder is primitive:"),
 904                      ppr binder],
 905               hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]
 906              ]
 907
 908 mkStrictMsg :: Id -> Message
 909 mkStrictMsg binder
 910   = vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"),
 911                      ppr binder],
 912               hsep [ptext (sLit "Binder's demand info:"), ppr (idNewDemandInfo binder)]
 913              ]
 914
 915 mkArityMsg :: Id -> Message
 916 mkArityMsg binder
 917   = vcat [hsep [ptext (sLit "Demand type has "),
 918                      ppr (dmdTypeDepth dmd_ty),
 919                      ptext (sLit " arguments, rhs has "),
 920                      ppr (idArity binder),
 921                      ptext (sLit "arguments, "),
 922                      ppr binder],
 923               hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty]
 924
 925          ]
 926            where (StrictSig dmd_ty) = idNewStrictness binder
 927
 928 mkUnboxedTupleMsg :: Id -> Message
 929 mkUnboxedTupleMsg binder
 930   = vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder],
 931           hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]]
 932
 933 mkCastErr :: Type -> Type -> Message
 934 mkCastErr from_ty expr_ty
 935   = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"),
 936           ptext (sLit "From-type:") <+> ppr from_ty,
 937           ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty
 938     ]
 939
 940 dupVars :: [[Var]] -> Message
 941 dupVars vars
 942   = hang (ptext (sLit "Duplicate variables brought into scope"))
 943        2 (ppr vars)
 944 \end{code}