From: simonmar <unknown>
Date: Fri, 24 Jan 2003 14:04:41 +0000 (+0000)
Subject: [project @ 2003-01-24 14:04:40 by simonmar]
X-Git-Tag: Approx_11550_changesets_converted~1237
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b429adbb230a10427a833073f6e7502b6e5da7fd;p=ghc-hetmet.git

[project @ 2003-01-24 14:04:40 by simonmar]
- Generalise seq to allow an unlifted type in its second argument.  This
  works because seq is *always* inlined and replaced by a case.

- Remove getTag, a wired-in Id with an unfolding, with a definition
  in GHC.Base:

	getTag x = x `seq` dataToTag# x

  this is why we required the above generalisation to seq (dataToTag#
  returns an Int#).  See the comments in GHC.Base for more details.

- As a side-effect, this fixes a bug in the interpreter, where the
  compiler optimised away the evaluation of the argument to dataToTag#,
  but the interpreter ended up passing it an unevaluated thunk (nullary
  constructors aren't always evaluated in GHCi, but the simplifier
  assumes they are).  Now, in the interpreter, getTag won't be inlined
  so the compiler can't optimise away the evaluation, and we're saved.

  The real bug here is either (a) dataToTag# requires an evaluated
  argument or (b) the interpreter doesn't supply it with one, take your
  pick.
---

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index 0b69a4b..1299448 100644
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -138,7 +138,6 @@ ghcPrimIds
     realWorldPrimId,
     unsafeCoerceId,
     nullAddrId,
-    getTagId,
     seqId
     ]
 \end{code}
@@ -850,10 +849,10 @@ seqId
     info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
 	   
 
-    ty  = mkForAllTys [alphaTyVar,betaTyVar]
-		      (mkFunTy alphaTy (mkFunTy betaTy betaTy))
-    [x,y] = mkTemplateLocals [alphaTy, betaTy]
-    rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x [(DEFAULT, [], Var y)])
+    ty  = mkForAllTys [alphaTyVar,openBetaTyVar]
+		      (mkFunTy alphaTy (mkFunTy openBetaTy openBetaTy))
+    [x,y] = mkTemplateLocals [alphaTy, openBetaTy]
+    rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x [(DEFAULT, [], Var y)])
 
 -- lazy :: forall a?. a? -> a?	 (i.e. works for unboxed types too)
 -- Used to lazify pseq:		pseq a b = a `seq` lazy b
@@ -873,24 +872,6 @@ lazyIdUnfolding = mkLams [openAlphaTyVar,x] (Var x)
 		  [x] = mkTemplateLocals [openAlphaTy]
 \end{code}
 
-@getTag#@ is another function which can't be defined in Haskell.  It needs to
-evaluate its argument and call the dataToTag# primitive.
-
-\begin{code}
-getTagId
-  = pcMiscPrelId getTagName ty info
-  where
-    info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
-	-- We don't provide a defn for this; you must inline it
-
-    ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy)
-    [x,y] = mkTemplateLocals [alphaTy,alphaTy]
-    rhs = mkLams [alphaTyVar,x] $
-	  Case (Var x) y [ (DEFAULT, [], mkApps (Var dataToTagId) [Type alphaTy, Var y]) ]
-
-dataToTagId = mkPrimOpId DataToTagOp
-\end{code}
-
 @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
 nasty as-is, change it back to a literal (@Literal@).
 
diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs
index 4aa78af..fef42d1 100644
--- a/ghc/compiler/prelude/PrelNames.lhs
+++ b/ghc/compiler/prelude/PrelNames.lhs
@@ -318,8 +318,6 @@ mkTupNameStr Unboxed n = (gHC_PRIM_Name, mkFastString ("(#" ++ nOfThem (n-1) ','
 %************************************************************************
 
 \begin{code}
-getTag_RDR		= nameRdrName getTagName
-
 eq_RDR 			= nameRdrName eqName
 ge_RDR 			= nameRdrName geName
 ne_RDR 			= varQual_RDR  pREL_BASE_Name FSLIT("/=")
@@ -387,6 +385,7 @@ plus_RDR                = varQual_RDR pREL_NUM_Name FSLIT("+")
 compose_RDR		= varQual_RDR pREL_BASE_Name FSLIT(".")
 
 not_RDR 		= varQual_RDR pREL_BASE_Name FSLIT("not")
+getTag_RDR	 	= varQual_RDR pREL_BASE_Name FSLIT("getTag")
 succ_RDR 		= varQual_RDR pREL_ENUM_Name FSLIT("succ")
 pred_RDR                = varQual_RDR pREL_ENUM_Name FSLIT("pred")
 minBound_RDR            = varQual_RDR pREL_ENUM_Name FSLIT("minBound")
@@ -479,7 +478,6 @@ threadIdPrimTyConName  	      = tcQual  gHC_PRIM_Name FSLIT("ThreadId#") threadI
 cCallableClassName   	      = clsQual gHC_PRIM_Name FSLIT("CCallable") cCallableClassKey
 cReturnableClassName 	      = clsQual gHC_PRIM_Name FSLIT("CReturnable") cReturnableClassKey
 
-getTagName 	 = wVarQual gHC_PRIM_Name FSLIT("getTag#")	getTagIdKey
 unsafeCoerceName = wVarQual gHC_PRIM_Name FSLIT("unsafeCoerce#") unsafeCoerceIdKey 
 nullAddrName     = wVarQual gHC_PRIM_Name FSLIT("nullAddr#")	nullAddrIdKey
 seqName		 = wVarQual gHC_PRIM_Name FSLIT("seq")		seqIdKey
@@ -873,7 +871,6 @@ parrDataConKey				= mkPreludeDataConUnique 24
 
 \begin{code}
 absentErrorIdKey	      = mkPreludeMiscIdUnique  1
-getTagIdKey		      = mkPreludeMiscIdUnique  2
 augmentIdKey		      = mkPreludeMiscIdUnique  3
 appendIdKey		      = mkPreludeMiscIdUnique  4
 buildIdKey		      = mkPreludeMiscIdUnique  5