diff options
| -rw-r--r-- | compiler/GHC/Core/Opt/DmdAnal.hs | 26 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/WorkWrap/Utils.hs | 20 | ||||
| -rw-r--r-- | compiler/GHC/Types/Demand.hs | 174 | ||||
| -rw-r--r-- | testsuite/tests/stranal/should_compile/T16859.hs | 42 | ||||
| -rw-r--r-- | testsuite/tests/stranal/should_compile/T16859.stderr | 182 | ||||
| -rw-r--r-- | testsuite/tests/stranal/should_compile/T18907.hs | 24 | ||||
| -rw-r--r-- | testsuite/tests/stranal/should_compile/T18907.stderr | 88 | ||||
| -rw-r--r-- | testsuite/tests/stranal/should_compile/all.T | 4 |
8 files changed, 465 insertions, 95 deletions
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index 413da0794a..d876c0fdf4 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -20,7 +20,7 @@ where import GHC.Prelude import GHC.Core.Opt.WorkWrap.Utils -import GHC.Types.Demand -- All of it +import GHC.Types.Demand import GHC.Core import GHC.Core.Multiplicity ( scaledThing ) import GHC.Utils.Outputable @@ -430,7 +430,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) | is_single_data_alt alt = let (rhs_ty, rhs') = dmdAnal env dmd rhs - (alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs + (alt_ty1, alt_bndr_dmds) = findBndrsDmds env rhs_ty bndrs (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr -- Evaluation cardinality on the case binder is irrelevant and a no-op. -- What matters is its nested sub-demand! @@ -438,9 +438,10 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) -- Compute demand on the scrutinee (bndrs', scrut_sd) | DataAlt _ <- alt - , id_dmds <- addCaseBndrDmd case_bndr_sd dmds - -- See Note [Demand on scrutinee of a product case] - = (setBndrsDemandInfo bndrs id_dmds, mkProd id_dmds) + -- See Note [Demand on case-alternative binders] in GHC.Types.Demand + , alt_bndr_dmds' <- addCaseBndrDmd case_bndr_sd alt_bndr_dmds + -- See Note [Scrutinee demands and unboxing] in GHC.Types.Demand + = (setBndrsDemandInfo bndrs alt_bndr_dmds', mkScrutProdDmd case_bndr_sd alt_bndr_dmds) | otherwise -- __DEFAULT and literal alts. Simply add demands and discard the -- evaluation cardinality, as we evaluate the scrutinee exactly once. @@ -540,7 +541,7 @@ dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) | (rhs_ty, rhs') <- dmdAnal env dmd rhs , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr - -- See Note [Demand on scrutinee of a product case] + -- See Note [Demand on case-alternative binders] in GHC.Types.Demand id_dmds = addCaseBndrDmd case_bndr_sd dmds = (alt_ty, Alt con (setBndrsDemandInfo bndrs id_dmds) rhs') @@ -641,19 +642,6 @@ to the Divergence lattice, but in practice it turned out to be hard to untaint from 'topDiv' to 'conDiv', leading to bugs, performance regressions and complexity that didn't justify the single fixed testcase T13380c. -Note [Demand on the scrutinee of a product case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When figuring out the demand on the scrutinee of a product case, -we use the demands of the case alternative, i.e. id_dmds. -But note that these include the demand on the case binder; -see Note [Demand on case-alternative binders] in GHC.Types.Demand. -This is crucial. Example: - f x = case x of y { (a,b) -> k y a } -If we just take scrut_demand = U(L,A), then we won't pass x to the -worker, so the worker will rebuild - x = (a, absent-error) -and that'll crash. - Note [Aggregated demand for cardinality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ FIXME: This Note should be named [LetUp vs. LetDown] and probably predates diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index 0a7ef0f3a5..ac056af789 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -548,8 +548,11 @@ mkWWstr dflags fam_envs has_inlineable_prag args , work_fn1 . work_fn2) } {- -Note [Unpacking arguments with product and polymorphic demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Historical Note [Unpacking arguments with product and polymorphic demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note is superseded by Note [Scrutinee demands and unboxing] in +GHC.Types.Demand. The example below may still be of interest, though. + The argument is unpacked in a case if it has a product type and has a strict *and* used demand put on it. I.e., arguments, with demands such as the following ones: @@ -614,23 +617,16 @@ wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataCon wantToUnbox fam_envs has_inlineable_prag ty dmd = case splitArgType_maybe fam_envs ty of Just dcpc@DataConPatContext{ dcpc_dc = dc } - | isStrUsedDmd dmd + | Just sd <- isStrUsedDmd_maybe dmd , let arity = dataConRepArity dc - -- See Note [Unpacking arguments with product and polymorphic demands] - , Just cs <- split_prod_dmd_arity dmd arity + -- See Note [Scrutinee demands and unboxing] in GHC.Types.Demand + , Just cs <- unboxFieldDmds_maybe arity sd -- See Note [Do not unpack class dictionaries] , not (has_inlineable_prag && isClassPred ty) -- See Note [mkWWstr and unsafeCoerce] , cs `lengthIs` arity -> Just (cs, dcpc) _ -> Nothing - where - split_prod_dmd_arity dmd arity - -- For seqDmd, it should behave like <S(AAAA)>, for some - -- suitable arity - | isSeqDmd dmd = Just (replicate arity absDmd) - | _ :* Prod ds <- dmd = Just ds - | otherwise = Nothing unbox_one :: DynFlags -> FamInstEnvs -> Var -> [Demand] diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index 8e2fec9ff6..14c81b403e 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -15,7 +15,7 @@ -- Lays out the abstract domain for "GHC.Core.Opt.DmdAnal". module GHC.Types.Demand ( -- * Demands - Card(..), Demand(..), SubDemand(Prod), mkProd, viewProd, + Card(..), Demand(..), SubDemand(Prod), viewProd, -- ** Algebra absDmd, topDmd, botDmd, seqDmd, topSubDmd, -- *** Least upper bound @@ -26,8 +26,8 @@ module GHC.Types.Demand ( multCard, multDmd, multSubDmd, -- ** Predicates on @Card@inalities and @Demand@s isAbs, isUsedOnce, isStrict, - isAbsDmd, isUsedOnceDmd, isStrUsedDmd, isStrictDmd, - isTopDmd, isSeqDmd, isWeakDmd, + isAbsDmd, isUsedOnceDmd, isStrUsedDmd, isStrUsedDmd_maybe, isStrictDmd, + isTopDmd, isWeakDmd, -- ** Special demands evalDmd, -- *** Demands used in PrimOp signatures @@ -35,7 +35,7 @@ module GHC.Types.Demand ( -- ** Other @Demand@ operations oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, mkWorkerDemand, peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds, - addCaseBndrDmd, + addCaseBndrDmd, mkScrutProdDmd, unboxFieldDmds_maybe, -- ** Extracting one-shot information argOneShots, argsOneShots, saturatedByOneShots, @@ -86,7 +86,7 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Unique.FM import GHC.Types.Basic -import GHC.Data.Maybe ( orElse ) +import GHC.Data.Maybe ( expectJust, orElse ) import GHC.Core.Type ( Type ) import GHC.Core.TyCon ( isNewTyCon, isClassTyCon ) @@ -289,7 +289,9 @@ data SubDemand -- Expands to 'Call' via 'viewCall' and to 'Prod' via 'viewProd'. -- -- @Poly n@ is semantically equivalent to @Prod [n :* Poly n, ...]@ or - -- @Call n (Poly n)@. 'mkCall' and 'mkProd' do these rewrites. + -- @Call n (Poly n)@. 'mkCall' does the rewrite. + -- + -- TODO -- -- In Note [Demand notation]: @U === P(U,U,...)@ and @U === CU(U)@, -- @S === P(S,S,...)@ and @S === CS(S)@, and so on. @@ -329,22 +331,6 @@ polyDmd C_11 = C_11 :* poly11 polyDmd C_1N = C_1N :* poly1N polyDmd C_10 = C_10 :* poly10 --- | A smart constructor for 'Prod', applying rewrite rules along the semantic --- equality @Prod [polyDmd n, ...] === polyDmd n@, simplifying to 'Poly' --- 'SubDemand's when possible. Note that this degrades boxity information! E.g. a --- polymorphic demand will never unbox. -mkProd :: [Demand] -> SubDemand -mkProd [] = seqSubDmd -mkProd ds@(n:*sd : _) - | want_to_simplify n, all (== polyDmd n) ds = sd - | otherwise = Prod ds - where - -- We only want to simplify absent and bottom demands and unbox the others. - -- See also Note [U should win] and Note [Don't optimise UP(U,U,...) to U]. - want_to_simplify C_00 = True - want_to_simplify C_10 = True - want_to_simplify _ = False - -- | @viewProd n sd@ interprets @sd@ as a 'Prod' of arity @n@, expanding 'Poly' -- demands as necessary. viewProd :: Arity -> SubDemand -> Maybe [Demand] @@ -463,10 +449,11 @@ isStrictDmd (n :* _) = isStrict n isStrUsedDmd :: Demand -> Bool isStrUsedDmd (n :* _) = isStrict n && not (isAbs n) -isSeqDmd :: Demand -> Bool -isSeqDmd (C_11 :* sd) = sd == seqSubDmd -isSeqDmd (C_1N :* sd) = sd == seqSubDmd -- I wonder if we need this case. -isSeqDmd _ = False +-- | Version of 'isStrUsedDmd' that returns the 'SubDemand' if True +isStrUsedDmd_maybe :: Demand -> Maybe SubDemand +isStrUsedDmd_maybe (n :* sd) + | isStrict n && not (isAbs n) = Just sd + | otherwise = Nothing -- | Is the value used at most once? isUsedOnceDmd :: Demand -> Bool @@ -577,15 +564,34 @@ mkWorkerDemand n = C_01 :* go n where go 0 = topSubDmd go n = Call C_01 $ go (n-1) -addCaseBndrDmd :: SubDemand -- On the case binder - -> [Demand] -- On the components of the constructor - -> [Demand] -- Final demands for the components of the constructor -addCaseBndrDmd (Poly n) alt_dmds - | isAbs n = alt_dmds --- See Note [Demand on case-alternative binders] -addCaseBndrDmd sd alt_dmds = zipWith plusDmd ds alt_dmds -- fuse ds! +-- | See Note [Demand on case-alternative binders] +addCaseBndrDmd :: SubDemand -- ^ On the case binder + -> [Demand] -- ^ On the alt binders + -> [Demand] -- ^ Final demands for the alt binders +addCaseBndrDmd sd alt_dmds + | Poly n <- sd, isAbs n + = alt_dmds + | otherwise + = zipWith plusDmd ds alt_dmds -- fuse ds! + where + ds = expectJust "sd can't be a Call" $ viewProd (length alt_dmds) sd + +mkScrutProdDmd :: SubDemand -- ^ On the case binder + -> [Demand] -- ^ On the alt binders + -> SubDemand -- ^ Final sub-demand on the scrutinee +mkScrutProdDmd case_bndr_sd alt_bndr_dmds + -- See Note [Scrutinee demands and unboxing] + | all is_dead alt_bndr_dmds = case_bndr_sd + | otherwise = Prod $ addCaseBndrDmd case_bndr_sd alt_bndr_dmds where - Just ds = viewProd (length alt_dmds) sd -- Guaranteed not to be a call + is_dead (n :* _) = isAbs n + +unboxFieldDmds_maybe :: Arity -> SubDemand -> Maybe [Demand] +unboxFieldDmds_maybe arity sd + -- See Note [Scrutinee demands and unboxing] + | Poly n <- sd, isAbs n = Just (replicate arity absDmd) + | Prod ds <- sd = Just ds + | otherwise = Nothing argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]] -- ^ See Note [Computing one-shot info] @@ -677,8 +683,8 @@ is hurt and we can assume that the nested demand is 'botSubDmd'. That ensures that @g@ above actually gets the @SP(U)@ demand on its second pair component, rather than the lazy @1P(U)@ if we 'lub'bed with an absent demand. -Demand on case-alternative binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Demand on case-alternative binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The demand on a binder in a case alternative comes (a) From the demand on the binder itself (b) From the demand on the case binder @@ -706,43 +712,83 @@ consequences play out. This is needed even for non-product types, in case the case-binder is used but the components of the case alternative are not. -Note [Don't optimise UP(U,U,...) to U] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -These two SubDemands: - UP(U,U) (@Prod [topDmd, topDmd]@) and U (@topSubDmd@) -are semantically equivalent, but we do not turn the former into -the latter, for a regrettable-subtle reason. Consider - f p1@(x,y) = (y,x) - g h p2@(_,_) = h p -We want to unbox @p1@ of @f@, but not @p2@ of @g@, because @g@ only uses -@p2@ boxed and we'd have to rebox. So we give @p1@ demand UP(U,U) and @p2@ -demand @U@ to inform 'GHC.Core.Opt.WorkWrap.Utils.wantToUnbox', which will -say "unbox" for @p1@ and "don't unbox" for @p2@. - -So the solution is: don't aggressively collapse @Prod [topDmd, topDmd]@ to -@topSubDmd@; instead leave it as-is. In effect we are using the UseDmd to do a -little bit of boxity analysis. Not very nice. - -Note [U should win] -~~~~~~~~~~~~~~~~~~~ -Both in 'lubSubDmd' and 'plusSubDmd' we want @U `plusSubDmd` UP(..)) to be @U@. -Why? Because U carries the implication the whole thing is used, box and all, -so we don't want to w/w it, cf. Note [Don't optimise UP(U,U,...) to U]. -If we use it both boxed and unboxed, then we are definitely using the box, -and so we are quite likely to pay a reboxing cost. So we make U win here. +Note [Scrutinee demands and unboxing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is the story why we encode boxity information in 'Prod' sub-demands and how +we exploit it in worker/wrapper. Consider (#16859, #18907): +```hs +foo :: Int -> Int -> (Int, Int) +foo x y = x `seq` (x, y) -- don't unbox x + +bar :: Int -> (Int -> Int) -> Int +bar n f = n `seq` f n -- similarly, don't unbox n + +baz :: Int -> Int -> (Int, Int) +baz a b = a `seq` (b, b) -- unbox a + +buz :: (Int, Int) -> (Int, Int) +buz p@(x,y) = (y,x) -- obviously, unbox p +``` +We should not unbox `x`: Although it is used strictly, we don't look +into its field, so there is no point in unboxing. In fact, it's harmful +to unbox `x`, because the returned pair needs `x` boxed, leading to reboxing. + +On the other hand, we *should* unbox `a`! It's only seq'd but not used +further. If we unbox it, the seq ends up in the wrapper and no field +is passed on to the worker, because it is absent. + +We achieve that by enconding *boxity information* in the semantics +of 'Prod'. That is: `SP(U)` means "Strictly used and the field is +used too, so unbox", whereas the otherwise semantically equivalent +'Poly' sub-demand `SU` says "Strictly used and the field *might* be +used too, just not by this function, so better don't unbox". + +Strictness Analysis then has to give `x`, `n` and `a` 'Poly' demands `SU`, `SU` +and `SA`, respectively, while `p` continues to have 'Prod' demand `SP(U,U)`. The +crux is in determining the sub-demand to put the scrutinee under when analysing +Case expressions: 'mkScrutProdDmd' computes that sub-demand, returning a 'Prod' +only when the case binder demand is a 'Prod' or when any of the field binders +was used (as is only the case for `p`), which indicates that unboxing might be +beneficial. + +Now, if WW would strictly follow the rule "Poly means don't unbox", +then it won't unbox `a` either, because it has demand `SA`. But it +sees that actually none of the fields of `a` are used (this test +is done via 'unboxFieldDmds_maybe'), so it unboxes `a` either way, +because then the seq happens in the wrapper and nothing has to be +passed to the worker. + +A corollary is that although `SP(U,U)` and `SU` are semantically equivalent, we +should *not* collapse the former into the latter willy-nilly, because that +affects what we can unbox. + +Coda: Obviously, this approach to boxity analysis is a huge hack, as we can't +differentiate "The fields are used" and "The fields are used, but the box is +also used". We currently interpret the latter (ex: `SP(U)`) as the former. +If we could discern the two, then in the latter case it might be beneficial to +pass both the fields and the box to the worker. This hack has caused a few +hiccups, like #13331, but otherwise served us well. + +Note [Poly should win over Prod] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Both in 'lubSubDmd' and 'plusSubDmd' we want ``SU `plusSubDmd` SP(U))`` to be +`SU`. Why? Because `SU` carries the implication the whole thing is used, box and +all, so we don't want to w/w it, cf. Note [Scrutinee demands and unboxing]. +If we use it both boxed and unboxed, then we are definitely using the box, and +so we are quite likely to pay a reboxing cost. So we make SU win here. TODO: Investigate why since 2013, we don't. Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer -Baseline: (A) Not making Used win (UProd wins) -Compare with: (B) making Used win for lub and both +Baseline: (A) Not making SU win (SP(U) wins) +Compare with: (B) making SU win for lub and plus Min -0.3% -5.6% -10.7% -11.0% -33.3% Max +0.3% +45.6% +11.5% +11.5% +6.9% Geometric Mean -0.0% +0.5% +0.3% +0.2% -0.8% -Baseline: (B) Making Used win for both lub and both -Compare with: (C) making Used win for plus, but UProd win for lub +Baseline: (B) Making SU win for both lub and plus +Compare with: (C) making SU win for plus, but SP(U) win for lub Min -0.1% -0.3% -7.9% -8.0% -6.5% Max +0.1% +1.0% +21.0% +21.0% +0.5% diff --git a/testsuite/tests/stranal/should_compile/T16859.hs b/testsuite/tests/stranal/should_compile/T16859.hs new file mode 100644 index 0000000000..68c8a58812 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/T16859.hs @@ -0,0 +1,42 @@ +module T16859 where + +import GHC.Types.Name (OccName) +import GHC.Types.SrcLoc +import GHC.Types.Unique + +data NameSort = Internal | External + +data Name = Name { + n_sort :: NameSort, -- What sort of name it is + n_occ :: !OccName, -- Its occurrence name + n_uniq :: {-# UNPACK #-} !Unique, + n_loc :: !SrcSpan -- Definition site + } + +{-# NOINLINE mkInternalName #-} +mkInternalName :: Unique -> OccName -> SrcSpan -> Name +mkInternalName uniq occ loc = Name { n_uniq = uniq + , n_sort = Internal + , n_occ = occ + , n_loc = loc } + +-- | Should not unbox `x`. +foo :: Int -> Int -> (Int, Int) +foo x y = x `seq` (x, y) +{-# NOINLINE foo #-} + +-- | Should unbox `x`. +bar :: Int -> Int -> (Int, Int) +bar x y = x `seq` (y, y) +{-# NOINLINE bar #-} + +-- | Should not unbox `x`. +baz :: Int -> Int -> (Int -> Int) -> Int +baz x y f = x `seq` (f x + y) +{-# NOINLINE baz #-} + +-- | Should unbox `p`. +buz :: (Int, Int) -> (Int, Int) +buz p@(x,y) = (y,x) +{-# NOINLINE buz #-} + diff --git a/testsuite/tests/stranal/should_compile/T16859.stderr b/testsuite/tests/stranal/should_compile/T16859.stderr new file mode 100644 index 0000000000..612b5d1140 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/T16859.stderr @@ -0,0 +1,182 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 278, types: 249, coercions: 4, joins: 0/0} + +-- RHS size: {terms: 18, types: 8, coercions: 1, joins: 0/0} +T16859.$WName :: NameSort %1 -> OccName %1 -> Unique %1 -> SrcSpan %1 -> Name +T16859.$WName = \ (dt :: NameSort) (dt :: OccName) (dt :: Unique) (dt :: SrcSpan) -> case dt of dt { __DEFAULT -> case dt `cast` (GHC.Types.Unique.N:Unique[0] :: Unique ~R# Int) of { GHC.Types.I# dt -> case dt of dt { __DEFAULT -> T16859.Name dt dt dt dt } } } + +-- RHS size: {terms: 5, types: 6, coercions: 0, joins: 0/0} +n_loc :: Name -> SrcSpan +n_loc = \ (ds :: Name) -> case ds of { Name ds1 ds2 dt ds3 -> ds3 } + +-- RHS size: {terms: 6, types: 6, coercions: 2, joins: 0/0} +n_uniq :: Name -> Unique +n_uniq = \ (ds :: Name) -> case ds of { Name ds1 ds2 dt ds3 -> (GHC.Types.I# dt) `cast` (Sym (GHC.Types.Unique.N:Unique[0]) :: Int ~R# Unique) } + +-- RHS size: {terms: 5, types: 6, coercions: 0, joins: 0/0} +n_occ :: Name -> OccName +n_occ = \ (ds :: Name) -> case ds of { Name ds1 ds2 dt ds3 -> ds2 } + +-- RHS size: {terms: 5, types: 6, coercions: 0, joins: 0/0} +n_sort :: Name -> NameSort +n_sort = \ (ds :: Name) -> case ds of { Name ds1 ds2 dt ds3 -> ds1 } + +-- RHS size: {terms: 14, types: 15, coercions: 0, joins: 0/0} +T16859.$wmkInternalName :: GHC.Prim.Int# -> OccName -> SrcSpan -> (# NameSort, OccName, GHC.Prim.Int#, SrcSpan #) +T16859.$wmkInternalName = \ (ww :: GHC.Prim.Int#) (w :: OccName) (w1 :: SrcSpan) -> case w of dt { GHC.Types.Name.Occurrence.OccName ipv ipv1 -> case w1 of dt1 { __DEFAULT -> (# T16859.Internal, dt, ww, dt1 #) } } + +-- RHS size: {terms: 17, types: 18, coercions: 1, joins: 0/0} +mkInternalName :: Unique -> OccName -> SrcSpan -> Name +mkInternalName = \ (w :: Unique) (w1 :: OccName) (w2 :: SrcSpan) -> case w `cast` (GHC.Types.Unique.N:Unique[0] :: Unique ~R# Int) of { GHC.Types.I# ww1 -> case T16859.$wmkInternalName ww1 w1 w2 of { (# ww3, ww4, ww5, ww6 #) -> T16859.Name ww3 ww4 ww5 ww6 } } + +-- RHS size: {terms: 8, types: 8, coercions: 0, joins: 0/0} +T16859.$wfoo :: Int -> Int -> (# Int, Int #) +T16859.$wfoo = \ (w :: Int) (w1 :: Int) -> case w of x { GHC.Types.I# ipv -> (# x, w1 #) } + +-- RHS size: {terms: 10, types: 11, coercions: 0, joins: 0/0} +foo :: Int -> Int -> (Int, Int) +foo = \ (w :: Int) (w1 :: Int) -> case T16859.$wfoo w w1 of { (# ww1, ww2 #) -> (ww1, ww2) } + +-- RHS size: {terms: 4, types: 5, coercions: 0, joins: 0/0} +T16859.$wbar :: Int -> (# Int, Int #) +T16859.$wbar = \ (w :: Int) -> (# w, w #) + +-- RHS size: {terms: 12, types: 13, coercions: 0, joins: 0/0} +bar :: Int -> Int -> (Int, Int) +bar = \ (w :: Int) (w1 :: Int) -> case w of { GHC.Types.I# ww1 -> case T16859.$wbar w1 of { (# ww3, ww4 #) -> (ww3, ww4) } } + +-- RHS size: {terms: 5, types: 6, coercions: 0, joins: 0/0} +T16859.$wbuz :: Int -> Int -> (# Int, Int #) +T16859.$wbuz = \ (ww :: Int) (ww1 :: Int) -> (# ww1, ww #) + +-- RHS size: {terms: 12, types: 17, coercions: 0, joins: 0/0} +buz :: (Int, Int) -> (Int, Int) +buz = \ (w :: (Int, Int)) -> case w of { (ww1, ww2) -> case T16859.$wbuz ww1 ww2 of { (# ww4, ww5 #) -> (ww4, ww5) } } + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T16859.$trModule4 :: GHC.Prim.Addr# +T16859.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T16859.$trModule3 :: GHC.Types.TrName +T16859.$trModule3 = GHC.Types.TrNameS T16859.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T16859.$trModule2 :: GHC.Prim.Addr# +T16859.$trModule2 = "T16859"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T16859.$trModule1 :: GHC.Types.TrName +T16859.$trModule1 = GHC.Types.TrNameS T16859.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T16859.$trModule :: GHC.Types.Module +T16859.$trModule = GHC.Types.Module T16859.$trModule3 T16859.$trModule1 + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep :: GHC.Types.KindRep +$krep = GHC.Types.KindRepTyConApp GHC.Types.SrcLoc.$tcSrcSpan (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep1 :: GHC.Types.KindRep +$krep1 = GHC.Types.KindRepTyConApp GHC.Types.Unique.$tcUnique (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep2 :: GHC.Types.KindRep +$krep2 = GHC.Types.KindRepTyConApp GHC.Types.Name.Occurrence.$tcOccName (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T16859.$tcNameSort2 :: GHC.Prim.Addr# +T16859.$tcNameSort2 = "NameSort"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T16859.$tcNameSort1 :: GHC.Types.TrName +T16859.$tcNameSort1 = GHC.Types.TrNameS T16859.$tcNameSort2 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T16859.$tcNameSort :: GHC.Types.TyCon +T16859.$tcNameSort = GHC.Types.TyCon 12401893980286669143## 13108152160491614238## T16859.$trModule T16859.$tcNameSort1 0# GHC.Types.krep$* + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +T16859.$tc'External1 :: GHC.Types.KindRep +T16859.$tc'External1 = GHC.Types.KindRepTyConApp T16859.$tcNameSort (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T16859.$tc'Internal2 :: GHC.Prim.Addr# +T16859.$tc'Internal2 = "'Internal"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T16859.$tc'Internal1 :: GHC.Types.TrName +T16859.$tc'Internal1 = GHC.Types.TrNameS T16859.$tc'Internal2 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T16859.$tc'Internal :: GHC.Types.TyCon +T16859.$tc'Internal = GHC.Types.TyCon 11363474980591478045## 16143980624492238634## T16859.$trModule T16859.$tc'Internal1 0# T16859.$tc'External1 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T16859.$tc'External3 :: GHC.Prim.Addr# +T16859.$tc'External3 = "'External"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T16859.$tc'External2 :: GHC.Types.TrName +T16859.$tc'External2 = GHC.Types.TrNameS T16859.$tc'External3 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T16859.$tc'External :: GHC.Types.TyCon +T16859.$tc'External = GHC.Types.TyCon 15854086861732328093## 8015185116764953966## T16859.$trModule T16859.$tc'External2 0# T16859.$tc'External1 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T16859.$tcName2 :: GHC.Prim.Addr# +T16859.$tcName2 = "Name"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T16859.$tcName1 :: GHC.Types.TrName +T16859.$tcName1 = GHC.Types.TrNameS T16859.$tcName2 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T16859.$tcName :: GHC.Types.TyCon +T16859.$tcName = GHC.Types.TyCon 16573135907244213379## 926532026695774645## T16859.$trModule T16859.$tcName1 0# GHC.Types.krep$* + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep3 :: GHC.Types.KindRep +$krep3 = GHC.Types.KindRepTyConApp T16859.$tcName (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep4 :: GHC.Types.KindRep +$krep4 = GHC.Types.KindRepFun $krep $krep3 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep5 :: GHC.Types.KindRep +$krep5 = GHC.Types.KindRepFun $krep1 $krep4 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep6 :: GHC.Types.KindRep +$krep6 = GHC.Types.KindRepFun $krep2 $krep5 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T16859.$tc'Name1 :: GHC.Types.KindRep +T16859.$tc'Name1 = GHC.Types.KindRepFun T16859.$tc'External1 $krep6 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T16859.$tc'Name3 :: GHC.Prim.Addr# +T16859.$tc'Name3 = "'Name"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T16859.$tc'Name2 :: GHC.Types.TrName +T16859.$tc'Name2 = GHC.Types.TrNameS T16859.$tc'Name3 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T16859.$tc'Name :: GHC.Types.TyCon +T16859.$tc'Name = GHC.Types.TyCon 16701807050114729930## 17238414091700286055## T16859.$trModule T16859.$tc'Name2 0# T16859.$tc'Name1 + +-- RHS size: {terms: 13, types: 8, coercions: 0, joins: 0/0} +T16859.$wbaz :: Int -> GHC.Prim.Int# -> (Int -> Int) -> GHC.Prim.Int# +T16859.$wbaz = \ (w :: Int) (ww :: GHC.Prim.Int#) (w1 :: Int -> Int) -> case w of x { GHC.Types.I# ipv -> case w1 x of { GHC.Types.I# x1 -> GHC.Prim.+# x1 ww } } + +-- RHS size: {terms: 14, types: 7, coercions: 0, joins: 0/0} +baz :: Int -> Int -> (Int -> Int) -> Int +baz = \ (w :: Int) (w1 :: Int) (w2 :: Int -> Int) -> case w1 of { GHC.Types.I# ww1 -> case T16859.$wbaz w ww1 w2 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } } + + + diff --git a/testsuite/tests/stranal/should_compile/T18907.hs b/testsuite/tests/stranal/should_compile/T18907.hs new file mode 100644 index 0000000000..514f87b100 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/T18907.hs @@ -0,0 +1,24 @@ +module T18907 (f, g, h) where + +-- | Should not unbox `x`. +-- But because of Optimistic Case Binder CPR (#19232), we will still CPR f. +f :: (Int, Int) -> (Int, Int) +f x@(_,_) + | sum [0..24::Int] == 1 = x + | otherwise = (0,0) +{-# NOINLINE f #-} + +-- | Ideally, we wouldn't unbox `x`, but we have a field demand on `p`, which +-- indicates that we should unbox. +g :: (Int, Int) -> (Int, Int) +g x@(p,_) = p `seq` x +{-# NOINLINE g #-} + +seq' a b = seq a b +{-# NOINLINE seq' #-} + +-- | Should not unbox `y`. +h :: Int -> Int -> Int +h x y = (x+1) `seq'` y +{-# NOINLINE h #-} + diff --git a/testsuite/tests/stranal/should_compile/T18907.stderr b/testsuite/tests/stranal/should_compile/T18907.stderr new file mode 100644 index 0000000000..55ebd82ad5 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/T18907.stderr @@ -0,0 +1,88 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 114, types: 118, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 8, types: 8, coercions: 0, joins: 0/0} +T18907.$wg :: Int -> Int -> (# Int, Int #) +T18907.$wg = \ (ww :: Int) (ww1 :: Int) -> case ww of p { GHC.Types.I# ipv -> (# p, ww1 #) } + +-- RHS size: {terms: 12, types: 17, coercions: 0, joins: 0/0} +g :: (Int, Int) -> (Int, Int) +g = \ (w :: (Int, Int)) -> case w of { (ww1, ww2) -> case T18907.$wg ww1 ww2 of { (# ww4, ww5 #) -> (ww4, ww5) } } + +-- RHS size: {terms: 8, types: 5, coercions: 0, joins: 0/0} +seq' :: forall {a} {b}. a -> b -> b +seq' = \ (@a) (@b) (a1 :: a) (b1 :: b) -> case a1 of { __DEFAULT -> b1 } + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18907.$trModule4 :: GHC.Prim.Addr# +T18907.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18907.$trModule3 :: GHC.Types.TrName +T18907.$trModule3 = GHC.Types.TrNameS T18907.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18907.$trModule2 :: GHC.Prim.Addr# +T18907.$trModule2 = "T18907"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18907.$trModule1 :: GHC.Types.TrName +T18907.$trModule1 = GHC.Types.TrNameS T18907.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T18907.$trModule :: GHC.Types.Module +T18907.$trModule = GHC.Types.Module T18907.$trModule3 T18907.$trModule1 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl :: Int +lvl = GHC.Types.I# 1# + +-- RHS size: {terms: 4, types: 3, coercions: 0, joins: 0/0} +T18907.$wh :: Int -> Int +T18907.$wh = \ (w :: Int) -> seq' @Int @Int lvl w + +-- RHS size: {terms: 7, types: 4, coercions: 0, joins: 0/0} +h :: Int -> Int -> Int +h = \ (w :: Int) (w1 :: Int) -> case w of { GHC.Types.I# ww1 -> T18907.$wh w1 } + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl1 :: Int +lvl1 = GHC.Types.I# 0# + +Rec { +-- RHS size: {terms: 16, types: 3, coercions: 0, joins: 0/0} +$wgo3 :: GHC.Prim.Int# -> GHC.Prim.Int# -> GHC.Prim.Int# +$wgo3 + = \ (w :: GHC.Prim.Int#) (ww :: GHC.Prim.Int#) -> + case w of wild { + __DEFAULT -> $wgo3 (GHC.Prim.+# wild 1#) (GHC.Prim.+# ww wild); + 24# -> GHC.Prim.+# ww 24# + } +end Rec } + +-- RHS size: {terms: 8, types: 1, coercions: 0, joins: 0/0} +lvl2 :: Bool +lvl2 + = case $wgo3 0# 0# of { + __DEFAULT -> GHC.Types.False; + 1# -> GHC.Types.True + } + +-- RHS size: {terms: 14, types: 17, coercions: 0, joins: 0/0} +T18907.$wf :: (Int, Int) -> (# Int, Int #) +T18907.$wf + = \ (w :: (Int, Int)) -> + case w of { (ds, ds1) -> + case lvl2 of { + False -> (# lvl1, lvl1 #); + True -> (# ds, ds1 #) + } + } + +-- RHS size: {terms: 8, types: 12, coercions: 0, joins: 0/0} +f :: (Int, Int) -> (Int, Int) +f = \ (w :: (Int, Int)) -> case T18907.$wf w of { (# ww1, ww2 #) -> (ww1, ww2) } + + + diff --git a/testsuite/tests/stranal/should_compile/all.T b/testsuite/tests/stranal/should_compile/all.T index 3e77a602ae..10439b8f65 100644 --- a/testsuite/tests/stranal/should_compile/all.T +++ b/testsuite/tests/stranal/should_compile/all.T @@ -58,6 +58,10 @@ test('T18122', [ grep_errmsg(r'wfoo =') ], compile, ['-ddump-simpl']) # We care about the call demand on $wg test('T18903', [ grep_errmsg(r'Dmd=\S+C\S+') ], compile, ['-ddump-simpl -dsuppress-uniques']) +# We care about the type of the workers of f and g +test('T18907', [ grep_errmsg(r'\$w\w+ ::') ], compile, ['-dppr-cols=1000 -ddump-simpl -dsuppress-idinfo -dsuppress-uniques']) +# We care about the worker of mkInternalName and foo: +test('T16859', [ grep_errmsg(r'\$w\w+ ::') ], compile, ['-dppr-cols=1000 -ddump-simpl -dsuppress-idinfo -dsuppress-uniques -package ghc']) # We care about the call demand on $wg1 and $wg2 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 |