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