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 CoreFVs ( mustHaveLocalBinding )
22 import Rules ( RuleBase )
23 import TypeRep ( Type(..), TyNote(..) ) -- friend
24 import Type ( UsageAnn(..),
26 splitFunTy_maybe, splitFunTys, splitTyConApp_maybe,
27 mkUsgTy, splitUsgTy, isUsgTy, isNotUsgTy, unUsgTy, tyUsg,
28 splitUsForAllTys, substUsTy,
30 import PprType ( {- instance Outputable Type -} )
31 import TyCon ( tyConArgVrcs_maybe, isFunTyCon )
32 import Literal ( Literal(..), literalType )
33 import Var ( Var, UVar, varType, setVarType, mkUVar, modifyIdInfo )
34 import IdInfo ( setLBVarInfo, LBVarInfo(..) )
35 import Id ( isExportedId )
36 import Name ( isLocallyDefined )
39 import UniqSupply ( UniqSupply, UniqSM,
40 initUs, splitUniqSupply )
42 import Maybes ( expectJust )
43 import List ( unzip4 )
44 import CmdLineOpts ( opt_D_dump_usagesp, opt_DoUSPLinting )
45 import ErrUtils ( doIfSet, dumpIfSet )
46 import PprCore ( pprCoreBindings )
49 ======================================================================
51 -- **! wasn't I going to do something about not requiring annotations
52 -- to be correct on unpointed types and/or those without haskell pointers
58 For full details, see _Once Upon a Polymorphic Type_, University of
59 Glasgow Department of Computing Science Technical Report TR-1998-19,
60 December 1998, or the summary in POPL'99.
62 [** NEW VERSION NOW IMPLEMENTED; different from the papers
63 above. Hopefully to appear in PLDI'00, and Keith Wansbrough's
64 University of Cambridge PhD thesis, c. Sep 2000 **]
67 Inference is performed as follows:
69 1. Remove all manipulable[*] annotations.
71 2. Walk over the resulting term adding fresh UVar annotations,
72 applying the type rules and collecting the constraints.
74 3. Find the solution to the constraints and apply the substitution
75 to the annotations, leaving a @UVar@-free term.
77 [*] A manipulable annotation is one derived from the current source
78 module, as opposed to one derived from an import, which we are clearly
81 As in the paper, a ``tau-type'' is a type that does *not* have an
82 annotation on top (although it may have some inside), and a
83 ``sigma-type'' is one that does (i.e., is a tau-type with an
84 annotation added). Also, a ``rho-type'' is one that may have initial
85 ``\/u.''s. This conflicts with the totally unrelated usage of these
86 terms in the remainder of GHC. Caveat lector! KSW 1999-07.
89 The inference is done over a set of @CoreBind@s, and inside the IO
93 doUsageSPInf :: UniqSupply
96 -> IO ([CoreBind], Maybe RuleBase)
98 doUsageSPInf us binds local_rules
100 let binds1 = doUnAnnotBinds binds
102 dumpIfSet opt_D_dump_usagesp "UsageSPInf unannot'd" $
103 pprCoreBindings binds1
105 let ((binds2,ucs,_),_)
106 = initUs us (uniqSMMToUs (usgInfBinds emptyVarEnv binds1))
108 dumpIfSet opt_D_dump_usagesp "UsageSPInf annot'd" $
109 pprCoreBindings binds2
111 let ms = solveUCS ucs
114 Nothing -> panic "doUsageSPInf: insol. conset!"
115 binds3 = appUSubstBinds s binds2
117 doIfSet opt_DoUSPLinting $
118 do doLintUSPAnnotsBinds binds3 -- lint check 1
119 doLintUSPConstBinds binds3 -- lint check 2 (force solution)
120 doCheckIfWorseUSP binds binds3 -- check for worsening of usages
122 dumpIfSet opt_D_dump_usagesp "UsageSPInf" $
123 pprCoreBindings binds3
125 return (binds3, Nothing)
128 ======================================================================
130 Inferring an expression
131 ~~~~~~~~~~~~~~~~~~~~~~~
133 Inference takes an annotated (rho-typed) environment and an expression
134 unannotated except for variables not appearing in the environment. It
135 returns an annotated expression, a type, a constraint set, and a
136 multiset of free variables. It is in the unique supply monad, which
137 supplies fresh uvars for annotation.
139 We conflate usage metavariables and usage variables; the latter are
140 distinguished by falling within the scope of a usage binder.
143 usgInfBinds :: VarEnv Var -- incoming environment (usu. empty)
144 -> [CoreBind] -- CoreBinds in dependency order
145 -> UniqSMM ([CoreBind], -- annotated CoreBinds
146 UConSet, -- constraint set
147 VarMultiset) -- usage of environment vars
154 usgInfBinds ve (b0:b0s)
155 -- (this clause is almost the same as the Let clause)
156 = do (v1s,ve1,b1,h1,fb1,fa1) <- usgInfBind ve b0
157 (b2s,h2,f2) <- usgInfBinds ve1 b0s
158 let h3 = occChksUConSet v1s (fb1 `plusMS` f2)
160 unionUCSs [h1,h2,h3],
161 fa1 `plusMS` (f2 `delsFromMS` v1s))
164 usgInfBind :: VarEnv Var
165 -> CoreBind -- CoreBind to infer for
166 -> UniqSMM ([Var], -- variables bound
167 VarEnv Var, -- extended VarEnv
168 CoreBind, -- annotated CoreBind
169 UConSet, -- constraints generated by this CoreBind
170 VarMultiset, -- this bd's use of vars bound in this bd
171 -- (could be anything for other vars)
172 VarMultiset) -- this bd's use of other vars
174 usgInfBind ve (NonRec v1 e1)
175 = do (v1',y1u) <- annotVar v1
176 (e2,y2u,h2,f2) <- usgInfCE (extendVarEnv ve v1 v1') e1
177 let h3 = usgSubTy y2u y1u
178 h4 = h2 `unionUCS` h3
179 (y4r,h4') = usgClos ve y2u h4
180 v1'' = setVarType v1 y4r
181 h5 = if isExportedId v1 then pessimise y4r else emptyUConSet
183 extendVarEnv ve v1 v1'',
189 usgInfBind ve (Rec ves)
190 = do let (v1s,e1s) = unzip ves
191 vy1s' <- mapM annotVar v1s
192 let (v1s',y1us) = unzip vy1s'
193 ve' = ve `plusVarEnv` (zipVarEnv v1s v1s')
194 eyhf2s <- mapM (usgInfCE ve') e1s
195 let (e2s,y2us,h2s,f2s) = unzip4 eyhf2s
196 h3s = zipWith usgSubTy y2us y1us
197 h4s = zipWith unionUCS h2s h3s
198 yh4s = zipWith (usgClos ve) y2us h4s
199 (y4rs,h4s') = unzip yh4s
200 v1s'' = zipWith setVarType v1s y4rs
201 f5 = foldl plusMS emptyMS f2s
202 h6s = zipWith (\ v y -> if isExportedId v then pessimise y else emptyUConSet)
205 ve `plusVarEnv` (zipVarEnv v1s v1s''),
207 unionUCSs (h4s' ++ h6s),
209 f5 `delsFromMS` v1s') -- we take pains that v1'==v1'' etc
212 usgInfCE :: VarEnv Var -- unannotated -> annotated vars
213 -> CoreExpr -- expression to annotate / infer
214 -> UniqSMM (CoreExpr, -- annotated expression (e)
215 Type, -- (sigma) type of expression (y)(u=sigma)(r=rho)
216 UConSet, -- set of constraints arising (h)
217 VarMultiset) -- variable occurrences (f)
219 usgInfCE ve e0@(Var v) | isTyVar v
220 = panic "usgInfCE: unexpected TyVar"
222 = do v' <- instVar (lookupVar ve v)
223 return $ ASSERT( isUsgTy (varType v' {-'cpp-}) )
229 usgInfCE ve e0@(Lit lit)
230 = do u1 <- newVarUSMM (Left e0)
232 mkUsgTy u1 (literalType lit),
236 {- ------------------------------------
237 No Con form now; we rely on usage information in the constructor itself
239 usgInfCE ve e0@(Con con args)
240 = -- constant or primop. guaranteed saturated.
241 do let (ey1s,e1s) = span isTypeArg args
242 y1s <- mapM (\ (Type ty) -> annotTyN (Left e0) ty) ey1s -- univ. + exist.
243 (y2us,y2u) <- case con of
244 DataCon c -> do u2 <- newVarUSMM (Left e0)
245 return $ dataConTys c u2 y1s
246 -- y1s is exdicts + args
247 PrimOp p -> return $ primOpUsgTys p y1s
248 otherwise -> panic "usgInfCE: unrecognised Con"
249 eyhf3s <- mapM (usgInfCE ve) e1s
250 let (e3s,y3us,h3s,f3s) = unzip4 eyhf3s
251 h4s = zipWith usgSubTy y3us y2us
252 return $ ASSERT( isUsgTy y2u )
253 (Con con (map Type y1s ++ e3s),
255 unionUCSs (h3s ++ h4s),
256 foldl plusMS emptyMS f3s)
258 whered ataConTys c u y1s
259 -- compute argtys of a datacon
260 = let cTy = annotMany (dataConType c) -- extra (sigma) annots later replaced
261 (y2us,y2u) = splitFunTys (applyTys cTy y1s)
262 -- safe 'cos a DataCon always returns a value of type (TyCon tys),
263 -- not an arrow type.
264 reUsg = mkUsgTy u . unUsgTy
265 in (map reUsg y2us, reUsg y2u)
266 -------------------------------------------- -}
269 usgInfCE ve e0@(App ea (Type yb))
270 = do (ea1,ya1u,ha1,fa1) <- usgInfCE ve ea
271 let (u1,ya1) = splitUsgTy ya1u
272 yb1 <- annotTyN (Left e0) yb
273 return (App ea1 (Type yb1),
274 mkUsgTy u1 (applyTy ya1 yb1),
278 usgInfCE ve (App ea eb)
279 = do (ea1,ya1u,ha1,fa1) <- usgInfCE ve ea
280 let ( u1,ya1) = splitUsgTy ya1u
281 (y2u,y3u) = expectJust "usgInfCE:App" $ splitFunTy_maybe ya1
282 (eb1,yb1u,hb1,fb1) <- usgInfCE ve eb
283 let h4 = usgSubTy yb1u y2u
284 return $ ASSERT( isUsgTy y3u )
287 unionUCSs [ha1,hb1,h4],
290 usgInfCE ve e0@(Lam v0 e) | isTyVar v0
291 = do (e1,y1u,h1,f1) <- usgInfCE ve e
292 let (u1,y1) = splitUsgTy y1u
294 mkUsgTy u1 (mkForAllTy v0 y1),
299 -- if used for checking also, may need to extend this case to
300 -- look in lbvarInfo instead.
302 = do u1 <- newVarUSMM (Left e0)
303 (v1,y1u) <- annotVar v0
304 (e2,y2u,h2,f2) <- usgInfCE (extendVarEnv ve v0 v1) e
305 let h3 = occChkUConSet v1 f2
306 f2' = f2 `delFromMS` v1
307 h4s = foldMS (\ v _ hs -> (leqUConSet u1 ((tyUsg . varType . lookupVar ve) v)
308 : hs)) -- in reverse order!
311 return (Note (TermUsg u1) (Lam v1 e2), -- add annot for lbVarInfo computation
312 mkUsgTy u1 (mkFunTy y1u y2u),
313 unionUCSs (h2:h3:h4s),
316 usgInfCE ve (Let b0s e0)
317 = do (v1s,ve1,b1s,h1,fb1,fa1) <- usgInfBind ve b0s
318 (e2,y2u,h2,f2) <- usgInfCE ve1 e0
319 let h3 = occChksUConSet v1s (fb1 `plusMS` f2)
320 return $ ASSERT( isUsgTy y2u )
323 unionUCSs [h1,h2,h3],
324 fa1 `plusMS` (f2 `delsFromMS` v1s))
326 usgInfCE ve (Case e0 v0 [(DEFAULT,[],e1)])
327 -- pure strict let, no selection (could be at polymorphic or function type)
328 = do (v1,y1u) <- annotVar v0
329 (e2,y2u,h2,f2) <- usgInfCE ve e0
330 (e3,y3u,h3,f3) <- usgInfCE (extendVarEnv ve v0 v1) e1
331 let h4 = usgEqTy y2u y1u -- **! why not subty?
332 h5 = occChkUConSet v1 f3
333 return $ ASSERT( isUsgTy y3u )
334 (Case e2 v1 [(DEFAULT,[],e3)],
336 unionUCSs [h2,h3,h4,h5],
337 f2 `plusMS` (f3 `delFromMS` v1))
339 usgInfCE ve e0@(Case e1 v1 alts)
340 -- general case (tycon of scrutinee must be known)
341 -- (assumes well-typed already; so doesn't check constructor)
342 = do (v2,y1u) <- annotVar v1
343 (e2,y2u,h2,f2) <- usgInfCE ve e1
344 let h3 = usgEqTy y2u y1u -- **! why not subty?
345 (u2,y2) = splitUsgTy y2u
346 (tc,y2s) = expectJust "usgInfCE:Case" $ splitTyConApp_maybe y2
347 (cs,v1ss,es) = unzip3 alts
348 v2ss = map (map (\ v -> setVarType v (mkUsgTy u2 (annotManyN (varType v)))))
350 ve3 = extendVarEnv ve v1 v2
351 eyhf4s <- mapM (\ (v1s,v2s,e) -> usgInfCE (ve3 `plusVarEnv` (zipVarEnv v1s v2s)) e)
353 let (e4s,y4us,h4s,f4s) = unzip4 eyhf4s
354 y5u <- annotTy (Left e0) (unannotTy (head y4us))
355 let h5s = zipWith usgSubTy y4us (repeat y5u)
356 h6s = zipWith occChksUConSet v2ss f4s
357 f4 = foldl1 maxMS (zipWith delsFromMS f4s v2ss)
358 h7 = occChkUConSet v2 (f4 `plusMS` (unitMS v2))
359 return $ ASSERT( isUsgTy y5u )
360 (Case e2 v2 (zip3 cs v2ss e4s),
362 unionUCSs (h2:h3:h7:(h4s ++ h5s ++ h6s)),
363 f2 `plusMS` (f4 `delFromMS` v2))
365 usgInfCE ve e0@(Note note ea)
366 = do (e1,y1u,h1,f1) <- usgInfCE ve ea
368 Coerce yb ya -> do let (u1,y1) = splitUsgTy y1u
369 ya3 = annotManyN ya -- really nasty type
370 h3 = usgEqTy y1 ya3 -- messy but OK
371 yb3 <- annotTyN (Left e0) yb
372 -- What this says is that a Coerce does the most general possible
373 -- annotation to what's inside it (nasty, nasty), because no information
374 -- can pass through a Coerce. It of course simply ignores the info
375 -- that filters down through into ty1, because it can do nothing with it.
376 -- It does still pass through the topmost usage annotation, though.
377 return (Note (Coerce yb3 ya3) e1,
382 SCC _ -> return (Note note e1, y1u, h1, f1)
384 InlineCall -> return (Note note e1, y1u, h1, f1)
386 InlineMe -> return (Note note e1, y1u, h1, f1)
388 TermUsg _ -> pprPanic "usgInfCE:Note TermUsg" $ ppr e0
390 usgInfCE ve e0@(Type _)
391 = pprPanic "usgInfCE:Type" $ ppr e0
396 lookupVar :: VarEnv Var -> Var -> Var
397 -- if variable in VarEnv then return annotated version,
398 -- otherwise it's imported and already annotated so leave alone.
399 --lookupVar ve v = error "lookupVar unimplemented"
400 lookupVar ve v = case lookupVarEnv ve v of
402 Nothing -> ASSERT( not (mustHaveLocalBinding v) )
403 ASSERT( isUsgTy (varType v) )
406 instVar :: Var -> UniqSMM Var
407 -- instantiate variable with rho-type, giving it a fresh sigma-type
408 instVar v = do let (uvs,ty) = splitUsForAllTys (varType v)
411 _ -> do uvs' <- mapM (\_ -> newVarUSMM (Left (Var v))) uvs
412 let ty' = substUsTy (zipVarEnv uvs uvs') ty
413 return (setVarType v ty')
415 annotVar :: Var -> UniqSMM (Var,Type)
416 -- freshly annotates a variable and returns it along with its new type
417 annotVar v = do y1u <- annotTy (Left (Var v)) (varType v)
418 return (setVarType v y1u, y1u)
422 The closure operation, which does the generalisation at let bindings.
425 usgClos :: VarEnv Var -- environment to close with respect to
426 -> Type -- type to close (sigma)
427 -> UConSet -- constraint set to reduce
428 -> (Type, -- closed type (rho)
429 UConSet) -- residual constraint set
431 usgClos zz_ve ty ucs = (ty,ucs) -- dummy definition; no generalisation at all
433 -- hmm! what if it sets some uvars to 1 or omega?
434 -- (should it do substitution here, or return a substitution,
435 -- or should it leave all that work to the end and just use
436 -- an "=" constraint here for now?)
439 The pessimise operation, which generates constraints to pessimise an
440 id (applied to exported ids, to ensure that they have fully general
441 types, since we don't know how they will be used in other modules).
444 pessimise :: Type -> UConSet
447 = pess True emptyVarEnv ty
450 pess :: Bool -> UVarSet -> Type -> UConSet
451 pess co ve (NoteTy (UsgForAll uv) ty)
452 = pess co (ve `extendVarSet` uv) ty
453 pess co ve ty0@(NoteTy (UsgNote u) ty)
454 = pessN co ve ty `unionUCS`
456 (False,_ ) -> emptyUConSet
457 (True ,UsMany ) -> emptyUConSet
458 (True ,UsOnce ) -> pprPanic "pessimise: can't force:" (ppr ty0)
459 (True ,UsVar uv) -> if uv `elemVarSet` ve
460 then emptyUConSet -- if bound by \/u, no need to pessimise
461 else eqManyUConSet u)
463 = pprPanic "pessimise: missing annot:" (ppr ty0)
465 pessN :: Bool -> UVarSet -> Type -> UConSet
466 pessN co ve (NoteTy (UsgForAll uv) ty) = pessN co (ve `extendVarSet` uv) ty
467 pessN co ve ty0@(NoteTy (UsgNote _) _ ) = pprPanic "pessimise: unexpected annot:" (ppr ty0)
468 pessN co ve (NoteTy (SynNote sty) ty) = pessN co ve sty `unionUCS` pessN co ve ty
469 pessN co ve (NoteTy (FTVNote _) ty) = pessN co ve ty
470 pessN co ve (TyVarTy _) = emptyUConSet
471 pessN co ve (AppTy _ _) = emptyUConSet
472 pessN co ve (TyConApp tc tys) = ASSERT( not((isFunTyCon tc)&&(length tys > 1)) )
474 pessN co ve (FunTy ty1 ty2) = pess (not co) ve ty1 `unionUCS` pess co ve ty2
475 pessN co ve (ForAllTy _ ty) = pessN co ve ty
480 ======================================================================
485 If a variable appears more than once in an fv set, force its usage to be Many.
492 occChkUConSet v fv = if occInMS v fv > 1
493 then ASSERT2( isUsgTy (varType v), ppr v )
494 eqManyUConSet ((tyUsg . varType) v)
497 occChksUConSet :: [Var]
501 occChksUConSet vs fv = unionUCSs (map (\v -> occChkUConSet v fv) vs)
505 Subtyping and equal-typing relations. These generate constraint sets.
506 Both assume their arguments are annotated correctly, and are either
507 both tau-types or both sigma-types (in fact, are both exactly the same
511 usgSubTy ty1 ty2 = genUsgCmpTy cmp ty1 ty2
512 where cmp u1 u2 = leqUConSet u2 u1
514 usgEqTy ty1 ty2 = genUsgCmpTy cmp ty1 ty2 -- **NB** doesn't equate tyconargs that
515 -- don't appear (see below)
516 where cmp u1 u2 = eqUConSet u1 u2
518 genUsgCmpTy :: (UsageAnn -> UsageAnn -> UConSet) -- constraint (u1 REL u2), respectively
523 genUsgCmpTy cmp (NoteTy (UsgNote u1) ty1) (NoteTy (UsgNote u2) ty2)
524 = cmp u1 u2 `unionUCS` genUsgCmpTy cmp ty1 ty2
527 -- deal with omitted == UsMany
528 genUsgCmpTy cmp (NoteTy (UsgNote u1) ty1) ty2
529 = cmp u1 UsMany `unionUCS` genUsgCmpTy cmp ty1 ty2
530 genUsgCmpTy cmp ty1 (NoteTy (UsgNote u2) ty2)
531 = cmp UsMany u2 `unionUCS` genUsgCmpTy cmp ty1 ty2
534 genUsgCmpTy cmp (NoteTy (SynNote sty1) ty1) (NoteTy (SynNote sty2) ty2)
535 = genUsgCmpTy cmp sty1 sty2 `unionUCS` genUsgCmpTy cmp ty1 ty2
536 -- **! is this right? or should I throw away synonyms, or sth else?
538 -- if SynNote only on one side, throw it out
539 genUsgCmpTy cmp (NoteTy (SynNote sty1) ty1) ty2
540 = genUsgCmpTy cmp ty1 ty2
541 genUsgCmpTy cmp ty1 (NoteTy (SynNote sty2) ty2)
542 = genUsgCmpTy cmp ty1 ty2
545 genUsgCmpTy cmp (NoteTy (FTVNote _) ty1) ty2
546 = genUsgCmpTy cmp ty1 ty2
547 genUsgCmpTy cmp ty1 (NoteTy (FTVNote _) ty2)
548 = genUsgCmpTy cmp ty1 ty2
550 genUsgCmpTy cmp (TyVarTy _) (TyVarTy _)
553 genUsgCmpTy cmp (AppTy tya1 tyb1) (AppTy tya2 tyb2)
554 = unionUCSs [genUsgCmpTy cmp tya1 tya2,
555 genUsgCmpTy cmp tyb1 tyb2, -- note, *both* ways for arg, since fun (prob) unknown
556 genUsgCmpTy cmp tyb2 tyb1]
558 genUsgCmpTy cmp (TyConApp tc1 ty1s) (TyConApp tc2 ty2s)
559 = case tyConArgVrcs_maybe tc1 of
560 Just oi -> unionUCSs (zipWith3 (\ ty1 ty2 (occPos,occNeg) ->
561 -- strictly this is wasteful (and possibly dangerous) for
562 -- usgEqTy, but I think it's OK. KSW 1999-04.
563 (if occPos then genUsgCmpTy cmp ty1 ty2 else emptyUConSet)
565 (if occNeg then genUsgCmpTy cmp ty2 ty1 else emptyUConSet))
567 Nothing -> panic ("genUsgCmpTy: variance info unavailable for " ++ showSDoc (ppr tc1))
569 genUsgCmpTy cmp (FunTy tya1 tyb1) (FunTy tya2 tyb2)
570 = genUsgCmpTy cmp tya2 tya1 `unionUCS` genUsgCmpTy cmp tyb1 tyb2 -- contravariance of arrow
572 genUsgCmpTy cmp (ForAllTy _ ty1) (ForAllTy _ ty2)
573 = genUsgCmpTy cmp ty1 ty2
575 genUsgCmpTy cmp ty1 ty2
576 = pprPanic "genUsgCmpTy: type shapes don't match" $
577 vcat [ppr ty1, ppr ty2]
581 Applying a substitution to all @UVar@s. This also moves @TermUsg@
582 notes on lambdas into the @lbvarInfo@ field of the binder. This
583 latter is a hack. KSW 1999-04.
586 appUSubstTy :: (UVar -> UsageAnn)
590 appUSubstTy s (NoteTy (UsgNote (UsVar uv)) ty)
591 = mkUsgTy (s uv) (appUSubstTy s ty)
592 appUSubstTy s (NoteTy note@(UsgNote _) ty) = NoteTy note (appUSubstTy s ty)
593 appUSubstTy s (NoteTy note@(SynNote _) ty) = NoteTy note (appUSubstTy s ty)
594 appUSubstTy s (NoteTy note@(FTVNote _) ty) = NoteTy note (appUSubstTy s ty)
595 appUSubstTy s ty@(TyVarTy _) = ty
596 appUSubstTy s (AppTy ty1 ty2) = AppTy (appUSubstTy s ty1) (appUSubstTy s ty2)
597 appUSubstTy s (TyConApp tc tys) = TyConApp tc (map (appUSubstTy s) tys)
598 appUSubstTy s (FunTy ty1 ty2) = FunTy (appUSubstTy s ty1) (appUSubstTy s ty2)
599 appUSubstTy s (ForAllTy tyv ty) = ForAllTy tyv (appUSubstTy s ty)
602 appUSubstBinds :: (UVar -> UsageAnn)
606 appUSubstBinds s binds = fst $ initAnnotM () $
607 genAnnotBinds mungeType mungeTerm binds
608 where mungeType _ ty = -- simply perform substitution
609 return (appUSubstTy s ty)
611 mungeTerm (Note (TermUsg (UsVar uv)) (Lam v e))
612 -- perform substitution *and* munge annot on lambda into IdInfo.lbvarInfo
613 = let lb = case (s uv) of { UsOnce -> IsOneShotLambda; UsMany -> NoLBVarInfo }
614 v' = modifyIdInfo (`setLBVarInfo` lb) v -- HACK ALERT!
615 -- see comment in IdInfo.lhs; this is because the info is easier to
616 -- access here, by agreement SLPJ/KSW 1999-04 (as a "short-term hack").
618 -- really should be: return (Note (TermUsg (s uv)) (Lam v e))
619 mungeTerm e@(Lam _ _) = return e
620 mungeTerm e = panic "appUSubstBinds: mungeTerm:" (ppr e)
624 A @VarMultiset@ is what it says: a set of variables with counts
625 attached to them. We build one out of a @VarEnv@.
628 type VarMultiset = VarEnv (Var,Int) -- I guess 536 870 911 occurrences is enough
630 emptyMS = emptyVarEnv
631 unitMS v = unitVarEnv v (v,1)
632 delFromMS = delVarEnv
633 delsFromMS = delVarEnvList
634 plusMS :: VarMultiset -> VarMultiset -> VarMultiset
635 plusMS = plusVarEnv_C (\ (v,n) (_,m) -> (v,n+m))
636 maxMS :: VarMultiset -> VarMultiset -> VarMultiset
637 maxMS = plusVarEnv_C (\ (v,n) (_,m) -> (v,max n m))
638 mapMS f = mapVarEnv (\ (v,n) -> f v n)
639 foldMS f = foldVarEnv (\ (v,n) a -> f v n a)
640 occInMS v ms = case lookupVarEnv ms v of
645 And a function used in debugging. It may give false positives with -DUSMANY turned off.
648 isUnAnnotated :: Type -> Bool
650 isUnAnnotated (NoteTy (UsgNote _ ) _ ) = False
651 isUnAnnotated (NoteTy (SynNote sty) ty) = isUnAnnotated sty && isUnAnnotated ty
652 isUnAnnotated (NoteTy (FTVNote _ ) ty) = isUnAnnotated ty
653 isUnAnnotated (TyVarTy _) = True
654 isUnAnnotated (AppTy ty1 ty2) = isUnAnnotated ty1 && isUnAnnotated ty2
655 isUnAnnotated (TyConApp tc tys) = all isUnAnnotated tys
656 isUnAnnotated (FunTy ty1 ty2) = isUnAnnotated ty1 && isUnAnnotated ty2
657 isUnAnnotated (ForAllTy tyv ty) = isUnAnnotated ty
660 ======================================================================