-
-
Notifications
You must be signed in to change notification settings - Fork 648
/
overloadingConstructor.ml
444 lines (411 loc) · 16.1 KB
/
overloadingConstructor.ml
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
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
(*
The Haxe Compiler
Copyright (C) 2005-2019 Haxe Foundation
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*)
open Option
open Common
open Type
open Codegen
open Gencommon
(* ******************************************* *)
(* overloading reflection constructors *)
(* ******************************************* *)
(*
this module works on languages that support function overloading and
enable function hiding via static functions.
it takes the constructor body out of the constructor and adds it to a special ctor
static function. The static function will receive the same parameters as the constructor,
plus the special "me" var, which will replace "this"
Then it always adds two constructors to the class: one that receives a special marker class,
indicating that the object should be constructed without executing constructor body,
and one that executes its normal constructor.
Both will only include a super() call to the superclasses' emtpy constructor.
This enables two things:
empty construction without the need of incompatibility with the platform's native construction method
the ability to call super() constructor in any place in the constructor
*)
let rec prev_ctor c tl =
match c.cl_super with
| None ->
raise Not_found
| Some (sup,stl) ->
let stl = List.map (apply_params c.cl_params tl) stl in
match sup.cl_constructor with
| None -> prev_ctor sup stl
| Some ctor -> ctor, sup, stl
let make_static_ctor_name cl =
let name = mk_internal_name "hx" "ctor" in
name ^ "_" ^ (String.concat "_" (fst cl.cl_path)) ^ "_" ^ (snd cl.cl_path)
(* replaces super() call with last static constructor call *)
let replace_super_call com c tl with_params me p follow_type =
let rec loop_super c tl =
match c.cl_super with
| None ->
raise Not_found
| Some(sup,stl) ->
let stl = List.map (apply_params c.cl_params tl) stl in
try
let static_ctor_name = make_static_ctor_name sup in
sup, stl, PMap.find static_ctor_name sup.cl_statics
with Not_found ->
loop_super sup stl
in
let sup, stl, cf = loop_super c tl in
let with_params = (mk (TLocal me) me.v_type p) :: with_params in
let cf =
try
(* choose best super function *)
List.iter (fun e -> replace_mono e.etype) with_params;
List.find (fun cf ->
replace_mono cf.cf_type;
let args, _ = get_fun (apply_params cf.cf_params stl cf.cf_type) in
try
List.for_all2 (fun (_,_,t) e -> try
let e_etype = follow_type e.etype in
let t = follow_type t in
unify e_etype t; true
with Unify_error _ ->
false
) args with_params
with Invalid_argument _ ->
false
) (cf :: cf.cf_overloads)
with Not_found ->
com.error "No suitable overload for the super call arguments was found" p; cf
in
{
eexpr = TCall(
{
eexpr = TField(Texpr.Builder.make_static_this sup p, FStatic(sup,cf));
etype = apply_params cf.cf_params stl cf.cf_type;
epos = p
},
with_params
);
etype = com.basic.tvoid;
epos = p;
}
(* will create a static counterpart of 'ctor', and replace its contents to a call to the static version*)
let create_static_ctor com ~empty_ctor_expr cl ctor follow_type =
match Meta.has Meta.SkipCtor ctor.cf_meta with
| true -> ()
| false when is_none ctor.cf_expr -> ()
| false ->
let static_ctor_name = make_static_ctor_name cl in
(* create the static constructor *)
let ctor_types = List.map (fun (s,t) -> (s, TInst(map_param (get_cl_t t), []))) cl.cl_params in
let ctor_type_params = List.map snd ctor_types in
List.iter (function (_,TInst(c,[])) -> (
match c.cl_kind with
| KTypeParameter (hd :: tail) ->
let before = hd :: tail in
let after = List.map (apply_params cl.cl_params ctor_type_params) (before) in
c.cl_kind <- KTypeParameter(after)
| _ -> ())
| _ -> ()) ctor_types;
let me = alloc_var "__hx_this" (TInst(cl, List.map snd ctor_types)) in
me.v_capture <- true;
let fn_args, _ = get_fun ctor.cf_type in
let ctor_params = List.map snd ctor_types in
let fn_type = TFun((me.v_name,false, me.v_type) :: List.map (fun (n,o,t) -> (n,o,apply_params cl.cl_params ctor_params t)) fn_args, com.basic.tvoid) in
let cur_tf_args = match ctor.cf_expr with
| Some { eexpr = TFunction(tf) } -> tf.tf_args
| _ -> assert false
in
let changed_tf_args = List.map (fun (v,_) -> (v,None)) cur_tf_args in
let local_map = Hashtbl.create (List.length cur_tf_args) in
let static_tf_args = (me, None) :: List.map (fun (v,b) ->
let new_v = alloc_var v.v_name (apply_params cl.cl_params ctor_params v.v_type) in
new_v.v_capture <- v.v_capture;
Hashtbl.add local_map v.v_id new_v;
(new_v, b)
) cur_tf_args in
let static_ctor = mk_class_field static_ctor_name fn_type false ctor.cf_pos (Method MethNormal) ctor_types in
let static_ctor_meta = if cl.cl_final then Meta.Private else Meta.Protected in
static_ctor.cf_meta <- (static_ctor_meta,[],ctor.cf_pos) :: static_ctor.cf_meta;
(* change ctor contents to reference the 'me' var instead of 'this' *)
let actual_super_call = ref None in
let rec map_expr ~is_first e = match e.eexpr with
| TCall (({ eexpr = TConst TSuper } as tsuper), params) -> (try
let params = List.map (fun e -> map_expr ~is_first:false e) params in
actual_super_call := Some { e with eexpr = TCall(tsuper, [empty_ctor_expr]) };
replace_super_call com cl ctor_params params me e.epos follow_type
with | Not_found ->
(* last static function was not found *)
actual_super_call := Some e;
if not is_first then
com.error "Super call must be the first call when extending native types" e.epos;
{ e with eexpr = TBlock([]) })
| TFunction tf when is_first ->
do_map ~is_first:true e
| TConst TThis ->
mk_local me e.epos
| TBlock (fst :: bl) ->
let fst = map_expr ~is_first:is_first fst in
{ e with eexpr = TBlock(fst :: List.map (fun e -> map_expr ~is_first:false e) bl); etype = apply_params cl.cl_params ctor_params e.etype }
| _ ->
do_map e
and do_map ?(is_first=false) e =
let do_t = apply_params cl.cl_params ctor_params in
let do_v v = try
Hashtbl.find local_map v.v_id
with | Not_found ->
v.v_type <- do_t v.v_type; v
in
Type.map_expr_type (map_expr ~is_first:is_first) do_t do_v e
in
let expr = do_map ~is_first:true (get ctor.cf_expr) in
let expr = match expr.eexpr with
| TFunction(tf) ->
{ expr with etype = fn_type; eexpr = TFunction({ tf with tf_args = static_tf_args }) }
| _ -> assert false in
static_ctor.cf_expr <- Some expr;
(* add to the statics *)
(try
let stat = PMap.find static_ctor_name cl.cl_statics in
stat.cf_overloads <- static_ctor :: stat.cf_overloads
with | Not_found ->
cl.cl_ordered_statics <- static_ctor :: cl.cl_ordered_statics;
cl.cl_statics <- PMap.add static_ctor_name static_ctor cl.cl_statics);
(* change current super call *)
match ctor.cf_expr with
| Some({ eexpr = TFunction(tf) } as e) ->
let block_contents, p = match !actual_super_call with
| None -> [], ctor.cf_pos
| Some super -> [super], super.epos
in
let block_contents = block_contents @ [{
eexpr = TCall(
{
eexpr = TField(
Texpr.Builder.make_static_this cl p,
FStatic(cl, static_ctor));
etype = apply_params static_ctor.cf_params (List.map snd cl.cl_params) static_ctor.cf_type;
epos = p
},
[{ eexpr = TConst TThis; etype = TInst(cl, List.map snd cl.cl_params); epos = p }]
@ List.map (fun (v,_) -> mk_local v p) cur_tf_args
);
etype = com.basic.tvoid;
epos = p
}] in
ctor.cf_expr <- Some { e with eexpr = TFunction({ tf with tf_expr = { tf.tf_expr with eexpr = TBlock block_contents }; tf_args = changed_tf_args }) }
| _ -> assert false
(* makes constructors that only call super() for the 'ctor' argument *)
let clone_ctors com ctor sup stl cl =
let rec clone cf =
let ncf = mk_class_field "new" (apply_params sup.cl_params stl cf.cf_type) (has_class_field_flag cf CfPublic) cf.cf_pos cf.cf_kind cf.cf_params in
if Meta.has Meta.Protected cf.cf_meta then
ncf.cf_meta <- (Meta.Protected,[],ncf.cf_pos) :: ncf.cf_meta;
let args, ret = get_fun ncf.cf_type in
(* single expression: call to super() *)
let tf_args = List.map (fun (name,_,t) ->
(* the constructor will have no optional arguments, as presumably this will be handled by the underlying expr *)
alloc_var name t, None
) args in
let super_call =
{
eexpr = TCall(
{ eexpr = TConst TSuper; etype = TInst(cl, List.map snd cl.cl_params); epos = ctor.cf_pos },
List.map (fun (v,_) -> mk_local v ctor.cf_pos) tf_args);
etype = com.basic.tvoid;
epos = ctor.cf_pos;
} in
ncf.cf_expr <- Some
{
eexpr = TFunction {
tf_args = tf_args;
tf_type = com.basic.tvoid;
tf_expr = mk_block super_call;
};
etype = ncf.cf_type;
epos = ctor.cf_pos;
};
ncf
in
(* take off createEmpty *)
let all = List.filter (fun cf -> replace_mono cf.cf_type; not (Meta.has Meta.SkipCtor cf.cf_meta)) (ctor :: ctor.cf_overloads) in
let clones = List.map clone all in
match clones with
| [] ->
(* raise Not_found *)
assert false (* should never happen *)
| cf :: [] -> cf
| cf :: overl ->
cf.cf_meta <- (Meta.Overload,[],cf.cf_pos) :: cf.cf_meta;
cf.cf_overloads <- overl; cf
let rec descends_from_native_or_skipctor cl =
not (is_hxgen (TClassDecl cl)) || Meta.has Meta.SkipCtor cl.cl_meta || match cl.cl_super with
| None -> false
| Some(c,_) -> descends_from_native_or_skipctor c
let ensure_super_is_first com cf =
let rec loop e =
match e.eexpr with
| TBlock (b :: block) ->
loop b
| TBlock []
| TCall({ eexpr = TConst TSuper },_) -> ()
| _ ->
com.error "Types that derive from a native class must have its super() call as the first statement in the constructor" cf.cf_pos
in
match cf.cf_expr with
| None -> ()
| Some e -> Type.iter loop e
let init com (empty_ctor_type : t) (empty_ctor_expr : texpr) (follow_type : t -> t) =
let basic = com.basic in
let should_change cl = not cl.cl_interface && (not cl.cl_extern || is_hxgen (TClassDecl cl)) && (match cl.cl_kind with KAbstractImpl _ | KModuleStatics _ -> false | _ -> true) in
let msize = List.length com.types in
let processed, empty_ctors = Hashtbl.create msize, Hashtbl.create msize in
let rec get_last_empty cl =
try
Hashtbl.find empty_ctors cl.cl_path
with | Not_found ->
match cl.cl_super with
| None -> raise Not_found
| Some (sup,_) -> get_last_empty sup
in
let rec change cl =
if not (Hashtbl.mem processed cl.cl_path) then begin
Hashtbl.add processed cl.cl_path true;
(* make sure we've processed the super types *)
Option.may (fun (super,_) -> if should_change super then change super) cl.cl_super;
(* implement static hx_ctor and reimplement constructors *)
(try
let ctor =
match cl.cl_constructor with
| Some ctor ->
ctor
| None ->
try
let sctor, sup, stl = prev_ctor cl (List.map snd cl.cl_params) in
(* we'll make constructors that will only call super() *)
let ctor = clone_ctors com sctor sup stl cl in
cl.cl_constructor <- Some ctor;
ctor
with Not_found -> (* create default constructor *)
let ctor = mk_class_field "new" (TFun ([], basic.tvoid)) false cl.cl_pos (Method MethNormal) [] in
ctor.cf_expr <- Some {
eexpr = TFunction {
tf_args = [];
tf_type = basic.tvoid;
tf_expr = mk (TBlock []) basic.tvoid cl.cl_pos;
};
etype = ctor.cf_type;
epos = ctor.cf_pos;
};
cl.cl_constructor <- Some ctor;
ctor
in
let has_super_constructor =
match cl.cl_super with
| None -> false
| Some (csup,_) -> has_constructor csup
in
(* now that we made sure we have a constructor, exit if native gen *)
if not (is_hxgen (TClassDecl cl)) || Meta.has Meta.SkipCtor cl.cl_meta then begin
if descends_from_native_or_skipctor cl && has_super_constructor then
List.iter (fun cf -> ensure_super_is_first com cf) (ctor :: ctor.cf_overloads);
raise Exit
end;
(* if cl descends from a native class, we cannot use the static constructor strategy *)
if descends_from_native_or_skipctor cl && has_super_constructor then
List.iter (fun cf -> ensure_super_is_first com cf) (ctor :: ctor.cf_overloads)
else
(* now that we have a current ctor, create the static counterparts *)
List.iter (fun cf -> create_static_ctor com ~empty_ctor_expr:empty_ctor_expr cl cf follow_type) (ctor :: ctor.cf_overloads)
with Exit -> ());
(* implement empty ctor *)
(try
(* now that we made sure we have a constructor, exit if native gen *)
if not (is_hxgen (TClassDecl cl)) then raise Exit;
(* get first *)
let empty_type = TFun (["empty",false,empty_ctor_type],basic.tvoid) in
let super =
match cl.cl_super with
| None -> (* implement empty *)
[]
| Some (sup,_) ->
try
ignore (get_last_empty sup);
let esuper = mk (TConst TSuper) (TInst (cl, List.map snd cl.cl_params)) cl.cl_pos in
[mk (TCall (esuper, [empty_ctor_expr])) basic.tvoid cl.cl_pos]
with Not_found ->
try
(* super type is native: find super constructor with least arguments *)
let sctor, sup, stl = prev_ctor cl (List.map snd cl.cl_params) in
let rec loop remaining (best,n) =
match remaining with
| [] -> best
| cf :: r ->
let args,_ = get_fun cf.cf_type in
if (List.length args) < n then
loop r (cf,List.length args)
else
loop r (best,n)
in
let args,_ = get_fun sctor.cf_type in
let best = loop sctor.cf_overloads (sctor, List.length args) in
let args,_ = get_fun (apply_params sup.cl_params stl best.cf_type) in
let esuper = mk (TConst TSuper) (TInst (sup, stl)) cl.cl_pos in
[mk (TCall (esuper, List.map (fun (n,o,t) -> null t cl.cl_pos) args)) basic.tvoid cl.cl_pos]
with Not_found ->
(* extends native type, but no ctor found *)
[]
in
let ctor = mk_class_field "new" empty_type false cl.cl_pos (Method MethNormal) [] in
ctor.cf_expr <- Some {
eexpr = TFunction {
tf_type = basic.tvoid;
tf_args = [alloc_var "empty" empty_ctor_type, None];
tf_expr = mk (TBlock super) basic.tvoid cl.cl_pos
};
etype = empty_type;
epos = cl.cl_pos;
};
ctor.cf_meta <- [Meta.SkipCtor, [], ctor.cf_pos];
Hashtbl.add empty_ctors cl.cl_path ctor;
match cl.cl_constructor with
| None ->
cl.cl_constructor <- Some ctor
| Some c ->
c.cf_overloads <- ctor :: c.cf_overloads
with Exit -> ());
end
in
let module_filter md =
(match md with
| TClassDecl cl when should_change cl ->
change cl;
| _ ->
());
md
in
module_filter
let init_expr_filter create_empty =
let rec run e =
match e.etype, e.eexpr with
| TInst (cl, params), TCall ({ eexpr = TField (_, FStatic ({cl_path = [],"Type"}, {cf_name = "createEmptyInstance"})) }, [{eexpr = TTypeExpr ((TClassDecl cl_arg) as mt_arg) }]) when cl == cl_arg && is_hxgen mt_arg ->
create_empty cl params e.epos
| _ ->
Type.map_expr run e
in
run
let priority = 0.0
let name = "overloading_constructor"
let configure gen ~empty_ctor_type ~empty_ctor_expr =
gen.gtools.r_create_empty <- (fun cl params pos -> mk (TNew(cl,params,[empty_ctor_expr])) (TInst(cl,params)) pos);
let module_filter = init gen.gcon empty_ctor_type empty_ctor_expr (run_follow gen) in
gen.gmodule_filters#add name (PCustom priority) module_filter;
let expr_filter = init_expr_filter gen.gtools.r_create_empty in
gen.gexpr_filters#add name (PCustom priority) expr_filter