X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FConFold.lhs;h=1af5fbf652ea65b151bed39d96f7a6654a0555d3;hb=b106d6412e354f2944a64f1fa135cb439ba2965f;hp=8d74489c3b97de5b26246872c7eff18cc663dab4;hpb=7e602b0a11e567fcb035d1afd34015aebcf9a577;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs
index 8d74489..1af5fbf 100644
--- a/ghc/compiler/simplCore/ConFold.lhs
+++ b/ghc/compiler/simplCore/ConFold.lhs
@@ -18,6 +18,9 @@ import Const		( mkMachInt, mkMachWord, Literal(..), Con(..) )
 import PrimOp		( PrimOp(..) )
 import SimplMonad
 import TysWiredIn	( trueDataCon, falseDataCon )
+import TyCon		( tyConDataCons, isEnumerationTyCon )
+import DataCon		( dataConTag, fIRST_TAG )
+import Type		( splitTyConApp_maybe )
 
 import Char		( ord, chr )
 import Outputable
@@ -94,6 +97,29 @@ tryPrimOp SeqOp args@[Type ty, Var var]
 \end{code}
 
 \begin{code}
+tryPrimOp TagToEnumOp [Type ty, Con (Literal (MachInt i _)) _]
+  | isEnumerationTyCon tycon = Just (Con (DataCon dc) [])
+  | otherwise = panic "tryPrimOp: tagToEnum# on non-enumeration type"
+    where tag = fromInteger i
+	  constrs = tyConDataCons tycon
+	  (dc:_) = [ dc | dc <- constrs, tag == dataConTag dc ]
+	  (Just (tycon,_)) = splitTyConApp_maybe ty
+
+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}
 tryPrimOp op args
   = case args of
      [Con (Literal (MachChar char_lit))      _] -> oneCharLit   op char_lit