Fix erroneous float in CoreOptwip/T16918

The simple optimiser was making an invalid transformation
to join points -- yikes.  The fix is easy.

I also added some documentation about the fact that GHC uses
a slightly more restrictive version of join points than does
the paper.

Fix #16918

1 files changed, 6 insertions, 3 deletions

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 91760c282b..2b8a0b37ab 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -786,8 +786,10 @@ lintCoreExpr (Lam var expr)
 
 lintCoreExpr e@(Case scrut var alt_ty alts) =
        -- Check the scrutinee
-  do { let scrut_diverges = exprIsBottom scrut
-     ; scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut
+  do { scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut
+          -- See Note [Join points are less general than the paper]
+          -- in CoreSyn
+
      ; (alt_ty, _) <- lintInTy alt_ty
      ; (var_ty, _) <- lintInTy (idType var)
 
@@ -810,7 +812,7 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
               , isAlgTyCon tycon
               , not (isAbstractTyCon tycon)
               , null (tyConDataCons tycon)
-              , not scrut_diverges
+              , not (exprIsBottom scrut)
               -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
                         -- This can legitimately happen for type families
                       $ return ()
@@ -880,6 +882,7 @@ lintCoreFun (Lam var body) nargs
 
 lintCoreFun expr nargs
   = markAllJoinsBadIf (nargs /= 0) $
+      -- See Note [Join points are less general than the paper]
     lintCoreExpr expr
 
 ------------------