[Git][ghc/ghc][wip/fix-ubx-cast] Properly convert values before/after storing them in unboxed sums.
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Tue Sep 27 22:55:38 UTC 2022
Andreas Klebinger pushed to branch wip/fix-ubx-cast at Glasgow Haskell Compiler / GHC
Commits:
b1eefe1e by Andreas Klebinger at 2022-09-28T00:54:13+02:00
Properly convert values before/after storing them in unboxed sums.
See Note [Casting slot arguments] for the details.
- - - - -
17 changed files:
- + compiler/GHC/Builtin/PrimOps/Casts.hs
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Stg/Syntax.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/Types/RepType.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/ghc.cabal.in
- docs/users_guide/debugging.rst
- testsuite/driver/testlib.py
- + testsuite/tests/unboxedsums/GenManyUbxSums.hs
- + testsuite/tests/unboxedsums/ManyUbxSums.stdout
- + testsuite/tests/unboxedsums/ManyUbxSums_Addr.hs
- + testsuite/tests/unboxedsums/T22208.hs
- testsuite/tests/unboxedsums/all.T
Changes:
=====================================
compiler/GHC/Builtin/PrimOps/Casts.hs
=====================================
@@ -0,0 +1,201 @@
+{-
+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.Types
+
+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 that 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`
+in order to get to a variable of rep `to_rep`.
+
+E.g. we call `getCasts from_rep to_rep` and get back [(op1#,ty1),(op2#,ty2)].
+We can use this list of primOps 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>
+-}
+
+-- | `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 = []
+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,intTy)]
+-- Cast from Int#
+sizedIntToSizedInt IntRep r = [(intFromMachineInt r,primRepToType r)]
+-- Sized to differently sized must go over machine word.
+sizedIntToSizedInt r1 r2 = (intToMachineInt r1,intTy) : [(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
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -1399,7 +1399,10 @@ instance OutputableP Platform CLabel where
pdoc !platform lbl = getPprStyle $ \pp_sty ->
case pp_sty of
PprDump{} -> pprCLabel platform CStyle lbl
- _ -> pprPanic "Labels in code should be printed with pprCLabel" (pprCLabel platform CStyle lbl)
+ -- Workaround for #22218
+ _ -> (pprCLabel platform CStyle lbl)
+ -- _ -> pprPanic "Labels in code should be printed with pprCLabel" (pprCLabel platform CStyle lbl)
+
pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc
pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -129,6 +129,7 @@ module GHC.Core.TyCon(
primRepIsFloat,
primRepsCompatible,
primRepCompatible,
+ primRepIsWord, primRepIsInt,
) where
@@ -1785,6 +1786,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
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -422,6 +422,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
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2393,6 +2393,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)
@@ -3344,6 +3345,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,
@@ -3796,7 +3798,8 @@ defaultFlags settings
Opt_VersionMacros,
Opt_RPath,
Opt_DumpWithWays,
- Opt_CompactUnwind
+ Opt_CompactUnwind,
+ Opt_SuppressStgReps
]
++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]
@@ -5020,6 +5023,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
, sdocLinearTypes = xopt LangExt.LinearTypes dflags
=====================================
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
=====================================
compiler/GHC/Stg/Unarise.hs
=====================================
@@ -186,6 +186,39 @@ 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 Float# and Double# from a unboxed sum.
+
+ foo :: (# Float# | Double# #) -> FD
+ foo x = case x of
+ (# x1 | #) -> F x1
+ (# | x2 #) -> D x2
+
+Naturally we would expect x1 to have a PrimRep of FloatRep and x2 of DoubleRep.
+However we used to generate this (bogus) code after Unarise giving rise to #22208:
+
+ M.foo :: (# GHC.Prim.Float# | GHC.Prim.Double# #) -> 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 Float# and Double# depending on the branch.
+This usually works out since we put floats/doubles in the same sort of register.
+However this caused issues down the road where we would assign between variables
+of different reps causing lint errors or in the case of #22208 even compiler panics.
+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 (# Float# | Double# #) if we want to store a float
+we convert it to a double on construction of the tuple value, and convert it back
+to a float once when want to use the field.
+Conversion for values coming out of a strict field happen in mapSumIdBinders. While
+conversion during the construction of sums happen inside mkUbxSum.
+
Note [UnariseEnv]
~~~~~~~~~~~~~~~~~~
At any variable occurrence 'v',
@@ -258,8 +291,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, appendFS)
import GHC.Types.Id
import GHC.Types.Literal
import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID)
@@ -281,6 +314,10 @@ 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.Types.Name
--------------------------------------------------------------------------------
@@ -306,8 +343,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 +359,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 +407,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 +420,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 +431,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 unariseUbxSumTupleArgs 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 +449,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 unariseUbxSumTupleArgs 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 +486,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
+unariseUbxSumTupleArgs :: 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
+unariseUbxSumTupleArgs 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 "unariseUbxSumTupleArgs: Constructor not a unboxed sum or tuple"
-- Doesn't return void args.
unariseRubbish_maybe :: Literal -> Maybe [OutStgArg]
@@ -473,15 +527,15 @@ 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')
| isUnboxedTupleBndr bndr
- = mapTupleIdBinders bndrs args rho1
+ = (mapTupleIdBinders bndrs args rho1, rhs)
| otherwise
= assert (isUnboxedSumBndr bndr) $
- if null bndrs then rho1
- else mapSumIdBinders bndrs args rho1
+ if null bndrs then (rho1, rhs)
+ else mapSumIdBinders bndrs args rhs rho1
- unariseExpr rho2 rhs
+ unariseExpr rho2 rhs'
elimCase rho args bndr (MultiValAlt _) alts
| isUnboxedSumBndr bndr
@@ -576,12 +630,12 @@ unariseSumAlt rho args 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 let (rho',e') = mapSumIdBinders bs args e rho
+ 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)
--------------------------------------------------------------------------------
@@ -623,24 +677,80 @@ mapSumIdBinders
-- only have one binder, so this list should be a singleton)
-> [OutStgArg] -- Arguments that form the sum (NOT including the tag).
-- Can't have void args.
+ -> InStgExpr
-> UnariseEnv
- -> UnariseEnv
+ -> (UnariseEnv, OutStgExpr)
-mapSumIdBinders [id] args rho0
+mapSumIdBinders [id] args rhs rho0
= assert (not (any (isZeroBitTy . stgArgType) args)) $
let
+ -- Slots representing the whole sum
arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args
+ -- The slots representing the field of the sum we bind.
id_slots = map primRepSlot $ typePrimRep (idType id)
layout1 = layoutUbxSum arg_slots id_slots
+
+ -- Arg id's which make up the field.
+ id_arg_exprs = [ args !! i | i <- layout1 ]
+ id_vars = [v | StgVarArg v <- id_arg_exprs]
+
+ update_id_type v ty
+ | (typePrimRep $ idType v) == (typePrimRep ty) = v
+ | otherwise = setIdType v ty
+
+ -- rep-based types for the field binders
+ id_tys = map primRepToType $ typePrimRep (idType id)
+ -- Arg id's with the typ set to one matching the fields rep.
+ typed_id_args = zipWithEqual "typed_id_args" (\var t -> StgVarArg (update_id_type var t)) id_vars id_tys
+ -- See Note [Casting slot arguments]
+ -- We can shadow the original argument id here since the binder for the field will only be used
+ -- at one specific type in this branch.
+ (rhs_with_casts) = foldr castArgShadow rhs $ zip id_vars id_tys
in
+ -- 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 id
- then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])
- else assert (layout1 `lengthIs` 1)
- extendRho rho0 id (UnaryVal (args !! head layout1))
+ then (extendRho rho0 id (MultiVal typed_id_args), rhs_with_casts)
+ else assert (typed_id_args `lengthIs` 1)
+ (extendRho rho0 id (UnaryVal (head typed_id_args)), rhs_with_casts)
-mapSumIdBinders ids sum_args _
+mapSumIdBinders ids sum_args _rhs _
= pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args)
+-- Convert the argument to the given type, and wrap the conversion
+-- around the given expression.
+castArgShadow :: (Id,Type) -> StgExpr -> StgExpr
+castArgShadow (arg, target_ty) (in_rhs) =
+ let ops = getCasts (typePrimRep1 $ idType arg) (typePrimRep1 target_ty)
+ in foldr (mkCast (StgVarArg arg) arg) (in_rhs) ops
+
+-- 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 :: StgArg -> Id -> StgExpr -> StgExpr
+castArgRename in_arg out_id in_rhs =
+ case ops of
+ [] -> in_rhs
+ op1:rest_ops ->
+ mkCast in_arg out_id op1 $
+ foldr (mkCast (StgVarArg out_id) out_id) in_rhs rest_ops
+ -- pprTrace "castArgRename" (ppr (in_arg,out_id)) $
+ where ops = getCasts (typePrimRep1 $ stgArgType in_arg) $ typePrimRep1 (idType out_id)
+ -- in foldr (mkCast in_arg out_id) (in_rhs) ops
+
+-- Variable to cast, (type to cast to, result_ty), rhs
+mkCast :: StgArg -> OutId -> (PrimOp,Type) -> (StgExpr) -> (StgExpr)
+mkCast arg_in out_id (cast_op,ty2) (in_rhs) =
+ let r2 = typePrimRep1 ty2
+ scrut = StgOpApp (StgPrimOp cast_op) [arg_in] ty2
+ alt = GenStgAlt { alt_con = DEFAULT, alt_bndrs = [], alt_rhs = in_rhs}
+ alt_ty = PrimAlt r2
+ in (StgCase scrut (setIdType out_id ty2) alt_ty [alt])
+
-- | Build a unboxed sum term from arguments of an alternative.
--
-- Example, for (# x | #) :: (# (# #) | Int #) we call
@@ -655,8 +765,11 @@ mkUbxSum
:: 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
@@ -667,16 +780,51 @@ mkUbxSum dc ty_args 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
+ Just (casted_arg,us',wrapper') ->
+ ( (arg_idx+1, arg_map, us', wrapper')
+ , casted_arg)
+ Nothing ->
+ ( (arg_idx+1, arg_map, us, wrapper)
+ , stg_arg)
+ | 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)
+ = let (u1,us') = takeUniqFromSupply us
+ -- cast_ops = getCasts (typePrimRep1 $ idType arg_id) (slotPrimRep slot_ty)
+ out_ty = primRepToType $ slotPrimRep slot_ty
+ out_name_fs
+ | (StgVarArg v_arg) <- arg
+ = getOccFS v_arg `appendFS` fsLit "_cst"
+ | otherwise = fsLit "cst_lit"
+ out_id = mkSysLocal out_name_fs u1 Many out_ty :: Id
+ casts = castArgRename arg out_id :: StgExpr -> StgExpr
+ in Just (arg,us',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 +935,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 +957,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
=====================================
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 )
--------------------------------------------------------------------------------
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -387,6 +387,7 @@ data SDocContext = SDC
, sdocSuppressUniques :: !Bool
, sdocSuppressModulePrefixes :: !Bool
, sdocSuppressStgExts :: !Bool
+ , sdocSuppressStgReps :: !Bool
, sdocErrorSpans :: !Bool
, sdocStarIsType :: !Bool
, sdocLinearTypes :: !Bool
@@ -447,6 +448,7 @@ defaultSDocContext = SDC
, sdocSuppressUniques = False
, sdocSuppressModulePrefixes = False
, sdocSuppressStgExts = False
+ , sdocSuppressStgReps = True
, sdocErrorSpans = False
, sdocStarIsType = False
, sdocLinearTypes = False
=====================================
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
=====================================
docs/users_guide/debugging.rst
=====================================
@@ -946,6 +946,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:
=====================================
testsuite/driver/testlib.py
=====================================
@@ -1447,7 +1447,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):
@@ -1474,7 +1475,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):
@@ -1495,7 +1497,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):
=====================================
testsuite/tests/unboxedsums/GenManyUbxSums.hs
=====================================
@@ -0,0 +1,102 @@
+#!/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
+
+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 (# t1 | t2 #) and one (# t1 | t3).
+-- So build all the combinations 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:
+-- {-# NOINLINE fun0 #-}
+-- fun0 :: (# Addr# | Addr# #) -> (# Addr# | Addr# #)
+-- fun0 x = case x of
+-- (# x1 | #) -> (# x1 | #) :: (# Addr# | Addr# #)
+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 = 0
+-- out_val = case in_val of I# x -> case fun0 (# x | #) of (# y | #) -> I# y
+-- in in_val == out_val
+mkTest n (t1,_,_)=
+ "test" ++ show n ++ " =\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"
+
+-- Test all the tuples
+mkTests n [] = ""
+mkTests n (combo:combos) =
+ mkTest n combo ++ "\n" ++ mkTests (n+1) combos
+
+
+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"
+
+ -- Actually invoke all the tests
+ let runTest n =
+ hPutStrLn out $ " putStrLn $ \"test" ++ show n ++ " \" ++ (show test" ++ show n ++ ")"
+ mapM runTest [0 .. length combos - 1]
+
+ hClose out
=====================================
testsuite/tests/unboxedsums/ManyUbxSums.stdout
=====================================
@@ -0,0 +1,1331 @@
+test0 True
+test1 True
+test2 True
+test3 True
+test4 True
+test5 True
+test6 True
+test7 True
+test8 True
+test9 True
+test10 True
+test11 True
+test12 True
+test13 True
+test14 True
+test15 True
+test16 True
+test17 True
+test18 True
+test19 True
+test20 True
+test21 True
+test22 True
+test23 True
+test24 True
+test25 True
+test26 True
+test27 True
+test28 True
+test29 True
+test30 True
+test31 True
+test32 True
+test33 True
+test34 True
+test35 True
+test36 True
+test37 True
+test38 True
+test39 True
+test40 True
+test41 True
+test42 True
+test43 True
+test44 True
+test45 True
+test46 True
+test47 True
+test48 True
+test49 True
+test50 True
+test51 True
+test52 True
+test53 True
+test54 True
+test55 True
+test56 True
+test57 True
+test58 True
+test59 True
+test60 True
+test61 True
+test62 True
+test63 True
+test64 True
+test65 True
+test66 True
+test67 True
+test68 True
+test69 True
+test70 True
+test71 True
+test72 True
+test73 True
+test74 True
+test75 True
+test76 True
+test77 True
+test78 True
+test79 True
+test80 True
+test81 True
+test82 True
+test83 True
+test84 True
+test85 True
+test86 True
+test87 True
+test88 True
+test89 True
+test90 True
+test91 True
+test92 True
+test93 True
+test94 True
+test95 True
+test96 True
+test97 True
+test98 True
+test99 True
+test100 True
+test101 True
+test102 True
+test103 True
+test104 True
+test105 True
+test106 True
+test107 True
+test108 True
+test109 True
+test110 True
+test111 True
+test112 True
+test113 True
+test114 True
+test115 True
+test116 True
+test117 True
+test118 True
+test119 True
+test120 True
+test121 True
+test122 True
+test123 True
+test124 True
+test125 True
+test126 True
+test127 True
+test128 True
+test129 True
+test130 True
+test131 True
+test132 True
+test133 True
+test134 True
+test135 True
+test136 True
+test137 True
+test138 True
+test139 True
+test140 True
+test141 True
+test142 True
+test143 True
+test144 True
+test145 True
+test146 True
+test147 True
+test148 True
+test149 True
+test150 True
+test151 True
+test152 True
+test153 True
+test154 True
+test155 True
+test156 True
+test157 True
+test158 True
+test159 True
+test160 True
+test161 True
+test162 True
+test163 True
+test164 True
+test165 True
+test166 True
+test167 True
+test168 True
+test169 True
+test170 True
+test171 True
+test172 True
+test173 True
+test174 True
+test175 True
+test176 True
+test177 True
+test178 True
+test179 True
+test180 True
+test181 True
+test182 True
+test183 True
+test184 True
+test185 True
+test186 True
+test187 True
+test188 True
+test189 True
+test190 True
+test191 True
+test192 True
+test193 True
+test194 True
+test195 True
+test196 True
+test197 True
+test198 True
+test199 True
+test200 True
+test201 True
+test202 True
+test203 True
+test204 True
+test205 True
+test206 True
+test207 True
+test208 True
+test209 True
+test210 True
+test211 True
+test212 True
+test213 True
+test214 True
+test215 True
+test216 True
+test217 True
+test218 True
+test219 True
+test220 True
+test221 True
+test222 True
+test223 True
+test224 True
+test225 True
+test226 True
+test227 True
+test228 True
+test229 True
+test230 True
+test231 True
+test232 True
+test233 True
+test234 True
+test235 True
+test236 True
+test237 True
+test238 True
+test239 True
+test240 True
+test241 True
+test242 True
+test243 True
+test244 True
+test245 True
+test246 True
+test247 True
+test248 True
+test249 True
+test250 True
+test251 True
+test252 True
+test253 True
+test254 True
+test255 True
+test256 True
+test257 True
+test258 True
+test259 True
+test260 True
+test261 True
+test262 True
+test263 True
+test264 True
+test265 True
+test266 True
+test267 True
+test268 True
+test269 True
+test270 True
+test271 True
+test272 True
+test273 True
+test274 True
+test275 True
+test276 True
+test277 True
+test278 True
+test279 True
+test280 True
+test281 True
+test282 True
+test283 True
+test284 True
+test285 True
+test286 True
+test287 True
+test288 True
+test289 True
+test290 True
+test291 True
+test292 True
+test293 True
+test294 True
+test295 True
+test296 True
+test297 True
+test298 True
+test299 True
+test300 True
+test301 True
+test302 True
+test303 True
+test304 True
+test305 True
+test306 True
+test307 True
+test308 True
+test309 True
+test310 True
+test311 True
+test312 True
+test313 True
+test314 True
+test315 True
+test316 True
+test317 True
+test318 True
+test319 True
+test320 True
+test321 True
+test322 True
+test323 True
+test324 True
+test325 True
+test326 True
+test327 True
+test328 True
+test329 True
+test330 True
+test331 True
+test332 True
+test333 True
+test334 True
+test335 True
+test336 True
+test337 True
+test338 True
+test339 True
+test340 True
+test341 True
+test342 True
+test343 True
+test344 True
+test345 True
+test346 True
+test347 True
+test348 True
+test349 True
+test350 True
+test351 True
+test352 True
+test353 True
+test354 True
+test355 True
+test356 True
+test357 True
+test358 True
+test359 True
+test360 True
+test361 True
+test362 True
+test363 True
+test364 True
+test365 True
+test366 True
+test367 True
+test368 True
+test369 True
+test370 True
+test371 True
+test372 True
+test373 True
+test374 True
+test375 True
+test376 True
+test377 True
+test378 True
+test379 True
+test380 True
+test381 True
+test382 True
+test383 True
+test384 True
+test385 True
+test386 True
+test387 True
+test388 True
+test389 True
+test390 True
+test391 True
+test392 True
+test393 True
+test394 True
+test395 True
+test396 True
+test397 True
+test398 True
+test399 True
+test400 True
+test401 True
+test402 True
+test403 True
+test404 True
+test405 True
+test406 True
+test407 True
+test408 True
+test409 True
+test410 True
+test411 True
+test412 True
+test413 True
+test414 True
+test415 True
+test416 True
+test417 True
+test418 True
+test419 True
+test420 True
+test421 True
+test422 True
+test423 True
+test424 True
+test425 True
+test426 True
+test427 True
+test428 True
+test429 True
+test430 True
+test431 True
+test432 True
+test433 True
+test434 True
+test435 True
+test436 True
+test437 True
+test438 True
+test439 True
+test440 True
+test441 True
+test442 True
+test443 True
+test444 True
+test445 True
+test446 True
+test447 True
+test448 True
+test449 True
+test450 True
+test451 True
+test452 True
+test453 True
+test454 True
+test455 True
+test456 True
+test457 True
+test458 True
+test459 True
+test460 True
+test461 True
+test462 True
+test463 True
+test464 True
+test465 True
+test466 True
+test467 True
+test468 True
+test469 True
+test470 True
+test471 True
+test472 True
+test473 True
+test474 True
+test475 True
+test476 True
+test477 True
+test478 True
+test479 True
+test480 True
+test481 True
+test482 True
+test483 True
+test484 True
+test485 True
+test486 True
+test487 True
+test488 True
+test489 True
+test490 True
+test491 True
+test492 True
+test493 True
+test494 True
+test495 True
+test496 True
+test497 True
+test498 True
+test499 True
+test500 True
+test501 True
+test502 True
+test503 True
+test504 True
+test505 True
+test506 True
+test507 True
+test508 True
+test509 True
+test510 True
+test511 True
+test512 True
+test513 True
+test514 True
+test515 True
+test516 True
+test517 True
+test518 True
+test519 True
+test520 True
+test521 True
+test522 True
+test523 True
+test524 True
+test525 True
+test526 True
+test527 True
+test528 True
+test529 True
+test530 True
+test531 True
+test532 True
+test533 True
+test534 True
+test535 True
+test536 True
+test537 True
+test538 True
+test539 True
+test540 True
+test541 True
+test542 True
+test543 True
+test544 True
+test545 True
+test546 True
+test547 True
+test548 True
+test549 True
+test550 True
+test551 True
+test552 True
+test553 True
+test554 True
+test555 True
+test556 True
+test557 True
+test558 True
+test559 True
+test560 True
+test561 True
+test562 True
+test563 True
+test564 True
+test565 True
+test566 True
+test567 True
+test568 True
+test569 True
+test570 True
+test571 True
+test572 True
+test573 True
+test574 True
+test575 True
+test576 True
+test577 True
+test578 True
+test579 True
+test580 True
+test581 True
+test582 True
+test583 True
+test584 True
+test585 True
+test586 True
+test587 True
+test588 True
+test589 True
+test590 True
+test591 True
+test592 True
+test593 True
+test594 True
+test595 True
+test596 True
+test597 True
+test598 True
+test599 True
+test600 True
+test601 True
+test602 True
+test603 True
+test604 True
+test605 True
+test606 True
+test607 True
+test608 True
+test609 True
+test610 True
+test611 True
+test612 True
+test613 True
+test614 True
+test615 True
+test616 True
+test617 True
+test618 True
+test619 True
+test620 True
+test621 True
+test622 True
+test623 True
+test624 True
+test625 True
+test626 True
+test627 True
+test628 True
+test629 True
+test630 True
+test631 True
+test632 True
+test633 True
+test634 True
+test635 True
+test636 True
+test637 True
+test638 True
+test639 True
+test640 True
+test641 True
+test642 True
+test643 True
+test644 True
+test645 True
+test646 True
+test647 True
+test648 True
+test649 True
+test650 True
+test651 True
+test652 True
+test653 True
+test654 True
+test655 True
+test656 True
+test657 True
+test658 True
+test659 True
+test660 True
+test661 True
+test662 True
+test663 True
+test664 True
+test665 True
+test666 True
+test667 True
+test668 True
+test669 True
+test670 True
+test671 True
+test672 True
+test673 True
+test674 True
+test675 True
+test676 True
+test677 True
+test678 True
+test679 True
+test680 True
+test681 True
+test682 True
+test683 True
+test684 True
+test685 True
+test686 True
+test687 True
+test688 True
+test689 True
+test690 True
+test691 True
+test692 True
+test693 True
+test694 True
+test695 True
+test696 True
+test697 True
+test698 True
+test699 True
+test700 True
+test701 True
+test702 True
+test703 True
+test704 True
+test705 True
+test706 True
+test707 True
+test708 True
+test709 True
+test710 True
+test711 True
+test712 True
+test713 True
+test714 True
+test715 True
+test716 True
+test717 True
+test718 True
+test719 True
+test720 True
+test721 True
+test722 True
+test723 True
+test724 True
+test725 True
+test726 True
+test727 True
+test728 True
+test729 True
+test730 True
+test731 True
+test732 True
+test733 True
+test734 True
+test735 True
+test736 True
+test737 True
+test738 True
+test739 True
+test740 True
+test741 True
+test742 True
+test743 True
+test744 True
+test745 True
+test746 True
+test747 True
+test748 True
+test749 True
+test750 True
+test751 True
+test752 True
+test753 True
+test754 True
+test755 True
+test756 True
+test757 True
+test758 True
+test759 True
+test760 True
+test761 True
+test762 True
+test763 True
+test764 True
+test765 True
+test766 True
+test767 True
+test768 True
+test769 True
+test770 True
+test771 True
+test772 True
+test773 True
+test774 True
+test775 True
+test776 True
+test777 True
+test778 True
+test779 True
+test780 True
+test781 True
+test782 True
+test783 True
+test784 True
+test785 True
+test786 True
+test787 True
+test788 True
+test789 True
+test790 True
+test791 True
+test792 True
+test793 True
+test794 True
+test795 True
+test796 True
+test797 True
+test798 True
+test799 True
+test800 True
+test801 True
+test802 True
+test803 True
+test804 True
+test805 True
+test806 True
+test807 True
+test808 True
+test809 True
+test810 True
+test811 True
+test812 True
+test813 True
+test814 True
+test815 True
+test816 True
+test817 True
+test818 True
+test819 True
+test820 True
+test821 True
+test822 True
+test823 True
+test824 True
+test825 True
+test826 True
+test827 True
+test828 True
+test829 True
+test830 True
+test831 True
+test832 True
+test833 True
+test834 True
+test835 True
+test836 True
+test837 True
+test838 True
+test839 True
+test840 True
+test841 True
+test842 True
+test843 True
+test844 True
+test845 True
+test846 True
+test847 True
+test848 True
+test849 True
+test850 True
+test851 True
+test852 True
+test853 True
+test854 True
+test855 True
+test856 True
+test857 True
+test858 True
+test859 True
+test860 True
+test861 True
+test862 True
+test863 True
+test864 True
+test865 True
+test866 True
+test867 True
+test868 True
+test869 True
+test870 True
+test871 True
+test872 True
+test873 True
+test874 True
+test875 True
+test876 True
+test877 True
+test878 True
+test879 True
+test880 True
+test881 True
+test882 True
+test883 True
+test884 True
+test885 True
+test886 True
+test887 True
+test888 True
+test889 True
+test890 True
+test891 True
+test892 True
+test893 True
+test894 True
+test895 True
+test896 True
+test897 True
+test898 True
+test899 True
+test900 True
+test901 True
+test902 True
+test903 True
+test904 True
+test905 True
+test906 True
+test907 True
+test908 True
+test909 True
+test910 True
+test911 True
+test912 True
+test913 True
+test914 True
+test915 True
+test916 True
+test917 True
+test918 True
+test919 True
+test920 True
+test921 True
+test922 True
+test923 True
+test924 True
+test925 True
+test926 True
+test927 True
+test928 True
+test929 True
+test930 True
+test931 True
+test932 True
+test933 True
+test934 True
+test935 True
+test936 True
+test937 True
+test938 True
+test939 True
+test940 True
+test941 True
+test942 True
+test943 True
+test944 True
+test945 True
+test946 True
+test947 True
+test948 True
+test949 True
+test950 True
+test951 True
+test952 True
+test953 True
+test954 True
+test955 True
+test956 True
+test957 True
+test958 True
+test959 True
+test960 True
+test961 True
+test962 True
+test963 True
+test964 True
+test965 True
+test966 True
+test967 True
+test968 True
+test969 True
+test970 True
+test971 True
+test972 True
+test973 True
+test974 True
+test975 True
+test976 True
+test977 True
+test978 True
+test979 True
+test980 True
+test981 True
+test982 True
+test983 True
+test984 True
+test985 True
+test986 True
+test987 True
+test988 True
+test989 True
+test990 True
+test991 True
+test992 True
+test993 True
+test994 True
+test995 True
+test996 True
+test997 True
+test998 True
+test999 True
+test1000 True
+test1001 True
+test1002 True
+test1003 True
+test1004 True
+test1005 True
+test1006 True
+test1007 True
+test1008 True
+test1009 True
+test1010 True
+test1011 True
+test1012 True
+test1013 True
+test1014 True
+test1015 True
+test1016 True
+test1017 True
+test1018 True
+test1019 True
+test1020 True
+test1021 True
+test1022 True
+test1023 True
+test1024 True
+test1025 True
+test1026 True
+test1027 True
+test1028 True
+test1029 True
+test1030 True
+test1031 True
+test1032 True
+test1033 True
+test1034 True
+test1035 True
+test1036 True
+test1037 True
+test1038 True
+test1039 True
+test1040 True
+test1041 True
+test1042 True
+test1043 True
+test1044 True
+test1045 True
+test1046 True
+test1047 True
+test1048 True
+test1049 True
+test1050 True
+test1051 True
+test1052 True
+test1053 True
+test1054 True
+test1055 True
+test1056 True
+test1057 True
+test1058 True
+test1059 True
+test1060 True
+test1061 True
+test1062 True
+test1063 True
+test1064 True
+test1065 True
+test1066 True
+test1067 True
+test1068 True
+test1069 True
+test1070 True
+test1071 True
+test1072 True
+test1073 True
+test1074 True
+test1075 True
+test1076 True
+test1077 True
+test1078 True
+test1079 True
+test1080 True
+test1081 True
+test1082 True
+test1083 True
+test1084 True
+test1085 True
+test1086 True
+test1087 True
+test1088 True
+test1089 True
+test1090 True
+test1091 True
+test1092 True
+test1093 True
+test1094 True
+test1095 True
+test1096 True
+test1097 True
+test1098 True
+test1099 True
+test1100 True
+test1101 True
+test1102 True
+test1103 True
+test1104 True
+test1105 True
+test1106 True
+test1107 True
+test1108 True
+test1109 True
+test1110 True
+test1111 True
+test1112 True
+test1113 True
+test1114 True
+test1115 True
+test1116 True
+test1117 True
+test1118 True
+test1119 True
+test1120 True
+test1121 True
+test1122 True
+test1123 True
+test1124 True
+test1125 True
+test1126 True
+test1127 True
+test1128 True
+test1129 True
+test1130 True
+test1131 True
+test1132 True
+test1133 True
+test1134 True
+test1135 True
+test1136 True
+test1137 True
+test1138 True
+test1139 True
+test1140 True
+test1141 True
+test1142 True
+test1143 True
+test1144 True
+test1145 True
+test1146 True
+test1147 True
+test1148 True
+test1149 True
+test1150 True
+test1151 True
+test1152 True
+test1153 True
+test1154 True
+test1155 True
+test1156 True
+test1157 True
+test1158 True
+test1159 True
+test1160 True
+test1161 True
+test1162 True
+test1163 True
+test1164 True
+test1165 True
+test1166 True
+test1167 True
+test1168 True
+test1169 True
+test1170 True
+test1171 True
+test1172 True
+test1173 True
+test1174 True
+test1175 True
+test1176 True
+test1177 True
+test1178 True
+test1179 True
+test1180 True
+test1181 True
+test1182 True
+test1183 True
+test1184 True
+test1185 True
+test1186 True
+test1187 True
+test1188 True
+test1189 True
+test1190 True
+test1191 True
+test1192 True
+test1193 True
+test1194 True
+test1195 True
+test1196 True
+test1197 True
+test1198 True
+test1199 True
+test1200 True
+test1201 True
+test1202 True
+test1203 True
+test1204 True
+test1205 True
+test1206 True
+test1207 True
+test1208 True
+test1209 True
+test1210 True
+test1211 True
+test1212 True
+test1213 True
+test1214 True
+test1215 True
+test1216 True
+test1217 True
+test1218 True
+test1219 True
+test1220 True
+test1221 True
+test1222 True
+test1223 True
+test1224 True
+test1225 True
+test1226 True
+test1227 True
+test1228 True
+test1229 True
+test1230 True
+test1231 True
+test1232 True
+test1233 True
+test1234 True
+test1235 True
+test1236 True
+test1237 True
+test1238 True
+test1239 True
+test1240 True
+test1241 True
+test1242 True
+test1243 True
+test1244 True
+test1245 True
+test1246 True
+test1247 True
+test1248 True
+test1249 True
+test1250 True
+test1251 True
+test1252 True
+test1253 True
+test1254 True
+test1255 True
+test1256 True
+test1257 True
+test1258 True
+test1259 True
+test1260 True
+test1261 True
+test1262 True
+test1263 True
+test1264 True
+test1265 True
+test1266 True
+test1267 True
+test1268 True
+test1269 True
+test1270 True
+test1271 True
+test1272 True
+test1273 True
+test1274 True
+test1275 True
+test1276 True
+test1277 True
+test1278 True
+test1279 True
+test1280 True
+test1281 True
+test1282 True
+test1283 True
+test1284 True
+test1285 True
+test1286 True
+test1287 True
+test1288 True
+test1289 True
+test1290 True
+test1291 True
+test1292 True
+test1293 True
+test1294 True
+test1295 True
+test1296 True
+test1297 True
+test1298 True
+test1299 True
+test1300 True
+test1301 True
+test1302 True
+test1303 True
+test1304 True
+test1305 True
+test1306 True
+test1307 True
+test1308 True
+test1309 True
+test1310 True
+test1311 True
+test1312 True
+test1313 True
+test1314 True
+test1315 True
+test1316 True
+test1317 True
+test1318 True
+test1319 True
+test1320 True
+test1321 True
+test1322 True
+test1323 True
+test1324 True
+test1325 True
+test1326 True
+test1327 True
+test1328 True
+test1329 True
+test1330 True
=====================================
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
=====================================
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
=====================================
testsuite/tests/unboxedsums/all.T
=====================================
@@ -35,3 +35,12 @@ 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('./GenManyUbxSums.hs'),
+ extra_files(['GenManyUbxSums.hs', 'ManyUbxSums_Addr.hs']),
+ ],
+ multi_compile_and_run,
+ ['ManyUbxSums',
+ [('ManyUbxSums_Addr.hs','')]
+ , '-v0 -dstg-lint -dcmm-lint'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b1eefe1ef761d5c2a129e71920054cbbd4ae96c4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b1eefe1ef761d5c2a129e71920054cbbd4ae96c4
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/20220927/157bfdff/attachment-0001.html>
More information about the ghc-commits
mailing list