2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
4 \section[UsageSPLint]{UsageSP ``lint'' pass}
6 This code is (based on) PhD work of Keith Wansbrough <kw217@cl.cam.ac.uk>,
7 September 1998 .. May 1999.
9 Keith Wansbrough 1998-09-04..1999-06-25
12 module UsageSPLint ( doLintUSPAnnotsBinds,
18 #include "HsVersions.h"
22 import Type ( Type(..), TyNote(..), UsageAnn(..), isUsgTy, tyUsg )
23 import TyCon ( isAlgTyCon, isPrimTyCon, isSynTyCon, isFunTyCon )
24 import Var ( IdOrTyVar, varType, idInfo )
25 import IdInfo ( LBVarInfo(..), lbvarInfo )
26 import SrcLoc ( noSrcLoc )
27 import ErrUtils ( Message, ghcExit )
28 import Util ( zipWithEqual )
34 ======================================================================
39 @doLintUSPAnnotsBinds@ checks that annotations are in the correct positions.
40 @doLintUSPConstsBinds@ checks that no @UVar@s remain anywhere (i.e., all annots are constants).
41 @doLintUSPBinds@ checks that the annotations are consistent. [unimplemented!]
42 @doCheckIfWorseUSP@ checks that annots on binders have not changed from Once to Many.
45 doLint :: ULintM a -> IO ()
47 doLint m = case runULM m of
49 Just bad_news -> do { printDump (display bad_news)
52 where display bad_news = vcat [ text "*** LintUSP errors: ***"
54 , text "*** end of LintUSP errors ***"
57 doLintUSPAnnotsBinds, doLintUSPConstBinds :: [CoreBind] -> IO ()
59 doLintUSPAnnotsBinds = doLint . lintUSPAnnotsBinds
60 doLintUSPConstBinds = doLint . lintUSPConstBinds
62 -- doLintUSPBinds is defined below
64 doCheckIfWorseUSP :: [CoreBind] -> [CoreBind] -> IO ()
66 doCheckIfWorseUSP binds binds'
67 = case checkIfWorseUSP binds binds' of
69 Just warns -> printErrs warns
72 ======================================================================
74 Verifying correct annotation positioning
75 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
77 The following functions check whether the usage annotations are
78 correctly placed on a type. They sit inside the lint monad.
79 @lintUSPAnnots@ assumes there should be an outermost annotation,
80 @lintUSPAnnotsN@ assumes there shouldn't.
82 The fact that no general catch-all pattern is given for @NoteTy@s is
83 entirely intentional. The meaning of future extensions here is
84 entirely unknown, so you'll have to decide how to check them
88 lintTyUSPAnnots :: Bool -- die on omitted annotation?
89 -> Bool -- die on extra annotation?
90 -> Type -- type to check
93 lintTyUSPAnnots fom fex = lint
95 lint (NoteTy (UsgNote _) ty) = lintTyUSPAnnotsN fom fex ty
96 lint ty0 = do { mayErrULM fom "missing UsgNote" ty0
97 ; lintTyUSPAnnotsN fom fex ty0
100 lintTyUSPAnnotsN :: Bool -- die on omitted annotation?
101 -> Bool -- die on extra annotation?
102 -> Type -- type to check
105 lintTyUSPAnnotsN fom fex = lintN
107 lintN ty0@(NoteTy (UsgNote _) ty) = do { mayErrULM fex "unexpected UsgNote" ty0
110 lintN (NoteTy (SynNote sty) ty) = do { lintN sty
113 lintN (NoteTy (FTVNote _) ty) = do { lintN ty }
115 lintN (TyVarTy _) = do { return () }
116 lintN (AppTy ty1 ty2) = do { lintN ty1
119 lintN (TyConApp tc tys) = ASSERT( isFunTyCon tc || isAlgTyCon tc || isPrimTyCon tc || isSynTyCon tc )
120 do { let thelint = if isFunTyCon tc
121 then lintTyUSPAnnots fom fex
126 lintN (FunTy ty1 ty2) = do { lintTyUSPAnnots fom fex ty1
127 ; lintTyUSPAnnots fom fex ty2
129 lintN (ForAllTy _ ty) = do { lintN ty }
133 Now the combined function that takes a @MungeFlags@ to tell it what to
134 do to a particular type. This is passed to @genAnnotBinds@ to get the
138 lintUSPAnnotsTyM :: MungeFlags -> Type -> AnnotM (ULintM ()) Type
140 lintUSPAnnotsTyM mf ty = AnnotM $ \ m ve ->
142 ; atLocULM (mfLoc mf) $
145 else lintTyUSPAnnotsN) checkOmitted True ty
149 where checkOmitted = False -- OK to omit Many if !USMANY
151 where checkOmitted = True -- require all annotations
154 lintUSPAnnotsBinds :: [CoreBind]
157 lintUSPAnnotsBinds binds = case initAnnotM (return ()) $
158 genAnnotBinds lintUSPAnnotsTyM return binds of
159 -- **! should check with mungeTerm too!
163 ======================================================================
165 Verifying correct usage typing
166 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
168 The following function verifies that all usage annotations are
169 consistent. It assumes that there are no usage variables, only
170 @UsOnce@ and @UsMany@ annotations.
172 This is very similar to usage inference, however, and so we could
173 simply use that, with a little work. For now, it's unimplemented.
176 doLintUSPBinds :: [CoreBind] -> IO ()
178 doLintUSPBinds binds = panic "doLintUSPBinds unimplemented"
179 {- case initUs us (uniqSMMToUs (usgInfBinds binds)) of
180 ((ucs,_),_) -> if isJust (solveUCS ucs)
182 else do { printDump (text "*** LintUSPBinds failed ***")
188 ======================================================================
190 Verifying usage constants only (not vars)
191 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
193 The following function checks that all usage annotations are ground,
194 i.e., @UsOnce@ or @UsMany@: no @UVar@s remain.
197 lintTyUSPConst :: Type
200 lintTyUSPConst (TyVarTy _) = do { return () }
202 lintTyUSPConst (AppTy ty1 ty2) = do { lintTyUSPConst ty1
205 lintTyUSPConst (TyConApp tc tys) = do { mapM lintTyUSPConst tys
208 lintTyUSPConst (FunTy ty1 ty2) = do { lintTyUSPConst ty1
211 lintTyUSPConst (ForAllTy _ ty) = do { lintTyUSPConst ty }
213 lintTyUSPConst ty0@(NoteTy (UsgNote (UsVar _)) ty) = do { errULM "unexpected usage variable" ty0
216 lintTyUSPConst ty0@(NoteTy (UsgNote _) ty) = do { lintTyUSPConst ty }
217 lintTyUSPConst ty0@(NoteTy (SynNote sty) ty) = do { lintTyUSPConst sty
220 lintTyUSPConst ty0@(NoteTy (FTVNote _) ty) = do { lintTyUSPConst ty }
224 Now the combined function and the invocation of @genAnnotBinds@ to do the real work.
227 lintUSPConstTyM :: MungeFlags -> Type -> AnnotM (ULintM ()) Type
229 lintUSPConstTyM mf ty = AnnotM $ \ m ve ->
232 ; atLocULM (mfLoc mf) $
237 lintUSPConstBinds :: [CoreBind]
240 lintUSPConstBinds binds = case initAnnotM (return ()) $
241 genAnnotBinds lintUSPConstTyM return binds of
242 -- **! should check with mungeTerm too!
246 ======================================================================
248 Checking annotations don't get any worse
249 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
251 It is assumed that all transformations in GHC are `work-safe', that
252 is, they do not cause any work to be duplicated. Thus they should
253 also be safe wrt the UsageSP analysis: if an identifier has a
254 used-once type at one point, the identifier should never become
255 used-many after transformation. This check verifies that this is the
258 The arguments are the CoreBinds before and after the inference. They
259 must have exactly the same shape apart from usage annotations.
261 We only bother checking binders; free variables *should* be fixed
262 already since they are imported and not changeable.
264 First, the various kinds of worsenings we can have:
267 data WorseErr = WorseVar IdOrTyVar IdOrTyVar -- variable gets worse
268 | WorseTerm CoreExpr CoreExpr -- term gets worse
269 | WorseLam IdOrTyVar IdOrTyVar -- lambda gets worse
271 instance Outputable WorseErr where
272 ppr (WorseVar v0 v) = ptext SLIT("Identifier:") <+> ppr v0 <+> dcolon
273 <+> ( ptext SLIT("was") <+> ppr (varType v0)
274 $$ ptext SLIT("now") <+> ppr (varType v))
275 ppr (WorseTerm e0 e) = ptext SLIT("Term:")
276 <+> ( ptext SLIT("was") <+> ppr e0
277 $$ ptext SLIT("now") <+> ppr e)
278 ppr (WorseLam v0 v) = ptext SLIT("Lambda:")
280 $$ ptext SLIT("(lambda-bound var info for var worsened)"))
286 checkIfWorseUSP :: [CoreBind] -- old binds
287 -> [CoreBind] -- new binds
288 -> Maybe SDoc -- maybe warnings
290 checkIfWorseUSP binds binds'
291 = let vvs = checkBinds binds binds'
292 in if isEmptyBag vvs then
295 Just $ ptext SLIT("UsageSP warning: annotations worsen for")
296 $$ nest 4 (vcat (map ppr (bagToList vvs)))
298 checkBinds :: [CoreBind] -> [CoreBind] -> Bag WorseErr
299 checkBinds binds binds' = unionManyBags $
300 zipWithEqual "UsageSPLint.checkBinds" checkBind binds binds'
302 checkBind :: CoreBind -> CoreBind -> Bag WorseErr
303 checkBind (NonRec v e) (NonRec v' e') = (checkVar v v') `unionBags` (checkCE e e')
304 checkBind (Rec ves) (Rec ves') = unionManyBags $
305 zipWithEqual "UsageSPLint.checkBind"
306 (\ (v,e) (v',e') -> (checkVar v v')
307 `unionBags` (checkCE e e'))
309 checkBind _ _ = panic "UsageSPLint.checkBind"
312 checkCE :: CoreExpr -> CoreExpr -> Bag WorseErr
314 checkCE (Var _) (Var _) = emptyBag
316 checkCE (Con _ args) (Con _ args') = unionManyBags $
317 zipWithEqual "UsageSPLint.checkCE:Con"
320 checkCE (App e arg) (App e' arg') = (checkCE e e')
321 `unionBags` (checkCE arg arg')
323 checkCE (Lam v e) (Lam v' e') = (checkVar v v')
324 `unionBags` (checkLamVar v v')
325 `unionBags` (checkCE e e')
327 checkCE (Let bind e) (Let bind' e') = (checkBind bind bind')
328 `unionBags` (checkCE e e')
330 checkCE (Case e v alts) (Case e' v' alts')
332 `unionBags` (checkVar v v')
333 `unionBags` (unionManyBags $
334 zipWithEqual "usageSPLint.checkCE:Case"
335 checkAlts alts alts')
336 where checkAlts (_,vs,e) (_,vs',e') = (unionManyBags $ zipWithEqual "UsageSPLint.checkCE:Alt"
338 `unionBags` (checkCE e e')
340 checkCE (Note (SCC _) e) (Note (SCC _) e') = checkCE e e'
342 checkCE (Note (Coerce _ _) e) (Note (Coerce _ _) e') = checkCE e e'
344 checkCE (Note InlineCall e) (Note InlineCall e') = checkCE e e'
346 checkCE (Note InlineMe e) (Note InlineMe e') = checkCE e e'
348 checkCE t@(Note (TermUsg u) e) t'@(Note (TermUsg u') e')
350 `unionBags` (checkUsg u u' (WorseTerm t t'))
352 checkCE (Type _) (Type _) = emptyBag
354 checkCE t t' = pprPanic "usageSPLint.checkCE:"
355 (ppr t $$ text "doesn't match" <+> ppr t')
358 -- does binder change from Once to Many?
359 -- notice we only check the top-level annotation; this is all that's necessary. KSW 1999-04.
360 checkVar :: IdOrTyVar -> IdOrTyVar -> Bag WorseErr
361 checkVar v v' | isTyVar v = emptyBag
362 | not (isUsgTy y) = emptyBag -- if initially no annot, definitely OK
363 | otherwise = checkUsg u u' (WorseVar v v')
369 -- does lambda change from Once to Many?
370 checkLamVar :: IdOrTyVar -> IdOrTyVar -> Bag WorseErr
371 checkLamVar v v' | isTyVar v = emptyBag
372 | otherwise = case ((lbvarInfo . idInfo) v, (lbvarInfo . idInfo) v') of
373 (NoLBVarInfo , _ ) -> emptyBag
374 (IsOneShotLambda, IsOneShotLambda) -> emptyBag
375 (IsOneShotLambda, NoLBVarInfo ) -> unitBag (WorseLam v v')
377 -- does term usage annotation change from Once to Many?
378 checkUsg :: UsageAnn -> UsageAnn -> WorseErr -> Bag WorseErr
379 checkUsg UsMany _ _ = emptyBag
380 checkUsg UsOnce UsOnce _ = emptyBag
381 checkUsg UsOnce UsMany err = unitBag err
384 ======================================================================
389 The errors (@ULintErr@s) are collected in the @ULintM@ monad, which
390 also tracks the location of the current type being checked.
393 data ULintErr = ULintErr SDoc String Type
395 pprULintErr :: ULintErr -> SDoc
396 pprULintErr (ULintErr loc s ty) = hang (text s <+> ptext SLIT("in") <+> loc <> ptext SLIT(":"))
400 newtype ULintM a = ULintM (SDoc -> (a,Bag ULintErr))
401 unULintM (ULintM f) = f
403 instance Monad ULintM where
404 m >>= f = ULintM $ \ loc -> let (a ,errs ) = (unULintM m) loc
405 (a',errs') = (unULintM (f a)) loc
406 in (a', errs `unionBags` errs')
407 return a = ULintM $ \ _ -> (a,emptyBag)
409 atLocULM :: SDoc -> ULintM a -> ULintM a
410 atLocULM loc m = ULintM $ \ _ -> (unULintM m) loc
412 errULM :: String -> Type -> ULintM ()
414 = ULintM $ \ loc -> ((),unitBag $ ULintErr loc err ty)
416 mayErrULM :: Bool -> String -> Type -> ULintM ()
418 = if f then errULM err ty else return ()
420 runULM :: ULintM a -> Maybe SDoc
421 runULM m = case (unULintM m) (panic "runULM: no location") of
422 (_,errs) -> if isEmptyBag errs
424 else Just (vcat (map pprULintErr (bagToList errs)))
427 ======================================================================