[project @ 2000-01-04 17:40:46 by simonpj]

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

diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs
index 1af5fbf..fe8186f 100644 (file)
--- a/ghc/compiler/simplCore/ConFold.lhs
+++ b/ghc/compiler/simplCore/ConFold.lhs
@@ -18,12 +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      ( 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}
@@ -87,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}
@@ -102,21 +107,27 @@ tryPrimOp TagToEnumOp [Type ty, Con (Literal (MachInt i _)) _]
   | otherwise = panic "tryPrimOp: tagToEnum# on non-enumeration type"
     where tag = fromInteger i
          constrs = tyConDataCons tycon
-         (dc:_) = [ dc | dc <- constrs, tag == dataConTag dc ]
+         (dc:_) = [ dc | dc <- constrs, tag == dataConTag dc - fIRST_TAG ]
          (Just (tycon,_)) = splitTyConApp_maybe ty
+\end{code}
 
+For dataToTag#, we can reduce if either 
+       
+       (a) the argument is a constructor
+       (b) the argument is a variable whose unfolding is a known constructor
+
+\begin{code}
 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)))) [])
+  | maybeToBool maybe_constr
+  = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
+    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
+    maybe_constr = case maybeUnfoldingTemplate (getIdUnfolding x) of
+                       Just (Con (DataCon dc) _) -> Just dc
+                       other                     -> Nothing
+    Just dc = maybe_constr
 \end{code}
 
 \begin{code}