Commit f49ddc1d authored by simonpj's avatar simonpj
Browse files

[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
parent e3352583
......@@ -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
......
......@@ -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}
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment