[project @ 1999-04-26 10:16:25 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..1af5fbf 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,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