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