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