[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 f927b00..fe8186f 100644 (file)
--- a/ghc/compiler/simplCore/ConFold.lhs
+++ b/ghc/compiler/simplCore/ConFold.lhs
@@ -8,7 +8,7 @@ ToDo:
    (i1 + i2) only if it results        in a valid Float.
 
 \begin{code}
-module ConFold ( cleverMkPrimApp ) where
+module ConFold ( tryPrimOp ) where
 
 #include "HsVersions.h"
 
@@ -18,13 +18,27 @@ import Const                ( mkMachInt, mkMachWord, Literal(..), Con(..) )
 import PrimOp          ( PrimOp(..) )
 import SimplMonad
 import TysWiredIn      ( trueDataCon, falseDataCon )
-
+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}
-cleverMkPrimApp :: PrimOp -> [CoreArg] -> CoreExpr
+tryPrimOp :: PrimOp -> [CoreArg]  -- op arg1 ... argn
+                                 --   Args are already simplified
+         -> Maybe CoreExpr       -- Nothing => no transformation
+                                 -- Just e  => transforms to e
 \end{code}
 
 In the parallel world, we use _seq_ to control the order in which
@@ -81,17 +95,43 @@ 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
-cleverMkPrimApp SeqOp [Type ty, Con (Literal lit) _]
-  = Con (Literal (mkMachInt 1)) []
+\begin{code}
+tryPrimOp SeqOp [Type ty, arg]
+  | exprIsValue arg
+  = Just (Con (Literal (mkMachInt 1)) [])
+\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 - 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
 
-cleverMkPrimApp SeqOp args@[Type ty, Var var]
-  | isEvaluated (getIdUnfolding var) = Con (Literal (mkMachInt 1)) []) -- var is eval'd
-  | otherwise                       = Con (PrimOp op) args             -- var not eval'd
+\begin{code}
+tryPrimOp DataToTagOp [Type ty, Con (DataCon dc) _]
+  = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
+tryPrimOp DataToTagOp [Type ty, Var x]
+  | maybeToBool maybe_constr
+  = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
+    Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
+  where
+    maybe_constr = case maybeUnfoldingTemplate (getIdUnfolding x) of
+                       Just (Con (DataCon dc) _) -> Just dc
+                       other                     -> Nothing
+    Just dc = maybe_constr
 \end{code}
 
 \begin{code}
-cleverMkPrimApp op args
+tryPrimOp op args
   = case args of
      [Con (Literal (MachChar char_lit))      _] -> oneCharLit   op char_lit
      [Con (Literal (MachInt int_lit signed)) _] -> (if signed then oneIntLit else oneWordLit)
@@ -123,21 +163,21 @@ cleverMkPrimApp op args
 
      other                                     -> give_up
   where
-    give_up = Con (PrimOp op) args
+    give_up = Nothing
 
-    return_char c   = Con (Literal (MachChar   c)) []
-    return_int i    = Con (Literal (mkMachInt  i)) []
-    return_word i   = Con (Literal (mkMachWord i)) []
-    return_float f  = Con (Literal (MachFloat  f)) []
-    return_double d = Con (Literal (MachDouble d)) []
-    return_lit lit  = Con (Literal lit) []
+    return_char c   = Just (Con (Literal (MachChar   c)) [])
+    return_int i    = Just (Con (Literal (mkMachInt  i)) [])
+    return_word i   = Just (Con (Literal (mkMachWord i)) [])
+    return_float f  = Just (Con (Literal (MachFloat  f)) [])
+    return_double d = Just (Con (Literal (MachDouble d)) [])
+    return_lit lit  = Just (Con (Literal lit) [])
 
-    return_bool True  = trueVal
-    return_bool False = falseVal
+    return_bool True  = Just trueVal
+    return_bool False = Just falseVal
 
     return_prim_case var lit val_if_eq val_if_neq
-      = Case (Var var) var [(Literal lit, [], val_if_eq),
-                           (DEFAULT,     [], val_if_neq)]
+      = Just (Case (Var var) var [(Literal lit, [], val_if_eq),
+                                 (DEFAULT,     [], val_if_neq)])
 
        ---------   Ints --------------
     oneIntLit IntNegOp     i = return_int (-i)
@@ -256,7 +296,7 @@ cleverMkPrimApp op args
     litVar other_op lit var = give_up
 
 
-    checkRange :: Integer -> CoreExpr
+    checkRange :: Integer -> Maybe CoreExpr
     checkRange val
      | (val > fromInt maxInt) || (val < fromInt minInt)  = 
        -- Better tell the user that we've overflowed...