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 ( {- SEE BELOW: -- KSW 2000-10-13
19 #include "HsVersions.h"
23 import TypeRep ( Type(..), TyNote(..) ) -- friend
25 import TyCon ( isAlgTyCon, isPrimTyCon, isSynTyCon, isFunTyCon )
26 import Var ( Var, varType )
27 import Id ( idLBVarInfo )
28 import IdInfo ( LBVarInfo(..) )
29 import ErrUtils ( ghcExit )
30 import Util ( zipWithEqual )
34 {- ENTIRE FILE COMMENTED OUT FOR NOW -- KSW 2000-10-13
36 This monomorphic version of the analysis is outdated. I'm
37 currently ripping out the old one and inserting the new one. For
38 now, I'm simply commenting out this entire file.
42 ======================================================================
47 @doLintUSPAnnotsBinds@ checks that annotations are in the correct positions.
48 @doLintUSPConstsBinds@ checks that no @UVar@s remain anywhere (i.e., all annots are constants).
49 @doLintUSPBinds@ checks that the annotations are consistent. [unimplemented!]
50 @doCheckIfWorseUSP@ checks that annots on binders have not changed from Once to Many.
53 doLint :: ULintM a -> IO ()
55 doLint m = case runULM m of
57 Just bad_news -> do { printDump (display bad_news)
60 where display bad_news = vcat [ text "*** LintUSP errors: ***"
62 , text "*** end of LintUSP errors ***"
65 doLintUSPAnnotsBinds, doLintUSPConstBinds :: [CoreBind] -> IO ()
67 doLintUSPAnnotsBinds = doLint . lintUSPAnnotsBinds
68 doLintUSPConstBinds = doLint . lintUSPConstBinds
70 -- doLintUSPBinds is defined below
72 doCheckIfWorseUSP :: [CoreBind] -> [CoreBind] -> IO ()
74 doCheckIfWorseUSP binds binds'
75 = case checkIfWorseUSP binds binds' of
77 Just warns -> printDump warns
80 ======================================================================
82 Verifying correct annotation positioning
83 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
85 The following functions check whether the usage annotations are
86 correctly placed on a type. They sit inside the lint monad.
87 @lintUSPAnnots@ assumes there should be an outermost annotation,
88 @lintUSPAnnotsN@ assumes there shouldn't.
90 The fact that no general catch-all pattern is given for @NoteTy@s is
91 entirely intentional. The meaning of future extensions here is
92 entirely unknown, so you'll have to decide how to check them
96 lintTyUSPAnnots :: Bool -- die on omitted annotation?
97 -> Bool -- die on extra annotation?
98 -> Type -- type to check
101 lintTyUSPAnnots fom fex = lint
103 lint (NoteTy (UsgNote _) ty) = lintTyUSPAnnotsN fom fex ty
104 lint ty0 = do { mayErrULM fom "missing UsgNote" ty0
105 ; lintTyUSPAnnotsN fom fex ty0
108 lintTyUSPAnnotsN :: Bool -- die on omitted annotation?
109 -> Bool -- die on extra annotation?
110 -> Type -- type to check
113 lintTyUSPAnnotsN fom fex = lintN
115 lintN ty0@(NoteTy (UsgNote _) ty) = do { mayErrULM fex "unexpected UsgNote" ty0
118 lintN (NoteTy (SynNote sty) ty) = do { lintN sty
121 lintN (NoteTy (FTVNote _) ty) = do { lintN ty }
123 lintN (TyVarTy _) = do { return () }
124 lintN (AppTy ty1 ty2) = do { lintN ty1
127 lintN (TyConApp tc tys) = ASSERT( isFunTyCon tc || isAlgTyCon tc || isPrimTyCon tc || isSynTyCon tc )
128 do { let thelint = if isFunTyCon tc
129 then lintTyUSPAnnots fom fex
134 lintN (FunTy ty1 ty2) = do { lintTyUSPAnnots fom fex ty1
135 ; lintTyUSPAnnots fom fex ty2
137 lintN (ForAllTy _ ty) = do { lintN ty }
141 Now the combined function that takes a @MungeFlags@ to tell it what to
142 do to a particular type. This is passed to @genAnnotBinds@ to get the
146 lintUSPAnnotsTyM :: MungeFlags -> Type -> AnnotM (ULintM ()) Type
148 lintUSPAnnotsTyM mf ty = AnnotM $ \ m ve ->
150 ; atLocULM (mfLoc mf) $
153 else lintTyUSPAnnotsN) checkOmitted True ty
157 where checkOmitted = False -- OK to omit Many if !USMANY
159 where checkOmitted = True -- require all annotations
162 lintUSPAnnotsBinds :: [CoreBind]
165 lintUSPAnnotsBinds binds = case initAnnotM (return ()) $
166 genAnnotBinds lintUSPAnnotsTyM return binds of
167 -- **! should check with mungeTerm too!
171 ======================================================================
173 Verifying correct usage typing
174 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
176 The following function verifies that all usage annotations are
177 consistent. It assumes that there are no usage variables, only
178 @UsOnce@ and @UsMany@ annotations.
180 This is very similar to usage inference, however, and so we could
181 simply use that, with a little work. For now, it's unimplemented.
184 doLintUSPBinds :: [CoreBind] -> IO ()
186 doLintUSPBinds binds = panic "doLintUSPBinds unimplemented"
187 {- case initUs us (uniqSMMToUs (usgInfBinds binds)) of
188 ((ucs,_),_) -> if isJust (solveUCS ucs)
190 else do { printDump (text "*** LintUSPBinds failed ***")
196 ======================================================================
198 Verifying usage constants only (not vars)
199 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
201 The following function checks that all usage annotations are ground,
202 i.e., @UsOnce@ or @UsMany@: no @UVar@s remain.
205 lintTyUSPConst :: Type
208 lintTyUSPConst (TyVarTy _) = do { return () }
210 lintTyUSPConst (AppTy ty1 ty2) = do { lintTyUSPConst ty1
213 lintTyUSPConst (TyConApp tc tys) = mapM_ lintTyUSPConst tys
214 lintTyUSPConst (FunTy ty1 ty2) = do { lintTyUSPConst ty1
217 lintTyUSPConst (ForAllTy _ ty) = do { lintTyUSPConst ty }
219 lintTyUSPConst ty0@(NoteTy (UsgNote (UsVar _)) ty) = do { errULM "unexpected usage variable" ty0
222 lintTyUSPConst ty0@(NoteTy (UsgNote _) ty) = do { lintTyUSPConst ty }
223 lintTyUSPConst ty0@(NoteTy (SynNote sty) ty) = do { lintTyUSPConst sty
226 lintTyUSPConst ty0@(NoteTy (FTVNote _) ty) = do { lintTyUSPConst ty }
230 Now the combined function and the invocation of @genAnnotBinds@ to do the real work.
233 lintUSPConstTyM :: MungeFlags -> Type -> AnnotM (ULintM ()) Type
235 lintUSPConstTyM mf ty = AnnotM $ \ m ve ->
238 ; atLocULM (mfLoc mf) $
243 lintUSPConstBinds :: [CoreBind]
246 lintUSPConstBinds binds = case initAnnotM (return ()) $
247 genAnnotBinds lintUSPConstTyM return binds of
248 -- **! should check with mungeTerm too!
252 ======================================================================
254 Checking annotations don't get any worse
255 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
257 It is assumed that all transformations in GHC are `work-safe', that
258 is, they do not cause any work to be duplicated. Thus they should
259 also be safe wrt the UsageSP analysis: if an identifier has a
260 used-once type at one point, the identifier should never become
261 used-many after transformation. This check verifies that this is the
264 The arguments are the CoreBinds before and after the inference. They
265 must have exactly the same shape apart from usage annotations.
267 We only bother checking binders; free variables *should* be fixed
268 already since they are imported and not changeable.
270 First, the various kinds of worsenings we can have:
273 data WorseErr = WorseVar Var Var -- variable gets worse
274 | WorseTerm CoreExpr CoreExpr -- term gets worse
275 | WorseLam Var Var -- lambda gets worse
277 instance Outputable WorseErr where
278 ppr (WorseVar v0 v) = ptext SLIT("Identifier:") <+> ppr v0 <+> dcolon
279 <+> ( ptext SLIT("was") <+> ppr (varType v0)
280 $$ ptext SLIT("now") <+> ppr (varType v))
281 ppr (WorseTerm e0 e) = ptext SLIT("Term:")
282 <+> ( ptext SLIT("was") <+> ppr e0
283 $$ ptext SLIT("now") <+> ppr e)
284 ppr (WorseLam v0 v) = ptext SLIT("Lambda:")
286 $$ ptext SLIT("(lambda-bound var info for var worsened)"))
292 checkIfWorseUSP :: [CoreBind] -- old binds
293 -> [CoreBind] -- new binds
294 -> Maybe SDoc -- maybe warnings
296 checkIfWorseUSP binds binds'
297 = let vvs = checkBinds binds binds'
298 in if isEmptyBag vvs then
301 Just $ ptext SLIT("UsageSP warning: annotations worsen for")
302 $$ nest 4 (vcat (map ppr (bagToList vvs)))
304 checkBinds :: [CoreBind] -> [CoreBind] -> Bag WorseErr
305 checkBinds binds binds' = unionManyBags $
306 zipWithEqual "UsageSPLint.checkBinds" checkBind binds binds'
308 checkBind :: CoreBind -> CoreBind -> Bag WorseErr
309 checkBind (NonRec v e) (NonRec v' e') = (checkVar v v') `unionBags` (checkCE e e')
310 checkBind (Rec ves) (Rec ves') = unionManyBags $
311 zipWithEqual "UsageSPLint.checkBind"
312 (\ (v,e) (v',e') -> (checkVar v v')
313 `unionBags` (checkCE e e'))
315 checkBind _ _ = panic "UsageSPLint.checkBind"
318 checkCE :: CoreExpr -> CoreExpr -> Bag WorseErr
320 checkCE (Var _) (Var _) = emptyBag
321 checkCE (Lit _) (Lit _) = emptyBag
323 checkCE (App e arg) (App e' arg') = (checkCE e e')
324 `unionBags` (checkCE arg arg')
326 checkCE (Lam v e) (Lam v' e') = (checkVar v v')
327 `unionBags` (checkLamVar v v')
328 `unionBags` (checkCE e e')
330 checkCE (Let bind e) (Let bind' e') = (checkBind bind bind')
331 `unionBags` (checkCE e e')
333 checkCE (Case e v alts) (Case e' v' alts')
335 `unionBags` (checkVar v v')
336 `unionBags` (unionManyBags $
337 zipWithEqual "usageSPLint.checkCE:Case"
338 checkAlts alts alts')
339 where checkAlts (_,vs,e) (_,vs',e') = (unionManyBags $ zipWithEqual "UsageSPLint.checkCE:Alt"
341 `unionBags` (checkCE e e')
343 checkCE (Note (SCC _) e) (Note (SCC _) e') = checkCE e e'
345 checkCE (Note (Coerce _ _) e) (Note (Coerce _ _) e') = checkCE e e'
347 checkCE (Note InlineCall e) (Note InlineCall e') = checkCE e e'
349 checkCE (Note InlineMe e) (Note InlineMe e') = checkCE e e'
351 checkCE t@(Note (TermUsg u) e) t'@(Note (TermUsg u') e')
353 `unionBags` (checkUsg u u' (WorseTerm t t'))
355 checkCE (Type _) (Type _) = emptyBag
357 checkCE t t' = pprPanic "usageSPLint.checkCE:"
358 (ppr t $$ text "doesn't match" <+> ppr t')
361 -- does binder change from Once to Many?
362 -- notice we only check the top-level annotation; this is all that's necessary. KSW 1999-04.
363 checkVar :: Var -> Var -> Bag WorseErr
364 checkVar v v' | isTyVar v = emptyBag
365 | not (isUsgTy y) = emptyBag -- if initially no annot, definitely OK
366 | otherwise = checkUsg u u' (WorseVar v v')
372 -- does lambda change from Once to Many?
373 checkLamVar :: Var -> Var -> Bag WorseErr
374 checkLamVar v v' | isTyVar v = emptyBag
375 | otherwise = case (idLBVarInfo v, idLBVarInfo v') of
376 (NoLBVarInfo , _ ) -> emptyBag
377 (IsOneShotLambda, IsOneShotLambda) -> emptyBag
378 (IsOneShotLambda, NoLBVarInfo ) -> unitBag (WorseLam v v')
380 -- does term usage annotation change from Once to Many?
381 checkUsg :: UsageAnn -> UsageAnn -> WorseErr -> Bag WorseErr
382 checkUsg UsMany _ _ = emptyBag
383 checkUsg UsOnce UsOnce _ = emptyBag
384 checkUsg UsOnce UsMany err = unitBag err
387 ======================================================================
392 The errors (@ULintErr@s) are collected in the @ULintM@ monad, which
393 also tracks the location of the current type being checked.
396 data ULintErr = ULintErr SDoc String Type
398 pprULintErr :: ULintErr -> SDoc
399 pprULintErr (ULintErr loc s ty) = hang (text s <+> ptext SLIT("in") <+> loc <> ptext SLIT(":"))
403 newtype ULintM a = ULintM (SDoc -> (a,Bag ULintErr))
404 unULintM (ULintM f) = f
406 instance Monad ULintM where
407 m >>= f = ULintM $ \ loc -> let (a ,errs ) = (unULintM m) loc
408 (a',errs') = (unULintM (f a)) loc
409 in (a', errs `unionBags` errs')
410 return a = ULintM $ \ _ -> (a,emptyBag)
412 atLocULM :: SDoc -> ULintM a -> ULintM a
413 atLocULM loc m = ULintM $ \ _ -> (unULintM m) loc
415 errULM :: String -> Type -> ULintM ()
417 = ULintM $ \ loc -> ((),unitBag $ ULintErr loc err ty)
419 mayErrULM :: Bool -> String -> Type -> ULintM ()
421 = if f then errULM err ty else return ()
423 runULM :: ULintM a -> Maybe SDoc
424 runULM m = case (unULintM m) (panic "runULM: no location") of
425 (_,errs) -> if isEmptyBag errs
427 else Just (vcat (map pprULintErr (bagToList errs)))
429 END OF ENTIRELY-COMMENTED-OUT FILE -- KSW 2000-10-13 -}
432 ======================================================================