X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=d562a4d45589af6e1578158b2036c14e627f3573;hb=c837a7f2f12d3f340454b9525be188f3ec27c8cf;hp=56afa7ae6be4b84bd3f5da753fc15e5b3bc9f8c7;hpb=7e602b0a11e567fcb035d1afd34015aebcf9a577;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 56afa7a..d562a4d 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -8,74 +8,91 @@ module Id (
 	Id, DictId,
 
 	-- Simple construction
-	mkVanillaId, mkImportedId, mkSysLocal, mkUserLocal,
-	mkTemplateLocals, mkWildId, mkUserId,
+	mkId, mkVanillaId, mkSysLocal, mkUserLocal,
+	mkTemplateLocals, mkWildId, mkTemplateLocal,
 
 	-- Taking an Id apart
-	idName, idType, idUnique, idInfo, idDetails,
+	idName, idType, idUnique, idInfo,
 	idPrimRep, isId,
 	recordSelectorFieldLabel,
 
 	-- Modifying an Id
-	setIdName, setIdUnique, setIdType, setIdInfo, mkIdVisible,
+	setIdName, setIdUnique, setIdType, setIdNoDiscard, 
+	setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
+	zapFragileIdInfo, zapLamIdInfo,
 
 	-- Predicates
 	omitIfaceSigForId,
+	exportWithOrigOccName,
 	externallyVisibleId,
 	idFreeTyVars, 
 
 	-- Inline pragma stuff
 	getInlinePragma, setInlinePragma, modifyInlinePragma, 
-	idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd,
-	isSpecPragmaId,
-	
 
-	isRecordSelector,
+	isSpecPragmaId,	isRecordSelector,
 	isPrimitiveId_maybe, isDataConId_maybe,
-	isConstantId,
-	isBottomingId, idAppIsBottom,
+	isConstantId, isBottomingId, idAppIsBottom,
+	isExportedId, isUserExportedId,
+	mayHaveNoBinding,
+
+	-- One shot lambda stuff
+	isOneShotLambda, setOneShotLambda, clearOneShotLambda,
 
 	-- IdInfo stuff
 	setIdUnfolding,
 	setIdArity,
 	setIdDemandInfo,
 	setIdStrictness,
+	setIdWorkerInfo,
 	setIdSpecialisation,
 	setIdUpdateInfo,
 	setIdCafInfo,
+	setIdCprInfo,
+	setIdOccInfo,
 
 	getIdArity,
 	getIdDemandInfo,
 	getIdStrictness,
+	getIdWorkerInfo,
 	getIdUnfolding,
 	getIdSpecialisation,
 	getIdUpdateInfo,
-	getIdCafInfo
+	getIdCafInfo,
+	getIdCprInfo,
+	getIdOccInfo
 
     ) where
 
 #include "HsVersions.h"
 
 import {-# SOURCE #-} CoreUnfold ( Unfolding )
+import {-# SOURCE #-} CoreSyn    ( CoreRules )
 
-import Var		( Id, DictId, VarDetails(..), 
-			  isId, mkId, 
-			  idName, idType, idUnique, idInfo, idDetails,
-			  setIdName, setVarType, setIdUnique, setIdInfo, modifyIdInfo,
+import Var		( Id, DictId,
+			  isId, mkIdVar,
+			  idName, idType, idUnique, idInfo,
+			  setIdName, setVarType, setIdUnique, 
+			  setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
 			  externallyVisibleId
 			)
 import VarSet
-import Type		( Type, tyVarsOfType, typePrimRep, addFreeTyVars )
-import IdInfo
-import Demand		( Demand )
-import Name	 	( Name, OccName, Module,
+import Type		( Type, tyVarsOfType, typePrimRep, addFreeTyVars, seqType, splitTyConApp_maybe )
+
+import IdInfo 
+
+import Demand		( Demand, isStrict, wwLazy )
+import Name	 	( Name, OccName,
 			  mkSysLocalName, mkLocalName,
-			  isWiredInName, mkNameVisible
+			  isWiredInName, isUserExportedName
 			) 
+import OccName		( UserFS )
 import Const		( Con(..) )
 import PrimRep		( PrimRep )
 import PrimOp		( PrimOp )
+import TysPrim		( statePrimTyCon )
 import FieldLabel	( FieldLabel(..) )
+import SrcLoc		( SrcLoc )
 import Unique		( Unique, mkBuiltinUnique, getBuiltinUniques )
 import Outputable
 
@@ -83,9 +100,13 @@ infixl 	1 `setIdUnfolding`,
 	  `setIdArity`,
 	  `setIdDemandInfo`,
 	  `setIdStrictness`,
+	  `setIdWorkerInfo`,
 	  `setIdSpecialisation`,
 	  `setIdUpdateInfo`,
-	  `setInlinePragma`
+	  `setInlinePragma`,
+	  `getIdCafInfo`,
+	  `getIdCprInfo`
+
 	-- infixl so you can say (id `set` a `set` b)
 \end{code}
 
@@ -97,23 +118,30 @@ infixl 	1 `setIdUnfolding`,
 %*									*
 %************************************************************************
 
-\begin{code}
-mkVanillaId :: Name -> Type -> Id
-mkVanillaId name ty = mkId name (addFreeTyVars ty) VanillaId noIdInfo
+Absolutely all Ids are made by mkId.  It 
+	a) Pins free-tyvar-info onto the Id's type, 
+	   where it can easily be found.
+	b) Ensures that exported Ids are 
 
-mkImportedId :: Name -> Type -> IdInfo -> Id
-mkImportedId name ty info = mkId name (addFreeTyVars ty) VanillaId info
+\begin{code}
+mkId :: Name -> Type -> IdInfo -> Id
+mkId name ty info = mkIdVar name (addFreeTyVars ty) info'
+		  where
+		    info' | isUserExportedName name = setNoDiscardInfo info
+			  | otherwise		    = info
+\end{code}
 
-mkUserId :: Name -> Type -> Id
-mkUserId name ty = mkVanillaId name ty
+\begin{code}
+mkVanillaId :: Name -> Type -> Id
+mkVanillaId name ty = mkId name ty vanillaIdInfo
 
 -- SysLocal: for an Id being created by the compiler out of thin air...
 -- UserLocal: an Id with a name the user might recognize...
-mkUserLocal :: OccName     -> Unique -> Type -> Id
-mkSysLocal  :: FAST_STRING -> Unique -> Type -> Id
+mkUserLocal :: OccName -> Unique -> Type -> SrcLoc -> Id
+mkSysLocal  :: UserFS  -> Unique -> Type -> Id
 
-mkSysLocal  fs uniq ty  = mkVanillaId (mkSysLocalName uniq fs)  ty
-mkUserLocal occ uniq ty = mkVanillaId (mkLocalName    uniq occ) ty
+mkSysLocal  fs uniq ty      = mkVanillaId (mkSysLocalName uniq fs)      ty
+mkUserLocal occ uniq ty loc = mkVanillaId (mkLocalName    uniq occ loc) ty
 \end{code}
 
 Make some local @Ids@ for a template @CoreExpr@.  These have bogus
@@ -130,6 +158,9 @@ mkTemplateLocals :: [Type] -> [Id]
 mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl"))
 			       (getBuiltinUniques (length tys))
 			       tys
+
+mkTemplateLocal :: Int -> Type -> Id
+mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty
 \end{code}
 
 
@@ -145,39 +176,12 @@ idFreeTyVars id = tyVarsOfType (idType id)
 
 setIdType :: Id -> Type -> Id
 	-- Add free tyvar info to the type
-setIdType id ty = setVarType id (addFreeTyVars ty)
+setIdType id ty = seqType ty `seq` setVarType id (addFreeTyVars ty)
 
 idPrimRep :: Id -> PrimRep
 idPrimRep id = typePrimRep (idType id)
 \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.
-
-\begin{code}
-omitIfaceSigForId :: Id -> Bool
-omitIfaceSigForId id
-  | isWiredInName (idName id)
-  = True
-
-  | otherwise
-  = case idDetails id of
-	RecordSelId _  -> True	-- Includes dictionary selectors
-        ConstantId _   -> True
-		-- ConstantIds 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!
-\end{code}
-
-\begin{code}
-mkIdVisible :: Module -> Unique -> Id -> Id
-mkIdVisible mod u id 
-  = setIdName id (mkNameVisible mod u (idName id))
-\end{code}
 
 %************************************************************************
 %*									*
@@ -186,28 +190,89 @@ mkIdVisible mod u id
 %************************************************************************
 
 \begin{code}
+idFlavour :: Id -> IdFlavour
+idFlavour id = flavourInfo (idInfo id)
+
+setIdNoDiscard :: Id -> Id
+setIdNoDiscard id	-- Make an Id into a NoDiscardId, unless it is already
+  = modifyIdInfo setNoDiscardInfo id
+
 recordSelectorFieldLabel :: Id -> FieldLabel
-recordSelectorFieldLabel id = case idDetails id of
+recordSelectorFieldLabel id = case idFlavour id of
 				RecordSelId lbl -> lbl
 
-isRecordSelector id = case idDetails id of
+isRecordSelector id = case idFlavour id of
 			RecordSelId lbl -> True
 			other	  	-> False
 
-isPrimitiveId_maybe id = case idDetails id of
+isPrimitiveId_maybe id = case idFlavour id of
 			    ConstantId (PrimOp op) -> Just op
 			    other		   -> Nothing
 
-isDataConId_maybe id = case idDetails id of
+isDataConId_maybe id = case idFlavour id of
 			  ConstantId (DataCon con) -> Just con
 			  other		           -> Nothing
 
-isConstantId id = case idDetails id of
+isConstantId id = case idFlavour id of
 		    ConstantId _ -> 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
+	-- 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.
+
+-- Don't drop a binding for an exported Id,
+-- if it otherwise looks dead.  
+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)
+\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.
+
+\begin{code}
+omitIfaceSigForId :: Id -> Bool
+omitIfaceSigForId id
+  | isWiredInName (idName id)
+  = True
+
+  | otherwise
+  = case idFlavour id of
+	RecordSelId _  -> True	-- Includes dictionary selectors
+        ConstantId _   -> True
+		-- ConstantIds 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
 \end{code}
 
 
+
 %************************************************************************
 %*									*
 \subsection{IdInfo stuff}
@@ -221,7 +286,7 @@ getIdArity :: Id -> ArityInfo
 getIdArity id = arityInfo (idInfo id)
 
 setIdArity :: Id -> ArityInfo -> Id
-setIdArity id arity = modifyIdInfo id (arity `setArityInfo`)
+setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
 
 	---------------------------------
 	-- STRICTNESS
@@ -229,7 +294,7 @@ getIdStrictness :: Id -> StrictnessInfo
 getIdStrictness id = strictnessInfo (idInfo id)
 
 setIdStrictness :: Id -> StrictnessInfo -> Id
-setIdStrictness id strict_info = modifyIdInfo id (strict_info `setStrictnessInfo`)
+setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id
 
 -- isBottomingId returns true if an application to n args would diverge
 isBottomingId :: Id -> Bool
@@ -239,12 +304,20 @@ idAppIsBottom :: Id -> Int -> Bool
 idAppIsBottom id n = appIsBottom (strictnessInfo (idInfo id)) n
 
 	---------------------------------
+	-- WORKER ID
+getIdWorkerInfo :: Id -> WorkerInfo
+getIdWorkerInfo 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)
 
 setIdUnfolding :: Id -> Unfolding -> Id
-setIdUnfolding id unfolding = modifyIdInfo id (unfolding `setUnfoldingInfo`)
+setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
 
 	---------------------------------
 	-- DEMAND
@@ -252,7 +325,7 @@ getIdDemandInfo :: Id -> Demand
 getIdDemandInfo id = demandInfo (idInfo id)
 
 setIdDemandInfo :: Id -> Demand -> Id
-setIdDemandInfo id demand_info = modifyIdInfo id (demand_info `setDemandInfo`)
+setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id
 
 	---------------------------------
 	-- UPDATE INFO
@@ -260,15 +333,15 @@ getIdUpdateInfo :: Id -> UpdateInfo
 getIdUpdateInfo id = updateInfo (idInfo id)
 
 setIdUpdateInfo :: Id -> UpdateInfo -> Id
-setIdUpdateInfo id upd_info = modifyIdInfo id (upd_info `setUpdateInfo`)
+setIdUpdateInfo id upd_info = modifyIdInfo (`setUpdateInfo` upd_info) id
 
 	---------------------------------
 	-- SPECIALISATION
-getIdSpecialisation :: Id -> IdSpecEnv
+getIdSpecialisation :: Id -> CoreRules
 getIdSpecialisation id = specInfo (idInfo id)
 
-setIdSpecialisation :: Id -> IdSpecEnv -> Id
-setIdSpecialisation id spec_info = modifyIdInfo id (spec_info `setSpecInfo`)
+setIdSpecialisation :: Id -> CoreRules -> Id
+setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
 
 	---------------------------------
 	-- CAF INFO
@@ -276,7 +349,23 @@ getIdCafInfo :: Id -> CafInfo
 getIdCafInfo id = cafInfo (idInfo id)
 
 setIdCafInfo :: Id -> CafInfo -> Id
-setIdCafInfo id caf_info = modifyIdInfo id (caf_info `setCafInfo`)
+setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
+
+	---------------------------------
+	-- CPR INFO
+getIdCprInfo :: Id -> CprInfo
+getIdCprInfo 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)
+
+setIdOccInfo :: Id -> OccInfo -> Id
+setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id
 \end{code}
 
 
@@ -290,28 +379,58 @@ getInlinePragma :: Id -> InlinePragInfo
 getInlinePragma id = inlinePragInfo (idInfo id)
 
 setInlinePragma :: Id -> InlinePragInfo -> Id
-setInlinePragma id prag = modifyIdInfo id (setInlinePragInfo prag)
+setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id
 
 modifyInlinePragma :: Id -> (InlinePragInfo -> InlinePragInfo) -> Id
-modifyInlinePragma id fn = modifyIdInfo id (\info -> setInlinePragInfo (fn (inlinePragInfo info)) info)
-
-idWantsToBeINLINEd :: Id -> Bool
-idWantsToBeINLINEd id = case getInlinePragma id of
-			  IWantToBeINLINEd -> True
-			  IMustBeINLINEd   -> True
-			  other		   -> False
-
-idMustNotBeINLINEd id = case getInlinePragma id of
-			  IMustNotBeINLINEd -> True
-			  IAmASpecPragmaId  -> True
-			  IAmALoopBreaker   -> True
-			  other		    -> False
-
-idMustBeINLINEd id =  case getInlinePragma id of
-			IMustBeINLINEd -> True
-			other	       -> False
-
-isSpecPragmaId id = case getInlinePragma id of
-			IAmASpecPragmaId -> True
-			other		 -> False
+modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id
 \end{code}
+
+
+	---------------------------------
+	-- ONE-SHOT LAMBDAS
+\begin{code}
+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
+	-- 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
+	-- difference.  For example, consider
+	--	a `thenST` \ r -> ...E...
+	-- The early full laziness pass, if it doesn't know that r is one-shot
+	-- will pull out E (let's say it doesn't mention r) to give
+	--	let lvl = E in a `thenST` \ r -> ...lvl...
+	-- When `thenST` gets inlined, we end up with
+	--	let lvl = E in \s -> case a s of (r, s') -> ...lvl...
+	-- and we don't re-inline E.
+	--
+	-- It would be better to spot that r was one-shot to start with, but
+	-- I don't want to rely on that.
+	--
+	-- Another good example is in fill_in in PrelPack.lhs.  We should be able to
+	-- 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
+
+clearOneShotLambda :: Id -> Id
+clearOneShotLambda id 
+  | isOneShotLambda id = modifyIdInfo (`setLBVarInfo` NoLBVarInfo) id
+  | otherwise	       = id			
+
+-- But watch out: this may change the type of something else
+--	f = \x -> e
+-- If we change the one-shot-ness of x, f's type changes
+\end{code}
+
+\begin{code}
+zapFragileIdInfo :: Id -> Id
+zapFragileIdInfo id = maybeModifyIdInfo zapFragileInfo id
+
+zapLamIdInfo :: Id -> Id
+zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id
+\end{code}
+