ghc/compiler/stgSyn/StgLint.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   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 PrelInfo         ( primOpType, mkFunTy, PrimOp(..), PrimRep
  12                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  13                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  14                         )
  15 import Type
  16 import Bag
  17 import Literal          ( literalType, Literal )
  18 import Id               ( idType, isDataCon,
  19                           getInstantiatedDataConSig
  20                         )
  21 import Maybes
  22 import Outputable
  23 import Pretty
  24 import SrcLoc           ( SrcLoc )
  25 import StgSyn
  26 import UniqSet
  27 import Util
  28
  29 infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
  30 \end{code}
  31
  32 Checks for
  33         (a) *some* type errors
  34         (b) locally-defined variables used but not defined
  35
  36 %************************************************************************
  37 %*                                                                      *
  38 \subsection{``lint'' for various constructs}
  39 %*                                                                      *
  40 %************************************************************************
  41
  42 @lintStgBindings@ is the top-level interface function.
  43
  44 \begin{code}
  45 lintStgBindings :: PprStyle -> String -> [StgBinding] -> [StgBinding]
  46
  47 lintStgBindings sty whodunnit binds
  48   = BSCC("StgLint")
  49     case (initL (lint_binds binds)) of
  50       Nothing  -> binds
  51       Just msg -> pprPanic "" (ppAboves [
  52                         ppStr ("*** Stg Lint Errors: in "++whodunnit++" ***"),
  53                         msg sty,
  54                         ppStr "*** Offending Program ***",
  55                         ppAboves (map (pprPlainStgBinding sty) binds),
  56                         ppStr "*** End of Offense ***"])
  57     ESCC
  58   where
  59     lint_binds :: [StgBinding] -> LintM ()
  60
  61     lint_binds [] = returnL ()
  62     lint_binds (bind:binds)
  63       = lintStgBinds bind               `thenL` \ binders ->
  64         addInScopeVars binders (
  65             lint_binds binds
  66         )
  67 \end{code}
  68
  69
  70 \begin{code}
  71 lintStgArg :: StgArg -> LintM (Maybe Type)
  72
  73 lintStgArg (StgLitArg lit)       = returnL (Just (literalType lit))
  74 lintStgArg a@(StgVarArg v)
  75   = checkInScope v      `thenL_`
  76     returnL (Just (idType v))
  77 \end{code}
  78
  79 \begin{code}
  80 lintStgBinds :: StgBinding -> LintM [Id]                -- Returns the binders
  81 lintStgBinds (StgNonRec binder rhs)
  82   = lint_binds_help (binder,rhs)        `thenL_`
  83     returnL [binder]
  84
  85 lintStgBinds (StgRec pairs)
  86   = addInScopeVars binders (
  87         mapL lint_binds_help pairs `thenL_`
  88         returnL binders
  89     )
  90   where
  91     binders = [b | (b,_) <- pairs]
  92
  93 lint_binds_help (binder, rhs)
  94   = addLoc (RhsOf binder) (
  95         -- Check the rhs
  96         lintStgRhs rhs    `thenL` \ maybe_rhs_ty ->
  97
  98         -- Check match to RHS type
  99         (case maybe_rhs_ty of
 100           Nothing     -> returnL ()
 101           Just rhs_ty -> checkTys (idType binder)
 102                                    rhs_ty
 103                                    (mkRhsMsg binder rhs_ty)
 104         )                       `thenL_`
 105
 106         returnL ()
 107     )
 108 \end{code}
 109
 110 \begin{code}
 111 lintStgRhs :: StgRhs -> LintM (Maybe Type)
 112
 113 lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
 114   = addLoc (LambdaBodyOf binders) (
 115     addInScopeVars binders (
 116         lintStgExpr expr   `thenMaybeL` \ body_ty ->
 117         returnL (Just (foldr (mkFunTy . idType) body_ty binders))
 118     ))
 119
 120 lintStgRhs (StgRhsCon _ con args)
 121   = mapMaybeL lintStgArg args   `thenL` \ maybe_arg_tys ->
 122     case maybe_arg_tys of
 123       Nothing       -> returnL Nothing
 124       Just arg_tys  -> checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
 125   where
 126     con_ty = idType con
 127 \end{code}
 128
 129 \begin{code}
 130 lintStgExpr :: StgExpr -> LintM (Maybe Type)    -- Nothing if error found
 131
 132 lintStgExpr e@(StgApp fun args _)
 133   = lintStgArg fun              `thenMaybeL` \ fun_ty  ->
 134     mapMaybeL lintStgArg args   `thenL`      \ maybe_arg_tys ->
 135     case maybe_arg_tys of
 136       Nothing       -> returnL Nothing
 137       Just arg_tys  -> checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
 138
 139 lintStgExpr e@(StgCon con args _)
 140   = mapMaybeL lintStgArg args   `thenL` \ maybe_arg_tys ->
 141     case maybe_arg_tys of
 142       Nothing       -> returnL Nothing
 143       Just arg_tys  -> checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e)
 144   where
 145     con_ty = idType con
 146
 147 lintStgExpr e@(StgPrim op args _)
 148   = mapMaybeL lintStgArg args   `thenL` \ maybe_arg_tys ->
 149     case maybe_arg_tys of
 150       Nothing      -> returnL Nothing
 151       Just arg_tys -> checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e)
 152   where
 153     op_ty = primOpType op
 154
 155 lintStgExpr (StgLet binds body)
 156   = lintStgBinds binds          `thenL` \ binders ->
 157     addLoc (BodyOfLetRec binders) (
 158     addInScopeVars binders (
 159         lintStgExpr body
 160     ))
 161
 162 lintStgExpr (StgLetNoEscape _ _ binds body)
 163   = lintStgBinds binds          `thenL` \ binders ->
 164     addLoc (BodyOfLetRec binders) (
 165     addInScopeVars binders (
 166         lintStgExpr body
 167     ))
 168
 169 lintStgExpr (StgSCC _ _ expr)   = lintStgExpr expr
 170
 171 lintStgExpr e@(StgCase scrut _ _ _ alts)
 172   = lintStgExpr scrut           `thenMaybeL` \ _ ->
 173
 174         -- Check that it is a data type
 175     case maybeAppDataTyCon scrut_ty of
 176       Nothing -> addErrL (mkCaseDataConMsg e)   `thenL_`
 177                  returnL Nothing
 178       Just (tycon, _, _)
 179               -> lintStgAlts alts scrut_ty tycon
 180   where
 181     scrut_ty = get_ty alts
 182
 183     get_ty (StgAlgAlts  ty _ _) = ty
 184     get_ty (StgPrimAlts ty _ _) = ty
 185 \end{code}
 186
 187 \begin{code}
 188 lintStgAlts :: StgCaseAlts
 189              -> Type            -- Type of scrutinee
 190              -> TyCon                   -- TyCon pinned on the case
 191              -> LintM (Maybe Type)      -- Type of alternatives
 192
 193 lintStgAlts alts scrut_ty case_tycon
 194   = (case alts of
 195          StgAlgAlts _ alg_alts deflt ->
 196            chk_non_abstract_type case_tycon     `thenL_`
 197            mapL (lintAlgAlt scrut_ty) alg_alts  `thenL` \ maybe_alt_tys ->
 198            lintDeflt deflt scrut_ty             `thenL` \ maybe_deflt_ty ->
 199            returnL (maybe_deflt_ty : maybe_alt_tys)
 200
 201          StgPrimAlts _ prim_alts deflt ->
 202            mapL (lintPrimAlt scrut_ty) prim_alts `thenL` \ maybe_alt_tys ->
 203            lintDeflt deflt scrut_ty              `thenL` \ maybe_deflt_ty ->
 204            returnL (maybe_deflt_ty : maybe_alt_tys)
 205     )                                            `thenL` \ maybe_result_tys ->
 206          -- Check the result types
 207     case catMaybes (maybe_result_tys) of
 208       []             -> returnL Nothing
 209
 210       (first_ty:tys) -> mapL check tys  `thenL_`
 211                         returnL (Just first_ty)
 212         where
 213           check ty = checkTys first_ty ty (mkCaseAltMsg alts)
 214   where
 215     chk_non_abstract_type tycon
 216       = case (getTyConFamilySize tycon) of
 217           Nothing -> addErrL (mkCaseAbstractMsg tycon)
 218           Just  _ -> returnL () -- that's cool
 219
 220 lintAlgAlt scrut_ty (con, args, _, rhs)
 221   = (case maybeAppDataTyCon scrut_ty of
 222       Nothing ->
 223          addErrL (mkAlgAltMsg1 scrut_ty)
 224       Just (tycon, tys_applied, cons) ->
 225          let
 226            (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
 227          in
 228          checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
 229          checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
 230                                                                  `thenL_`
 231          mapL check (arg_tys `zipEqual` args)                    `thenL_`
 232          returnL ()
 233     )                                                            `thenL_`
 234     addInScopeVars args         (
 235          lintStgExpr rhs
 236     )
 237   where
 238     check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
 239
 240     -- elem: yes, the elem-list here can sometimes be long-ish,
 241     -- but as it's use-once, probably not worth doing anything different
 242     -- We give it its own copy, so it isn't overloaded.
 243     elem _ []       = False
 244     elem x (y:ys)   = x==y || elem x ys
 245
 246 lintPrimAlt scrut_ty alt@(lit,rhs)
 247  = checkTys (literalType lit) scrut_ty (mkPrimAltMsg alt)       `thenL_`
 248    lintStgExpr rhs
 249
 250 lintDeflt StgNoDefault scrut_ty = returnL Nothing
 251 lintDeflt deflt@(StgBindDefault binder _ rhs) scrut_ty
 252   = checkTys (idType binder) scrut_ty (mkDefltMsg deflt)        `thenL_`
 253     addInScopeVars [binder] (
 254         lintStgExpr rhs
 255     )
 256 \end{code}
 257
 258
 259 %************************************************************************
 260 %*                                                                      *
 261 \subsection[lint-monad]{The Lint monad}
 262 %*                                                                      *
 263 %************************************************************************
 264
 265 \begin{code}
 266 type LintM a = [LintLocInfo]    -- Locations
 267             -> UniqSet Id       -- Local vars in scope
 268             -> Bag ErrMsg       -- Error messages so far
 269             -> (a, Bag ErrMsg)  -- Result and error messages (if any)
 270
 271 type ErrMsg = PprStyle -> Pretty
 272
 273 data LintLocInfo
 274   = RhsOf Id            -- The variable bound
 275   | LambdaBodyOf [Id]   -- The lambda-binder
 276   | BodyOfLetRec [Id]   -- One of the binders
 277
 278 instance Outputable LintLocInfo where
 279     ppr sty (RhsOf v)
 280       = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
 281
 282     ppr sty (LambdaBodyOf bs)
 283       = ppBesides [ppr sty (getSrcLoc (head bs)),
 284                 ppStr ": [in body of lambda with binders ", pp_binders sty bs, ppStr "]"]
 285
 286     ppr sty (BodyOfLetRec bs)
 287       = ppBesides [ppr sty (getSrcLoc (head bs)),
 288                 ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"]
 289
 290 pp_binders :: PprStyle -> [Id] -> Pretty
 291 pp_binders sty bs
 292   = ppInterleave ppComma (map pp_binder bs)
 293   where
 294     pp_binder b
 295       = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
 296 \end{code}
 297
 298 \begin{code}
 299 initL :: LintM a -> Maybe ErrMsg
 300 initL m
 301   = case (m [] emptyUniqSet emptyBag) of { (_, errs) ->
 302     if isEmptyBag errs then
 303         Nothing
 304     else
 305         Just ( \ sty ->
 306           ppAboves [ msg sty | msg <- bagToList errs ]
 307         )
 308     }
 309
 310 returnL :: a -> LintM a
 311 returnL r loc scope errs = (r, errs)
 312
 313 thenL :: LintM a -> (a -> LintM b) -> LintM b
 314 thenL m k loc scope errs
 315   = case m loc scope errs of
 316       (r, errs') -> k r loc scope errs'
 317
 318 thenL_ :: LintM a -> LintM b -> LintM b
 319 thenL_ m k loc scope errs
 320   = case m loc scope errs of
 321       (_, errs') -> k loc scope errs'
 322
 323 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
 324 thenMaybeL m k loc scope errs
 325   = case m loc scope errs of
 326       (Nothing, errs2) -> (Nothing, errs2)
 327       (Just r,  errs2) -> k r loc scope errs2
 328
 329 thenMaybeL_ :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
 330 thenMaybeL_ m k loc scope errs
 331   = case m loc scope errs of
 332       (Nothing, errs2) -> (Nothing, errs2)
 333       (Just _,  errs2) -> k loc scope errs2
 334
 335 mapL :: (a -> LintM b) -> [a] -> LintM [b]
 336 mapL f [] = returnL []
 337 mapL f (x:xs)
 338   = f x         `thenL` \ r ->
 339     mapL f xs   `thenL` \ rs ->
 340     returnL (r:rs)
 341
 342 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
 343         -- Returns Nothing if anything fails
 344 mapMaybeL f [] = returnL (Just [])
 345 mapMaybeL f (x:xs)
 346   = f x             `thenMaybeL` \ r ->
 347     mapMaybeL f xs  `thenMaybeL` \ rs ->
 348     returnL (Just (r:rs))
 349 \end{code}
 350
 351 \begin{code}
 352 checkL :: Bool -> ErrMsg -> LintM ()
 353 checkL True  msg loc scope errs = ((), errs)
 354 checkL False msg loc scope errs = ((), addErr errs msg loc)
 355
 356 addErrL :: ErrMsg -> LintM ()
 357 addErrL msg loc scope errs = ((), addErr errs msg loc)
 358
 359 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
 360
 361 addErr errs_so_far msg locs
 362   = errs_so_far `snocBag` ( \ sty ->
 363     ppHang (ppr sty (head locs)) 4 (msg sty)
 364     )
 365
 366 addLoc :: LintLocInfo -> LintM a -> LintM a
 367 addLoc extra_loc m loc scope errs
 368   = m (extra_loc:loc) scope errs
 369
 370 addInScopeVars :: [Id] -> LintM a -> LintM a
 371 addInScopeVars ids m loc scope errs
 372   = -- We check if these "new" ids are already
 373     -- in scope, i.e., we have *shadowing* going on.
 374     -- For now, it's just a "trace"; we may make
 375     -- a real error out of it...
 376     let
 377         new_set = mkUniqSet ids
 378
 379         shadowed = scope `intersectUniqSets` new_set
 380     in
 381 --  After adding -fliberate-case, Simon decided he likes shadowed
 382 --  names after all.  WDP 94/07
 383 --  (if isEmptyUniqSet shadowed
 384 --  then id
 385 --  else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
 386     m loc (scope `unionUniqSets` new_set) errs
 387 --  )
 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) = splitTypeWithDictsAsArgs fun_ty
 400
 401     cfa res_ty expected []      -- Args have run out; that's fine
 402       = (Just (glueTyArgs 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       | isTyVarTemplateTy res_ty
 409       = (Just res_ty, errs)
 410       | otherwise
 411       = case splitTyArgs (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       = case (sleazy_cmp_ty expected_arg_ty arg_ty) of
 417           EQ_ -> cfa res_ty expected_arg_tys arg_tys
 418           _   -> (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 `elementOfUniqSet` 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   = case (sleazy_cmp_ty ty1 ty2) of
 432       EQ_   -> ((), errs)
 433       other -> ((), 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_cmp_ty ty1 ty2
 524         -- NB: probably severe overkill (WDP 95/04)
 525   = case (splitTypeWithDictsAsArgs ty1) of { (_,tyargs1,tyres1) ->
 526     case (splitTypeWithDictsAsArgs ty2) of { (_,tyargs2,tyres2) ->
 527     let
 528         ty11 = glueTyArgs tyargs1 tyres1
 529         ty22 = glueTyArgs tyargs2 tyres2
 530     in
 531     cmpUniType False{-!!!NOT PROPERLY!!!-} ty11 ty22
 532     }}
 533 \end{code}