diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2017-04-11 15:34:12 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2017-04-12 16:16:16 +0100 |
| commit | 8346334ef5ef3999c124a904f6915f75260eca9a (patch) | |
| tree | 84f1b8a19cff51559361aa482d027aad755d67bc /compiler/simplCore | |
| parent | b5b7d820afd8fca098bf1f4a7380d425ca6be31d (diff) | |
| download | haskell-8346334ef5ef3999c124a904f6915f75260eca9a.tar.gz | |
Fix another literal-string buglet
We were failing to float a nested binding
x :: Addr# = "foo"#
to top level, even though we /were/ floating string
literals themselves. A small oversight, easily fixed.
Diffstat (limited to 'compiler/simplCore')
| -rw-r--r-- | compiler/simplCore/SetLevels.hs | 13 |
1 files changed, 7 insertions, 6 deletions
diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs index 90e1d5369a..afca7ae3b9 100644 --- a/compiler/simplCore/SetLevels.hs +++ b/compiler/simplCore/SetLevels.hs @@ -84,7 +84,7 @@ import Literal ( litIsTrivial ) import Demand ( StrictSig, isStrictDmd, splitStrictSig, increaseStrictSigArity ) import Name ( getOccName, mkSystemVarName ) import OccName ( occNameString ) -import Type ( isUnliftedType, Type, mkLamTypes, splitTyConApp_maybe ) +import Type ( Type, mkLamTypes, splitTyConApp_maybe ) import BasicTypes ( Arity, RecFlag(..), isRec ) import DataCon ( dataConOrigResTy ) import TysWiredIn @@ -1001,10 +1001,10 @@ lvlBind env (AnnNonRec bndr rhs) || isCoVar bndr -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv) -- so we will ignore this case for now || not (profitableFloat env dest_lvl) - || (isTopLvl dest_lvl && isUnliftedType (idType bndr)) - -- We can't float an unlifted binding to top level, so we don't - -- float it at all. It's a bit brutal, but unlifted bindings - -- aren't expensive either + || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs (idType bndr))) + -- We can't float an unlifted binding to top level (except + -- literal strings), so we don't float it at all. It's a + -- bit brutal, but unlifted bindings aren't expensive either = -- No float do { rhs' <- lvlRhs env NonRecursive is_bot mb_join_arity rhs @@ -1035,7 +1035,8 @@ lvlBind env (AnnNonRec bndr rhs) abs_vars = abstractVars dest_lvl env bind_fvs dest_lvl = destLevel env bind_fvs (isFunction rhs) is_bot is_join - mb_bot_str = exprBotStrictness_maybe (deAnnotate rhs) + deann_rhs = deAnnotate rhs + mb_bot_str = exprBotStrictness_maybe deann_rhs is_bot = isJust mb_bot_str -- NB: not isBottomThunk! See Note [Bottoming floats] point (3) |