X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=4b7f131634f6a198239855964504cea1d5d4bf03;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=949ed2345dd5cbe73cc021025fee56e24dba7792;hpb=f6c8cfd4faf6b202fb128054a2c56c7c842be77b;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 949ed23..4b7f131 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -8,18 +8,18 @@ module Id (
 	Id, DictId,
 
 	-- Simple construction
-	mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo,
+	mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo, 
 	mkSysLocal, mkSysLocalUnencoded, mkUserLocal, mkVanillaGlobal,
 	mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal,
-	mkWorkerId,
+	mkWorkerId, mkExportedLocalId,
 
 	-- Taking an Id apart
 	idName, idType, idUnique, idInfo,
-	idPrimRep, isId, globalIdDetails,
+	isId, globalIdDetails, idPrimRep,
 	recordSelectorFieldLabel,
 
 	-- Modifying an Id
-	setIdName, setIdUnique, setIdType, setIdLocalExported, setGlobalIdDetails,
+	setIdName, setIdUnique, Id.setIdType, setIdLocalExported, 
 	setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
 	zapLamIdInfo, zapDemandIdInfo, 
 
@@ -30,16 +30,16 @@ module Id (
 	isPrimOpId, isPrimOpId_maybe, 
 	isFCallId, isFCallId_maybe,
 	isDataConWorkId, isDataConWorkId_maybe, 
-	isDataConWrapId, isDataConWrapId_maybe,
-	isBottomingId,
-	hasNoBinding,
+	isBottomingId, idIsFrom,
+	hasNoBinding, 
 
 	-- Inline pragma stuff
 	idInlinePragma, setInlinePragma, modifyInlinePragma, 
 
 
 	-- One shot lambda stuff
-	isOneShotLambda, setOneShotLambda, clearOneShotLambda,
+	isOneShotBndr, isOneShotLambda, isStateHackType,
+	setOneShotLambda, clearOneShotLambda,
 
 	-- IdInfo stuff
 	setIdUnfolding,
@@ -84,31 +84,34 @@ import BasicTypes	( Arity )
 import Var		( Id, DictId,
 			  isId, isExportedId, isSpecPragmaId, isLocalId,
 			  idName, idType, idUnique, idInfo, isGlobalId,
-			  setIdName, setVarType, setIdUnique, setIdLocalExported,
+			  setIdName, setIdType, setIdUnique, setIdLocalExported,
 			  setIdInfo, lazySetIdInfo, modifyIdInfo, 
 			  maybeModifyIdInfo,
-			  globalIdDetails, setGlobalIdDetails
+			  globalIdDetails
 			)
-import qualified Var	( mkLocalId, mkGlobalId, mkSpecPragmaId )
-import Type		( Type, typePrimRep, addFreeTyVars, 
-                          seqType, splitTyConApp_maybe )
-
+import qualified Var	( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId )
+import Type		( Type, typePrimRep, addFreeTyVars, seqType, 
+			  splitTyConApp_maybe, PrimRep )
+import TysPrim		( statePrimTyCon )
 import IdInfo 
 
+#ifdef OLD_STRICTNESS
 import qualified Demand	( Demand )
+#endif
 import DataCon		( isUnboxedTupleCon )
 import NewDemand	( Demand, StrictSig, topDmd, topSig, isBottomingSig )
-import Name	 	( Name, OccName,
+import Name	 	( Name, OccName, nameIsLocalOrFrom, 
 			  mkSystemName, mkSystemNameEncoded, mkInternalName,
 			  getOccName, getSrcLoc
 			) 
+import Module		( Module )
 import OccName		( EncodedFS, mkWorkerOcc )
-import PrimRep		( PrimRep )
 import FieldLabel	( FieldLabel )
 import Maybes		( orElse )
 import SrcLoc		( SrcLoc )
 import Outputable
 import Unique		( Unique, mkBuiltinUnique )
+import CmdLineOpts	( opt_NoStateHack )
 
 -- infixl so you can say (id `set` a `set` b)
 infixl 	1 `setIdUnfolding`,
@@ -145,6 +148,9 @@ mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info
 mkSpecPragmaId :: Name -> Type -> Id
 mkSpecPragmaId name ty = Var.mkSpecPragmaId name (addFreeTyVars ty) vanillaIdInfo
 
+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}
@@ -208,7 +214,7 @@ mkTemplateLocal i ty = mkSysLocal FSLIT("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)
@@ -236,6 +242,7 @@ Meanwhile, it is not discarded as dead code.
 recordSelectorFieldLabel :: Id -> FieldLabel
 recordSelectorFieldLabel id = case globalIdDetails id of
 				 RecordSelId lbl -> lbl
+				 other -> panic "recordSelectorFieldLabel"
 
 isRecordSelector id = case globalIdDetails id of
 			RecordSelId lbl -> True
@@ -265,14 +272,6 @@ isDataConWorkId_maybe id = case globalIdDetails id of
 			  DataConWorkId con -> Just con
 			  other	            -> Nothing
 
-isDataConWrapId_maybe id = case globalIdDetails id of
-				  DataConWrapId con -> Just con
-				  other	            -> Nothing
-
-isDataConWrapId id = case globalIdDetails id of
-			DataConWrapId con -> True
-			other	          -> False
-
 -- 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
@@ -295,7 +294,6 @@ isImplicitId id
         FCallId _       -> True
         PrimOpId _      -> True
 	ClassOpId _	-> True
-	GenericOpId _	-> True
         DataConWorkId _ -> True
 	DataConWrapId _ -> True
 		-- These are are implied by their type or class decl;
@@ -303,6 +301,9 @@ isImplicitId id
 		-- The dfun id is not an implicit Id; it must *not* be omitted, because 
 		-- it carries version info for the instance decl
 	other		-> False
+
+idIsFrom :: Module -> Id -> Bool
+idIsFrom mod id = nameIsLocalOrFrom mod (idName id)
 \end{code}
 
 \begin{code}
@@ -456,6 +457,39 @@ modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (
 idLBVarInfo :: Id -> LBVarInfo
 idLBVarInfo id = lbvarInfo (idInfo id)
 
+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
+	--	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.
+
+
+-- The OneShotLambda functions simply fiddle with the IdInfo flag
 isOneShotLambda :: Id -> Bool
 isOneShotLambda id = case idLBVarInfo id of
                        IsOneShotLambda  -> True