Ticket #8095: fomit-type-family-coercions.patch

File fomit-type-family-coercions.patch, 8.5 KB (added by mbieleck, 19 months ago)
  • compiler/main/DynFlags.hs

    diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
    index 2be121e..6bde1ed 100644
    a b data GeneralFlag 
    525525   | Opt_OptimalApplicativeDo
    526526   | Opt_VersionMacros
    527527   | Opt_WholeArchiveHsLibs
     528   | Opt_OmitTypeFamilyCoercions -- replace coercions resulting from type
     529                                 -- family flattening with UnivCo
    528530
    529531   -- PreInlining is on by default. The option is there just to see how
    530532   -- bad things get if you turn it off!
    fFlagsDeps = [ 
    37363738  flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage,
    37373739  flagSpec "loopification"                    Opt_Loopification,
    37383740  flagSpec "omit-interface-pragmas"           Opt_OmitInterfacePragmas,
     3741  flagSpec "omit-type-family-coercions"       Opt_OmitTypeFamilyCoercions,
    37393742  flagSpec "omit-yields"                      Opt_OmitYields,
    37403743  flagSpec "optimal-applicative-do"           Opt_OptimalApplicativeDo,
    37413744  flagSpec "pedantic-bottoms"                 Opt_PedanticBottoms,
  • compiler/typecheck/TcFlatten.hs

    diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs
    index 1bb4a71..b4952a9 100644
    a b module TcFlatten( 
    99
    1010#include "HsVersions.h"
    1111
     12import DynFlags
    1213import TcRnTypes
    1314import TcType
    1415import Type
    flatten_fam_app tc tys -- Can be over-saturated 
    11451146               -- all Nominal roles b/c the tycon is oversaturated
    11461147         ; (xis_rest, cos_rest) <- flatten_many (repeat Nominal) tys_rest
    11471148               -- cos_res :: xis_rest ~ tys_rest
    1148 
    1149          ; return ( mkAppTys xi1 xis_rest   -- NB mkAppTys: rhs_xi might not be a type variable
    1150                                             --    cf Trac #5655
    1151                   , mkAppCos co1 cos_rest
     1149         ; let ty' = mkAppTys xi1 xis_rest -- NB mkAppTys: rhs_xi might not be a type variable
     1150                                           --    cf Trac #5655
     1151         ; omitTypeFamilyCoercionsEnabled <-
     1152             gopt Opt_OmitTypeFamilyCoercions <$> liftTcS getDynFlags
     1153         ; if omitTypeFamilyCoercionsEnabled
     1154             then do { orig_ty_zonked <- liftTcS $ zonkTcType $ mkTyConApp tc tys
     1155                     ; role <- getRole
     1156                     ; return (ty', mkUnsafeCo role ty' orig_ty_zonked) }
     1157             else return ( ty'
     1158                         , mkAppCos co1 cos_rest
    11521159                            -- (rhs_xi :: F xis) ; (F cos :: F xis ~ F tys)
    1153                   ) }
     1160                         ) }
    11541161
    11551162flatten_exact_fam_app, flatten_exact_fam_app_fully ::
    11561163  TyCon -> [TcType] -> FlatM (Xi, Coercion)
  • new file testsuite/tests/typecheck/should_compile/OmitTyFamCoercions.hs

    diff --git a/testsuite/tests/typecheck/should_compile/OmitTyFamCoercions.hs b/testsuite/tests/typecheck/should_compile/OmitTyFamCoercions.hs
    new file mode 100644
    index 0000000..533b35f
    - +  
     1{-# LANGUAGE TypeFamilies, DataKinds #-}
     2{-# OPTIONS_GHC -fomit-type-family-coercions #-}
     3module OmitTyFamCoercions where
     4
     5data N = Z | S N
     6
     7type family Countdown n where
     8  Countdown (S k) = Countdown k
     9  Countdown Z = Int
     10
     11-- The test checks that the long chain of coercions from reducing
     12-- `Countdown` is not present in Core
     13foo :: Countdown (S(S(S(S(S(S(S(S(S(S Z)))))))))) -> Int
     14foo = id
  • new file testsuite/tests/typecheck/should_compile/OmitTyFamCoercions.stderr

    diff --git a/testsuite/tests/typecheck/should_compile/OmitTyFamCoercions.stderr b/testsuite/tests/typecheck/should_compile/OmitTyFamCoercions.stderr
    new file mode 100644
    index 0000000..5ff4482
    - +  
     1
     2==================== Tidy Core ====================
     3Result size of Tidy Core
     4  = {terms: 63, types: 31, coercions: 17, joins: 0/0}
     5
     6-- RHS size: {terms: 1, types: 1, coercions: 17, joins: 0/0}
     7foo
     8  :: Countdown ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))
     9     -> Int
     10[GblId]
     11foo
     12  = (id @ Int)
     13    `cast` (UnsafeCo representational
     14              Int
     15              (Countdown ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z)))))))))))
     16            -> <Int>_R
     17            :: (Int -> Int :: *)
     18               ~R# (Countdown ('S ('S ('S ('S ('S ('S ('S ('S ('S ('S 'Z))))))))))
     19                    -> Int :: *))
     20
     21-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
     22$trModule1_rTi :: GHC.Prim.Addr#
     23[GblId, Caf=NoCafRefs]
     24$trModule1_rTi = "main"#
     25
     26-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
     27$trModule2_rTz :: GHC.Types.TrName
     28[GblId, Caf=NoCafRefs]
     29$trModule2_rTz = GHC.Types.TrNameS $trModule1_rTi
     30
     31-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
     32$trModule3_rTA :: GHC.Prim.Addr#
     33[GblId, Caf=NoCafRefs]
     34$trModule3_rTA = "OmitTyFamCoercions"#
     35
     36-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
     37$trModule4_rTB :: GHC.Types.TrName
     38[GblId, Caf=NoCafRefs]
     39$trModule4_rTB = GHC.Types.TrNameS $trModule3_rTA
     40
     41-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
     42OmitTyFamCoercions.$trModule :: GHC.Types.Module
     43[GblId, Caf=NoCafRefs]
     44OmitTyFamCoercions.$trModule
     45  = GHC.Types.Module $trModule2_rTz $trModule4_rTB
     46
     47-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
     48$tcN1_rTC :: GHC.Prim.Addr#
     49[GblId, Caf=NoCafRefs]
     50$tcN1_rTC = "N"#
     51
     52-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
     53$tcN2_rTD :: GHC.Types.TrName
     54[GblId, Caf=NoCafRefs]
     55$tcN2_rTD = GHC.Types.TrNameS $tcN1_rTC
     56
     57-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
     58OmitTyFamCoercions.$tcN :: GHC.Types.TyCon
     59[GblId]
     60OmitTyFamCoercions.$tcN
     61  = GHC.Types.TyCon
     62      10986362045750609911##
     63      17252763998195801839##
     64      OmitTyFamCoercions.$trModule
     65      $tcN2_rTD
     66      0#
     67      GHC.Types.krep$*
     68
     69-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
     70$krep_rTE :: GHC.Types.KindRep
     71[GblId]
     72$krep_rTE
     73  = GHC.Types.KindRepTyConApp
     74      OmitTyFamCoercions.$tcN (GHC.Types.[] @ GHC.Types.KindRep)
     75
     76-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
     77$tc'Z1_rTF :: GHC.Prim.Addr#
     78[GblId, Caf=NoCafRefs]
     79$tc'Z1_rTF = "'Z"#
     80
     81-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
     82$tc'Z2_rTG :: GHC.Types.TrName
     83[GblId, Caf=NoCafRefs]
     84$tc'Z2_rTG = GHC.Types.TrNameS $tc'Z1_rTF
     85
     86-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
     87OmitTyFamCoercions.$tc'Z :: GHC.Types.TyCon
     88[GblId]
     89OmitTyFamCoercions.$tc'Z
     90  = GHC.Types.TyCon
     91      4644564235544244111##
     92      10926620795288904532##
     93      OmitTyFamCoercions.$trModule
     94      $tc'Z2_rTG
     95      0#
     96      $krep_rTE
     97
     98-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
     99$krep1_rTH :: GHC.Types.KindRep
     100[GblId]
     101$krep1_rTH = GHC.Types.KindRepFun $krep_rTE $krep_rTE
     102
     103-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
     104$tc'S1_rTI :: GHC.Prim.Addr#
     105[GblId, Caf=NoCafRefs]
     106$tc'S1_rTI = "'S"#
     107
     108-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
     109$tc'S2_rTJ :: GHC.Types.TrName
     110[GblId, Caf=NoCafRefs]
     111$tc'S2_rTJ = GHC.Types.TrNameS $tc'S1_rTI
     112
     113-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
     114OmitTyFamCoercions.$tc'S :: GHC.Types.TyCon
     115[GblId]
     116OmitTyFamCoercions.$tc'S
     117  = GHC.Types.TyCon
     118      12843356727716621616##
     119      10217746361553368891##
     120      OmitTyFamCoercions.$trModule
     121      $tc'S2_rTJ
     122      0#
     123      $krep1_rTH
     124
     125
     126
  • testsuite/tests/typecheck/should_compile/all.T

    diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
    index d6aaef5..ee7cd7f 100644
    a b test('T13822', normal, compile, ['']) 
    567567test('T13871', normal, compile, [''])
    568568test('T13879', normal, compile, [''])
    569569test('T13881', normal, compile, [''])
     570test('OmitTyFamCoercions', normal, compile, ['-ddump-simpl'])
  • utils/mkUserGuidePart/Options/Language.hs

    diff --git a/utils/mkUserGuidePart/Options/Language.hs b/utils/mkUserGuidePart/Options/Language.hs
    index e584d2f..4b7048a 100644
    a b languageOptions = 
    4545         , flagDescription = "Deprecated. Use ``-freduction-depth=⟨n⟩`` instead."
    4646         , flagType = DynamicFlag
    4747         }
     48  , flag { flagName = "-fomit-type-family-coercions"
     49         , flagDescription =
     50           "Remove big coercions generated by reducing type families during "++
     51           "type checking. Should speed up the compilation of code "++
     52           "heavily using type-level computation."
     53         , flagType = DynamicFlag
     54         }
    4855  , flag { flagName = "-XAllowAmbiguousTypes"
    4956         , flagDescription =
    5057           "Allow the user to write :ref:`ambiguous types <ambiguity>`, and "++