compiler/stgSyn/StgLint.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[StgLint]{A ``lint'' pass to check for Stg correctness}
   5
   6 \begin{code}
   7 {-# OPTIONS -w #-}
   8 -- The above warning supression flag is a temporary kludge.
   9 -- While working on this module you are encouraged to remove it and fix
  10 -- any warnings in the module. See
  11 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  12 -- for details
  13
  14 module StgLint ( lintStgBindings ) where
  15
  16 #include "HsVersions.h"
  17
  18 import StgSyn
  19
  20 import Bag              ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
  21 import Id               ( Id, idType, isLocalId )
  22 import VarSet
  23 import DataCon          ( DataCon, dataConInstArgTys, dataConRepType )
  24 import CoreSyn          ( AltCon(..) )
  25 import PrimOp           ( primOpType )
  26 import Literal          ( literalType )
  27 import Maybes
  28 import Name             ( getSrcLoc )
  29 import ErrUtils         ( Message, mkLocMessage )
  30 import Type             ( mkFunTys, splitFunTys, splitTyConApp_maybe,
  31                           isUnLiftedType, isTyVarTy, dropForAlls, Type
  32                         )
  33 import TyCon            ( isAlgTyCon, isNewTyCon, tyConDataCons )
  34 import Util             ( zipEqual, equalLength )
  35 import SrcLoc           ( srcLocSpan )
  36 import Outputable
  37 import Control.Monad
  38 \end{code}
  39
  40 Checks for
  41         (a) *some* type errors
  42         (b) locally-defined variables used but not defined
  43
  44
  45 Note: unless -dverbose-stg is on, display of lint errors will result
  46 in "panic: bOGUS_LVs".
  47
  48 WARNING:
  49 ~~~~~~~~
  50
  51 This module has suffered bit-rot; it is likely to yield lint errors
  52 for Stg code that is currently perfectly acceptable for code
  53 generation.  Solution: don't use it!  (KSW 2000-05).
  54
  55
  56 %************************************************************************
  57 %*                                                                      *
  58 \subsection{``lint'' for various constructs}
  59 %*                                                                      *
  60 %************************************************************************
  61
  62 @lintStgBindings@ is the top-level interface function.
  63
  64 \begin{code}
  65 lintStgBindings :: String -> [StgBinding] -> [StgBinding]
  66
  67 lintStgBindings whodunnit binds
  68   = {-# SCC "StgLint" #-}
  69     case (initL (lint_binds binds)) of
  70       Nothing  -> binds
  71       Just msg -> pprPanic "" (vcat [
  72                         ptext SLIT("*** Stg Lint ErrMsgs: in") <+> text whodunnit <+> ptext SLIT("***"),
  73                         msg,
  74                         ptext SLIT("*** Offending Program ***"),
  75                         pprStgBindings binds,
  76                         ptext SLIT("*** End of Offense ***")])
  77   where
  78     lint_binds :: [StgBinding] -> LintM ()
  79
  80     lint_binds [] = return ()
  81     lint_binds (bind:binds) = do
  82         binders <- lintStgBinds bind
  83         addInScopeVars binders $
  84             lint_binds binds
  85 \end{code}
  86
  87
  88 \begin{code}
  89 lintStgArg :: StgArg -> LintM (Maybe Type)
  90 lintStgArg (StgLitArg lit) = return (Just (literalType lit))
  91 lintStgArg (StgVarArg v)   = lintStgVar v
  92
  93 lintStgVar v = do checkInScope v
  94                   return (Just (idType v))
  95 \end{code}
  96
  97 \begin{code}
  98 lintStgBinds :: StgBinding -> LintM [Id]                -- Returns the binders
  99 lintStgBinds (StgNonRec binder rhs) = do
 100     lint_binds_help (binder,rhs)
 101     return [binder]
 102
 103 lintStgBinds (StgRec pairs)
 104   = addInScopeVars binders $ do
 105         mapM_ lint_binds_help pairs
 106         return binders
 107   where
 108     binders = [b | (b,_) <- pairs]
 109
 110 lint_binds_help (binder, rhs)
 111   = addLoc (RhsOf binder) $ do
 112         -- Check the rhs
 113         maybe_rhs_ty <- lintStgRhs rhs
 114
 115         -- Check binder doesn't have unlifted type
 116         checkL (not (isUnLiftedType binder_ty))
 117                (mkUnLiftedTyMsg binder rhs)
 118
 119         -- Check match to RHS type
 120         case maybe_rhs_ty of
 121           Nothing     -> return ()
 122           Just rhs_ty -> checkTys  binder_ty
 123                                    rhs_ty
 124                                    (mkRhsMsg binder rhs_ty)
 125
 126         return ()
 127   where
 128     binder_ty = idType binder
 129 \end{code}
 130
 131 \begin{code}
 132 lintStgRhs :: StgRhs -> LintM (Maybe Type)
 133
 134 lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr)
 135   = lintStgExpr expr
 136
 137 lintStgRhs (StgRhsClosure _ _ _ _ _ binders expr)
 138   = addLoc (LambdaBodyOf binders) $
 139       addInScopeVars binders $ runMaybeT $ do
 140         body_ty <- MaybeT $ lintStgExpr expr
 141         return (mkFunTys (map idType binders) body_ty)
 142
 143 lintStgRhs (StgRhsCon _ con args) = runMaybeT $ do
 144     arg_tys <- mapM (MaybeT . lintStgArg) args
 145     MaybeT $ checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
 146   where
 147     con_ty = dataConRepType con
 148 \end{code}
 149
 150 \begin{code}
 151 lintStgExpr :: StgExpr -> LintM (Maybe Type)    -- Nothing if error found
 152
 153 lintStgExpr (StgLit l) = return (Just (literalType l))
 154
 155 lintStgExpr e@(StgApp fun args) = runMaybeT $ do
 156     fun_ty <- MaybeT $ lintStgVar fun
 157     arg_tys <- mapM (MaybeT . lintStgArg) args
 158     MaybeT $ checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
 159
 160 lintStgExpr e@(StgConApp con args) = runMaybeT $ do
 161     arg_tys <- mapM (MaybeT . lintStgArg) args
 162     MaybeT $ checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e)
 163   where
 164     con_ty = dataConRepType con
 165
 166 lintStgExpr e@(StgOpApp (StgFCallOp _ _) args res_ty) = runMaybeT $ do
 167         -- We don't have enough type information to check
 168         -- the application; ToDo
 169     maybe_arg_tys <- mapM (MaybeT . lintStgArg) args
 170     return res_ty
 171
 172 lintStgExpr e@(StgOpApp (StgPrimOp op) args _) = runMaybeT $ do
 173     arg_tys <- mapM (MaybeT . lintStgArg) args
 174     MaybeT $ checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e)
 175   where
 176     op_ty = primOpType op
 177
 178 lintStgExpr (StgLam _ bndrs _) = do
 179     addErrL (ptext SLIT("Unexpected StgLam") <+> ppr bndrs)
 180     return Nothing
 181
 182 lintStgExpr (StgLet binds body) = do
 183     binders <- lintStgBinds binds
 184     addLoc (BodyOfLetRec binders) $
 185       addInScopeVars binders $
 186         lintStgExpr body
 187
 188 lintStgExpr (StgLetNoEscape _ _ binds body) = do
 189     binders <- lintStgBinds binds
 190     addLoc (BodyOfLetRec binders) $
 191       addInScopeVars binders $
 192         lintStgExpr body
 193
 194 lintStgExpr (StgSCC _ expr)     = lintStgExpr expr
 195
 196 lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
 197     MaybeT $ lintStgExpr scrut
 198
 199     MaybeT $ liftM Just $
 200      case alts_type of
 201         AlgAlt tc    -> check_bndr tc
 202         PrimAlt tc   -> check_bndr tc
 203         UbxTupAlt tc -> check_bndr tc
 204         PolyAlt      -> return ()
 205
 206     MaybeT $ trace (showSDoc (ppr e)) $ do
 207         -- we only allow case of tail-call or primop.
 208      case scrut of
 209         StgApp _ _     -> return ()
 210         StgConApp _ _  -> return ()
 211         StgOpApp _ _ _ -> return ()
 212         other          -> addErrL (mkCaseOfCaseMsg e)
 213
 214      addInScopeVars [bndr] $
 215         lintStgAlts alts scrut_ty
 216   where
 217     scrut_ty      = idType bndr
 218     bad_bndr      = mkDefltMsg bndr
 219     check_bndr tc = case splitTyConApp_maybe scrut_ty of
 220                         Just (bndr_tc, _) -> checkL (tc == bndr_tc) bad_bndr
 221                         Nothing           -> addErrL bad_bndr
 222
 223
 224 lintStgAlts :: [StgAlt]
 225             -> Type             -- Type of scrutinee
 226             -> LintM (Maybe Type)       -- Type of alternatives
 227
 228 lintStgAlts alts scrut_ty = do
 229     maybe_result_tys <- mapM (lintAlt scrut_ty) alts
 230
 231          -- Check the result types
 232     case catMaybes (maybe_result_tys) of
 233       []             -> return Nothing
 234
 235       (first_ty:tys) -> do mapM_ check tys
 236                            return (Just first_ty)
 237         where
 238           check ty = checkTys first_ty ty (mkCaseAltMsg alts)
 239
 240 lintAlt scrut_ty (DEFAULT, _, _, rhs)
 241  = lintStgExpr rhs
 242
 243 lintAlt scrut_ty (LitAlt lit, _, _, rhs) = do
 244    checkTys (literalType lit) scrut_ty (mkAltMsg1 scrut_ty)
 245    lintStgExpr rhs
 246
 247 lintAlt scrut_ty (DataAlt con, args, _, rhs) = do
 248     case splitTyConApp_maybe scrut_ty of
 249       Just (tycon, tys_applied) | isAlgTyCon tycon &&
 250                                   not (isNewTyCon tycon) -> do
 251          let
 252            cons    = tyConDataCons tycon
 253            arg_tys = dataConInstArgTys con tys_applied
 254                 -- This almost certainly does not work for existential constructors
 255
 256          checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con)
 257          checkL (equalLength arg_tys args) (mkAlgAltMsg3 con args)
 258          mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args)
 259          return ()
 260       other ->
 261          addErrL (mkAltMsg1 scrut_ty)
 262
 263     addInScopeVars args $
 264          lintStgExpr rhs
 265   where
 266     check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
 267
 268     -- elem: yes, the elem-list here can sometimes be long-ish,
 269     -- but as it's use-once, probably not worth doing anything different
 270     -- We give it its own copy, so it isn't overloaded.
 271     elem _ []       = False
 272     elem x (y:ys)   = x==y || elem x ys
 273 \end{code}
 274
 275
 276 %************************************************************************
 277 %*                                                                      *
 278 \subsection[lint-monad]{The Lint monad}
 279 %*                                                                      *
 280 %************************************************************************
 281
 282 \begin{code}
 283 newtype LintM a = LintM
 284     { unLintM :: [LintLocInfo]      -- Locations
 285               -> IdSet              -- Local vars in scope
 286               -> Bag Message        -- Error messages so far
 287               -> (a, Bag Message)   -- Result and error messages (if any)
 288     }
 289
 290 data LintLocInfo
 291   = RhsOf Id            -- The variable bound
 292   | LambdaBodyOf [Id]   -- The lambda-binder
 293   | BodyOfLetRec [Id]   -- One of the binders
 294
 295 dumpLoc (RhsOf v) =
 296   (srcLocSpan (getSrcLoc v), ptext SLIT(" [RHS of ") <> pp_binders [v] <> char ']' )
 297 dumpLoc (LambdaBodyOf bs) =
 298   (srcLocSpan (getSrcLoc (head bs)), ptext SLIT(" [in body of lambda with binders ") <> pp_binders bs <> char ']' )
 299
 300 dumpLoc (BodyOfLetRec bs) =
 301   (srcLocSpan (getSrcLoc (head bs)), ptext SLIT(" [in body of letrec with binders ") <> pp_binders bs <> char ']' )
 302
 303
 304 pp_binders :: [Id] -> SDoc
 305 pp_binders bs
 306   = sep (punctuate comma (map pp_binder bs))
 307   where
 308     pp_binder b
 309       = hsep [ppr b, dcolon, ppr (idType b)]
 310 \end{code}
 311
 312 \begin{code}
 313 initL :: LintM a -> Maybe Message
 314 initL (LintM m)
 315   = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
 316     if isEmptyBag errs then
 317         Nothing
 318     else
 319         Just (vcat (punctuate (text "") (bagToList errs)))
 320     }
 321
 322 instance Monad LintM where
 323     return a = LintM $ \loc scope errs -> (a, errs)
 324     (>>=) = thenL
 325     (>>)  = thenL_
 326
 327 thenL :: LintM a -> (a -> LintM b) -> LintM b
 328 thenL m k = LintM $ \loc scope errs
 329   -> case unLintM m loc scope errs of
 330       (r, errs') -> unLintM (k r) loc scope errs'
 331
 332 thenL_ :: LintM a -> LintM b -> LintM b
 333 thenL_ m k = LintM $ \loc scope errs
 334   -> case unLintM m loc scope errs of
 335       (_, errs') -> unLintM k loc scope errs'
 336 \end{code}
 337
 338 \begin{code}
 339 checkL :: Bool -> Message -> LintM ()
 340 checkL True  msg = return ()
 341 checkL False msg = addErrL msg
 342
 343 addErrL :: Message -> LintM ()
 344 addErrL msg = LintM $ \loc scope errs -> ((), addErr errs msg loc)
 345
 346 addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
 347 addErr errs_so_far msg locs
 348   = errs_so_far `snocBag` mk_msg locs
 349   where
 350     mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
 351                      in  mkLocMessage l (hdr $$ msg)
 352     mk_msg []      = msg
 353
 354 addLoc :: LintLocInfo -> LintM a -> LintM a
 355 addLoc extra_loc m = LintM $ \loc scope errs
 356    -> unLintM m (extra_loc:loc) scope errs
 357
 358 addInScopeVars :: [Id] -> LintM a -> LintM a
 359 addInScopeVars ids m = LintM $ \loc scope errs
 360  -> -- We check if these "new" ids are already
 361     -- in scope, i.e., we have *shadowing* going on.
 362     -- For now, it's just a "trace"; we may make
 363     -- a real error out of it...
 364     let
 365         new_set = mkVarSet ids
 366     in
 367 --  After adding -fliberate-case, Simon decided he likes shadowed
 368 --  names after all.  WDP 94/07
 369 --  (if isEmptyVarSet shadowed
 370 --  then id
 371 --  else pprTrace "Shadowed vars:" (ppr (varSetElems shadowed))) $
 372     unLintM m loc (scope `unionVarSet` new_set) errs
 373 \end{code}
 374
 375 Checking function applications: we only check that the type has the
 376 right *number* of arrows, we don't actually compare the types.  This
 377 is because we can't expect the types to be equal - the type
 378 applications and type lambdas that we use to calculate accurate types
 379 have long since disappeared.
 380
 381 \begin{code}
 382 checkFunApp :: Type                 -- The function type
 383             -> [Type]               -- The arg type(s)
 384             -> Message              -- Error messgae
 385             -> LintM (Maybe Type)   -- The result type
 386
 387 checkFunApp fun_ty arg_tys msg = LintM checkFunApp'
 388  where
 389   checkFunApp' loc scope errs
 390    = cfa res_ty expected_arg_tys arg_tys
 391    where
 392     (expected_arg_tys, res_ty) = splitFunTys (dropForAlls fun_ty)
 393
 394     cfa res_ty expected []      -- Args have run out; that's fine
 395       = (Just (mkFunTys expected res_ty), errs)
 396
 397     cfa res_ty [] arg_tys       -- Expected arg tys ran out first;
 398                                 -- first see if res_ty is a tyvar template;
 399                                 -- otherwise, maybe res_ty is a
 400                                 -- dictionary type which is actually a function?
 401       | isTyVarTy res_ty
 402       = (Just res_ty, errs)
 403       | otherwise
 404       = case splitFunTys res_ty of
 405           ([], _)                 -> (Nothing, addErr errs msg loc)     -- Too many args
 406           (new_expected, new_res) -> cfa new_res new_expected arg_tys
 407
 408     cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys)
 409       = cfa res_ty expected_arg_tys arg_tys
 410 \end{code}
 411
 412 \begin{code}
 413 checkInScope :: Id -> LintM ()
 414 checkInScope id = LintM $ \loc scope errs
 415  -> if isLocalId id && not (id `elemVarSet` scope) then
 416         ((), addErr errs (hsep [ppr id, ptext SLIT("is out of scope")]) loc)
 417     else
 418         ((), errs)
 419
 420 checkTys :: Type -> Type -> Message -> LintM ()
 421 checkTys ty1 ty2 msg = LintM $ \loc scope errs
 422  -> -- if (ty1 == ty2) then
 423     ((), errs)
 424     -- else ((), addErr errs msg loc)
 425 \end{code}
 426
 427 \begin{code}
 428 mkCaseAltMsg :: [StgAlt] -> Message
 429 mkCaseAltMsg alts
 430   = ($$) (text "In some case alternatives, type of alternatives not all same:")
 431             (empty) -- LATER: ppr alts
 432
 433 mkDefltMsg :: Id -> Message
 434 mkDefltMsg bndr
 435   = ($$) (ptext SLIT("Binder of a case expression doesn't match type of scrutinee:"))
 436             (panic "mkDefltMsg")
 437
 438 mkFunAppMsg :: Type -> [Type] -> StgExpr -> Message
 439 mkFunAppMsg fun_ty arg_tys expr
 440   = vcat [text "In a function application, function type doesn't match arg types:",
 441               hang (ptext SLIT("Function type:")) 4 (ppr fun_ty),
 442               hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys)),
 443               hang (ptext SLIT("Expression:")) 4 (ppr expr)]
 444
 445 mkRhsConMsg :: Type -> [Type] -> Message
 446 mkRhsConMsg fun_ty arg_tys
 447   = vcat [text "In a RHS constructor application, con type doesn't match arg types:",
 448               hang (ptext SLIT("Constructor type:")) 4 (ppr fun_ty),
 449               hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys))]
 450
 451 mkAltMsg1 :: Type -> Message
 452 mkAltMsg1 ty
 453   = ($$) (text "In a case expression, type of scrutinee does not match patterns")
 454          (ppr ty)
 455
 456 mkAlgAltMsg2 :: Type -> DataCon -> Message
 457 mkAlgAltMsg2 ty con
 458   = vcat [
 459         text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
 460         ppr ty,
 461         ppr con
 462     ]
 463
 464 mkAlgAltMsg3 :: DataCon -> [Id] -> Message
 465 mkAlgAltMsg3 con alts
 466   = vcat [
 467         text "In some algebraic case alternative, number of arguments doesn't match constructor:",
 468         ppr con,
 469         ppr alts
 470     ]
 471
 472 mkAlgAltMsg4 :: Type -> Id -> Message
 473 mkAlgAltMsg4 ty arg
 474   = vcat [
 475         text "In some algebraic case alternative, type of argument doesn't match data constructor:",
 476         ppr ty,
 477         ppr arg
 478     ]
 479
 480 mkCaseOfCaseMsg :: StgExpr -> Message
 481 mkCaseOfCaseMsg e
 482   = text "Case of non-tail-call:" $$ ppr e
 483
 484 mkRhsMsg :: Id -> Type -> Message
 485 mkRhsMsg binder ty
 486   = vcat [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
 487                      ppr binder],
 488               hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
 489               hsep [ptext SLIT("Rhs type:"), ppr ty]
 490              ]
 491
 492 mkUnLiftedTyMsg binder rhs
 493   = (ptext SLIT("Let(rec) binder") <+> quotes (ppr binder) <+>
 494      ptext SLIT("has unlifted type") <+> quotes (ppr (idType binder)))
 495     $$
 496     (ptext SLIT("RHS:") <+> ppr rhs)
 497 \end{code}