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) = do { mapM lintTyUSPConst tys
216 lintTyUSPConst (FunTy ty1 ty2) = do { lintTyUSPConst ty1
219 lintTyUSPConst (ForAllTy _ ty) = do { lintTyUSPConst ty }
221 lintTyUSPConst ty0@(NoteTy (UsgNote (UsVar _)) ty) = do { errULM "unexpected usage variable" ty0
224 lintTyUSPConst ty0@(NoteTy (UsgNote _) ty) = do { lintTyUSPConst ty }
225 lintTyUSPConst ty0@(NoteTy (SynNote sty) ty) = do { lintTyUSPConst sty
228 lintTyUSPConst ty0@(NoteTy (FTVNote _) ty) = do { lintTyUSPConst ty }
232 Now the combined function and the invocation of @genAnnotBinds@ to do the real work.
235 lintUSPConstTyM :: MungeFlags -> Type -> AnnotM (ULintM ()) Type
237 lintUSPConstTyM mf ty = AnnotM $ \ m ve ->
240 ; atLocULM (mfLoc mf) $
245 lintUSPConstBinds :: [CoreBind]
248 lintUSPConstBinds binds = case initAnnotM (return ()) $
249 genAnnotBinds lintUSPConstTyM return binds of
250 -- **! should check with mungeTerm too!
254 ======================================================================
256 Checking annotations don't get any worse
257 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
259 It is assumed that all transformations in GHC are `work-safe', that
260 is, they do not cause any work to be duplicated. Thus they should
261 also be safe wrt the UsageSP analysis: if an identifier has a
262 used-once type at one point, the identifier should never become
263 used-many after transformation. This check verifies that this is the
266 The arguments are the CoreBinds before and after the inference. They
267 must have exactly the same shape apart from usage annotations.
269 We only bother checking binders; free variables *should* be fixed
270 already since they are imported and not changeable.
272 First, the various kinds of worsenings we can have:
275 data WorseErr = WorseVar Var Var -- variable gets worse
276 | WorseTerm CoreExpr CoreExpr -- term gets worse
277 | WorseLam Var Var -- lambda gets worse
279 instance Outputable WorseErr where
280 ppr (WorseVar v0 v) = ptext SLIT("Identifier:") <+> ppr v0 <+> dcolon
281 <+> ( ptext SLIT("was") <+> ppr (varType v0)
282 $$ ptext SLIT("now") <+> ppr (varType v))
283 ppr (WorseTerm e0 e) = ptext SLIT("Term:")
284 <+> ( ptext SLIT("was") <+> ppr e0
285 $$ ptext SLIT("now") <+> ppr e)
286 ppr (WorseLam v0 v) = ptext SLIT("Lambda:")
288 $$ ptext SLIT("(lambda-bound var info for var worsened)"))
294 checkIfWorseUSP :: [CoreBind] -- old binds
295 -> [CoreBind] -- new binds
296 -> Maybe SDoc -- maybe warnings
298 checkIfWorseUSP binds binds'
299 = let vvs = checkBinds binds binds'
300 in if isEmptyBag vvs then
303 Just $ ptext SLIT("UsageSP warning: annotations worsen for")
304 $$ nest 4 (vcat (map ppr (bagToList vvs)))
306 checkBinds :: [CoreBind] -> [CoreBind] -> Bag WorseErr
307 checkBinds binds binds' = unionManyBags $
308 zipWithEqual "UsageSPLint.checkBinds" checkBind binds binds'
310 checkBind :: CoreBind -> CoreBind -> Bag WorseErr
311 checkBind (NonRec v e) (NonRec v' e') = (checkVar v v') `unionBags` (checkCE e e')
312 checkBind (Rec ves) (Rec ves') = unionManyBags $
313 zipWithEqual "UsageSPLint.checkBind"
314 (\ (v,e) (v',e') -> (checkVar v v')
315 `unionBags` (checkCE e e'))
317 checkBind _ _ = panic "UsageSPLint.checkBind"
320 checkCE :: CoreExpr -> CoreExpr -> Bag WorseErr
322 checkCE (Var _) (Var _) = emptyBag
323 checkCE (Lit _) (Lit _) = emptyBag
325 checkCE (App e arg) (App e' arg') = (checkCE e e')
326 `unionBags` (checkCE arg arg')
328 checkCE (Lam v e) (Lam v' e') = (checkVar v v')
329 `unionBags` (checkLamVar v v')
330 `unionBags` (checkCE e e')
332 checkCE (Let bind e) (Let bind' e') = (checkBind bind bind')
333 `unionBags` (checkCE e e')
335 checkCE (Case e v alts) (Case e' v' alts')
337 `unionBags` (checkVar v v')
338 `unionBags` (unionManyBags $
339 zipWithEqual "usageSPLint.checkCE:Case"
340 checkAlts alts alts')
341 where checkAlts (_,vs,e) (_,vs',e') = (unionManyBags $ zipWithEqual "UsageSPLint.checkCE:Alt"
343 `unionBags` (checkCE e e')
345 checkCE (Note (SCC _) e) (Note (SCC _) e') = checkCE e e'
347 checkCE (Note (Coerce _ _) e) (Note (Coerce _ _) e') = checkCE e e'
349 checkCE (Note InlineCall e) (Note InlineCall e') = checkCE e e'
351 checkCE (Note InlineMe e) (Note InlineMe e') = checkCE e e'
353 checkCE t@(Note (TermUsg u) e) t'@(Note (TermUsg u') e')
355 `unionBags` (checkUsg u u' (WorseTerm t t'))
357 checkCE (Type _) (Type _) = emptyBag
359 checkCE t t' = pprPanic "usageSPLint.checkCE:"
360 (ppr t $$ text "doesn't match" <+> ppr t')
363 -- does binder change from Once to Many?
364 -- notice we only check the top-level annotation; this is all that's necessary. KSW 1999-04.
365 checkVar :: Var -> Var -> Bag WorseErr
366 checkVar v v' | isTyVar v = emptyBag
367 | not (isUsgTy y) = emptyBag -- if initially no annot, definitely OK
368 | otherwise = checkUsg u u' (WorseVar v v')
374 -- does lambda change from Once to Many?
375 checkLamVar :: Var -> Var -> Bag WorseErr
376 checkLamVar v v' | isTyVar v = emptyBag
377 | otherwise = case (idLBVarInfo v, idLBVarInfo v') of
378 (NoLBVarInfo , _ ) -> emptyBag
379 (IsOneShotLambda, IsOneShotLambda) -> emptyBag
380 (IsOneShotLambda, NoLBVarInfo ) -> unitBag (WorseLam v v')
382 -- does term usage annotation change from Once to Many?
383 checkUsg :: UsageAnn -> UsageAnn -> WorseErr -> Bag WorseErr
384 checkUsg UsMany _ _ = emptyBag
385 checkUsg UsOnce UsOnce _ = emptyBag
386 checkUsg UsOnce UsMany err = unitBag err
389 ======================================================================
394 The errors (@ULintErr@s) are collected in the @ULintM@ monad, which
395 also tracks the location of the current type being checked.
398 data ULintErr = ULintErr SDoc String Type
400 pprULintErr :: ULintErr -> SDoc
401 pprULintErr (ULintErr loc s ty) = hang (text s <+> ptext SLIT("in") <+> loc <> ptext SLIT(":"))
405 newtype ULintM a = ULintM (SDoc -> (a,Bag ULintErr))
406 unULintM (ULintM f) = f
408 instance Monad ULintM where
409 m >>= f = ULintM $ \ loc -> let (a ,errs ) = (unULintM m) loc
410 (a',errs') = (unULintM (f a)) loc
411 in (a', errs `unionBags` errs')
412 return a = ULintM $ \ _ -> (a,emptyBag)
414 atLocULM :: SDoc -> ULintM a -> ULintM a
415 atLocULM loc m = ULintM $ \ _ -> (unULintM m) loc
417 errULM :: String -> Type -> ULintM ()
419 = ULintM $ \ loc -> ((),unitBag $ ULintErr loc err ty)
421 mayErrULM :: Bool -> String -> Type -> ULintM ()
423 = if f then errULM err ty else return ()
425 runULM :: ULintM a -> Maybe SDoc
426 runULM m = case (unULintM m) (panic "runULM: no location") of
427 (_,errs) -> if isEmptyBag errs
429 else Just (vcat (map pprULintErr (bagToList errs)))
431 END OF ENTIRELY-COMMENTED-OUT FILE -- KSW 2000-10-13 -}
434 ======================================================================