PrelRules: Don't break let/app invariant in shiftRulewip/T16742

Previously shiftRule would rewrite as invalid shift like
```
let x = I# (uncheckedIShiftL# n 80)
in ...
```
to
```
let x = I# (error "invalid shift")
in ...
```
However, this breaks the let/app invariant as `error` is not
okay-for-speculation. There isn't an easy way to avoid this so let's not
try. Instead we just take advantage of the undefined nature of invalid
shifts and return zero.

Fixes #16742.

7 files changed, 53 insertions, 5 deletions

diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index f48fef568e..95b05392ae 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -445,6 +445,9 @@ which will generate a @case@ if necessary
 The let/app invariant is initially enforced by mkCoreLet and mkCoreApp in
 coreSyn/MkCore.
 
+For discussion of some implications of the let/app invariant primops see
+Note [Checking versus non-checking primops] in PrimOp.
+
 Note [CoreSyn type and coercion invariant]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We allow a /non-recursive/, /non-top-level/ let to bind type and
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index 6f77813785..6b93df5494 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -476,8 +476,7 @@ shiftRule shift_op
              -> return e1
              -- See Note [Guarding against silly shifts]
              | shift_len < 0 || shift_len > wordSizeInBits dflags
-             -> return $ mkRuntimeErrorApp rUNTIME_ERROR_ID wordPrimTy
-                           ("Bad shift length " ++ show shift_len)
+             -> return $ Lit $ mkLitNumberWrap dflags LitNumInt 0 (exprType e1)
 
            -- Do the shift at type Integer, but shift length is Int
            Lit (LitNumber nt x t)
@@ -702,7 +701,27 @@ can't constant fold it, but if it gets to the assember we get
      Error: operand type mismatch for `shl'
 
 So the best thing to do is to rewrite the shift with a call to error,
-when the second arg is stupid.
+when the second arg is large. However, in general we cannot do this; consider
+this case
+
+    let x = I# (uncheckedIShiftL# n 80)
+    in ...
+
+Here x contains an invalid shift and consequently we would like to rewrite it
+as follows:
+
+    let x = I# (error "invalid shift)
+    in ...
+
+This was originally done in the fix to #16449 but this breaks the let/app
+invariant (see Note [CoreSyn let/app invariant] in CoreSyn) as noted in #16742.
+For the reasons discussed in Note [Checking versus non-checking primops] (in
+the PrimOp module) there is no safe way rewrite the argument of I# such that
+it bottoms.
+
+Consequently we instead take advantage of the fact that large shifts are
+undefined behavior (see associated documentation in primops.txt.pp) and
+transform the invalid shift into an "obviously incorrect" value.
 
 There are two cases:
 
diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs
index edadf15d4c..3e157aea9b 100644
--- a/compiler/prelude/PrimOp.hs
+++ b/compiler/prelude/PrimOp.hs
@@ -304,6 +304,27 @@ primOpOutOfLine :: PrimOp -> Bool
 *                                                                      *
 ************************************************************************
 
+Note [Checking versus non-checking primops]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+  In GHC primops break down into two classes:
+
+   a. Checking primops behave, for instance, like division. In this
+      case the primop may throw an exception (e.g. division-by-zero)
+      and is consequently is marked with the can_fail flag described below.
+      The ability to fail comes at the expense of precluding some optimizations.
+
+   b. Non-checking primops behavior, for instance, like addition. While
+      addition can overflow it does not produce an exception. So can_fail is
+      set to False, and we get more optimisation opportunities.  But we must
+      never throw an exception, so we cannot rewrite to a call to error.
+
+  It is important that a non-checking primop never be transformed in a way that
+  would cause it to bottom. Doing so would violate Core's let/app invariant
+  (see Note [CoreSyn let/app invariant] in CoreSyn) which is critical to
+  the simplifier's ability to float without fear of changing program meaning.
+
+
 Note [PrimOp can_fail and has_side_effects]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Both can_fail and has_side_effects mean that the primop has
diff --git a/testsuite/tests/codeGen/should_run/T16449_2.hs b/testsuite/tests/codeGen/should_run/T16449_2.hs
index 3424d43e25..acb885369c 100644
--- a/testsuite/tests/codeGen/should_run/T16449_2.hs
+++ b/testsuite/tests/codeGen/should_run/T16449_2.hs
@@ -5,5 +5,9 @@ module Main where
 import GHC.Prim
 import GHC.Int
 
+-- Test that large unchecked shifts, which constitute undefined behavior, do
+-- not crash the compiler and instead evaluate to 0.
+-- See Note [Guarding against silly shifts] in PrelRules.
+
 -- Shift should be larger than the word size (e.g. 64 on 64-bit) for this test.
 main = print (I# (uncheckedIShiftL# 1# 1000#))
diff --git a/testsuite/tests/codeGen/should_run/T16449_2.stderr b/testsuite/tests/codeGen/should_run/T16449_2.stderr
deleted file mode 100644
index 869a5b0f91..0000000000
--- a/testsuite/tests/codeGen/should_run/T16449_2.stderr
+++ /dev/null
@@ -1 +0,0 @@
-T16449_2: Bad shift length 1000
diff --git a/testsuite/tests/codeGen/should_run/T16449_2.stdout b/testsuite/tests/codeGen/should_run/T16449_2.stdout
new file mode 100644
index 0000000000..77ac542d4f
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T16449_2.stdout
@@ -0,0 +1,2 @@
+0
+
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index 5545c9ebb0..535ca8651e 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -196,4 +196,4 @@ test('T15892',
         extra_run_opts('+RTS -G1 -A32k -RTS') ],
      compile_and_run, ['-O'])
 test('T16617', normal, compile_and_run, [''])
-test('T16449_2', [expect_broken_for(16742, ['dyn', 'ghci', 'optasm', 'threaded2']), exit_code(1)], compile_and_run, [''])
+test('T16449_2', exit_code(0), compile_and_run, [''])