... |
... |
@@ -20,7 +20,6 @@ import GHC.Core.Make |
20
|
20
|
import GHC.Core.Predicate
|
21
|
21
|
import GHC.Core.Type
|
22
|
22
|
import GHC.Core.Utils
|
23
|
|
-import GHC.Tc.Utils.TcType
|
24
|
23
|
import GHC.Types.Id
|
25
|
24
|
import GHC.Types.Name
|
26
|
25
|
import GHC.Types.SrcLoc
|
... |
... |
@@ -29,6 +28,41 @@ import GHC.Types.Var |
29
|
28
|
|
30
|
29
|
type OverloadedCallsCCState = Strict.Maybe SrcSpan
|
31
|
30
|
|
|
31
|
+{- Note [Overloaded Calls and join points]
|
|
32
|
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
33
|
+Currently GHC considers cost centres as destructive to
|
|
34
|
+join contexts. Or in other words this is not considered valid:
|
|
35
|
+
|
|
36
|
+ join f x = ...
|
|
37
|
+ in
|
|
38
|
+ ... -> scc<tick> jmp
|
|
39
|
+
|
|
40
|
+This makes the functionality of `-fprof-late-overloaded-calls` not feasible
|
|
41
|
+for join points in general. We used to try to work around this by putting the
|
|
42
|
+ticks on the rhs of the join point rather than around the jump. However beyond
|
|
43
|
+the loss of accuracy this was broken for recursive join points as we ended up
|
|
44
|
+with something like:
|
|
45
|
+
|
|
46
|
+ rec-join f x = scc<tick> ... jmp f x
|
|
47
|
+
|
|
48
|
+Which similarly is not valid as the tick once again destroys the tail call.
|
|
49
|
+One might think we could limit ourselves to non-recursive tail calls and do
|
|
50
|
+something clever like:
|
|
51
|
+
|
|
52
|
+ join f x = scc<tick> ...
|
|
53
|
+ in ... jmp f x
|
|
54
|
+
|
|
55
|
+And sometimes this works! But sometimes the full rhs would look something like:
|
|
56
|
+
|
|
57
|
+ join g x = ....
|
|
58
|
+ join f x = scc<tick> ... -> jmp g x
|
|
59
|
+
|
|
60
|
+Which, would again no longer be valid. I believe in the long run we can make
|
|
61
|
+cost centre ticks non-destructive to join points. Or we could keep track of
|
|
62
|
+where we are/are not allowed to insert a cost centre. But in the short term I will
|
|
63
|
+simply disable the annotation of join calls under this flag.
|
|
64
|
+-}
|
|
65
|
+
|
32
|
66
|
-- | Insert cost centres on function applications with dictionary arguments. The
|
33
|
67
|
-- source locations attached to the cost centres is approximated based on the
|
34
|
68
|
-- "closest" source note encountered in the traversal.
|
... |
... |
@@ -52,21 +86,10 @@ overloadedCallsCC = |
52
|
86
|
CoreBndr
|
53
|
87
|
-> LateCCM OverloadedCallsCCState CoreExpr
|
54
|
88
|
-> LateCCM OverloadedCallsCCState CoreExpr
|
55
|
|
- wrap_if_join b pexpr = do
|
|
89
|
+ wrap_if_join _b pexpr = do
|
|
90
|
+ -- See Note [Overloaded Calls and join points]
|
56
|
91
|
expr <- pexpr
|
57
|
|
- if isJoinId b && isOverloadedTy (exprType expr) then do
|
58
|
|
- let
|
59
|
|
- cc_name :: FastString
|
60
|
|
- cc_name = fsLit "join-rhs-" `appendFS` getOccFS b
|
61
|
|
-
|
62
|
|
- cc_srcspan <-
|
63
|
|
- fmap (Strict.fromMaybe (UnhelpfulSpan UnhelpfulNoLocationInfo)) $
|
64
|
|
- lift $ gets lateCCState_extra
|
65
|
|
-
|
66
|
|
- insertCC cc_name cc_srcspan expr
|
67
|
|
- else
|
68
|
|
- return expr
|
69
|
|
-
|
|
92
|
+ return expr
|
70
|
93
|
|
71
|
94
|
processExpr :: CoreExpr -> LateCCM OverloadedCallsCCState CoreExpr
|
72
|
95
|
processExpr expr =
|
... |
... |
@@ -99,6 +122,7 @@ overloadedCallsCC = |
99
|
122
|
|
100
|
123
|
-- Avoid instrumenting join points.
|
101
|
124
|
-- (See comment in processBind above)
|
|
125
|
+ -- Also see Note [Overloaded Calls and join points]
|
102
|
126
|
&& not (isJoinVarExpr f)
|
103
|
127
|
then do
|
104
|
128
|
-- Extract a name and source location from the function being
|