Skip to content
This repository
Newer
Older
100644 350 lines (312 sloc) 10.769 kb
fccc6851 »
2011-06-21 Initial open-source release
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18
19 (*
20 Please see .mli for more informations about this module
21 @author Esther Baruk
22 @author Mathieu Barbin
23 *)
24
25 (* refactoring *)
26
27 (* depends *)
28 module Hashtbl = Base.Hashtbl
29 module List = Base.List
30
31 (* shorthand *)
32 module Q = QmlAst
33
34 (*
35 Note: This union-find structure is needed by the compare function, which does not take an
36 extra env in argument. We use a global ref which is set with the value shared_toplevel of
37 the env before each call to share_constants.
38 [imperative_structure_traversing_alias] is a map to a union-find structure for
39 traversing alias, and shared some more pattern of code without being lost because of alias.
40
41 example which explain the motivation of the structure :
42 {[
43 d0 = { a = 4.65 ; b = "titi" }
44 e0 = { a = d0 ; g = { g } }
45
46 d1 = { a = 4.65 ; b = "titi" }
47 e1 = { a = d1 ; g = { g } }
48
49 * constant-sharing *
50
51 ?? e0 == e1 ??
52 ]}
53 *)
54 type traversing_alias = (Ident.t, unit) UnionFind.t IdentMap.t
55
56 module IHashtbl = Hashtbl.Make (Ident)
57 let imperative_structure_traversing_alias = IHashtbl.create 10
58 let reset_traversing_alias () = IHashtbl.clear imperative_structure_traversing_alias
59
60 let map_alias id =
61 try
62 let set = IHashtbl.find imperative_structure_traversing_alias id in
63 UnionFind.key set
64 with
65 (* IHashtbl.find raises Not_found *)
66 | Not_found -> id
67
68 let resolve_alias expr = QmlAstWalk.Expr.map
69 (fun e ->
70 match e with
71 | Q.Ident (label, id) ->
72 let f_id = map_alias id in
73 if id == f_id then e else Q.Ident (label, f_id)
74 | _ -> e) expr
75
76 let find_or_create source =
77 try
78 IHashtbl.find imperative_structure_traversing_alias source
79 with
80 | Not_found ->
81 let set = UnionFind.make source () in
82 IHashtbl.add imperative_structure_traversing_alias source set ;
83 set
84
85 let define_alias alias source =
86 let source_set = find_or_create source in
87 let alias_set = find_or_create alias in
88 UnionFind.replace ~replaced:alias_set ~keeped:source_set
89
90 (* Ordered expressions *)
91 module Expr =
92 struct
93 type t = QmlAst.expr
94
95 (* Sub ast of QML, handled for constant sharing.
96 Coerce < Record < Ident < Const < else *)
97 let compare x y =
98 let rec aux x y =
99 match x, y with
100 | Q.Coerce (_, e1, _), Q.Coerce (_, e2, _) -> aux e1 e2
101 | Q.Coerce _, _ -> -1
102 | _, Q.Coerce _ -> 1
103 | Q.Record (_, fds), Q.Record (_, fds') ->
104 let field (f, e) (f', e') =
105 let r = String.compare f f' in
106 if r <> 0 then r else
107 aux e e'
108 in
109 Base.List.make_compare field fds fds'
110 | Q.Record _, _ -> -1
111 | _, Q.Record _ -> 1
112 | Q.Ident (_, id1), Q.Ident (_, id2) ->
113 let id1 = map_alias id1 in
114 let id2 = map_alias id2 in
115 Ident.compare id1 id2
116 | Q.Ident _, _ -> -1
117 | _, Q.Ident _ -> 1
118 | Q.Const (_, c), Q.Const (_, c') -> Pervasives.compare c c'
119 | Q.Const _, _ -> -1
120 | _, Q.Const _ -> 1
121 | _ -> assert false (* internal error of this module *)
122 in aux x y
123 end
124
125 (* A map of expressions *)
126 module ExprMap : BaseMapSig.S with type key = QmlAst.expr = BaseMap.Make (Expr)
127
128 type options = {
129 no_string_sharing : bool;
130 no_float_sharing : bool;
131 no_record_sharing: bool;
132 remove_coerce : bool;
133 }
134
135 (*
136 Make options from side
137 *)
138 let make_options side =
139 match side with
140 | `server -> {
141
142 no_string_sharing =
143 #<If:CONST_SHARING_SERVER_STRING $equals "0">
144 true
145 #<Else>
146 false
147 #<End>
148 ;
149
150 no_float_sharing =
151 #<If:CONST_SHARING_SERVER_FLOAT $equals "0">
152 true
153 #<Else>
154 false
155 #<End>
156 ;
157
158 no_record_sharing =
159 #<If:CONST_SHARING_SERVER_RECORD $equals "0">
160 true
161 #<Else>
162 false
163 #<End>
164 ;
165
166 remove_coerce =
167 #<If:CONST_SHARING_SERVER_REMOVE_COERCE $equals "0">
168 false
169 #<Else>
170 true
171 #<End>
172 ;
173 }
174 | `client -> {
175 no_string_sharing =
176 #<If:CONST_SHARING_CLIENT_STRING $equals "0">
177 true
178 #<Else>
179 false
180 #<End>
181 ;
182
183 no_float_sharing =
184 #<If:CONST_SHARING_CLIENT_FLOAT $equals "0">
185 true
186 #<Else>
187 false
188 #<End>
189 ;
190
191 no_record_sharing =
192 #<If:CONST_SHARING_CLIENT_RECORD $equals "0">
193 true
194 #<Else>
195 false
196 #<End>
197 ;
198
199 remove_coerce =
200 #<If:CONST_SHARING_CLIENT_REMOVE_COERCE $equals "0">
201 false
202 #<Else>
203 true
204 #<End>
205 ;
206 }
207
208 (*
209 Type of the environment.
210 + *constants* is a map of expressions so as to find easily the identifier related to a constant
211 + *decls* is the map of identifiers so as to store the toplevel declarations to be added at
212 the beginning of the code (in which all constants were replaced by their identifier)
213 *)
214 type env = {
215 options : options ;
216 constants : Ident.t ExprMap.t ;
217 decls : QmlAst.expr IdentMap.t ;
218 }
219
220 (* Empty environment
221 constant is a string map (ident, value)
222 defs is a map which contains the toplevel definition (ident, expr) *)
223 let empty_env options = {
224 options = options ;
225 constants = ExprMap.empty ;
226 decls = IdentMap.empty ;
227 }
228
229 let is_constant env e =
230 let rec aux in_record e =
231 match e with
232 | Q.Ident (_, id) when in_record -> let id = map_alias id in IdentMap.mem id env.decls
233 | Q.Coerce (_, expr, _) when not env.options.remove_coerce -> aux in_record expr
234 | Q.Const (_, Q.String _) when not env.options.no_string_sharing -> true
235 | Q.Const (_, Q.Float _) when not env.options.no_float_sharing -> true
236 | Q.Const (_, Q.Int _) when in_record -> true
237 | Q.Record (_, []) when not env.options.no_record_sharing -> true
238 | Q.Record (_, [_, expr]) when not env.options.no_record_sharing -> aux true expr
239 | Q.Record (_, l) when not env.options.no_record_sharing ->
240 List.for_all (fun (_,e) -> aux true e) l
241 | _ -> false
242 in aux false e
243
244 (* Define an new identifier for the constant, register it
245 in the environment (into the field [decls] and add it to gamma *)
246 let make_toplevel_decl ~typed gamma annotmap env const ty =
247 let id = Ident.next "const" in
248 let annotmap, const =
249 let rec aux const =
250 match const with
251 | Q.Const (_, c) -> if typed then QmlAstCons.TypedExpr.const annotmap c else annotmap,QmlAstCons.UntypedExpr.const c
252 | Q.Record (_, l) -> if typed then QmlAstCons.TypedExpr.record annotmap l else annotmap,QmlAstCons.UntypedExpr.record l
253 | Q.Coerce (_, e, ty) when not env.options.remove_coerce ->
254 let a, c = aux e in
255 if typed then QmlAstCons.TypedExpr.coerce a c ty
256 else a,QmlAstCons.UntypedExpr.coerce c ty
257 | _ -> assert false
258 in aux const
259 in
260 let const = resolve_alias const in
261 let consts_ = ExprMap.add const id env.constants in
262 let decls_ = IdentMap.add id const env.decls in
263 let gamma =
264 if typed then
265 let tsc = QmlTypes.Scheme.generalize gamma (Option.get ty) in
266 QmlTypes.Env.Ident.add id tsc gamma
267 else gamma
268 in
269 let annotmap, id =
270 if typed then QmlAstCons.TypedExpr.ident annotmap id (Option.get ty)
271 else annotmap,QmlAstCons.UntypedExpr.ident id in
272 let env_ = { env with constants = consts_; decls = decls_ } in
273 (gamma, annotmap, env_), id
274
275 (* Run through the code, create the toplevel declaration and replace
276 the constant by its identifier *)
277 let share_constants ~typed (gamma, annotmap, env) e = QmlAstWalk.Expr.traverse_foldmap
278 (fun tra (gamma, annotmap, env) e ->
279 let rec aux e =
280 match e with
281 | Q.Coerce (_, e, _) when env.options.remove_coerce -> aux e
282 | _ -> e
283 in
284 let e = aux e in
285 match e with
286 | Q.Directive (_, `create_lazy_record, _, _) ->
287 (gamma, annotmap, env), e
288 | _ ->
289 let (gamma, annotmap, env), e = tra (gamma, annotmap, env) e in
290 if is_constant env e then
291 let ty = if typed then Some (QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap) else None in
292 try
293 let id = ExprMap.find e env.constants in
294 let annotmap, id =
295 if typed then
296 QmlAstCons.TypedExpr.ident annotmap id (Option.get ty)
297 else
298 annotmap,QmlAstCons.UntypedExpr.ident id
299 in
300 (gamma, annotmap, env), id
301 with Not_found ->
302 make_toplevel_decl ~typed gamma annotmap env e ty
303 else
304 (gamma, annotmap, env), e
305 )
306 (gamma, annotmap, env)
307 e
308
309 (* Add the toplevel declarations to the code *)
310 let add_decls env code =
311 IdentMap.fold_rev
312 (fun x const code ->
313 let label = Annot.nolabel "QmlConstantSharing.add_decls" in
314 Q.NewVal (label, [x, const]) :: code)
315 env.decls
316 code
317
318 let process_code ~side ~typed gamma annotmap code =
319 let options = make_options side in
320 reset_traversing_alias () ;
321 let env = empty_env options in
322 let (gamma, annotmap, env), code =
323 List.fold_left_map_stable
324 (fun acc code_elt ->
325 match code_elt with
326 | Q.NewVal (label, bindings) ->
327 let acc, shared_bindings = List.fold_left_map_stable
328 (fun acc ((id, expr) as bind) ->
329 let acc, shared_expr = share_constants ~typed acc expr in
330 let _ =
331 match shared_expr with
332 | Q.Ident (_, const) -> (
333 (* store this alias *)
334 define_alias id const;
335 )
336 | _ -> ()
337 in
338 acc,
339 if expr == shared_expr then bind else (id, shared_expr)
340 )
341 acc bindings in
342 acc,
343 if bindings == shared_bindings then code_elt
344 else Q.NewVal (label, shared_bindings)
345 (* Alias or constant in ValRec are not allowed any way *)
346 | code_elt ->
347 QmlAstWalk.Top.fold_map_expr (share_constants ~typed) acc code_elt
348 ) (gamma, annotmap, env) code
349 in (gamma, annotmap), (add_decls env code)
Something went wrong with that request. Please try again.