[Git][ghc/ghc][master] Properly cast values when writing/reading unboxed sums.
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Nov 30 19:51:24 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
31462d98 by Andreas Klebinger at 2022-11-30T14:50:58-05:00
Properly cast values when writing/reading unboxed sums.
Unboxed sums might store a Int8# value as Int64#. This patch
makes sure we keep track of the actual value type.
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,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
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -1448,7 +1448,8 @@ instance OutputableP Platform CLabel where
pdoc !platform lbl = getPprStyle $ \pp_sty ->
case pp_sty of
PprDump{} -> pprCLabel platform lbl
- _ -> pprPanic "Labels in code should be printed with pprCLabel or pprAsmLabel" (pprCLabel platform lbl)
+ _ -> let lbl_doc = (pprCLabel platform lbl)
+ in pprTraceUserWarning (text "Labels in code should be printed with pprCLabel or pprAsmLabel" <> lbl_doc) lbl_doc
pprCLabelStyle :: forall doc. IsLine doc => Platform -> LabelStyle -> CLabel -> doc
pprCLabelStyle !platform !sty lbl = -- see Note [Bangs in CLabel]
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -130,6 +130,8 @@ module GHC.Core.TyCon(
primRepIsFloat,
primRepsCompatible,
primRepCompatible,
+ primRepIsWord,
+ primRepIsInt,
) where
@@ -1787,6 +1789,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
=====================================
@@ -425,6 +425,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
=====================================
@@ -2395,6 +2395,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)
@@ -3349,6 +3350,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,
@@ -3808,8 +3810,8 @@ defaultFlags settings
Opt_RPath,
Opt_DumpWithWays,
Opt_CompactUnwind,
- Opt_ShowErrorContext
-
+ Opt_ShowErrorContext,
+ Opt_SuppressStgReps
]
++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]
@@ -5035,6 +5037,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
=====================================
@@ -184,6 +184,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',
@@ -256,8 +379,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)
@@ -273,6 +396,7 @@ 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
@@ -280,7 +404,11 @@ import Data.Bifunctor (second)
import Data.List.NonEmpty (NonEmpty (..))
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.
@@ -305,8 +433,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].
@@ -319,25 +449,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)
@@ -365,7 +497,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'))
@@ -378,7 +510,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)
@@ -389,12 +521,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)
@@ -402,15 +539,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
@@ -435,17 +576,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]
@@ -472,15 +617,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@(tag_arg : real_args) bndr (MultiValAlt _) alts
| isUnboxedSumBndr bndr
@@ -570,18 +719,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 at 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.
@@ -617,27 +771,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.
--
@@ -650,31 +867,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
=====================================
compiler/GHC/Types/RepType.hs
=====================================
@@ -244,7 +244,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
@@ -267,7 +268,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
{- **********************************************************************
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -414,6 +414,7 @@ data SDocContext = SDC
, sdocSuppressUniques :: !Bool
, sdocSuppressModulePrefixes :: !Bool
, sdocSuppressStgExts :: !Bool
+ , sdocSuppressStgReps :: !Bool
, sdocErrorSpans :: !Bool
, sdocStarIsType :: !Bool
, sdocLinearTypes :: !Bool
@@ -474,6 +475,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
=====================================
@@ -952,6 +952,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
=====================================
@@ -1492,7 +1492,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):
@@ -1519,7 +1520,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):
@@ -1540,7 +1542,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,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
=====================================
testsuite/tests/unboxedsums/ManyUbxSums.stdout
=====================================
@@ -0,0 +1 @@
+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
=====================================
@@ -55,3 +55,12 @@ test('unpack_sums_9', normal, compile, [""])
# [only_ways(['normal']),
# extra_files([ "unboxedsums" + str(i) + ".hs" for i in range(1, 12) ])],
# makefile_test, [])
+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'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31462d98c31e3ef48af2f6c6f2d379d74ccc63f5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/31462d98c31e3ef48af2f6c6f2d379d74ccc63f5
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/20221130/cae96803/attachment-0001.html>
More information about the ghc-commits
mailing list