X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=13443a9852ee5e2fb9ebf3f76894d46fe44e2511;hb=46a825e77f5742d8881cf3f8fb59126257257338;hp=814fcb7ee4f7de79e3340a4a41f8f1acea11dc3c;hpb=e87d56ce33f663da1c445f37e95c40d814caa384;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 814fcb7..13443a9 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -9,7 +9,7 @@ module Id (
 
 	-- Simple construction
 	mkId, mkVanillaId, mkSysLocal, mkUserLocal,
-	mkTemplateLocals, mkWildId, mkTemplateLocal,
+	mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal,
 
 	-- Taking an Id apart
 	idName, idType, idUnique, idInfo,
@@ -22,92 +22,92 @@ module Id (
 	zapFragileIdInfo, zapLamIdInfo,
 
 	-- Predicates
-	omitIfaceSigForId,
-	exportWithOrigOccName,
+	isImplicitId, isDeadBinder,
 	externallyVisibleId,
-	idFreeTyVars,
-	isIP,
+	isSpecPragmaId,	isRecordSelector,
+	isPrimOpId, isPrimOpId_maybe, isDictFunId,
+	isDataConId, isDataConId_maybe, 
+	isDataConWrapId, isDataConWrapId_maybe,
+	isBottomingId,
+	isExportedId, isLocalId, 
+	hasNoBinding,
 
 	-- Inline pragma stuff
-	getInlinePragma, setInlinePragma, modifyInlinePragma, 
+	idInlinePragma, setInlinePragma, modifyInlinePragma, 
 
-	isSpecPragmaId,	isRecordSelector,
-	isPrimitiveId_maybe, isDataConId_maybe,
-	isConstantId, isConstantId_maybe, isBottomingId, idAppIsBottom,
-	isExportedId, isUserExportedId,
-	mayHaveNoBinding,
 
 	-- One shot lambda stuff
 	isOneShotLambda, setOneShotLambda, clearOneShotLambda,
 
 	-- IdInfo stuff
 	setIdUnfolding,
-	setIdArity,
+	setIdArityInfo,
 	setIdDemandInfo,
 	setIdStrictness,
+        setIdTyGenInfo,
 	setIdWorkerInfo,
 	setIdSpecialisation,
-	setIdUpdateInfo,
 	setIdCafInfo,
 	setIdCprInfo,
 	setIdOccInfo,
 
-	getIdArity,
-	getIdDemandInfo,
-	getIdStrictness,
-	getIdWorkerInfo,
-	getIdUnfolding,
-	getIdSpecialisation,
-	getIdUpdateInfo,
-	getIdCafInfo,
-	getIdCprInfo,
-	getIdOccInfo
+	idArity, idArityInfo, 
+	idFlavour,
+	idDemandInfo,
+	idStrictness,
+        idTyGenInfo,
+	idWorkerInfo,
+	idUnfolding,
+	idSpecialisation,
+	idCafInfo,
+	idCprInfo,
+	idLBVarInfo,
+	idOccInfo,
 
     ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} CoreUnfold ( Unfolding )
-import {-# SOURCE #-} CoreSyn    ( CoreRules )
 
+import CoreSyn		( Unfolding, CoreRules )
+import BasicTypes	( Arity )
 import Var		( Id, DictId,
 			  isId, mkIdVar,
 			  idName, idType, idUnique, idInfo,
 			  setIdName, setVarType, setIdUnique, 
-			  setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
+			  setIdInfo, lazySetIdInfo, modifyIdInfo, 
+			  maybeModifyIdInfo,
 			  externallyVisibleId
 			)
-import VarSet
-import Type		( Type, tyVarsOfType, typePrimRep, addFreeTyVars, seqType, splitTyConApp_maybe )
+import Type		( Type, typePrimRep, addFreeTyVars, 
+                          usOnce, seqType, splitTyConApp_maybe )
 
 import IdInfo 
 
-import Demand		( Demand, isStrict, wwLazy )
+import Demand		( Demand )
 import Name	 	( Name, OccName,
 			  mkSysLocalName, mkLocalName,
-			  isWiredInName, isUserExportedName,
-			  getOccName, isIPOcc
+			  getOccName
 			) 
 import OccName		( UserFS )
-import Const		( Con(..) )
 import PrimRep		( PrimRep )
-import PrimOp		( PrimOp )
 import TysPrim		( statePrimTyCon )
-import FieldLabel	( FieldLabel(..) )
+import FieldLabel	( FieldLabel )
 import SrcLoc		( SrcLoc )
-import Unique		( Unique, mkBuiltinUnique, getBuiltinUniques )
+import Unique		( Unique, mkBuiltinUnique, getBuiltinUniques, 
+			  getNumBuiltinUniques )
 import Outputable
 
 infixl 	1 `setIdUnfolding`,
-	  `setIdArity`,
+	  `setIdArityInfo`,
 	  `setIdDemandInfo`,
 	  `setIdStrictness`,
+	  `setIdTyGenInfo`,
 	  `setIdWorkerInfo`,
 	  `setIdSpecialisation`,
-	  `setIdUpdateInfo`,
 	  `setInlinePragma`,
-	  `getIdCafInfo`,
-	  `getIdCprInfo`
+	  `idCafInfo`,
+	  `idCprInfo`
 
 	-- infixl so you can say (id `set` a `set` b)
 \end{code}
@@ -127,10 +127,7 @@ Absolutely all Ids are made by mkId.  It
 
 \begin{code}
 mkId :: Name -> Type -> IdInfo -> Id
-mkId name ty info = mkIdVar name (addFreeTyVars ty) info'
-		  where
-		    info' | isUserExportedName name = setNoDiscardInfo info
-			  | otherwise		    = info
+mkId name ty info = mkIdVar name (addFreeTyVars ty) info
 \end{code}
 
 \begin{code}
@@ -161,6 +158,12 @@ mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl"))
 			       (getBuiltinUniques (length tys))
 			       tys
 
+mkTemplateLocalsNum :: Int -> [Type] -> [Id]
+-- The Int gives the starting point for unique allocation
+mkTemplateLocalsNum n tys = zipWith (mkSysLocal SLIT("tpl"))
+			       (getNumBuiltinUniques n (length tys))
+			       tys
+
 mkTemplateLocal :: Int -> Type -> Id
 mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty
 \end{code}
@@ -173,9 +176,6 @@ mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty
 %************************************************************************
 
 \begin{code}
-idFreeTyVars :: Id -> TyVarSet
-idFreeTyVars id = tyVarsOfType (idType id)
-
 setIdType :: Id -> Type -> Id
 	-- Add free tyvar info to the type
 setIdType id ty = seqType ty `seq` setVarType id (addFreeTyVars ty)
@@ -207,78 +207,95 @@ isRecordSelector id = case idFlavour id of
 			RecordSelId lbl -> True
 			other	  	-> False
 
-isPrimitiveId_maybe id = case idFlavour id of
-			    ConstantId (PrimOp op) -> Just op
-			    other		   -> Nothing
+isPrimOpId id = case idFlavour id of
+		    PrimOpId op -> True
+		    other	-> False
+
+isPrimOpId_maybe id = case idFlavour id of
+			    PrimOpId op -> Just op
+			    other	-> Nothing
+
+isDataConId id = case idFlavour id of
+			DataConId _ -> True
+			other	    -> False
 
 isDataConId_maybe id = case idFlavour id of
-			  ConstantId (DataCon con) -> Just con
-			  other		           -> Nothing
+			  DataConId con -> Just con
+			  other	        -> Nothing
 
-isConstantId id = case idFlavour id of
-		    ConstantId _ -> True
-		    other	 -> False
+isDataConWrapId_maybe id = case idFlavour id of
+				  DataConWrapId con -> Just con
+				  other	            -> Nothing
 
-isConstantId_maybe id = case idFlavour id of
-		  	  ConstantId const -> Just const
-			  other	           -> Nothing
+isDataConWrapId id = case idFlavour id of
+			DataConWrapId con -> True
+			other	          -> False
 
 isSpecPragmaId id = case idFlavour id of
 			SpecPragmaId -> True
 			other	     -> False
 
-mayHaveNoBinding id = isConstantId id
-	-- mayHaveNoBinding returns True of an Id which may not have a
+hasNoBinding id = case idFlavour id of
+			DataConId _ -> True
+			PrimOpId _  -> True
+			other	    -> False
+	-- hasNoBinding returns True of an Id which may not have a
 	-- binding, even though it is defined in this module.  Notably,
 	-- the constructors of a dictionary are in this situation.
-	--	
-	-- mayHaveNoBinding returns True of some things that *do* have a local binding,
-	-- so it's only an approximation.  That's ok... it's only use for assertions.
+
+isDictFunId id = case idFlavour id of
+		   DictFunId -> True
+		   other     -> False
 
 -- Don't drop a binding for an exported Id,
 -- if it otherwise looks dead.  
+-- Perhaps a better name would be isDiscardableId
 isExportedId :: Id -> Bool
 isExportedId id = case idFlavour id of
-			VanillaId -> False
-			other	  -> True	-- All the others are no-discard
-
--- Say if an Id was exported by the user
--- Implies isExportedId (see mkId above)
-isUserExportedId :: Id -> Bool
-isUserExportedId id = isUserExportedName (idName id)
+			VanillaId  -> False
+			other	   -> True
+
+isLocalId :: Id -> Bool
+-- True of Ids that are locally defined, but are not constants
+-- like data constructors, record selectors, and the like. 
+-- See comments with CoreFVs.isLocalVar
+isLocalId id 
+#ifdef DEBUG
+  | not (isId id) = pprTrace "isLocalid" (ppr id) False
+  | otherwise
+#endif
+  = case idFlavour id of
+	 VanillaId    -> True
+	 ExportedId   -> True
+	 SpecPragmaId -> True
+	 other	      -> False
 \end{code}
 
 
-omitIfaceSigForId tells whether an Id's info is implied by other declarations,
-so we don't need to put its signature in an interface file, even if it's mentioned
-in some other interface unfolding.
+isImplicitId tells whether an Id's info is implied by other
+declarations, so we don't need to put its signature in an interface
+file, even if it's mentioned in some other interface unfolding.
 
 \begin{code}
-omitIfaceSigForId :: Id -> Bool
-omitIfaceSigForId id
-  | isWiredInName (idName id)
-  = True
-
-  | otherwise
+isImplicitId :: Id -> Bool
+isImplicitId id
   = case idFlavour id of
-	RecordSelId _  -> True	-- Includes dictionary selectors
-        ConstantId _   -> True
-		-- ConstantIds are implied by their type or class decl;
+	RecordSelId _   -> True	-- Includes dictionary selectors
+        PrimOpId _      -> True
+        DataConId _     -> True
+	DataConWrapId _ -> True
+		-- These are are implied by their type or class decl;
 		-- remember that all type and class decls appear in the interface file.
 		-- The dfun id must *not* be omitted, because it carries version info for
 		-- the instance decl
-
-	other	       -> False	-- Don't omit!
-
--- Certain names must be exported with their original occ names, because
--- these names are bound by either a class declaration or a data declaration
--- or an explicit user export.
-exportWithOrigOccName :: Id -> Bool
-exportWithOrigOccName id = omitIfaceSigForId id || isUserExportedId id
-
-isIP id = isIPOcc (getOccName id)
+	other		-> False
 \end{code}
 
+\begin{code}
+isDeadBinder :: Id -> Bool
+isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)
+		  | otherwise = False	-- TyVars count as not dead
+\end{code}
 
 
 %************************************************************************
@@ -290,87 +307,87 @@ isIP id = isIPOcc (getOccName id)
 \begin{code}
 	---------------------------------
 	-- ARITY
-getIdArity :: Id -> ArityInfo
-getIdArity id = arityInfo (idInfo id)
+idArityInfo :: Id -> ArityInfo
+idArityInfo id = arityInfo (idInfo id)
+
+idArity :: Id -> Arity
+idArity id = arityLowerBound (idArityInfo id)
 
-setIdArity :: Id -> ArityInfo -> Id
-setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
+setIdArityInfo :: Id -> ArityInfo -> Id
+setIdArityInfo id arity = modifyIdInfo (`setArityInfo` arity) id
 
 	---------------------------------
 	-- STRICTNESS
-getIdStrictness :: Id -> StrictnessInfo
-getIdStrictness id = strictnessInfo (idInfo id)
+idStrictness :: Id -> StrictnessInfo
+idStrictness id = strictnessInfo (idInfo id)
 
 setIdStrictness :: Id -> StrictnessInfo -> Id
 setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id
 
 -- isBottomingId returns true if an application to n args would diverge
 isBottomingId :: Id -> Bool
-isBottomingId id = isBottomingStrictness (strictnessInfo (idInfo id))
+isBottomingId id = isBottomingStrictness (idStrictness id)
 
-idAppIsBottom :: Id -> Int -> Bool
-idAppIsBottom id n = appIsBottom (strictnessInfo (idInfo id)) n
+	---------------------------------
+	-- TYPE GENERALISATION
+idTyGenInfo :: Id -> TyGenInfo
+idTyGenInfo id = tyGenInfo (idInfo id)
+
+setIdTyGenInfo :: Id -> TyGenInfo -> Id
+setIdTyGenInfo id tygen_info = modifyIdInfo (`setTyGenInfo` tygen_info) id
 
 	---------------------------------
 	-- WORKER ID
-getIdWorkerInfo :: Id -> WorkerInfo
-getIdWorkerInfo id = workerInfo (idInfo id)
+idWorkerInfo :: Id -> WorkerInfo
+idWorkerInfo id = workerInfo (idInfo id)
 
 setIdWorkerInfo :: Id -> WorkerInfo -> Id
 setIdWorkerInfo id work_info = modifyIdInfo (`setWorkerInfo` work_info) id
 
 	---------------------------------
 	-- UNFOLDING
-getIdUnfolding :: Id -> Unfolding
-getIdUnfolding id = unfoldingInfo (idInfo id)
+idUnfolding :: Id -> Unfolding
+idUnfolding id = unfoldingInfo (idInfo id)
 
 setIdUnfolding :: Id -> Unfolding -> Id
 setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
 
 	---------------------------------
 	-- DEMAND
-getIdDemandInfo :: Id -> Demand
-getIdDemandInfo id = demandInfo (idInfo id)
+idDemandInfo :: Id -> Demand
+idDemandInfo id = demandInfo (idInfo id)
 
 setIdDemandInfo :: Id -> Demand -> Id
 setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id
 
 	---------------------------------
-	-- UPDATE INFO
-getIdUpdateInfo :: Id -> UpdateInfo
-getIdUpdateInfo id = updateInfo (idInfo id)
-
-setIdUpdateInfo :: Id -> UpdateInfo -> Id
-setIdUpdateInfo id upd_info = modifyIdInfo (`setUpdateInfo` upd_info) id
-
-	---------------------------------
 	-- SPECIALISATION
-getIdSpecialisation :: Id -> CoreRules
-getIdSpecialisation id = specInfo (idInfo id)
+idSpecialisation :: Id -> CoreRules
+idSpecialisation id = specInfo (idInfo id)
 
 setIdSpecialisation :: Id -> CoreRules -> Id
 setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
 
 	---------------------------------
 	-- CAF INFO
-getIdCafInfo :: Id -> CafInfo
-getIdCafInfo id = cafInfo (idInfo id)
+idCafInfo :: Id -> CafInfo
+idCafInfo id = cafInfo (idInfo id)
 
 setIdCafInfo :: Id -> CafInfo -> Id
 setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
 
 	---------------------------------
 	-- CPR INFO
-getIdCprInfo :: Id -> CprInfo
-getIdCprInfo id = cprInfo (idInfo id)
+idCprInfo :: Id -> CprInfo
+idCprInfo id = cprInfo (idInfo id)
 
 setIdCprInfo :: Id -> CprInfo -> Id
 setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id
 
 	---------------------------------
 	-- Occcurrence INFO
-getIdOccInfo :: Id -> OccInfo
-getIdOccInfo id = occInfo (idInfo id)
+idOccInfo :: Id -> OccInfo
+idOccInfo id = occInfo (idInfo id)
 
 setIdOccInfo :: Id -> OccInfo -> Id
 setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id
@@ -383,8 +400,8 @@ The inline pragma tells us to be very keen to inline this Id, but it's still
 OK not to if optimisation is switched off.
 
 \begin{code}
-getInlinePragma :: Id -> InlinePragInfo
-getInlinePragma id = inlinePragInfo (idInfo id)
+idInlinePragma :: Id -> InlinePragInfo
+idInlinePragma id = inlinePragInfo (idInfo id)
 
 setInlinePragma :: Id -> InlinePragInfo -> Id
 setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id
@@ -397,12 +414,18 @@ modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (
 	---------------------------------
 	-- ONE-SHOT LAMBDAS
 \begin{code}
+idLBVarInfo :: Id -> LBVarInfo
+idLBVarInfo id = lbvarInfo (idInfo id)
+
 isOneShotLambda :: Id -> Bool
-isOneShotLambda id = case lbvarInfo (idInfo id) of
-			IsOneShotLambda -> True
-			NoLBVarInfo	-> case splitTyConApp_maybe (idType id) of
-						Just (tycon,_) -> tycon == statePrimTyCon
-						other	       -> False
+isOneShotLambda id = analysis || hack
+  where analysis = case idLBVarInfo id of
+                     LBVarInfo u    | u == usOnce             -> True
+                     other                                    -> False
+        hack     = case splitTyConApp_maybe (idType id) of
+                     Just (tycon,_) | tycon == statePrimTyCon -> True
+                     other                                    -> False
+
 	-- The last clause is a gross hack.  It claims that 
 	-- every function over realWorldStatePrimTy is a one-shot
 	-- function.  This is pretty true in practice, and makes a big
@@ -422,7 +445,7 @@ isOneShotLambda id = case lbvarInfo (idInfo id) of
 	-- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.
 
 setOneShotLambda :: Id -> Id
-setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id
+setOneShotLambda id = modifyIdInfo (`setLBVarInfo` LBVarInfo usOnce) id
 
 clearOneShotLambda :: Id -> Id
 clearOneShotLambda id