Commit 7d8d0012 authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Marge Bot

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

    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.
parent 8a061d18
......@@ -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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment