1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
|
{-# LANGUAGE TupleSections #-}
module RewritePerfPlugin where
-- Testing performance of rewriting type-family applications.
-- ghc
import GHC.Core
( Expr(Coercion) )
import GHC.Core.Coercion
( mkUnivCo )
import GHC.Core.TyCo.Rep
( Type, UnivCoProvenance(PluginProv) )
import GHC.Core.TyCon
( TyCon )
import GHC.Core.Type
( eqType, mkTyConApp, splitTyConApp_maybe )
import GHC.Plugins
( Plugin(..), defaultPlugin, purePlugin )
import GHC.Tc.Plugin
( TcPluginM
, findImportedModule, lookupOrig
, tcLookupClass, tcLookupDataCon, tcLookupTyCon
, unsafeTcPluginTcM
)
import GHC.Tc.Types
( TcPlugin(..)
, TcPluginSolveResult(..), TcPluginRewriteResult(..)
, TcPluginRewriter, RewriteEnv
)
import GHC.Tc.Types.Constraint
( Ct(..), CanEqLHS(..)
, ctPred
)
import GHC.Types.Name.Occurrence
( mkTcOcc )
import GHC.Types.Unique.FM
( UniqFM, listToUFM )
import GHC.Unit.Finder
( FindResult(..) )
import GHC.Unit.Module
( Module
, mkModuleName
)
--------------------------------------------------------------------------------
-- In this test, we write a plugin which returns "TcPluginNoRewrite"
-- for all the type families in RewritePerfDefs.
--
-- Comparing the result with T9872b gives an indication of the performance
-- impact of rewriting plugins in code that heavily rewrites type families.
type PluginDefs = [ TyCon ]
definitionsModule :: TcPluginM Module
definitionsModule = do
findResult <- findImportedModule ( mkModuleName "RewritePerfDefs" ) Nothing
case findResult of
Found _ res -> pure res
FoundMultiple _ -> error $ "RewritePerfPlugin: found multiple modules named 'RewritePerfDefs'."
_ -> error $ "RewritePerfPlugin: could not find any module named 'RewritePerfDefs'."
lookupDefs :: TcPluginM PluginDefs
lookupDefs = do
defs <- definitionsModule
traverse ( \ tyConName -> lookupOrig defs ( mkTcOcc tyConName ) >>= tcLookupTyCon )
[ "And", "NE", "EQ", "All", "ListConcat", "AppendIf", "Apply"
, "Map", "MapAppend", "MapAppend2", "MapAppend3"
, "Iterate2", "Iterate3", "Iterate4"
, "Orientations", "Compatible", "Allowed"
, "MatchingOrientations", "AllowedCombinations"
, "Solutions"
]
plugin :: Plugin
plugin =
defaultPlugin
{ tcPlugin = \ _args -> Just $ rewritingPlugin
, pluginRecompile = purePlugin
}
rewritingPlugin :: TcPlugin
rewritingPlugin =
TcPlugin
{ tcPluginInit = lookupDefs
, tcPluginSolve = \ _ _ _ _ _ -> pure $ TcPluginOk [] []
, tcPluginRewrite = rewriter
, tcPluginStop = \ _ -> pure ()
}
rewriter :: PluginDefs -> UniqFM TyCon TcPluginRewriter
rewriter tyCons =
listToUFM $ map ( , don'tRewrite ) tyCons
don'tRewrite :: RewriteEnv -> [ Ct ] -> [ Type ] -> TcPluginM TcPluginRewriteResult
don'tRewrite _ _ _ = pure TcPluginNoRewrite
|
