This code is (based on) PhD work of Keith Wansbrough <kw217@cl.cam.ac.uk>,
September 1998 .. May 1999.
-Keith Wansbrough 1998-09-04..1999-05-07
+Keith Wansbrough 1998-09-04..1999-07-07
\begin{code}
-module UsageSPUtils ( AnnotM(AnnotM), initAnnotM,
+module UsageSPUtils ( {- SEE BELOW: -- KSW 2000-10-13
+ AnnotM(AnnotM), initAnnotM,
genAnnotBinds,
MungeFlags(isSigma,isLocal,isExp,hasUsg,mfLoc),
doAnnotBinds, doUnAnnotBinds,
- annotMany, annotManyN, unannotTy, freshannotTy,
+ annotTy, annotTyN, annotMany, annotManyN, unannotTy, freshannotTy,
newVarUs, newVarUSMM,
UniqSMM, usToUniqSMM, uniqSMMToUs,
- primOpUsgTys,
+ primOpUsgTys, -}
) where
#include "HsVersions.h"
+{- ENTIRE FILE COMMENTED OUT FOR NOW -- KSW 2000-10-13
import CoreSyn
-import Const ( Con(..), Literal(..) )
-import Var ( IdOrTyVar, varName, varType, setVarType, mkUVar )
-import Id ( idMustBeINLINEd, isExportedId )
+import Var ( Var, varType, setVarType, mkUVar )
+import Id ( isExportedId )
import Name ( isLocallyDefined )
-import Type ( Type(..), TyNote(..), UsageAnn(..), isUsgTy, splitFunTys )
+import TypeRep ( Type(..), TyNote(..) ) -- friend
+import Type ( splitFunTys )
import Subst ( substTy, mkTyVarSubst )
import TyCon ( isAlgTyCon, isPrimTyCon, isSynTyCon, isFunTyCon )
import VarEnv
import PrimOp ( PrimOp, primOpUsg )
-import Maybes ( expectJust )
import UniqSupply ( UniqSupply, UniqSM, initUs, getUniqueUs, thenUs, returnUs )
+import Util ( lengthExceeds )
import Outputable
-import PprCore ( ) -- instances only
+
+
+ This monomorphic version of the analysis is outdated. I'm
+ currently ripping out the old one and inserting the new one. For
+ now, I'm simply commenting out this entire file.
+
+
\end{code}
======================================================================
@hasLocalDef@ tells us if the given variable has an actual local
definition that we can play with. This is not quite the same as
-@isLocallyDefined@, since @IMustBeINLINEd@ things (usually) don't have
+@isLocallyDefined@, since @hasNoBindingId@ things (usually) don't have
a local definition - the simplifier will inline whatever their
unfolding is anyway. We treat these as if they were externally
defined, since we don't have access to their definition (at least not
assumed true (exactly) of all imported ids.
\begin{code}
-hasLocalDef :: IdOrTyVar -> Bool
-hasLocalDef var = isLocallyDefined var
- && not (idMustBeINLINEd var)
+hasLocalDef :: Var -> Bool
+hasLocalDef var = mustHaveLocalBinding var
-hasUsgInfo :: IdOrTyVar -> Bool
+hasUsgInfo :: Var -> Bool
hasUsgInfo var = (not . isLocallyDefined) var
\end{code}
-> CoreBind -- original CoreBind
-> AnnotM flexi
(CoreBind, -- annotated CoreBind
- [IdOrTyVar], -- old variables, to be mapped to...
- [IdOrTyVar]) -- ... new variables
+ [Var], -- old variables, to be mapped to...
+ [Var]) -- ... new variables
genAnnotBind f g (NonRec v1 e1) = do { v1' <- genAnnotVar f v1
; e1' <- genAnnotCE f g e1
-> AnnotM flexi CoreExpr -- yields new expression
genAnnotCE mungeType mungeTerm = go
- where go e0@(Var v) | isTyVar v = return e0 -- arises, e.g., as tyargs of Con
+ where go e0@(Var v) | isTyVar v = return e0 -- arises, e.g., as tyargs of constructor
-- (no it doesn't: (Type (TyVar tyvar))
| otherwise = do { mv' <- lookupAnnVar v
; v' <- case mv' of
; return (Var v')
}
- go (Con c args) = -- we know it's saturated
- do { args' <- mapM go args
- ; return (Con c args')
- }
+ go (Lit l) = -- we know it's saturated
+ return (Lit l)
go (App e arg) = do { e' <- go e
; arg' <- go arg
go (Note InlineCall e) = do { e' <- go e
; return (Note InlineCall e')
}
+ go (Note InlineMe e) = do { e' <- go e
+ ; return (Note InlineMe e')
+ }
go e0@(Note (TermUsg _) _) = do { e1 <- mungeTerm e0
; case e1 of -- munge may have removed note
Note tu@(TermUsg _) e2 -> do { e3 <- go e2
genAnnotVar :: (MungeFlags -> Type -> AnnotM flexi Type)
- -> IdOrTyVar
- -> AnnotM flexi IdOrTyVar
+ -> Var
+ -> AnnotM flexi Var
genAnnotVar mungeType v | isTyVar v = return v
| otherwise = do { vty' <- mungeType (sigVarTyMF v) (varType v)
; return (setVarType v vty')
}
-{- #ifdef DEBUG
+{- ifdef DEBUG
; return $
pprTrace "genAnnotVar" (ppr (tyUsg vty') <+> ppr v) $
(setVarType v vty')
- #endif
+ endif
-}
\end{code}
pessimiseN co (NoteTy note@(FTVNote _ ) ty) = NoteTy note (pessimiseN co ty)
pessimiseN co ty0@(TyVarTy _) = ty0
pessimiseN co ty0@(AppTy _ _) = ty0
-pessimiseN co ty0@(TyConApp tc tys) = ASSERT( not ((isFunTyCon tc) && (length tys > 1)) )
+pessimiseN co ty0@(TyConApp tc tys) = ASSERT( not ((isFunTyCon tc) && (tys `lengthExceeds` 1)) )
ty0
pessimiseN co (FunTy ty1 ty2) = FunTy (pessimise (not co) ty1)
(pessimise co ty2)
unannotTy :: Type -> Type
-- strip all annotations
+unannotTy (NoteTy (UsgForAll uv) ty) = unannotTy ty
unannotTy (NoteTy (UsgNote _ ) ty) = unannotTy ty
unannotTy (NoteTy (SynNote sty) ty) = NoteTy (SynNote (unannotTy sty)) (unannotTy ty)
unannotTy (NoteTy note@(FTVNote _ ) ty) = NoteTy note (unannotTy ty)
+unannotTy ty@(PredTy _) = ty -- PredTys need to be preserved
unannotTy ty@(TyVarTy _) = ty
unannotTy (AppTy ty1 ty2) = AppTy (unannotTy ty1) (unannotTy ty2)
unannotTy (TyConApp tc tys) = TyConApp tc (map unannotTy tys)
#ifndef USMANY
fixAnnotTy = id
#else
+fixAnnotTy (NoteTy note@(UsgForAll uv) ty) = NoteTy note (fixAnnotTy ty)
fixAnnotTy (NoteTy note@(UsgNote _ ) ty) = NoteTy note (fixAnnotTyN ty)
fixAnnotTy ty0 = NoteTy (UsgNote UsMany) (fixAnnotTyN ty0)
\begin{code}
newtype AnnotM flexi a = AnnotM ( flexi -- UniqSupply etc
- -> VarEnv IdOrTyVar -- unannotated to annotated variables
- -> (a,flexi,VarEnv IdOrTyVar))
+ -> VarEnv Var -- unannotated to annotated variables
+ -> (a,flexi,VarEnv Var))
unAnnotM (AnnotM f) = f
instance Monad (AnnotM flexi) where
initAnnotM :: fl -> AnnotM fl a -> (a,fl)
initAnnotM fl m = case (unAnnotM m) fl emptyVarEnv of { (r,fl',_) -> (r,fl') }
-withAnnVar :: IdOrTyVar -> IdOrTyVar -> AnnotM fl a -> AnnotM fl a
+withAnnVar :: Var -> Var -> AnnotM fl a -> AnnotM fl a
withAnnVar v v' m = AnnotM (\ us ve -> let ve' = extendVarEnv ve v v'
(r,us',_) = (unAnnotM m) us ve'
in (r,us',ve))
-withAnnVars :: [IdOrTyVar] -> [IdOrTyVar] -> AnnotM fl a -> AnnotM fl a
+withAnnVars :: [Var] -> [Var] -> AnnotM fl a -> AnnotM fl a
withAnnVars vs vs' m = AnnotM (\ us ve -> let ve' = plusVarEnv ve (zipVarEnv vs vs')
(r,us',_) = (unAnnotM m) us ve'
in (r,us',ve))
-lookupAnnVar :: IdOrTyVar -> AnnotM fl (Maybe IdOrTyVar)
+lookupAnnVar :: Var -> AnnotM fl (Maybe Var)
lookupAnnVar var = AnnotM (\ us ve -> (lookupVarEnv ve var,
us,
ve))
returnUs (UsVar uv)
{- #ifdef DEBUG
let src = case e of
- Left (Con (Literal _) _) -> "literal"
- Left (Con _ _) -> "primop"
+ Left (Lit _) -> "literal"
Left (Lam v e) -> "lambda: " ++ showSDoc (ppr v)
Left _ -> "unknown"
Right s -> s
-- substitution may reveal more args
in ((map (substTy s) ty0us) ++ ty1us,
rty1u)
+
+
+END OF ENTIRELY-COMMENTED-OUT FILE -- KSW 2000-10-13 -}
\end{code}
======================================================================