summaryrefslogtreecommitdiff
path: root/compiler/simplCore
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2019-07-30 15:56:08 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2019-08-04 18:18:08 -0400
commit7d8d0012acd8701c0bb562376fd8321009342dcd (patch)
tree71095e7098bc6a935112c8794a2bfa7ad88bc841 /compiler/simplCore
parent8a061d18c759cd396bb71d82688ffb28f5d27c94 (diff)
downloadhaskell-7d8d0012acd8701c0bb562376fd8321009342dcd.tar.gz
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.
Diffstat (limited to 'compiler/simplCore')
-rw-r--r--compiler/simplCore/SetLevels.hs13
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