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
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
|
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[DsBinds]{Pattern-matching bindings (HsBinds and MonoBinds)}
Handles @HsBinds@; those at the top level require different handling,
in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
lower levels it is preserved with @let@/@letrec@s).
\begin{code}
module DsBinds ( dsHsBinds, dsHsNestedBinds, AutoScc(..) ) where
#include "HsVersions.h"
import {-# SOURCE #-} DsExpr( dsLExpr )
import {-# SOURCE #-} Match( matchWrapper )
import DsMonad
import DsGRHSs ( dsGuarded )
import DsUtils
import HsSyn -- lots of things
import CoreSyn -- lots of things
import CoreUtils ( exprType, mkInlineMe, mkSCC )
import CmdLineOpts ( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs )
import CostCentre ( mkAutoCC, IsCafCC(..) )
import Id ( idType, idName, isExportedId, isSpecPragmaId, Id )
import NameSet
import VarSet
import Type ( mkTyVarTy, substTyWith )
import TysWiredIn ( voidTy )
import Outputable
import SrcLoc ( Located(..) )
import Maybe ( isJust )
import Bag ( bagToList )
import Monad ( foldM )
\end{code}
%************************************************************************
%* *
\subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
%* *
%************************************************************************
\begin{code}
dsHsNestedBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
dsHsNestedBinds binds = dsHsBinds NoSccs binds []
dsHsBinds :: AutoScc -- scc annotation policy (see below)
-> LHsBinds Id
-> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
-> DsM [(Id,CoreExpr)] -- Result
dsHsBinds auto_scc binds rest
= foldM (dsLHsBind auto_scc) rest (bagToList binds)
dsLHsBind :: AutoScc
-> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
-> LHsBind Id
-> DsM [(Id,CoreExpr)] -- Result
dsLHsBind auto_scc rest (L loc bind)
= putSrcSpanDs loc $ dsHsBind auto_scc rest bind
dsHsBind :: AutoScc
-> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
-> HsBind Id
-> DsM [(Id,CoreExpr)] -- Result
dsHsBind auto_scc rest (VarBind var expr)
= dsLExpr expr `thenDs` \ core_expr ->
-- Dictionary bindings are always VarMonoBinds, so
-- we only need do this here
addDictScc var core_expr `thenDs` \ core_expr' ->
let
-- Gross hack to prevent inlining into SpecPragmaId rhss
-- Consider fromIntegral = fromInteger . toInteger
-- spec1 = fromIntegral Int Float
-- Even though fromIntegral is small we don't want to inline
-- it inside spec1, so that we collect the specialised call
-- Solution: make spec1 an INLINE thing.
core_expr'' = mkInline (isSpecPragmaId var) core_expr'
in
returnDs ((var, core_expr'') : rest)
dsHsBind auto_scc rest (FunBind (L _ fun) _ matches)
= matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) ->
addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair ->
returnDs (pair : rest)
dsHsBind auto_scc rest (PatBind pat grhss ty)
= dsGuarded grhss ty `thenDs` \ body_expr ->
mkSelectorBinds pat body_expr `thenDs` \ sel_binds ->
mappM (addAutoScc auto_scc) sel_binds `thenDs` \ sel_binds ->
returnDs (sel_binds ++ rest)
-- Common special case: no type or dictionary abstraction
-- For the (rare) case when there are some mixed-up
-- dictionary bindings (for which a Rec is convenient)
-- we reply on the enclosing dsBind to wrap a Rec around.
dsHsBind auto_scc rest (AbsBinds [] [] exports inlines binds)
= dsHsBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
let
core_prs' = addLocalInlines exports inlines core_prs
exports' = [(global, Var local) | (_, global, local) <- exports]
in
returnDs (core_prs' ++ exports' ++ rest)
-- Another common case: one exported variable
-- Non-recursive bindings come through this way
dsHsBind auto_scc rest
(AbsBinds all_tyvars dicts exps@[(tyvars, global, local)] inlines binds)
= ASSERT( all (`elem` tyvars) all_tyvars )
dsHsBinds (addSccs auto_scc exps) binds [] `thenDs` \ core_prs ->
let
-- Always treat the binds as recursive, because the typechecker
-- makes rather mixed-up dictionary bindings
core_bind = Rec core_prs
-- The mkInline does directly what the
-- addLocalInlines do in the other cases
export' = (global, mkInline (idName global `elemNameSet` inlines) $
mkLams tyvars $ mkLams dicts $
Let core_bind (Var local))
in
returnDs (export' : rest)
dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports inlines binds)
= dsHsBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
let
-- Rec because of mixed-up dictionary bindings
core_bind = Rec (addLocalInlines exports inlines core_prs)
tup_expr = mkTupleExpr locals
tup_ty = exprType tup_expr
poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
Let core_bind tup_expr
locals = [local | (_, _, local) <- exports]
local_tys = map idType locals
in
newSysLocalDs (exprType poly_tup_expr) `thenDs` \ poly_tup_id ->
let
dict_args = map Var dicts
mk_bind ((tyvars, global, local), n) -- locals !! n == local
= -- Need to make fresh locals to bind in the selector, because
-- some of the tyvars will be bound to voidTy
newSysLocalsDs (map substitute local_tys) `thenDs` \ locals' ->
newSysLocalDs (substitute tup_ty) `thenDs` \ tup_id ->
returnDs (global, mkLams tyvars $ mkLams dicts $
mkTupleSelector locals' (locals' !! n) tup_id $
mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args)
where
mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
| otherwise = voidTy
ty_args = map mk_ty_arg all_tyvars
substitute = substTyWith all_tyvars ty_args
in
mappM mk_bind (exports `zip` [0..]) `thenDs` \ export_binds ->
-- don't scc (auto-)annotate the tuple itself.
returnDs ((poly_tup_id, poly_tup_expr) : (export_binds ++ rest))
\end{code}
%************************************************************************
%* *
\subsection{Adding inline pragmas}
%* *
%************************************************************************
\begin{code}
mkInline :: Bool -> CoreExpr -> CoreExpr
mkInline True body = mkInlineMe body
mkInline False body = body
addLocalInlines :: [(a, Id, Id)] -> NameSet -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
addLocalInlines exports inlines pairs
= [(bndr, mkInline (bndr `elemVarSet` local_inlines) rhs) | (bndr,rhs) <- pairs]
where
local_inlines = mkVarSet [l | (_,g,l) <- exports, idName g `elemNameSet` inlines]
\end{code}
%************************************************************************
%* *
\subsection[addAutoScc]{Adding automatic sccs}
%* *
%************************************************************************
\begin{code}
data AutoScc
= TopLevel
| TopLevelAddSccs (Id -> Maybe Id)
| NoSccs
addSccs :: AutoScc -> [(a,Id,Id)] -> AutoScc
addSccs auto_scc@(TopLevelAddSccs _) exports = auto_scc
addSccs NoSccs exports = NoSccs
addSccs TopLevel exports
= TopLevelAddSccs (\id -> case [ exp | (_,exp,loc) <- exports, loc == id ] of
(exp:_) | opt_AutoSccsOnAllToplevs ||
(isExportedId exp &&
opt_AutoSccsOnExportedToplevs)
-> Just exp
_ -> Nothing)
addAutoScc :: AutoScc -- if needs be, decorate toplevs?
-> (Id, CoreExpr)
-> DsM (Id, CoreExpr)
addAutoScc (TopLevelAddSccs auto_scc_fn) pair@(bndr, core_expr)
| do_auto_scc
= getModuleDs `thenDs` \ mod ->
returnDs (bndr, mkSCC (mkAutoCC top_bndr mod NotCafCC) core_expr)
where do_auto_scc = isJust maybe_auto_scc
maybe_auto_scc = auto_scc_fn bndr
(Just top_bndr) = maybe_auto_scc
addAutoScc _ pair
= returnDs pair
\end{code}
If profiling and dealing with a dict binding,
wrap the dict in @_scc_ DICT <dict>@:
\begin{code}
addDictScc var rhs = returnDs rhs
{- DISABLED for now (need to somehow make up a name for the scc) -- SDM
| not ( opt_SccProfilingOn && opt_AutoSccsOnDicts)
|| not (isDictTy (idType var))
= returnDs rhs -- That's easy: do nothing
| otherwise
= getModuleAndGroupDs `thenDs` \ (mod, grp) ->
-- ToDo: do -dicts-all flag (mark dict things with individual CCs)
returnDs (Note (SCC (mkAllDictsCC mod grp False)) rhs)
-}
\end{code}
|
