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 Rules ( RuleBase )
22 import TypeRep ( Type(..), TyNote(..) ) -- friend
23 import Type ( applyTy, applyTys,
24 splitFunTy_maybe, splitFunTys, splitTyConApp,
26 import TyCon ( tyConArgVrcs_maybe, isFunTyCon )
27 import Literal ( Literal(..), literalType )
28 import Var ( Var, varType, setVarType, modifyIdInfo )
29 import IdInfo ( setLBVarInfo, LBVarInfo(..) )
30 import Id ( isExportedId )
33 import UniqSupply ( UniqSupply, UniqSM,
34 initUs, splitUniqSupply )
36 import Maybes ( expectJust )
37 import List ( unzip4 )
38 import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_UsageSPOn )
39 import CoreLint ( showPass, endPass )
40 import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn )
41 import PprCore ( pprCoreBindings )
44 ======================================================================
46 -- **! wasn't I going to do something about not requiring annotations
47 -- to be correct on unpointed types and/or those without haskell pointers
53 For full details, see _Once Upon a Polymorphic Type_, University of
54 Glasgow Department of Computing Science Technical Report TR-1998-19,
55 December 1998, or the summary in POPL'99.
57 [** NEW VERSION NOW IMPLEMENTED; different from the papers
58 above. Hopefully to appear in PLDI'00, and Keith Wansbrough's
59 University of Cambridge PhD thesis, c. Sep 2000 **]
62 Inference is performed as follows:
64 1. Remove all manipulable[*] annotations.
66 2. Walk over the resulting term adding fresh UVar annotations,
67 applying the type rules and collecting the constraints.
69 3. Find the solution to the constraints and apply the substitution
70 to the annotations, leaving a @UVar@-free term.
72 [*] A manipulable annotation is one derived from the current source
73 module, as opposed to one derived from an import, which we are clearly
76 As in the paper, a ``tau-type'' is a type that does *not* have an
77 annotation on top (although it may have some inside), and a
78 ``sigma-type'' is one that does (i.e., is a tau-type with an
79 annotation added). Also, a ``rho-type'' is one that may have initial
80 ``\/u.''s. This conflicts with the totally unrelated usage of these
81 terms in the remainder of GHC. Caveat lector! KSW 1999-07.
84 The inference is done over a set of @CoreBind@s, and inside the IO
88 doUsageSPInf :: DynFlags
93 doUsageSPInf dflags us binds
95 = do { printDump (text "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on") ;
99 {- ENTIRE PASS COMMENTED OUT FOR NOW -- KSW 2000-10-13
101 This monomorphic version of the analysis is outdated. I'm
102 currently ripping out the old one and inserting the new one. For
103 now, I'm simply commenting out this entire pass.
108 let binds1 = doUnAnnotBinds binds
110 showPass dflags "UsageSPInf"
112 dumpIfSet_dyn dflags Opt_D_dump_usagesp "UsageSPInf unannot'd" $
113 pprCoreBindings binds1
115 let ((binds2,ucs,_),_) = initUs us (uniqSMMToUs (usgInfBinds emptyVarEnv binds1))
117 dumpIfSet_dyn dflags Opt_D_dump_usagesp "UsageSPInf annot'd" $
118 pprCoreBindings binds2
120 let ms = solveUCS ucs
123 Nothing -> panic "doUsageSPInf: insol. conset!"
124 binds3 = appUSubstBinds s binds2
126 doIfSet_dyn dflags Opt_DoUSPLinting $
127 do doLintUSPAnnotsBinds binds3 -- lint check 1
128 doLintUSPConstBinds binds3 -- lint check 2 (force solution)
129 doCheckIfWorseUSP binds binds3 -- check for worsening of usages
131 endPass dflags "UsageSPInf" (dopt Opt_D_dump_usagesp dflags) binds3
136 ======================================================================
138 Inferring an expression
139 ~~~~~~~~~~~~~~~~~~~~~~~
141 Inference takes an annotated (rho-typed) environment and an expression
142 unannotated except for variables not appearing in the environment. It
143 returns an annotated expression, a type, a constraint set, and a
144 multiset of free variables. It is in the unique supply monad, which
145 supplies fresh uvars for annotation.
147 We conflate usage metavariables and usage variables; the latter are
148 distinguished by falling within the scope of a usage binder.
151 usgInfBinds :: VarEnv Var -- incoming environment (usu. empty)
152 -> [CoreBind] -- CoreBinds in dependency order
153 -> UniqSMM ([CoreBind], -- annotated CoreBinds
154 UConSet, -- constraint set
155 VarMultiset) -- usage of environment vars
162 usgInfBinds ve (b0:b0s)
163 -- (this clause is almost the same as the Let clause)
164 = do (v1s,ve1,b1,h1,fb1,fa1) <- usgInfBind ve b0
165 (b2s,h2,f2) <- usgInfBinds ve1 b0s
166 let h3 = occChksUConSet v1s (fb1 `plusMS` f2)
168 unionUCSs [h1,h2,h3],
169 fa1 `plusMS` (f2 `delsFromMS` v1s))
172 usgInfBind :: VarEnv Var
173 -> CoreBind -- CoreBind to infer for
174 -> UniqSMM ([Var], -- variables bound
175 VarEnv Var, -- extended VarEnv
176 CoreBind, -- annotated CoreBind
177 UConSet, -- constraints generated by this CoreBind
178 VarMultiset, -- this bd's use of vars bound in this bd
179 -- (could be anything for other vars)
180 VarMultiset) -- this bd's use of other vars
182 usgInfBind ve (NonRec v1 e1)
183 = do (v1',y1u) <- annotVar v1
184 (e2,y2u,h2,f2) <- usgInfCE (extendVarEnv ve v1 v1') e1
185 let h3 = usgSubTy y2u y1u
186 h4 = h2 `unionUCS` h3
187 (y4r,h4') = usgClos ve y2u h4
188 v1'' = setVarType v1 y4r
189 h5 = if isExportedId v1 then pessimise y4r else emptyUConSet
191 extendVarEnv ve v1 v1'',
197 usgInfBind ve (Rec ves)
198 = do let (v1s,e1s) = unzip ves
199 vy1s' <- mapM annotVar v1s
200 let (v1s',y1us) = unzip vy1s'
201 ve' = ve `plusVarEnv` (zipVarEnv v1s v1s')
202 eyhf2s <- mapM (usgInfCE ve') e1s
203 let (e2s,y2us,h2s,f2s) = unzip4 eyhf2s
204 h3s = zipWith usgSubTy y2us y1us
205 h4s = zipWith unionUCS h2s h3s
206 yh4s = zipWith (usgClos ve) y2us h4s
207 (y4rs,h4s') = unzip yh4s
208 v1s'' = zipWith setVarType v1s y4rs
209 f5 = foldl plusMS emptyMS f2s
210 h6s = zipWith (\ v y -> if isExportedId v then pessimise y else emptyUConSet)
213 ve `plusVarEnv` (zipVarEnv v1s v1s''),
215 unionUCSs (h4s' ++ h6s),
217 f5 `delsFromMS` v1s') -- we take pains that v1'==v1'' etc
220 usgInfCE :: VarEnv Var -- unannotated -> annotated vars
221 -> CoreExpr -- expression to annotate / infer
222 -> UniqSMM (CoreExpr, -- annotated expression (e)
223 Type, -- (sigma) type of expression (y)(u=sigma)(r=rho)
224 UConSet, -- set of constraints arising (h)
225 VarMultiset) -- variable occurrences (f)
227 usgInfCE ve e0@(Var v) | isTyVar v
228 = panic "usgInfCE: unexpected TyVar"
230 = do v' <- instVar (lookupVar ve v)
231 return $ ASSERT( isUsgTy (varType v' {-'cpp-}) )
237 usgInfCE ve e0@(Lit lit)
238 = do u1 <- newVarUSMM (Left e0)
240 mkUsgTy u1 (literalType lit),
244 {- ------------------------------------
245 No Con form now; we rely on usage information in the constructor itself
247 usgInfCE ve e0@(Con con args)
248 = -- constant or primop. guaranteed saturated.
249 do let (ey1s,e1s) = span isTypeArg args
250 y1s <- mapM (\ (Type ty) -> annotTyN (Left e0) ty) ey1s -- univ. + exist.
251 (y2us,y2u) <- case con of
252 DataCon c -> do u2 <- newVarUSMM (Left e0)
253 return $ dataConTys c u2 y1s
254 -- y1s is exdicts + args
255 PrimOp p -> return $ primOpUsgTys p y1s
256 otherwise -> panic "usgInfCE: unrecognised Con"
257 eyhf3s <- mapM (usgInfCE ve) e1s
258 let (e3s,y3us,h3s,f3s) = unzip4 eyhf3s
259 h4s = zipWith usgSubTy y3us y2us
260 return $ ASSERT( isUsgTy y2u )
261 (Con con (map Type y1s ++ e3s),
263 unionUCSs (h3s ++ h4s),
264 foldl plusMS emptyMS f3s)
266 whered ataConTys c u y1s
267 -- compute argtys of a datacon
268 = let cTy = annotMany (dataConType c) -- extra (sigma) annots later replaced
269 (y2us,y2u) = splitFunTys (applyTys cTy y1s)
270 -- safe 'cos a DataCon always returns a value of type (TyCon tys),
271 -- not an arrow type.
272 reUsg = mkUsgTy u . unUsgTy
273 in (map reUsg y2us, reUsg y2u)
274 -------------------------------------------- -}
277 usgInfCE ve e0@(App ea (Type yb))
278 = do (ea1,ya1u,ha1,fa1) <- usgInfCE ve ea
279 let (u1,ya1) = splitUsgTy ya1u
280 yb1 <- annotTyN (Left e0) yb
281 return (App ea1 (Type yb1),
282 mkUsgTy u1 (applyTy ya1 yb1),
286 usgInfCE ve (App ea eb)
287 = do (ea1,ya1u,ha1,fa1) <- usgInfCE ve ea
288 let ( u1,ya1) = splitUsgTy ya1u
289 (y2u,y3u) = expectJust "usgInfCE:App" $ splitFunTy_maybe ya1
290 (eb1,yb1u,hb1,fb1) <- usgInfCE ve eb
291 let h4 = usgSubTy yb1u y2u
292 return $ ASSERT( isUsgTy y3u )
295 unionUCSs [ha1,hb1,h4],
298 usgInfCE ve e0@(Lam v0 e) | isTyVar v0
299 = do (e1,y1u,h1,f1) <- usgInfCE ve e
300 let (u1,y1) = splitUsgTy y1u
302 mkUsgTy u1 (mkForAllTy v0 y1),
307 -- if used for checking also, may need to extend this case to
308 -- look in lbvarInfo instead.
310 = do u1 <- newVarUSMM (Left e0)
311 (v1,y1u) <- annotVar v0
312 (e2,y2u,h2,f2) <- usgInfCE (extendVarEnv ve v0 v1) e
313 let h3 = occChkUConSet v1 f2
314 f2' = f2 `delFromMS` v1
315 h4s = foldMS (\ v _ hs -> (leqUConSet u1 ((tyUsg . varType . lookupVar ve) v)
316 : hs)) -- in reverse order!
319 return (Note (TermUsg u1) (Lam v1 e2), -- add annot for lbVarInfo computation
320 mkUsgTy u1 (mkFunTy y1u y2u),
321 unionUCSs (h2:h3:h4s),
324 usgInfCE ve (Let b0s e0)
325 = do (v1s,ve1,b1s,h1,fb1,fa1) <- usgInfBind ve b0s
326 (e2,y2u,h2,f2) <- usgInfCE ve1 e0
327 let h3 = occChksUConSet v1s (fb1 `plusMS` f2)
328 return $ ASSERT( isUsgTy y2u )
331 unionUCSs [h1,h2,h3],
332 fa1 `plusMS` (f2 `delsFromMS` v1s))
334 usgInfCE ve (Case e0 v0 [(DEFAULT,[],e1)])
335 -- pure strict let, no selection (could be at polymorphic or function type)
336 = do (v1,y1u) <- annotVar v0
337 (e2,y2u,h2,f2) <- usgInfCE ve e0
338 (e3,y3u,h3,f3) <- usgInfCE (extendVarEnv ve v0 v1) e1
339 let h4 = usgEqTy y2u y1u -- **! why not subty?
340 h5 = occChkUConSet v1 f3
341 return $ ASSERT( isUsgTy y3u )
342 (Case e2 v1 [(DEFAULT,[],e3)],
344 unionUCSs [h2,h3,h4,h5],
345 f2 `plusMS` (f3 `delFromMS` v1))
347 usgInfCE ve e0@(Case e1 v1 alts)
348 -- general case (tycon of scrutinee must be known)
349 -- (assumes well-typed already; so doesn't check constructor)
350 = do (v2,y1u) <- annotVar v1
351 (e2,y2u,h2,f2) <- usgInfCE ve e1
352 let h3 = usgEqTy y2u y1u -- **! why not subty?
353 (u2,y2) = splitUsgTy y2u
354 (tc,y2s) = splitTyConApp y2
355 (cs,v1ss,es) = unzip3 alts
356 v2ss = map (map (\ v -> setVarType v (mkUsgTy u2 (annotManyN (varType v)))))
358 ve3 = extendVarEnv ve v1 v2
359 eyhf4s <- mapM (\ (v1s,v2s,e) -> usgInfCE (ve3 `plusVarEnv` (zipVarEnv v1s v2s)) e)
361 let (e4s,y4us,h4s,f4s) = unzip4 eyhf4s
362 y5u <- annotTy (Left e0) (unannotTy (head y4us))
363 let h5s = zipWith usgSubTy y4us (repeat y5u)
364 h6s = zipWith occChksUConSet v2ss f4s
365 f4 = foldl1 maxMS (zipWith delsFromMS f4s v2ss)
366 h7 = occChkUConSet v2 (f4 `plusMS` (unitMS v2))
367 return $ ASSERT( isUsgTy y5u )
368 (Case e2 v2 (zip3 cs v2ss e4s),
370 unionUCSs (h2:h3:h7:(h4s ++ h5s ++ h6s)),
371 f2 `plusMS` (f4 `delFromMS` v2))
373 usgInfCE ve e0@(Note note ea)
374 = do (e1,y1u,h1,f1) <- usgInfCE ve ea
376 Coerce yb ya -> do let (u1,y1) = splitUsgTy y1u
377 ya3 = annotManyN ya -- really nasty type
378 h3 = usgEqTy y1 ya3 -- messy but OK
379 yb3 <- annotTyN (Left e0) yb
380 -- What this says is that a Coerce does the most general possible
381 -- annotation to what's inside it (nasty, nasty), because no information
382 -- can pass through a Coerce. It of course simply ignores the info
383 -- that filters down through into ty1, because it can do nothing with it.
384 -- It does still pass through the topmost usage annotation, though.
385 return (Note (Coerce yb3 ya3) e1,
390 SCC _ -> return (Note note e1, y1u, h1, f1)
392 InlineCall -> return (Note note e1, y1u, h1, f1)
394 InlineMe -> return (Note note e1, y1u, h1, f1)
396 TermUsg _ -> pprPanic "usgInfCE:Note TermUsg" $ ppr e0
398 usgInfCE ve e0@(Type _)
399 = pprPanic "usgInfCE:Type" $ ppr e0
404 lookupVar :: VarEnv Var -> Var -> Var
405 -- if variable in VarEnv then return annotated version,
406 -- otherwise it's imported and already annotated so leave alone.
407 --lookupVar ve v = error "lookupVar unimplemented"
408 lookupVar ve v = case lookupVarEnv ve v of
410 Nothing -> ASSERT( not (mustHaveLocalBinding v) )
411 ASSERT( isUsgTy (varType v) )
414 instVar :: Var -> UniqSMM Var
415 -- instantiate variable with rho-type, giving it a fresh sigma-type
416 instVar v = do let (uvs,ty) = splitUsForAllTys (varType v)
419 _ -> do uvs' <- mapM (\_ -> newVarUSMM (Left (Var v))) uvs
420 let ty' = substUsTy (zipVarEnv uvs uvs') ty
421 return (setVarType v ty')
423 annotVar :: Var -> UniqSMM (Var,Type)
424 -- freshly annotates a variable and returns it along with its new type
425 annotVar v = do y1u <- annotTy (Left (Var v)) (varType v)
426 return (setVarType v y1u, y1u)
430 The closure operation, which does the generalisation at let bindings.
433 usgClos :: VarEnv Var -- environment to close with respect to
434 -> Type -- type to close (sigma)
435 -> UConSet -- constraint set to reduce
436 -> (Type, -- closed type (rho)
437 UConSet) -- residual constraint set
439 usgClos zz_ve ty ucs = (ty,ucs) -- dummy definition; no generalisation at all
441 -- hmm! what if it sets some uvars to 1 or omega?
442 -- (should it do substitution here, or return a substitution,
443 -- or should it leave all that work to the end and just use
444 -- an "=" constraint here for now?)
447 The pessimise operation, which generates constraints to pessimise an
448 id (applied to exported ids, to ensure that they have fully general
449 types, since we don't know how they will be used in other modules).
452 pessimise :: Type -> UConSet
455 = pess True emptyVarEnv ty
458 pess :: Bool -> UVarSet -> Type -> UConSet
459 pess co ve (NoteTy (UsgForAll uv) ty)
460 = pess co (ve `extendVarSet` uv) ty
461 pess co ve ty0@(NoteTy (UsgNote u) ty)
462 = pessN co ve ty `unionUCS`
464 (False,_ ) -> emptyUConSet
465 (True ,UsMany ) -> emptyUConSet
466 (True ,UsOnce ) -> pprPanic "pessimise: can't force:" (ppr ty0)
467 (True ,UsVar uv) -> if uv `elemVarSet` ve
468 then emptyUConSet -- if bound by \/u, no need to pessimise
469 else eqManyUConSet u)
471 = pprPanic "pessimise: missing annot:" (ppr ty0)
473 pessN :: Bool -> UVarSet -> Type -> UConSet
474 pessN co ve (NoteTy (UsgForAll uv) ty) = pessN co (ve `extendVarSet` uv) ty
475 pessN co ve ty0@(NoteTy (UsgNote _) _ ) = pprPanic "pessimise: unexpected annot:" (ppr ty0)
476 pessN co ve (NoteTy (SynNote sty) ty) = pessN co ve sty `unionUCS` pessN co ve ty
477 pessN co ve (NoteTy (FTVNote _) ty) = pessN co ve ty
478 pessN co ve (TyVarTy _) = emptyUConSet
479 pessN co ve (AppTy _ _) = emptyUConSet
480 pessN co ve (TyConApp tc tys) = ASSERT( not((isFunTyCon tc)&&(length tys > 1)) )
482 pessN co ve (FunTy ty1 ty2) = pess (not co) ve ty1 `unionUCS` pess co ve ty2
483 pessN co ve (ForAllTy _ ty) = pessN co ve ty
488 ======================================================================
493 If a variable appears more than once in an fv set, force its usage to be Many.
500 occChkUConSet v fv = if occInMS v fv > 1
501 then ASSERT2( isUsgTy (varType v), ppr v )
502 eqManyUConSet ((tyUsg . varType) v)
505 occChksUConSet :: [Var]
509 occChksUConSet vs fv = unionUCSs (map (\v -> occChkUConSet v fv) vs)
513 Subtyping and equal-typing relations. These generate constraint sets.
514 Both assume their arguments are annotated correctly, and are either
515 both tau-types or both sigma-types (in fact, are both exactly the same
519 usgSubTy ty1 ty2 = genUsgCmpTy cmp ty1 ty2
520 where cmp u1 u2 = leqUConSet u2 u1
522 usgEqTy ty1 ty2 = genUsgCmpTy cmp ty1 ty2 -- **NB** doesn't equate tyconargs that
523 -- don't appear (see below)
524 where cmp u1 u2 = eqUConSet u1 u2
526 genUsgCmpTy :: (UsageAnn -> UsageAnn -> UConSet) -- constraint (u1 REL u2), respectively
531 genUsgCmpTy cmp (NoteTy (UsgNote u1) ty1) (NoteTy (UsgNote u2) ty2)
532 = cmp u1 u2 `unionUCS` genUsgCmpTy cmp ty1 ty2
535 -- deal with omitted == UsMany
536 genUsgCmpTy cmp (NoteTy (UsgNote u1) ty1) ty2
537 = cmp u1 UsMany `unionUCS` genUsgCmpTy cmp ty1 ty2
538 genUsgCmpTy cmp ty1 (NoteTy (UsgNote u2) ty2)
539 = cmp UsMany u2 `unionUCS` genUsgCmpTy cmp ty1 ty2
542 genUsgCmpTy cmp (NoteTy (SynNote sty1) ty1) (NoteTy (SynNote sty2) ty2)
543 = genUsgCmpTy cmp sty1 sty2 `unionUCS` genUsgCmpTy cmp ty1 ty2
544 -- **! is this right? or should I throw away synonyms, or sth else?
546 -- if SynNote only on one side, throw it out
547 genUsgCmpTy cmp (NoteTy (SynNote sty1) ty1) ty2
548 = genUsgCmpTy cmp ty1 ty2
549 genUsgCmpTy cmp ty1 (NoteTy (SynNote sty2) ty2)
550 = genUsgCmpTy cmp ty1 ty2
553 genUsgCmpTy cmp (NoteTy (FTVNote _) ty1) ty2
554 = genUsgCmpTy cmp ty1 ty2
555 genUsgCmpTy cmp ty1 (NoteTy (FTVNote _) ty2)
556 = genUsgCmpTy cmp ty1 ty2
558 genUsgCmpTy cmp (TyVarTy _) (TyVarTy _)
561 genUsgCmpTy cmp (AppTy tya1 tyb1) (AppTy tya2 tyb2)
562 = unionUCSs [genUsgCmpTy cmp tya1 tya2,
563 genUsgCmpTy cmp tyb1 tyb2, -- note, *both* ways for arg, since fun (prob) unknown
564 genUsgCmpTy cmp tyb2 tyb1]
566 genUsgCmpTy cmp (TyConApp tc1 ty1s) (TyConApp tc2 ty2s)
567 = case tyConArgVrcs_maybe tc1 of
568 Just oi -> unionUCSs (zipWith3 (\ ty1 ty2 (occPos,occNeg) ->
569 -- strictly this is wasteful (and possibly dangerous) for
570 -- usgEqTy, but I think it's OK. KSW 1999-04.
571 (if occPos then genUsgCmpTy cmp ty1 ty2 else emptyUConSet)
573 (if occNeg then genUsgCmpTy cmp ty2 ty1 else emptyUConSet))
575 Nothing -> panic ("genUsgCmpTy: variance info unavailable for " ++ showSDoc (ppr tc1))
577 genUsgCmpTy cmp (FunTy tya1 tyb1) (FunTy tya2 tyb2)
578 = genUsgCmpTy cmp tya2 tya1 `unionUCS` genUsgCmpTy cmp tyb1 tyb2 -- contravariance of arrow
580 genUsgCmpTy cmp (ForAllTy _ ty1) (ForAllTy _ ty2)
581 = genUsgCmpTy cmp ty1 ty2
583 genUsgCmpTy cmp ty1 ty2
584 = pprPanic "genUsgCmpTy: type shapes don't match" $
585 vcat [ppr ty1, ppr ty2]
589 Applying a substitution to all @UVar@s. This also moves @TermUsg@
590 notes on lambdas into the @lbvarInfo@ field of the binder. This
591 latter is a hack. KSW 1999-04.
594 appUSubstTy :: (UVar -> UsageAnn)
598 appUSubstTy s (NoteTy (UsgNote (UsVar uv)) ty)
599 = mkUsgTy (s uv) (appUSubstTy s ty)
600 appUSubstTy s (NoteTy note@(UsgNote _) ty) = NoteTy note (appUSubstTy s ty)
601 appUSubstTy s (NoteTy note@(SynNote _) ty) = NoteTy note (appUSubstTy s ty)
602 appUSubstTy s (NoteTy note@(FTVNote _) ty) = NoteTy note (appUSubstTy s ty)
603 appUSubstTy s ty@(TyVarTy _) = ty
604 appUSubstTy s (AppTy ty1 ty2) = AppTy (appUSubstTy s ty1) (appUSubstTy s ty2)
605 appUSubstTy s (TyConApp tc tys) = TyConApp tc (map (appUSubstTy s) tys)
606 appUSubstTy s (FunTy ty1 ty2) = FunTy (appUSubstTy s ty1) (appUSubstTy s ty2)
607 appUSubstTy s (ForAllTy tyv ty) = ForAllTy tyv (appUSubstTy s ty)
610 appUSubstBinds :: (UVar -> UsageAnn)
614 appUSubstBinds s binds = fst $ initAnnotM () $
615 genAnnotBinds mungeType mungeTerm binds
616 where mungeType _ ty = -- simply perform substitution
617 return (appUSubstTy s ty)
619 mungeTerm (Note (TermUsg (UsVar uv)) (Lam v e))
620 -- perform substitution *and* munge annot on lambda into IdInfo.lbvarInfo
621 = let lb = case (s uv) of { UsOnce -> IsOneShotLambda; UsMany -> NoLBVarInfo }
622 v' = modifyIdInfo (`setLBVarInfo` lb) v -- HACK ALERT!
623 -- see comment in IdInfo.lhs; this is because the info is easier to
624 -- access here, by agreement SLPJ/KSW 1999-04 (as a "short-term hack").
626 -- really should be: return (Note (TermUsg (s uv)) (Lam v e))
627 mungeTerm e@(Lam _ _) = return e
628 mungeTerm e = panic "appUSubstBinds: mungeTerm:" (ppr e)
632 A @VarMultiset@ is what it says: a set of variables with counts
633 attached to them. We build one out of a @VarEnv@.
636 type VarMultiset = VarEnv (Var,Int) -- I guess 536 870 911 occurrences is enough
638 emptyMS = emptyVarEnv
639 unitMS v = unitVarEnv v (v,1)
640 delFromMS = delVarEnv
641 delsFromMS = delVarEnvList
642 plusMS :: VarMultiset -> VarMultiset -> VarMultiset
643 plusMS = plusVarEnv_C (\ (v,n) (_,m) -> (v,n+m))
644 maxMS :: VarMultiset -> VarMultiset -> VarMultiset
645 maxMS = plusVarEnv_C (\ (v,n) (_,m) -> (v,max n m))
646 mapMS f = mapVarEnv (\ (v,n) -> f v n)
647 foldMS f = foldVarEnv (\ (v,n) a -> f v n a)
648 occInMS v ms = case lookupVarEnv ms v of
653 And a function used in debugging. It may give false positives with -DUSMANY turned off.
656 isUnAnnotated :: Type -> Bool
658 isUnAnnotated (NoteTy (UsgNote _ ) _ ) = False
659 isUnAnnotated (NoteTy (SynNote sty) ty) = isUnAnnotated sty && isUnAnnotated ty
660 isUnAnnotated (NoteTy (FTVNote _ ) ty) = isUnAnnotated ty
661 isUnAnnotated (TyVarTy _) = True
662 isUnAnnotated (AppTy ty1 ty2) = isUnAnnotated ty1 && isUnAnnotated ty2
663 isUnAnnotated (TyConApp tc tys) = all isUnAnnotated tys
664 isUnAnnotated (FunTy ty1 ty2) = isUnAnnotated ty1 && isUnAnnotated ty2
665 isUnAnnotated (ForAllTy tyv ty) = isUnAnnotated ty
668 END OF ENTIRELY-COMMENTED-OUT PASS -- KSW 2000-10-13 -}
671 ======================================================================