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