X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=70963624a9569aef2d5eb5b33fd68b2b755714dc;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=7fc7505834044159fe27de1c620322963657f5d1;hpb=26741ec416bae2c502ef00a2ba0e79050a32cb67;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 7fc7505..7096362 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -75,6 +75,7 @@ module Id (
 	isTopLevId,
 	isTupleCon,
 	isWorkerId,
+	isWrapperId,
 	toplevelishId,
 	unfoldingUnfriendlyId,
 
@@ -89,6 +90,10 @@ module Id (
 	pprId,
 	showId,
 
+	-- Specialialisation
+	getIdSpecialisation,
+	addIdSpecialisation,
+
 	-- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
 	addIdArity,
 	addIdDemandInfo,
@@ -101,6 +106,7 @@ module Id (
 	getIdUnfolding,
 	getIdUpdateInfo,
 	getPragmaInfo,
+	replaceIdInfo,
 
 	-- IdEnvs AND IdSets
 	SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet),
@@ -124,6 +130,7 @@ module Id (
 	mkIdEnv,
 	mkIdSet,
 	modifyIdEnv,
+	modifyIdEnv_Directly,
 	nullIdEnv,
 	rngIdEnv,
 	unionIdSets,
@@ -158,6 +165,7 @@ import PprType		( getTypeString, typeMaybeString, specMaybeTysSuffix,
 			)
 import PprStyle
 import Pretty
+import MatchEnv		( MatchEnv )
 import SrcLoc		( mkBuiltinSrcLoc )
 import TyCon		( TyCon, mkTupleTyCon, tyConDataCons )
 import Type		( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
@@ -606,9 +614,7 @@ isSuperDictSelId_maybe other_id				  = Nothing
 isWorkerId (Id _ _ _ (WorkerId _) _ _) = True
 isWorkerId other		     = False
 
-{-LATER:
 isWrapperId id = workerExists (getIdStrictness id)
--}
 \end{code}
 
 \begin{code}
@@ -778,46 +784,7 @@ unfoldingUnfriendlyId	-- return True iff it is definitely a bad
 	-> Bool		-- mentions this Id.  Reason: it cannot
 			-- possibly be seen in another module.
 
-unfoldingUnfriendlyId id = panic "Id.unfoldingUnfriendlyId"
-{-LATER:
-
-unfoldingUnfriendlyId id
-  | not (externallyVisibleId id) -- that settles that...
-  = True
-
-unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper) _ _)
-  = class_thing wrapper
-  where
-    -- "class thing": If we're going to use this worker Id in
-    -- an interface, we *have* to be able to untangle the wrapper's
-    -- strictness when reading it back in.  At the moment, this
-    -- is not always possible: in precisely those cases where
-    -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
-
-    class_thing (Id _ _ _ (SuperDictSelId _ _) _ _)    = True
-    class_thing (Id _ _ _ (MethodSelId _ _) _ _)  	   = True
-    class_thing (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
-    class_thing other				   = False
-
-unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _)) _ _) _ _)
-    -- a SPEC of a DictFunId can end up w/ gratuitous
-    -- TyVar(Templates) in the i/face; only a problem
-    -- if -fshow-pragma-name-errs; but we can do without the pain.
-    -- A HACK in any case (WDP 94/05/02)
-  = naughty_DictFunId dfun
-
-unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _) _ _)
-  = naughty_DictFunId dfun -- similar deal...
-
-unfoldingUnfriendlyId other_id   = False -- is friendly in all other cases
-
-naughty_DictFunId :: IdDetails -> Bool
-    -- True <=> has a TyVar(Template) in the "type" part of its "name"
-
-naughty_DictFunId (DictFunId _ _ _) = panic "False" -- came from outside; must be OK
-naughty_DictFunId (DictFunId _ ty _)
-  = not (isGroundTy ty)
--}
+unfoldingUnfriendlyId id = not (externallyVisibleId id)
 \end{code}
 
 @externallyVisibleId@: is it true that another module might be
@@ -1089,7 +1056,7 @@ mkWorkerId u unwrkr ty info
   = Id u n ty (WorkerId unwrkr) NoPragmaInfo info
   where
     unwrkr_name = getName unwrkr
-    unwrkr_orig = trace "mkWorkerId:origName:" $ origName "mkWorkerId" unwrkr_name
+    unwrkr_orig = origName "mkWorkerId" unwrkr_name
     umod = moduleOf unwrkr_orig
 
     n = mkCompoundName u umod SLIT("wrk") [Left unwrkr_orig] unwrkr_name
@@ -1213,11 +1180,11 @@ getPragmaInfo :: GenId ty -> PragmaInfo
 getIdInfo     (Id _ _ _ _ _ info) = info
 getPragmaInfo (Id _ _ _ _ info _) = info
 
-{-LATER:
 replaceIdInfo :: Id -> IdInfo -> Id
 
-replaceIdInfo (Id u n ty _ details) info = Id u n ty info details
+replaceIdInfo (Id u n ty details pinfo _) info = Id u n ty details pinfo info
 
+{-LATER:
 selectIdInfoForSpecId :: Id -> IdInfo
 selectIdInfoForSpecId unspec
   = ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
@@ -1482,9 +1449,8 @@ Notice the ``big lambdas'' and type arguments to @Con@---we are producing
 %************************************************************************
 
 @getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
-and generates an @UnfoldingDetails@ for its unfolding.  The @Ids@ and
-@TyVars@ don't really have to be new, because we are only producing a
-template.
+and generates an @Unfolding@.  The @Ids@ and @TyVars@ don't really
+have to be new, because we are only producing a template.
 
 ToDo: what if @DataConId@'s type has a context (haven't thought about it
 --WDP)?
@@ -1497,16 +1463,16 @@ dictionaries, in the even of an overloaded data-constructor---none at
 present.)
 
 \begin{code}
-getIdUnfolding :: Id -> UnfoldingDetails
+getIdUnfolding :: Id -> Unfolding
 
 getIdUnfolding (Id _ _ _ _ _ info) = getInfo_UF info
 
 {-LATER:
-addIdUnfolding :: Id -> UnfoldingDetails -> Id
+addIdUnfolding :: Id -> Unfolding -> Id
 addIdUnfolding id@(Id u n ty info details) unfold_details
   = ASSERT(
     	case (isLocallyDefined id, unfold_details) of
-	(_,     NoUnfoldingDetails) -> True
+	(_,     NoUnfolding) -> True
 	(True,  IWantToBeINLINEd _) -> True
 	(False, IWantToBeINLINEd _) -> False -- v bad
 	(False, _)  	    	    -> True
@@ -1574,14 +1540,12 @@ addIdFBTypeInfo (Id u n ty info details) upd_info
 \end{code}
 
 \begin{code}
-{- LATER:
 getIdSpecialisation :: Id -> SpecEnv
 getIdSpecialisation (Id _ _ _ _ _ info) = getInfo info
 
 addIdSpecialisation :: Id -> SpecEnv -> Id
 addIdSpecialisation (Id u n ty details prags info) spec_info
   = Id u n ty details prags (info `addInfo` spec_info)
--}
 \end{code}
 
 Strictness: we snaffle the info out of the IdInfo.
@@ -1712,7 +1676,7 @@ delManyFromIdEnv  :: IdEnv a -> [GenId ty] -> IdEnv a
 delOneFromIdEnv	  :: IdEnv a -> GenId ty -> IdEnv a
 combineIdEnvs	  :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
 mapIdEnv	  :: (a -> b) -> IdEnv a -> IdEnv b
-modifyIdEnv	  :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
+modifyIdEnv	  :: (a -> a) -> IdEnv a -> GenId ty -> IdEnv a
 rngIdEnv	  :: IdEnv a -> [a]
 		  
 isNullIdEnv	  :: IdEnv a -> Bool
@@ -1740,10 +1704,15 @@ lookupNoFailIdEnv env id    = case (lookupIdEnv env id) of { Just xx -> xx }
 -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
 -- modify function, and put it back.
 
-modifyIdEnv env mangle_fn key
+modifyIdEnv mangle_fn env key
   = case (lookupIdEnv env key) of
       Nothing -> env
       Just xx -> addOneToIdEnv env key (mangle_fn xx)
+
+modifyIdEnv_Directly mangle_fn env key
+  = case (lookupUFM_Directly env key) of
+      Nothing -> env
+      Just xx -> addToUFM_Directly env key (mangle_fn xx)
 \end{code}
 
 \begin{code}