[Git][ghc/ghc][wip/T22010] Split #23537 workaround into new module
Jaro Reinders (@Noughtmare)
gitlab at gitlab.haskell.org
Mon Jun 26 09:50:02 UTC 2023
Jaro Reinders pushed to branch wip/T22010 at Glasgow Haskell Compiler / GHC
Commits:
be92a75c by Jaro Reinders at 2023-06-26T11:49:52+02:00
Split #23537 workaround into new module
- - - - -
9 changed files:
- compiler/GHC/HsToCore/Match/Literal.hs
- compiler/GHC/StgToCmm/Ticky.hs
- compiler/GHC/Tc/Deriv/Utils.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/TcType.hs
- + compiler/GHC/Utils/Unique.hs
- compiler/ghc.cabal.in
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
Changes:
=====================================
compiler/GHC/HsToCore/Match/Literal.hs
=====================================
@@ -64,6 +64,7 @@ import GHC.Utils.Outputable as Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
+import GHC.Utils.Unique (same)
import GHC.Data.FastString
@@ -319,29 +320,29 @@ warnAboutOverflowedLiterals dflags lit
, Just (i, tc) <- lit
= if
-- These only show up via the 'HsOverLit' route
- | tc == intTyConName -> check i tc minInt maxInt
- | tc == wordTyConName -> check i tc minWord maxWord
- | tc == int8TyConName -> check i tc (min' @Int8) (max' @Int8)
- | tc == int16TyConName -> check i tc (min' @Int16) (max' @Int16)
- | tc == int32TyConName -> check i tc (min' @Int32) (max' @Int32)
- | tc == int64TyConName -> check i tc (min' @Int64) (max' @Int64)
- | tc == word8TyConName -> check i tc (min' @Word8) (max' @Word8)
- | tc == word16TyConName -> check i tc (min' @Word16) (max' @Word16)
- | tc == word32TyConName -> check i tc (min' @Word32) (max' @Word32)
- | tc == word64TyConName -> check i tc (min' @Word64) (max' @Word64)
- | tc == naturalTyConName -> checkPositive i tc
+ | same tc intTyConName -> check i tc minInt maxInt
+ | same tc wordTyConName -> check i tc minWord maxWord
+ | same tc int8TyConName -> check i tc (min' @Int8) (max' @Int8)
+ | same tc int16TyConName -> check i tc (min' @Int16) (max' @Int16)
+ | same tc int32TyConName -> check i tc (min' @Int32) (max' @Int32)
+ | same tc int64TyConName -> check i tc (min' @Int64) (max' @Int64)
+ | same tc word8TyConName -> check i tc (min' @Word8) (max' @Word8)
+ | same tc word16TyConName -> check i tc (min' @Word16) (max' @Word16)
+ | same tc word32TyConName -> check i tc (min' @Word32) (max' @Word32)
+ | same tc word64TyConName -> check i tc (min' @Word64) (max' @Word64)
+ | same tc naturalTyConName -> checkPositive i tc
-- These only show up via the 'HsLit' route
- | tc == intPrimTyConName -> check i tc minInt maxInt
- | tc == wordPrimTyConName -> check i tc minWord maxWord
- | tc == int8PrimTyConName -> check i tc (min' @Int8) (max' @Int8)
- | tc == int16PrimTyConName -> check i tc (min' @Int16) (max' @Int16)
- | tc == int32PrimTyConName -> check i tc (min' @Int32) (max' @Int32)
- | tc == int64PrimTyConName -> check i tc (min' @Int64) (max' @Int64)
- | tc == word8PrimTyConName -> check i tc (min' @Word8) (max' @Word8)
- | tc == word16PrimTyConName -> check i tc (min' @Word16) (max' @Word16)
- | tc == word32PrimTyConName -> check i tc (min' @Word32) (max' @Word32)
- | tc == word64PrimTyConName -> check i tc (min' @Word64) (max' @Word64)
+ | same tc intPrimTyConName -> check i tc minInt maxInt
+ | same tc wordPrimTyConName -> check i tc minWord maxWord
+ | same tc int8PrimTyConName -> check i tc (min' @Int8) (max' @Int8)
+ | same tc int16PrimTyConName -> check i tc (min' @Int16) (max' @Int16)
+ | same tc int32PrimTyConName -> check i tc (min' @Int32) (max' @Int32)
+ | same tc int64PrimTyConName -> check i tc (min' @Int64) (max' @Int64)
+ | same tc word8PrimTyConName -> check i tc (min' @Word8) (max' @Word8)
+ | same tc word16PrimTyConName -> check i tc (min' @Word16) (max' @Word16)
+ | same tc word32PrimTyConName -> check i tc (min' @Word32) (max' @Word32)
+ | same tc word64PrimTyConName -> check i tc (min' @Word64) (max' @Word64)
| otherwise -> return ()
@@ -369,10 +370,6 @@ warnAboutOverflowedLiterals dflags lit
where
bounds = Just (MinBound minB, MaxBound maxB)
- -- Work around #23537
- {-# NOINLINE (==) #-}
- (==) = (GHC.Prelude.==)
-
warnAboutEmptyEnumerations :: FamInstEnvs -> DynFlags -> LHsExpr GhcTc
-> Maybe (LHsExpr GhcTc)
-> LHsExpr GhcTc -> DsM ()
@@ -400,28 +397,24 @@ warnAboutEmptyEnumerations fam_envs dflags fromExpr mThnExpr toExpr
to = wrap @a to'
mThn = fmap (wrap @a . fst) mThn'
- -- Work around #23537
- {-# NOINLINE (==) #-}
- (==) = (GHC.Prelude.==)
-
platform <- targetPlatform <$> getDynFlags
-- Be careful to use target Int/Word sizes! cf #17336
- if | tc == intTyConName -> case platformWordSize platform of
- PW4 -> check @Int32
- PW8 -> check @Int64
- | tc == wordTyConName -> case platformWordSize platform of
- PW4 -> check @Word32
- PW8 -> check @Word64
- | tc == int8TyConName -> check @Int8
- | tc == int16TyConName -> check @Int16
- | tc == int32TyConName -> check @Int32
- | tc == int64TyConName -> check @Int64
- | tc == word8TyConName -> check @Word8
- | tc == word16TyConName -> check @Word16
- | tc == word32TyConName -> check @Word32
- | tc == word64TyConName -> check @Word64
- | tc == integerTyConName -> check @Integer
- | tc == naturalTyConName -> check @Integer
+ if | same tc intTyConName -> case platformWordSize platform of
+ PW4 -> check @Int32
+ PW8 -> check @Int64
+ | same tc wordTyConName -> case platformWordSize platform of
+ PW4 -> check @Word32
+ PW8 -> check @Word64
+ | same tc int8TyConName -> check @Int8
+ | same tc int16TyConName -> check @Int16
+ | same tc int32TyConName -> check @Int32
+ | same tc int64TyConName -> check @Int64
+ | same tc word8TyConName -> check @Word8
+ | same tc word16TyConName -> check @Word16
+ | same tc word32TyConName -> check @Word32
+ | same tc word64TyConName -> check @Word64
+ | same tc integerTyConName -> check @Integer
+ | same tc naturalTyConName -> check @Integer
-- We use 'Integer' because otherwise a negative 'Natural' literal
-- could cause a compile time crash (instead of a runtime one).
-- See the T10930b test case for an example of where this matters.
=====================================
compiler/GHC/StgToCmm/Ticky.hs
=====================================
@@ -157,6 +157,7 @@ import GHC.Types.Id.Info
import GHC.StgToCmm.Env (getCgInfo_maybe)
import Data.Coerce (coerce)
import GHC.Utils.Json
+import GHC.Utils.Unique (anyOf)
-----------------------------------------------------------------------------
--
@@ -884,22 +885,19 @@ showTypeCategory ty
| otherwise = case tcSplitTyConApp_maybe ty of
Nothing -> '.'
Just (tycon, _) ->
- let -- Work around #23537
- {-# NOINLINE anyOf #-}
- anyOf us = getUnique tycon `elem` us in
case () of
- _ | anyOf [fUNTyConKey] -> '>'
- | anyOf [charTyConKey] -> 'C'
- | anyOf [charPrimTyConKey] -> 'c'
- | anyOf [doubleTyConKey] -> 'D'
- | anyOf [doublePrimTyConKey] -> 'd'
- | anyOf [floatTyConKey] -> 'F'
- | anyOf [floatPrimTyConKey] -> 'f'
- | anyOf [intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey] -> 'I'
- | anyOf [intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey] -> 'i'
- | anyOf [wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey] -> 'W'
- | anyOf [wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey] -> 'w'
- | anyOf [listTyConKey] -> 'L'
+ _ | anyOf tycon [fUNTyConKey] -> '>'
+ | anyOf tycon [charTyConKey] -> 'C'
+ | anyOf tycon [charPrimTyConKey] -> 'c'
+ | anyOf tycon [doubleTyConKey] -> 'D'
+ | anyOf tycon [doublePrimTyConKey] -> 'd'
+ | anyOf tycon [floatTyConKey] -> 'F'
+ | anyOf tycon [floatPrimTyConKey] -> 'f'
+ | anyOf tycon [intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey] -> 'I'
+ | anyOf tycon [intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey] -> 'i'
+ | anyOf tycon [wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey] -> 'W'
+ | anyOf tycon [wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey] -> 'w'
+ | anyOf tycon [listTyConKey] -> 'L'
| isUnboxedTupleTyCon tycon -> 't'
| isTupleTyCon tycon -> 'T'
| isPrimTyCon tycon -> 'P'
=====================================
compiler/GHC/Tc/Deriv/Utils.hs
=====================================
@@ -66,6 +66,7 @@ import GHC.Builtin.Names.TH (liftClassKey)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Error
+import GHC.Utils.Unique (same)
import Control.Monad.Trans.Reader
import Data.Foldable (traverse_)
@@ -893,37 +894,37 @@ classArgsErr cls cls_tys = DerivErrNotAClass (mkClassPred cls cls_tys)
-- class for which stock deriving isn't possible.
stockSideConditions :: DerivContext -> Class -> Maybe Condition
stockSideConditions deriv_ctxt cls
- | cls_key == eqClassKey = Just (cond_std `andCond` cond_args cls)
- | cls_key == ordClassKey = Just (cond_std `andCond` cond_args cls)
- | cls_key == showClassKey = Just (cond_std `andCond` cond_args cls)
- | cls_key == readClassKey = Just (cond_std `andCond` cond_args cls)
- | cls_key == enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
- | cls_key == ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
- | cls_key == boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
- | cls_key == dataClassKey = Just (checkFlag LangExt.DeriveDataTypeable `andCond`
- cond_vanilla `andCond`
- cond_args cls)
- | cls_key == functorClassKey = Just (checkFlag LangExt.DeriveFunctor `andCond`
- cond_vanilla `andCond`
- cond_functorOK True False)
- | cls_key == foldableClassKey = Just (checkFlag LangExt.DeriveFoldable `andCond`
- cond_vanilla `andCond`
- cond_functorOK False True)
- -- Functor/Fold/Trav works ok
- -- for rank-n types
- | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond`
- cond_vanilla `andCond`
- cond_functorOK False False)
- | cls_key == genClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond`
- cond_vanilla `andCond`
- cond_RepresentableOk)
- | cls_key == gen1ClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond`
- cond_vanilla `andCond`
- cond_Representable1Ok)
- | cls_key == liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond`
- cond_vanilla `andCond`
- cond_args cls)
- | otherwise = Nothing
+ | same cls_key eqClassKey = Just (cond_std `andCond` cond_args cls)
+ | same cls_key ordClassKey = Just (cond_std `andCond` cond_args cls)
+ | same cls_key showClassKey = Just (cond_std `andCond` cond_args cls)
+ | same cls_key readClassKey = Just (cond_std `andCond` cond_args cls)
+ | same cls_key enumClassKey = Just (cond_std `andCond` cond_isEnumeration)
+ | same cls_key ixClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
+ | same cls_key boundedClassKey = Just (cond_std `andCond` cond_enumOrProduct cls)
+ | same cls_key dataClassKey = Just (checkFlag LangExt.DeriveDataTypeable `andCond`
+ cond_vanilla `andCond`
+ cond_args cls)
+ | same cls_key functorClassKey = Just (checkFlag LangExt.DeriveFunctor `andCond`
+ cond_vanilla `andCond`
+ cond_functorOK True False)
+ | same cls_key foldableClassKey = Just (checkFlag LangExt.DeriveFoldable `andCond`
+ cond_vanilla `andCond`
+ cond_functorOK False True)
+ -- Functor/Fold/Trav works ok
+ -- for rank-n types
+ | same cls_key traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond`
+ cond_vanilla `andCond`
+ cond_functorOK False False)
+ | same cls_key genClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond`
+ cond_vanilla `andCond`
+ cond_RepresentableOk)
+ | same cls_key gen1ClassKey = Just (checkFlag LangExt.DeriveGeneric `andCond`
+ cond_vanilla `andCond`
+ cond_Representable1Ok)
+ | same cls_key liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond`
+ cond_vanilla `andCond`
+ cond_args cls)
+ | otherwise = Nothing
where
cls_key = getUnique cls
cond_std = cond_stdOK deriv_ctxt False
@@ -931,10 +932,6 @@ stockSideConditions deriv_ctxt cls
cond_vanilla = cond_stdOK deriv_ctxt True
-- Vanilla data constructors but allow no data cons or polytype arguments
- -- Work around #23537
- {-# NOINLINE (==) #-}
- (==) = (GHC.Prelude.==)
-
type Condition
= DynFlags
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -89,6 +89,7 @@ import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Outputable
+import GHC.Utils.Unique (same)
import GHC.Unit.State
import GHC.Unit.External
@@ -791,25 +792,21 @@ hasFixedRuntimeRepRes std_nm user_expr ty = mapM_ do_check mb_arity
in hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowFun user_expr) res_ty
mb_arity :: Maybe Arity
mb_arity -- arity of the arrow operation, counting type-level arguments
- | std_nm == arrAName -- result used as an argument in, e.g., do_premap
+ | same std_nm arrAName -- result used as an argument in, e.g., do_premap
= Just 3
- | std_nm == composeAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt
+ | same std_nm composeAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt
= Just 5
- | std_nm == firstAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt
+ | same std_nm firstAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt
= Just 4
- | std_nm == appAName -- result used as an argument in, e.g., dsCmd/HsCmdArrApp/HsHigherOrderApp
+ | same std_nm appAName -- result used as an argument in, e.g., dsCmd/HsCmdArrApp/HsHigherOrderApp
= Just 2
- | std_nm == choiceAName -- result used as an argument in, e.g., HsCmdIf
+ | same std_nm choiceAName -- result used as an argument in, e.g., HsCmdIf
= Just 5
- | std_nm == loopAName -- result used as an argument in, e.g., HsCmdIf
+ | same std_nm loopAName -- result used as an argument in, e.g., HsCmdIf
= Just 4
| otherwise
= Nothing
- -- Work around #23537
- {-# NOINLINE (==) #-}
- (==) = (GHC.Prelude.==)
-
{-
************************************************************************
* *
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -249,6 +249,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Error( Validity'(..) )
+import GHC.Utils.Unique( anyOf )
import qualified GHC.LanguageExtensions as LangExt
import Data.IORef ( IORef )
@@ -2255,23 +2256,19 @@ marshalableTyCon dflags tc
boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason
boxedMarshalableTyCon tc
- | anyOf [ intTyConKey, int8TyConKey, int16TyConKey
- , int32TyConKey, int64TyConKey
- , wordTyConKey, word8TyConKey, word16TyConKey
- , word32TyConKey, word64TyConKey
- , floatTyConKey, doubleTyConKey
- , ptrTyConKey, funPtrTyConKey
- , charTyConKey
- , stablePtrTyConKey
- , boolTyConKey
- ]
+ | anyOf tc [ intTyConKey, int8TyConKey, int16TyConKey
+ , int32TyConKey, int64TyConKey
+ , wordTyConKey, word8TyConKey, word16TyConKey
+ , word32TyConKey, word64TyConKey
+ , floatTyConKey, doubleTyConKey
+ , ptrTyConKey, funPtrTyConKey
+ , charTyConKey
+ , stablePtrTyConKey
+ , boolTyConKey
+ ]
= IsValid
| otherwise = NotValid NotABoxedMarshalableTyCon
- where
- -- Work around #23537
- {-# NOINLINE anyOf #-}
- anyOf x = getUnique tc `elem` x
legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
-- Check args of 'foreign import prim', only allow simple unlifted types.
=====================================
compiler/GHC/Utils/Unique.hs
=====================================
@@ -0,0 +1,35 @@
+{-# LANGUAGE CPP #-}
+
+{- Work around #23537
+
+On 32 bit systems, GHC's code gen around 64 bit numbers is not quite
+complete. This led to panics mentioning missing cases in iselExpr64.
+Now that GHC uses Word64 for its uniques, these panics have started
+popping up whenever a unique is compared to many other uniques in one
+function. As a work around we use these two functions which are not
+inlined on 32 bit systems, thus preventing the panics.
+-}
+
+module GHC.Utils.Unique (same, anyOf) where
+
+#include "MachDeps.h"
+
+import GHC.Prelude.Basic ( Bool, Eq((==)), Foldable(elem) )
+import GHC.Types.Unique (Unique, Uniquable (getUnique))
+
+
+#if WORD_SIZE_IN_BITS == 32
+{-# NOINLINE same #-}
+#else
+{-# INLINE same #-}
+#endif
+same :: Eq a => a -> a -> Bool
+same = (==)
+
+#if WORD_SIZE_IN_BITS == 32
+{-# NOINLINE anyOf #-}
+#else
+{-# INLINE anyOf #-}
+#endif
+anyOf :: Uniquable a => a -> [Unique] -> Bool
+anyOf tc xs = getUnique tc `elem` xs
\ No newline at end of file
=====================================
compiler/ghc.cabal.in
=====================================
@@ -900,6 +900,7 @@ Library
GHC.Utils.Ppr.Colour
GHC.Utils.TmpFs
GHC.Utils.Trace
+ GHC.Utils.Unique
GHC.Wasm.ControlFlow
GHC.Wasm.ControlFlow.FromCmm
GHC.CmmToAsm.Wasm
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -315,6 +315,7 @@ GHC.Utils.Ppr
GHC.Utils.Ppr.Colour
GHC.Utils.TmpFs
GHC.Utils.Trace
+GHC.Utils.Unique
Language.Haskell.Syntax
Language.Haskell.Syntax.Basic
Language.Haskell.Syntax.Binds
=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -322,6 +322,7 @@ GHC.Utils.Ppr
GHC.Utils.Ppr.Colour
GHC.Utils.TmpFs
GHC.Utils.Trace
+GHC.Utils.Unique
Language.Haskell.Syntax
Language.Haskell.Syntax.Basic
Language.Haskell.Syntax.Binds
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be92a75cf92969cd7ca56f83b6b7d8840db8725a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/be92a75cf92969cd7ca56f83b6b7d8840db8725a
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/20230626/5b71ce2a/attachment-0001.html>
More information about the ghc-commits
mailing list