[project @ 2000-07-11 16:24:57 by simonmar]

[ghc-hetmet.git] / ghc / compiler / usageSP / UsageSPUtils.lhs

diff --git a/ghc/compiler/usageSP/UsageSPUtils.lhs b/ghc/compiler/usageSP/UsageSPUtils.lhs
index fd91ec2..9246709 100644 (file)
--- a/ghc/compiler/usageSP/UsageSPUtils.lhs
+++ b/ghc/compiler/usageSP/UsageSPUtils.lhs
@@ -25,9 +25,9 @@ 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 Var              ( Var, varName, varType, setVarType, mkUVar )
+import Id               ( isExportedId )
 import Name             ( isLocallyDefined )
 import TypeRep          ( Type(..), TyNote(..) )  -- friend
 import Type             ( UsageAnn(..), isUsgTy, splitFunTys )
@@ -35,10 +35,8 @@ 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}
 
 ======================================================================
@@ -180,11 +178,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 +206,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 +227,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 +236,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 +315,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 +546,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 +558,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 +597,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