X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FusageSP%2FUsageSPUtils.lhs;h=4fb51f0eebb78fb962d26c357344250a8bb35b1c;hb=6c47f6156655687400570387b5f69a0aadb4acb4;hp=6f7c636310de8660cd658445c213a16c2cd0419a;hpb=10b66230065ac2426509b60eb2da0a314b34d0e3;p=ghc-hetmet.git diff --git a/ghc/compiler/usageSP/UsageSPUtils.lhs b/ghc/compiler/usageSP/UsageSPUtils.lhs index 6f7c636..4fb51f0 100644 --- a/ghc/compiler/usageSP/UsageSPUtils.lhs +++ b/ghc/compiler/usageSP/UsageSPUtils.lhs @@ -6,7 +6,7 @@ This code is (based on) PhD work of Keith Wansbrough , September 1998 .. May 1999. -Keith Wansbrough 1998-09-04..1999-06-25 +Keith Wansbrough 1998-09-04..1999-07-07 \begin{code} module UsageSPUtils ( AnnotM(AnnotM), initAnnotM, @@ -14,7 +14,7 @@ module UsageSPUtils ( AnnotM(AnnotM), initAnnotM, MungeFlags(isSigma,isLocal,isExp,hasUsg,mfLoc), doAnnotBinds, doUnAnnotBinds, - annotMany, annotManyN, unannotTy, freshannotTy, + annotTy, annotTyN, annotMany, annotManyN, unannotTy, freshannotTy, newVarUs, newVarUSMM, UniqSMM, usToUniqSMM, uniqSMMToUs, @@ -25,11 +25,14 @@ module UsageSPUtils ( AnnotM(AnnotM), initAnnotM, #include "HsVersions.h" import CoreSyn -import Const ( Con(..), Literal(..) ) -import Var ( IdOrTyVar, varName, varType, setVarType, mkUVar ) -import Id ( idMustBeINLINEd, isExportedId ) +import CoreFVs ( mustHaveLocalBinding ) +import Literal ( Literal(..) ) +import Var ( Var, varName, varType, setVarType, mkUVar ) +import Id ( isExportedId ) import Name ( isLocallyDefined ) -import Type ( Type(..), TyNote(..), UsageAnn(..), isUsgTy, splitFunTys ) +import TypeRep ( Type(..), TyNote(..) ) -- friend +import Type ( UsageAnn(..), isUsgTy, splitFunTys ) +import PprType ( {- instance Outputable Type -} ) import Subst ( substTy, mkTyVarSubst ) import TyCon ( isAlgTyCon, isPrimTyCon, isSynTyCon, isFunTyCon ) import VarEnv @@ -166,7 +169,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 @IMustBeINLINEd@ things (usually) don't have +@isLocallyDefined@, since @mayHaveNoBindingId@ 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 @@ -179,11 +182,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 (idMustBeINLINEd var) +hasLocalDef :: Var -> Bool +hasLocalDef var = mustHaveLocalBinding var -hasUsgInfo :: IdOrTyVar -> Bool +hasUsgInfo :: Var -> Bool hasUsgInfo var = (not . isLocallyDefined) var \end{code} @@ -208,8 +210,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 @@ -229,7 +231,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 @@ -238,10 +240,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 @@ -319,18 +319,18 @@ 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) ; return (setVarType v vty') } -{- #ifdef DEBUG +{- ifdef DEBUG ; return $ pprTrace "genAnnotVar" (ppr (tyUsg vty') <+> ppr v) $ (setVarType v vty') - #endif + endif -} \end{code} @@ -459,9 +459,12 @@ unTermUsg _ = panic "unTermUsg" 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) +-- IP notes need to be preserved +unannotTy ty@(NoteTy (IPNote _) _) = ty unannotTy ty@(TyVarTy _) = ty unannotTy (AppTy ty1 ty2) = AppTy (unannotTy ty1) (unannotTy ty2) unannotTy (TyConApp tc tys) = TyConApp tc (map unannotTy tys) @@ -474,6 +477,7 @@ fixAnnotTy :: Type -> Type #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) @@ -546,8 +550,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 @@ -558,17 +562,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)) @@ -597,8 +601,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