X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FMkId.lhs;h=c112a2ab0e2a9f3da88a009885325a47689e3a47;hb=53ce311e219dcccf4d205f573c16e23a5c44265e;hp=97adb9454569d2a8b6f7c2713f3061f0d6decd86;hpb=c01030fe3c628d2be3250e309dd8e933f2011e3a;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index 97adb94..c112a2a 100644
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -22,7 +22,7 @@ module MkId (
 
 	-- And some particular Ids; see below for why they are wired in
 	wiredInIds,
-	unsafeCoerceId, realWorldPrimId, nullAddrId,
+	unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId,
 	eRROR_ID, eRROR_CSTRING_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID,
 	rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID,
 	nO_METHOD_BINDING_ERROR_ID, aBSENT_ERROR_ID, pAR_ERROR_ID
@@ -45,7 +45,7 @@ import TcType		( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
 			  tcSplitFunTys, tcSplitForAllTys, mkPredTy
 			)
 import Module		( Module )
-import CoreUtils	( mkInlineMe, exprType )
+import CoreUtils	( exprType )
 import CoreUnfold 	( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
 import Literal		( Literal(..), nullAddrLit )
 import TyCon		( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
@@ -71,13 +71,13 @@ import Id		( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
 			)
 import IdInfo		( IdInfo, noCafNoTyGenIdInfo,
 			  setUnfoldingInfo, 
-			  setArityInfo, setSpecInfo,  setCgInfo, setCafInfo,
-			  mkNewStrictnessInfo, setNewStrictnessInfo,
-			  GlobalIdDetails(..), CafInfo(..), CprInfo(..), 
-			  CgInfo 
+			  setArityInfo, setSpecInfo, setCafInfo,
+			  newStrictnessFromOld, setAllStrictnessInfo,
+			  GlobalIdDetails(..), CafInfo(..), CprInfo(..)
 			)
 import NewDemand	( mkStrictSig, strictSigResInfo, DmdResult(..),
-			  mkTopDmdType, topDmd, evalDmd, Demand(..), Keepity(..) )
+			  mkTopDmdType, topDmd, evalDmd, lazyDmd, 
+			  Demand(..), Demands(..) )
 import FieldLabel	( mkFieldLabel, fieldLabelName, 
 			  firstFieldLabelTag, allFieldLabelTags, fieldLabelType
 			)
@@ -147,7 +147,7 @@ mkDataConId work_name data_con
   where
     info = noCafNoTyGenIdInfo
 	   `setArityInfo`		arity
-	   `setNewStrictnessInfo`	Just strict_sig
+	   `setAllStrictnessInfo`	Just strict_sig
 
     arity      = dataConRepArity data_con
 
@@ -238,15 +238,15 @@ mkDataConWrapId data_con
 	   `setArityInfo`	arity
 		-- It's important to specify the arity, so that partial
 		-- applications are treated as values
-	   `setNewStrictnessInfo` 	Just wrap_sig
+	   `setAllStrictnessInfo` 	Just wrap_sig
 
     wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty)
 
     wrap_sig = mkStrictSig (mkTopDmdType arg_dmds res_info)
     res_info = strictSigResInfo (idNewStrictness work_id)
     arg_dmds = [Abs | d <- dict_args] ++ map mk_dmd strict_marks
-    mk_dmd str | isMarkedStrict str = Eval
-	       | otherwise	    = Lazy
+    mk_dmd str | isMarkedStrict str = evalDmd
+	       | otherwise	    = lazyDmd
 	-- The Cpr info can be important inside INLINE rhss, where the
 	-- wrapper constructor isn't inlined.
 	-- And the argument strictness can be important too; we
@@ -444,7 +444,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
 	   `setCafInfo`		  caf_info
 	   `setArityInfo`	  arity
 	   `setUnfoldingInfo`     mkTopUnfolding rhs_w_str
-	   `setNewStrictnessInfo` Just strict_sig
+	   `setAllStrictnessInfo` Just strict_sig
 
 	-- Allocate Ids.  We do it a funny way round because field_dict_tys is
 	-- almost always empty.  Also note that we use length_tycon_theta
@@ -588,7 +588,7 @@ mkDictSelId name clas
     info      = noCafNoTyGenIdInfo
 		`setArityInfo`	    	1
 		`setUnfoldingInfo`  	mkTopUnfolding rhs
-		`setNewStrictnessInfo`	Just strict_sig
+		`setAllStrictnessInfo`	Just strict_sig
 
 	-- We no longer use 'must-inline' on record selectors.  They'll
 	-- inline like crazy if they scrutinise a constructor
@@ -598,9 +598,9 @@ mkDictSelId name clas
 	-- It's worth giving one, so that absence info etc is generated
 	-- even if the selector isn't inlined
     strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
-    arg_dmd | isNewTyCon tycon = Eval
-	    | otherwise	       = Seq Drop [ if the_arg_id == id then Eval else Abs
-					  | id <- arg_ids ]
+    arg_dmd | isNewTyCon tycon = evalDmd
+	    | otherwise	       = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
+					    | id <- arg_ids ])
 
     tyvars  = classTyVars clas
 
@@ -648,7 +648,7 @@ mkPrimOpId prim_op
     info = noCafNoTyGenIdInfo
 	   `setSpecInfo`	rules
 	   `setArityInfo` 	arity
-	   `setNewStrictnessInfo`	Just (mkNewStrictnessInfo id arity strict_info NoCPRInfo)
+	   `setAllStrictnessInfo`	Just (newStrictnessFromOld name arity strict_info NoCPRInfo)
 	-- Until we modify the primop generation code
 
     rules = foldl (addRule id) emptyCoreRules (primOpRules prim_op)
@@ -678,7 +678,7 @@ mkFCallId uniq fcall ty
 
     info = noCafNoTyGenIdInfo
 	   `setArityInfo` 		arity
-	   `setNewStrictnessInfo`	Just strict_sig
+	   `setAllStrictnessInfo`	Just strict_sig
 
     (_, tau) 	 = tcSplitForAllTys ty
     (arg_tys, _) = tcSplitFunTys tau
@@ -841,6 +841,13 @@ dataToTagId = mkPrimOpId DataToTagOp
 @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
 nasty as-is, change it back to a literal (@Literal@).
 
+voidArgId is a Local Id used simply as an argument in functions
+where we just want an arg to avoid having a thunk of unlifted type.
+E.g.
+	x = \ void :: State# RealWorld -> (# p, q #)
+
+This comes up in strictness analysis
+
 \begin{code}
 realWorldPrimId	-- :: State# RealWorld
   = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
@@ -850,6 +857,9 @@ realWorldPrimId	-- :: State# RealWorld
 	-- which in turn makes Simplify.interestingArg return True,
 	-- which in turn makes INLINE things applied to realWorld# likely
 	-- to be inlined
+
+voidArgId 	-- :: State# RealWorld
+  = mkSysLocal SLIT("void") voidArgIdKey realWorldStatePrimTy
 \end{code}
 
 
@@ -929,7 +939,7 @@ pc_bottoming_Id key mod name ty
  = pcMiscPrelId key mod name ty bottoming_info
  where
     strict_sig	   = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
-    bottoming_info = noCafNoTyGenIdInfo `setNewStrictnessInfo` Just strict_sig
+    bottoming_info = noCafNoTyGenIdInfo `setAllStrictnessInfo` Just strict_sig
 	-- these "bottom" out, no matter what their arguments
 
 generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy