From: simonm <unknown>
Date: Mon, 26 Apr 1999 10:16:25 +0000 (+0000)
Subject: [project @ 1999-04-26 10:16:25 by simonm]
X-Git-Tag: Approximately_9120_patches~6308
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b106d6412e354f2944a64f1fa135cb439ba2965f;p=ghc-hetmet.git

[project @ 1999-04-26 10:16:25 by simonm]
Reduce (dataToTag# x) where x is bound to a known constructor.
---

diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs
index 07c1cba..1af5fbf 100644
--- a/ghc/compiler/simplCore/ConFold.lhs
+++ b/ghc/compiler/simplCore/ConFold.lhs
@@ -107,6 +107,16 @@ tryPrimOp TagToEnumOp [Type ty, Con (Literal (MachInt i _)) _]
 
 tryPrimOp DataToTagOp [Type ty, Con (DataCon dc) _]
   = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
+tryPrimOp DataToTagOp [Type ty, Var x]
+  | unfolding_is_constr
+  = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
+  where
+    unfolding = getIdUnfolding var
+    CoreUnfolding form guidance unf_template = unfolding
+    unfolding_is_constr = case unf_template of
+				  Con con@(DataCon _) _ -> conOkForAlt con
+				  other	    -> False
+    Con (DataCon dc) con_args = unf_template
 \end{code}
 
 \begin{code}