From f49ddc1dd3a1812e394c91195fe18920cb35211e Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 1 Oct 2001 09:41:28 +0000 Subject: [PATCH] [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 | 3 +++ ghc/compiler/prelude/PrelRules.lhs | 35 ++++++++++++++++++++++++----------- 2 files changed, 27 insertions(+), 11 deletions(-) diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 67b36a8..20384c2 100644 --- 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 --- 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} -- 1.7.10.4