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),
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 ( mayHaveNoBinding, isExportedId )
+import Var ( Var, varType, setVarType, mkUVar )
+import Id ( isExportedId )
import Name ( isLocallyDefined )
import TypeRep ( Type(..), TyNote(..) ) -- friend
-import Type ( UsageAnn(..), isUsgTy, splitFunTys )
+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 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 @mayHaveNoBindingId@ 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 (mayHaveNoBinding 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
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)
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)
--- IP notes need to be preserved
-unannotTy ty@(NoteTy (IPNote _) _) = 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)
\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}
======================================================================
projects / ghc-hetmet.git / blobdiff