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 (
  10         lintStgBindings,
  11
  12         PprStyle, StgBinding, PlainStgBinding(..), Id
  13     ) where
  14
  15 IMPORT_Trace
  16
  17 import AbsPrel          ( typeOfPrimOp, mkFunTy, PrimOp(..), PrimKind
  18                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  19                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  20                         )
  21 import AbsUniType
  22 import Bag
  23 import BasicLit         ( typeOfBasicLit, BasicLit )
  24 import Id               ( getIdUniType, isNullaryDataCon, isDataCon,
  25                           isBottomingId,
  26                           getInstantiatedDataConSig, Id
  27                           IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
  28                         )
  29 import Maybes
  30 import Outputable
  31 import Pretty
  32 import SrcLoc           ( SrcLoc )
  33 import StgSyn
  34 import UniqSet
  35 import Util
  36
  37 infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
  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 :: PprStyle -> String -> [PlainStgBinding] -> [PlainStgBinding]
  54
  55 lintStgBindings sty whodunnit binds
  56   = BSCC("StgLint")
  57     case (initL (lint_binds binds)) of
  58       Nothing  -> binds
  59       Just msg -> pprPanic "" (ppAboves [
  60                         ppStr ("*** Stg Lint Errors: in "++whodunnit++" ***"),
  61                         msg sty,
  62                         ppStr "*** Offending Program ***",
  63                         ppAboves (map (pprPlainStgBinding sty) binds),
  64                         ppStr "*** End of Offense ***"])
  65     ESCC
  66   where
  67     lint_binds :: [PlainStgBinding] -> 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 lintStgAtom :: PlainStgAtom -> LintM (Maybe UniType)
  80
  81 lintStgAtom (StgLitAtom lit)       = returnL (Just (typeOfBasicLit lit))
  82 lintStgAtom a@(StgVarAtom v)
  83   = checkInScope v      `thenL_`
  84     returnL (Just (getIdUniType v))
  85 \end{code}
  86
  87 \begin{code}
  88 lintStgBinds :: PlainStgBinding -> 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 (getIdUniType binder)
 110                                    rhs_ty
 111                                    (mkRhsMsg binder rhs_ty)
 112         )                       `thenL_`
 113
 114         returnL ()
 115     )
 116 \end{code}
 117
 118 \begin{code}
 119 lintStgRhs :: PlainStgRhs -> LintM (Maybe UniType)
 120
 121 lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
 122   = addLoc (LambdaBodyOf binders) (
 123     addInScopeVars binders (
 124         lintStgExpr expr   `thenMaybeL` \ body_ty ->
 125         returnL (Just (foldr (mkFunTy . getIdUniType) body_ty binders))
 126     ))
 127
 128 lintStgRhs (StgRhsCon _ con args)
 129   = mapMaybeL lintStgAtom 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 = getIdUniType con
 135 \end{code}
 136
 137 \begin{code}
 138 lintStgExpr :: PlainStgExpr -> LintM (Maybe UniType)    -- Nothing if error found
 139
 140 lintStgExpr e@(StgApp fun args _)
 141   = lintStgAtom fun             `thenMaybeL` \ fun_ty  ->
 142     mapMaybeL lintStgAtom 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@(StgConApp con args _)
 148   = mapMaybeL lintStgAtom 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 = getIdUniType con
 154
 155 lintStgExpr e@(StgPrimApp op args _)
 156   = mapMaybeL lintStgAtom 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 = typeOfPrimOp 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 getUniDataTyCon_maybe scrut_ty of
 184       Nothing -> addErrL (mkCaseDataConMsg e)   `thenL_`
 185                  returnL Nothing
 186       Just (tycon, _, _)
 187               -> lintStgAlts alts scrut_ty tycon
 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 :: PlainStgCaseAlternatives
 197              -> UniType                 -- Type of scrutinee
 198              -> TyCon                   -- TyCon pinned on the case
 199              -> LintM (Maybe UniType)   -- Type of alternatives
 200
 201 lintStgAlts alts scrut_ty case_tycon
 202   = (case alts of
 203          StgAlgAlts _ alg_alts deflt ->
 204            chk_non_abstract_type case_tycon     `thenL_`
 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   where
 223     chk_non_abstract_type tycon
 224       = case (getTyConFamilySize tycon) of
 225           Nothing -> addErrL (mkCaseAbstractMsg tycon)
 226           Just  _ -> returnL () -- that's cool
 227
 228 lintAlgAlt scrut_ty (con, args, _, rhs)
 229   = (case getUniDataTyCon_maybe scrut_ty of
 230       Nothing ->
 231          addErrL (mkAlgAltMsg1 scrut_ty)
 232       Just (tycon, tys_applied, cons) ->
 233          let
 234            (_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
 235          in
 236          checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
 237          checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
 238                                                                  `thenL_`
 239          mapL check (arg_tys `zipEqual` args)                    `thenL_`
 240          returnL ()
 241     )                                                            `thenL_`
 242     addInScopeVars args         (
 243          lintStgExpr rhs
 244     )
 245   where
 246     check (ty, arg) = checkTys ty (getIdUniType arg) (mkAlgAltMsg4 ty arg)
 247
 248     -- elem: yes, the elem-list here can sometimes be long-ish,
 249     -- but as it's use-once, probably not worth doing anything different
 250     -- We give it its own copy, so it isn't overloaded.
 251     elem _ []       = False
 252     elem x (y:ys)   = x==y || elem x ys
 253
 254 lintPrimAlt scrut_ty alt@(lit,rhs)
 255  = checkTys (typeOfBasicLit lit) scrut_ty (mkPrimAltMsg alt)    `thenL_`
 256    lintStgExpr rhs
 257
 258 lintDeflt StgNoDefault scrut_ty = returnL Nothing
 259 lintDeflt deflt@(StgBindDefault binder _ rhs) scrut_ty
 260   = checkTys (getIdUniType binder) scrut_ty (mkDefltMsg deflt)  `thenL_`
 261     addInScopeVars [binder] (
 262         lintStgExpr rhs
 263     )
 264 \end{code}
 265
 266
 267 %************************************************************************
 268 %*                                                                      *
 269 \subsection[lint-monad]{The Lint monad}
 270 %*                                                                      *
 271 %************************************************************************
 272
 273 \begin{code}
 274 type LintM a = [LintLocInfo]    -- Locations
 275             -> UniqSet Id       -- Local vars in scope
 276             -> Bag ErrMsg       -- Error messages so far
 277             -> (a, Bag ErrMsg)  -- Result and error messages (if any)
 278
 279 type ErrMsg = PprStyle -> Pretty
 280
 281 data LintLocInfo
 282   = RhsOf Id            -- The variable bound
 283   | LambdaBodyOf [Id]   -- The lambda-binder
 284   | BodyOfLetRec [Id]   -- One of the binders
 285
 286 instance Outputable LintLocInfo where
 287     ppr sty (RhsOf v)
 288       = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
 289
 290     ppr sty (LambdaBodyOf bs)
 291       = ppBesides [ppr sty (getSrcLoc (head bs)),
 292                 ppStr ": [in body of lambda with binders ", pp_binders sty bs, ppStr "]"]
 293
 294     ppr sty (BodyOfLetRec bs)
 295       = ppBesides [ppr sty (getSrcLoc (head bs)),
 296                 ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"]
 297
 298 pp_binders :: PprStyle -> [Id] -> Pretty
 299 pp_binders sty bs
 300   = ppInterleave ppComma (map pp_binder bs)
 301   where
 302     pp_binder b
 303       = ppCat [ppr sty b, ppStr "::", ppr sty (getIdUniType b)]
 304 \end{code}
 305
 306 \begin{code}
 307 initL :: LintM a -> Maybe ErrMsg
 308 initL m
 309   = case (m [] emptyUniqSet emptyBag) of { (_, errs) ->
 310     if isEmptyBag errs then
 311         Nothing
 312     else
 313         Just ( \ sty ->
 314           ppAboves [ msg sty | msg <- bagToList errs ]
 315         )
 316     }
 317
 318 returnL :: a -> LintM a
 319 returnL r loc scope errs = (r, errs)
 320
 321 thenL :: LintM a -> (a -> LintM b) -> LintM b
 322 thenL m k loc scope errs
 323   = case m loc scope errs of
 324       (r, errs') -> k r loc scope errs'
 325
 326 thenL_ :: LintM a -> LintM b -> LintM b
 327 thenL_ m k loc scope errs
 328   = case m loc scope errs of
 329       (_, errs') -> k loc scope errs'
 330
 331 thenMaybeL :: LintM (Maybe a) -> (a -> LintM (Maybe b)) -> LintM (Maybe b)
 332 thenMaybeL m k loc scope errs
 333   = case m loc scope errs of
 334       (Nothing, errs2) -> (Nothing, errs2)
 335       (Just r,  errs2) -> k r loc scope errs2
 336
 337 thenMaybeL_ :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
 338 thenMaybeL_ m k loc scope errs
 339   = case m loc scope errs of
 340       (Nothing, errs2) -> (Nothing, errs2)
 341       (Just _,  errs2) -> k loc scope errs2
 342
 343 mapL :: (a -> LintM b) -> [a] -> LintM [b]
 344 mapL f [] = returnL []
 345 mapL f (x:xs)
 346   = f x         `thenL` \ r ->
 347     mapL f xs   `thenL` \ rs ->
 348     returnL (r:rs)
 349
 350 mapMaybeL :: (a -> LintM (Maybe b)) -> [a] -> LintM (Maybe [b])
 351         -- Returns Nothing if anything fails
 352 mapMaybeL f [] = returnL (Just [])
 353 mapMaybeL f (x:xs)
 354   = f x             `thenMaybeL` \ r ->
 355     mapMaybeL f xs  `thenMaybeL` \ rs ->
 356     returnL (Just (r:rs))
 357 \end{code}
 358
 359 \begin{code}
 360 checkL :: Bool -> ErrMsg -> LintM ()
 361 checkL True  msg loc scope errs = ((), errs)
 362 checkL False msg loc scope errs = ((), addErr errs msg loc)
 363
 364 addErrL :: ErrMsg -> LintM ()
 365 addErrL msg loc scope errs = ((), addErr errs msg loc)
 366
 367 addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
 368
 369 addErr errs_so_far msg locs
 370   = errs_so_far `snocBag` ( \ sty ->
 371     ppHang (ppr sty (head locs)) 4 (msg sty)
 372     )
 373
 374 addLoc :: LintLocInfo -> LintM a -> LintM a
 375 addLoc extra_loc m loc scope errs
 376   = m (extra_loc:loc) scope errs
 377
 378 addInScopeVars :: [Id] -> LintM a -> LintM a
 379 addInScopeVars ids m loc scope errs
 380   = -- We check if these "new" ids are already
 381     -- in scope, i.e., we have *shadowing* going on.
 382     -- For now, it's just a "trace"; we may make
 383     -- a real error out of it...
 384     let
 385         new_set = mkUniqSet ids
 386
 387         shadowed = scope `intersectUniqSets` new_set
 388     in
 389 --  After adding -fliberate-case, Simon decided he likes shadowed
 390 --  names after all.  WDP 94/07
 391 --  (if isEmptyUniqSet shadowed
 392 --  then id
 393 --  else pprTrace "Shadowed vars:" (ppr PprDebug (uniqSetToList shadowed))) (
 394     m loc (scope `unionUniqSets` new_set) errs
 395 --  )
 396 \end{code}
 397
 398 \begin{code}
 399 checkFunApp :: UniType          -- The function type
 400             -> [UniType]        -- The arg type(s)
 401             -> ErrMsg           -- Error messgae
 402             -> LintM (Maybe UniType)    -- The result type
 403
 404 checkFunApp fun_ty arg_tys msg loc scope errs
 405   = cfa res_ty expected_arg_tys arg_tys
 406   where
 407     (_, expected_arg_tys, res_ty) = splitTypeWithDictsAsArgs fun_ty
 408
 409     cfa res_ty expected []      -- Args have run out; that's fine
 410       = (Just (glueTyArgs expected res_ty), errs)
 411
 412     cfa res_ty [] arg_tys       -- Expected arg tys ran out first;
 413                                 -- first see if res_ty is a tyvar template;
 414                                 -- otherwise, maybe res_ty is a
 415                                 -- dictionary type which is actually a function?
 416       | isTyVarTemplateTy res_ty
 417       = (Just res_ty, errs)
 418       | otherwise
 419       = case splitTyArgs (unDictifyTy res_ty) of
 420           ([], _)                 -> (Nothing, addErr errs msg loc)     -- Too many args
 421           (new_expected, new_res) -> cfa new_res new_expected arg_tys
 422
 423     cfa res_ty (expected_arg_ty:expected_arg_tys) (arg_ty:arg_tys)
 424       = case (sleazy_cmp_ty expected_arg_ty arg_ty) of
 425           EQ_ -> cfa res_ty expected_arg_tys arg_tys
 426           _   -> (Nothing, addErr errs msg loc) -- Arg mis-match
 427 \end{code}
 428
 429 \begin{code}
 430 checkInScope :: Id -> LintM ()
 431 checkInScope id loc scope errs
 432   = if isLocallyDefined id && not (isDataCon id) && not (id `elementOfUniqSet` scope) then
 433         ((), addErr errs (\ sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc)
 434     else
 435         ((), errs)
 436
 437 checkTys :: UniType -> UniType -> ErrMsg -> LintM ()
 438 checkTys ty1 ty2 msg loc scope errs
 439   = case (sleazy_cmp_ty ty1 ty2) of
 440       EQ_   -> ((), errs)
 441       other -> ((), addErr errs msg loc)
 442 \end{code}
 443
 444 \begin{code}
 445 mkCaseAltMsg :: PlainStgCaseAlternatives -> ErrMsg
 446 mkCaseAltMsg alts sty
 447   = ppAbove (ppStr "In some case alternatives, type of alternatives not all same:")
 448             -- LATER: (ppr sty alts)
 449             (panic "mkCaseAltMsg")
 450
 451 mkCaseDataConMsg :: PlainStgExpr -> ErrMsg
 452 mkCaseDataConMsg expr sty
 453   = ppAbove (ppStr "A case scrutinee not a type-constructor type:")
 454             (pp_expr sty expr)
 455
 456 mkCaseAbstractMsg :: TyCon -> ErrMsg
 457 mkCaseAbstractMsg tycon sty
 458   = ppAbove (ppStr "An algebraic case on an abstract type:")
 459             (ppr sty tycon)
 460
 461 mkDefltMsg :: PlainStgCaseDefault -> ErrMsg
 462 mkDefltMsg deflt sty
 463   = ppAbove (ppStr "Binder in default case of a case expression doesn't match type of scrutinee:")
 464             --LATER: (ppr sty deflt)
 465             (panic "mkDefltMsg")
 466
 467 mkFunAppMsg :: UniType -> [UniType] -> PlainStgExpr -> ErrMsg
 468 mkFunAppMsg fun_ty arg_tys expr sty
 469   = ppAboves [ppStr "In a function application, function type doesn't match arg types:",
 470               ppHang (ppStr "Function type:") 4 (ppr sty fun_ty),
 471               ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys)),
 472               ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
 473
 474 mkRhsConMsg :: UniType -> [UniType] -> ErrMsg
 475 mkRhsConMsg fun_ty arg_tys sty
 476   = ppAboves [ppStr "In a RHS constructor application, con type doesn't match arg types:",
 477               ppHang (ppStr "Constructor type:") 4 (ppr sty fun_ty),
 478               ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys))]
 479
 480 mkUnappTyMsg :: Id -> UniType -> ErrMsg
 481 mkUnappTyMsg var ty sty
 482   = ppAboves [ppStr "Variable has a for-all type, but isn't applied to any types.",
 483               ppBeside (ppStr "Var:      ") (ppr sty var),
 484               ppBeside (ppStr "Its type: ") (ppr sty ty)]
 485
 486 mkAlgAltMsg1 :: UniType -> ErrMsg
 487 mkAlgAltMsg1 ty sty
 488   = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
 489             (ppr sty ty)
 490
 491 mkAlgAltMsg2 :: UniType -> Id -> ErrMsg
 492 mkAlgAltMsg2 ty con sty
 493   = ppAboves [
 494         ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
 495         ppr sty ty,
 496         ppr sty con
 497     ]
 498
 499 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
 500 mkAlgAltMsg3 con alts sty
 501   = ppAboves [
 502         ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:",
 503         ppr sty con,
 504         ppr sty alts
 505     ]
 506
 507 mkAlgAltMsg4 :: UniType -> Id -> ErrMsg
 508 mkAlgAltMsg4 ty arg sty
 509   = ppAboves [
 510         ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
 511         ppr sty ty,
 512         ppr sty arg
 513     ]
 514
 515 mkPrimAltMsg :: (BasicLit, PlainStgExpr) -> ErrMsg
 516 mkPrimAltMsg alt sty
 517   = ppAbove (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
 518             (ppr sty alt)
 519
 520 mkRhsMsg :: Id -> UniType -> ErrMsg
 521 mkRhsMsg binder ty sty
 522   = ppAboves [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
 523                      ppr sty binder],
 524               ppCat [ppStr "Binder's type:", ppr sty (getIdUniType binder)],
 525               ppCat [ppStr "Rhs type:", ppr sty ty]
 526              ]
 527
 528 pp_expr :: PprStyle -> PlainStgExpr -> Pretty
 529 pp_expr sty expr = ppr sty expr
 530
 531 sleazy_cmp_ty ty1 ty2
 532         -- NB: probably severe overkill (WDP 95/04)
 533   = case (splitTypeWithDictsAsArgs ty1) of { (_,tyargs1,tyres1) ->
 534     case (splitTypeWithDictsAsArgs ty2) of { (_,tyargs2,tyres2) ->
 535     let
 536         ty11 = glueTyArgs tyargs1 tyres1
 537         ty22 = glueTyArgs tyargs2 tyres2
 538     in
 539     cmpUniType False{-!!!NOT PROPERLY!!!-} ty11 ty22
 540     }}
 541 \end{code}