diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2021-07-28 15:23:36 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-08-02 04:15:41 -0400 |
commit | 3968cd0c9282ea88b3952133f1c0ceb29bb23e03 (patch) | |
tree | 1476874987efba0915fc37e340dcc1cc32652be7 | |
parent | 7bad93a286694c1cc63f781ac0c20e6319c1ae89 (diff) | |
download | haskell-3968cd0c9282ea88b3952133f1c0ceb29bb23e03.tar.gz |
Constant-fold unpackAppendCString (fix #20174)
Minor renaming: since 1ed0409010afeaa318676e351b833aea659bf93a rules get
an InScopeEnv arg (containing an IdUnfoldingFun) instead of an
IdUnfoldingFun directly, hence I've renamed the parameter from "id_unf"
to "env" for clarity.
-rw-r--r-- | compiler/GHC/Builtin/Names.hs | 51 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/ConstantFold.hs | 100 | ||||
-rw-r--r-- | libraries/base/GHC/Base.hs | 2 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T20174.hs | 18 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T20174.stderr | 19 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 1 |
6 files changed, 143 insertions, 48 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 399b773e65..913b8a4ed9 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -322,6 +322,7 @@ basicKnownKeyNames -- Strings and lists unpackCStringName, unpackCStringUtf8Name, + unpackCStringAppendName, unpackCStringAppendUtf8Name, unpackCStringFoldrName, unpackCStringFoldrUtf8Name, cstringLengthName, @@ -752,14 +753,6 @@ integerMul_RDR = nameRdrName integerMulName ioDataCon_RDR :: RdrName ioDataCon_RDR = nameRdrName ioDataConName -eqString_RDR, unpackCString_RDR, unpackCStringFoldr_RDR, - unpackCStringFoldrUtf8_RDR, unpackCStringUtf8_RDR :: RdrName -eqString_RDR = nameRdrName eqStringName -unpackCString_RDR = nameRdrName unpackCStringName -unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName -unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name -unpackCStringFoldrUtf8_RDR = nameRdrName unpackCStringFoldrUtf8Name - newStablePtr_RDR :: RdrName newStablePtr_RDR = nameRdrName newStablePtrName @@ -1049,14 +1042,20 @@ modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey -- Base strings Strings unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, unpackCStringFoldrUtf8Name, + unpackCStringAppendName, unpackCStringAppendUtf8Name, eqStringName, cstringLengthName :: Name -unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey -unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey -unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey cstringLengthName = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey + +unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey +unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey +unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey + +unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey +unpackCStringAppendUtf8Name = varQual gHC_CSTRING (fsLit "unpackAppendCStringUtf8#") unpackCStringAppendUtf8IdKey unpackCStringFoldrUtf8Name = varQual gHC_CSTRING (fsLit "unpackFoldrCStringUtf8#") unpackCStringFoldrUtf8IdKey + -- The 'inline' function inlineIdName :: Name inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey @@ -2272,9 +2271,8 @@ wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey, noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey, realWorldPrimIdKey, recConErrorIdKey, - unpackCStringUtf8IdKey, unpackCStringAppendIdKey, - unpackCStringFoldrIdKey, unpackCStringFoldrUtf8IdKey, - unpackCStringIdKey, + unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey, + unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey, typeErrorIdKey, divIntIdKey, modIntIdKey, absentSumFieldErrorIdKey, cstringLengthIdKey, raiseOverflowIdKey, raiseUnderflowIdKey, raiseDivZeroIdKey @@ -2296,20 +2294,23 @@ runtimeErrorIdKey = mkPreludeMiscIdUnique 13 patErrorIdKey = mkPreludeMiscIdUnique 14 realWorldPrimIdKey = mkPreludeMiscIdUnique 15 recConErrorIdKey = mkPreludeMiscIdUnique 16 + unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 17 -unpackCStringAppendIdKey = mkPreludeMiscIdUnique 18 -unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 19 +unpackCStringAppendUtf8IdKey = mkPreludeMiscIdUnique 18 +unpackCStringFoldrUtf8IdKey = mkPreludeMiscIdUnique 19 unpackCStringIdKey = mkPreludeMiscIdUnique 20 -unpackCStringFoldrUtf8IdKey = mkPreludeMiscIdUnique 21 -voidPrimIdKey = mkPreludeMiscIdUnique 22 -typeErrorIdKey = mkPreludeMiscIdUnique 23 -divIntIdKey = mkPreludeMiscIdUnique 24 -modIntIdKey = mkPreludeMiscIdUnique 25 -cstringLengthIdKey = mkPreludeMiscIdUnique 26 -raiseOverflowIdKey = mkPreludeMiscIdUnique 27 -raiseUnderflowIdKey = mkPreludeMiscIdUnique 28 -raiseDivZeroIdKey = mkPreludeMiscIdUnique 29 +unpackCStringAppendIdKey = mkPreludeMiscIdUnique 21 +unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 22 + +voidPrimIdKey = mkPreludeMiscIdUnique 23 +typeErrorIdKey = mkPreludeMiscIdUnique 24 +divIntIdKey = mkPreludeMiscIdUnique 25 +modIntIdKey = mkPreludeMiscIdUnique 26 +cstringLengthIdKey = mkPreludeMiscIdUnique 27 +raiseOverflowIdKey = mkPreludeMiscIdUnique 28 +raiseUnderflowIdKey = mkPreludeMiscIdUnique 29 +raiseDivZeroIdKey = mkPreludeMiscIdUnique 30 concatIdKey, filterIdKey, zipIdKey, bindIOIdKey, returnIOIdKey, newStablePtrIdKey, diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index 163c9e0d5d..421de78568 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -1910,12 +1910,18 @@ is fine. builtinRules :: [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules - = [BuiltinRule { ru_name = fsLit "AppendLitString", + = [BuiltinRule { ru_name = fsLit "CStringFoldrLit", ru_fn = unpackCStringFoldrName, - ru_nargs = 4, ru_try = match_append_lit_C }, - BuiltinRule { ru_name = fsLit "AppendLitStringUtf8", + ru_nargs = 4, ru_try = match_cstring_foldr_lit_C }, + BuiltinRule { ru_name = fsLit "CStringFoldrLitUtf8", ru_fn = unpackCStringFoldrUtf8Name, - ru_nargs = 4, ru_try = match_append_lit_utf8 }, + ru_nargs = 4, ru_try = match_cstring_foldr_lit_utf8 }, + BuiltinRule { ru_name = fsLit "CStringAppendLit", + ru_fn = unpackCStringAppendName, + ru_nargs = 2, ru_try = match_cstring_append_lit_C }, + BuiltinRule { ru_name = fsLit "CStringAppendLitUtf8", + ru_fn = unpackCStringAppendUtf8Name, + ru_nargs = 2, ru_try = match_cstring_append_lit_utf8 }, BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, ru_nargs = 2, ru_try = match_eq_string }, BuiltinRule { ru_name = fsLit "CStringLength", ru_fn = cstringLengthName, @@ -2345,6 +2351,41 @@ builtinBignumRules = pure $ mk_lit (fromRational (n % d)) +--------------------------------------------------- +-- The rules are: +-- unpackAppendCString*# "foo"# (unpackCString*# "baz"#) +-- = unpackCString*# "foobaz"# +-- +-- unpackAppendCString*# "foo"# (unpackAppendCString*# "baz"# e) +-- = unpackAppendCString*# "foobaz"# e +-- + +-- CString version +match_cstring_append_lit_C :: RuleFun +match_cstring_append_lit_C = match_cstring_append_lit unpackCStringAppendIdKey unpackCStringIdKey + +-- CStringUTF8 version +match_cstring_append_lit_utf8 :: RuleFun +match_cstring_append_lit_utf8 = match_cstring_append_lit unpackCStringAppendUtf8IdKey unpackCStringUtf8IdKey + +{-# INLINE match_cstring_append_lit #-} +match_cstring_append_lit :: Unique -> Unique -> RuleFun +match_cstring_append_lit append_key unpack_key _ env _ [lit1, e2] + | Just (LitString s1) <- exprIsLiteral_maybe env lit1 + , (strTicks, Var unpk `App` lit2) <- stripStrTopTicks env e2 + , unpk `hasKey` unpack_key + , Just (LitString s2) <- exprIsLiteral_maybe env lit2 + = Just $ mkTicks strTicks + $ Var unpk `App` Lit (LitString (s1 `BS.append` s2)) + + | Just (LitString s1) <- exprIsLiteral_maybe env lit1 + , (strTicks, Var appnd `App` lit2 `App` e) <- stripStrTopTicks env e2 + , appnd `hasKey` append_key + , Just (LitString s2) <- exprIsLiteral_maybe env lit2 + = Just $ mkTicks strTicks + $ Var appnd `App` Lit (LitString (s1 `BS.append` s2)) `App` e + +match_cstring_append_lit _ _ _ _ _ _ = Nothing --------------------------------------------------- -- The rule is this: @@ -2354,35 +2395,32 @@ builtinBignumRules = -- See also Note [String literals in GHC] in CString.hs -- CString version -match_append_lit_C :: RuleFun -match_append_lit_C = match_append_lit unpackCStringFoldrIdKey +match_cstring_foldr_lit_C :: RuleFun +match_cstring_foldr_lit_C = match_cstring_foldr_lit unpackCStringFoldrIdKey -- CStringUTF8 version -match_append_lit_utf8 :: RuleFun -match_append_lit_utf8 = match_append_lit unpackCStringFoldrUtf8IdKey +match_cstring_foldr_lit_utf8 :: RuleFun +match_cstring_foldr_lit_utf8 = match_cstring_foldr_lit unpackCStringFoldrUtf8IdKey -{-# INLINE match_append_lit #-} -match_append_lit :: Unique -> RuleFun -match_append_lit foldVariant _ id_unf _ +{-# INLINE match_cstring_foldr_lit #-} +match_cstring_foldr_lit :: Unique -> RuleFun +match_cstring_foldr_lit foldVariant _ env _ [ Type ty1 , lit1 , c1 , e2 ] - -- N.B. Ensure that we strip off any ticks (e.g. source notes) from the - -- `lit` and `c` arguments, lest this may fail to fire when building with - -- -g3. See #16740. | (strTicks, Var unpk `App` Type ty2 `App` lit2 `App` c2 - `App` n) <- stripTicksTop tickishFloatable e2 + `App` n) <- stripStrTopTicks env e2 , unpk `hasKey` foldVariant - , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1 - , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2 + , Just (LitString s1) <- exprIsLiteral_maybe env lit1 + , Just (LitString s2) <- exprIsLiteral_maybe env lit2 , let freeVars = (mkInScopeSet (exprFreeVars c1 `unionVarSet` exprFreeVars c2)) in eqExpr freeVars c1 c2 - , (c1Ticks, c1') <- stripTicksTop tickishFloatable c1 - , c2Ticks <- stripTicksTopT tickishFloatable c2 + , (c1Ticks, c1') <- stripStrTopTicks env c1 + , c2Ticks <- stripStrTopTicksT c2 = assert (ty1 `eqType` ty2) $ Just $ mkTicks strTicks $ Var unpk `App` Type ty1 @@ -2390,7 +2428,23 @@ match_append_lit foldVariant _ id_unf _ `App` mkTicks (c1Ticks ++ c2Ticks) c1' `App` n -match_append_lit _ _ _ _ _ = Nothing +match_cstring_foldr_lit _ _ _ _ _ = Nothing + + +-- N.B. Ensure that we strip off any ticks (e.g. source notes) from the +-- argument, lest this may fail to fire when building with -g3. See #16740. +-- +-- Also, look into variable's unfolding just in case the expression we look for +-- is in a top-level thunk. +stripStrTopTicks :: InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr) +stripStrTopTicks (_,id_unf) e = case e of + Var v + | Just rhs <- expandUnfolding_maybe (id_unf v) + -> stripTicksTop tickishFloatable rhs + _ -> stripTicksTop tickishFloatable e + +stripStrTopTicksT :: CoreExpr -> [CoreTickish] +stripStrTopTicksT e = stripTicksTopT tickishFloatable e --------------------------------------------------- -- The rule is this: @@ -2429,13 +2483,13 @@ match_eq_string _ _ _ _ = Nothing -- function computing the length of such ByteStrings can often be constant -- folded. match_cstring_length :: RuleFun -match_cstring_length env id_unf _ [lit1] - | Just (LitString str) <- exprIsLiteral_maybe id_unf lit1 +match_cstring_length rule_env env _ [lit1] + | Just (LitString str) <- exprIsLiteral_maybe env lit1 -- If elemIndex returns Just, it has the index of the first embedded NUL -- in the string. If no NUL bytes are present (the common case) then use -- full length of the byte string. = let len = fromMaybe (BS.length str) (BS.elemIndex 0 str) - in Just (Lit (mkLitInt (roPlatform env) (fromIntegral len))) + in Just (Lit (mkLitInt (roPlatform rule_env) (fromIntegral len))) match_cstring_length _ _ _ _ = Nothing --------------------------------------------------- diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs index 508edb71e2..f0f14877c8 100644 --- a/libraries/base/GHC/Base.hs +++ b/libraries/base/GHC/Base.hs @@ -1696,10 +1696,12 @@ a `iShiftRL#` b | isTrue# (b >=# WORD_SIZE_IN_BITS#) = 0# "unpack" [~1] forall a . unpackCString# a = build (unpackFoldrCString# a) "unpack-list" [1] forall a . unpackFoldrCString# a (:) [] = unpackCString# a "unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n +"unpack-append-nil" forall a . unpackAppendCString# a [] = unpackCString# a "unpack-utf8" [~1] forall a . unpackCStringUtf8# a = build (unpackFoldrCStringUtf8# a) "unpack-list-utf8" [1] forall a . unpackFoldrCStringUtf8# a (:) [] = unpackCStringUtf8# a "unpack-append-utf8" forall a n . unpackFoldrCStringUtf8# a (:) n = unpackAppendCStringUtf8# a n +"unpack-append-nil-utf8" forall a . unpackAppendCStringUtf8# a [] = unpackCStringUtf8# a -- There's a built-in rule (in GHC.Core.Op.ConstantFold) for -- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n diff --git a/testsuite/tests/simplCore/should_compile/T20174.hs b/testsuite/tests/simplCore/should_compile/T20174.hs new file mode 100644 index 0000000000..d89a9645d8 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T20174.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -ddump-simpl -dsuppress-all -dno-typeable-binds -O2 #-} + +module Test (foobar, foobar2, foobar3) where + +import GHC.Exts + +bar :: String +bar = unpackCString# "bar"# + +foobar :: String +foobar = unpackAppendCString# "foo"# bar + +foobar2 :: String +foobar2 = unpackAppendCString# "foo"# (unpackCString# "bar"#) + +foobar3 :: String +foobar3 = unpackAppendCString# "foo"# (unpackAppendCString# "bar"# []) diff --git a/testsuite/tests/simplCore/should_compile/T20174.stderr b/testsuite/tests/simplCore/should_compile/T20174.stderr new file mode 100644 index 0000000000..17141396a3 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T20174.stderr @@ -0,0 +1,19 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 9, types: 4, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +foobar1 = "foobar"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +foobar = unpackCString# foobar1 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +foobar2 = foobar + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +foobar3 = foobar + + + diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 616a469746..dbec3b3066 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -369,3 +369,4 @@ test('T19794', normal, compile, ['-O']) test('T19890', [ grep_errmsg(r'= T19890.foo1') ], compile, ['-O -ddump-simpl']) test('T20125', [ grep_errmsg(r'= T20125.MkT') ], compile, ['-O -ddump-simpl -dsuppress-uniques']) test('T20143', [ grep_errmsg(r'unsafeEqualityProof') ], compile, ['-O -ddump-simpl -dsuppress-uniques']) +test('T20174', normal, compile, ['']) |