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