2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
4 \section[UsageSPInf]{UsageSP Inference Engine}
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-07-06
12 module UsageSPInf ( doUsageSPInf ) where
14 #include "HsVersions.h"
21 import TypeRep ( Type(..), TyNote(..) ) -- friend
22 import Type ( UsageAnn(..),
24 splitFunTy_maybe, splitFunTys, splitTyConApp_maybe,
25 mkUsgTy, splitUsgTy, isUsgTy, isNotUsgTy, unUsgTy, tyUsg,
26 splitUsForAllTys, substUsTy,
28 import PprType ( {- instance Outputable Type -} )
29 import TyCon ( tyConArgVrcs_maybe, isFunTyCon )
30 import Literal ( Literal(..), literalType )
31 import Var ( Var, UVar, varType, setVarType, mkUVar, modifyIdInfo )
32 import IdInfo ( setLBVarInfo, LBVarInfo(..) )
33 import Id ( mayHaveNoBinding, isExportedId )
34 import Name ( isLocallyDefined )
37 import UniqSupply ( UniqSupply, UniqSM,
38 initUs, splitUniqSupply )
40 import Maybes ( expectJust )
41 import List ( unzip4 )
42 import CmdLineOpts ( opt_D_dump_usagesp, opt_DoUSPLinting )
43 import ErrUtils ( doIfSet, dumpIfSet )
44 import PprCore ( pprCoreBindings )
47 ======================================================================
49 -- **! wasn't I going to do something about not requiring annotations
50 -- to be correct on unpointed types and/or those without haskell pointers
56 For full details, see _Once Upon a Polymorphic Type_, University of
57 Glasgow Department of Computing Science Technical Report TR-1998-19,
58 December 1998, or the summary in POPL'99.
60 [** NEW VERSION NOW IMPLEMENTED; different from the papers
61 above. Hopefully to appear in PLDI'00, and Keith Wansbrough's
62 University of Cambridge PhD thesis, c. Sep 2000 **]
65 Inference is performed as follows:
67 1. Remove all manipulable[*] annotations.
69 2. Walk over the resulting term adding fresh UVar annotations,
70 applying the type rules and collecting the constraints.
72 3. Find the solution to the constraints and apply the substitution
73 to the annotations, leaving a @UVar@-free term.
75 [*] A manipulable annotation is one derived from the current source
76 module, as opposed to one derived from an import, which we are clearly
79 As in the paper, a ``tau-type'' is a type that does *not* have an
80 annotation on top (although it may have some inside), and a
81 ``sigma-type'' is one that does (i.e., is a tau-type with an
82 annotation added). Also, a ``rho-type'' is one that may have initial
83 ``\/u.''s. This conflicts with the totally unrelated usage of these
84 terms in the remainder of GHC. Caveat lector! KSW 1999-07.
87 The inference is done over a set of @CoreBind@s, and inside the IO
91 doUsageSPInf :: UniqSupply
95 doUsageSPInf us binds = do
96 let binds1 = doUnAnnotBinds binds
98 dumpIfSet opt_D_dump_usagesp "UsageSPInf unannot'd" $
99 pprCoreBindings binds1
101 let ((binds2,ucs,_),_)
102 = initUs us (uniqSMMToUs (usgInfBinds emptyVarEnv binds1))
104 dumpIfSet opt_D_dump_usagesp "UsageSPInf annot'd" $
105 pprCoreBindings binds2
107 let ms = solveUCS ucs
110 Nothing -> panic "doUsageSPInf: insol. conset!"
111 binds3 = appUSubstBinds s binds2
113 doIfSet opt_DoUSPLinting $
114 do doLintUSPAnnotsBinds binds3 -- lint check 1
115 doLintUSPConstBinds binds3 -- lint check 2 (force solution)
116 doCheckIfWorseUSP binds binds3 -- check for worsening of usages
118 dumpIfSet opt_D_dump_usagesp "UsageSPInf" $
119 pprCoreBindings binds3
124 ======================================================================
126 Inferring an expression
127 ~~~~~~~~~~~~~~~~~~~~~~~
129 Inference takes an annotated (rho-typed) environment and an expression
130 unannotated except for variables not appearing in the environment. It
131 returns an annotated expression, a type, a constraint set, and a
132 multiset of free variables. It is in the unique supply monad, which
133 supplies fresh uvars for annotation.
135 We conflate usage metavariables and usage variables; the latter are
136 distinguished by falling within the scope of a usage binder.
139 usgInfBinds :: VarEnv Var -- incoming environment (usu. empty)
140 -> [CoreBind] -- CoreBinds in dependency order
141 -> UniqSMM ([CoreBind], -- annotated CoreBinds
142 UConSet, -- constraint set
143 VarMultiset) -- usage of environment vars
150 usgInfBinds ve (b0:b0s)
151 -- (this clause is almost the same as the Let clause)
152 = do (v1s,ve1,b1,h1,fb1,fa1) <- usgInfBind ve b0
153 (b2s,h2,f2) <- usgInfBinds ve1 b0s
154 let h3 = occChksUConSet v1s (fb1 `plusMS` f2)
156 unionUCSs [h1,h2,h3],
157 fa1 `plusMS` (f2 `delsFromMS` v1s))
160 usgInfBind :: VarEnv Var
161 -> CoreBind -- CoreBind to infer for
162 -> UniqSMM ([Var], -- variables bound
163 VarEnv Var, -- extended VarEnv
164 CoreBind, -- annotated CoreBind
165 UConSet, -- constraints generated by this CoreBind
166 VarMultiset, -- this bd's use of vars bound in this bd
167 -- (could be anything for other vars)
168 VarMultiset) -- this bd's use of other vars
170 usgInfBind ve (NonRec v1 e1)
171 = do (v1',y1u) <- annotVar v1
172 (e2,y2u,h2,f2) <- usgInfCE (extendVarEnv ve v1 v1') e1
173 let h3 = usgSubTy y2u y1u
174 h4 = h2 `unionUCS` h3
175 (y4r,h4') = usgClos ve y2u h4
176 v1'' = setVarType v1 y4r
177 h5 = if isExportedId v1 then pessimise y4r else emptyUConSet
179 extendVarEnv ve v1 v1'',
185 usgInfBind ve (Rec ves)
186 = do let (v1s,e1s) = unzip ves
187 vy1s' <- mapM annotVar v1s
188 let (v1s',y1us) = unzip vy1s'
189 ve' = ve `plusVarEnv` (zipVarEnv v1s v1s')
190 eyhf2s <- mapM (usgInfCE ve') e1s
191 let (e2s,y2us,h2s,f2s) = unzip4 eyhf2s
192 h3s = zipWith usgSubTy y2us y1us
193 h4s = zipWith unionUCS h2s h3s
194 yh4s = zipWith (usgClos ve) y2us h4s
195 (y4rs,h4s') = unzip yh4s
196 v1s'' = zipWith setVarType v1s y4rs
197 f5 = foldl plusMS emptyMS f2s
198 h6s = zipWith (\ v y -> if isExportedId v then pessimise y else emptyUConSet)
201 ve `plusVarEnv` (zipVarEnv v1s v1s''),
203 unionUCSs (h4s' ++ h6s),
205 f5 `delsFromMS` v1s') -- we take pains that v1'==v1'' etc
208 usgInfCE :: VarEnv Var -- unannotated -> annotated vars
209 -> CoreExpr -- expression to annotate / infer
210 -> UniqSMM (CoreExpr, -- annotated expression (e)
211 Type, -- (sigma) type of expression (y)(u=sigma)(r=rho)
212 UConSet, -- set of constraints arising (h)
213 VarMultiset) -- variable occurrences (f)
215 usgInfCE ve e0@(Var v) | isTyVar v
216 = panic "usgInfCE: unexpected TyVar"
218 = do v' <- instVar (lookupVar ve v)
219 return $ ASSERT( isUsgTy (varType v' {-'cpp-}) )
225 usgInfCE ve e0@(Lit lit)
226 = do u1 <- newVarUSMM (Left e0)
228 mkUsgTy u1 (literalType lit),
232 {- ------------------------------------
233 No Con form now; we rely on usage information in the constructor itself
235 usgInfCE ve e0@(Con con args)
236 = -- constant or primop. guaranteed saturated.
237 do let (ey1s,e1s) = span isTypeArg args
238 y1s <- mapM (\ (Type ty) -> annotTyN (Left e0) ty) ey1s -- univ. + exist.
239 (y2us,y2u) <- case con of
240 DataCon c -> do u2 <- newVarUSMM (Left e0)
241 return $ dataConTys c u2 y1s
242 -- y1s is exdicts + args
243 PrimOp p -> return $ primOpUsgTys p y1s
244 otherwise -> panic "usgInfCE: unrecognised Con"
245 eyhf3s <- mapM (usgInfCE ve) e1s
246 let (e3s,y3us,h3s,f3s) = unzip4 eyhf3s
247 h4s = zipWith usgSubTy y3us y2us
248 return $ ASSERT( isUsgTy y2u )
249 (Con con (map Type y1s ++ e3s),
251 unionUCSs (h3s ++ h4s),
252 foldl plusMS emptyMS f3s)
254 whered ataConTys c u y1s
255 -- compute argtys of a datacon
256 = let cTy = annotMany (dataConType c) -- extra (sigma) annots later replaced
257 (y2us,y2u) = splitFunTys (applyTys cTy y1s)
258 -- safe 'cos a DataCon always returns a value of type (TyCon tys),
259 -- not an arrow type.
260 reUsg = mkUsgTy u . unUsgTy
261 in (map reUsg y2us, reUsg y2u)
262 -------------------------------------------- -}
265 usgInfCE ve e0@(App ea (Type yb))
266 = do (ea1,ya1u,ha1,fa1) <- usgInfCE ve ea
267 let (u1,ya1) = splitUsgTy ya1u
268 yb1 <- annotTyN (Left e0) yb
269 return (App ea1 (Type yb1),
270 mkUsgTy u1 (applyTy ya1 yb1),
274 usgInfCE ve (App ea eb)
275 = do (ea1,ya1u,ha1,fa1) <- usgInfCE ve ea
276 let ( u1,ya1) = splitUsgTy ya1u
277 (y2u,y3u) = expectJust "usgInfCE:App" $ splitFunTy_maybe ya1
278 (eb1,yb1u,hb1,fb1) <- usgInfCE ve eb
279 let h4 = usgSubTy yb1u y2u
280 return $ ASSERT( isUsgTy y3u )
283 unionUCSs [ha1,hb1,h4],
286 usgInfCE ve e0@(Lam v0 e) | isTyVar v0
287 = do (e1,y1u,h1,f1) <- usgInfCE ve e
288 let (u1,y1) = splitUsgTy y1u
290 mkUsgTy u1 (mkForAllTy v0 y1),
295 -- if used for checking also, may need to extend this case to
296 -- look in lbvarInfo instead.
298 = do u1 <- newVarUSMM (Left e0)
299 (v1,y1u) <- annotVar v0
300 (e2,y2u,h2,f2) <- usgInfCE (extendVarEnv ve v0 v1) e
301 let h3 = occChkUConSet v1 f2
302 f2' = f2 `delFromMS` v1
303 h4s = foldMS (\ v _ hs -> (leqUConSet u1 ((tyUsg . varType . lookupVar ve) v)
304 : hs)) -- in reverse order!
307 return (Note (TermUsg u1) (Lam v1 e2), -- add annot for lbVarInfo computation
308 mkUsgTy u1 (mkFunTy y1u y2u),
309 unionUCSs (h2:h3:h4s),
312 usgInfCE ve (Let b0s e0)
313 = do (v1s,ve1,b1s,h1,fb1,fa1) <- usgInfBind ve b0s
314 (e2,y2u,h2,f2) <- usgInfCE ve1 e0
315 let h3 = occChksUConSet v1s (fb1 `plusMS` f2)
316 return $ ASSERT( isUsgTy y2u )
319 unionUCSs [h1,h2,h3],
320 fa1 `plusMS` (f2 `delsFromMS` v1s))
322 usgInfCE ve (Case e0 v0 [(DEFAULT,[],e1)])
323 -- pure strict let, no selection (could be at polymorphic or function type)
324 = do (v1,y1u) <- annotVar v0
325 (e2,y2u,h2,f2) <- usgInfCE ve e0
326 (e3,y3u,h3,f3) <- usgInfCE (extendVarEnv ve v0 v1) e1
327 let h4 = usgEqTy y2u y1u -- **! why not subty?
328 h5 = occChkUConSet v1 f3
329 return $ ASSERT( isUsgTy y3u )
330 (Case e2 v1 [(DEFAULT,[],e3)],
332 unionUCSs [h2,h3,h4,h5],
333 f2 `plusMS` (f3 `delFromMS` v1))
335 usgInfCE ve e0@(Case e1 v1 alts)
336 -- general case (tycon of scrutinee must be known)
337 -- (assumes well-typed already; so doesn't check constructor)
338 = do (v2,y1u) <- annotVar v1
339 (e2,y2u,h2,f2) <- usgInfCE ve e1
340 let h3 = usgEqTy y2u y1u -- **! why not subty?
341 (u2,y2) = splitUsgTy y2u
342 (tc,y2s) = expectJust "usgInfCE:Case" $ splitTyConApp_maybe y2
343 (cs,v1ss,es) = unzip3 alts
344 v2ss = map (map (\ v -> setVarType v (mkUsgTy u2 (annotManyN (varType v)))))
346 ve3 = extendVarEnv ve v1 v2
347 eyhf4s <- mapM (\ (v1s,v2s,e) -> usgInfCE (ve3 `plusVarEnv` (zipVarEnv v1s v2s)) e)
349 let (e4s,y4us,h4s,f4s) = unzip4 eyhf4s
350 y5u <- annotTy (Left e0) (unannotTy (head y4us))
351 let h5s = zipWith usgSubTy y4us (repeat y5u)
352 h6s = zipWith occChksUConSet v2ss f4s
353 f4 = foldl1 maxMS (zipWith delsFromMS f4s v2ss)
354 h7 = occChkUConSet v2 (f4 `plusMS` (unitMS v2))
355 return $ ASSERT( isUsgTy y5u )
356 (Case e2 v2 (zip3 cs v2ss e4s),
358 unionUCSs (h2:h3:h7:(h4s ++ h5s ++ h6s)),
359 f2 `plusMS` (f4 `delFromMS` v2))
361 usgInfCE ve e0@(Note note ea)
362 = do (e1,y1u,h1,f1) <- usgInfCE ve ea
364 Coerce yb ya -> do let (u1,y1) = splitUsgTy y1u
365 ya3 = annotManyN ya -- really nasty type
366 h3 = usgEqTy y1 ya3 -- messy but OK
367 yb3 <- annotTyN (Left e0) yb
368 -- What this says is that a Coerce does the most general possible
369 -- annotation to what's inside it (nasty, nasty), because no information
370 -- can pass through a Coerce. It of course simply ignores the info
371 -- that filters down through into ty1, because it can do nothing with it.
372 -- It does still pass through the topmost usage annotation, though.
373 return (Note (Coerce yb3 ya3) e1,
378 SCC _ -> return (Note note e1, y1u, h1, f1)
380 InlineCall -> return (Note note e1, y1u, h1, f1)
382 InlineMe -> return (Note note e1, y1u, h1, f1)
384 TermUsg _ -> pprPanic "usgInfCE:Note TermUsg" $ ppr e0
386 usgInfCE ve e0@(Type _)
387 = pprPanic "usgInfCE:Type" $ ppr e0
392 lookupVar :: VarEnv Var -> Var -> Var
393 -- if variable in VarEnv then return annotated version,
394 -- otherwise it's imported and already annotated so leave alone.
395 --lookupVar ve v = error "lookupVar unimplemented"
396 lookupVar ve v = case lookupVarEnv ve v of
398 Nothing -> ASSERT( not (isLocallyDefined v) || (mayHaveNoBinding v) )
399 ASSERT( isUsgTy (varType v) )
402 instVar :: Var -> UniqSMM Var
403 -- instantiate variable with rho-type, giving it a fresh sigma-type
404 instVar v = do let (uvs,ty) = splitUsForAllTys (varType v)
407 _ -> do uvs' <- mapM (\_ -> newVarUSMM (Left (Var v))) uvs
408 let ty' = substUsTy (zipVarEnv uvs uvs') ty
409 return (setVarType v ty')
411 annotVar :: Var -> UniqSMM (Var,Type)
412 -- freshly annotates a variable and returns it along with its new type
413 annotVar v = do y1u <- annotTy (Left (Var v)) (varType v)
414 return (setVarType v y1u, y1u)
418 The closure operation, which does the generalisation at let bindings.
421 usgClos :: VarEnv Var -- environment to close with respect to
422 -> Type -- type to close (sigma)
423 -> UConSet -- constraint set to reduce
424 -> (Type, -- closed type (rho)
425 UConSet) -- residual constraint set
427 usgClos zz_ve ty ucs = (ty,ucs) -- dummy definition; no generalisation at all
429 -- hmm! what if it sets some uvars to 1 or omega?
430 -- (should it do substitution here, or return a substitution,
431 -- or should it leave all that work to the end and just use
432 -- an "=" constraint here for now?)
435 The pessimise operation, which generates constraints to pessimise an
436 id (applied to exported ids, to ensure that they have fully general
437 types, since we don't know how they will be used in other modules).
440 pessimise :: Type -> UConSet
443 = pess True emptyVarEnv ty
446 pess :: Bool -> UVarSet -> Type -> UConSet
447 pess co ve (NoteTy (UsgForAll uv) ty)
448 = pess co (ve `extendVarSet` uv) ty
449 pess co ve ty0@(NoteTy (UsgNote u) ty)
450 = pessN co ve ty `unionUCS`
452 (False,_ ) -> emptyUConSet
453 (True ,UsMany ) -> emptyUConSet
454 (True ,UsOnce ) -> pprPanic "pessimise: can't force:" (ppr ty0)
455 (True ,UsVar uv) -> if uv `elemVarSet` ve
456 then emptyUConSet -- if bound by \/u, no need to pessimise
457 else eqManyUConSet u)
459 = pprPanic "pessimise: missing annot:" (ppr ty0)
461 pessN :: Bool -> UVarSet -> Type -> UConSet
462 pessN co ve (NoteTy (UsgForAll uv) ty) = pessN co (ve `extendVarSet` uv) ty
463 pessN co ve ty0@(NoteTy (UsgNote _) _ ) = pprPanic "pessimise: unexpected annot:" (ppr ty0)
464 pessN co ve (NoteTy (SynNote sty) ty) = pessN co ve sty `unionUCS` pessN co ve ty
465 pessN co ve (NoteTy (FTVNote _) ty) = pessN co ve ty
466 pessN co ve (TyVarTy _) = emptyUConSet
467 pessN co ve (AppTy _ _) = emptyUConSet
468 pessN co ve (TyConApp tc tys) = ASSERT( not((isFunTyCon tc)&&(length tys > 1)) )
470 pessN co ve (FunTy ty1 ty2) = pess (not co) ve ty1 `unionUCS` pess co ve ty2
471 pessN co ve (ForAllTy _ ty) = pessN co ve ty
476 ======================================================================
481 If a variable appears more than once in an fv set, force its usage to be Many.
488 occChkUConSet v fv = if occInMS v fv > 1
489 then ASSERT2( isUsgTy (varType v), ppr v )
490 eqManyUConSet ((tyUsg . varType) v)
493 occChksUConSet :: [Var]
497 occChksUConSet vs fv = unionUCSs (map (\v -> occChkUConSet v fv) vs)
501 Subtyping and equal-typing relations. These generate constraint sets.
502 Both assume their arguments are annotated correctly, and are either
503 both tau-types or both sigma-types (in fact, are both exactly the same
507 usgSubTy ty1 ty2 = genUsgCmpTy cmp ty1 ty2
508 where cmp u1 u2 = leqUConSet u2 u1
510 usgEqTy ty1 ty2 = genUsgCmpTy cmp ty1 ty2 -- **NB** doesn't equate tyconargs that
511 -- don't appear (see below)
512 where cmp u1 u2 = eqUConSet u1 u2
514 genUsgCmpTy :: (UsageAnn -> UsageAnn -> UConSet) -- constraint (u1 REL u2), respectively
519 genUsgCmpTy cmp (NoteTy (UsgNote u1) ty1) (NoteTy (UsgNote u2) ty2)
520 = cmp u1 u2 `unionUCS` genUsgCmpTy cmp ty1 ty2
523 -- deal with omitted == UsMany
524 genUsgCmpTy cmp (NoteTy (UsgNote u1) ty1) ty2
525 = cmp u1 UsMany `unionUCS` genUsgCmpTy cmp ty1 ty2
526 genUsgCmpTy cmp ty1 (NoteTy (UsgNote u2) ty2)
527 = cmp UsMany u2 `unionUCS` genUsgCmpTy cmp ty1 ty2
530 genUsgCmpTy cmp (NoteTy (SynNote sty1) ty1) (NoteTy (SynNote sty2) ty2)
531 = genUsgCmpTy cmp sty1 sty2 `unionUCS` genUsgCmpTy cmp ty1 ty2
532 -- **! is this right? or should I throw away synonyms, or sth else?
534 -- if SynNote only on one side, throw it out
535 genUsgCmpTy cmp (NoteTy (SynNote sty1) ty1) ty2
536 = genUsgCmpTy cmp ty1 ty2
537 genUsgCmpTy cmp ty1 (NoteTy (SynNote sty2) ty2)
538 = genUsgCmpTy cmp ty1 ty2
541 genUsgCmpTy cmp (NoteTy (FTVNote _) ty1) ty2
542 = genUsgCmpTy cmp ty1 ty2
543 genUsgCmpTy cmp ty1 (NoteTy (FTVNote _) ty2)
544 = genUsgCmpTy cmp ty1 ty2
546 genUsgCmpTy cmp (TyVarTy _) (TyVarTy _)
549 genUsgCmpTy cmp (AppTy tya1 tyb1) (AppTy tya2 tyb2)
550 = unionUCSs [genUsgCmpTy cmp tya1 tya2,
551 genUsgCmpTy cmp tyb1 tyb2, -- note, *both* ways for arg, since fun (prob) unknown
552 genUsgCmpTy cmp tyb2 tyb1]
554 genUsgCmpTy cmp (TyConApp tc1 ty1s) (TyConApp tc2 ty2s)
555 = case tyConArgVrcs_maybe tc1 of
556 Just oi -> unionUCSs (zipWith3 (\ ty1 ty2 (occPos,occNeg) ->
557 -- strictly this is wasteful (and possibly dangerous) for
558 -- usgEqTy, but I think it's OK. KSW 1999-04.
559 (if occPos then genUsgCmpTy cmp ty1 ty2 else emptyUConSet)
561 (if occNeg then genUsgCmpTy cmp ty2 ty1 else emptyUConSet))
563 Nothing -> panic ("genUsgCmpTy: variance info unavailable for " ++ showSDoc (ppr tc1))
565 genUsgCmpTy cmp (FunTy tya1 tyb1) (FunTy tya2 tyb2)
566 = genUsgCmpTy cmp tya2 tya1 `unionUCS` genUsgCmpTy cmp tyb1 tyb2 -- contravariance of arrow
568 genUsgCmpTy cmp (ForAllTy _ ty1) (ForAllTy _ ty2)
569 = genUsgCmpTy cmp ty1 ty2
571 genUsgCmpTy cmp ty1 ty2
572 = pprPanic "genUsgCmpTy: type shapes don't match" $
573 vcat [ppr ty1, ppr ty2]
577 Applying a substitution to all @UVar@s. This also moves @TermUsg@
578 notes on lambdas into the @lbvarInfo@ field of the binder. This
579 latter is a hack. KSW 1999-04.
582 appUSubstTy :: (UVar -> UsageAnn)
586 appUSubstTy s (NoteTy (UsgNote (UsVar uv)) ty)
587 = mkUsgTy (s uv) (appUSubstTy s ty)
588 appUSubstTy s (NoteTy note@(UsgNote _) ty) = NoteTy note (appUSubstTy s ty)
589 appUSubstTy s (NoteTy note@(SynNote _) ty) = NoteTy note (appUSubstTy s ty)
590 appUSubstTy s (NoteTy note@(FTVNote _) ty) = NoteTy note (appUSubstTy s ty)
591 appUSubstTy s ty@(TyVarTy _) = ty
592 appUSubstTy s (AppTy ty1 ty2) = AppTy (appUSubstTy s ty1) (appUSubstTy s ty2)
593 appUSubstTy s (TyConApp tc tys) = TyConApp tc (map (appUSubstTy s) tys)
594 appUSubstTy s (FunTy ty1 ty2) = FunTy (appUSubstTy s ty1) (appUSubstTy s ty2)
595 appUSubstTy s (ForAllTy tyv ty) = ForAllTy tyv (appUSubstTy s ty)
598 appUSubstBinds :: (UVar -> UsageAnn)
602 appUSubstBinds s binds = fst $ initAnnotM () $
603 genAnnotBinds mungeType mungeTerm binds
604 where mungeType _ ty = -- simply perform substitution
605 return (appUSubstTy s ty)
607 mungeTerm (Note (TermUsg (UsVar uv)) (Lam v e))
608 -- perform substitution *and* munge annot on lambda into IdInfo.lbvarInfo
609 = let lb = case (s uv) of { UsOnce -> IsOneShotLambda; UsMany -> NoLBVarInfo }
610 v' = modifyIdInfo (`setLBVarInfo` lb) v -- HACK ALERT!
611 -- see comment in IdInfo.lhs; this is because the info is easier to
612 -- access here, by agreement SLPJ/KSW 1999-04 (as a "short-term hack").
614 -- really should be: return (Note (TermUsg (s uv)) (Lam v e))
615 mungeTerm e@(Lam _ _) = return e
616 mungeTerm e = panic "appUSubstBinds: mungeTerm:" (ppr e)
620 A @VarMultiset@ is what it says: a set of variables with counts
621 attached to them. We build one out of a @VarEnv@.
624 type VarMultiset = VarEnv (Var,Int) -- I guess 536 870 911 occurrences is enough
626 emptyMS = emptyVarEnv
627 unitMS v = unitVarEnv v (v,1)
628 delFromMS = delVarEnv
629 delsFromMS = delVarEnvList
630 plusMS :: VarMultiset -> VarMultiset -> VarMultiset
631 plusMS = plusVarEnv_C (\ (v,n) (_,m) -> (v,n+m))
632 maxMS :: VarMultiset -> VarMultiset -> VarMultiset
633 maxMS = plusVarEnv_C (\ (v,n) (_,m) -> (v,max n m))
634 mapMS f = mapVarEnv (\ (v,n) -> f v n)
635 foldMS f = foldVarEnv (\ (v,n) a -> f v n a)
636 occInMS v ms = case lookupVarEnv ms v of
641 And a function used in debugging. It may give false positives with -DUSMANY turned off.
644 isUnAnnotated :: Type -> Bool
646 isUnAnnotated (NoteTy (UsgNote _ ) _ ) = False
647 isUnAnnotated (NoteTy (SynNote sty) ty) = isUnAnnotated sty && isUnAnnotated ty
648 isUnAnnotated (NoteTy (FTVNote _ ) ty) = isUnAnnotated ty
649 isUnAnnotated (TyVarTy _) = True
650 isUnAnnotated (AppTy ty1 ty2) = isUnAnnotated ty1 && isUnAnnotated ty2
651 isUnAnnotated (TyConApp tc tys) = all isUnAnnotated tys
652 isUnAnnotated (FunTy ty1 ty2) = isUnAnnotated ty1 && isUnAnnotated ty2
653 isUnAnnotated (ForAllTy tyv ty) = isUnAnnotated ty
656 ======================================================================