X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FusageSP%2FUsageSPUtils.lhs;h=0a18567666a460647f995b36cd4b85561b74194d;hb=31285afea6a7b553380fd0a01e0a8ce0d7e50878;hp=d421d1be3e452b792fb657a79c6ebed98f8f403b;hpb=30b5ebe424ebae69b162ac3fc547eb14d898535f;p=ghc-hetmet.git diff --git a/ghc/compiler/usageSP/UsageSPUtils.lhs b/ghc/compiler/usageSP/UsageSPUtils.lhs index d421d1b..0a18567 100644 --- 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} -module UsageSPUtils ( AnnotM(AnnotM), initAnnotM, +module UsageSPUtils ( {- SEE BELOW: -- KSW 2000-10-13 + AnnotM(AnnotM), initAnnotM, genAnnotBinds, MungeFlags(isSigma,isLocal,isExp,hasUsg,mfLoc), @@ -19,26 +20,31 @@ module UsageSPUtils ( AnnotM(AnnotM), initAnnotM, 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} ====================================================================== @@ -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 -@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 @@ -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} -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} @@ -209,8 +214,8 @@ genAnnotBind :: (MungeFlags -> Type -> AnnotM flexi Type) -- type-altering func -> 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 @@ -230,7 +235,7 @@ genAnnotCE :: (MungeFlags -> Type -> AnnotM flexi Type) -- type-altering functi -> 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 @@ -239,10 +244,8 @@ genAnnotCE mungeType mungeTerm = go ; 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 @@ -320,8 +323,8 @@ genAnnotCE mungeType mungeTerm = go 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) @@ -464,6 +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 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) @@ -549,8 +553,8 @@ variable mapping, along with some general state. \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 @@ -561,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') } -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)) @@ -600,8 +604,7 @@ newVarUs e = getUniqueUs `thenUs` \ u -> 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 @@ -633,6 +636,9 @@ primOpUsgTys p tys = let (tyvs,ty0us,rtyu) = primOpUsg p -- substitution may reveal more args in ((map (substTy s) ty0us) ++ ty1us, rty1u) + + +END OF ENTIRELY-COMMENTED-OUT FILE -- KSW 2000-10-13 -} \end{code} ======================================================================