ghc/compiler/stgSyn/StgLint.lhs

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