ghc/compiler/stgSyn/StgLint.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[StgLint]{A ``lint'' pass to check for Stg correctness}
   5
   6 \begin{code}
   7 module StgLint ( lintStgBindings ) where
   8
   9 #include "HsVersions.h"
  10
  11 import StgSyn
  12
  13 import Bag              ( Bag, emptyBag, isEmptyBag, snocBag, foldBag )
  14 import Id               ( Id, idType )
  15 import VarSet
  16 import DataCon          ( DataCon, dataConArgTys, dataConRepType )
  17 import PrimOp           ( primOpType )
  18 import Literal          ( literalType, Literal )
  19 import Maybes           ( catMaybes )
  20 import Name             ( isLocallyDefined, getSrcLoc )
  21 import ErrUtils         ( ErrMsg, Message, addErrLocHdrLine, pprBagOfErrors, dontAddErrLoc )
  22 import Type             ( mkFunTys, splitFunTys, splitAlgTyConApp_maybe,
  23                           isUnLiftedType, isTyVarTy, splitForAllTys, Type
  24                         )
  25 import PprType          ( {- instance Outputable Type -} )
  26 import TyCon            ( TyCon, isDataTyCon )
  27 import Util             ( zipEqual )
  28 import Outputable
  29
  30 infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
  31 \end{code}
  32
  33 Checks for
  34         (a) *some* type errors
  35         (b) locally-defined variables used but not defined
  36
  37 %************************************************************************
  38 %*                                                                      *
  39 \subsection{``lint'' for various constructs}
  40 %*                                                                      *
  41 %************************************************************************
  42
  43 @lintStgBindings@ is the top-level interface function.
  44
  45 \begin{code}
  46 lintStgBindings :: String -> [StgBinding] -> [StgBinding]
  47
  48 lintStgBindings whodunnit binds
  49   = _scc_ "StgLint"
  50     case (initL (lint_binds binds)) of
  51       Nothing  -> binds
  52       Just msg -> pprPanic "" (vcat [
  53                         ptext SLIT("*** Stg Lint ErrMsgs: in") <+> text whodunnit <+> ptext SLIT("***"),
  54                         msg,
  55                         ptext SLIT("*** Offending Program ***"),
  56                         pprStgBindings binds,
  57                         ptext SLIT("*** End of Offense ***")])
  58   where
  59     lint_binds :: [StgBinding] -> LintM ()
  60
  61     lint_binds [] = returnL ()
  62     lint_binds (bind:binds)
  63       = lintStgBinds bind               `thenL` \ binders ->
  64         addInScopeVars binders (
  65             lint_binds binds
  66         )
  67 \end{code}
  68
  69
  70 \begin{code}
  71 lintStgArg :: StgArg -> LintM (Maybe Type)
  72 lintStgArg (StgLitArg lit) = returnL (Just (literalType lit))
  73 lintStgArg (StgVarArg v)   = lintStgVar v
  74
  75 lintStgVar v  = checkInScope v  `thenL_`
  76                 returnL (Just (idType v))
  77 \end{code}
  78
  79 \begin{code}
  80 lintStgBinds :: StgBinding -> LintM [Id]                -- Returns the binders
  81 lintStgBinds (StgNonRec binder rhs)
  82   = lint_binds_help (binder,rhs)        `thenL_`
  83     returnL [binder]
  84
  85 lintStgBinds (StgRec pairs)
  86   = addInScopeVars binders (
  87         mapL lint_binds_help pairs `thenL_`
  88         returnL binders
  89     )
  90   where
  91     binders = [b | (b,_) <- pairs]
  92
  93 lint_binds_help (binder, rhs)
  94   = addLoc (RhsOf binder) (
  95         -- Check the rhs
  96         lintStgRhs rhs    `thenL` \ maybe_rhs_ty ->
  97
  98         -- Check binder doesn't have unlifted type
  99         checkL (not (isUnLiftedType binder_ty))
 100                (mkUnLiftedTyMsg binder rhs)             `thenL_`
 101
 102         -- Check match to RHS type
 103         (case maybe_rhs_ty of
 104           Nothing     -> returnL ()
 105           Just rhs_ty -> checkTys  binder_ty
 106                                    rhs_ty
 107                                    (mkRhsMsg binder rhs_ty)
 108         )                       `thenL_`
 109
 110         returnL ()
 111     )
 112   where
 113     binder_ty = idType binder
 114 \end{code}
 115
 116 \begin{code}
 117 lintStgRhs :: StgRhs -> LintM (Maybe Type)
 118
 119 lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr)
 120   = lintStgExpr expr
 121
 122 lintStgRhs (StgRhsClosure _ _ _ _ _ binders expr)
 123   = addLoc (LambdaBodyOf binders) (
 124     addInScopeVars binders (
 125         lintStgExpr expr   `thenMaybeL` \ body_ty ->
 126         returnL (Just (mkFunTys (map idType binders) body_ty))
 127     ))
 128
 129 lintStgRhs (StgRhsCon _ con args)
 130   = mapMaybeL lintStgArg args   `thenL` \ maybe_arg_tys ->
 131     case maybe_arg_tys of
 132       Nothing       -> returnL Nothing
 133       Just arg_tys  -> checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
 134   where
 135     con_ty = dataConRepType con
 136 \end{code}
 137
 138 \begin{code}
 139 lintStgExpr :: StgExpr -> LintM (Maybe Type)    -- Nothing if error found
 140
 141 lintStgExpr (StgLit l) = returnL (Just (literalType l))
 142
 143 lintStgExpr e@(StgApp fun args)
 144   = lintStgVar fun              `thenMaybeL` \ fun_ty  ->
 145     mapMaybeL lintStgArg args   `thenL`      \ maybe_arg_tys ->
 146     case maybe_arg_tys of
 147       Nothing       -> returnL Nothing
 148       Just arg_tys  -> checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
 149
 150 lintStgExpr e@(StgConApp con args)
 151   = mapMaybeL lintStgArg args   `thenL` \ maybe_arg_tys ->
 152     case maybe_arg_tys of
 153       Nothing       -> returnL Nothing
 154       Just arg_tys  -> checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e)
 155   where
 156     con_ty = dataConRepType con
 157
 158 lintStgExpr e@(StgPrimApp op args _)
 159   = mapMaybeL lintStgArg args   `thenL` \ maybe_arg_tys ->
 160     case maybe_arg_tys of
 161       Nothing       -> returnL Nothing
 162       Just arg_tys  -> checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e)
 163   where
 164     op_ty = primOpType op
 165
 166 lintStgExpr (StgLam _ bndrs _)
 167   = addErrL (ptext SLIT("Unexpected StgLam") <+> ppr bndrs)     `thenL_`
 168     returnL Nothing
 169
 170 lintStgExpr (StgLet binds body)
 171   = lintStgBinds binds          `thenL` \ binders ->
 172     addLoc (BodyOfLetRec binders) (
 173     addInScopeVars binders (
 174         lintStgExpr body
 175     ))
 176
 177 lintStgExpr (StgLetNoEscape _ _ binds body)
 178   = lintStgBinds binds          `thenL` \ binders ->
 179     addLoc (BodyOfLetRec binders) (
 180     addInScopeVars binders (
 181         lintStgExpr body
 182     ))
 183
 184 lintStgExpr (StgSCC _ expr)     = lintStgExpr expr
 185
 186 lintStgExpr e@(StgCase scrut _ _ bndr _ alts)
 187   = lintStgExpr scrut           `thenMaybeL` \ _ ->
 188     checkTys (idType bndr) scrut_ty (mkDefltMsg bndr) `thenL_`
 189
 190     (trace (showSDoc (ppr e)) $
 191         -- we only allow case of tail-call or primop.
 192     (case scrut of
 193         StgApp _ _    -> returnL ()
 194         StgConApp _ _ -> returnL ()
 195         other -> addErrL (mkCaseOfCaseMsg e))   `thenL_`
 196
 197     addInScopeVars [bndr] (lintStgAlts alts scrut_ty)
 198   )
 199   where
 200     scrut_ty = get_ty alts
 201
 202     get_ty (StgAlgAlts  ty _ _) = ty
 203     get_ty (StgPrimAlts ty _ _) = ty
 204 \end{code}
 205
 206 \begin{code}
 207 lintStgAlts :: StgCaseAlts
 208              -> Type            -- Type of scrutinee
 209              -> LintM (Maybe Type)      -- Type of alternatives
 210
 211 lintStgAlts alts scrut_ty
 212   = (case alts of
 213          StgAlgAlts _ alg_alts deflt ->
 214            mapL (lintAlgAlt scrut_ty) alg_alts  `thenL` \ maybe_alt_tys ->
 215            lintDeflt deflt scrut_ty             `thenL` \ maybe_deflt_ty ->
 216            returnL (maybe_deflt_ty : maybe_alt_tys)
 217
 218          StgPrimAlts _ prim_alts deflt ->
 219            mapL (lintPrimAlt scrut_ty) prim_alts `thenL` \ maybe_alt_tys ->
 220            lintDeflt deflt scrut_ty              `thenL` \ maybe_deflt_ty ->
 221            returnL (maybe_deflt_ty : maybe_alt_tys)
 222     )                                            `thenL` \ maybe_result_tys ->
 223          -- Check the result types
 224     case catMaybes (maybe_result_tys) of
 225       []             -> returnL Nothing
 226
 227       (first_ty:tys) -> mapL check tys  `thenL_`
 228                         returnL (Just first_ty)
 229         where
 230           check ty = checkTys first_ty ty (mkCaseAltMsg alts)
 231
 232 lintAlgAlt scrut_ty (con, args, _, rhs)
 233   = (case splitAlgTyConApp_maybe scrut_ty of
 234       Nothing ->
 235          addErrL (mkAlgAltMsg1 scrut_ty)
 236       Just (tycon, tys_applied, cons) ->
 237          let
 238            arg_tys = dataConArgTys con tys_applied
 239                 -- This almost certainly does not work for existential constructors
 240          in
 241          checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
 242          checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
 243                                                                  `thenL_`
 244          mapL check (zipEqual "lintAlgAlt:stg" arg_tys args)     `thenL_`
 245          returnL ()
 246     )                                                            `thenL_`
 247     addInScopeVars args         (
 248          lintStgExpr rhs
 249     )
 250   where
 251     check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
 252
 253     -- elem: yes, the elem-list here can sometimes be long-ish,
 254     -- but as it's use-once, probably not worth doing anything different
 255     -- We give it its own copy, so it isn't overloaded.
 256     elem _ []       = False
 257     elem x (y:ys)   = x==y || elem x ys
 258
 259 lintPrimAlt scrut_ty alt@(lit,rhs)
 260  = checkTys (literalType lit) scrut_ty (mkPrimAltMsg alt)       `thenL_`
 261    lintStgExpr rhs
 262
 263 lintDeflt StgNoDefault scrut_ty = returnL Nothing
 264 lintDeflt deflt@(StgBindDefault rhs) scrut_ty = lintStgExpr rhs
 265 \end{code}
 266
 267
 268 %************************************************************************
 269 %*                                                                      *
 270 \subsection[lint-monad]{The Lint monad}
 271 %*                                                                      *
 272 %************************************************************************
 273
 274 \begin{code}
 275 type LintM a = [LintLocInfo]    -- Locations
 276             -> IdSet            -- Local vars in scope
 277             -> Bag ErrMsg       -- Error messages so far
 278             -> (a, Bag ErrMsg)  -- Result and error messages (if any)
 279
 280 data LintLocInfo
 281   = RhsOf Id            -- The variable bound
 282   | LambdaBodyOf [Id]   -- The lambda-binder
 283   | BodyOfLetRec [Id]   -- One of the binders
 284
 285 dumpLoc (RhsOf v) =
 286   (getSrcLoc v, ptext SLIT(" [RHS of ") <> pp_binders [v] <> char ']' )
 287 dumpLoc (LambdaBodyOf bs) =
 288   (getSrcLoc (head bs), ptext SLIT(" [in body of lambda with binders ") <> pp_binders bs <> char ']' )
 289
 290 dumpLoc (BodyOfLetRec bs) =
 291   (getSrcLoc (head bs), ptext SLIT(" [in body of letrec with binders ") <> pp_binders bs <> char ']' )
 292
 293
 294 pp_binders :: [Id] -> SDoc
 295 pp_binders bs
 296   = sep (punctuate comma (map pp_binder bs))
 297   where
 298     pp_binder b
 299       = hsep [ppr b, dcolon, ppr (idType b)]
 300 \end{code}
 301
 302 \begin{code}
 303 initL :: LintM a -> Maybe Message
 304 initL m
 305   = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
 306     if isEmptyBag errs then
 307         Nothing
 308     else
 309         Just (pprBagOfErrors errs)
 310     }
 311
 312 returnL :: a -> LintM a
 313 returnL r loc scope errs = (r, errs)
 314
 315 thenL :: LintM a -> (a -> LintM b) -> LintM b
 316 thenL m k loc scope errs
 317   = case m loc scope errs of
 318       (r, errs') -> k r loc scope errs'
 319
 320 thenL_ :: LintM a -> LintM b -> LintM b
 321 thenL_ m k loc scope errs
 322   = case m loc scope errs of
 323       (_, errs') -> k loc scope errs'
 324
 325 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
 326 thenMaybeL m k loc scope errs
 327   = case m loc scope errs of
 328       (Nothing, errs2) -> (Nothing, errs2)
 329       (Just r,  errs2) -> k r loc scope errs2
 330
 331 thenMaybeL_ :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
 332 thenMaybeL_ m k loc scope errs
 333   = case m loc scope errs of
 334       (Nothing, errs2) -> (Nothing, errs2)
 335       (Just _,  errs2) -> k loc scope errs2
 336
 337 mapL :: (a -> LintM b) -> [a] -> LintM [b]
 338 mapL f [] = returnL []
 339 mapL f (x:xs)
 340   = f x         `thenL` \ r ->
 341     mapL f xs   `thenL` \ rs ->
 342     returnL (r:rs)
 343
 344 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
 345         -- Returns Nothing if anything fails
 346 mapMaybeL f [] = returnL (Just [])
 347 mapMaybeL f (x:xs)
 348   = f x             `thenMaybeL` \ r ->
 349     mapMaybeL f xs  `thenMaybeL` \ rs ->
 350     returnL (Just (r:rs))
 351 \end{code}
 352
 353 \begin{code}
 354 checkL :: Bool -> Message -> LintM ()
 355 checkL True  msg loc scope errs = ((), errs)
 356 checkL False msg loc scope errs = ((), addErr errs msg loc)
 357
 358 addErrL :: Message -> LintM ()
 359 addErrL msg loc scope errs = ((), addErr errs msg loc)
 360
 361 addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
 362
 363 addErr errs_so_far msg locs
 364   = errs_so_far `snocBag` mk_msg locs
 365   where
 366     mk_msg (loc:_) = let (l,hdr) = dumpLoc loc in addErrLocHdrLine l hdr msg
 367     mk_msg []      = dontAddErrLoc "" msg
 368
 369 addLoc :: LintLocInfo -> LintM a -> LintM a
 370 addLoc extra_loc m loc scope errs
 371   = m (extra_loc:loc) scope errs
 372
 373 addInScopeVars :: [Id] -> LintM a -> LintM a
 374 addInScopeVars ids m loc scope errs
 375   = -- We check if these "new" ids are already
 376     -- in scope, i.e., we have *shadowing* going on.
 377     -- For now, it's just a "trace"; we may make
 378     -- a real error out of it...
 379     let
 380         new_set = mkVarSet ids
 381
 382         shadowed = scope `intersectVarSet` new_set
 383     in
 384 --  After adding -fliberate-case, Simon decided he likes shadowed
 385 --  names after all.  WDP 94/07
 386 --  (if isEmptyVarSet shadowed
 387 --  then id
 388 --  else pprTrace "Shadowed vars:" (ppr (varSetElems shadowed))) $
 389     m loc (scope `unionVarSet` new_set) errs
 390 \end{code}
 391
 392 Checking function applications: we only check that the type has the
 393 right *number* of arrows, we don't actually compare the types.  This
 394 is because we can't expect the types to be equal - the type
 395 applications and type lambdas that we use to calculate accurate types
 396 have long since disappeared.
 397
 398 \begin{code}
 399 checkFunApp :: Type                 -- The function type
 400             -> [Type]               -- The arg type(s)
 401             -> Message              -- Error messgae
 402             -> LintM (Maybe Type)   -- The result type
 403
 404 checkFunApp fun_ty arg_tys msg loc scope errs
 405   = cfa res_ty expected_arg_tys arg_tys
 406   where
 407     (_, de_forall_ty)   = splitForAllTys fun_ty
 408     (expected_arg_tys, res_ty) = splitFunTys de_forall_ty
 409
 410     cfa res_ty expected []      -- Args have run out; that's fine
 411       = (Just (mkFunTys expected res_ty), errs)
 412
 413     cfa res_ty [] arg_tys       -- Expected arg tys ran out first;
 414                                 -- first see if res_ty is a tyvar template;
 415                                 -- otherwise, maybe res_ty is a
 416                                 -- dictionary type which is actually a function?
 417       | isTyVarTy res_ty
 418       = (Just res_ty, errs)
 419       | otherwise
 420       = case splitFunTys res_ty of
 421           ([], _)                 -> (Nothing, addErr errs msg loc)     -- Too many args
 422           (new_expected, new_res) -> cfa new_res new_expected arg_tys
 423
 424     cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys)
 425       = cfa res_ty expected_arg_tys arg_tys
 426 \end{code}
 427
 428 \begin{code}
 429 checkInScope :: Id -> LintM ()
 430 checkInScope id loc scope errs
 431   = if isLocallyDefined id && not (id `elemVarSet` scope) then
 432         ((), addErr errs (hsep [ppr id, ptext SLIT("is out of scope")]) loc)
 433     else
 434         ((), errs)
 435
 436 checkTys :: Type -> Type -> Message -> LintM ()
 437 checkTys ty1 ty2 msg loc scope errs
 438   = -- if (ty1 == ty2) then
 439     ((), errs)
 440     -- else ((), addErr errs msg loc)
 441 \end{code}
 442
 443 \begin{code}
 444 mkCaseAltMsg :: StgCaseAlts -> Message
 445 mkCaseAltMsg alts
 446   = ($$) (text "In some case alternatives, type of alternatives not all same:")
 447             (empty) -- LATER: ppr alts
 448
 449 mkCaseAbstractMsg :: TyCon -> Message
 450 mkCaseAbstractMsg tycon
 451   = ($$) (ptext SLIT("An algebraic case on an abstract type:"))
 452             (ppr tycon)
 453
 454 mkDefltMsg :: Id -> Message
 455 mkDefltMsg bndr
 456   = ($$) (ptext SLIT("Binder of a case expression doesn't match type of scrutinee:"))
 457             (panic "mkDefltMsg")
 458
 459 mkFunAppMsg :: Type -> [Type] -> StgExpr -> Message
 460 mkFunAppMsg fun_ty arg_tys expr
 461   = vcat [text "In a function application, function type doesn't match arg types:",
 462               hang (ptext SLIT("Function type:")) 4 (ppr fun_ty),
 463               hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys)),
 464               hang (ptext SLIT("Expression:")) 4 (ppr expr)]
 465
 466 mkRhsConMsg :: Type -> [Type] -> Message
 467 mkRhsConMsg fun_ty arg_tys
 468   = vcat [text "In a RHS constructor application, con type doesn't match arg types:",
 469               hang (ptext SLIT("Constructor type:")) 4 (ppr fun_ty),
 470               hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys))]
 471
 472 mkUnappTyMsg :: Id -> Type -> Message
 473 mkUnappTyMsg var ty
 474   = vcat [text "Variable has a for-all type, but isn't applied to any types.",
 475               (<>) (ptext SLIT("Var:      ")) (ppr var),
 476               (<>) (ptext SLIT("Its type: ")) (ppr ty)]
 477
 478 mkAlgAltMsg1 :: Type -> Message
 479 mkAlgAltMsg1 ty
 480   = ($$) (text "In some case statement, type of scrutinee is not a data type:")
 481             (ppr ty)
 482
 483 mkAlgAltMsg2 :: Type -> DataCon -> Message
 484 mkAlgAltMsg2 ty con
 485   = vcat [
 486         text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
 487         ppr ty,
 488         ppr con
 489     ]
 490
 491 mkAlgAltMsg3 :: DataCon -> [Id] -> Message
 492 mkAlgAltMsg3 con alts
 493   = vcat [
 494         text "In some algebraic case alternative, number of arguments doesn't match constructor:",
 495         ppr con,
 496         ppr alts
 497     ]
 498
 499 mkAlgAltMsg4 :: Type -> Id -> Message
 500 mkAlgAltMsg4 ty arg
 501   = vcat [
 502         text "In some algebraic case alternative, type of argument doesn't match data constructor:",
 503         ppr ty,
 504         ppr arg
 505     ]
 506
 507 mkPrimAltMsg :: (Literal, StgExpr) -> Message
 508 mkPrimAltMsg alt
 509   = text "In a primitive case alternative, type of literal doesn't match type of scrutinee:"
 510     $$ ppr alt
 511
 512 mkCaseOfCaseMsg :: StgExpr -> Message
 513 mkCaseOfCaseMsg e
 514   = text "Case of non-tail-call:" $$ ppr e
 515
 516 mkRhsMsg :: Id -> Type -> Message
 517 mkRhsMsg binder ty
 518   = vcat [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
 519                      ppr binder],
 520               hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
 521               hsep [ptext SLIT("Rhs type:"), ppr ty]
 522              ]
 523
 524 mkUnLiftedTyMsg binder rhs
 525   = (ptext SLIT("Let(rec) binder") <+> quotes (ppr binder) <+>
 526      ptext SLIT("has unlifted type") <+> quotes (ppr (idType binder)))
 527     $$
 528     (ptext SLIT("RHS:") <+> ppr rhs)
 529 \end{code}