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 TypeRep ( Type(..), TyNote(..) ) -- friend
23 import Type ( UsageAnn(..), isUsgTy, tyUsg )
24 import TyCon ( isAlgTyCon, isPrimTyCon, isSynTyCon, isFunTyCon )
25 import Var ( Var, varType )
26 import Id ( idLBVarInfo )
27 import IdInfo ( LBVarInfo(..) )
28 import ErrUtils ( ghcExit )
29 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 Var Var -- variable gets worse
268 | WorseTerm CoreExpr CoreExpr -- term gets worse
269 | WorseLam Var Var -- 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
315 checkCE (Lit _) (Lit _) = emptyBag
317 checkCE (App e arg) (App e' arg') = (checkCE e e')
318 `unionBags` (checkCE arg arg')
320 checkCE (Lam v e) (Lam v' e') = (checkVar v v')
321 `unionBags` (checkLamVar v v')
322 `unionBags` (checkCE e e')
324 checkCE (Let bind e) (Let bind' e') = (checkBind bind bind')
325 `unionBags` (checkCE e e')
327 checkCE (Case e v alts) (Case e' v' alts')
329 `unionBags` (checkVar v v')
330 `unionBags` (unionManyBags $
331 zipWithEqual "usageSPLint.checkCE:Case"
332 checkAlts alts alts')
333 where checkAlts (_,vs,e) (_,vs',e') = (unionManyBags $ zipWithEqual "UsageSPLint.checkCE:Alt"
335 `unionBags` (checkCE e e')
337 checkCE (Note (SCC _) e) (Note (SCC _) e') = checkCE e e'
339 checkCE (Note (Coerce _ _) e) (Note (Coerce _ _) e') = checkCE e e'
341 checkCE (Note InlineCall e) (Note InlineCall e') = checkCE e e'
343 checkCE (Note InlineMe e) (Note InlineMe e') = checkCE e e'
345 checkCE t@(Note (TermUsg u) e) t'@(Note (TermUsg u') e')
347 `unionBags` (checkUsg u u' (WorseTerm t t'))
349 checkCE (Type _) (Type _) = emptyBag
351 checkCE t t' = pprPanic "usageSPLint.checkCE:"
352 (ppr t $$ text "doesn't match" <+> ppr t')
355 -- does binder change from Once to Many?
356 -- notice we only check the top-level annotation; this is all that's necessary. KSW 1999-04.
357 checkVar :: Var -> Var -> Bag WorseErr
358 checkVar v v' | isTyVar v = emptyBag
359 | not (isUsgTy y) = emptyBag -- if initially no annot, definitely OK
360 | otherwise = checkUsg u u' (WorseVar v v')
366 -- does lambda change from Once to Many?
367 checkLamVar :: Var -> Var -> Bag WorseErr
368 checkLamVar v v' | isTyVar v = emptyBag
369 | otherwise = case (idLBVarInfo v, idLBVarInfo v') of
370 (NoLBVarInfo , _ ) -> emptyBag
371 (IsOneShotLambda, IsOneShotLambda) -> emptyBag
372 (IsOneShotLambda, NoLBVarInfo ) -> unitBag (WorseLam v v')
374 -- does term usage annotation change from Once to Many?
375 checkUsg :: UsageAnn -> UsageAnn -> WorseErr -> Bag WorseErr
376 checkUsg UsMany _ _ = emptyBag
377 checkUsg UsOnce UsOnce _ = emptyBag
378 checkUsg UsOnce UsMany err = unitBag err
381 ======================================================================
386 The errors (@ULintErr@s) are collected in the @ULintM@ monad, which
387 also tracks the location of the current type being checked.
390 data ULintErr = ULintErr SDoc String Type
392 pprULintErr :: ULintErr -> SDoc
393 pprULintErr (ULintErr loc s ty) = hang (text s <+> ptext SLIT("in") <+> loc <> ptext SLIT(":"))
397 newtype ULintM a = ULintM (SDoc -> (a,Bag ULintErr))
398 unULintM (ULintM f) = f
400 instance Monad ULintM where
401 m >>= f = ULintM $ \ loc -> let (a ,errs ) = (unULintM m) loc
402 (a',errs') = (unULintM (f a)) loc
403 in (a', errs `unionBags` errs')
404 return a = ULintM $ \ _ -> (a,emptyBag)
406 atLocULM :: SDoc -> ULintM a -> ULintM a
407 atLocULM loc m = ULintM $ \ _ -> (unULintM m) loc
409 errULM :: String -> Type -> ULintM ()
411 = ULintM $ \ loc -> ((),unitBag $ ULintErr loc err ty)
413 mayErrULM :: Bool -> String -> Type -> ULintM ()
415 = if f then errULM err ty else return ()
417 runULM :: ULintM a -> Maybe SDoc
418 runULM m = case (unULintM m) (panic "runULM: no location") of
419 (_,errs) -> if isEmptyBag errs
421 else Just (vcat (map pprULintErr (bagToList errs)))
424 ======================================================================