diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2021-11-15 23:22:06 -0500 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2021-11-16 08:55:07 -0500 |
| commit | fc4d8f1e72cf6aaa7d1bacafa201e3553a63d93a (patch) | |
| tree | 672569f812aae2ccf20c5251fd20524139dcdce7 /compiler/GHC/Core/Lint.hs | |
| parent | cc635da167fdec2dead0603b0026cb841f0aa645 (diff) | |
| download | haskell-wip/T20541.tar.gz | |
Increase type sharingwip/T20541
Fixes #20541 by making mkTyConApp do more sharing of types.
In particular, replace
* BoxedRep Lifted ==> LiftedRep
* BoxedRep Unlifted ==> UnliftedRep
* TupleRep '[] ==> ZeroBitRep
* TYPE ZeroBitRep ==> ZeroBitType
In each case, the thing on the right is a type synonym
for the thing on the left, declared in ghc-prim:GHC.Types.
See Note [Using synonyms to compress types] in GHC.Core.Type.
The synonyms for ZeroBitRep and ZeroBitType are new, but absolutely
in the same spirit as the other ones. (These synonyms are mainly
for internal use, though the programmer can use them too.)
I also renamed GHC.Core.Ty.Rep.isVoidTy to isZeroBitTy, to be
compatible with the "zero-bit" nomenclature above. See discussion
on !6806.
There is a tricky wrinkle: see GHC.Core.Types
Note [Care using synonyms to compress types]
Compiler allocation decreases by up to 0.8%.
Diffstat (limited to 'compiler/GHC/Core/Lint.hs')
| -rw-r--r-- | compiler/GHC/Core/Lint.hs | 9 |
1 files changed, 4 insertions, 5 deletions
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 7e3b472a95..899ba20fb0 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -1272,13 +1272,12 @@ lintTyApp fun_ty arg_ty lintValApp :: CoreExpr -> LintedType -> LintedType -> UsageEnv -> UsageEnv -> LintM (LintedType, UsageEnv) lintValApp arg fun_ty arg_ty fun_ue arg_ue | Just (w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty - = do { ensureEqTys arg_ty' arg_ty err1 + = do { ensureEqTys arg_ty' arg_ty (mkAppMsg arg_ty' arg_ty arg) ; let app_ue = addUE fun_ue (scaleUE w arg_ue) ; return (res_ty', app_ue) } | otherwise = failWithL err2 where - err1 = mkAppMsg fun_ty arg_ty arg err2 = mkNonFunAppMsg fun_ty arg_ty arg lintTyKind :: OutTyVar -> LintedType -> LintM () @@ -3099,10 +3098,10 @@ mkNewTyDataConAltMsg scrut_ty alt -- Other error messages mkAppMsg :: Type -> Type -> CoreExpr -> SDoc -mkAppMsg fun_ty arg_ty arg +mkAppMsg expected_arg_ty actual_arg_ty arg = vcat [text "Argument value doesn't match argument type:", - hang (text "Fun type:") 4 (ppr fun_ty), - hang (text "Arg type:") 4 (ppr arg_ty), + hang (text "Expected arg type:") 4 (ppr expected_arg_ty), + hang (text "Actual arg type:") 4 (ppr actual_arg_ty), hang (text "Arg:") 4 (ppr arg)] mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc |