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 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               ( idType, isAlgCon, dataConArgTys,
  15                           emptyIdSet, isEmptyIdSet, elementOfIdSet,
  16                           mkIdSet, intersectIdSets,
  17                           unionIdSets, idSetToList, IdSet,
  18                           GenId{-instanced NamedThing-}, Id
  19                         )
  20 import Literal          ( literalType, Literal{-instance Outputable-} )
  21 import Maybes           ( catMaybes )
  22 import Name             ( isLocallyDefined, getSrcLoc )
  23 import ErrUtils         ( ErrMsg )
  24 import PrimOp           ( primOpType )
  25 import SrcLoc           ( SrcLoc{-instance Outputable-} )
  26 import Type             ( mkFunTys, splitFunTys, splitAlgTyConApp_maybe,
  27                           isTyVarTy, Type
  28                         )
  29 import TyCon            ( TyCon, isDataTyCon )
  30 import Util             ( zipEqual )
  31 import GlaExts          ( trace )
  32 import Outputable
  33
  34 infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
  35
  36 unDictifyTy = panic "StgLint.unDictifyTy (ToDo)"
  37 \end{code}
  38
  39 Checks for
  40         (a) *some* type errors
  41         (b) locally-defined variables used but not defined
  42
  43 %************************************************************************
  44 %*                                                                      *
  45 \subsection{``lint'' for various constructs}
  46 %*                                                                      *
  47 %************************************************************************
  48
  49 @lintStgBindings@ is the top-level interface function.
  50
  51 \begin{code}
  52 lintStgBindings :: String -> [StgBinding] -> [StgBinding]
  53
  54 lintStgBindings whodunnit binds
  55   = _scc_ "StgLint"
  56     case (initL (lint_binds binds)) of
  57       Nothing  -> binds
  58       Just msg -> pprPanic "" (vcat [
  59                         ptext SLIT("*** Stg Lint ErrMsgs: in "),text whodunnit, ptext SLIT(" ***"),
  60                         msg,
  61                         ptext SLIT("*** Offending Program ***"),
  62                         pprStgBindings binds,
  63                         ptext SLIT("*** End of Offense ***")])
  64   where
  65     lint_binds :: [StgBinding] -> LintM ()
  66
  67     lint_binds [] = returnL ()
  68     lint_binds (bind:binds)
  69       = lintStgBinds bind               `thenL` \ binders ->
  70         addInScopeVars binders (
  71             lint_binds binds
  72         )
  73 \end{code}
  74
  75
  76 \begin{code}
  77 lintStgArg :: StgArg -> LintM (Maybe Type)
  78
  79 lintStgArg (StgLitArg lit)       = returnL (Just (literalType lit))
  80 lintStgArg (StgConArg con)       = returnL (Just (idType con))
  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 (splitAlgTyConApp_maybe scrut_ty) of
 183       Just (tycon, _, _) | isDataTyCon tycon
 184               -> lintStgAlts alts scrut_ty tycon
 185       other   -> addErrL (mkCaseDataConMsg e)   `thenL_`
 186                  returnL Nothing
 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 splitAlgTyConApp_maybe 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 data LintLocInfo
 273   = RhsOf Id            -- The variable bound
 274   | LambdaBodyOf [Id]   -- The lambda-binder
 275   | BodyOfLetRec [Id]   -- One of the binders
 276
 277 instance Outputable LintLocInfo where
 278     ppr (RhsOf v)
 279       = hcat [ppr (getSrcLoc v), ptext SLIT(": [RHS of "), pp_binders [v], char ']']
 280
 281     ppr (LambdaBodyOf bs)
 282       = hcat [ppr (getSrcLoc (head bs)),
 283                 ptext SLIT(": [in body of lambda with binders "), pp_binders bs, char ']']
 284
 285     ppr (BodyOfLetRec bs)
 286       = hcat [ppr (getSrcLoc (head bs)),
 287                 ptext SLIT(": [in body of letrec with binders "), pp_binders bs, char ']']
 288
 289 pp_binders :: [Id] -> SDoc
 290 pp_binders bs
 291   = sep (punctuate comma (map pp_binder bs))
 292   where
 293     pp_binder b
 294       = hsep [ppr b, ptext SLIT("::"), ppr (idType b)]
 295 \end{code}
 296
 297 \begin{code}
 298 initL :: LintM a -> Maybe ErrMsg
 299 initL m
 300   = case (m [] emptyIdSet emptyBag) of { (_, errs) ->
 301     if isEmptyBag errs then
 302         Nothing
 303     else
 304         Just (foldBag ($$) (\ msg -> msg) empty errs)
 305     }
 306
 307 returnL :: a -> LintM a
 308 returnL r loc scope errs = (r, errs)
 309
 310 thenL :: LintM a -> (a -> LintM b) -> LintM b
 311 thenL m k loc scope errs
 312   = case m loc scope errs of
 313       (r, errs') -> k r loc scope errs'
 314
 315 thenL_ :: LintM a -> LintM b -> LintM b
 316 thenL_ m k loc scope errs
 317   = case m loc scope errs of
 318       (_, errs') -> k loc scope errs'
 319
 320 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
 321 thenMaybeL m k loc scope errs
 322   = case m loc scope errs of
 323       (Nothing, errs2) -> (Nothing, errs2)
 324       (Just r,  errs2) -> k r loc scope errs2
 325
 326 thenMaybeL_ :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
 327 thenMaybeL_ m k loc scope errs
 328   = case m loc scope errs of
 329       (Nothing, errs2) -> (Nothing, errs2)
 330       (Just _,  errs2) -> k loc scope errs2
 331
 332 mapL :: (a -> LintM b) -> [a] -> LintM [b]
 333 mapL f [] = returnL []
 334 mapL f (x:xs)
 335   = f x         `thenL` \ r ->
 336     mapL f xs   `thenL` \ rs ->
 337     returnL (r:rs)
 338
 339 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
 340         -- Returns Nothing if anything fails
 341 mapMaybeL f [] = returnL (Just [])
 342 mapMaybeL f (x:xs)
 343   = f x             `thenMaybeL` \ r ->
 344     mapMaybeL f xs  `thenMaybeL` \ rs ->
 345     returnL (Just (r:rs))
 346 \end{code}
 347
 348 \begin{code}
 349 checkL :: Bool -> ErrMsg -> LintM ()
 350 checkL True  msg loc scope errs = ((), errs)
 351 checkL False msg loc scope errs = ((), addErr errs msg loc)
 352
 353 addErrL :: ErrMsg -> LintM ()
 354 addErrL msg loc scope errs = ((), addErr errs msg loc)
 355
 356 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
 357
 358 addErr errs_so_far msg locs
 359   = errs_so_far `snocBag` (hang (ppr (head locs)) 4 msg)
 360
 361 addLoc :: LintLocInfo -> LintM a -> LintM a
 362 addLoc extra_loc m loc scope errs
 363   = m (extra_loc:loc) scope errs
 364
 365 addInScopeVars :: [Id] -> LintM a -> LintM a
 366 addInScopeVars ids m loc scope errs
 367   = -- We check if these "new" ids are already
 368     -- in scope, i.e., we have *shadowing* going on.
 369     -- For now, it's just a "trace"; we may make
 370     -- a real error out of it...
 371     let
 372         new_set = mkIdSet ids
 373
 374         shadowed = scope `intersectIdSets` new_set
 375     in
 376 --  After adding -fliberate-case, Simon decided he likes shadowed
 377 --  names after all.  WDP 94/07
 378 --  (if isEmptyIdSet shadowed
 379 --  then id
 380 --  else pprTrace "Shadowed vars:" (ppr (idSetToList shadowed))) $
 381     m loc (scope `unionIdSets` new_set) errs
 382 \end{code}
 383
 384 \begin{code}
 385 checkFunApp :: Type             -- The function type
 386             -> [Type]   -- The arg type(s)
 387             -> ErrMsg           -- Error messgae
 388             -> LintM (Maybe Type)       -- The result type
 389
 390 checkFunApp fun_ty arg_tys msg loc scope errs
 391   = cfa res_ty expected_arg_tys arg_tys
 392   where
 393     (expected_arg_tys, res_ty) = splitFunTys fun_ty
 394
 395     cfa res_ty expected []      -- Args have run out; that's fine
 396       = (Just (mkFunTys expected res_ty), errs)
 397
 398     cfa res_ty [] arg_tys       -- Expected arg tys ran out first;
 399                                 -- first see if res_ty is a tyvar template;
 400                                 -- otherwise, maybe res_ty is a
 401                                 -- dictionary type which is actually a function?
 402       | isTyVarTy res_ty
 403       = (Just res_ty, errs)
 404       | otherwise
 405       = case splitFunTys (unDictifyTy res_ty) of
 406           ([], _)                 -> (Nothing, addErr errs msg loc)     -- Too many args
 407           (new_expected, new_res) -> cfa new_res new_expected arg_tys
 408
 409     cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys)
 410       = if (sleazy_eq_ty expected_arg_ty arg_ty)
 411         then cfa res_ty expected_arg_tys arg_tys
 412         else (Nothing, addErr errs msg loc) -- Arg mis-match
 413 \end{code}
 414
 415 \begin{code}
 416 checkInScope :: Id -> LintM ()
 417 checkInScope id loc scope errs
 418   = if isLocallyDefined id && not (isAlgCon id) && not (id `elementOfIdSet` scope) then
 419         ((), addErr errs (hsep [ppr id, ptext SLIT("is out of scope")]) loc)
 420     else
 421         ((), errs)
 422
 423 checkTys :: Type -> Type -> ErrMsg -> LintM ()
 424 checkTys ty1 ty2 msg loc scope errs
 425   = if (sleazy_eq_ty ty1 ty2)
 426     then ((), errs)
 427     else ((), addErr errs msg loc)
 428 \end{code}
 429
 430 \begin{code}
 431 mkCaseAltMsg :: StgCaseAlts -> ErrMsg
 432 mkCaseAltMsg alts
 433   = ($$) (text "In some case alternatives, type of alternatives not all same:")
 434             -- LATER: (ppr alts)
 435             (panic "mkCaseAltMsg")
 436
 437 mkCaseDataConMsg :: StgExpr -> ErrMsg
 438 mkCaseDataConMsg expr
 439   = ($$) (ptext SLIT("A case scrutinee not a type-constructor type:"))
 440             (pp_expr expr)
 441
 442 mkCaseAbstractMsg :: TyCon -> ErrMsg
 443 mkCaseAbstractMsg tycon
 444   = ($$) (ptext SLIT("An algebraic case on an abstract type:"))
 445             (ppr tycon)
 446
 447 mkDefltMsg :: StgCaseDefault -> ErrMsg
 448 mkDefltMsg deflt
 449   = ($$) (ptext SLIT("Binder in default case of a case expression doesn't match type of scrutinee:"))
 450             --LATER: (ppr deflt)
 451             (panic "mkDefltMsg")
 452
 453 mkFunAppMsg :: Type -> [Type] -> StgExpr -> ErrMsg
 454 mkFunAppMsg fun_ty arg_tys expr
 455   = vcat [text "In a function application, function type doesn't match arg types:",
 456               hang (ptext SLIT("Function type:")) 4 (ppr fun_ty),
 457               hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys)),
 458               hang (ptext SLIT("Expression:")) 4 (pp_expr expr)]
 459
 460 mkRhsConMsg :: Type -> [Type] -> ErrMsg
 461 mkRhsConMsg fun_ty arg_tys
 462   = vcat [text "In a RHS constructor application, con type doesn't match arg types:",
 463               hang (ptext SLIT("Constructor type:")) 4 (ppr fun_ty),
 464               hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys))]
 465
 466 mkUnappTyMsg :: Id -> Type -> ErrMsg
 467 mkUnappTyMsg var ty
 468   = vcat [text "Variable has a for-all type, but isn't applied to any types.",
 469               (<>) (ptext SLIT("Var:      ")) (ppr var),
 470               (<>) (ptext SLIT("Its type: ")) (ppr ty)]
 471
 472 mkAlgAltMsg1 :: Type -> ErrMsg
 473 mkAlgAltMsg1 ty
 474   = ($$) (text "In some case statement, type of scrutinee is not a data type:")
 475             (ppr ty)
 476
 477 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
 478 mkAlgAltMsg2 ty con
 479   = vcat [
 480         text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
 481         ppr ty,
 482         ppr con
 483     ]
 484
 485 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
 486 mkAlgAltMsg3 con alts
 487   = vcat [
 488         text "In some algebraic case alternative, number of arguments doesn't match constructor:",
 489         ppr con,
 490         ppr alts
 491     ]
 492
 493 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
 494 mkAlgAltMsg4 ty arg
 495   = vcat [
 496         text "In some algebraic case alternative, type of argument doesn't match data constructor:",
 497         ppr ty,
 498         ppr arg
 499     ]
 500
 501 mkPrimAltMsg :: (Literal, StgExpr) -> ErrMsg
 502 mkPrimAltMsg alt
 503   = ($$) (text "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
 504             (ppr alt)
 505
 506 mkRhsMsg :: Id -> Type -> ErrMsg
 507 mkRhsMsg binder ty
 508   = vcat [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
 509                      ppr binder],
 510               hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
 511               hsep [ptext SLIT("Rhs type:"), ppr ty]
 512              ]
 513
 514 pp_expr :: StgExpr -> SDoc
 515 pp_expr expr = ppr expr
 516
 517 sleazy_eq_ty ty1 ty2
 518         -- NB: probably severe overkill (WDP 95/04)
 519   = trace "StgLint.sleazy_eq_ty:use eqSimplTy?" $
 520     case (splitFunTys ty1) of { (tyargs1,tyres1) ->
 521     case (splitFunTys ty2) of { (tyargs2,tyres2) ->
 522     let
 523         ty11 = mkFunTys tyargs1 tyres1
 524         ty22 = mkFunTys tyargs2 tyres2
 525     in
 526     ty11 == ty22 }}
 527 \end{code}