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