X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=c7ce818adb64b34fe7e59fc5ca7542377fd50cd2;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=57edb62c432ad19e53acc1f309a7e46a9b4a7c02;hpb=4161ba13916463f8e67259498eacf22744160e1f;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 57edb62..c7ce818 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -8,111 +8,128 @@ module Id (
 	Id, DictId,
 
 	-- Simple construction
-	mkId, mkVanillaId, mkSysLocal, mkUserLocal,
+	mkGlobalId, mkLocalId, mkLocalIdWithInfo, 
+	mkSysLocal, mkUserLocal, mkVanillaGlobal,
 	mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal,
+	mkWorkerId, mkExportedLocalId,
 
 	-- Taking an Id apart
 	idName, idType, idUnique, idInfo,
-	idPrimRep, isId,
+	isId, globalIdDetails, idPrimRep,
 	recordSelectorFieldLabel,
 
 	-- Modifying an Id
-	setIdName, setIdUnique, setIdType, setIdNoDiscard, 
+	setIdName, setIdUnique, Id.setIdType, setIdExported, setIdNotExported, 
 	setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
-	zapFragileIdInfo, zapLamIdInfo,
+	zapLamIdInfo, zapDemandIdInfo, 
 
 	-- Predicates
-	omitIfaceSigForId, isDeadBinder,
-	exportWithOrigOccName,
-	externallyVisibleId,
-	isIP,
-	isSpecPragmaId,	isRecordSelector,
+	isImplicitId, isDeadBinder, isDictId,
+	isExportedId, isLocalId, isGlobalId,
+	isRecordSelector, isNaughtyRecordSelector,
+	isClassOpId_maybe,
 	isPrimOpId, isPrimOpId_maybe, 
-	isDataConId, isDataConId_maybe, isDataConWrapId, 
-		isDataConWrapId_maybe,
-	isBottomingId,
-	isExportedId, isLocalId, 
-	hasNoBinding,
+	isFCallId, isFCallId_maybe,
+	isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
+	isBottomingId, idIsFrom,
+	hasNoBinding, 
 
 	-- Inline pragma stuff
 	idInlinePragma, setInlinePragma, modifyInlinePragma, 
 
 
 	-- One shot lambda stuff
-	isOneShotLambda, setOneShotLambda, clearOneShotLambda,
+	isOneShotBndr, isOneShotLambda, isStateHackType,
+	setOneShotLambda, clearOneShotLambda,
 
 	-- IdInfo stuff
 	setIdUnfolding,
-	setIdArityInfo,
-	setIdDemandInfo,
-	setIdStrictness,
-        setIdTyGenInfo,
+	setIdArity,
+	setIdNewDemandInfo, 
+	setIdNewStrictness, zapIdNewStrictness,
 	setIdWorkerInfo,
 	setIdSpecialisation,
 	setIdCafInfo,
-	setIdCprInfo,
 	setIdOccInfo,
 
-	idArity, idArityInfo, 
-	idFlavour,
-	idDemandInfo,
-	idStrictness,
-        idTyGenInfo,
+#ifdef OLD_STRICTNESS
+	idDemandInfo, 
+	idStrictness, 
+	idCprInfo,
+	setIdStrictness, 
+	setIdDemandInfo, 
+	setIdCprInfo,
+#endif
+
+	idArity, 
+	idNewDemandInfo, idNewDemandInfo_maybe,
+	idNewStrictness, idNewStrictness_maybe, 
 	idWorkerInfo,
 	idUnfolding,
-	idSpecialisation,
+	idSpecialisation, idCoreRules,
 	idCafInfo,
-	idCprInfo,
 	idLBVarInfo,
 	idOccInfo,
 
+#ifdef OLD_STRICTNESS
+	newStrictnessFromOld 	-- Temporary
+#endif
+
     ) where
 
 #include "HsVersions.h"
 
 
-import CoreSyn		( Unfolding, CoreRules )
+import CoreSyn		( Unfolding, CoreRule )
 import BasicTypes	( Arity )
 import Var		( Id, DictId,
-			  isId, mkIdVar,
-			  idName, idType, idUnique, idInfo,
-			  setIdName, setVarType, setIdUnique, 
+			  isId, isExportedId, isLocalId,
+			  idName, idType, idUnique, idInfo, isGlobalId,
+			  setIdName, setIdType, setIdUnique, 
+			  setIdExported, setIdNotExported,
 			  setIdInfo, lazySetIdInfo, modifyIdInfo, 
 			  maybeModifyIdInfo,
-			  externallyVisibleId
+			  globalIdDetails
 			)
-import Type		( Type, typePrimRep, addFreeTyVars, 
-                          usOnce, seqType, splitTyConApp_maybe )
-
+import qualified Var	( mkLocalId, mkGlobalId, mkExportedLocalId )
+import TyCon		( FieldLabel, TyCon )
+import Type		( Type, typePrimRep, addFreeTyVars, seqType, 
+			  splitTyConApp_maybe, PrimRep )
+import TcType		( isDictTy )
+import TysPrim		( statePrimTyCon )
 import IdInfo 
 
-import Demand		( Demand )
-import Name	 	( Name, OccName,
-			  mkSysLocalName, mkLocalName,
-			  nameIsLocallyDefined,
-			  getOccName, isIPOcc
-			) 
-import OccName		( UserFS )
-import PrimRep		( PrimRep )
-import TysPrim		( statePrimTyCon )
-import FieldLabel	( FieldLabel )
+#ifdef OLD_STRICTNESS
+import qualified Demand	( Demand )
+#endif
+import DataCon		( DataCon, isUnboxedTupleCon )
+import NewDemand	( Demand, StrictSig, topDmd, topSig, isBottomingSig )
+import Name	 	( Name, OccName, nameIsLocalOrFrom, 
+			  mkSystemVarName, mkInternalName, getOccName,
+			  getSrcLoc ) 
+import Module		( Module )
+import OccName		( mkWorkerOcc )
+import Maybes		( orElse )
 import SrcLoc		( SrcLoc )
-import Unique		( Unique, mkBuiltinUnique, getBuiltinUniques, 
-			  getNumBuiltinUniques )
 import Outputable
+import Unique		( Unique, mkBuiltinUnique )
+import FastString	( FastString )
+import StaticFlags	( opt_NoStateHack )
 
+-- infixl so you can say (id `set` a `set` b)
 infixl 	1 `setIdUnfolding`,
-	  `setIdArityInfo`,
-	  `setIdDemandInfo`,
-	  `setIdStrictness`,
-	  `setIdTyGenInfo`,
+	  `setIdArity`,
+	  `setIdNewDemandInfo`,
+	  `setIdNewStrictness`,
 	  `setIdWorkerInfo`,
 	  `setIdSpecialisation`,
 	  `setInlinePragma`,
-	  `idCafInfo`,
-	  `idCprInfo`
-
-	-- infixl so you can say (id `set` a `set` b)
+	  `idCafInfo`
+#ifdef OLD_STRICTNESS
+	  ,`idCprInfo`
+	  ,`setIdStrictness`
+	  ,`setIdDemandInfo`
+#endif
 \end{code}
 
 
@@ -123,51 +140,63 @@ infixl 	1 `setIdUnfolding`,
 %*									*
 %************************************************************************
 
-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 
+Absolutely all Ids are made by mkId.  It is just like Var.mkId,
+but in addition it pins free-tyvar-info onto the Id's type, 
+where it can easily be found.
 
 \begin{code}
-mkId :: Name -> Type -> IdInfo -> Id
-mkId name ty info = mkIdVar name (addFreeTyVars ty) info
+mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id
+mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info
+
+mkExportedLocalId :: Name -> Type -> Id
+mkExportedLocalId name ty = Var.mkExportedLocalId name (addFreeTyVars ty) vanillaIdInfo
+
+mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id
+mkGlobalId details name ty info = Var.mkGlobalId details name (addFreeTyVars ty) info
 \end{code}
 
 \begin{code}
-mkVanillaId :: Name -> Type -> Id
-mkVanillaId name ty = mkId name ty vanillaIdInfo
+mkLocalId :: Name -> Type -> Id
+mkLocalId name ty = mkLocalIdWithInfo 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 -> SrcLoc -> Id
-mkSysLocal  :: UserFS  -> Unique -> Type -> Id
+mkSysLocal  :: FastString  -> Unique -> Type -> Id
+mkVanillaGlobal :: Name -> Type -> IdInfo -> Id
+
+mkSysLocal fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty
 
-mkSysLocal  fs uniq ty      = mkVanillaId (mkSysLocalName uniq fs)      ty
-mkUserLocal occ uniq ty loc = mkVanillaId (mkLocalName    uniq occ loc) ty
+mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName    uniq occ loc) ty
+mkVanillaGlobal 	    = mkGlobalId VanillaGlobal
 \end{code}
 
 Make some local @Ids@ for a template @CoreExpr@.  These have bogus
 @Uniques@, but that's OK because the templates are supposed to be
 instantiated before use.
-
+ 
 \begin{code}
 -- "Wild Id" typically used when you need a binder that you don't expect to use
 mkWildId :: Type -> Id
-mkWildId ty = mkSysLocal SLIT("wild") (mkBuiltinUnique 1) ty
+mkWildId ty = mkSysLocal FSLIT("wild") (mkBuiltinUnique 1) ty
+
+mkWorkerId :: Unique -> Id -> Type -> Id
+-- A worker gets a local name.  CoreTidy will externalise it if necessary.
+mkWorkerId uniq unwrkr ty
+  = mkLocalId wkr_name ty
+  where
+    wkr_name = mkInternalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcLoc unwrkr)
 
 -- "Template locals" typically used in unfoldings
 mkTemplateLocals :: [Type] -> [Id]
-mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl"))
-			       (getBuiltinUniques (length tys))
-			       tys
+mkTemplateLocals tys = zipWith mkTemplateLocal [1..] tys
 
 mkTemplateLocalsNum :: Int -> [Type] -> [Id]
-mkTemplateLocalsNum n tys = zipWith (mkSysLocal SLIT("tpl"))
-			       (getNumBuiltinUniques n (length tys))
-			       tys
+-- The Int gives the starting point for unique allocation
+mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
 
 mkTemplateLocal :: Int -> Type -> Id
-mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty
+mkTemplateLocal i ty = mkSysLocal FSLIT("tpl") (mkBuiltinUnique i) ty
 \end{code}
 
 
@@ -180,7 +209,7 @@ mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty
 \begin{code}
 setIdType :: Id -> Type -> Id
 	-- Add free tyvar info to the type
-setIdType id ty = seqType ty `seq` setVarType id (addFreeTyVars ty)
+setIdType id ty = seqType ty `seq` Var.setIdType id (addFreeTyVars ty)
 
 idPrimRep :: Id -> PrimRep
 idPrimRep id = typePrimRep (idType id)
@@ -194,118 +223,105 @@ idPrimRep id = typePrimRep (idType id)
 %************************************************************************
 
 \begin{code}
-idFlavour :: Id -> IdFlavour
-idFlavour id = flavourInfo (idInfo id)
+recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel)
+recordSelectorFieldLabel id = case globalIdDetails id of
+				 RecordSelId tycon lbl _ -> (tycon,lbl)
+				 other -> panic "recordSelectorFieldLabel"
 
-setIdNoDiscard :: Id -> Id
-setIdNoDiscard id	-- Make an Id into a NoDiscardId, unless it is already
-  = modifyIdInfo setNoDiscardInfo id
+isRecordSelector id = case globalIdDetails id of
+			RecordSelId {}  -> True
+			other	  	-> False
 
-recordSelectorFieldLabel :: Id -> FieldLabel
-recordSelectorFieldLabel id = case idFlavour id of
-				RecordSelId lbl -> lbl
+isNaughtyRecordSelector id = case globalIdDetails id of
+			RecordSelId { sel_naughty = n } -> n
+			other	  	  	        -> False
 
-isRecordSelector id = case idFlavour id of
-			RecordSelId lbl -> True
-			other	  	-> False
+isClassOpId_maybe id = case globalIdDetails id of
+			ClassOpId cls -> Just cls
+			_other        -> Nothing
 
-isPrimOpId id = case idFlavour id of
+isPrimOpId id = case globalIdDetails id of
 		    PrimOpId op -> True
 		    other	-> False
 
-isPrimOpId_maybe id = case idFlavour id of
+isPrimOpId_maybe id = case globalIdDetails 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
-			  DataConId con -> Just con
-			  other	        -> Nothing
-
-isDataConWrapId_maybe id = case idFlavour id of
-				  DataConWrapId con -> Just con
-				  other	            -> Nothing
-
-isDataConWrapId id = case idFlavour id of
-			DataConWrapId con -> True
-			other	          -> False
-
-isSpecPragmaId id = case idFlavour id of
-			SpecPragmaId -> True
-			other	     -> False
-
-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.
-
--- 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
-
-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 = 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.
-
-\begin{code}
-omitIfaceSigForId :: Id -> Bool
-omitIfaceSigForId id
-  = ASSERT2( not (omit && nameIsLocallyDefined (idName id)
-                       && idTyGenInfo id /= TyGenNever),
-             ppr id )
-    -- mustn't omit type signature for a name whose type might change!
-    omit
-  where
-    omit = omitIfaceSigForId' id
-
-omitIfaceSigForId' id
-  = case idFlavour id of
-	RecordSelId _   -> True	-- Includes dictionary selectors
+isFCallId id = case globalIdDetails id of
+		    FCallId call -> True
+		    other	 -> False
+
+isFCallId_maybe id = case globalIdDetails id of
+			    FCallId call -> Just call
+			    other	 -> Nothing
+
+isDataConWorkId id = case globalIdDetails id of
+			DataConWorkId _ -> True
+			other	        -> False
+
+isDataConWorkId_maybe id = case globalIdDetails id of
+			  DataConWorkId con -> Just con
+			  other	            -> Nothing
+
+isDataConId_maybe :: Id -> Maybe DataCon
+isDataConId_maybe id = case globalIdDetails id of
+		 	 DataConWorkId con -> Just con
+			 DataConWrapId con -> Just con
+			 other		    -> Nothing
+
+idDataCon :: Id -> DataCon
+-- Get from either the worker or the wrapper to the DataCon
+-- Currently used only in the desugarer
+--	 INVARIANT: idDataCon (dataConWrapId d) = d
+-- (Remember, dataConWrapId can return either the wrapper or the worker.)
+idDataCon id = case globalIdDetails id of
+		  DataConWorkId con -> con
+		  DataConWrapId con -> con
+		  other		    -> pprPanic "idDataCon" (ppr id)
+
+
+isDictId :: Id -> Bool
+isDictId id = isDictTy (idType id)
+
+-- hasNoBinding returns True of an Id which may not have a
+-- binding, even though it is defined in this module.  
+-- Data constructor workers used to be things of this kind, but
+-- they aren't any more.  Instead, we inject a binding for 
+-- them at the CorePrep stage. 
+-- EXCEPT: unboxed tuples, which definitely have no binding
+hasNoBinding id = case globalIdDetails id of
+			PrimOpId _  	 -> True
+			FCallId _   	 -> True
+			DataConWorkId dc -> isUnboxedTupleCon dc
+			other	         -> False
+
+isImplicitId :: Id -> Bool
+	-- 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.
+isImplicitId id
+  = case globalIdDetails id of
+	RecordSelId {}  -> True
+        FCallId _       -> True
         PrimOpId _      -> True
-        DataConId _     -> True
+	ClassOpId _	-> True
+        DataConWorkId _ -> 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!
+		-- The dfun id is not an implicit Id; it must *not* be omitted, because 
+		-- it carries version info for the instance decl
+	other		-> False
 
--- 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 || isExportedId id
+idIsFrom :: Module -> Id -> Bool
+idIsFrom mod id = nameIsLocalOrFrom mod (idName id)
 \end{code}
 
 \begin{code}
 isDeadBinder :: Id -> Bool
 isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)
 		  | otherwise = False	-- TyVars count as not dead
-
-isIP id = isIPOcc (getOccName id)
 \end{code}
 
 
@@ -318,34 +334,37 @@ isIP id = isIPOcc (getOccName id)
 \begin{code}
 	---------------------------------
 	-- ARITY
-idArityInfo :: Id -> ArityInfo
-idArityInfo id = arityInfo (idInfo id)
-
 idArity :: Id -> Arity
-idArity id = arityLowerBound (idArityInfo id)
+idArity id = arityInfo (idInfo id)
 
-setIdArityInfo :: Id -> ArityInfo -> Id
-setIdArityInfo id arity = modifyIdInfo (`setArityInfo` arity) id
+setIdArity :: Id -> Arity -> Id
+setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
 
+#ifdef OLD_STRICTNESS
 	---------------------------------
-	-- STRICTNESS
+	-- (OLD) STRICTNESS 
 idStrictness :: Id -> StrictnessInfo
 idStrictness id = strictnessInfo (idInfo id)
 
 setIdStrictness :: Id -> StrictnessInfo -> Id
 setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id
+#endif
 
 -- isBottomingId returns true if an application to n args would diverge
 isBottomingId :: Id -> Bool
-isBottomingId id = isBottomingStrictness (idStrictness id)
+isBottomingId id = isBottomingSig (idNewStrictness id)
 
-	---------------------------------
-	-- TYPE GENERALISATION
-idTyGenInfo :: Id -> TyGenInfo
-idTyGenInfo id = tyGenInfo (idInfo id)
+idNewStrictness_maybe :: Id -> Maybe StrictSig
+idNewStrictness :: Id -> StrictSig
+
+idNewStrictness_maybe id = newStrictnessInfo (idInfo id)
+idNewStrictness       id = idNewStrictness_maybe id `orElse` topSig
+
+setIdNewStrictness :: Id -> StrictSig -> Id
+setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id
 
-setIdTyGenInfo :: Id -> TyGenInfo -> Id
-setIdTyGenInfo id tygen_info = modifyIdInfo (`setTyGenInfo` tygen_info) id
+zapIdNewStrictness :: Id -> Id
+zapIdNewStrictness id = modifyIdInfo (`setNewStrictnessInfo` Nothing) id
 
 	---------------------------------
 	-- WORKER ID
@@ -363,37 +382,59 @@ idUnfolding id = unfoldingInfo (idInfo id)
 setIdUnfolding :: Id -> Unfolding -> Id
 setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
 
+#ifdef OLD_STRICTNESS
 	---------------------------------
-	-- DEMAND
-idDemandInfo :: Id -> Demand
+	-- (OLD) DEMAND
+idDemandInfo :: Id -> Demand.Demand
 idDemandInfo id = demandInfo (idInfo id)
 
-setIdDemandInfo :: Id -> Demand -> Id
+setIdDemandInfo :: Id -> Demand.Demand -> Id
 setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id
+#endif
+
+idNewDemandInfo_maybe :: Id -> Maybe NewDemand.Demand
+idNewDemandInfo       :: Id -> NewDemand.Demand
+
+idNewDemandInfo_maybe id = newDemandInfo (idInfo id)
+idNewDemandInfo       id = newDemandInfo (idInfo id) `orElse` NewDemand.topDmd
+
+setIdNewDemandInfo :: Id -> NewDemand.Demand -> Id
+setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` Just dmd) id
 
 	---------------------------------
 	-- SPECIALISATION
-idSpecialisation :: Id -> CoreRules
+idSpecialisation :: Id -> SpecInfo
 idSpecialisation id = specInfo (idInfo id)
 
-setIdSpecialisation :: Id -> CoreRules -> Id
+idCoreRules :: Id -> [CoreRule]
+idCoreRules id = specInfoRules (idSpecialisation id)
+
+setIdSpecialisation :: Id -> SpecInfo -> Id
 setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
 
 	---------------------------------
 	-- CAF INFO
 idCafInfo :: Id -> CafInfo
+#ifdef OLD_STRICTNESS
+idCafInfo id = case cgInfo (idInfo id) of
+		  NoCgInfo -> pprPanic "idCafInfo" (ppr id)
+		  info     -> cgCafInfo info
+#else
 idCafInfo id = cafInfo (idInfo id)
+#endif
 
 setIdCafInfo :: Id -> CafInfo -> Id
 setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
 
 	---------------------------------
 	-- CPR INFO
+#ifdef OLD_STRICTNESS
 idCprInfo :: Id -> CprInfo
 idCprInfo id = cprInfo (idInfo id)
 
 setIdCprInfo :: Id -> CprInfo -> Id
 setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id
+#endif
 
 	---------------------------------
 	-- Occcurrence INFO
@@ -428,16 +469,20 @@ modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (
 idLBVarInfo :: Id -> LBVarInfo
 idLBVarInfo id = lbvarInfo (idInfo id)
 
-isOneShotLambda :: Id -> Bool
-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 
+isOneShotBndr :: Id -> Bool
+-- This one is the "business end", called externally.
+-- Its main purpose is to encapsulate the Horrible State Hack
+isOneShotBndr id = isOneShotLambda id || (isStateHackType (idType id))
+
+isStateHackType :: Type -> Bool
+isStateHackType ty
+  | opt_NoStateHack 
+  = False
+  | otherwise
+  = case splitTyConApp_maybe ty of
+	Just (tycon,_) -> tycon == statePrimTyCon
+        other          -> False
+	-- This 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
@@ -455,8 +500,15 @@ isOneShotLambda id = analysis || hack
 	-- 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.
 
+
+-- The OneShotLambda functions simply fiddle with the IdInfo flag
+isOneShotLambda :: Id -> Bool
+isOneShotLambda id = case idLBVarInfo id of
+                       IsOneShotLambda  -> True
+                       NoLBVarInfo      -> False
+
 setOneShotLambda :: Id -> Id
-setOneShotLambda id = modifyIdInfo (`setLBVarInfo` LBVarInfo usOnce) id
+setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id
 
 clearOneShotLambda :: Id -> Id
 clearOneShotLambda id 
@@ -469,10 +521,9 @@ clearOneShotLambda id
 \end{code}
 
 \begin{code}
-zapFragileIdInfo :: Id -> Id
-zapFragileIdInfo id = maybeModifyIdInfo zapFragileInfo id
-
 zapLamIdInfo :: Id -> Id
 zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id
+
+zapDemandIdInfo id = maybeModifyIdInfo zapDemandInfo id
 \end{code}