Don't float unlifted join points to top level

Ticket #16978 showed that we were floating a recursive,
unlifted join point to top level.  It's very much a corner
case:

    joinrec j :: Int#
            j = jump j
    in ...

But somehow it showed up in a real program.

For non-recursive bindings in SetLevels.lvlBind we were already
(correctly) checking for unlifted bindings, but when I wrote
that code I didn't think that a /recursive/ binding could be
unlifted but /join-points/ can be!

Actually I don't think that SetLevels should be floating
join points at all.  SetLevels really floats things to move
stuff out of loops and save allocation; but none of that applies
to join points.  The only reason to float join points is in
cases like
   join j1 x = join j2 y = ...
               in ...
which we might want to swizzle to
   join j2 x y = ... in
   join j1 x = ...
   in ...
because now j1 looks small and might be inlined away altogether.
But this is a very local float perhaps better done in the simplifier.

Still: this patch fixes the crash, and does so in a way that is
harmless if/when we change our strategy for floating join points.

1 files changed, 11 insertions, 2 deletions

diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs
index fef15a47b2..e7187b3c52 100644
--- a/compiler/simplCore/SetLevels.hs
+++ b/compiler/simplCore/SetLevels.hs
@@ -88,7 +88,8 @@ import Literal          ( litIsTrivial )
 import Demand           ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity )
 import Name             ( getOccName, mkSystemVarName )
 import OccName          ( occNameString )
-import Type             ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType, closeOverKindsDSet )
+import Type             ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType
+                        , isUnliftedType, closeOverKindsDSet )
 import BasicTypes       ( Arity, RecFlag(..), isRec )
 import DataCon          ( dataConOrigResTy )
 import TysWiredIn
@@ -1098,12 +1099,20 @@ lvlBind env (AnnRec pairs)
   |  floatTopLvlOnly env && not (isTopLvl dest_lvl)
          -- Only floating to the top level is allowed.
   || not (profitableFloat env dest_lvl)
-  = do { let bind_lvl       = incMinorLvl (le_ctxt_lvl env)
+  || (isTopLvl dest_lvl && any (isUnliftedType . idType) bndrs)
+       -- This isUnliftedType stuff is the same test as in the non-rec case
+       -- You might wonder whether we can have a recursive binding for
+       -- an unlifted value -- but we can if it's a /join binding/ (#16978)
+       -- (Ultimately I think we should not use SetLevels to
+       -- float join bindings at all, but that's another story.)
+  =    -- No float
+    do { let bind_lvl       = incMinorLvl (le_ctxt_lvl env)
              (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs
              lvl_rhs (b,r)  = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r
        ; rhss' <- mapM lvl_rhs pairs
        ; return (Rec (bndrs' `zip` rhss'), env') }
 
+  -- Otherwise we are going to float
   | null abs_vars
   = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs
        ; new_rhss <- mapM (do_rhs new_env) pairs