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