diff options
| -rw-r--r-- | compiler/GHC/Builtin/PrimOps/Casts.hs | 212 | ||||
| -rw-r--r-- | compiler/GHC/Core/TyCon.hs | 20 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Flags.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Session.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Stg/Syntax.hs | 17 | ||||
| -rw-r--r-- | compiler/GHC/Stg/Unarise.hs | 390 | ||||
| -rw-r--r-- | compiler/GHC/Types/RepType.hs | 15 | ||||
| -rw-r--r-- | compiler/GHC/Utils/Outputable.hs | 2 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 1 | ||||
| -rw-r--r-- | docs/users_guide/debugging.rst | 10 | ||||
| -rw-r--r-- | testsuite/driver/testlib.py | 9 | ||||
| -rwxr-xr-x | testsuite/tests/unboxedsums/GenManyUbxSums.hs | 109 | ||||
| -rw-r--r-- | testsuite/tests/unboxedsums/ManyUbxSums.stdout | 1 | ||||
| -rw-r--r-- | testsuite/tests/unboxedsums/ManyUbxSums_Addr.hs | 26 | ||||
| -rw-r--r-- | testsuite/tests/unboxedsums/T22208.hs | 41 | ||||
| -rw-r--r-- | testsuite/tests/unboxedsums/all.T | 10 |
16 files changed, 790 insertions, 80 deletions
diff --git a/compiler/GHC/Builtin/PrimOps/Casts.hs b/compiler/GHC/Builtin/PrimOps/Casts.hs new file mode 100644 index 0000000000..ced3ace986 --- /dev/null +++ b/compiler/GHC/Builtin/PrimOps/Casts.hs @@ -0,0 +1,212 @@ +{- +This module contains helpers to cast variables +between different Int/WordReps in StgLand. + +-} + +module GHC.Builtin.PrimOps.Casts + ( getCasts ) +where + +import GHC.Prelude + +import GHC.Core.TyCon +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Types.RepType +import GHC.Core.Type +import GHC.Builtin.Types.Prim + +import GHC.Builtin.PrimOps +import GHC.Plugins (HasDebugCallStack) + +{- Note [PrimRep based casting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module contains a number of utility functions useful when +converting between variables of differing PrimReps. + +The general pattern is: +* We have two primReps `from_rep` and `to_rep`. +* We want a list of PrimOps we can apply to a variable of rep `from_rep`. +Applying the list of primOps in order takes us to `to_rep` from `from_rep` giving +us a variable of the returned type at each step. + +E.g. we call `getCasts from_rep to_rep` and get back [(op1#,ty1),(op2#,ty2)]. +We can use this result to construct a function of type +`StgExpr -> StgExpr` by construction an expression + + case op1# <from> of (x' :: ty1) -> case op2# x' of x' -> <rhs_hole> + +Ideally backends will compile the sequence of PrimOps to a no-op. E.g. by reusing +the same register but just relabeling it as another width. +However this is might not always be possible or the required optimizations +simply not implemented in the backend. This means currently many of these casts +will be cheap but not all of them will be completely zero-cost. + +-} + +-- | `getCasts from_rep to_rep` gives us a list of primops which when applied in order convert from_rep to to_rep. +-- See Note [PrimRep based casting] +getCasts :: PrimRep -> PrimRep -> [(PrimOp,Type)] +getCasts from_rep to_rep + -- No-op + | -- pprTrace "getCasts" (ppr (from_rep,to_rep)) $ + to_rep == from_rep + = [] + + -- Float <-> Double + | to_rep == FloatRep = + assertPpr (from_rep == DoubleRep) (ppr from_rep <+> ppr to_rep) $ + [(DoubleToFloatOp,floatPrimTy)] + | to_rep == DoubleRep = + assertPpr (from_rep == FloatRep) (ppr from_rep <+> ppr to_rep) $ + [(FloatToDoubleOp,doublePrimTy)] + + -- Addr <-> Word/Int + | to_rep == AddrRep = wordOrIntToAddrRep from_rep + | from_rep == AddrRep = addrToWordOrIntRep to_rep + + -- Int* -> Int* + | primRepIsInt from_rep + , primRepIsInt to_rep + = sizedIntToSizedInt from_rep to_rep + + -- Word* -> Word* + | primRepIsWord from_rep + , primRepIsWord to_rep + = sizedWordToSizedWord from_rep to_rep + + -- Word* -> Int* + | primRepIsWord from_rep + , primRepIsInt to_rep + = let (op1,r1) = wordToIntRep from_rep + in (op1,primRepToType r1):sizedIntToSizedInt r1 to_rep + + -- Int* -> Word* + | primRepIsInt from_rep + , primRepIsWord to_rep + = let (op1,r1) = intToWordRep from_rep + in (op1,primRepToType r1):sizedWordToSizedWord r1 to_rep + + | otherwise = pprPanic "getCasts:Unexpect rep combination" + (ppr (from_rep,to_rep)) + +wordOrIntToAddrRep :: HasDebugCallStack => PrimRep -> [(PrimOp,Type)] +wordOrIntToAddrRep AddrRep = [] -- No-op argument is already AddrRep +wordOrIntToAddrRep IntRep = [(IntToAddrOp, addrPrimTy)] +wordOrIntToAddrRep WordRep = [(WordToIntOp,intPrimTy), (IntToAddrOp,addrPrimTy)] +wordOrIntToAddrRep r + | primRepIsInt r = (intToMachineInt r,intPrimTy):[(IntToAddrOp,addrPrimTy)] + | primRepIsWord r = + let (op1,r1) = wordToIntRep r + in (op1, primRepToType r1):[(intToMachineInt r1,intPrimTy), (IntToAddrOp,addrPrimTy)] + | otherwise = pprPanic "Rep not word or int rep" (ppr r) + +addrToWordOrIntRep :: HasDebugCallStack => PrimRep -> [(PrimOp,Type)] +-- Machine sizes +addrToWordOrIntRep IntRep = [(AddrToIntOp, intPrimTy)] +addrToWordOrIntRep WordRep = [(AddrToIntOp,intPrimTy), (IntToWordOp,wordPrimTy)] +-- Explicitly sized reps +addrToWordOrIntRep r + | primRepIsWord r = (AddrToIntOp,intPrimTy) : (IntToWordOp,wordPrimTy) : sizedWordToSizedWord WordRep r + | primRepIsInt r = (AddrToIntOp,intPrimTy) : sizedIntToSizedInt IntRep r + | otherwise = pprPanic "Target rep not word or int rep" (ppr r) + + +-- WordX# -> IntX# (same size), argument is source rep +wordToIntRep :: HasDebugCallStack => PrimRep -> (PrimOp,PrimRep) +wordToIntRep rep + = case rep of + (WordRep) -> (WordToIntOp, IntRep) + (Word8Rep) -> (Word8ToInt8Op, Int8Rep) + (Word16Rep) -> (Word16ToInt16Op, Int16Rep) + (Word32Rep) -> (Word32ToInt32Op, Int32Rep) + (Word64Rep) -> (Word64ToInt64Op, Int64Rep) + _ -> pprPanic "Rep not a wordRep" (ppr rep) + +-- IntX# -> WordX#, argument is source rep +intToWordRep :: HasDebugCallStack => PrimRep -> (PrimOp,PrimRep) +intToWordRep rep + = case rep of + (IntRep) -> (IntToWordOp, WordRep) + (Int8Rep) -> (Int8ToWord8Op, Word8Rep) + (Int16Rep) -> (Int16ToWord16Op, Word16Rep) + (Int32Rep) -> (Int32ToWord32Op, Word32Rep) + (Int64Rep) -> (Int64ToWord64Op, Word64Rep) + _ -> pprPanic "Rep not a wordRep" (ppr rep) + +-- Casts between any size int to any other size of int +sizedIntToSizedInt :: HasDebugCallStack => PrimRep -> PrimRep -> [(PrimOp,Type)] +sizedIntToSizedInt r1 r2 + | r1 == r2 = [] +-- Cast to Int# +sizedIntToSizedInt r IntRep = [(intToMachineInt r,intPrimTy)] +-- Cast from Int# +sizedIntToSizedInt IntRep r = [(intFromMachineInt r,primRepToType r)] +-- Sized to differently sized must go over machine word. +sizedIntToSizedInt r1 r2 = (intToMachineInt r1,intPrimTy) : [(intFromMachineInt r2,primRepToType r2)] + +-- Casts between any size Word to any other size of Word +sizedWordToSizedWord :: HasDebugCallStack => PrimRep -> PrimRep -> [(PrimOp,Type)] +sizedWordToSizedWord r1 r2 + | r1 == r2 = [] +-- Cast to Word# +sizedWordToSizedWord r WordRep = [(wordToMachineWord r,wordPrimTy)] +-- Cast from Word# +sizedWordToSizedWord WordRep r = [(wordFromMachineWord r, primRepToType r)] +-- Conversion between different non-machine sizes must go via machine word. +sizedWordToSizedWord r1 r2 = (wordToMachineWord r1,wordPrimTy) : [(wordFromMachineWord r2, primRepToType r2)] + + +-- Prefer the definitions above this line if possible +---------------------- + + +-- Int*# to Int# +{-# INLINE intToMachineInt #-} +intToMachineInt :: HasDebugCallStack => PrimRep -> PrimOp +intToMachineInt r = + assertPpr (primRepIsInt r) (ppr r) $ + case r of + (Int8Rep) -> Int8ToIntOp + (Int16Rep) -> Int16ToIntOp + (Int32Rep) -> Int32ToIntOp + (Int64Rep) -> Int64ToIntOp + _ -> pprPanic "Source rep not int" $ ppr r + +-- Int# to Int*# +{-# INLINE intFromMachineInt #-} +intFromMachineInt :: HasDebugCallStack => PrimRep -> PrimOp +intFromMachineInt r = + assertPpr (primRepIsInt r) (ppr r) $ + case r of + Int8Rep -> IntToInt8Op + Int16Rep -> IntToInt16Op + Int32Rep -> IntToInt32Op + Int64Rep -> IntToInt64Op + _ -> pprPanic "Dest rep not sized int" $ ppr r + +-- Word# to Word*# +{-# INLINE wordFromMachineWord #-} +wordFromMachineWord :: HasDebugCallStack => PrimRep -> PrimOp +wordFromMachineWord r = + assert (primRepIsWord r) $ + case r of + Word8Rep -> WordToWord8Op + Word16Rep -> WordToWord16Op + Word32Rep -> WordToWord32Op + Word64Rep -> WordToWord64Op + _ -> pprPanic "Dest rep not sized word" $ ppr r + +-- Word*# to Word# +{-# INLINE wordToMachineWord #-} +wordToMachineWord :: HasDebugCallStack => PrimRep -> PrimOp +wordToMachineWord r = + assertPpr (primRepIsWord r) (text "Not a word rep:" <> ppr r) $ + case r of + Word8Rep -> Word8ToWordOp + Word16Rep -> Word16ToWordOp + Word32Rep -> Word32ToWordOp + Word64Rep -> Word64ToWordOp + _ -> pprPanic "Dest rep not sized word" $ ppr r
\ No newline at end of file diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index 58479676d8..7e22ac483e 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -129,6 +129,8 @@ module GHC.Core.TyCon( primRepIsFloat, primRepsCompatible, primRepCompatible, + primRepIsWord, + primRepIsInt, ) where @@ -1783,6 +1785,24 @@ primRepIsFloat DoubleRep = Just True primRepIsFloat (VecRep _ _) = Nothing primRepIsFloat _ = Just False +-- Rep is one of the word reps. +primRepIsWord :: PrimRep -> Bool +primRepIsWord WordRep = True +primRepIsWord (Word8Rep) = True +primRepIsWord (Word16Rep) = True +primRepIsWord (Word32Rep) = True +primRepIsWord (Word64Rep) = True +primRepIsWord _ = False + +-- Rep is one of the int reps. +primRepIsInt :: PrimRep -> Bool +primRepIsInt (IntRep) = True +primRepIsInt (Int8Rep) = True +primRepIsInt (Int16Rep) = True +primRepIsInt (Int32Rep) = True +primRepIsInt (Int64Rep) = True +primRepIsInt _ = False + {- ************************************************************************ * * diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index e9f64a85ce..8f6c37d5a7 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -374,6 +374,7 @@ data GeneralFlag -- variables that have otherwise identical names. | Opt_SuppressUniques | Opt_SuppressStgExts + | Opt_SuppressStgReps | Opt_SuppressTicks -- Replaces Opt_PprShowTicks | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps | Opt_SuppressCoreSizes -- ^ Suppress per binding Core size stats in dumps diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index c16098593a..51d27cd0f8 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -2434,6 +2434,7 @@ dynamic_flags_deps = [ setGeneralFlag Opt_SuppressIdInfo setGeneralFlag Opt_SuppressTicks setGeneralFlag Opt_SuppressStgExts + setGeneralFlag Opt_SuppressStgReps setGeneralFlag Opt_SuppressTypeSignatures setGeneralFlag Opt_SuppressCoreSizes setGeneralFlag Opt_SuppressTimestamps) @@ -3372,6 +3373,7 @@ dFlagsDeps = [ depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts (useInstead "-d" "suppress-stg-exts"), flagSpec "suppress-stg-exts" Opt_SuppressStgExts, + flagSpec "suppress-stg-reps" Opt_SuppressStgReps, flagSpec "suppress-coercions" Opt_SuppressCoercions, flagSpec "suppress-coercion-types" Opt_SuppressCoercionTypes, flagSpec "suppress-idinfo" Opt_SuppressIdInfo, @@ -3817,7 +3819,8 @@ defaultFlags settings Opt_SimplPreInlining, Opt_VersionMacros, Opt_RPath, - Opt_CompactUnwind + Opt_CompactUnwind, + Opt_SuppressStgReps ] ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] @@ -5031,6 +5034,7 @@ initSDocContext dflags style = SDC , sdocSuppressUniques = gopt Opt_SuppressUniques dflags , sdocSuppressModulePrefixes = gopt Opt_SuppressModulePrefixes dflags , sdocSuppressStgExts = gopt Opt_SuppressStgExts dflags + , sdocSuppressStgReps = gopt Opt_SuppressStgReps dflags , sdocErrorSpans = gopt Opt_ErrorSpans dflags , sdocStarIsType = xopt LangExt.StarIsType dflags , sdocImpredicativeTypes = xopt LangExt.ImpredicativeTypes dflags diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index 779ddf8d56..c5170f36cf 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -87,7 +87,7 @@ import GHC.Core.Ppr( {- instances -} ) import GHC.Builtin.PrimOps ( PrimOp, PrimCall ) import GHC.Core.TyCon ( PrimRep(..), TyCon ) import GHC.Core.Type ( Type ) -import GHC.Types.RepType ( typePrimRep1 ) +import GHC.Types.RepType ( typePrimRep1, typePrimRep ) import GHC.Utils.Panic.Plain {- @@ -740,12 +740,23 @@ pprStgTopBinding = pprGenStgTopBinding pprStgTopBindings :: OutputablePass pass => StgPprOpts -> [GenStgTopBinding pass] -> SDoc pprStgTopBindings = pprGenStgTopBindings +pprIdWithRep :: Id -> SDoc +pprIdWithRep v = ppr v <> pprTypeRep (idType v) + +pprTypeRep :: Type -> SDoc +pprTypeRep ty = + ppUnlessOption sdocSuppressStgReps $ + char ':' <> case typePrimRep ty of + [r] -> ppr r + r -> ppr r + + instance Outputable StgArg where ppr = pprStgArg pprStgArg :: StgArg -> SDoc -pprStgArg (StgVarArg var) = ppr var -pprStgArg (StgLitArg con) = ppr con +pprStgArg (StgVarArg var) = pprIdWithRep var +pprStgArg (StgLitArg con) = ppr con <> pprTypeRep (literalType con) instance OutputablePass pass => Outputable (GenStgExpr pass) where ppr = pprStgExpr panicStgPprOpts diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs index 23c2646f73..84f508bd9b 100644 --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -186,6 +186,129 @@ So we pass type arguments of the DataCon's TyCon in StgConApp to decide what layout to use. Note that unlifted values can't be let-bound, so we don't need types in StgRhsCon. +Note [Casting slot arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this function which selects between Int32# and Int64# from a unboxed sum. + + foo :: (# Int32# | Int64# #) -> FD + foo x = case x of + (# x1 | #) -> F x1 + (# | x2 #) -> D x2 + +Naturally we would expect x1 to have a PrimRep of Int32Rep and x2 of DoubleRep. +However we used to generate this (bogus) code after Unarise giving rise to #22208: + + M.foo :: (# GHC.Prim.Int32# | GHC.Prim.Int64# #) -> M.FD + [GblId, Arity=1, Unf=OtherCon []] = + {} \r [sum_tag sum_field] + case sum_tag of tag_gsc { + __DEFAULT -> M.F [sum_field]; + 2# -> M.D [sum_field]; + }; + +Where sum_field is used both as Int32# and Int64# depending on the branch +because they share the same SlotTy. +This usually works out since we put all int's in the same sort of register. +So even if the reps where wrong (x :: bits32) = (y :: bits64) would produce +correct code in the most cases. +However there are cases where this goes wrong, causing lint errors,in the case of #22208 +compiler panics or in some cases incorrect results in the C backend. +For now our solution is to construct proper casts between the PrimRep of the slot and +the variables we want to store in, or read out of these slots. + +This means when we have a sum (# Int32# | Int64# #) if we want to store a Int32 +we convert it to a Int64 on construction of the tuple value, and convert it back +to a Int32 once when want to use the field. On most backends these coversions should +be no-ops at runtime so this seems reasonable. + +Conversion for values coming out of a strict field happen in mapSumIdBinders. While +conversion during the construction of sums happen inside mkUbxSum. + +------------- A full example of casting during sum construction ---------------- + +To compile a constructor application of a unboxed sum of type (# Int32# | Int64# ) +in an expression like `let sum = (# x | #)` we will call mkUbxSum to determine +which binders we have to replace sum with at use sites during unarise. +See also Note [Translating unboxed sums to unboxed tuples]. + +Int32# and Int64# in this case will share the same slot in the unboxed sum. This means +the sum after unarise will be represented by two binders. One for the tag and one for +the field. The later having Int64Rep. +However our input for the field is of Int32Rep. So in order to soundly construct +`(# x | #) :: (# Int32# | Int64# )` we must upcast `x` to Int64#. +To do this mkUbxSum will produce an expression with a hole for constructor application +to go into. That is the call to mkUbxSum and it's result will look something like: + + >>> mkUbxSum (#|#) [Int32#, Int64#] (x::Int32#) us (x') + ([1#::Int#, x'::Int64#], \rhs -> case int32ToInt# x of x' -> rhs ) + +We will use the returned arguments to construct an application to an unboxed tuple: + + >>> mkTuple [tag::Int#, x'::Int64#] + (# tag, x' #) + +Which we will then use as the rhs to pass into the casting wrapper to +construct an expression that casts `x` to the right type before constructing the +tuple + + >>> (\rhs -> case int32ToInt# x of x' -> rhs ) (# tag, x' #) + case int32ToInt# x of x' -> (# #) 1# x' + +Which results in the this definition for `sum` after all is said and done: + + let sum = case int32ToInt# x of { x' -> (# #) 1# x' } + +Not that the renaming is not optional. Cmm requires binders of different uniques +to have at least different types. See Note [CorePrep Overview]: 6. Clone all local Ids + +------------- A full example of casting during sum matching -------------------- + +When matching on an unboxed sum constructor we start out with +something like this the pre-unarise: + + f :: (# Int32 | Int64# ) -> ... + f sum = case sum of + (# x |#) -> alt_rhs + ... + +We unarise the function arguments and get: + + f sum_tag sum_slot1 = case sum_tag of + 1# -> ??? + +Now we need to match up the original alternative binders with the sum slots passed +to the function. This is done by mapSumIdBinders which we we call for our +example alternative like this: + + >>> mapSumIdBinders [x] [sum_slot1] alt_rhs env + (env', alt_rhs') + +mapSumIdBinders first matches up the list of binders with the slots passed to +the function which is trivial in this case. Then we check if the slot and the +variable residing inside it agree on their Rep. If alternative binders and +the function arguments agree in their slot reps we we just extend the environment +with a mapping from `x` to `sum_slot1` and we return the rhs as is. + +If the reps of the sum_slots do not agree with alternative binders they represent +then we need to wrap the whole RHS in nested cases which cast the sum_slot<n> +variables to the correct rep. Here `x` is of Int32Rep while `sum_slot1` will be +of Int64Rep. This means instead of retuning the original alt_rhs we will return: + + >>> mapSumIdBinders [x] [sum_slot1] alt_rhs env + ( env'[x=x'] + , case int64ToInt32# (sum_slot1 :: Int64#) of + (x' :: Int32#) -> alt_rhs + ) + +We then run unarise on alt_rhs within that expression, which will replace the first occurence +of `x` with sum_slot_arg_1 giving us post-unarise: + + f sum_tag sum_slot1 = + case sum_tag of + 1# -> case int64ToInt32# sum_slot1 of + x' -> ... x' ... + ... + Note [UnariseEnv] ~~~~~~~~~~~~~~~~~~ At any variable occurrence 'v', @@ -258,8 +381,8 @@ import GHC.Prelude import GHC.Types.Basic import GHC.Core import GHC.Core.DataCon -import GHC.Core.TyCon ( isVoidRep ) -import GHC.Data.FastString (FastString, mkFastString) +import GHC.Core.TyCon +import GHC.Data.FastString (FastString, mkFastString, fsLit) import GHC.Types.Id import GHC.Types.Literal import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID) @@ -275,13 +398,18 @@ import GHC.Core.Type import GHC.Builtin.Types.Prim (intPrimTy) import GHC.Builtin.Types import GHC.Types.Unique.Supply +import GHC.Types.Unique import GHC.Utils.Misc import GHC.Types.Var.Env import Data.Bifunctor (second) import Data.Maybe (mapMaybe) import qualified Data.IntMap as IM +import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Casts +import Data.List (mapAccumL) +-- import GHC.Utils.Trace -------------------------------------------------------------------------------- -- | A mapping from binders to the Ids they were expanded/renamed to. @@ -306,8 +434,10 @@ import qualified Data.IntMap as IM -- INVARIANT: OutStgArgs in the range only have NvUnaryTypes -- (i.e. no unboxed tuples, sums or voids) -- -type UnariseEnv = VarEnv UnariseVal +newtype UnariseEnv = UnariseEnv { ue_rho :: (VarEnv UnariseVal) } +initUnariseEnv :: VarEnv UnariseVal -> UnariseEnv +initUnariseEnv = UnariseEnv data UnariseVal = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void). | UnaryVal OutStgArg -- See NOTE [Renaming during unarisation]. @@ -320,25 +450,27 @@ instance Outputable UnariseVal where -- The id is mapped to one or more things. -- See Note [UnariseEnv] extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv -extendRho rho x (MultiVal args) +extendRho env x (MultiVal args) = assert (all (isNvUnaryType . stgArgType) args) - extendVarEnv rho x (MultiVal args) -extendRho rho x (UnaryVal val) + env { ue_rho = extendVarEnv (ue_rho env) x (MultiVal args) } +extendRho env x (UnaryVal val) = assert (isNvUnaryType (stgArgType val)) - extendVarEnv rho x (UnaryVal val) + env { ue_rho = extendVarEnv (ue_rho env) x (UnaryVal val) } -- Properly shadow things from an outer scope. -- See Note [UnariseEnv] -- The id stands for itself so we don't record a mapping. -- See Note [UnariseEnv] extendRhoWithoutValue :: UnariseEnv -> Id -> UnariseEnv -extendRhoWithoutValue rho x = delVarEnv rho x +extendRhoWithoutValue env x = env { ue_rho = delVarEnv (ue_rho env) x } +lookupRho :: UnariseEnv -> Id -> Maybe UnariseVal +lookupRho env v = lookupVarEnv (ue_rho env) v -------------------------------------------------------------------------------- unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding] -unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds) +unarise us binds = initUs_ us (mapM (unariseTopBinding (initUnariseEnv emptyVarEnv)) binds) unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding unariseTopBinding rho (StgTopLifted bind) @@ -366,7 +498,7 @@ unariseRhs rho (StgRhsCon ccs con mu ts args) unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr unariseExpr rho e@(StgApp f []) - = case lookupVarEnv rho f of + = case lookupRho rho f of Just (MultiVal args) -- Including empty tuples -> return (mkTuple args) Just (UnaryVal (StgVarArg f')) @@ -379,7 +511,7 @@ unariseExpr rho e@(StgApp f []) unariseExpr rho e@(StgApp f args) = return (StgApp f' (unariseFunArgs rho args)) where - f' = case lookupVarEnv rho f of + f' = case lookupRho rho f of Just (UnaryVal (StgVarArg f')) -> f' Nothing -> f err -> pprPanic "unariseExpr - app2" (pprStgExpr panicStgPprOpts e $$ ppr err) @@ -390,12 +522,17 @@ unariseExpr _ (StgLit l) = return (StgLit l) unariseExpr rho (StgConApp dc n args ty_args) - | Just args' <- unariseMulti_maybe rho dc args ty_args - = return (mkTuple args') - - | otherwise - , let args' = unariseConArgs rho args - = return (StgConApp dc n args' (map stgArgType args')) + | isUnboxedSumDataCon dc || isUnboxedTupleDataCon dc + = do + us <- getUniqueSupplyM + case unariseUbxSumOrTupleArgs rho us dc args ty_args of + (args', Just cast_wrapper) + -> return $ cast_wrapper (mkTuple args') + (args', Nothing) + -> return $ (mkTuple args') + | otherwise = + let args' = unariseConArgs rho args in + return $ (StgConApp dc n args' (map stgArgType args')) unariseExpr rho (StgOpApp op args ty) = return (StgOpApp op (unariseFunArgs rho args) ty) @@ -403,15 +540,19 @@ unariseExpr rho (StgOpApp op args ty) unariseExpr rho (StgCase scrut bndr alt_ty alts) -- tuple/sum binders in the scrutinee can always be eliminated | StgApp v [] <- scrut - , Just (MultiVal xs) <- lookupVarEnv rho v + , Just (MultiVal xs) <- lookupRho rho v = elimCase rho xs bndr alt_ty alts -- Handle strict lets for tuples and sums: -- case (# a,b #) of r -> rhs -- and analogously for sums | StgConApp dc _n args ty_args <- scrut - , Just args' <- unariseMulti_maybe rho dc args ty_args - = elimCase rho args' bndr alt_ty alts + , isUnboxedSumDataCon dc || isUnboxedTupleDataCon dc + = do + us <- getUniqueSupplyM + case unariseUbxSumOrTupleArgs rho us dc args ty_args of + (args',Just wrapper) -> wrapper <$> elimCase rho args' bndr alt_ty alts + (args',Nothing) -> elimCase rho args' bndr alt_ty alts -- See (3) of Note [Rubbish literals] in GHC.Types.Literal | StgLit lit <- scrut @@ -436,17 +577,21 @@ unariseExpr rho (StgTick tick e) = StgTick tick <$> unariseExpr rho e -- Doesn't return void args. -unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg] -unariseMulti_maybe rho dc args ty_args +unariseUbxSumOrTupleArgs :: UnariseEnv -> UniqSupply -> DataCon -> [InStgArg] -> [Type] + -> ( [OutStgArg] -- Arguments representing the unboxed sum + , Maybe (StgExpr -> StgExpr)) -- Transformation to apply to the arguments, to bring them + -- into the right Rep +unariseUbxSumOrTupleArgs rho us dc args ty_args | isUnboxedTupleDataCon dc - = Just (unariseConArgs rho args) + = (unariseConArgs rho args, Nothing) | isUnboxedSumDataCon dc , let args1 = assert (isSingleton args) (unariseConArgs rho args) - = Just (mkUbxSum dc ty_args args1) + = let (args2, cast_wrapper) = mkUbxSum dc ty_args args1 us + in (args2, Just cast_wrapper) | otherwise - = Nothing + = panic "unariseUbxSumOrTupleArgs: Constructor not a unboxed sum or tuple" -- Doesn't return void args. unariseRubbish_maybe :: Literal -> Maybe [OutStgArg] @@ -473,15 +618,19 @@ elimCase rho args bndr (MultiValAlt _) [GenStgAlt{ alt_con = _ , alt_bndrs = bndrs , alt_rhs = rhs}] = do let rho1 = extendRho rho bndr (MultiVal args) - rho2 + (rho2, rhs') <- case () of + _ | isUnboxedTupleBndr bndr - = mapTupleIdBinders bndrs args rho1 + -> return (mapTupleIdBinders bndrs args rho1, rhs) | otherwise - = assert (isUnboxedSumBndr bndr) $ - if null bndrs then rho1 - else mapSumIdBinders bndrs args rho1 + -> assert (isUnboxedSumBndr bndr) $ + case bndrs of + -- Sum with a void-type binder? + [] -> return (rho1, rhs) + [alt_bndr] -> mapSumIdBinders alt_bndr args rhs rho1 + _ -> pprPanic "mapSumIdBinders" (ppr bndrs $$ ppr args) - unariseExpr rho2 rhs + unariseExpr rho2 rhs' elimCase rho args bndr (MultiValAlt _) alts | isUnboxedSumBndr bndr @@ -572,18 +721,23 @@ unariseSumAlt :: UnariseEnv unariseSumAlt rho _ GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=e} = GenStgAlt DEFAULT mempty <$> unariseExpr rho e -unariseSumAlt rho args GenStgAlt{ alt_con = DataAlt sumCon +unariseSumAlt rho args alt@GenStgAlt{ alt_con = DataAlt sumCon , alt_bndrs = bs , alt_rhs = e } - = do let rho' = mapSumIdBinders bs args rho - lit_case = LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))) - GenStgAlt lit_case mempty <$> unariseExpr rho' e + + = do (rho',e') <- case bs of + [b] -> mapSumIdBinders b args e rho + -- Sums must have one binder + _ -> pprPanic "unariseSumAlt2" (ppr args $$ pprPanicAlt alt) + let lit_case = LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))) + GenStgAlt lit_case mempty <$> unariseExpr rho' e' unariseSumAlt _ scrt alt - = pprPanic "unariseSumAlt" (ppr scrt $$ pprPanicAlt alt) + = pprPanic "unariseSumAlt3" (ppr scrt $$ pprPanicAlt alt) -------------------------------------------------------------------------------- +-- Mapping binders when matching und a unboxed sum/tuple mapTupleIdBinders :: [InId] -- Un-processed binders of a tuple alternative. @@ -619,27 +773,90 @@ mapTupleIdBinders ids args0 rho0 map_ids rho0 ids_unarised args0 mapSumIdBinders - :: [InId] -- Binder of a sum alternative (remember that sum patterns - -- only have one binder, so this list should be a singleton) + :: InId -- Binder (in the case alternative). -> [OutStgArg] -- Arguments that form the sum (NOT including the tag). -- Can't have void args. + -> InStgExpr -> UnariseEnv - -> UnariseEnv + -> UniqSM (UnariseEnv, OutStgExpr) -mapSumIdBinders [id] args rho0 - = assert (not (any (isZeroBitTy . stgArgType) args)) $ +mapSumIdBinders alt_bndr args rhs rho0 + = assert (not (any (isZeroBitTy . stgArgType) args)) $ do + uss <- listSplitUniqSupply <$> getUniqueSupplyM let + fld_reps = typePrimRep (idType alt_bndr) + + -- Slots representing the whole sum arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args - id_slots = map primRepSlot $ typePrimRep (idType id) + -- The slots representing the field of the sum we bind. + id_slots = map primRepSlot $ fld_reps layout1 = layoutUbxSum arg_slots id_slots - in - if isMultiValBndr id - then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ]) - else assert (layout1 `lengthIs` 1) - extendRho rho0 id (UnaryVal (args !! head layout1)) -mapSumIdBinders ids sum_args _ - = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args) + -- See Note [Casting slot arguments] + -- Most of the code here is just to make sure our binders are of the + -- right type. + -- Select only the args which contain parts of the current field. + id_arg_exprs = [ args !! i | i <- layout1 ] + id_vars = [v | StgVarArg v <- id_arg_exprs] + -- Output types for the field binders based on their rep + id_tys = map primRepToType fld_reps + + typed_id_arg_input = assert (equalLength id_vars id_tys) $ + zip3 id_vars id_tys uss + + mkCastInput :: (Id,Type,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) + mkCastInput (id,tar_type,bndr_us) = + let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) (typePrimRep1 tar_type) + cst_opts = zip3 ops types $ uniqsFromSupply bndr_us + out_id = case cst_opts of + [] -> id + _ -> let (_,ty,uq) = last cst_opts + in mkCastVar uq ty + in (cst_opts,id,out_id) + + cast_inputs = map mkCastInput typed_id_arg_input + (rhs_with_casts,typed_ids) = mapAccumL cast_arg (\x->x) cast_inputs + where + cast_arg rhs_in (cast_ops,in_id,out_id) = + let rhs_out = castArgRename cast_ops (StgVarArg in_id) + in (rhs_in . rhs_out, out_id) + + typed_id_args = map StgVarArg typed_ids + + -- pprTrace "mapSumIdBinders" + -- (text "id_tys" <+> ppr id_tys $$ + -- text "id_args" <+> ppr id_arg_exprs $$ + -- text "rhs" <+> ppr rhs $$ + -- text "rhs_with_casts" <+> ppr rhs_with_casts + -- ) $ + if isMultiValBndr alt_bndr + then return (extendRho rho0 alt_bndr (MultiVal typed_id_args), rhs_with_casts rhs) + else assert (typed_id_args `lengthIs` 1) $ + return (extendRho rho0 alt_bndr (UnaryVal (head typed_id_args)), rhs_with_casts rhs) + +-- Convert the argument to the given type, and wrap the conversion +-- around the given expression. Use the given Id as a name for the +-- converted value. +castArgRename :: [(PrimOp,Type,Unique)] -> StgArg -> StgExpr -> StgExpr +castArgRename ops in_arg rhs = + case ops of + [] -> rhs + ((op,ty,uq):rest_ops) -> + let out_id' = mkCastVar uq ty -- out_name `setIdUnique` uq `setIdType` ty + sub_cast = castArgRename rest_ops (StgVarArg out_id') + in mkCast in_arg op out_id' ty $ sub_cast rhs + +-- Construct a case binder used when casting sums, of a given type and unique. +mkCastVar :: Unique -> Type -> Id +mkCastVar uq ty = mkSysLocal (fsLit "cst_sum") uq ManyTy ty + +mkCast :: StgArg -> PrimOp -> OutId -> Type -> StgExpr -> StgExpr +mkCast arg_in cast_op out_id out_ty in_rhs = + let r2 = typePrimRep1 out_ty + scrut = StgOpApp (StgPrimOp cast_op) [arg_in] out_ty + alt = GenStgAlt { alt_con = DEFAULT, alt_bndrs = [], alt_rhs = in_rhs} + alt_ty = PrimAlt r2 + in (StgCase scrut out_id alt_ty [alt]) -- | Build a unboxed sum term from arguments of an alternative. -- @@ -652,31 +869,72 @@ mapSumIdBinders ids sum_args _ -- [ 1#, rubbish ] -- mkUbxSum - :: DataCon -- Sum data con + :: HasDebugCallStack + => DataCon -- Sum data con -> [Type] -- Type arguments of the sum data con -> [OutStgArg] -- Actual arguments of the alternative. - -> [OutStgArg] -- Final tuple arguments -mkUbxSum dc ty_args args0 + -> UniqSupply + -> ([OutStgArg] -- Final tuple arguments + ,(StgExpr->StgExpr) -- We might need to cast the args first + ) +mkUbxSum dc ty_args args0 us = let (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args) - -- drop tag slot - + -- drop tag slot + field_slots = (mapMaybe (typeSlotTy . stgArgType) args0) tag = dataConTag dc + layout' = layoutUbxSum sum_slots field_slots - layout' = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0) tag_arg = StgLitArg (LitNumber LitNumInt (fromIntegral tag)) arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0) - mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg] - mkTupArgs _ [] _ - = [] - mkTupArgs arg_idx (slot : slots_left) arg_map - | Just stg_arg <- IM.lookup arg_idx arg_map - = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map - | otherwise - = ubxSumRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map + ((_idx,_idx_map,_us,wrapper),slot_args) + = assert (length arg_idxs <= length sum_slots ) $ + mapAccumL mkTupArg (0,arg_idxs,us,id) sum_slots + + mkTupArg :: (Int, IM.IntMap StgArg,UniqSupply,StgExpr->StgExpr) + -> SlotTy + -> ((Int,IM.IntMap StgArg,UniqSupply,StgExpr->StgExpr), StgArg) + mkTupArg (arg_idx, arg_map, us, wrapper) slot + | Just stg_arg <- IM.lookup arg_idx arg_map + = case castArg us slot stg_arg of + -- Slot and arg type missmatched, do a cast + Just (casted_arg,us',wrapper') -> + ( (arg_idx+1, arg_map, us', wrapper . wrapper') + , casted_arg) + -- Use the arg as-is + Nothing -> + ( (arg_idx+1, arg_map, us, wrapper) + , stg_arg) + -- Garbage slot, fill with rubbish + | otherwise + = ( (arg_idx+1, arg_map, us, wrapper) + , ubxSumRubbishArg slot) + + castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr) + castArg us slot_ty arg + -- Cast the argument to the type of the slot if required + | slotPrimRep slot_ty /= typePrimRep1 (stgArgType arg) + , out_ty <- primRepToType $ slotPrimRep slot_ty + , (ops,types) <- unzip $ getCasts (typePrimRep1 $ stgArgType arg) $ typePrimRep1 out_ty + , not . null $ ops + = let (us1,us2) = splitUniqSupply us + cast_uqs = uniqsFromSupply us1 + cast_opts = zip3 ops types cast_uqs + (_op,out_ty,out_uq) = last cast_opts + casts = castArgRename cast_opts arg :: StgExpr -> StgExpr + in Just (StgVarArg (mkCastVar out_uq out_ty),us2,casts) + -- No need for casting + | otherwise = Nothing + + tup_args = tag_arg : slot_args in - tag_arg : mkTupArgs 0 sum_slots arg_idxs + -- pprTrace "mkUbxSum" ( + -- text "ty_args (slots)" <+> ppr ty_args $$ + -- text "args0" <+> ppr args0 $$ + -- text "wrapper" <+> + -- (ppr $ wrapper $ StgLit $ LitChar '_')) + (tup_args, wrapper) -- | Return a rubbish value for the given slot type. @@ -787,7 +1045,7 @@ unariseArgBinder is_con_arg rho x = -- | MultiVal a function argument. Never returns an empty list. unariseFunArg :: UnariseEnv -> StgArg -> [StgArg] unariseFunArg rho (StgVarArg x) = - case lookupVarEnv rho x of + case lookupRho rho x of Just (MultiVal []) -> [voidArg] -- NB: do not remove void args Just (MultiVal as) -> as Just (UnaryVal arg) -> [arg] @@ -809,7 +1067,7 @@ unariseFunArgBinder = unariseArgBinder False -- | MultiVal a DataCon argument. Returns an empty list when argument is void. unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg] unariseConArg rho (StgVarArg x) = - case lookupVarEnv rho x of + case lookupRho rho x of Just (UnaryVal arg) -> [arg] Just (MultiVal as) -> as -- 'as' can be empty Nothing diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs index 7a854e4d5c..8b39fc468b 100644 --- a/compiler/GHC/Types/RepType.hs +++ b/compiler/GHC/Types/RepType.hs @@ -245,7 +245,8 @@ ubxSumRepType constrs0 in sumRep -layoutUbxSum :: SortedSlotTys -- Layout of sum. Does not include tag. +layoutUbxSum :: HasDebugCallStack + => SortedSlotTys -- Layout of sum. Does not include tag. -- We assume that they are in increasing order -> [SlotTy] -- Slot types of things we want to map to locations in the -- sum layout @@ -268,7 +269,8 @@ layoutUbxSum sum_slots0 arg_slots0 = | otherwise = findSlot arg (slot_idx + 1) slots useds findSlot _ _ [] _ - = pprPanic "findSlot" (text "Can't find slot" $$ ppr sum_slots0 $$ ppr arg_slots0) + = pprPanic "findSlot" (text "Can't find slot" $$ text "sum_slots:" <> ppr sum_slots0 + $$ text "arg_slots:" <> ppr arg_slots0 ) -------------------------------------------------------------------------------- @@ -347,18 +349,17 @@ fitsIn ty1 ty2 = Just ty1 | isWordSlot ty1 && isWordSlot ty2 = Just (max ty1 ty2) - | isFloatSlot ty1 && isFloatSlot ty2 - = Just (max ty1 ty2) | otherwise = Nothing + -- We used to share slots between Float/Double but currently we can't easily + -- covert between float/double in a way that is both work free and safe. + -- So we put them in different slots. + -- See Note [Casting slot arguments] where isWordSlot Word64Slot = True isWordSlot WordSlot = True isWordSlot _ = False - isFloatSlot DoubleSlot = True - isFloatSlot FloatSlot = True - isFloatSlot _ = False {- ********************************************************************** diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index 7d95e158f4..22a717070d 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -382,6 +382,7 @@ data SDocContext = SDC , sdocSuppressUniques :: !Bool , sdocSuppressModulePrefixes :: !Bool , sdocSuppressStgExts :: !Bool + , sdocSuppressStgReps :: !Bool , sdocErrorSpans :: !Bool , sdocStarIsType :: !Bool , sdocLinearTypes :: !Bool @@ -442,6 +443,7 @@ defaultSDocContext = SDC , sdocSuppressUniques = False , sdocSuppressModulePrefixes = False , sdocSuppressStgExts = False + , sdocSuppressStgReps = True , sdocErrorSpans = False , sdocStarIsType = False , sdocImpredicativeTypes = False diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 95217523cb..e7856c37c5 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -168,6 +168,7 @@ Library GHC.Builtin.Names GHC.Builtin.Names.TH GHC.Builtin.PrimOps + GHC.Builtin.PrimOps.Casts GHC.Builtin.PrimOps.Ids GHC.Builtin.Types GHC.Builtin.Types.Literals diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst index 8e86138c83..c059416a48 100644 --- a/docs/users_guide/debugging.rst +++ b/docs/users_guide/debugging.rst @@ -935,6 +935,16 @@ parts that you are not interested in. Suppress the printing of core size stats per binding +.. ghc-flag:: -dsuppress-stg-reps + :shortdesc: Suppress rep annotations on STG args. + :type: dynamic + + :since: 9.6.1 + + default: enabled + + Disabling this will annoate certain stg arguments with their prim rep. + .. _checking-consistency: diff --git a/testsuite/driver/testlib.py b/testsuite/driver/testlib.py index 9c9a1760a2..87c943f7d8 100644 --- a/testsuite/driver/testlib.py +++ b/testsuite/driver/testlib.py @@ -1446,7 +1446,8 @@ def compile_cmp_asm(name: TestName, ext: str, extra_hc_opts: str ) -> PassFail: - print('Compile only, extra args = ', extra_hc_opts) + if extra_hc_opts: + print('Compile only, extra args = ', extra_hc_opts) result = simple_build(name + '.' + ext, way, '-keep-s-files -O ' + extra_hc_opts, False, None, [], False, False) if badResult(result): @@ -1473,7 +1474,8 @@ def compile_grep_asm(name: TestName, is_substring: bool, extra_hc_opts: str ) -> PassFail: - print('Compile only, extra args = ', extra_hc_opts) + if extra_hc_opts: + print('Compile and grep asm, extra args = ', extra_hc_opts) result = simple_build(name + '.' + ext, way, '-keep-s-files -O ' + extra_hc_opts, False, None, [], False, False) if badResult(result): @@ -1494,7 +1496,8 @@ def compile_grep_core(name: TestName, way: WayName, extra_hc_opts: str ) -> PassFail: - print('Compile only, extra args = ', extra_hc_opts) + if extra_hc_opts: + print('Compile only, extra args = ', extra_hc_opts) result = simple_build(name + '.hs', way, '-ddump-to-file -dsuppress-all -ddump-simpl -O ' + extra_hc_opts, False, None, [], False, False) if badResult(result): diff --git a/testsuite/tests/unboxedsums/GenManyUbxSums.hs b/testsuite/tests/unboxedsums/GenManyUbxSums.hs new file mode 100755 index 0000000000..5d38f10b5b --- /dev/null +++ b/testsuite/tests/unboxedsums/GenManyUbxSums.hs @@ -0,0 +1,109 @@ +#!/usr/bin/env runghc +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnboxedSums #-} + +-- This little piece of code constructs a large set of functions +-- constructing and deconstructing unboxed tuples of various types. +module Main where + +import GHC.Exts +import System.IO +import Data.List (intersperse) +inputs = ["Int", "Word"] +sizes = ["","8","16","32","64"] + +-- ["Addr#","Int#","Int8#","Int16#","Int32#","Int64#","Word#","Word8#","Word16#","Word32#","Word64#"] +types = "Addr#" : do + r <- inputs + s <- sizes + return $ r++s++"#" + +-- We eventually build two sums, one of type (# t1 | t2 #) and one of (# t1 | t3). +-- So we build all possible combinations of three types here. +combos = do + t1 <- types + t2 <- types + t3 <- types + return (t1,t2,t3) + +mkCon ty = case ty of + "Addr#" -> "Addr" + "Int#" -> "I#" + "Int8#" -> "I8#" + "Int16#" -> "I16#" + "Int32#" -> "I32#" + "Int64#" -> "I64#" + "Word#" -> "W#" + "Word8#" -> "W8#" + "Word16#" -> "W16#" + "Word32#" -> "W32#" + "Word64#" -> "W64#" + +-- Construct a function like the one below, varying the types in the sums based on the +-- given type tuples. +-- We need to NOINLINE or the function will be constant folded away. +-- {-# NOINLINE fun0 #-} +-- fun0 :: (# Addr# | I16# #) -> (# Addr# | I# #) +-- fun0 x = case x of +-- (# x1 | #) -> (# x1 | #) :: (# Addr# | I# #) +mkFun n (t1,t2,t3) = + "{-# NOINLINE fun" ++ show n ++ " #-}\n" ++ + "fun" ++ show n ++ " :: (# " ++ t1 ++" | " ++ t2 ++ " #) -> (# " ++ t1 ++" | " ++ t3 ++ " #)\n" ++ + "fun" ++ show n ++ " x = case x of\n" ++ + " (# x1 | #) -> (# x1 | #) :: (# " ++ t1 ++ " | " ++ t3 ++ " #)" + +-- Generate functions for all the tuple combinations. +mkFuns _ [] = "" +mkFuns n (combo:combos) = + mkFun n combo ++ "\n" ++ mkFuns (n+1) combos + +-- generate a test that will put a value into a unboxed sum and then retrieve it later on. +-- It generates code like the one below: +-- test0 = +-- let in_val = maxBound +-- out_val = case in_val of I# x -> case fun0 (# x | #) of (# y | #) -> I# y +-- in in_val == out_val +mkTest n (t1,_,_)= + let test_name = "test" ++ show n + test_code = test_name ++ " =\n" ++ + " let in_val = (maxBound)\n" ++ + " out_val = case in_val of " ++ mkCon t1 ++ " x -> case fun" ++ show n ++ " (# x | #) of (# y | #) -> " ++ mkCon t1 ++ " y\n" ++ + " in in_val == out_val" + in (test_code,test_name) + +-- Test all the tuples +mkTests n combos = + let (defs, names) = unzip $ zipWith mkTest [0..] combos + assert_results = "\nassert_results = and [" ++ (concat $ intersperse "," names) ++ "]\n" :: String + in unlines defs ++ assert_results + +header = + "{-# LANGUAGE MagicHash #-}\n\ + \{-# LANGUAGE UnboxedTuples #-}\n\ + \{-# LANGUAGE UnboxedSums #-}\n\ + \module Main where\n\ + \import GHC.Exts\n\ + \import GHC.Word\n\ + \import GHC.Int\n\ + \import ManyUbxSums_Addr\n" +main = do + out <- openFile "ManyUbxSums.hs" WriteMode + hPutStrLn out header + + let combo:_ = combos + -- putStrLn $ mkFun 1 combo + hPutStrLn out $ mkFuns 0 combos + + hPutStrLn out $ mkTests 0 combos + hPutStrLn out "main = do" + + hPutStrLn out $ " putStrLn . show $ assert_results" + + -- The snippet below would print all individual test results. + -- But for CI really just check if all results match the input + -- let runTest n = + -- hPutStrLn out $ " putStrLn $ \"test" ++ show n ++ " \" ++ (show test" ++ show n ++ ")" + -- mapM runTest [0 .. length combos - 1] + + hClose out diff --git a/testsuite/tests/unboxedsums/ManyUbxSums.stdout b/testsuite/tests/unboxedsums/ManyUbxSums.stdout new file mode 100644 index 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/unboxedsums/ManyUbxSums.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/unboxedsums/ManyUbxSums_Addr.hs b/testsuite/tests/unboxedsums/ManyUbxSums_Addr.hs new file mode 100644 index 0000000000..6e718168e8 --- /dev/null +++ b/testsuite/tests/unboxedsums/ManyUbxSums_Addr.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnboxedSums #-} + +{-# OPTIONS_GHC -Wno-missing-methods #-} + +module ManyUbxSums_Addr where + +import GHC.Exts +-- import GHC.Word +-- import GHC.Int +--import GHC.Utils.Misc + +data Addr = Addr Addr# + +instance Eq Addr where + (Addr x) == (Addr y) = case (eqAddr# x y) of + 1# -> True + 0# -> False + +instance Num Addr where + fromInteger x = case fromIntegral x of I# x1 -> Addr (int2Addr# x1) + +instance Bounded Addr where + maxBound = fromIntegral (maxBound :: Word) + minBound = 0
\ No newline at end of file diff --git a/testsuite/tests/unboxedsums/T22208.hs b/testsuite/tests/unboxedsums/T22208.hs new file mode 100644 index 0000000000..cc85eafcef --- /dev/null +++ b/testsuite/tests/unboxedsums/T22208.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} +module M where + +import GHC.Base + +-- Reproducer from #22208 +foo :: (# Float# | Double# #) -> (# Float# | Float #) +foo (# x | #) = (# x | #) +bar :: (# Word# | Int64# #) -> (# Double# | Word# #) +bar (# y | #) = let x = y in (# | x #) +baz :: (# Word# | Word64# #) -> (# Word# | (##) #) +baz (# x | #) = (# x | #) + +foo1 :: (# Float# | Double# #) -> (# Float# | Float #) +foo1 (# x | #) = (# x | #) +bar1 :: (# Word# | Int64# #) -> (# Double# | Word# #) +bar1 (# y | #) = let x = y in (# | x #) +baz1 :: (# Word# | Word64# #) -> (# Word# | (##) #) +baz1 (# x | #) = (# x | #) + +-- i8 value from w64 slot +baz2 :: (# Int8# | Word64# #) -> (# Int8# | (##) #) +baz2 (# x | #) = (# x | #) + +-- w8 value from w64 slot +baz3 :: (# Word8# | Word64# #) -> (# Word8# | (##) #) +baz3 (# x | #) = (# x | #) + +-- w8 from w slot +baz4 :: (# Word8# | Word# #) -> (# Word8# | (##) #) +baz4 (# x | #) = (# x | #) + +-- w from w slot +baz5 :: (# Word8# | Word# #) -> (# Word# | (##) #) +baz5 (# | x #) = (# x | #) + +-- addr from w slot +baz6 :: (# Addr# | Word# #) -> (# Addr# | (##) #) +baz6 (# x | #) = (# x | #)
\ No newline at end of file diff --git a/testsuite/tests/unboxedsums/all.T b/testsuite/tests/unboxedsums/all.T index ba25543d54..2c28e160e9 100644 --- a/testsuite/tests/unboxedsums/all.T +++ b/testsuite/tests/unboxedsums/all.T @@ -35,3 +35,13 @@ test('T20858b', [extra_files(['T20858.hs']) ,extra_hc_opts("-fprint-explicit-runtime-reps -fprint-explicit-kinds")] , ghci_script, ['T20858b.script']) test('T20859', normal, compile, ['']) + +test('T22208', normal, compile, ['-dstg-lint -dcmm-lint']) +test('ManyUbxSums', + [ pre_cmd('{compiler} --run ./GenManyUbxSums.hs'), + extra_files(['GenManyUbxSums.hs', 'ManyUbxSums_Addr.hs']), + ], + multi_compile_and_run, + ['ManyUbxSums', + [('ManyUbxSums_Addr.hs','')] + , '-v0 -dstg-lint -dcmm-lint']) |