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,
MungeFlags(isSigma,isLocal,isExp,hasUsg,mfLoc),
doAnnotBinds, doUnAnnotBinds,
- annotMany, annotManyN, unannotTy, freshannotTy,
+ annotTy, annotTyN, annotMany, annotManyN, unannotTy, freshannotTy,
newVarUs, newVarUSMM,
UniqSMM, usToUniqSMM, uniqSMMToUs,
#include "HsVersions.h"
import CoreSyn
-import Const ( Con(..), Literal(..) )
-import Var ( IdOrTyVar, varName, varType, setVarType, mkUVar )
-import Id ( idMustBeINLINEd )
-import Name ( isLocallyDefined, isExported )
-import Type ( Type(..), TyNote(..), UsageAnn(..), isUsgTy, substTy, splitFunTys )
+import CoreFVs ( mustHaveLocalBinding )
+import Var ( Var, varName, varType, setVarType, mkUVar )
+import Id ( isExportedId )
+import Name ( isLocallyDefined )
+import TypeRep ( Type(..), TyNote(..) ) -- friend
+import Type ( UsageAnn(..), isUsgTy, 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
\end{code}
======================================================================
tauTyMF loc = MungeFlags { isSigma = False, isLocal = True,
hasUsg = False, isExp = False, mfLoc = loc }
sigVarTyMF v = MungeFlags { isSigma = True, isLocal = hasLocalDef v,
- hasUsg = hasUsgInfo v, isExp = isExported v,
+ hasUsg = hasUsgInfo v, isExp = isExportedId v,
mfLoc = ptext SLIT("type of binder") <+> ppr v }
\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 @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
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}
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)
#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
-- and returns this (sigma) type
primOpUsgTys p tys = let (tyvs,ty0us,rtyu) = primOpUsg p
- s = zipVarEnv tyvs tys
+ s = mkTyVarSubst tyvs tys
(ty1us,rty1u) = splitFunTys (substTy s rtyu)
-- substitution may reveal more args
in ((map (substTy s) ty0us) ++ ty1us,
projects / ghc-hetmet.git / blobdiff