Simon Peyton Jones pushed to branch wip/T23109a at Glasgow Haskell Compiler / GHC
Commits:
-
2bb593cc
by Simon Peyton Jones at 2025-04-21T18:14:38+01:00
-
61760473
by Simon Peyton Jones at 2025-04-21T18:15:16+01:00
-
af0ef54b
by Simon Peyton Jones at 2025-04-21T18:16:14+01:00
-
cba0eb2f
by Simon Peyton Jones at 2025-04-21T18:16:45+01:00
4 changed files:
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- libraries/ghc-internal/src/GHC/Internal/Base.hs
- libraries/ghc-internal/src/GHC/Internal/Float.hs
Changes:
| ... | ... | @@ -406,7 +406,7 @@ lvlApp env orig_expr ((_,AnnVar fn), args) |
| 406 | 406 | , arity < n_val_args
|
| 407 | 407 | , Nothing <- isClassOpId_maybe fn
|
| 408 | 408 | = do { rargs' <- mapM (lvlNonTailMFE env False) rargs
|
| 409 | - ; lapp' <- lvlNonTailMFE env False lapp
|
|
| 409 | + ; lapp' <- lvlNonTailMFE env True lapp
|
|
| 410 | 410 | ; return (foldl' App lapp' rargs') }
|
| 411 | 411 | |
| 412 | 412 | | otherwise
|
| ... | ... | @@ -707,16 +707,20 @@ lvlMFE env strict_ctxt ann_expr |
| 707 | 707 | escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env)
|
| 708 | 708 | |
| 709 | 709 | -- See Note [Floating to the top]
|
| 710 | + is_con_app = isSaturatedConApp expr
|
|
| 710 | 711 | saves_alloc = isTopLvl dest_lvl
|
| 711 | 712 | && (escapes_value_lam || floatConsts env)
|
| 712 | 713 | -- Always float allocation out of a value lambda
|
| 713 | 714 | -- if it gets to top level
|
| 714 | - && (not strict_ctxt || is_hnf || is_bot_lam)
|
|
| 715 | -{-
|
|
| 716 | - && ( (floatConsts env &&
|
|
| 717 | - (not strict_ctxt || is_hnf)) -- (FT1) and (FT2)
|
|
| 718 | - || (is_bot_lam && escapes_value_lam)) -- (FT3)
|
|
| 719 | --}
|
|
| 715 | + && (not strict_ctxt || is_con_app || is_bot_lam)
|
|
| 716 | + -- is_con_app: don't float PAPs to the top; they may well end
|
|
| 717 | + -- up getting eta-expanded and re-inlined
|
|
| 718 | + -- E.g. f = \x -> (++) ys
|
|
| 719 | + -- If we float, then eta-expand we get
|
|
| 720 | + -- lvl = (++) ys
|
|
| 721 | + -- f = \x \zs -> lvl zs
|
|
| 722 | + -- and now wei'll inline lvl. Silly.
|
|
| 723 | + |
|
| 720 | 724 | |
| 721 | 725 | hasFreeJoin :: LevelEnv -> DVarSet -> Bool
|
| 722 | 726 | -- Has a free join point which is not being floated to top level.
|
| ... | ... | @@ -1466,7 +1466,7 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env |
| 1466 | 1466 | , occ_int_cxt = int_cxt }
|
| 1467 | 1467 | = isNotTopLevel top_lvl -- Get rid of allocation
|
| 1468 | 1468 | || (int_cxt==IsInteresting) -- Function is applied
|
| 1469 | - || (early_phase && not (isConLikeUnfolding unf)) -- See early_phase
|
|
| 1469 | + -- || (early_phase && not (isConLikeUnfolding unf)) -- See early_phase
|
|
| 1470 | 1470 | one_occ OneOcc{ occ_n_br = 1
|
| 1471 | 1471 | , occ_in_lam = IsInsideLam
|
| 1472 | 1472 | , occ_int_cxt = IsInteresting }
|
| ... | ... | @@ -1479,7 +1479,7 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env |
| 1479 | 1479 | -- See Note [pre/postInlineUnconditionally in gentle mode]
|
| 1480 | 1480 | inline_prag = idInlinePragma bndr
|
| 1481 | 1481 | |
| 1482 | - early_phase = sePhase env /= FinalPhase
|
|
| 1482 | +-- early_phase = sePhase env /= FinalPhase
|
|
| 1483 | 1483 | -- If we don't have this early_phase test, consider
|
| 1484 | 1484 | -- x = length [1,2,3]
|
| 1485 | 1485 | -- The full laziness pass carefully floats all the cons cells to
|
| ... | ... | @@ -1809,7 +1809,7 @@ build g = g (:) [] |
| 1809 | 1809 | |
| 1810 | 1810 | augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a]
|
| 1811 | 1811 | {-# INLINE [1] augment #-}
|
| 1812 | -augment g xs = g (:) xs
|
|
| 1812 | +augment g = g (:)
|
|
| 1813 | 1813 | |
| 1814 | 1814 | {-# RULES
|
| 1815 | 1815 | "fold/build" forall k z (g::forall b. (a->b->b) -> b -> b) .
|
| ... | ... | @@ -1975,7 +1975,7 @@ The rules for map work like this. |
| 1975 | 1975 | "++/literal_utf8" forall x. (++) (unpackCStringUtf8# x) = unpackAppendCStringUtf8# x #-}
|
| 1976 | 1976 | |
| 1977 | 1977 | {-# RULES
|
| 1978 | -"++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys
|
|
| 1978 | +"++" [~1] forall xs. (++) xs = augment (\c n -> foldr c n xs)
|
|
| 1979 | 1979 | #-}
|
| 1980 | 1980 | |
| 1981 | 1981 |
| ... | ... | @@ -5,6 +5,7 @@ |
| 5 | 5 | , MagicHash
|
| 6 | 6 | , UnboxedTuples
|
| 7 | 7 | , UnliftedFFITypes
|
| 8 | + , TypeApplications
|
|
| 8 | 9 | #-}
|
| 9 | 10 | {-# LANGUAGE CApiFFI #-}
|
| 10 | 11 | -- We believe we could deorphan this module, by moving lots of things
|
| ... | ... | @@ -1696,6 +1697,16 @@ showSignedFloat showPos p x |
| 1696 | 1697 | = showParen (p > 6) (showChar '-' . showPos (-x))
|
| 1697 | 1698 | | otherwise = showPos x
|
| 1698 | 1699 | |
| 1700 | + |
|
| 1701 | +-- Speicialise showSignedFloat for (a) the type and (b) the argument function
|
|
| 1702 | +-- The particularly targets are the calls in `instance Show Float` and
|
|
| 1703 | +-- `instance Show Double`
|
|
| 1704 | +-- Specialising for both (a) and (b) is obviously more efficient; and if you
|
|
| 1705 | +-- don't you find that the `x` argument is strict, but boxed, and that can cause
|
|
| 1706 | +-- functions calling showSignedFloat to have box their argument.
|
|
| 1707 | +{-# SPECIALISE showSignedFloat @Float showFloat #-}
|
|
| 1708 | +{-# SPECIALISE showSignedFloat @Double showFloat #-}
|
|
| 1709 | + |
|
| 1699 | 1710 | {-
|
| 1700 | 1711 | We need to prevent over/underflow of the exponent in encodeFloat when
|
| 1701 | 1712 | called from scaleFloat, hence we clamp the scaling parameter.
|