projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 2001-09-25 18:08:47 by ken]
[ghc-hetmet.git]
/
ghc
/
compiler
/
usageSP
/
UsageSPUtils.lhs
diff --git
a/ghc/compiler/usageSP/UsageSPUtils.lhs
b/ghc/compiler/usageSP/UsageSPUtils.lhs
index
fd91ec2
..
0a18567
100644
(file)
--- a/
ghc/compiler/usageSP/UsageSPUtils.lhs
+++ b/
ghc/compiler/usageSP/UsageSPUtils.lhs
@@
-9,7
+9,8
@@
September 1998 .. May 1999.
Keith Wansbrough 1998-09-04..1999-07-07
\begin{code}
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),
genAnnotBinds,
MungeFlags(isSigma,isLocal,isExp,hasUsg,mfLoc),
@@
-19,26
+20,31
@@
module UsageSPUtils ( AnnotM(AnnotM), initAnnotM,
newVarUs, newVarUSMM,
UniqSMM, usToUniqSMM, uniqSMMToUs,
newVarUs, newVarUSMM,
UniqSMM, usToUniqSMM, uniqSMMToUs,
- primOpUsgTys,
+ primOpUsgTys, -}
) where
#include "HsVersions.h"
) where
#include "HsVersions.h"
+{- ENTIRE FILE COMMENTED OUT FOR NOW -- KSW 2000-10-13
import CoreSyn
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 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 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 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}
======================================================================
\end{code}
======================================================================
@@
-167,7
+173,7
@@
for us. @sigVarTyMF@ checks the variable to see how to set the flags.
@hasLocalDef@ tells us if the given variable has an actual local
definition that we can play with. This is not quite the same as
@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
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
@@
-180,11
+186,10
@@
usage info in its type that must at all costs be preserved. This is
assumed true (exactly) of all imported ids.
\begin{code}
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}
hasUsgInfo var = (not . isLocallyDefined) var
\end{code}
@@
-209,8
+214,8
@@
genAnnotBind :: (MungeFlags -> Type -> AnnotM flexi Type) -- type-altering func
-> CoreBind -- original CoreBind
-> AnnotM flexi
(CoreBind, -- annotated CoreBind
-> 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
genAnnotBind f g (NonRec v1 e1) = do { v1' <- genAnnotVar f v1
; e1' <- genAnnotCE f g e1
@@
-230,7
+235,7
@@
genAnnotCE :: (MungeFlags -> Type -> AnnotM flexi Type) -- type-altering functi
-> AnnotM flexi CoreExpr -- yields new expression
genAnnotCE mungeType mungeTerm = go
-> 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
-- (no it doesn't: (Type (TyVar tyvar))
| otherwise = do { mv' <- lookupAnnVar v
; v' <- case mv' of
@@
-239,10
+244,8
@@
genAnnotCE mungeType mungeTerm = go
; return (Var v')
}
; 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 (App e arg) = do { e' <- go e
; arg' <- go arg
@@
-320,8
+323,8
@@
genAnnotCE mungeType mungeTerm = go
genAnnotVar :: (MungeFlags -> Type -> AnnotM flexi Type)
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)
genAnnotVar mungeType v | isTyVar v = return v
| otherwise = do { vty' <- mungeType (sigVarTyMF v) (varType v)
@@
-464,8
+467,7
@@
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 (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)
unannotTy ty@(TyVarTy _) = ty
unannotTy (AppTy ty1 ty2) = AppTy (unannotTy ty1) (unannotTy ty2)
unannotTy (TyConApp tc tys) = TyConApp tc (map unannotTy tys)
@@
-551,8
+553,8
@@
variable mapping, along with some general state.
\begin{code}
newtype AnnotM flexi a = AnnotM ( flexi -- UniqSupply etc
\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
unAnnotM (AnnotM f) = f
instance Monad (AnnotM flexi) where
@@
-563,17
+565,17
@@
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') }
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))
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))
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))
lookupAnnVar var = AnnotM (\ us ve -> (lookupVarEnv ve var,
us,
ve))
@@
-602,8
+604,7
@@
newVarUs e = getUniqueUs `thenUs` \ u ->
returnUs (UsVar uv)
{- #ifdef DEBUG
let src = case e of
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
Left (Lam v e) -> "lambda: " ++ showSDoc (ppr v)
Left _ -> "unknown"
Right s -> s
@@
-635,6
+636,9
@@
primOpUsgTys p tys = let (tyvs,ty0us,rtyu) = primOpUsg p
-- substitution may reveal more args
in ((map (substTy s) ty0us) ++ ty1us,
rty1u)
-- substitution may reveal more args
in ((map (substTy s) ty0us) ++ ty1us,
rty1u)
+
+
+END OF ENTIRELY-COMMENTED-OUT FILE -- KSW 2000-10-13 -}
\end{code}
======================================================================
\end{code}
======================================================================