[project @ 2001-10-01 09:41:28 by simonpj]

Stuff to make a RULE work for
	eqString "foo" "foo" = True
(etc.)  The rule is of course a BuiltinRule in PrelRules

diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs
index 67b36a8..20384c2 100644 (file)
--- a/ghc/compiler/prelude/PrelNames.lhs
+++ b/ghc/compiler/prelude/PrelNames.lhs
@@ -159,6 +159,7 @@ knownKeyNames
        mapName,
        appendName,
        unpackCStringName,
+       unpackCStringListName,
        unpackCStringAppendName,
        unpackCStringFoldrName,
        unpackCStringUtf8Name,
@@ -378,6 +379,7 @@ eqStringName          = varQual pREL_BASE_Name SLIT("eqString") eqStringIdKey
 
 -- Strings
 unpackCStringName       = varQual pREL_BASE_Name SLIT("unpackCString#") unpackCStringIdKey
+unpackCStringListName   = varQual pREL_BASE_Name SLIT("unpackCStringList#") unpackCStringListIdKey
 unpackCStringAppendName = varQual pREL_BASE_Name SLIT("unpackAppendCString#") unpackCStringAppendIdKey
 unpackCStringFoldrName  = varQual pREL_BASE_Name SLIT("unpackFoldrCString#") unpackCStringFoldrIdKey
 unpackCStringUtf8Name   = varQual pREL_BASE_Name SLIT("unpackCStringUtf8#") unpackCStringUtf8IdKey
@@ -843,6 +845,7 @@ plusIntegerIdKey          = mkPreludeMiscIdUnique 41
 timesIntegerIdKey            = mkPreludeMiscIdUnique 42
 printIdKey                   = mkPreludeMiscIdUnique 43
 failIOIdKey                  = mkPreludeMiscIdUnique 44
+unpackCStringListIdKey       = mkPreludeMiscIdUnique 45
 \end{code}
 
 Certain class operations from Prelude classes.  They get their own

diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs
index d6a4b6f..9a1c493 100644 (file)
--- a/ghc/compiler/prelude/PrelRules.lhs
+++ b/ghc/compiler/prelude/PrelRules.lhs
@@ -37,7 +37,8 @@ import DataCon                ( dataConTag, dataConTyCon, dataConId, fIRST_TAG )
 import CoreUtils       ( exprIsValue, cheapEqExpr, exprIsConApp_maybe )
 import Type            ( tyConAppTyCon, eqType )
 import OccName         ( occNameUserString)
-import PrelNames       ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey )
+import PrelNames       ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
+                         eqStringName, unpackCStringListIdKey )
 import Name            ( Name )
 import Bits            ( Bits(..) )
 #if __GLASGOW_HASKELL__ >= 500
@@ -462,21 +463,22 @@ dataToTagRule other = Nothing
 builtinRules :: [(Name, CoreRule)]
 -- Rules for non-primops that can't be expressed using a RULE pragma
 builtinRules
-  = [ (unpackCStringFoldrName, BuiltinRule SLIT("AppendLitString") match_append_lit_str)
+  = [ (unpackCStringFoldrName, BuiltinRule SLIT("AppendLitString") match_append_lit),
+      (eqStringName,          BuiltinRule SLIT("EqString") match_eq_string)
     ]
 
 
 -- The rule is this:
 --     unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)  =  unpackFoldrCString# "foobaz" c n
 
-match_append_lit_str [Type ty1,
-                     Lit (MachStr s1),
-                     c1,
-                     Var unpk `App` Type ty2 
-                              `App` Lit (MachStr s2)
-                              `App` c2
-                              `App` n
-                    ]
+match_append_lit [Type ty1,
+                  Lit (MachStr s1),
+                  c1,
+                  Var unpk `App` Type ty2 
+                           `App` Lit (MachStr s2)
+                           `App` c2
+                           `App` n
+                 ]
   | unpk `hasKey` unpackCStringFoldrIdKey && 
     c1 `cheapEqExpr` c2
   = ASSERT( ty1 `eqType` ty2 )
@@ -485,5 +487,16 @@ match_append_lit_str [Type ty1,
                   `App` c1
                   `App` n)
 
-match_append_lit_str other = Nothing
+match_append_lit other = Nothing
+
+-- The rule is this:
+--     eqString (unpackCStringList# (Lit s1)) (unpackCStringList# (Lit s2) = s1==s2
+
+match_eq_string [Var unpk1 `App` Lit (MachStr s1),
+                Var unpk2 `App` Lit (MachStr s2)]
+  | unpk1 `hasKey` unpackCStringListIdKey,
+    unpk2 `hasKey` unpackCStringListIdKey
+  = Just (if s1 == s2 then trueVal else falseVal)
+
+match_eq_string other = Nothing
 \end{code}