[project @ 1999-04-23 13:53:28 by simonm]

[ghc-hetmet.git] / ghc / compiler / simplCore / ConFold.lhs

diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs
index 8d74489..07c1cba 100644 (file)
--- 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,19 @@ 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)))) [])
+\end{code}
+
+\begin{code}
 tryPrimOp op args
   = case args of
      [Con (Literal (MachChar char_lit))      _] -> oneCharLit   op char_lit