Make exprIsConApp_maybe work better for literals strings

There are two things here

* Use exprIsLiteral_maybe to "look through" a variable bound
  to a literal string.

* Add CONLIKE to the NOINLINE pragma for unpackCString# and
  unpackCStringUtf8#

See Trac #13317, Trac #10844, and
Note [exprIsConApp_maybe on literal strings] in CoreSubst

I did a nofib run and got essentially zero change except for one
2.2% improvement in allocation for 'pretty'.

7 files changed, 56 insertions, 11 deletions

diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs
index 89a92f886a..53072dc0d9 100644
--- a/compiler/coreSyn/CoreSubst.hs
+++ b/compiler/coreSyn/CoreSubst.hs
@@ -1378,7 +1378,7 @@ However e might not *look* as if
 
 Note [exprIsConApp_maybe on literal strings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See #9400.
+See #9400 and #13317.
 
 Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core
 they are represented as unpackCString# "abc"# by MkCore.mkStringExprFS, or
@@ -1394,6 +1394,13 @@ We need to be careful about UTF8 strings here. ""# contains a ByteString, so
 we must parse it back into a FastString to split off the first character.
 That way we can treat unpackCString# and unpackCStringUtf8# in the same way.
 
+We must also be caeful about
+   lvl = "foo"#
+   ...(unpackCString# lvl)...
+to ensure that we see through the let-binding for 'lvl'.  Hence the
+(exprIsLiteral_maybe .. arg) in the guard before the call to
+dealWithStringLiteral.
+
 Note [Push coercions in exprIsConApp_maybe]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In Trac #13025 I found a case where we had
@@ -1460,9 +1467,11 @@ exprIsConApp_maybe (in_scope, id_unf) expr
         , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs)
         = go (Left in_scope') rhs cont
 
-        | (fun `hasKey` unpackCStringIdKey)
-         || (fun `hasKey` unpackCStringUtf8IdKey)
-        , [Lit (MachStr str)] <- args
+        -- See Note [exprIsConApp_maybe on literal strings]
+        | (fun `hasKey` unpackCStringIdKey) ||
+          (fun `hasKey` unpackCStringUtf8IdKey)
+        , [arg]              <- args
+        , Just (MachStr str) <- exprIsLiteral_maybe (in_scope, id_unf) arg
         = dealWithStringLiteral fun str co
         where
           unfolding = id_unf fun
diff --git a/libraries/ghc-prim/GHC/CString.hs b/libraries/ghc-prim/GHC/CString.hs
index 19e6f75b1f..2adb13d8a0 100644
--- a/libraries/ghc-prim/GHC/CString.hs
+++ b/libraries/ghc-prim/GHC/CString.hs
@@ -34,9 +34,8 @@ import GHC.Prim
 -- stuff uses Strings in the representation, so to give representations for
 -- ghc-prim types we need unpackCString#
 
-{-
-Note [Inlining unpackCString#]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Inlining unpackCString#]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 There's really no point in ever inlining things like unpackCString# as the loop
 doesn't specialise in an interesting way and we can't deforest the list
 constructors (we'd want to use unpackFoldrCString# for this). Moreover, it's
@@ -57,10 +56,22 @@ to match unpackCString#,
  * stream fusion rules; e.g. in the `text` library,
        unstream (S.map safe (S.streamList (GHC.unpackCString# a)))
           = unpackCString# a
+
+Moreover, we want to make it CONLIKE, so that:
+
+* the rules in PrelRules will fire when the string is let-bound.
+  E.g. the eqString rule in PrelRules
+   eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
+
+* exprIsConApp_maybe will see the string when we ahve
+     let x = unpackCString# "foo"#
+     ...(case x of algs)...
+
+All of this goes for unpackCStringUtf8# too.
 -}
 
 unpackCString# :: Addr# -> [Char]
-{-# NOINLINE unpackCString# #-}
+{-# NOINLINE CONLIKE unpackCString# #-}
 unpackCString# addr
   = unpack 0#
   where
@@ -110,7 +121,7 @@ unpackFoldrCString# addr f z
 -- There's really no point in inlining this for the same reasons as
 -- unpackCString. See Note [Inlining unpackCString#] above for details.
 unpackCStringUtf8# :: Addr# -> [Char]
-{-# NOINLINE unpackCStringUtf8# #-}
+{-# NOINLINE CONLIKE unpackCStringUtf8# #-}
 unpackCStringUtf8# addr
   = unpack 0#
   where
diff --git a/testsuite/tests/simplCore/should_compile/Makefile b/testsuite/tests/simplCore/should_compile/Makefile
index ef3e74ad7f..7dd784bf45 100644
--- a/testsuite/tests/simplCore/should_compile/Makefile
+++ b/testsuite/tests/simplCore/should_compile/Makefile
@@ -15,6 +15,10 @@ T9509:
         # Grep output should show a SPEC rule firing
         # The unfolding use threshold is to prevent foo inlining before it is specialised
 
+T13317:
+	$(RM) -f T13317.o T13317.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) $(T8832_WORDSIZE_OPTS) -O -c -ddump-simpl-stats T13317.hs | grep 'KnownBranch'
+
 T8832:
 	$(RM) -f T8832.o T8832.hi
 	'$(TEST_HC)' $(TEST_HC_OPTS) $(T8832_WORDSIZE_OPTS) -O -c -ddump-simpl T8832.hs | grep '^[a-zA-Z0-9]\+ ='
diff --git a/testsuite/tests/simplCore/should_compile/T13317.hs b/testsuite/tests/simplCore/should_compile/T13317.hs
new file mode 100644
index 0000000000..510d0d4c73
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T13317.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE MagicHash #-}
+
+module T13317 where
+
+import GHC.Base
+
+f x = let x = "foo"#
+          y1 = unpackCString# x
+          y2 = unpackCString# x
+      in
+      (y1, case y2 of
+              'f' : _ -> True
+              _       -> False
+      )
+-- This case-expression should simplify
+-- yeilding a KnownBranch simplifier tick
diff --git a/testsuite/tests/simplCore/should_compile/T13317.stdout b/testsuite/tests/simplCore/should_compile/T13317.stdout
new file mode 100644
index 0000000000..d54ebe969c
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T13317.stdout
@@ -0,0 +1 @@
+3 KnownBranch
diff --git a/testsuite/tests/simplCore/should_compile/T3234.stderr b/testsuite/tests/simplCore/should_compile/T3234.stderr
index 9d87b3ecc1..ad31846bf6 100644
--- a/testsuite/tests/simplCore/should_compile/T3234.stderr
+++ b/testsuite/tests/simplCore/should_compile/T3234.stderr
@@ -10,7 +10,7 @@
 
 
 ==================== Grand total simplifier statistics ====================
-Total ticks:     54
+Total ticks:     55
 
 15 PreInlineUnconditionally
   1 n
@@ -40,7 +40,7 @@ Total ticks:     54
   1 fold/build
   1 unpack
   1 unpack-list
-4 LetFloatFromLet 4
+5 LetFloatFromLet 5
 25 BetaReduction
   1 a
   1 c
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 1dd4232b2d..53f5ade353 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -240,3 +240,7 @@ test('str-rules',
      run_command,
      ['$MAKE -s --no-print-directory str-rules'])
 test('T13170', only_ways(['optasm']), compile, ['-dcore-lint'])
+test('T13317',
+     normal,
+     run_command,
+     ['$MAKE -s --no-print-directory T13317'])