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