[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

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

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}