[Git][ghc/ghc][wip/T21623] 2 commits: Fix fragile rule setup in GHC.Float
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Sep 22 16:51:49 UTC 2022
Simon Peyton Jones pushed to branch wip/T21623 at Glasgow Haskell Compiler / GHC
Commits:
be252113 by Simon Peyton Jones at 2022-09-22T17:52:50+01:00
Fix fragile rule setup in GHC.Float
See Note [realToFrac natural-to-float]
- - - - -
d3fb90e8 by Simon Peyton Jones at 2022-09-22T17:53:43+01:00
Wibbles
- - - - -
6 changed files:
- compiler/GHC/Tc/TyCl/Utils.hs
- libraries/base/GHC/Float.hs
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/ghci/scripts/T16575.stdout
- testsuite/tests/typecheck/should_compile/T17021a.hs
Changes:
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -85,6 +85,8 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Control.Monad
+import GHC.Utils.Trace
+
{-
************************************************************************
* *
@@ -885,7 +887,8 @@ mkRecSelBind (tycon, fl)
mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors
-> (Id, LHsBind GhcRn)
mkOneRecordSelector all_cons idDetails fl has_sel
- = (sel_id, L (noAnnSrcSpan loc) sel_bind)
+ = pprTrace "mkOneRec" (ppr con1 $$ ppr sel_name $$ ppr field_ty $$ ppr data_ty $$ ppr is_naughty)
+ (sel_id, L (noAnnSrcSpan loc) sel_bind)
where
loc = getSrcSpan sel_name
loc' = noAnnSrcSpan loc
@@ -902,13 +905,16 @@ mkOneRecordSelector all_cons idDetails fl has_sel
con1 = assert (not (null cons_w_field)) $ head cons_w_field
-- Selector type; Note [Polymorphic selectors]
- field_ty = conLikeFieldType con1 lbl
- data_tv_set= tyCoVarsOfType data_ty
- data_tvbs = filter (\tvb -> binderVar tvb `elemVarSet` data_tv_set) $
- conLikeUserTyVarBinders con1
+ field_ty = conLikeFieldType con1 lbl
+ data_tv_set = tyCoVarsOfTypes (data_ty : req_theta)
+ data_tvbs = filter (\tvb -> binderVar tvb `elemVarSet` data_tv_set) $
+ conLikeUserTyVarBinders con1
+ -- is_naughty: see Note [Naughty record selectors]
is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set)
- || has_sel == NoFieldSelectors
+ || has_sel == NoFieldSelectors -- No field selectors => all are naughty
+ -- thus suppressing making a binding
+ -- A slight hack!
sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors]
| otherwise = mkForAllTys (tyVarSpecToBinders data_tvbs) $
=====================================
libraries/base/GHC/Float.hs
=====================================
@@ -345,7 +345,8 @@ instance Fractional Float where
recip x = 1.0 / x
rationalToFloat :: Integer -> Integer -> Float
-{-# NOINLINE [1] rationalToFloat #-}
+{-# NOINLINE [0] rationalToFloat #-}
+-- Re NOINLINE pragma, see Note [realToFrac natural-to-float]
rationalToFloat n 0
| n == 0 = 0/0
| n < 0 = (-1)/0
@@ -577,7 +578,8 @@ instance Fractional Double where
recip x = 1.0 / x
rationalToDouble :: Integer -> Integer -> Double
-{-# NOINLINE [1] rationalToDouble #-}
+{-# NOINLINE [0] rationalToDouble #-}
+-- Re NOINLINE pragma, see Note [realToFrac natural-to-float]
rationalToDouble n 0
| n == 0 = 0/0
| n < 0 = (-1)/0
@@ -1488,6 +1490,25 @@ with the native backend, and 0.143 seconds with the C backend.
A few more details in #2251, and the patch message
"Add RULES for realToFrac from Int".
+
+Note [realToFrac natural-to-float]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (realToFrac @Natural @Float ..dicts.. (NS lit#))
+We want to constant-fold this. For many types this is guaranteed
+by a RULE for realToFrac: eg. RULE "realToFrac/Float->Double" above.
+
+In case there is a similar rule, we do not inline realToFrac in stage 2.
+But for whatever reason, there is no such RULE for Natural. So in stage 1
+we end up with
+ rationalToFloat (integerFromNatural (NS lit))
+and that turns into
+ rationalToFloat (IS lit#) (IS 1#)
+
+Now we'd have a BUILTIN constant folding rule for rationalToFloat; but
+to allow that rule to fire reliably we should delay inlining rationalToFloat
+until stage 0. (It may get an inlining from CPR analysis.)
+
+Hence the NOINLINE[0] rationalToFloat, and similarly rationalToDouble.
-}
-- Utils
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -61,6 +61,7 @@ GHC.Core.SimpleOpt
GHC.Core.Stats
GHC.Core.Subst
GHC.Core.Tidy
+GHC.Core.TyCo.Compare
GHC.Core.TyCo.FVs
GHC.Core.TyCo.Ppr
GHC.Core.TyCo.Rep
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -61,6 +61,7 @@ GHC.Core.SimpleOpt
GHC.Core.Stats
GHC.Core.Subst
GHC.Core.Tidy
+GHC.Core.TyCo.Compare
GHC.Core.TyCo.FVs
GHC.Core.TyCo.Ppr
GHC.Core.TyCo.Rep
=====================================
testsuite/tests/ghci/scripts/T16575.stdout
=====================================
@@ -1,5 +1,9 @@
+Loaded package environment from /home/simonpj/.ghc/x86_64-linux-9.5.20220920/environments/default
+GHCi, version 9.5.20220920: https://www.haskell.org/ghc/ :? for help
+ghci> ghci> [1 of 1] Compiling Ghost ( T16575.hs, interpreted )
+Ok, one module loaded.
Collecting type info for 1 module(s) ...
-T16575.hs:(4,15)-(4,18): GHC.Types.Int -> Ghost.X -> GHC.Show.ShowS
+ghci> T16575.hs:(4,15)-(4,18): GHC.Types.Int -> Ghost.X -> GHC.Show.ShowS
T16575.hs:(4,15)-(4,18): Ghost.X -> GHC.Base.String
T16575.hs:(4,15)-(4,18): [Ghost.X] -> GHC.Show.ShowS
T16575.hs:(7,7)-(7,8): Ghost.X -> Ghost.X -> GHC.Types.Bool
@@ -25,5 +29,6 @@ T16575.hs:(8,5)-(8,5): Ghost.X
T16575.hs:(8,10)-(8,10): Ghost.X
T16575.hs:(9,5)-(9,5): Ghost.X
T16575.hs:(9,10)-(9,10): Ghost.X
- :: [X] -> ShowS
- :: X -> X -> Bool
+ghci> ghci> ghci> ghci> ghci> :: [X] -> ShowS
+ghci> ghci> ghci> ghci> ghci> ghci> :: X -> X -> Bool
+ghci> ghci> ghci> ghci> ghci> Leaving GHCi.
=====================================
testsuite/tests/typecheck/should_compile/T17021a.hs
=====================================
@@ -12,7 +12,7 @@ type family Id x where
--type LevId :: TYPE (Id LiftedRep) -> TYPE (Id LiftedRep)
--newtype LevId x = MkLevId x
-otype LevId2 :: (r ~ Id LiftedRep) => TYPE r -> TYPE r
+type LevId2 :: (r ~ Id LiftedRep) => TYPE r -> TYPE r
newtype LevId2 x = MkLevId2 x
{-
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/883cb4793c9f65f82dec512a28639dacec77dc39...d3fb90e8c932fc792793401b199fca50f9db840b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/883cb4793c9f65f82dec512a28639dacec77dc39...d3fb90e8c932fc792793401b199fca50f9db840b
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220922/465d330b/attachment-0001.html>
More information about the ghc-commits
mailing list