[project @ 1999-09-06 14:36:03 by simonmar]

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

diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs
index e6f4be7..fe8186f 100644 (file)
--- a/ghc/compiler/simplCore/ConFold.lhs
+++ b/ghc/compiler/simplCore/ConFold.lhs
@@ -18,14 +18,20 @@ 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 TyCon           ( tyConDataCons, isEnumerationTyCon, isNewTyCon )
+import DataCon         ( dataConTag, dataConTyCon, fIRST_TAG )
 import Const           ( conOkForAlt )
-import CoreUnfold      ( Unfolding(..) )
+import CoreUnfold      ( maybeUnfoldingTemplate )
+import CoreUtils       ( exprIsValue )
 import Type            ( splitTyConApp_maybe )
 
+import Maybes          ( maybeToBool )
 import Char            ( ord, chr )
 import Outputable
+
+#if __GLASGOW_HASKELL__ >= 404
+import GlaExts         ( fromInt )
+#endif
 \end{code}
 
 \begin{code}
@@ -89,13 +95,10 @@ NB: If we ever do case-floating, we have an extra worry:
 
 The second case must never be floated outside of the first!
 
-\begin{code}p
-tryPrimOp SeqOp [Type ty, Con (Literal lit) _]
+\begin{code}
+tryPrimOp SeqOp [Type ty, arg]
+  | exprIsValue arg
   = Just (Con (Literal (mkMachInt 1)) [])
-
-tryPrimOp SeqOp args@[Type ty, Var var]
-  | isEvaluated (getIdUnfolding var) = Just (Con (Literal (mkMachInt 1)) []))  -- var is eval'd
-  | otherwise                       = Nothing                                  -- var not eval'd
 \end{code}
 
 \begin{code}
@@ -117,18 +120,14 @@ For dataToTag#, we can reduce if either
 tryPrimOp DataToTagOp [Type ty, Con (DataCon dc) _]
   = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
 tryPrimOp DataToTagOp [Type ty, Var x]
-  | has_unfolding && unfolding_is_constr
-  = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
+  | maybeToBool maybe_constr
+  = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
+    Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
   where
-    has_unfolding = case unfolding of
-                       CoreUnfolding _ _ _ -> True
-                       other               -> False
-    unfolding = getIdUnfolding x
-    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
+    maybe_constr = case maybeUnfoldingTemplate (getIdUnfolding x) of
+                       Just (Con (DataCon dc) _) -> Just dc
+                       other                     -> Nothing
+    Just dc = maybe_constr
 \end{code}
 
 \begin{code}