X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FusageSP%2FUsageSPUtils.lhs;h=4fb51f0eebb78fb962d26c357344250a8bb35b1c;hb=6c47f6156655687400570387b5f69a0aadb4acb4;hp=fd91ec217e8a8ae0b3bffddf7d4e3ac58edfec47;hpb=266fadd93461d4317967df08cd641e965cd8769a;p=ghc-hetmet.git

diff --git a/ghc/compiler/usageSP/UsageSPUtils.lhs b/ghc/compiler/usageSP/UsageSPUtils.lhs
index fd91ec2..4fb51f0 100644
--- a/ghc/compiler/usageSP/UsageSPUtils.lhs
+++ b/ghc/compiler/usageSP/UsageSPUtils.lhs
@@ -25,12 +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               ( mayHaveNoBinding, isExportedId )
+import CoreFVs		( mustHaveLocalBinding )
+import Literal          ( Literal(..) )
+import Var              ( Var, varName, varType, setVarType, mkUVar )
+import Id               ( isExportedId )
 import Name             ( isLocallyDefined )
 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
@@ -180,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 (mayHaveNoBinding var)
+hasLocalDef :: Var -> Bool
+hasLocalDef var = mustHaveLocalBinding var
 
-hasUsgInfo :: IdOrTyVar -> Bool
+hasUsgInfo :: Var -> Bool
 hasUsgInfo var = (not . isLocallyDefined) var
 \end{code}
 
@@ -209,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
@@ -230,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
@@ -239,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
@@ -320,8 +319,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)
@@ -551,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
@@ -563,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))
@@ -602,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