2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
4 \section[UsageSPUtils]{UsageSP Utilities}
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-07
12 module UsageSPUtils ( {- SEE BELOW: -- KSW 2000-10-13
13 AnnotM(AnnotM), initAnnotM,
15 MungeFlags(isSigma,isLocal,isExp,hasUsg,mfLoc),
17 doAnnotBinds, doUnAnnotBinds,
18 annotTy, annotTyN, annotMany, annotManyN, unannotTy, freshannotTy,
21 UniqSMM, usToUniqSMM, uniqSMMToUs,
26 #include "HsVersions.h"
28 {- ENTIRE FILE COMMENTED OUT FOR NOW -- KSW 2000-10-13
30 import Var ( Var, varType, setVarType, mkUVar )
31 import Id ( isExportedId )
32 import Name ( isLocallyDefined )
33 import TypeRep ( Type(..), TyNote(..) ) -- friend
34 import Type ( splitFunTys )
35 import Subst ( substTy, mkTyVarSubst )
36 import TyCon ( isAlgTyCon, isPrimTyCon, isSynTyCon, isFunTyCon )
38 import PrimOp ( PrimOp, primOpUsg )
39 import UniqSupply ( UniqSupply, UniqSM, initUs, getUniqueUs, thenUs, returnUs )
40 import Util ( lengthExceeds )
44 This monomorphic version of the analysis is outdated. I'm
45 currently ripping out the old one and inserting the new one. For
46 now, I'm simply commenting out this entire file.
51 ======================================================================
53 Walking over (and altering) types
54 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
56 We often need to fiddle with (i.e., add or remove) usage annotations
57 on a type. We define here a general framework to do this. Usage
58 annotations come from any monad with a function @getAnnM@ which yields
59 a new annotation. We use two mutually recursive functions, one for
60 sigma types and one for tau types.
63 genAnnotTy :: Monad m =>
64 (m UsageAnn) -- get new annotation
68 genAnnotTy getAnnM ty = do { u <- getAnnM
69 ; ty' <- genAnnotTyN getAnnM ty
70 ; return (NoteTy (UsgNote u) ty')
73 genAnnotTyN :: Monad m =>
79 (NoteTy (UsgNote _) ty) = panic "genAnnotTyN: unexpected UsgNote"
81 (NoteTy (SynNote sty) ty) = do { sty' <- genAnnotTyN getAnnM sty
82 -- is this right? shouldn't there be some
83 -- correlation between sty' and ty'?
84 -- But sty is a TyConApp; does this make it safer?
85 ; ty' <- genAnnotTyN getAnnM ty
86 ; return (NoteTy (SynNote sty') ty')
89 (NoteTy fvn@(FTVNote _) ty) = do { ty' <- genAnnotTyN getAnnM ty
90 ; return (NoteTy fvn ty')
94 ty0@(TyVarTy _) = do { return ty0 }
97 (AppTy ty1 ty2) = do { ty1' <- genAnnotTyN getAnnM ty1
98 ; ty2' <- genAnnotTyN getAnnM ty2
99 ; return (AppTy ty1' ty2')
103 (TyConApp tc tys) = ASSERT( isFunTyCon tc || isAlgTyCon tc || isPrimTyCon tc || isSynTyCon tc )
104 do { let gAT = if isFunTyCon tc
105 then genAnnotTy -- sigma for partial apps of (->)
106 else genAnnotTyN -- tau otherwise
107 ; tys' <- mapM (gAT getAnnM) tys
108 ; return (TyConApp tc tys')
112 (FunTy ty1 ty2) = do { ty1' <- genAnnotTy getAnnM ty1
113 ; ty2' <- genAnnotTy getAnnM ty2
114 ; return (FunTy ty1' ty2')
118 (ForAllTy v ty) = do { ty' <- genAnnotTyN getAnnM ty
119 ; return (ForAllTy v ty')
125 Walking over (and retyping) terms
126 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
128 We also often need to play with the types in a term. This is slightly
129 tricky because of redundancy: we want to change binder types, and keep
130 the bound types matching these; then there's a special case also with
131 non-locally-defined bound variables. We generalise over all this
134 The name `annot' is a bit of a misnomer, as the code is parameterised
135 over exactly what it does to the types (and certain terms). Notice
136 also that it is possible for this parameter to use
137 monadically-threaded state: here called `flexi'. For genuine
138 annotation, this state will be a UniqSupply.
140 We may add annotations to the outside of a (term, not type) lambda; a
141 function passed to @genAnnotBinds@ does this, taking the lambda and
142 returning the annotated lambda. It is inside the @AnnotM@ monad.
143 This term-munging function is applied when we see either a term lambda
144 or a usage annotation; *IMPORTANT:* it is applied *before* we recurse
145 down into the term, and it is expected to work only at the top level.
146 Recursion will subsequently be done by genAnnotBinds. It may
147 optionally remove a Note TermUsg, or optionally add one if it is not
148 already present, but it may perform NO OTHER MODIFICATIONS to the
149 structure of the term.
151 We do different things to types of variables bound locally and of
152 variables bound in other modules, in certain cases: the former get
153 uvars and the latter keep their existing annotations when we annotate,
154 for example. To control this, @MungeFlags@ describes what kind of a
155 type this is that we're about to munge.
158 data MungeFlags = MungeFlags { isSigma :: Bool, -- want annotated on top (sigma type)
159 isLocal :: Bool, -- is locally-defined type
160 hasUsg :: Bool, -- has fixed usage info, don't touch
161 isExp :: Bool, -- is exported (and must be pessimised)
162 mfLoc :: SDoc -- location info
165 tauTyMF loc = MungeFlags { isSigma = False, isLocal = True,
166 hasUsg = False, isExp = False, mfLoc = loc }
167 sigVarTyMF v = MungeFlags { isSigma = True, isLocal = hasLocalDef v,
168 hasUsg = hasUsgInfo v, isExp = isExportedId v,
169 mfLoc = ptext SLIT("type of binder") <+> ppr v }
172 The helper functions @tauTyMF@ and @sigVarTyMF@ create @MungeFlags@
173 for us. @sigVarTyMF@ checks the variable to see how to set the flags.
175 @hasLocalDef@ tells us if the given variable has an actual local
176 definition that we can play with. This is not quite the same as
177 @isLocallyDefined@, since @hasNoBindingId@ things (usually) don't have
178 a local definition - the simplifier will inline whatever their
179 unfolding is anyway. We treat these as if they were externally
180 defined, since we don't have access to their definition (at least not
181 easily). This doesn't hurt much, since after the simplifier has run
182 the unfolding will have been inlined and we can access the unfolding
185 @hasUsgInfo@, on the other hand, says if the variable already has
186 usage info in its type that must at all costs be preserved. This is
187 assumed true (exactly) of all imported ids.
190 hasLocalDef :: Var -> Bool
191 hasLocalDef var = mustHaveLocalBinding var
193 hasUsgInfo :: Var -> Bool
194 hasUsgInfo var = (not . isLocallyDefined) var
197 Here's the walk itself.
200 genAnnotBinds :: (MungeFlags -> Type -> AnnotM flexi Type)
201 -> (CoreExpr -> AnnotM flexi CoreExpr) -- see caveats above
203 -> AnnotM flexi [CoreBind]
205 genAnnotBinds _ _ [] = return []
207 genAnnotBinds f g (b:bs) = do { (b',vs,vs') <- genAnnotBind f g b
208 ; bs' <- withAnnVars vs vs' $
213 genAnnotBind :: (MungeFlags -> Type -> AnnotM flexi Type) -- type-altering function
214 -> (CoreExpr -> AnnotM flexi CoreExpr) -- term-altering function
215 -> CoreBind -- original CoreBind
217 (CoreBind, -- annotated CoreBind
218 [Var], -- old variables, to be mapped to...
219 [Var]) -- ... new variables
221 genAnnotBind f g (NonRec v1 e1) = do { v1' <- genAnnotVar f v1
222 ; e1' <- genAnnotCE f g e1
223 ; return (NonRec v1' e1', [v1], [v1'])
226 genAnnotBind f g (Rec ves) = do { let (vs,es) = unzip ves
227 ; vs' <- mapM (genAnnotVar f) vs
228 ; es' <- withAnnVars vs vs' $
229 mapM (genAnnotCE f g) es
230 ; return (Rec (zip vs' es'), vs, vs')
233 genAnnotCE :: (MungeFlags -> Type -> AnnotM flexi Type) -- type-altering function
234 -> (CoreExpr -> AnnotM flexi CoreExpr) -- term-altering function
235 -> CoreExpr -- original expression
236 -> AnnotM flexi CoreExpr -- yields new expression
238 genAnnotCE mungeType mungeTerm = go
239 where go e0@(Var v) | isTyVar v = return e0 -- arises, e.g., as tyargs of constructor
240 -- (no it doesn't: (Type (TyVar tyvar))
241 | otherwise = do { mv' <- lookupAnnVar v
243 Just var -> return var
244 Nothing -> fixedVar v
248 go (Lit l) = -- we know it's saturated
251 go (App e arg) = do { e' <- go e
253 ; return (App e' arg')
256 go e0@(Lam v0 _) = do { e1 <- (if isTyVar v0 then return else mungeTerm) e0
258 = case e1 of -- munge may have added note
259 Note tu@(TermUsg _) (Lam v e2)
261 Lam v e2 -> (v,e2,id)
262 ; v' <- genAnnotVar mungeType v
263 ; e' <- withAnnVar v v' $ go e2
264 ; return (wrap (Lam v' e'))
267 go (Let bind e) = do { (bind',vs,vs') <- genAnnotBind mungeType mungeTerm bind
268 ; e' <- withAnnVars vs vs' $ go e
269 ; return (Let bind' e')
272 go (Case e v alts) = do { e' <- go e
273 ; v' <- genAnnotVar mungeType v
274 ; alts' <- withAnnVar v v' $ mapM genAnnotAlt alts
275 ; return (Case e' v' alts')
278 go (Note scc@(SCC _) e) = do { e' <- go e
279 ; return (Note scc e')
281 go e0@(Note (Coerce ty1 ty0)
282 e) = do { ty1' <- mungeType
283 (tauTyMF (ptext SLIT("coercer of")
286 (tauTyMF (ptext SLIT("coercee of")
288 -- (Better to specify ty0'
289 -- identical to the type of e, including
290 -- annotations, right at the beginning, but
291 -- not possible at this point.)
293 ; return (Note (Coerce ty1' ty0') e')
295 go (Note InlineCall e) = do { e' <- go e
296 ; return (Note InlineCall e')
298 go (Note InlineMe e) = do { e' <- go e
299 ; return (Note InlineMe e')
301 go e0@(Note (TermUsg _) _) = do { e1 <- mungeTerm e0
302 ; case e1 of -- munge may have removed note
303 Note tu@(TermUsg _) e2 -> do { e3 <- go e2
304 ; return (Note tu e3)
309 go e0@(Type ty) = -- should only occur at toplevel of Arg,
311 do { ty' <- mungeType
312 (tauTyMF (ptext SLIT("tyarg")
317 fixedVar v = ASSERT2( not (hasLocalDef v), text "genAnnotCE: locally defined var" <+> ppr v <+> text "not in varenv" )
318 genAnnotVar mungeType v
320 genAnnotAlt (c,vs,e) = do { vs' <- mapM (genAnnotVar mungeType) vs
321 ; e' <- withAnnVars vs vs' $ go e
322 ; return (c, vs', e')
326 genAnnotVar :: (MungeFlags -> Type -> AnnotM flexi Type)
330 genAnnotVar mungeType v | isTyVar v = return v
331 | otherwise = do { vty' <- mungeType (sigVarTyMF v) (varType v)
332 ; return (setVarType v vty')
336 pprTrace "genAnnotVar" (ppr (tyUsg vty') <+> ppr v) $
342 ======================================================================
344 Some specific things to do to types inside terms
345 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
347 @annotTyM@ annotates a type with fresh uvars everywhere the inference
348 is allowed to go, and leaves alone annotations where it may not go.
350 We assume there are no annotations already.
353 annotTyM :: MungeFlags -> Type -> AnnotM UniqSupply Type
355 annotTyM mf ty = uniqSMtoAnnotM . uniqSMMToUs $
356 case (hasUsg mf, isLocal mf, isSigma mf) of
357 (True ,_ ,_ ) -> ASSERT( isUsgTy ty )
359 (False,True ,True ) -> if isExp mf then
360 annotTyP (tag 'p') ty
363 (False,True ,False) -> annotTyN (tag 't') ty
364 (False,False,True ) -> return $ annotMany ty -- assume worst
365 (False,False,False) -> return $ annotManyN ty
366 where tag c = Right $ "annotTyM:" ++ [c] ++ ": " ++ showSDoc (ppr ty)
368 -- specific functions for annotating tau and sigma types
371 annotTy tag = genAnnotTy (newVarUSMM tag)
372 annotTyN tag = genAnnotTyN (newVarUSMM tag)
374 -- ...with uvars and pessimal Manys (for exported ids)
375 annotTyP tag ty = do { ty' <- annotTy tag ty ; return (pessimise True ty') }
378 annotMany, annotManyN :: Type -> Type
383 annotMany ty = unId (genAnnotTy (return UsMany) ty)
384 annotManyN ty = unId (genAnnotTyN (return UsMany) ty)
387 -- monad required for the above
388 newtype Id a = Id a ; unId (Id a) = a
389 instance Monad Id where { a >>= f = f (unId a) ; return a = Id a }
391 -- lambda-annotating function for use along with the above
392 annotLam e0@(Lam v e) = do { uv <- uniqSMtoAnnotM $ newVarUs (Left e0)
393 ; return (Note (TermUsg uv) (Lam v e))
395 annotLam (Note (TermUsg _) _) = panic "annotLam: unexpected term usage annot"
398 The above requires a `pessimising' translation. This is applied to
399 types of exported ids, and ensures that they have a fully general
400 type (since we don't know how they will be used in other modules).
403 pessimise :: Bool -> Type -> Type
406 pessimise co ty0@(NoteTy usg@(UsgNote u ) ty)
408 then case u of UsMany -> pty
409 UsVar _ -> pty -- force to UsMany
410 UsOnce -> pprPanic "pessimise:" (ppr ty0)
412 where pty = pessimiseN co ty
414 pessimise co ty0 = pessimiseN co ty0 -- assume UsMany
416 pessimise co ty0@(NoteTy usg@(UsgNote u ) ty)
418 then case u of UsMany -> NoteTy usg pty
419 UsVar _ -> NoteTy (UsgNote UsMany) pty
420 UsOnce -> pprPanic "pessimise:" (ppr ty0)
422 where pty = pessimiseN co ty
424 pessimise co ty0 = pprPanic "pessimise: missing usage note:" $
428 pessimiseN co ty0@(NoteTy usg@(UsgNote _ ) ty) = pprPanic "pessimiseN: unexpected usage note:" $
430 pessimiseN co (NoteTy (SynNote sty) ty) = NoteTy (SynNote (pessimiseN co sty))
432 pessimiseN co (NoteTy note@(FTVNote _ ) ty) = NoteTy note (pessimiseN co ty)
433 pessimiseN co ty0@(TyVarTy _) = ty0
434 pessimiseN co ty0@(AppTy _ _) = ty0
435 pessimiseN co ty0@(TyConApp tc tys) = ASSERT( not ((isFunTyCon tc) && (tys `lengthExceeds` 1)) )
437 pessimiseN co (FunTy ty1 ty2) = FunTy (pessimise (not co) ty1)
439 pessimiseN co (ForAllTy tyv ty) = ForAllTy tyv (pessimiseN co ty)
443 @unAnnotTyM@ strips annotations (that the inference is allowed to
444 touch) from a term, and `fixes' those it isn't permitted to touch (by
445 putting @Many@ annotations where they are missing, but leaving
446 existing annotations in the type).
448 @unTermUsg@ removes from a term any term usage annotations it finds.
451 unAnnotTyM :: MungeFlags -> Type -> AnnotM a Type
453 unAnnotTyM mf ty = if hasUsg mf then
455 return (fixAnnotTy ty)
456 else return (unannotTy ty)
459 unTermUsg :: CoreExpr -> AnnotM a CoreExpr
460 -- strip all term annotations
461 unTermUsg e@(Lam _ _) = return e
462 unTermUsg (Note (TermUsg _) e) = return e
463 unTermUsg _ = panic "unTermUsg"
465 unannotTy :: Type -> Type
466 -- strip all annotations
467 unannotTy (NoteTy (UsgForAll uv) ty) = unannotTy ty
468 unannotTy (NoteTy (UsgNote _ ) ty) = unannotTy ty
469 unannotTy (NoteTy (SynNote sty) ty) = NoteTy (SynNote (unannotTy sty)) (unannotTy ty)
470 unannotTy (NoteTy note@(FTVNote _ ) ty) = NoteTy note (unannotTy ty)
471 unannotTy ty@(PredTy _) = ty -- PredTys need to be preserved
472 unannotTy ty@(TyVarTy _) = ty
473 unannotTy (AppTy ty1 ty2) = AppTy (unannotTy ty1) (unannotTy ty2)
474 unannotTy (TyConApp tc tys) = TyConApp tc (map unannotTy tys)
475 unannotTy (FunTy ty1 ty2) = FunTy (unannotTy ty1) (unannotTy ty2)
476 unannotTy (ForAllTy tyv ty) = ForAllTy tyv (unannotTy ty)
479 fixAnnotTy :: Type -> Type
480 -- put Manys where they are missing
484 fixAnnotTy (NoteTy note@(UsgForAll uv) ty) = NoteTy note (fixAnnotTy ty)
485 fixAnnotTy (NoteTy note@(UsgNote _ ) ty) = NoteTy note (fixAnnotTyN ty)
486 fixAnnotTy ty0 = NoteTy (UsgNote UsMany) (fixAnnotTyN ty0)
488 fixAnnotTyN ty0@(NoteTy note@(UsgNote _ ) ty) = pprPanic "fixAnnotTyN: unexpected usage note:" $
490 fixAnnotTyN (NoteTy (SynNote sty) ty) = NoteTy (SynNote (fixAnnotTyN sty))
492 fixAnnotTyN (NoteTy note@(FTVNote _ ) ty) = NoteTy note (fixAnnotTyN ty)
493 fixAnnotTyN ty0@(TyVarTy _) = ty0
494 fixAnnotTyN (AppTy ty1 ty2) = AppTy (fixAnnotTyN ty1) (fixAnnotTyN ty2)
495 fixAnnotTyN (TyConApp tc tys) = ASSERT( isFunTyCon tc || isAlgTyCon tc || isPrimTyCon tc || isSynTyCon tc )
496 TyConApp tc (map (if isFunTyCon tc then
500 fixAnnotTyN (FunTy ty1 ty2) = FunTy (fixAnnotTy ty1) (fixAnnotTy ty2)
501 fixAnnotTyN (ForAllTy tyv ty) = ForAllTy tyv (fixAnnotTyN ty)
505 The composition (reannotating a type with fresh uvars but the same
506 structure) is useful elsewhere:
509 freshannotTy :: Type -> UniqSMM Type
510 freshannotTy = annotTy (Right "freshannotTy") . unannotTy
514 Wrappers apply these functions to sets of bindings.
517 doAnnotBinds :: UniqSupply
519 -> ([CoreBind],UniqSupply)
521 doAnnotBinds us binds = initAnnotM us (genAnnotBinds annotTyM annotLam binds)
524 doUnAnnotBinds :: [CoreBind]
527 doUnAnnotBinds binds = fst $ initAnnotM () $
528 genAnnotBinds unAnnotTyM unTermUsg binds
531 ======================================================================
536 The @UniqSM@ type is not an instance of @Monad@, and cannot be made so
537 since it is merely a synonym rather than a newtype. Here we define
538 @UniqSMM@, which *is* an instance of @Monad@.
541 newtype UniqSMM a = UsToUniqSMM (UniqSM a)
542 uniqSMMToUs (UsToUniqSMM us) = us
543 usToUniqSMM = UsToUniqSMM
545 instance Monad UniqSMM where
546 m >>= f = UsToUniqSMM $ uniqSMMToUs m `thenUs` \ a ->
548 return = UsToUniqSMM . returnUs
552 For annotation, the monad @AnnotM@, we need to carry around our
553 variable mapping, along with some general state.
556 newtype AnnotM flexi a = AnnotM ( flexi -- UniqSupply etc
557 -> VarEnv Var -- unannotated to annotated variables
558 -> (a,flexi,VarEnv Var))
559 unAnnotM (AnnotM f) = f
561 instance Monad (AnnotM flexi) where
562 a >>= f = AnnotM (\ us ve -> let (r,us',ve') = unAnnotM a us ve
563 in unAnnotM (f r) us' ve')
564 return a = AnnotM (\ us ve -> (a,us,ve))
566 initAnnotM :: fl -> AnnotM fl a -> (a,fl)
567 initAnnotM fl m = case (unAnnotM m) fl emptyVarEnv of { (r,fl',_) -> (r,fl') }
569 withAnnVar :: Var -> Var -> AnnotM fl a -> AnnotM fl a
570 withAnnVar v v' m = AnnotM (\ us ve -> let ve' = extendVarEnv ve v v'
571 (r,us',_) = (unAnnotM m) us ve'
574 withAnnVars :: [Var] -> [Var] -> AnnotM fl a -> AnnotM fl a
575 withAnnVars vs vs' m = AnnotM (\ us ve -> let ve' = plusVarEnv ve (zipVarEnv vs vs')
576 (r,us',_) = (unAnnotM m) us ve'
579 lookupAnnVar :: Var -> AnnotM fl (Maybe Var)
580 lookupAnnVar var = AnnotM (\ us ve -> (lookupVarEnv ve var,
585 A useful helper allows us to turn a computation in the unique supply
586 monad into one in the annotation monad parameterised by a unique
590 uniqSMtoAnnotM :: UniqSM a -> AnnotM UniqSupply a
592 uniqSMtoAnnotM m = AnnotM (\ us ve -> let (r,us') = initUs us m
596 @newVarUs@ and @newVarUSMM@ generate a new usage variable. They take
597 an argument which is used for debugging only, describing what the
598 variable is to annotate.
601 newVarUs :: (Either CoreExpr String) -> UniqSM UsageAnn
602 -- the first arg is for debugging use only
603 newVarUs e = getUniqueUs `thenUs` \ u ->
608 Left (Lit _) -> "literal"
609 Left (Lam v e) -> "lambda: " ++ showSDoc (ppr v)
612 in pprTrace "newVarUs:" (ppr uv <+> text src) $
616 newVarUSMM :: (Either CoreExpr String) -> UniqSMM UsageAnn
617 newVarUSMM = usToUniqSMM . newVarUs
620 ======================================================================
622 PrimOps and usage information.
624 Analagously to @DataCon.dataConArgTys@, we determine the argtys and
625 result ty of a primop, *after* substition (which may reveal more args,
626 notably for @CCall@s).
629 primOpUsgTys :: PrimOp -- this primop
630 -> [Type] -- instantiated at these (tau) types
631 -> ([Type],Type) -- requires args of these (sigma) types,
632 -- and returns this (sigma) type
634 primOpUsgTys p tys = let (tyvs,ty0us,rtyu) = primOpUsg p
635 s = mkTyVarSubst tyvs tys
636 (ty1us,rty1u) = splitFunTys (substTy s rtyu)
637 -- substitution may reveal more args
638 in ((map (substTy s) ty0us) ++ ty1us,
642 END OF ENTIRELY-COMMENTED-OUT FILE -- KSW 2000-10-13 -}
645 ======================================================================