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