diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2019-06-04 00:42:10 -0400 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-06-13 02:49:25 -0400 |
| commit | a657543c4d676b7e6e0984b72b31dd95949855e4 (patch) | |
| tree | 950a4eb77414f8703fe751a1e9705e2f17981605 | |
| parent | fc6b23be509e290f8d27775a1c637284a335ed81 (diff) | |
| download | haskell-a657543c4d676b7e6e0984b72b31dd95949855e4.tar.gz | |
PrelRules: Ensure that string unpack/append rule fires with source notes
Previously the presence of source notes could hide nested applications
of `unpackFoldrCString#` from our constant folding logic. For instance,
consider the expression:
```haskell
unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
```
Specifically, ticks appearing in two places can defeat the rule:
a. Surrounding the inner application of `unpackFoldrCString#`
b. Surrounding the fold function, `c`
The latter caused the `str_rules` testcase to fail when `base` was built
with `-g3`.
Fixes #16740.
| -rw-r--r-- | compiler/prelude/PrelRules.hs | 29 |
1 files changed, 18 insertions, 11 deletions
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index 63a8c9d48a..6f77813785 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -42,7 +42,7 @@ import TyCon ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons , tyConFamilySize ) import DataCon ( dataConTagZ, dataConTyCon, dataConWorkId ) -import CoreUtils ( cheapEqExpr, exprIsHNF, exprType ) +import CoreUtils ( cheapEqExpr, cheapEqExpr', exprIsHNF, exprType, stripTicksTop, stripTicksTopT, mkTicks ) import CoreUnfold ( exprIsConApp_maybe ) import Type import OccName ( occNameFS ) @@ -1367,20 +1367,27 @@ match_append_lit _ id_unf _ [ Type ty1 , lit1 , c1 - , Var unpk `App` Type ty2 - `App` lit2 - `App` c2 - `App` n + , e2 ] - | unpk `hasKey` unpackCStringFoldrIdKey && - c1 `cheapEqExpr` c2 + -- 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 + , unpk `hasKey` unpackCStringFoldrIdKey + , cheapEqExpr' tickishFloatable c1 c2 + , (c1Ticks, c1') <- stripTicksTop tickishFloatable c1 + , c2Ticks <- stripTicksTopT tickishFloatable c2 , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1 , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2 = ASSERT( ty1 `eqType` ty2 ) - Just (Var unpk `App` Type ty1 - `App` Lit (LitString (s1 `BS.append` s2)) - `App` c1 - `App` n) + Just $ mkTicks strTicks + $ Var unpk `App` Type ty1 + `App` Lit (LitString (s1 `BS.append` s2)) + `App` mkTicks (c1Ticks ++ c2Ticks) c1' + `App` n match_append_lit _ _ _ _ = Nothing |