a0fdf78d34109f753f1fc561cd24273935d52861
[ghc.git] / 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 {-# LANGUAGE CPP #-}
8
9 module StgLint ( lintStgBindings ) where
10
11 import StgSyn
12
13 import Bag              ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
14 import Id               ( Id, idType, isLocalId )
15 import VarSet
16 import DataCon
17 import CoreSyn          ( AltCon(..) )
18 import PrimOp           ( primOpType )
19 import Literal          ( literalType )
20 import Maybes
21 import Name             ( getSrcLoc )
22 import ErrUtils         ( MsgDoc, Severity(..), mkLocMessage )
23 import TypeRep
24 import Type
25 import TyCon
26 import Util 
27 import SrcLoc
28 import Outputable
29 import FastString
30 #if __GLASGOW_HASKELL__ < 709
31 import Control.Applicative ( Applicative(..) )
32 #endif
33 import Control.Monad
34 import Data.Function
35
36 #include "HsVersions.h"
37 \end{code}
38
39 Checks for
40         (a) *some* type errors
41         (b) locally-defined variables used but not defined
42
43
44 Note: unless -dverbose-stg is on, display of lint errors will result
45 in "panic: bOGUS_LVs".
46
47 WARNING:
48 ~~~~~~~~
49
50 This module has suffered bit-rot; it is likely to yield lint errors
51 for Stg code that is currently perfectly acceptable for code
52 generation.  Solution: don't use it!  (KSW 2000-05).
53
54
55 %************************************************************************
56 %*                                                                      *
57 \subsection{``lint'' for various constructs}
58 %*                                                                      *
59 %************************************************************************
60
61 @lintStgBindings@ is the top-level interface function.
62
63 \begin{code}
64 lintStgBindings :: String -> [StgBinding] -> [StgBinding]
65
66 lintStgBindings whodunnit binds
67   = {-# SCC "StgLint" #-}
68     case (initL (lint_binds binds)) of
69       Nothing  -> binds
70       Just msg -> pprPanic "" (vcat [
71                         ptext (sLit "*** Stg Lint ErrMsgs: in") <+>
72                               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 :: Id -> LintM (Maybe Kind)
94 lintStgVar v = do checkInScope v
95                   return (Just (idType v))
96 \end{code}
97
98 \begin{code}
99 lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders
100 lintStgBinds (StgNonRec binder rhs) = do
101     lint_binds_help (binder,rhs)
102     return [binder]
103
104 lintStgBinds (StgRec pairs)
105   = addInScopeVars binders $ do
106         mapM_ lint_binds_help pairs
107         return binders
108   where
109     binders = [b | (b,_) <- pairs]
110
111 lint_binds_help :: (Id, StgRhs) -> LintM ()
112 lint_binds_help (binder, rhs)
113   = addLoc (RhsOf binder) $ do
114         -- Check the rhs
115         _maybe_rhs_ty <- lintStgRhs rhs
116
117         -- Check binder doesn't have unlifted type
118         checkL (not (isUnLiftedType binder_ty))
119                (mkUnLiftedTyMsg binder rhs)
120
121         -- Check match to RHS type
122         -- Actually we *can't* check the RHS type, because
123         -- unsafeCoerce means it really might not match at all
124         -- notably;  eg x::Int = (error @Bool "urk") |> unsafeCoerce...
125         -- case maybe_rhs_ty of
126         --  Nothing     -> return ()
127         --    Just rhs_ty -> checkTys binder_ty
128         --                          rhs_ty
129         ---                         (mkRhsMsg binder rhs_ty)
130
131         return ()
132   where
133     binder_ty = idType binder
134 \end{code}
135
136 \begin{code}
137 lintStgRhs :: StgRhs -> LintM (Maybe Type)   -- Just ty => type is exact
138
139 lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr)
140   = lintStgExpr expr
141
142 lintStgRhs (StgRhsClosure _ _ _ _ _ binders expr)
143   = addLoc (LambdaBodyOf binders) $
144       addInScopeVars binders $ runMaybeT $ do
145         body_ty <- MaybeT $ lintStgExpr expr
146         return (mkFunTys (map idType binders) body_ty)
147
148 lintStgRhs (StgRhsCon _ con args) = runMaybeT $ do
149     arg_tys <- mapM (MaybeT . lintStgArg) args
150     MaybeT $ checkFunApp con_ty arg_tys (mkRhsConMsg con_ty arg_tys)
151   where
152     con_ty = dataConRepType con
153 \end{code}
154
155 \begin{code}
156 lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Just ty => type is exact
157
158 lintStgExpr (StgLit l) = return (Just (literalType l))
159
160 lintStgExpr e@(StgApp fun args) = runMaybeT $ do
161     fun_ty <- MaybeT $ lintStgVar fun
162     arg_tys <- mapM (MaybeT . lintStgArg) args
163     MaybeT $ checkFunApp fun_ty arg_tys (mkFunAppMsg fun_ty arg_tys e)
164
165 lintStgExpr e@(StgConApp con args) = runMaybeT $ do
166     arg_tys <- mapM (MaybeT . lintStgArg) args
167     MaybeT $ checkFunApp con_ty arg_tys (mkFunAppMsg con_ty arg_tys e)
168   where
169     con_ty = dataConRepType con
170
171 lintStgExpr e@(StgOpApp (StgPrimOp op) args _) = runMaybeT $ do
172     arg_tys <- mapM (MaybeT . lintStgArg) args
173     MaybeT $ checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e)
174   where
175     op_ty = primOpType op
176
177 lintStgExpr (StgOpApp _ args res_ty) = runMaybeT $ do
178         -- We don't have enough type information to check
179         -- the application for StgFCallOp and StgPrimCallOp; ToDo
180     _maybe_arg_tys <- mapM (MaybeT . lintStgArg) args
181     return res_ty
182
183 lintStgExpr (StgLam bndrs _) = do
184     addErrL (ptext (sLit "Unexpected StgLam") <+> ppr bndrs)
185     return Nothing
186
187 lintStgExpr (StgLet binds body) = do
188     binders <- lintStgBinds binds
189     addLoc (BodyOfLetRec binders) $
190       addInScopeVars binders $
191         lintStgExpr body
192
193 lintStgExpr (StgLetNoEscape _ _ binds body) = do
194     binders <- lintStgBinds binds
195     addLoc (BodyOfLetRec binders) $
196       addInScopeVars binders $
197         lintStgExpr body
198
199 lintStgExpr (StgSCC _ _ _ expr) = lintStgExpr expr
200
201 lintStgExpr (StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
202     _ <- MaybeT $ lintStgExpr scrut
203
204     in_scope <- MaybeT $ liftM Just $
205      case alts_type of
206         AlgAlt tc    -> check_bndr tc >> return True
207         PrimAlt tc   -> check_bndr tc >> return True
208         UbxTupAlt _  -> return False -- Binder is always dead in this case
209         PolyAlt      -> return True
210
211     MaybeT $ addInScopeVars [bndr | in_scope] $
212              lintStgAlts alts scrut_ty
213   where
214     scrut_ty          = idType bndr
215     UnaryRep scrut_rep = repType scrut_ty -- Not used if scrutinee is unboxed tuple
216     check_bndr tc = case tyConAppTyCon_maybe scrut_rep of
217                         Just bndr_tc -> checkL (tc == bndr_tc) bad_bndr
218                         Nothing      -> addErrL bad_bndr
219                   where
220                      bad_bndr = mkDefltMsg bndr tc
221
222 lintStgExpr e = pprPanic "lintStgExpr" (ppr e)
223
224 lintStgAlts :: [StgAlt]
225             -> Type               -- Type of scrutinee
226             -> LintM (Maybe Type) -- Just ty => type is accurage
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           -- We can't check that the alternatives have the
240           -- same type, because they don't, with unsafeCoerce#
241
242 lintAlt :: Type -> (AltCon, [Id], [Bool], StgExpr) -> LintM (Maybe Type)
243 lintAlt _ (DEFAULT, _, _, rhs)
244  = lintStgExpr rhs
245
246 lintAlt scrut_ty (LitAlt lit, _, _, rhs) = do
247    checkTys (literalType lit) scrut_ty (mkAltMsg1 scrut_ty)
248    lintStgExpr rhs
249
250 lintAlt scrut_ty (DataAlt con, args, _, rhs) = do
251     case splitTyConApp_maybe scrut_ty of
252       Just (tycon, tys_applied) | isAlgTyCon tycon &&
253                                   not (isNewTyCon tycon) -> do
254          let
255            cons    = tyConDataCons tycon
256            arg_tys = dataConInstArgTys con tys_applied
257                 -- This does not work for existential constructors
258
259          checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con)
260          checkL (length args == dataConRepArity con) (mkAlgAltMsg3 con args)
261          when (isVanillaDataCon con) $
262            mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args)
263          return ()
264       _ ->
265          addErrL (mkAltMsg1 scrut_ty)
266
267     addInScopeVars args $
268          lintStgExpr rhs
269   where
270     check (ty, arg) = checkTys ty (idType arg) (mkAlgAltMsg4 ty arg)
271
272     -- elem: yes, the elem-list here can sometimes be long-ish,
273     -- but as it's use-once, probably not worth doing anything different
274     -- We give it its own copy, so it isn't overloaded.
275     elem _ []       = False
276     elem x (y:ys)   = x==y || elem x ys
277 \end{code}
278
279
280 %************************************************************************
281 %*                                                                      *
282 \subsection[lint-monad]{The Lint monad}
283 %*                                                                      *
284 %************************************************************************
285
286 \begin{code}
287 newtype LintM a = LintM
288     { unLintM :: [LintLocInfo]      -- Locations
289               -> IdSet              -- Local vars in scope
290               -> Bag MsgDoc        -- Error messages so far
291               -> (a, Bag MsgDoc)   -- Result and error messages (if any)
292     }
293
294 data LintLocInfo
295   = RhsOf Id            -- The variable bound
296   | LambdaBodyOf [Id]   -- The lambda-binder
297   | BodyOfLetRec [Id]   -- One of the binders
298
299 dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
300 dumpLoc (RhsOf v) =
301   (srcLocSpan (getSrcLoc v), ptext (sLit " [RHS of ") <> pp_binders [v] <> char ']' )
302 dumpLoc (LambdaBodyOf bs) =
303   (srcLocSpan (getSrcLoc (head bs)), ptext (sLit " [in body of lambda with binders ") <> pp_binders bs <> char ']' )
304
305 dumpLoc (BodyOfLetRec bs) =
306   (srcLocSpan (getSrcLoc (head bs)), ptext (sLit " [in body of letrec with binders ") <> pp_binders bs <> char ']' )
307
308
309 pp_binders :: [Id] -> SDoc
310 pp_binders bs
311   = sep (punctuate comma (map pp_binder bs))
312   where
313     pp_binder b
314       = hsep [ppr b, dcolon, ppr (idType b)]
315 \end{code}
316
317 \begin{code}
318 initL :: LintM a -> Maybe MsgDoc
319 initL (LintM m)
320   = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
321     if isEmptyBag errs then
322         Nothing
323     else
324         Just (vcat (punctuate blankLine (bagToList errs)))
325     }
326
327 instance Functor LintM where
328       fmap = liftM
329
330 instance Applicative LintM where
331       pure = return
332       (<*>) = ap
333
334 instance Monad LintM where
335     return a = LintM $ \_loc _scope errs -> (a, errs)
336     (>>=) = thenL
337     (>>)  = thenL_
338
339 thenL :: LintM a -> (a -> LintM b) -> LintM b
340 thenL m k = LintM $ \loc scope errs
341   -> case unLintM m loc scope errs of
342       (r, errs') -> unLintM (k r) loc scope errs'
343
344 thenL_ :: LintM a -> LintM b -> LintM b
345 thenL_ m k = LintM $ \loc scope errs
346   -> case unLintM m loc scope errs of
347       (_, errs') -> unLintM k loc scope errs'
348 \end{code}
349
350 \begin{code}
351 checkL :: Bool -> MsgDoc -> LintM ()
352 checkL True  _   = return ()
353 checkL False msg = addErrL msg
354
355 addErrL :: MsgDoc -> LintM ()
356 addErrL msg = LintM $ \loc _scope errs -> ((), addErr errs msg loc)
357
358 addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
359 addErr errs_so_far msg locs
360   = errs_so_far `snocBag` mk_msg locs
361   where
362     mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
363                      in  mkLocMessage SevWarning l (hdr $$ msg)
364     mk_msg []      = msg
365
366 addLoc :: LintLocInfo -> LintM a -> LintM a
367 addLoc extra_loc m = LintM $ \loc scope errs
368    -> unLintM m (extra_loc:loc) scope errs
369
370 addInScopeVars :: [Id] -> LintM a -> LintM a
371 addInScopeVars ids m = LintM $ \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 = mkVarSet ids
378     in
379 --  After adding -fliberate-case, Simon decided he likes shadowed
380 --  names after all.  WDP 94/07
381 --  (if isEmptyVarSet shadowed
382 --  then id
383 --  else pprTrace "Shadowed vars:" (ppr (varSetElems shadowed))) $
384     unLintM m loc (scope `unionVarSet` new_set) errs
385 \end{code}
386
387 Checking function applications: we only check that the type has the
388 right *number* of arrows, we don't actually compare the types.  This
389 is because we can't expect the types to be equal - the type
390 applications and type lambdas that we use to calculate accurate types
391 have long since disappeared.
392
393 \begin{code}
394 checkFunApp :: Type                 -- The function type
395             -> [Type]               -- The arg type(s)
396             -> MsgDoc              -- Error message
397             -> LintM (Maybe Type)   -- Just ty => result type is accurate
398
399 checkFunApp fun_ty arg_tys msg
400  = do { case mb_msg of
401           Just msg -> addErrL msg
402           Nothing  -> return ()
403       ; return mb_ty }
404  where
405   (mb_ty, mb_msg) = cfa True fun_ty arg_tys
406
407   cfa :: Bool -> Type -> [Type] -> (Maybe Type          -- Accurate result?
408                                    , Maybe MsgDoc)      -- Errors?
409
410   cfa accurate fun_ty []      -- Args have run out; that's fine
411       = (if accurate then Just fun_ty else Nothing, Nothing)
412
413   cfa accurate fun_ty arg_tys@(arg_ty':arg_tys')   
414       | Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
415       = if accurate && not (arg_ty `stgEqType` arg_ty') 
416         then (Nothing, Just msg)       -- Arg type mismatch
417         else cfa accurate res_ty arg_tys'
418
419       | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty
420       = cfa False fun_ty' arg_tys
421
422       | Just (tc,tc_args) <- splitTyConApp_maybe fun_ty
423       , isNewTyCon tc
424       = if length tc_args < tyConArity tc 
425         then WARN( True, text "cfa: unsaturated newtype" <+> ppr fun_ty $$ msg )
426              (Nothing, Nothing)   -- This is odd, but I've seen it
427         else cfa False (newTyConInstRhs tc tc_args) arg_tys
428
429       | Just tc <- tyConAppTyCon_maybe fun_ty
430       , not (isTypeFamilyTyCon tc)      -- Definite error
431       = (Nothing, Just msg)             -- Too many args
432
433       | otherwise
434       = (Nothing, Nothing)
435 \end{code}
436
437 \begin{code}
438 stgEqType :: Type -> Type -> Bool
439 -- Compare types, but crudely because we have discarded
440 -- both casts and type applications, so types might look
441 -- different but be the same.  So reply "True" if in doubt.
442 -- "False" means that the types are definitely different.
443 --
444 -- Fundamentally this is a losing battle because of unsafeCoerce
445
446 stgEqType orig_ty1 orig_ty2 
447   = gos (repType orig_ty1) (repType orig_ty2)
448   where
449     gos :: RepType -> RepType -> Bool
450     gos (UbxTupleRep tys1) (UbxTupleRep tys2)
451       = equalLength tys1 tys2 && and (zipWith go tys1 tys2)
452     gos (UnaryRep ty1) (UnaryRep ty2) = go ty1 ty2
453     gos _ _ = False
454
455     go :: UnaryType -> UnaryType -> Bool
456     go ty1 ty2
457       | Just (tc1, tc_args1) <- splitTyConApp_maybe ty1
458       , Just (tc2, tc_args2) <- splitTyConApp_maybe ty2
459       , let res = if tc1 == tc2 
460                   then equalLength tc_args1 tc_args2 && and (zipWith (gos `on` repType) tc_args1 tc_args2)
461                   else  -- TyCons don't match; but don't bleat if either is a 
462                         -- family TyCon because a coercion might have made it 
463                         -- equal to something else
464                     (isFamilyTyCon tc1 || isFamilyTyCon tc2)
465       = if res then True
466         else 
467         pprTrace "stgEqType: unequal" (vcat [ppr ty1, ppr ty2]) 
468         False
469
470       | otherwise = True  -- Conservatively say "fine".  
471                           -- Type variables in particular
472
473 checkInScope :: Id -> LintM ()
474 checkInScope id = LintM $ \loc scope errs
475  -> if isLocalId id && not (id `elemVarSet` scope) then
476         ((), addErr errs (hsep [ppr id, ptext (sLit "is out of scope")]) loc)
477     else
478         ((), errs)
479
480 checkTys :: Type -> Type -> MsgDoc -> LintM ()
481 checkTys ty1 ty2 msg = LintM $ \loc _scope errs
482   -> if (ty1 `stgEqType` ty2)
483      then ((), errs)
484      else ((), addErr errs msg loc)
485 \end{code}
486
487 \begin{code}
488 _mkCaseAltMsg :: [StgAlt] -> MsgDoc
489 _mkCaseAltMsg _alts
490   = ($$) (text "In some case alternatives, type of alternatives not all same:")
491             (Outputable.empty) -- LATER: ppr alts
492
493 mkDefltMsg :: Id -> TyCon -> MsgDoc
494 mkDefltMsg bndr tc
495   = ($$) (ptext (sLit "Binder of a case expression doesn't match type of scrutinee:"))
496          (ppr bndr $$ ppr (idType bndr) $$ ppr tc)
497
498 mkFunAppMsg :: Type -> [Type] -> StgExpr -> MsgDoc
499 mkFunAppMsg fun_ty arg_tys expr
500   = vcat [text "In a function application, function type doesn't match arg types:",
501               hang (ptext (sLit "Function type:")) 4 (ppr fun_ty),
502               hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys)),
503               hang (ptext (sLit "Expression:")) 4 (ppr expr)]
504
505 mkRhsConMsg :: Type -> [Type] -> MsgDoc
506 mkRhsConMsg fun_ty arg_tys
507   = vcat [text "In a RHS constructor application, con type doesn't match arg types:",
508               hang (ptext (sLit "Constructor type:")) 4 (ppr fun_ty),
509               hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys))]
510
511 mkAltMsg1 :: Type -> MsgDoc
512 mkAltMsg1 ty
513   = ($$) (text "In a case expression, type of scrutinee does not match patterns")
514          (ppr ty)
515
516 mkAlgAltMsg2 :: Type -> DataCon -> MsgDoc
517 mkAlgAltMsg2 ty con
518   = vcat [
519         text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
520         ppr ty,
521         ppr con
522     ]
523
524 mkAlgAltMsg3 :: DataCon -> [Id] -> MsgDoc
525 mkAlgAltMsg3 con alts
526   = vcat [
527         text "In some algebraic case alternative, number of arguments doesn't match constructor:",
528         ppr con,
529         ppr alts
530     ]
531
532 mkAlgAltMsg4 :: Type -> Id -> MsgDoc
533 mkAlgAltMsg4 ty arg
534   = vcat [
535         text "In some algebraic case alternative, type of argument doesn't match data constructor:",
536         ppr ty,
537         ppr arg
538     ]
539
540 _mkRhsMsg :: Id -> Type -> MsgDoc
541 _mkRhsMsg binder ty
542   = vcat [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"),
543                      ppr binder],
544               hsep [ptext (sLit "Binder's type:"), ppr (idType binder)],
545               hsep [ptext (sLit "Rhs type:"), ppr ty]
546              ]
547
548 mkUnLiftedTyMsg :: Id -> StgRhs -> SDoc
549 mkUnLiftedTyMsg binder rhs
550   = (ptext (sLit "Let(rec) binder") <+> quotes (ppr binder) <+>
551      ptext (sLit "has unlifted type") <+> quotes (ppr (idType binder)))
552     $$
553     (ptext (sLit "RHS:") <+> ppr rhs)
554 \end{code}