From 7d8d0012acd8701c0bb562376fd8321009342dcd Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 30 Jul 2019 15:56:08 +0100 Subject: 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. --- compiler/simplCore/SetLevels.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) (limited to 'compiler/simplCore/SetLevels.hs') 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 -- cgit v1.2.1