diff options
| -rw-r--r-- | compiler/GHC/Core/DataCon.hs | 17 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/CprAnal.hs | 16 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/DmdAnal.hs | 15 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/WorkWrap/Utils.hs | 284 | ||||
| -rw-r--r-- | compiler/GHC/Core/TyCon.hs | 99 | ||||
| -rw-r--r-- | compiler/GHC/CoreToIface.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Pat.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Foreign/Call.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Utils.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Deriv/Utils.hs | 4 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T18013.stderr | 43 | ||||
| -rw-r--r-- | testsuite/tests/stranal/should_compile/T18982.hs | 41 | ||||
| -rw-r--r-- | testsuite/tests/stranal/should_compile/T18982.stderr | 246 | ||||
| -rw-r--r-- | testsuite/tests/stranal/should_compile/all.T | 2 |
14 files changed, 542 insertions, 234 deletions
diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs index adbdc144c3..ee8448cc8b 100644 --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -1564,15 +1564,13 @@ promoteDataCon (MkData { dcPromoted = tc }) = tc -- | Extract the type constructor, type argument, data constructor and it's -- /representation/ argument types from a type if it is a product type. -- --- Precisely, we return @Just@ for any type that is all of: +-- Precisely, we return @Just@ for any data type that is all of: -- -- * Concrete (i.e. constructors visible) --- -- * Single-constructor +-- * ... which has no existentials -- --- * Not existentially quantified --- --- Whether the type is a @data@ type or a @newtype@ +-- Whether the type is a @data@ type or a @newtype@. splitDataProductType_maybe :: Type -- ^ A product type, perhaps -> Maybe (TyCon, -- The type constructor @@ -1580,13 +1578,14 @@ splitDataProductType_maybe DataCon, -- The data constructor [Scaled Type]) -- Its /representation/ arg types - -- Rejecting existentials is conservative. Maybe some things - -- could be made to work with them, but I'm not going to sweat - -- it through till someone finds it's important. + -- Rejecting existentials means we don't have to worry about + -- freshening and substituting type variables + -- (See "GHC.Type.Id.Make.dataConArgUnpack") splitDataProductType_maybe ty | Just (tycon, ty_args) <- splitTyConApp_maybe ty - , Just con <- isDataProductTyCon_maybe tycon + , Just con <- tyConSingleDataCon_maybe tycon + , null (dataConExTyCoVars con) -- no existentials! See above = Just (tycon, ty_args, con, dataConInstArgTys con ty_args) | otherwise = Nothing diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index cab2f3b701..41ccd26c7b 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -322,7 +322,7 @@ cprAnalBind top_lvl env id rhs not_strict = not (isStrUsedDmd (idDemandInfo id)) -- See Note [CPR for sum types] (_, ret_ty) = splitPiTys (idType id) - not_a_prod = isNothing (deepSplitProductType_maybe (ae_fam_envs env) ret_ty) + not_a_prod = isNothing (splitArgType_maybe (ae_fam_envs env) ret_ty) returns_sum = not (isTopLevel top_lvl) && not_a_prod isDataStructure :: Id -> CoreExpr -> Bool @@ -425,7 +425,7 @@ nonVirgin env = env { ae_virgin = False } extendSigEnvForDemand :: AnalEnv -> Id -> Demand -> AnalEnv extendSigEnvForDemand env id dmd | isId id - , Just (_, DataConAppContext { dcac_dc = dc }) + , Just (_, DataConPatContext { dcpc_dc = dc }) <- wantToUnbox (ae_fam_envs env) has_inlineable_prag (idType id) dmd = extendSigEnv env id (CprSig (conCprType (dataConTag dc))) | otherwise @@ -446,14 +446,12 @@ extendEnvForDataAlt env scrut case_bndr dc bndrs ids_w_strs = filter isId bndrs `zip` dataConRepStrictness dc - tycon = dataConTyCon dc - is_product = isJust (isDataProductTyCon_maybe tycon) - is_sum = isJust (isDataSumTyCon_maybe tycon) + is_algebraic = isJust (tyConAlgDataCons_maybe (dataConTyCon dc)) + no_exs = null (dataConExTyCoVars dc) case_bndr_ty - | is_product || is_sum = conCprType (dataConTag dc) - -- Any of the constructors had existentials. This is a little too - -- conservative (after all, we only care about the particular data con), - -- but there is no easy way to write is_sum and this won't happen much. + | is_algebraic, no_exs = conCprType (dataConTag dc) + -- The tycon wasn't algebraic or the datacon had existentials. + -- See Note [Which types are unboxed?] for why no existentials. | otherwise = topCprType -- We could have much deeper CPR info here with Nested CPR, which could diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index de4b435c5f..fe2e66849f 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -426,8 +426,8 @@ dmdAnal' env dmd (Lam var body) dmdAnal' env dmd (Case scrut case_bndr ty [(alt, bndrs, rhs)]) -- Only one alternative. - -- If it's a DataAlt, it should be a product constructor. - | is_non_sum_alt alt + -- If it's a DataAlt, it should be the only constructor of the type. + | is_single_data_alt alt = let (rhs_ty, rhs') = dmdAnal env dmd rhs (alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs @@ -466,8 +466,8 @@ dmdAnal' env dmd (Case scrut case_bndr ty [(alt, bndrs, rhs)]) -- , text "res_ty" <+> ppr res_ty ]) $ (res_ty, Case scrut' case_bndr' ty [(alt, bndrs', rhs')]) where - is_non_sum_alt (DataAlt dc) = isJust $ isDataProductTyCon_maybe $ dataConTyCon dc - is_non_sum_alt _ = True + is_single_data_alt (DataAlt dc) = isJust $ tyConSingleAlgDataCon_maybe $ dataConTyCon dc + is_single_data_alt _ = True dmdAnal' env dmd (Case scrut case_bndr ty alts) = let -- Case expression with multiple alternatives @@ -527,10 +527,11 @@ forcesRealWorld :: FamInstEnvs -> Type -> Bool forcesRealWorld fam_envs ty | ty `eqType` realWorldStatePrimTy = True - | Just DataConAppContext{ dcac_dc = dc, dcac_arg_tys = field_tys } - <- deepSplitProductType_maybe fam_envs ty + | Just DataConPatContext{ dcpc_dc = dc, dcpc_tc_args = tc_args } + <- splitArgType_maybe fam_envs ty , isUnboxedTupleDataCon dc - = any (\(ty,_) -> scaledThing ty `eqType` realWorldStatePrimTy) field_tys + , let field_tys = dataConInstArgTys dc tc_args + = any (eqType realWorldStatePrimTy . scaledThing) field_tys | otherwise = False diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index 3551cd7d78..7fd73b2cfc 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -8,7 +8,7 @@ A library for the ``worker\/wrapper'' back-end to the strictness analyser module GHC.Core.Opt.WorkWrap.Utils ( mkWwBodies, mkWWstr, mkWorkerArgs - , DataConAppContext(..), deepSplitProductType_maybe, wantToUnbox + , DataConPatContext(..), splitArgType_maybe, wantToUnbox , findTypeShape , isWorkerSmallEnough ) @@ -19,7 +19,8 @@ where import GHC.Prelude import GHC.Core -import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase ) +import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase + , dataConRepFSInstPat ) import GHC.Types.Id import GHC.Types.Id.Info ( JoinArity ) import GHC.Core.DataCon @@ -43,9 +44,11 @@ import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk import GHC.Types.Unique.Supply import GHC.Types.Unique +import GHC.Types.Name ( getOccFS ) import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable +import GHC.Utils.Panic import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Data.FastString @@ -606,53 +609,53 @@ mkWWstr_one dflags fam_envs has_inlineable_prag arg arg_ty = idType arg dmd = idDemandInfo arg -wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataConAppContext) +wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataConPatContext) +-- See Note [Which types are unboxed?] wantToUnbox fam_envs has_inlineable_prag ty dmd = - case deepSplitProductType_maybe fam_envs ty of - Just dcac@DataConAppContext{ dcac_arg_tys = con_arg_tys } + case splitArgType_maybe fam_envs ty of + Just dcpc@DataConPatContext{ dcpc_dc = dc } | isStrUsedDmd dmd + , let arity = dataConRepArity dc -- See Note [Unpacking arguments with product and polymorphic demands] - , Just cs <- split_prod_dmd_arity dmd (length con_arg_tys) + , Just cs <- split_prod_dmd_arity dmd arity -- See Note [Do not unpack class dictionaries] , not (has_inlineable_prag && isClassPred ty) -- See Note [mkWWstr and unsafeCoerce] - , cs `equalLength` con_arg_tys - -> Just (cs, dcac) + , cs `lengthIs` arity + -> Just (cs, dcpc) _ -> Nothing where - split_prod_dmd_arity dmd arty + split_prod_dmd_arity dmd arity -- For seqDmd, it should behave like <S(AAAA)>, for some -- suitable arity - | isSeqDmd dmd = Just (replicate arty absDmd) + | isSeqDmd dmd = Just (replicate arity absDmd) | _ :* Prod ds <- dmd = Just ds | otherwise = Nothing unbox_one :: DynFlags -> FamInstEnvs -> Var -> [Demand] - -> DataConAppContext + -> DataConPatContext -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) unbox_one dflags fam_envs arg cs - DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys - , dcac_arg_tys = inst_con_arg_tys - , dcac_co = co } - = do { (uniq1:uniqs) <- getUniquesM - ; let scale = scaleScaled (idMult arg) - scaled_inst_con_arg_tys = map (\(t,s) -> (scale t, s)) inst_con_arg_tys - -- See Note [Add demands for strict constructors] - cs' = addDataConStrictness data_con cs - unpk_args = zipWith3 mk_ww_arg uniqs scaled_inst_con_arg_tys cs' - unbox_fn = mkUnpackCase (Var arg) co (idMult arg) uniq1 - data_con unpk_args - arg_no_unf = zapStableUnfolding arg - -- See Note [Zap unfolding when beta-reducing] - -- in GHC.Core.Opt.Simplify; and see #13890 - rebox_fn = Let (NonRec arg_no_unf con_app) - con_app = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co - ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False unpk_args - ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) } - -- Don't pass the arg, rebox instead - where - mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd + DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args + , dcpc_co = co } + = do { (case_bndr_uniq:pat_bndrs_uniqs) <- getUniquesM + ; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc + (ex_tvs', arg_ids) = + dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg) dc tc_args + -- See Note [Add demands for strict constructors] + cs' = addDataConStrictness dc cs + arg_ids' = zipWithEqual "unbox_one" setIdDemandInfo arg_ids cs' + unbox_fn = mkUnpackCase (Var arg) co (idMult arg) case_bndr_uniq + dc (ex_tvs' ++ arg_ids') + arg_no_unf = zapStableUnfolding arg + -- See Note [Zap unfolding when beta-reducing] + -- in GHC.Core.Opt.Simplify; and see #13890 + rebox_fn = Let (NonRec arg_no_unf con_app) + con_app = mkConApp2 dc tc_args (ex_tvs' ++ arg_ids') `mkCast` mkSymCo co + ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False (ex_tvs' ++ arg_ids') + ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) } + -- Don't pass the arg, rebox instead ---------------------- nop_fn :: CoreExpr -> CoreExpr @@ -932,74 +935,68 @@ off the unpacking in mkWWstr_one (see the isClassPred test). Historical note: #14955 describes how I got this fix wrong the first time. -} --- | Context for a 'DataCon' application with a hole for every field, including --- surrounding coercions. --- The result of 'deepSplitProductType_maybe' and 'deepSplitCprType_maybe'. --- --- Example: --- --- > DataConAppContext Just [Int] [(Lazy, Int)] (co :: Maybe Int ~ First Int) +-- | The result of 'splitArgType_maybe' and 'splitResultType_maybe'. -- --- represents --- --- > Just @Int (_1 :: Int) |> co :: First Int --- --- where _1 is a hole for the first argument. The number of arguments is --- determined by the length of @arg_tys@. -data DataConAppContext - = DataConAppContext - { dcac_dc :: !DataCon - , dcac_tys :: ![Type] - , dcac_arg_tys :: ![(Scaled Type, StrictnessMark)] - , dcac_co :: !Coercion +-- Both splits +-- * Take a type `ty` +-- * Succeed with (DataConPatContext dc tys co) +-- iff co :: T tys ~ ty +-- and `dc` is the appropriate DataCon of `T` +-- and `T` is suitable for the kind of split +-- (differs for strictness and CPR, see Note [Which types are unboxed?]) +data DataConPatContext + = DataConPatContext + { dcpc_dc :: !DataCon + , dcpc_tc_args :: ![Type] + , dcpc_co :: !Coercion } -deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe DataConAppContext --- If deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co) --- then dc @ tys (args::arg_tys) :: rep_ty --- co :: ty ~ rep_ty --- Why do we return the strictness of the data-con arguments? --- Answer: see Note [Record evaluated-ness in worker/wrapper] -deepSplitProductType_maybe fam_envs ty +-- | If @splitArgType_maybe ty = Just (dc, tys, co)@ +-- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@ +-- and @co :: ty ~ tc tys@ +-- where underscore prefixes are holes, e.g. yet unspecified. +-- +-- See Note [Which types are unboxed?]. +splitArgType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext +splitArgType_maybe fam_envs ty | let (co, ty1) = topNormaliseType_maybe fam_envs ty `orElse` (mkRepReflCo ty, ty) , Just (tc, tc_args) <- splitTyConApp_maybe ty1 - , Just con <- isDataProductTyCon_maybe tc - , let arg_tys = dataConInstArgTys con tc_args - strict_marks = dataConRepStrictness con - = Just DataConAppContext { dcac_dc = con - , dcac_tys = tc_args - , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks - , dcac_co = co } -deepSplitProductType_maybe _ _ = Nothing - -deepSplitCprType_maybe - :: FamInstEnvs -> ConTag -> Type -> Maybe DataConAppContext --- If deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co) --- then dc @ tys (args::arg_tys) :: rep_ty --- co :: ty ~ rep_ty --- Why do we return the strictness of the data-con arguments? --- Answer: see Note [Record evaluated-ness in worker/wrapper] -deepSplitCprType_maybe fam_envs con_tag ty + , Just con <- tyConSingleAlgDataCon_maybe tc + = Just DataConPatContext { dcpc_dc = con + , dcpc_tc_args = tc_args + , dcpc_co = co } +splitArgType_maybe _ _ = Nothing + +-- | If @splitResultType_maybe n ty = Just (dc, tys, co)@ +-- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@ +-- and @co :: ty ~ tc tys@ +-- where underscore prefixes are holes, e.g. yet unspecified. +-- @dc@ is the @n@th data constructor of @tc@. +-- +-- See Note [Which types are unboxed?]. +splitResultType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConPatContext +splitResultType_maybe fam_envs con_tag ty | let (co, ty1) = topNormaliseType_maybe fam_envs ty `orElse` (mkRepReflCo ty, ty) , Just (tc, tc_args) <- splitTyConApp_maybe ty1 - , isDataTyCon tc + , isDataTyCon tc -- NB: rules out unboxed sums and pairs! , let cons = tyConDataCons tc , cons `lengthAtLeast` con_tag -- This might not be true if we import the - -- type constructor via a .hs-bool file (#8743) + -- type constructor via a .hs-boot file (#8743) , let con = cons `getNth` (con_tag - fIRST_TAG) - arg_tys = dataConInstArgTys con tc_args - strict_marks = dataConRepStrictness con - , all isLinear arg_tys + , null (dataConExTyCoVars con) -- no existentials; + -- See Note [Which types are unboxed?] + -- and GHC.Core.Opt.CprAnal.extendEnvForDataAlt + -- where we also check this. + , all isLinear (dataConInstArgTys con tc_args) -- Deactivates CPR worker/wrapper splits on constructors with non-linear -- arguments, for the moment, because they require unboxed tuple with variable -- multiplicity fields. - = Just DataConAppContext { dcac_dc = con - , dcac_tys = tc_args - , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks - , dcac_co = co } -deepSplitCprType_maybe _ _ _ = Nothing + = Just DataConPatContext { dcpc_dc = con + , dcpc_tc_args = tc_args + , dcpc_co = co } +splitResultType_maybe _ _ _ = Nothing isLinear :: Scaled a -> Bool isLinear (Scaled w _ ) = @@ -1035,13 +1032,16 @@ findTypeShape fam_envs ty | Just (_, rhs, _) <- topReduceTyFamApp_maybe fam_envs tc tc_args = go rec_tc rhs - | Just con <- isDataProductTyCon_maybe tc + | Just con <- tyConSingleAlgDataCon_maybe tc , Just rec_tc <- if isTupleTyCon tc then Just rec_tc else checkRecTc rec_tc tc -- We treat tuples specially because they can't cause loops. -- Maybe we should do so in checkRecTc. - = TsProd (map (go rec_tc . scaledThing) (dataConInstArgTys con tc_args)) + -- The use of 'dubiousDataConInstArgTys' is OK, since this + -- function performs no substitution at all, hence the uniques + -- don't matter. + = TsProd (map (go rec_tc) (dubiousDataConInstArgTys con tc_args)) | Just (ty', _) <- instNewTyCon_maybe tc tc_args , Just rec_tc <- checkRecTc rec_tc tc @@ -1050,7 +1050,55 @@ findTypeShape fam_envs ty | otherwise = TsUnk -{- +-- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that +-- the 'DataCon' may not have existentials. The lack of cloning the existentials +-- compared to 'dataConInstExAndArgVars' makes this function \"dubious\"; +-- only use it where type variables aren't substituted for! +dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type] +dubiousDataConInstArgTys dc tc_args = arg_tys + where + univ_tvs = dataConUnivTyVars dc + ex_tvs = dataConExTyCoVars dc + subst = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs + arg_tys = map (substTy subst . scaledThing) (dataConRepArgTys dc) + +{- Note [Which types are unboxed?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Worker/wrapper will unbox + + 1. A strict data type argument, that + * is an algebraic data type (not a newtype) + * has a single constructor (thus is a "product") + * that may bind existentials + We can transform + > f (D @ex a b) = e + to + > $wf @ex a b = e + via 'mkWWstr'. + + 2. The constructed result of a function, if + * its type is an algebraic data type (not a newtype) + * (might have multiple constructors, in contrast to (1)) + * the applied data constructor *does not* bind existentials + We can transform + > f x y = let ... in D a b + to + > $wf x y = let ... in (# a, b #) + via 'mkWWcpr'. + + NB: We don't allow existentials for CPR W/W, because we don't have unboxed + dependent tuples (yet?). Otherwise, we could transform + > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..) + to + > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #) + +The respective tests are in 'splitArgType_maybe' and +'splitResultType_maybe', respectively. + +Note that the data constructor /can/ have evidence arguments: equality +constraints, type classes etc. So it can be GADT. These evidence +arguments are simply value arguments, and should not get in the way. + ************************************************************************ * * \subsection{CPR stuff} @@ -1083,35 +1131,36 @@ mkWWcpr opt_CprAnal fam_envs body_ty cpr | otherwise = case asConCpr cpr of Nothing -> return (False, id, id, body_ty) -- No CPR info - Just con_tag | Just dcac <- deepSplitCprType_maybe fam_envs con_tag body_ty - -> mkWWcpr_help dcac + Just con_tag | Just dcpc <- splitResultType_maybe fam_envs con_tag body_ty + -> mkWWcpr_help dcpc | otherwise -- See Note [non-algebraic or open body type warning] -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty ) return (False, id, id, body_ty) -mkWWcpr_help :: DataConAppContext +mkWWcpr_help :: DataConPatContext -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type) -mkWWcpr_help (DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys - , dcac_arg_tys = arg_tys, dcac_co = co }) - | [arg1@(arg_ty1, _)] <- arg_tys - , isUnliftedType (scaledThing arg_ty1) - , isLinear arg_ty1 +mkWWcpr_help (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args + , dcpc_co = co }) + | [arg_ty] <- dataConInstArgTys dc tc_args -- NB: No existentials! + , [str_mark] <- dataConRepStrictness dc + , isUnliftedType (scaledThing arg_ty) + , isLinear arg_ty -- Special case when there is a single result of unlifted, linear, type -- -- Wrapper: case (..call worker..) of x -> C x -- Worker: case ( ..body.. ) of C x -> x = do { (work_uniq : arg_uniq : _) <- getUniquesM - ; let arg = mk_ww_local arg_uniq arg1 - con_app = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co + ; let arg_id = mk_ww_local arg_uniq str_mark arg_ty + con_app = mkConApp2 dc tc_args [arg_id] `mkCast` mkSymCo co ; return ( True - , \ wkr_call -> mkDefaultCase wkr_call arg con_app - , \ body -> mkUnpackCase body co One work_uniq data_con [arg] (varToCoreExpr arg) + , \ wkr_call -> mkDefaultCase wkr_call arg_id con_app + , \ body -> mkUnpackCase body co One work_uniq dc [arg_id] (varToCoreExpr arg_id) -- varToCoreExpr important here: arg can be a coercion -- Lacking this caused #10658 - , scaledThing arg_ty1 ) } + , scaledThing arg_ty ) } | otherwise -- The general case -- Wrapper: case (..call worker..) of (# a, b #) -> C a b @@ -1123,18 +1172,22 @@ mkWWcpr_help (DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys -- parametrised by the multiplicity of its fields. Specifically, in this -- instance, the multiplicity of the fields of (#,#) is chosen to be the -- same as those of C. - = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM - ; let wrap_wild = mk_ww_local wild_uniq (linear ubx_tup_ty,MarkedStrict) - args = zipWith mk_ww_local uniqs arg_tys - ubx_tup_ty = exprType ubx_tup_app - ubx_tup_app = mkCoreUbxTup (map (scaledThing . fst) arg_tys) (map varToCoreExpr args) - con_app = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co - tup_con = tupleDataCon Unboxed (length arg_tys) + = do { (work_uniq : wild_uniq : pat_bndrs_uniqs) <- getUniquesM + ; let case_mult = One -- see above + (_exs, arg_ids) = + dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs case_mult dc tc_args + wrap_wild = mk_ww_local wild_uniq MarkedStrict (Scaled case_mult ubx_tup_ty) + ubx_tup_ty = exprType ubx_tup_app + ubx_tup_app = mkCoreUbxTup (map idType arg_ids) (map varToCoreExpr arg_ids) + con_app = mkConApp2 dc tc_args arg_ids `mkCast` mkSymCo co + tup_con = tupleDataCon Unboxed (length arg_ids) + + ; MASSERT( null _exs ) -- Should have been caught by splitResultType_maybe ; return (True , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild - (DataAlt tup_con) args con_app - , \ body -> mkUnpackCase body co One work_uniq data_con args ubx_tup_app + (DataAlt tup_con) arg_ids con_app + , \ body -> mkUnpackCase body co case_mult work_uniq dc arg_ids ubx_tup_app , ubx_tup_ty ) } mkUnpackCase :: CoreExpr -> Coercion -> Mult -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr @@ -1149,7 +1202,7 @@ mkUnpackCase scrut co mult uniq boxing_con unpk_args body (DataAlt boxing_con) unpk_args body where casted_scrut = scrut `mkCast` co - bndr = mk_ww_local uniq (Scaled mult (exprType casted_scrut), MarkedStrict) + bndr = mk_ww_local uniq MarkedStrict (Scaled mult (exprType casted_scrut)) -- An unpacking case can always be chosen linear, because the variables -- are always passed to a constructor. This limits the {- @@ -1291,10 +1344,13 @@ mk_absent_let dflags fam_envs arg -- See also Note [Unique Determinism] in GHC.Types.Unique unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty] -mk_ww_local :: Unique -> (Scaled Type, StrictnessMark) -> Id +ww_prefix :: FastString +ww_prefix = fsLit "ww" + +mk_ww_local :: Unique -> StrictnessMark -> Scaled Type -> Id -- The StrictnessMark comes form the data constructor and says -- whether this field is strict -- See Note [Record evaluated-ness in worker/wrapper] -mk_ww_local uniq (Scaled w ty,str) +mk_ww_local uniq str (Scaled w ty) = setCaseBndrEvald str $ - mkSysLocalOrCoVar (fsLit "ww") uniq w ty + mkSysLocalOrCoVar ww_prefix uniq w ty diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index a038fd646c..0cd1463b46 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -58,8 +58,7 @@ module GHC.Core.TyCon( isKindTyCon, isLiftedTypeKindTyConName, isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon, - isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, - isDataSumTyCon_maybe, + isDataTyCon, isEnumerationTyCon, isNewTyCon, isAbstractTyCon, isFamilyTyCon, isOpenFamilyTyCon, @@ -84,6 +83,7 @@ module GHC.Core.TyCon( tyConCType, tyConCType_maybe, tyConDataCons, tyConDataCons_maybe, tyConSingleDataCon_maybe, tyConSingleDataCon, + tyConAlgDataCons_maybe, tyConSingleAlgDataCon_maybe, tyConFamilySize, tyConStupidTheta, @@ -143,7 +143,7 @@ import {-# SOURCE #-} GHC.Builtin.Types , multiplicityTyCon , vecCountTyCon, vecElemTyCon, liftedTypeKind ) import {-# SOURCE #-} GHC.Core.DataCon - ( DataCon, dataConExTyCoVars, dataConFieldLabels + ( DataCon, dataConFieldLabels , dataConTyCon, dataConFullSig , isUnboxedSumDataCon ) import GHC.Builtin.Uniques @@ -1976,72 +1976,6 @@ unwrapNewTyConEtad_maybe (AlgTyCon { algTcRhs = NewTyCon { nt_co = co, = Just (tvs, rhs, co) unwrapNewTyConEtad_maybe _ = Nothing -isProductTyCon :: TyCon -> Bool --- True of datatypes or newtypes that have --- one, non-existential, data constructor --- See Note [Product types] -isProductTyCon tc@(AlgTyCon {}) - = case algTcRhs tc of - TupleTyCon {} -> True - DataTyCon{ data_cons = [data_con] } - -> null (dataConExTyCoVars data_con) - NewTyCon {} -> True - _ -> False -isProductTyCon _ = False - -isDataProductTyCon_maybe :: TyCon -> Maybe DataCon --- True of datatypes (not newtypes) with --- one, vanilla, data constructor --- See Note [Product types] -isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = [con] } - | null (dataConExTyCoVars con) -- non-existential - -> Just con - TupleTyCon { data_con = con } - -> Just con - _ -> Nothing -isDataProductTyCon_maybe _ = Nothing - -isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon] -isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = cons } - | cons `lengthExceeds` 1 - , all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? - -> Just cons - SumTyCon { data_cons = cons } - | all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? - -> Just cons - _ -> Nothing -isDataSumTyCon_maybe _ = Nothing - -{- Note [Product types] -~~~~~~~~~~~~~~~~~~~~~~~ -A product type is - * A data type (not a newtype) - * With one, boxed data constructor - * That binds no existential type variables - -The main point is that product types are amenable to unboxing for - * Strict function calls; we can transform - f (D a b) = e - to - fw a b = e - via the worker/wrapper transformation. (Question: couldn't this - work for existentials too?) - - * CPR for function results; we can transform - f x y = let ... in D a b - to - fw x y = let ... in (# a, b #) - -Note that the data constructor /can/ have evidence arguments: equality -constraints, type classes etc. So it can be GADT. These evidence -arguments are simply value arguments, and should not get in the way. --} - - -- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? {-# INLINE isTypeSynonymTyCon #-} -- See Note [Inlining coreView] in GHC.Core.Type isTypeSynonymTyCon :: TyCon -> Bool @@ -2382,8 +2316,7 @@ tyConDataCons_maybe _ = Nothing -- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ -- type with one alternative, a tuple type or a @newtype@ then that constructor -- is returned. If the 'TyCon' has more than one constructor, or represents a --- primitive or function type constructor then @Nothing@ is returned. In any --- other case, the function panics +-- primitive or function type constructor then @Nothing@ is returned. tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs }) = case rhs of @@ -2393,21 +2326,29 @@ tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs }) _ -> Nothing tyConSingleDataCon_maybe _ = Nothing +-- | Like 'tyConSingleDataCon_maybe', but panics if 'Nothing'. tyConSingleDataCon :: TyCon -> DataCon tyConSingleDataCon tc = case tyConSingleDataCon_maybe tc of Just c -> c Nothing -> pprPanic "tyConDataCon" (ppr tc) +-- | Like 'tyConSingleDataCon_maybe', but returns 'Nothing' for newtypes. tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon --- Returns (Just con) for single-constructor --- *algebraic* data types *not* newtypes -tyConSingleAlgDataCon_maybe (AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = [c] } -> Just c - TupleTyCon { data_con = c } -> Just c - _ -> Nothing -tyConSingleAlgDataCon_maybe _ = Nothing +tyConSingleAlgDataCon_maybe tycon + | isNewTyCon tycon = Nothing + | otherwise = tyConSingleDataCon_maybe tycon + +-- | Returns @Just dcs@ if the given 'TyCon' is a @data@ type, a tuple type +-- or a sum type with data constructors dcs. If the 'TyCon' has more than one +-- constructor, or represents a primitive or function type constructor then +-- @Nothing@ is returned. +-- +-- Like 'tyConDataCons_maybe', but returns 'Nothing' for newtypes. +tyConAlgDataCons_maybe :: TyCon -> Maybe [DataCon] +tyConAlgDataCons_maybe tycon + | isNewTyCon tycon = Nothing + | otherwise = tyConDataCons_maybe tycon -- | Determine the number of value constructors a 'TyCon' has. Panics if the -- 'TyCon' is not algebraic or a tuple diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index a65e89853c..076c2812d9 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -245,7 +245,7 @@ toIfaceTyCon tc , Just tsort <- tupleSort tc' = tsort | isUnboxedSumTyCon tc - , Just cons <- isDataSumTyCon_maybe tc = IfaceSumTyCon (length cons) + , Just cons <- tyConDataCons_maybe tc = IfaceSumTyCon (length cons) | otherwise = IfaceNormalTyCon diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index a1d59699c5..cf23cb4a1c 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -776,8 +776,6 @@ isIrrefutableHsPat L _ (PatSynCon _pat) -> False -- Conservative L _ (RealDataCon con) -> isJust (tyConSingleDataCon_maybe (dataConTyCon con)) - -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because - -- the latter is false of existentials. See #4439 && all goL (hsConPatArgs details) go (LitPat {}) = False go (NPat {}) = False diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs index f28d476c05..1644a6ddf6 100644 --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -350,7 +350,8 @@ resultWrapper result_ty -- Data types with a single constructor, which has a single arg -- This includes types like Ptr and ForeignPtr | Just (tycon, tycon_arg_tys) <- maybe_tc_app - , Just data_con <- isDataProductTyCon_maybe tycon -- One constructor, no existentials + , Just data_con <- tyConSingleAlgDataCon_maybe tycon -- One constructor + , null (dataConExTyCoVars data_con) -- no existentials , [Scaled _ unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument = do { (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty ; let marshal_con e = Var (dataConWrapId data_con) diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index ac66b00813..6384867a93 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -744,7 +744,7 @@ is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps is_flat_prod_pat (ConPat { pat_con = L _ pcon , pat_args = ps}) | RealDataCon con <- pcon - , isProductTyCon (dataConTyCon con) + , Just _ <- tyConSingleDataCon_maybe (dataConTyCon con) = all is_triv_lpat (hsConPatArgs ps) is_flat_prod_pat _ = False diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs index f4d71a38a1..aa60f706a3 100644 --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -928,8 +928,8 @@ cond_isEnumeration _ _ rep_tc cond_isProduct :: Condition cond_isProduct _ _ rep_tc - | isProductTyCon rep_tc = IsValid - | otherwise = NotValid why + | Just _ <- tyConSingleDataCon_maybe rep_tc = IsValid + | otherwise = NotValid why where why = quotes (pprSourceTyCon rep_tc) <+> text "must have precisely one constructor" diff --git a/testsuite/tests/simplCore/should_compile/T18013.stderr b/testsuite/tests/simplCore/should_compile/T18013.stderr index 20cb606cb4..a0d90899e1 100644 --- a/testsuite/tests/simplCore/should_compile/T18013.stderr +++ b/testsuite/tests/simplCore/should_compile/T18013.stderr @@ -132,33 +132,58 @@ Result size of Tidy Core = {terms: 52, types: 101, coercions: 17, joins: 0/1} -- RHS size: {terms: 37, types: 84, coercions: 17, joins: 0/1} -mapMaybeRule +mapMaybeRule [InlPrag=[2]] :: forall a b. Rule IO a b -> Rule IO (Maybe a) (Maybe b) [GblId, Arity=1, - Str=<SU>, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 150 10}] + Str=<SP(U,UCU(CS(CS(P(U,SP(U,U))))))>, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) + Tmpl= \ (@a) (@b) (w [Occ=Once1!] :: Rule IO a b) -> + case w of { Rule @s ww1 ww2 [Occ=OnceL1!] -> + T18013a.Rule + @IO + @(Maybe a) + @(Maybe b) + @s + ww1 + ((\ (s2 [Occ=Once1] :: s) + (a1 [Occ=Once1!] :: Maybe a) + (s1 [Occ=Once2] :: GHC.Prim.State# GHC.Prim.RealWorld) -> + case a1 of { + Nothing -> + (# s1, T18013a.Result @s @(Maybe b) ww1 (GHC.Maybe.Nothing @b) #); + Just x [Occ=Once1] -> + case ((ww2 s2 x) `cast` <Co:4>) s1 of + { (# ipv [Occ=Once1], ipv1 [Occ=Once1!] #) -> + case ipv1 of { Result t2 [Occ=Once1] c1 [Occ=Once1] -> + (# ipv, T18013a.Result @s @(Maybe b) t2 (GHC.Maybe.Just @b c1) #) + } + } + }) + `cast` <Co:13>) + }}] mapMaybeRule - = \ (@a) (@b) (f :: Rule IO a b) -> - case f of { Rule @s t0 g -> + = \ (@a) (@b) (w :: Rule IO a b) -> + case w of { Rule @s ww1 ww2 -> let { lvl :: Result s (Maybe b) [LclId, Unf=OtherCon []] - lvl = T18013a.Result @s @(Maybe b) t0 (GHC.Maybe.Nothing @b) } in + lvl = T18013a.Result @s @(Maybe b) ww1 (GHC.Maybe.Nothing @b) } in T18013a.Rule @IO @(Maybe a) @(Maybe b) @s - t0 + ww1 ((\ (s2 :: s) (a1 :: Maybe a) (s1 :: GHC.Prim.State# GHC.Prim.RealWorld) -> case a1 of { Nothing -> (# s1, lvl #); Just x -> - case ((g s2 x) `cast` <Co:4>) s1 of { (# ipv, ipv1 #) -> + case ((ww2 s2 x) `cast` <Co:4>) s1 of { (# ipv, ipv1 #) -> case ipv1 of { Result t2 c1 -> (# ipv, T18013a.Result @s @(Maybe b) t2 (GHC.Maybe.Just @b c1) #) } diff --git a/testsuite/tests/stranal/should_compile/T18982.hs b/testsuite/tests/stranal/should_compile/T18982.hs new file mode 100644 index 0000000000..e451d6bb76 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/T18982.hs @@ -0,0 +1,41 @@ +{-# OPTIONS_GHC -O -fforce-recomp #-} +{-# LANGUAGE GADTs #-} + +module T18982 where + +data Box a where + Box :: a -> Box a + +data Ex a where + Ex :: e -> a -> Ex a + +data GADT a where + GADT :: Int -> GADT Int + +data ExGADT a where + ExGADT :: (e ~ Int) => e -> Int -> ExGADT Int + +-- | Expected worker type: +-- $wf :: Int# -> Int# +f :: Box Int -> Int +f (Box n) = n + 1 +{-# NOINLINE f #-} + +-- | Expected worker type: +-- $wg :: forall {e}. e -> Int# -> Int# +g :: Ex Int -> Int +g (Ex e n) = e `seq` n + 1 +{-# NOINLINE g #-} + +-- | Expected worker type: +-- $wh :: Int# -> Int# +h :: GADT a -> Int +h (GADT n) = n + 1 +{-# NOINLINE h #-} + +-- | Expected worker type: +-- $wi :: forall {e}. e -> Int# -> Int# +i :: ExGADT a -> Int +i (ExGADT e n) = e `seq` n + 1 +{-# NOINLINE i #-} + diff --git a/testsuite/tests/stranal/should_compile/T18982.stderr b/testsuite/tests/stranal/should_compile/T18982.stderr new file mode 100644 index 0000000000..3e6074e759 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/T18982.stderr @@ -0,0 +1,246 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 311, types: 249, coercions: 4, joins: 0/0} + +-- RHS size: {terms: 8, types: 11, coercions: 1, joins: 0/0} +T18982.$WExGADT :: forall e. (e ~ Int) => e %1 -> Int %1 -> ExGADT Int +T18982.$WExGADT = \ (@e) (dt :: e ~ Int) (dt :: e) (dt :: Int) -> T18982.ExGADT @Int @e @~(<Int>_N :: Int GHC.Prim.~# Int) dt dt dt + +-- RHS size: {terms: 3, types: 2, coercions: 1, joins: 0/0} +T18982.$WGADT :: Int %1 -> GADT Int +T18982.$WGADT = \ (dt :: Int) -> T18982.GADT @Int @~(<Int>_N :: Int GHC.Prim.~# Int) dt + +-- RHS size: {terms: 7, types: 8, coercions: 0, joins: 0/0} +T18982.$WEx :: forall e a. e %1 -> a %1 -> Ex a +T18982.$WEx = \ (@e) (@a) (dt :: e) (dt :: a) -> T18982.Ex @a @e dt dt + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18982.$trModule4 :: GHC.Prim.Addr# +T18982.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18982.$trModule3 :: GHC.Types.TrName +T18982.$trModule3 = GHC.Types.TrNameS T18982.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18982.$trModule2 :: GHC.Prim.Addr# +T18982.$trModule2 = "T18982"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18982.$trModule1 :: GHC.Types.TrName +T18982.$trModule1 = GHC.Types.TrNameS T18982.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T18982.$trModule :: GHC.Types.Module +T18982.$trModule = GHC.Types.Module T18982.$trModule3 T18982.$trModule1 + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep :: GHC.Types.KindRep +$krep = GHC.Types.KindRepTyConApp GHC.Types.$tcInt (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$krep1 :: GHC.Types.KindRep +$krep1 = GHC.Types.KindRepVar 1# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$krep2 :: GHC.Types.KindRep +$krep2 = GHC.Types.KindRepVar 0# + +-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} +$krep3 :: [GHC.Types.KindRep] +$krep3 = GHC.Types.: @GHC.Types.KindRep $krep (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep4 :: [GHC.Types.KindRep] +$krep4 = GHC.Types.: @GHC.Types.KindRep $krep2 $krep3 + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep5 :: [GHC.Types.KindRep] +$krep5 = GHC.Types.: @GHC.Types.KindRep GHC.Types.krep$* $krep4 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep6 :: GHC.Types.KindRep +$krep6 = GHC.Types.KindRepTyConApp GHC.Types.$tc~ $krep5 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18982.$tcBox2 :: GHC.Prim.Addr# +T18982.$tcBox2 = "Box"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18982.$tcBox1 :: GHC.Types.TrName +T18982.$tcBox1 = GHC.Types.TrNameS T18982.$tcBox2 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T18982.$tcBox :: GHC.Types.TyCon +T18982.$tcBox = GHC.Types.TyCon 16948648223906549518## 2491460178135962649## T18982.$trModule T18982.$tcBox1 0# GHC.Types.krep$*Arr* + +-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} +$krep7 :: [GHC.Types.KindRep] +$krep7 = GHC.Types.: @GHC.Types.KindRep $krep2 (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep8 :: GHC.Types.KindRep +$krep8 = GHC.Types.KindRepTyConApp T18982.$tcBox $krep7 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T18982.$tc'Box1 :: GHC.Types.KindRep +T18982.$tc'Box1 = GHC.Types.KindRepFun $krep2 $krep8 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18982.$tc'Box3 :: GHC.Prim.Addr# +T18982.$tc'Box3 = "'Box"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18982.$tc'Box2 :: GHC.Types.TrName +T18982.$tc'Box2 = GHC.Types.TrNameS T18982.$tc'Box3 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T18982.$tc'Box :: GHC.Types.TyCon +T18982.$tc'Box = GHC.Types.TyCon 1412068769125067428## 8727214667407894081## T18982.$trModule T18982.$tc'Box2 1# T18982.$tc'Box1 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18982.$tcEx2 :: GHC.Prim.Addr# +T18982.$tcEx2 = "Ex"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18982.$tcEx1 :: GHC.Types.TrName +T18982.$tcEx1 = GHC.Types.TrNameS T18982.$tcEx2 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T18982.$tcEx :: GHC.Types.TyCon +T18982.$tcEx = GHC.Types.TyCon 4376661818164435927## 18005417598910668817## T18982.$trModule T18982.$tcEx1 0# GHC.Types.krep$*Arr* + +-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} +$krep9 :: [GHC.Types.KindRep] +$krep9 = GHC.Types.: @GHC.Types.KindRep $krep1 (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep10 :: GHC.Types.KindRep +$krep10 = GHC.Types.KindRepTyConApp T18982.$tcEx $krep9 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep11 :: GHC.Types.KindRep +$krep11 = GHC.Types.KindRepFun $krep1 $krep10 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T18982.$tc'Ex1 :: GHC.Types.KindRep +T18982.$tc'Ex1 = GHC.Types.KindRepFun $krep2 $krep11 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18982.$tc'Ex3 :: GHC.Prim.Addr# +T18982.$tc'Ex3 = "'Ex"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18982.$tc'Ex2 :: GHC.Types.TrName +T18982.$tc'Ex2 = GHC.Types.TrNameS T18982.$tc'Ex3 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T18982.$tc'Ex :: GHC.Types.TyCon +T18982.$tc'Ex = GHC.Types.TyCon 14609381081172201359## 3077219645053200509## T18982.$trModule T18982.$tc'Ex2 2# T18982.$tc'Ex1 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18982.$tcGADT2 :: GHC.Prim.Addr# +T18982.$tcGADT2 = "GADT"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18982.$tcGADT1 :: GHC.Types.TrName +T18982.$tcGADT1 = GHC.Types.TrNameS T18982.$tcGADT2 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T18982.$tcGADT :: GHC.Types.TyCon +T18982.$tcGADT = GHC.Types.TyCon 9243924476135839950## 5096619276488416461## T18982.$trModule T18982.$tcGADT1 0# GHC.Types.krep$*Arr* + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep12 :: GHC.Types.KindRep +$krep12 = GHC.Types.KindRepTyConApp T18982.$tcGADT $krep3 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T18982.$tc'GADT1 :: GHC.Types.KindRep +T18982.$tc'GADT1 = GHC.Types.KindRepFun $krep $krep12 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18982.$tc'GADT3 :: GHC.Prim.Addr# +T18982.$tc'GADT3 = "'GADT"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18982.$tc'GADT2 :: GHC.Types.TrName +T18982.$tc'GADT2 = GHC.Types.TrNameS T18982.$tc'GADT3 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T18982.$tc'GADT :: GHC.Types.TyCon +T18982.$tc'GADT = GHC.Types.TyCon 2077850259354179864## 16731205864486799217## T18982.$trModule T18982.$tc'GADT2 0# T18982.$tc'GADT1 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18982.$tcExGADT2 :: GHC.Prim.Addr# +T18982.$tcExGADT2 = "ExGADT"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18982.$tcExGADT1 :: GHC.Types.TrName +T18982.$tcExGADT1 = GHC.Types.TrNameS T18982.$tcExGADT2 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T18982.$tcExGADT :: GHC.Types.TyCon +T18982.$tcExGADT = GHC.Types.TyCon 6470898418160489500## 10361108917441214060## T18982.$trModule T18982.$tcExGADT1 0# GHC.Types.krep$*Arr* + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep13 :: GHC.Types.KindRep +$krep13 = GHC.Types.KindRepTyConApp T18982.$tcExGADT $krep3 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep14 :: GHC.Types.KindRep +$krep14 = GHC.Types.KindRepFun $krep $krep13 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep15 :: GHC.Types.KindRep +$krep15 = GHC.Types.KindRepFun $krep2 $krep14 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T18982.$tc'ExGADT1 :: GHC.Types.KindRep +T18982.$tc'ExGADT1 = GHC.Types.KindRepFun $krep6 $krep15 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18982.$tc'ExGADT3 :: GHC.Prim.Addr# +T18982.$tc'ExGADT3 = "'ExGADT"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18982.$tc'ExGADT2 :: GHC.Types.TrName +T18982.$tc'ExGADT2 = GHC.Types.TrNameS T18982.$tc'ExGADT3 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T18982.$tc'ExGADT :: GHC.Types.TyCon +T18982.$tc'ExGADT = GHC.Types.TyCon 8468257409157161049## 5503123603717080600## T18982.$trModule T18982.$tc'ExGADT2 1# T18982.$tc'ExGADT1 + +-- RHS size: {terms: 11, types: 14, coercions: 0, joins: 0/0} +T18982.$wi :: forall {a} {e}. (a GHC.Prim.~# Int) -> e -> GHC.Prim.Int# -> GHC.Prim.Int# +T18982.$wi = \ (@a) (@e) (ww :: a GHC.Prim.~# Int) (ww1 :: e) (ww2 :: GHC.Prim.Int#) -> case ww1 of { __DEFAULT -> GHC.Prim.+# ww2 1# } + +-- RHS size: {terms: 15, types: 27, coercions: 1, joins: 0/0} +i :: forall a. ExGADT a -> Int +i = \ (@a) (w :: ExGADT a) -> case w of { ExGADT @e ww1 ww2 ww3 ww4 -> case ww4 of { GHC.Types.I# ww6 -> case T18982.$wi @a @e @~(ww1 :: a GHC.Prim.~# Int) ww3 ww6 of ww7 { __DEFAULT -> GHC.Types.I# ww7 } } } + +-- RHS size: {terms: 6, types: 10, coercions: 0, joins: 0/0} +T18982.$wh :: forall {a}. (a GHC.Prim.~# Int) -> GHC.Prim.Int# -> GHC.Prim.Int# +T18982.$wh = \ (@a) (ww :: a GHC.Prim.~# Int) (ww1 :: GHC.Prim.Int#) -> GHC.Prim.+# ww1 1# + +-- RHS size: {terms: 14, types: 18, coercions: 1, joins: 0/0} +h :: forall a. GADT a -> Int +h = \ (@a) (w :: GADT a) -> case w of { GADT ww1 ww2 -> case ww2 of { GHC.Types.I# ww4 -> case T18982.$wh @a @~(ww1 :: a GHC.Prim.~# Int) ww4 of ww5 { __DEFAULT -> GHC.Types.I# ww5 } } } + +-- RHS size: {terms: 9, types: 5, coercions: 0, joins: 0/0} +T18982.$wg :: forall {e}. e -> GHC.Prim.Int# -> GHC.Prim.Int# +T18982.$wg = \ (@e) (ww :: e) (ww1 :: GHC.Prim.Int#) -> case ww of { __DEFAULT -> GHC.Prim.+# ww1 1# } + +-- RHS size: {terms: 14, types: 12, coercions: 0, joins: 0/0} +g :: Ex Int -> Int +g = \ (w :: Ex Int) -> case w of { Ex @e ww1 ww2 -> case ww2 of { GHC.Types.I# ww4 -> case T18982.$wg @e ww1 ww4 of ww5 { __DEFAULT -> GHC.Types.I# ww5 } } } + +-- RHS size: {terms: 4, types: 1, coercions: 0, joins: 0/0} +T18982.$wf :: GHC.Prim.Int# -> GHC.Prim.Int# +T18982.$wf = \ (ww :: GHC.Prim.Int#) -> GHC.Prim.+# ww 1# + +-- RHS size: {terms: 13, types: 8, coercions: 0, joins: 0/0} +f :: Box Int -> Int +f = \ (w :: Box Int) -> case w of { Box ww1 -> case ww1 of { GHC.Types.I# ww3 -> case T18982.$wf ww3 of ww4 { __DEFAULT -> GHC.Types.I# ww4 } } } + + + diff --git a/testsuite/tests/stranal/should_compile/all.T b/testsuite/tests/stranal/should_compile/all.T index c00d61b8c2..28c8154a77 100644 --- a/testsuite/tests/stranal/should_compile/all.T +++ b/testsuite/tests/stranal/should_compile/all.T @@ -62,3 +62,5 @@ test('T18903', [ grep_errmsg(r'Dmd=\S+C\S+') ], compile, ['-ddump-simpl -dsuppr test('T18894', [ grep_errmsg(r'Dmd=\S+C\S+') ], compile, ['-ddump-stranal -dsuppress-uniques']) # We care about the Arity 2 on eta, as a result of the annotated Dmd test('T18894b', [ grep_errmsg(r'Arity=2') ], compile, ['-ddump-stranal -dsuppress-uniques -fno-call-arity -dppr-cols=200']) +# We care about the workers of f,g,h,i: +test('T18982', [ grep_errmsg(r'\$w. .*Int#$') ], compile, ['-dppr-cols=1000 -ddump-simpl -dsuppress-idinfo -dsuppress-uniques']) |