forked from HaxeFoundation/haxe
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathoptimizer.ml
1666 lines (1619 loc) · 58.7 KB
/
optimizer.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
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(*
* Copyright (C)2005-2013 Haxe Foundation
*
* Permission is hereby granted, free of charge, to any person obtaining a
* copy of this software and associated documentation files (the "Software"),
* to deal in the Software without restriction, including without limitation
* the rights to use, copy, modify, merge, publish, distribute, sublicense,
* and/or sell copies of the Software, and to permit persons to whom the
* Software is furnished to do so, subject to the following conditions:
*
* The above copyright notice and this permission notice shall be included in
* all copies or substantial portions of the Software.
*
* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
* DEALINGS IN THE SOFTWARE.
*)
open Ast
open Type
open Common
open Typecore
(* ---------------------------------------------------------------------- *)
(* API OPTIMIZATIONS *)
(* tells if an expression causes side effects. This does not account for potential null accesses (fields/arrays/ops) *)
let has_side_effect e =
let rec loop e =
match e.eexpr with
| TConst _ | TLocal _ | TTypeExpr _ | TFunction _ -> ()
| TCall ({ eexpr = TField(_,FStatic({ cl_path = ([],"Std") },{ cf_name = "string" })) },args) -> Type.iter loop e
| TNew _ | TCall _ | TBinop ((OpAssignOp _ | OpAssign),_,_) | TUnop ((Increment|Decrement),_,_) -> raise Exit
| TReturn _ | TBreak | TContinue | TThrow _ | TCast (_,Some _) -> raise Exit
| TArray _ | TEnumParameter _ | TCast (_,None) | TBinop _ | TUnop _ | TParenthesis _ | TMeta _ | TWhile _ | TFor _
| TField _ | TIf _ | TTry _ | TSwitch _ | TArrayDecl _ | TBlock _ | TObjectDecl _ | TVar _ -> Type.iter loop e
in
try
loop e; false
with Exit ->
true
let rec is_exhaustive e1 = match e1.eexpr with
| TMeta((Meta.Exhaustive,_,_),_) -> true
| TMeta(_, e1) | TParenthesis e1 -> is_exhaustive e1
| _ -> false
let mk_untyped_call name p params =
{
eexpr = TCall({ eexpr = TLocal(alloc_unbound_var name t_dynamic); etype = t_dynamic; epos = p }, params);
etype = t_dynamic;
epos = p;
}
let api_inline2 com c field params p =
match c.cl_path, field, params with
| ([],"Type"),"enumIndex",[{ eexpr = TField (_,FEnum (en,f)) }] -> (match com.platform with
| Cs when en.e_extern && not (Meta.has Meta.HxGen en.e_meta) ->
(* We don't want to optimize enums from external sources; as they might change unexpectedly *)
(* and since native C# enums don't have the concept of index - they have rather a value, *)
(* which can't be mapped to a native API - this kind of substitution is dangerous *)
None
| _ ->
Some (mk (TConst (TInt (Int32.of_int f.ef_index))) com.basic.tint p))
| ([],"Type"),"enumIndex",[{ eexpr = TCall({ eexpr = TField (_,FEnum (en,f)) },pl) }] when List.for_all (fun e -> not (has_side_effect e)) pl ->
(match com.platform with
| Cs when en.e_extern && not (Meta.has Meta.HxGen en.e_meta) ->
(* see comment above *)
None
| _ ->
Some (mk (TConst (TInt (Int32.of_int f.ef_index))) com.basic.tint p))
| ([],"Std"),"int",[{ eexpr = TConst (TInt _) } as e] ->
Some { e with epos = p }
| ([],"String"),"fromCharCode",[{ eexpr = TConst (TInt i) }] when i > 0l && i < 128l ->
Some (mk (TConst (TString (String.make 1 (char_of_int (Int32.to_int i))))) com.basic.tstring p)
| ([],"Std"),"string",[{ eexpr = TConst c } as e] ->
(match c with
| TString s ->
Some { e with epos = p }
| TInt i ->
Some { eexpr = TConst (TString (Int32.to_string i)); epos = p; etype = com.basic.tstring }
| TBool b ->
Some { eexpr = TConst (TString (if b then "true" else "false")); epos = p; etype = com.basic.tstring }
| _ ->
None)
| ([],"Std"),"string",[{ eexpr = TIf (_,{ eexpr = TConst (TString _)},Some { eexpr = TConst (TString _) }) } as e] ->
Some e
| ([],"Std"),"string",[{ eexpr = TLocal v | TField({ eexpr = TLocal v },_) } as ev] when (com.platform = Js || com.platform = Flash) && not (Meta.has Meta.CompilerGenerated v.v_meta) ->
let pos = ev.epos in
let stringv() =
let to_str = mk (TBinop (Ast.OpAdd, mk (TConst (TString "")) com.basic.tstring pos, ev)) com.basic.tstring pos in
if com.platform = Js || is_nullable ev.etype then
let chk_null = mk (TBinop (Ast.OpEq, ev, mk (TConst TNull) t_dynamic pos)) com.basic.tbool pos in
mk (TIf (chk_null, mk (TConst (TString "null")) com.basic.tstring pos, Some to_str)) com.basic.tstring pos
else
to_str
in
(match follow ev.etype with
| TInst ({ cl_path = [],"String" }, []) ->
Some (stringv())
| TAbstract ({ a_path = [],"Float" }, []) ->
Some (stringv())
| TAbstract ({ a_path = [],"Int" }, []) ->
Some (stringv())
| TAbstract ({ a_path = [],"UInt" }, []) ->
Some (stringv())
| TAbstract ({ a_path = [],"Bool" }, []) ->
Some (stringv())
| _ ->
None)
| ([],"Std"),"int",[{ eexpr = TConst (TFloat f) }] ->
let f = float_of_string f in
(match classify_float f with
| FP_infinite | FP_nan ->
None
| _ when f <= Int32.to_float Int32.min_int -. 1. || f >= Int32.to_float Int32.max_int +. 1. ->
None (* out range, keep platform-specific behavior *)
| _ ->
Some { eexpr = TConst (TInt (Int32.of_float f)); etype = com.basic.tint; epos = p })
| ([],"Math"),"ceil",[{ eexpr = TConst (TFloat f) }] ->
let f = float_of_string f in
(match classify_float f with
| FP_infinite | FP_nan ->
None
| _ when f <= Int32.to_float Int32.min_int -. 1. || f >= Int32.to_float Int32.max_int ->
None (* out range, keep platform-specific behavior *)
| _ ->
Some { eexpr = TConst (TInt (Int32.of_float (ceil f))); etype = com.basic.tint; epos = p })
| ([],"Math"),"floor",[{ eexpr = TConst (TFloat f) }] ->
let f = float_of_string f in
(match classify_float f with
| FP_infinite | FP_nan ->
None
| _ when f <= Int32.to_float Int32.min_int || f >= Int32.to_float Int32.max_int +. 1. ->
None (* out range, keep platform-specific behavior *)
| _ ->
Some { eexpr = TConst (TInt (Int32.of_float (floor f))); etype = com.basic.tint; epos = p })
| (["cs"],"Lib"),("fixed" | "checked" | "unsafe"),[e] ->
Some (mk_untyped_call ("__" ^ field ^ "__") p [e])
| (["cs"],"Lib"),("lock"),[obj;block] ->
Some (mk_untyped_call ("__lock__") p [obj;mk_block block])
| (["java"],"Lib"),("lock"),[obj;block] ->
Some (mk_untyped_call ("__lock__") p [obj;mk_block block])
| _ ->
None
let api_inline ctx c field params p = match c.cl_path, field, params with
| ([],"Std"),"is",[o;t] | (["js"],"Boot"),"__instanceof",[o;t] when ctx.com.platform = Js ->
let mk_local ctx n t pos =
mk (TLocal (try
PMap.find n ctx.locals
with _ ->
let v = add_local ctx n t in
v.v_meta <- [Meta.Unbound,[],p];
v
)) t pos in
let tstring = ctx.com.basic.tstring in
let tbool = ctx.com.basic.tbool in
let tint = ctx.com.basic.tint in
let is_trivial e =
match e.eexpr with
| TConst _ | TLocal _ -> true
| _ -> false
in
let typeof t =
let tof = mk_local ctx "__typeof__" (tfun [o.etype] tstring) p in
let tof = mk (TCall (tof, [o])) tstring p in
mk (TBinop (Ast.OpEq, tof, (mk (TConst (TString t)) tstring p))) tbool p
in
(match t.eexpr with
(* generate simple typeof checks for basic types *)
| TTypeExpr (TClassDecl ({ cl_path = [],"String" })) -> Some (typeof "string")
| TTypeExpr (TAbstractDecl ({ a_path = [],"Bool" })) -> Some (typeof "boolean")
| TTypeExpr (TAbstractDecl ({ a_path = [],"Float" })) -> Some (typeof "number")
| TTypeExpr (TAbstractDecl ({ a_path = [],"Int" })) when is_trivial o ->
(* generate (o|0) === o check *)
let teq = mk_local ctx "__strict_eq__" (tfun [tint; tint] tbool) p in
let lhs = mk (TBinop (Ast.OpOr, o, mk (TConst (TInt Int32.zero)) tint p)) tint p in
Some (mk (TCall (teq, [lhs; o])) tbool p)
| TTypeExpr (TClassDecl ({ cl_path = [],"Array" })) ->
(* generate (o instanceof Array) && o.__enum__ == null check *)
let iof = mk_local ctx "__instanceof__" (tfun [o.etype;t.etype] tbool) p in
let iof = mk (TCall (iof, [o; t])) tbool p in
let enum = mk (TField (o, FDynamic "__enum__")) (mk_mono()) p in
let null = mk (TConst TNull) (mk_mono()) p in
let not_enum = mk (TBinop (Ast.OpEq, enum, null)) tbool p in
Some (mk (TBinop (Ast.OpBoolAnd, iof, not_enum)) tbool p)
| _ ->
None)
| (["cs" | "java"],"Lib"),("nativeArray"),[{ eexpr = TArrayDecl args } as edecl; _]
| (["haxe";"ds";"_Vector"],"Vector_Impl_"),("fromArrayCopy"),[{ eexpr = TArrayDecl args } as edecl] -> (try
let platf = match ctx.com.platform with
| Cs -> "cs"
| Java -> "java"
| _ -> raise Exit
in
let mpath = if field = "fromArrayCopy" then
(["haxe";"ds"],"Vector")
else
([platf],"NativeArray")
in
let m = ctx.g.do_load_module ctx mpath null_pos in
let main = List.find (function | TClassDecl _ | TAbstractDecl _ -> true | _ -> false) m.m_types in
let t = match follow edecl.etype, main with
| TInst({ cl_path = [],"Array" }, [t]), TClassDecl(cl) ->
TInst(cl,[t])
| TInst({ cl_path = [],"Array" }, [t]), TAbstractDecl(a) ->
TAbstract(a,[t])
| _ -> assert false
in
Some ({ (mk_untyped_call "__array__" p args) with etype = t })
with | Exit ->
None)
| _ ->
api_inline2 ctx.com c field params p
(* ---------------------------------------------------------------------- *)
(* INLINING *)
type in_local = {
i_var : tvar;
i_subst : tvar;
mutable i_captured : bool;
mutable i_write : bool;
mutable i_read : int;
mutable i_force_temp : bool;
}
let inline_default_config cf t =
(* type substitution on both class and function type parameters *)
let rec get_params c pl =
match c.cl_super with
| None -> c.cl_params, pl
| Some (csup,spl) ->
let spl = (match apply_params c.cl_params pl (TInst (csup,spl)) with
| TInst (_,pl) -> pl
| _ -> assert false
) in
let ct, cpl = get_params csup spl in
c.cl_params @ ct, pl @ cpl
in
let tparams = (match follow t with
| TInst (c,pl) -> get_params c pl
| _ -> ([],[]))
in
let pmonos = List.map (fun _ -> mk_mono()) cf.cf_params in
let tmonos = snd tparams @ pmonos in
let tparams = fst tparams @ cf.cf_params in
tparams <> [], apply_params tparams tmonos
let rec type_inline ctx cf f ethis params tret config p ?(self_calling_closure=false) force =
(* perform some specific optimization before we inline the call since it's not possible to detect at final optimization time *)
try
let cl = (match follow ethis.etype with
| TInst (c,_) -> c
| TAnon a -> (match !(a.a_status) with Statics c -> c | _ -> raise Exit)
| _ -> raise Exit
) in
(match api_inline ctx cl cf.cf_name params p with
| None -> raise Exit
| Some e -> Some e)
with Exit ->
let has_params,map_type = match config with Some config -> config | None -> inline_default_config cf ethis.etype in
(* locals substitution *)
let locals = Hashtbl.create 0 in
let local v =
try
Hashtbl.find locals v.v_id
with Not_found ->
let v' = alloc_var v.v_name v.v_type in
if Meta.has Meta.Unbound v.v_meta then v'.v_meta <- [Meta.Unbound,[],p];
let i = {
i_var = v;
i_subst = v';
i_captured = false;
i_write = false;
i_force_temp = false;
i_read = 0;
} in
i.i_subst.v_meta <- v.v_meta;
Hashtbl.add locals v.v_id i;
Hashtbl.add locals i.i_subst.v_id i;
i
in
let in_local_fun = ref false in
let read_local v =
let l = try
Hashtbl.find locals v.v_id
with Not_found ->
(* make sure to duplicate unbound inline variable to prevent dependency leak when unifying monomorph *)
if has_meta Meta.Unbound v.v_meta then local v else
{
i_var = v;
i_subst = v;
i_captured = false;
i_write = false;
i_force_temp = false;
i_read = 0;
}
in
if !in_local_fun then l.i_captured <- true;
l
in
(* use default values for null/unset arguments *)
let rec loop pl al first =
match pl, al with
| _, [] -> []
| e :: pl, (v, opt) :: al ->
(*
if we pass a Null<T> var to an inlined method that needs a T.
we need to force a local var to be created on some platforms.
*)
if ctx.com.config.pf_static && not (is_nullable v.v_type) && is_null e.etype then (local v).i_force_temp <- true;
(*
if we cast from Dynamic, create a local var as well to do the cast
once and allow DCE to perform properly.
*)
if v.v_type != t_dynamic && follow e.etype == t_dynamic then (local v).i_write <- true;
(match e.eexpr, opt with
| TConst TNull , Some c -> mk (TConst c) v.v_type e.epos
(*
This is really weird and should be reviewed again. The problem is that we cannot insert a TCast here because
the abstract `this` value could be written to, which is not possible if it is wrapped in a cast.
The original problem here is that we do not generate a temporary variable and thus mute the type of the
`this` variable, which leads to unification errors down the line. See issues #2236 and #3713.
*)
(* | _ when first && (Meta.has Meta.Impl cf.cf_meta) -> {e with etype = v.v_type} *)
| _ -> e) :: loop pl al false
| [], (v,opt) :: al ->
(mk (TConst (match opt with None -> TNull | Some c -> c)) v.v_type p) :: loop [] al false
in
(*
Build the expr/var subst list
*)
let ethis = (match ethis.eexpr with TConst TSuper -> { ethis with eexpr = TConst TThis } | _ -> ethis) in
let vthis = alloc_var "_this" ethis.etype in
let inlined_vars = List.map2 (fun e (v,_) ->
let l = local v in
if has_side_effect e then l.i_force_temp <- true; (* force tmp var *)
l, e
) (ethis :: loop params f.tf_args true) ((vthis,None) :: f.tf_args) in
let inlined_vars = List.rev inlined_vars in
(*
here, we try to eliminate final returns from the expression tree.
However, this is not entirely correct since we don't yet correctly propagate
the type of returned expressions upwards ("return" expr itself being Dynamic).
We also substitute variables with fresh ones that might be renamed at later stage.
*)
let opt f = function
| None -> None
| Some e -> Some (f e)
in
let has_vars = ref false in
let in_loop = ref false in
let cancel_inlining = ref false in
let has_return_value = ref false in
let ret_val = (match follow f.tf_type with TAbstract ({ a_path = ([],"Void") },[]) -> false | _ -> true) in
let map_pos = if self_calling_closure then (fun e -> e) else (fun e -> { e with epos = p }) in
let rec map term e =
let po = e.epos in
let e = map_pos e in
match e.eexpr with
| TLocal v ->
let l = read_local v in
l.i_read <- l.i_read + (if !in_loop then 2 else 1);
(* never inline a function which contain a delayed macro because its bound
to its variables and not the calling method *)
if v.v_name = "__dollar__delay_call" then cancel_inlining := true;
let e = { e with eexpr = TLocal l.i_subst } in
if Meta.has Meta.This v.v_meta then mk (TCast(e,None)) v.v_type e.epos else e
| TConst TThis ->
let l = read_local vthis in
l.i_read <- l.i_read + (if !in_loop then 2 else 1);
{ e with eexpr = TLocal l.i_subst }
| TVar (v,eo) ->
has_vars := true;
{ e with eexpr = TVar ((local v).i_subst,opt (map false) eo)}
| TReturn eo when not !in_local_fun ->
if not term then error "Cannot inline a not final return" po;
(match eo with
| None -> mk (TConst TNull) f.tf_type p
| Some e ->
has_return_value := true;
map term e)
| TFor (v,e1,e2) ->
let i = local v in
let e1 = map false e1 in
let old = !in_loop in
in_loop := true;
let e2 = map false e2 in
in_loop := old;
{ e with eexpr = TFor (i.i_subst,e1,e2) }
| TWhile (cond,eloop,flag) ->
let cond = map false cond in
let old = !in_loop in
in_loop := true;
let eloop = map false eloop in
in_loop := old;
{ e with eexpr = TWhile (cond,eloop,flag) }
| TSwitch (e1,cases,def) when term ->
let term = term && (def <> None || is_exhaustive e1) in
let cases = List.map (fun (el,e) ->
let el = List.map (map false) el in
el, map term e
) cases in
let def = opt (map term) def in
{ e with eexpr = TSwitch (map false e1,cases,def); etype = if ret_val then unify_min ctx ((List.map snd cases) @ (match def with None -> [] | Some e -> [e])) else e.etype }
| TTry (e1,catches) ->
{ e with eexpr = TTry (map term e1,List.map (fun (v,e) ->
let lv = (local v).i_subst in
let e = map term e in
lv,e
) catches); etype = if term && ret_val then unify_min ctx (e1::List.map snd catches) else e.etype }
| TBlock l ->
let old = save_locals ctx in
let t = ref e.etype in
let has_return e =
let rec loop e = match e.eexpr with
| TReturn _ -> raise Exit
| _ -> Type.iter loop e
in
try loop e; false with Exit -> true
in
let rec loop = function
| [] when term ->
t := mk_mono();
[mk (TConst TNull) (!t) p]
| [] -> []
| [e] ->
let e = map term e in
if term then t := e.etype;
[e]
| ({ eexpr = TIf (cond,e1,None) } as e) :: l when term && has_return e1 ->
loop [{ e with eexpr = TIf (cond,e1,Some (mk (TBlock l) e.etype e.epos)); epos = punion e.epos (match List.rev l with e :: _ -> e.epos | [] -> assert false) }]
| e :: l ->
let e = map false e in
e :: loop l
in
let l = loop l in
old();
{ e with eexpr = TBlock l; etype = !t }
| TIf (econd,eif,Some eelse) when term ->
let econd = map false econd in
let eif = map term eif in
let eelse = map term eelse in
{ e with eexpr = TIf(econd,eif,Some eelse); etype = if ret_val then unify_min ctx [eif;eelse] else e.etype }
| TParenthesis e1 ->
let e1 = map term e1 in
mk (TParenthesis e1) e1.etype e.epos
| TUnop ((Increment|Decrement) as op,flag,({ eexpr = TLocal v } as e1)) ->
let l = read_local v in
l.i_write <- true;
{e with eexpr = TUnop(op,flag,{e1 with eexpr = TLocal l.i_subst})}
| TBinop ((OpAssign | OpAssignOp _) as op,({ eexpr = TLocal v } as e1),e2) ->
let l = read_local v in
l.i_write <- true;
let e2 = map false e2 in
{e with eexpr = TBinop(op,{e1 with eexpr = TLocal l.i_subst},e2)}
| TObjectDecl fl ->
let fl = List.map (fun (s,e) -> s,map false e) fl in
begin match follow e.etype with
| TAnon an when (match !(an.a_status) with Const -> true | _ -> false) ->
{e with eexpr = TObjectDecl fl; etype = TAnon { an with a_status = ref Closed}}
| _ ->
{e with eexpr = TObjectDecl fl}
end
| TFunction f ->
(match f.tf_args with [] -> () | _ -> has_vars := true);
let old = save_locals ctx and old_fun = !in_local_fun in
let args = List.map (function(v,c) -> (local v).i_subst, c) f.tf_args in
in_local_fun := true;
let expr = map false f.tf_expr in
in_local_fun := old_fun;
old();
{ e with eexpr = TFunction { tf_args = args; tf_expr = expr; tf_type = f.tf_type } }
| TConst TSuper ->
error "Cannot inline function containing super" po
| TMeta(m,e1) ->
let e1 = map term e1 in
{e with eexpr = TMeta(m,e1)}
| _ ->
Type.map_expr (map false) e
in
let e = map true f.tf_expr in
(*
if variables are not written and used with a const value, let's substitute
with the actual value, either create a temp var
*)
let subst = ref PMap.empty in
let is_constant e =
let rec loop e =
match e.eexpr with
| TLocal _
| TConst TThis (* not really, but should not be move inside a function body *)
-> raise Exit
| TField (_,FEnum _)
| TTypeExpr _
| TConst _ -> ()
| _ ->
Type.iter loop e
in
try loop e; true with Exit -> false
in
let is_writable e =
match e.eexpr with
| TField _ | TEnumParameter _ | TLocal _ | TArray _ -> true
| _ -> false
in
let force = ref force in
let vars = List.fold_left (fun acc (i,e) ->
let flag = not i.i_force_temp && (match e.eexpr with
| TLocal v when Meta.has Meta.This v.v_meta -> true
| TLocal _ | TConst _ -> not i.i_write
| TFunction _ -> if i.i_write then error "Cannot modify a closure parameter inside inline method" p; true
| _ -> not i.i_write && i.i_read <= 1
) in
let flag = flag && (not i.i_captured || is_constant e) in
(* force inlining if we modify 'this' *)
if i.i_write && (Meta.has Meta.This i.i_var.v_meta) then force := true;
(* force inlining of 'this' variable if it is written *)
let flag = if not flag && (Meta.has Meta.This i.i_var.v_meta) && i.i_write then begin
if not (is_writable e) then error "Cannot modify the abstract value, store it into a local first" p;
true
end else flag in
if flag then begin
subst := PMap.add i.i_subst.v_id e !subst;
acc
end else
(i.i_subst,Some e) :: acc
) [] inlined_vars in
let subst = !subst in
let rec inline_params e =
match e.eexpr with
| TLocal v -> (try PMap.find v.v_id subst with Not_found -> e)
| _ -> Type.map_expr inline_params e
in
let e = (if PMap.is_empty subst then e else inline_params e) in
let init = match vars with [] -> None | l -> Some l in
(*
If we have local variables and returning a value, then this will result in
unoptimized JS code, so let's instead skip inlining.
This could be fixed with better post process code cleanup (planed)
*)
if !cancel_inlining || (not (Common.defined ctx.com Define.Analyzer) && Common.platform ctx.com Js && not !force && (init <> None || !has_vars)) then
None
else
let wrap e =
(* we can't mute the type of the expression because it is not correct to do so *)
let etype = if has_params then map_type e.etype else e.etype in
(* if the expression is "untyped" and we don't want to unify it accidentally ! *)
try (match follow e.etype with
| TMono _ | TInst ({cl_kind = KTypeParameter _ },_) ->
(match follow tret with
| TAbstract ({ a_path = [],"Void" },_) -> e
| _ -> raise (Unify_error []))
| _ ->
type_eq (if ctx.com.config.pf_static then EqDoNotFollowNull else EqStrict) etype tret;
e)
with Unify_error _ ->
mk (TCast (e,None)) tret e.epos
in
let e = (match e.eexpr, init with
| _, None when not !has_return_value ->
{e with etype = tret}
| TBlock [e] , None -> wrap e
| _ , None -> wrap e
| TBlock l, Some vl ->
let el_v = List.map (fun (v,eo) -> mk (TVar (v,eo)) ctx.t.tvoid e.epos) vl in
mk (TBlock (el_v @ l)) tret e.epos
| _, Some vl ->
let el_v = List.map (fun (v,eo) -> mk (TVar (v,eo)) ctx.t.tvoid e.epos) vl in
mk (TBlock (el_v @ [e])) tret e.epos
) in
let inline_meta e meta = match meta with
| Meta.Deprecated,_,_ -> mk (TMeta(meta,e)) e.etype e.epos
| _ -> e
in
let e = List.fold_left inline_meta e cf.cf_meta in
(* we need to replace type-parameters that were used in the expression *)
if not has_params then
Some e
else
let mt = map_type cf.cf_type in
let unify_func () = unify_raise ctx mt (TFun (List.map (fun e -> "",false,e.etype) params,tret)) p in
(match follow ethis.etype with
| TAnon a -> (match !(a.a_status) with
| Statics {cl_kind = KAbstractImpl a } when Meta.has Meta.Impl cf.cf_meta ->
if cf.cf_name <> "_new" then begin
(* the first argument must unify with a_this for abstract implementation functions *)
let tb = (TFun(("",false,map_type a.a_this) :: List.map (fun e -> "",false,e.etype) (List.tl params),tret)) in
unify_raise ctx mt tb p
end
| _ -> unify_func())
| _ -> unify_func());
(*
this is very expensive since we are building the substitution list for
every expression, but hopefully in such cases the expression size is small
*)
let vars = Hashtbl.create 0 in
let map_var v =
if not (Hashtbl.mem vars v.v_id) then begin
Hashtbl.add vars v.v_id ();
v.v_type <- map_type v.v_type;
end;
v
in
let rec map_expr_type e = Type.map_expr_type map_expr_type map_type map_var e in
Some (map_expr_type e)
(* ---------------------------------------------------------------------- *)
(* LOOPS *)
let rec optimize_for_loop ctx (i,pi) e1 e2 p =
let t_void = ctx.t.tvoid in
let t_int = ctx.t.tint in
let lblock el = Some (mk (TBlock el) t_void p) in
let mk_field e n =
TField (e,try quick_field e.etype n with Not_found -> assert false)
in
let gen_int_iter pt f_get f_length =
let i = add_local ctx i pt in
let index = gen_local ctx t_int in
let arr, avars = (match e1.eexpr with
| TLocal _ -> e1, None
| _ ->
let atmp = gen_local ctx e1.etype in
mk (TLocal atmp) e1.etype e1.epos, (Some (atmp,Some e1))
) in
let iexpr = mk (TLocal index) t_int p in
let e2 = type_expr ctx e2 NoValue in
let aget = mk (TVar (i,Some (f_get arr iexpr pt p))) t_void pi in
let incr = mk (TUnop (Increment,Prefix,iexpr)) t_int p in
let block = match e2.eexpr with
| TBlock el -> mk (TBlock (aget :: incr :: el)) t_void e2.epos
| _ -> mk (TBlock [aget;incr;e2]) t_void p
in
let ivar = Some (mk (TConst (TInt 0l)) t_int p) in
let elength = f_length arr p in
let el = [mk (TWhile (
mk (TBinop (OpLt, iexpr, elength)) ctx.t.tbool p,
block,
NormalWhile
)) t_void p;
] in
let el = match avars with None -> el | Some (v,eo) -> (mk (TVar (v,eo)) t_void p) :: el in
let el = (mk (TVar (index,ivar)) t_void p) :: el in
lblock el
in
let get_next_array_element arr iexpr pt p =
(mk (TArray (arr,iexpr)) pt p)
in
let get_array_length arr p =
mk (mk_field arr "length") ctx.com.basic.tint p
in
match e1.eexpr, follow e1.etype with
| TNew ({ cl_path = ([],"IntIterator") },[],[i1;i2]) , _ ->
let max = (match i1.eexpr , i2.eexpr with
| TConst (TInt a), TConst (TInt b) when Int32.compare b a < 0 -> error "Range operator can't iterate backwards" p
| _, TConst _ | _ , TLocal _ -> None
| _ -> Some (gen_local ctx t_int)
) in
let tmp = gen_local ctx t_int in
let i = add_local ctx i t_int in
let rec check e =
match e.eexpr with
| TBinop (OpAssign,{ eexpr = TLocal l },_)
| TBinop (OpAssignOp _,{ eexpr = TLocal l },_)
| TUnop (Increment,_,{ eexpr = TLocal l })
| TUnop (Decrement,_,{ eexpr = TLocal l }) when l == i ->
error "Loop variable cannot be modified" e.epos
| _ ->
Type.iter check e
in
let e2 = type_expr ctx e2 NoValue in
check e2;
let etmp = mk (TLocal tmp) t_int p in
let incr = mk (TUnop (Increment,Postfix,etmp)) t_int p in
let init = mk (TVar (i,Some incr)) t_void pi in
let block = match e2.eexpr with
| TBlock el -> mk (TBlock (init :: el)) t_void e2.epos
| _ -> mk (TBlock [init;e2]) t_void p
in
(*
force locals to be of Int type (to prevent Int/UInt issues)
*)
let i2 = match follow i2.etype with
| TAbstract ({ a_path = ([],"Int") }, []) -> i2
| _ -> { i2 with eexpr = TCast(i2, None); etype = t_int }
in
(match max with
| None ->
lblock [
mk (TVar (tmp,Some i1)) t_void p;
mk (TWhile (
mk (TBinop (OpLt, etmp, i2)) ctx.t.tbool p,
block,
NormalWhile
)) t_void p;
]
| Some max ->
lblock [
mk (TVar (tmp,Some i1)) t_void p;
mk (TVar (max,Some i2)) t_void p;
mk (TWhile (
mk (TBinop (OpLt, etmp, mk (TLocal max) t_int p)) ctx.t.tbool p,
block,
NormalWhile
)) t_void p;
])
| TArrayDecl el, TInst({ cl_path = [],"Array" },[pt]) when false ->
begin try
let num_expr = ref 0 in
let rec loop e = match fst e with
| EContinue | EBreak ->
raise Exit
| _ ->
incr num_expr;
Ast.map_expr loop e
in
ignore(loop e2);
let v = add_local ctx i pt in
let e2 = type_expr ctx e2 NoValue in
let cost = (List.length el) * !num_expr in
let max_cost = try
int_of_string (Common.defined_value ctx.com Define.LoopUnrollMaxCost)
with Not_found ->
250
in
if cost > max_cost then raise Exit;
let eloc = mk (TLocal v) v.v_type p in
let el = List.map (fun e ->
let e_assign = mk (TBinop(OpAssign,eloc,e)) e.etype e.epos in
concat e_assign e2
) el in
let ev = mk (TVar(v, None)) ctx.t.tvoid p in
Some (mk (TBlock (ev :: el)) ctx.t.tvoid p)
with Exit ->
gen_int_iter pt get_next_array_element get_array_length
end
| _ , TInst({ cl_path = [],"Array" },[pt])
| _ , TInst({ cl_path = ["flash"],"Vector" },[pt]) ->
gen_int_iter pt get_next_array_element get_array_length
| _ , TInst({ cl_array_access = Some pt } as c,pl) when (try match follow (PMap.find "length" c.cl_fields).cf_type with TAbstract ({ a_path = [],"Int" },[]) -> true | _ -> false with Not_found -> false) && not (PMap.mem "iterator" c.cl_fields) ->
gen_int_iter (apply_params c.cl_params pl pt) get_next_array_element get_array_length
| _, TAbstract({a_impl = Some c} as a,tl) ->
begin try
let cf_length = PMap.find "get_length" c.cl_statics in
let get_length e p =
make_static_call ctx c cf_length (apply_params a.a_params tl) [e] ctx.com.basic.tint p
in
begin match follow cf_length.cf_type with
| TFun(_,tr) ->
begin match follow tr with
| TAbstract({a_path = [],"Int"},_) -> ()
| _ -> raise Not_found
end
| _ ->
raise Not_found
end;
begin try
(* first try: do we have an @:arrayAccess getter field? *)
let todo = mk (TConst TNull) ctx.t.tint p in
let cf,_,r,_,_ = (!find_array_access_raise_ref) ctx a tl todo None p in
let get_next e_base e_index t p =
make_static_call ctx c cf (apply_params a.a_params tl) [e_base;e_index] r p
in
gen_int_iter r get_next get_length
with Not_found ->
(* second try: do we have @:arrayAccess on the abstract itself? *)
if not (Meta.has Meta.ArrayAccess a.a_meta) then raise Not_found;
(* let's allow this only for core-type abstracts *)
if not (Meta.has Meta.CoreType a.a_meta) then raise Not_found;
(* in which case we assume that a singular type parameter is the element type *)
let t = match tl with [t] -> t | _ -> raise Not_found in
gen_int_iter t get_next_array_element get_length
end with Not_found ->
None
end
| _ , TInst ({ cl_kind = KGenericInstance ({ cl_path = ["haxe";"ds"],"GenericStack" },[t]) } as c,[]) ->
let tcell = (try (PMap.find "head" c.cl_fields).cf_type with Not_found -> assert false) in
let i = add_local ctx i t in
let cell = gen_local ctx tcell in
let cexpr = mk (TLocal cell) tcell p in
let e2 = type_expr ctx e2 NoValue in
let evar = mk (TVar (i,Some (mk (mk_field cexpr "elt") t p))) t_void pi in
let enext = mk (TBinop (OpAssign,cexpr,mk (mk_field cexpr "next") tcell p)) tcell p in
let block = match e2.eexpr with
| TBlock el -> mk (TBlock (evar :: enext :: el)) t_void e2.epos
| _ -> mk (TBlock [evar;enext;e2]) t_void p
in
lblock [
mk (TVar (cell,Some (mk (mk_field e1 "head") tcell p))) t_void p;
mk (TWhile (
mk (TBinop (OpNotEq, cexpr, mk (TConst TNull) tcell p)) ctx.t.tbool p,
block,
NormalWhile
)) t_void p
]
| _ ->
None
let optimize_for_loop_iterator ctx v e1 e2 p =
let c,tl = (match follow e1.etype with TInst (c,pl) -> c,pl | _ -> raise Exit) in
let _, _, fhasnext = (try raw_class_field (fun cf -> apply_params c.cl_params tl cf.cf_type) c tl "hasNext" with Not_found -> raise Exit) in
if fhasnext.cf_kind <> Method MethInline then raise Exit;
let tmp = gen_local ctx e1.etype in
let eit = mk (TLocal tmp) e1.etype p in
let ehasnext = make_call ctx (mk (TField (eit,FInstance (c, tl, fhasnext))) (TFun([],ctx.t.tbool)) p) [] ctx.t.tbool p in
let enext = mk (TVar (v,Some (make_call ctx (mk (TField (eit,quick_field_dynamic eit.etype "next")) (TFun ([],v.v_type)) p) [] v.v_type p))) ctx.t.tvoid p in
let eblock = (match e2.eexpr with
| TBlock el -> { e2 with eexpr = TBlock (enext :: el) }
| _ -> mk (TBlock [enext;e2]) ctx.t.tvoid p
) in
mk (TBlock [
mk (TVar (tmp,Some e1)) ctx.t.tvoid p;
mk (TWhile (ehasnext,eblock,NormalWhile)) ctx.t.tvoid p
]) ctx.t.tvoid p
(* ---------------------------------------------------------------------- *)
(* SANITIZE *)
(*
makes sure that when an AST get generated to source code, it will not
generate expressions that evaluate differently. It is then necessary to
add parenthesises around some binary expressions when the AST does not
correspond to the natural operand priority order for the platform
*)
(*
this is the standard C++ operator precedence, which is also used by both JS and PHP
*)
let standard_precedence op =
let left = true and right = false in
match op with
| OpMult | OpDiv | OpMod -> 5, left
| OpAdd | OpSub -> 6, left
| OpShl | OpShr | OpUShr -> 7, left
| OpLt | OpLte | OpGt | OpGte -> 8, left
| OpEq | OpNotEq -> 9, left
| OpAnd -> 10, left
| OpXor -> 11, left
| OpOr -> 12, left
| OpInterval -> 13, right (* haxe specific *)
| OpBoolAnd -> 14, left
| OpBoolOr -> 15, left
| OpArrow -> 16, left
| OpAssignOp OpAssign -> 17, right (* mimics ?: *)
| OpAssign | OpAssignOp _ -> 18, right
let rec need_parent e =
match e.eexpr with
| TConst _ | TLocal _ | TArray _ | TField _ | TEnumParameter _ | TParenthesis _ | TMeta _ | TCall _ | TNew _ | TTypeExpr _ | TObjectDecl _ | TArrayDecl _ -> false
| TCast (e,None) -> need_parent e
| TCast _ | TThrow _ | TReturn _ | TTry _ | TSwitch _ | TFor _ | TIf _ | TWhile _ | TBinop _ | TContinue | TBreak
| TBlock _ | TVar _ | TFunction _ | TUnop _ -> true
let sanitize_expr com e =
let parent e =
match e.eexpr with
| TParenthesis _ -> e
| _ -> mk (TParenthesis e) e.etype e.epos
in
let block e =
match e.eexpr with
| TBlock _ -> e
| _ -> mk (TBlock [e]) e.etype e.epos
in
let complex e =
(* complex expressions are the one that once generated to source consists in several expressions *)
match e.eexpr with
| TVar _ (* needs to be put into blocks *)
| TFor _ (* a temp var is needed for holding iterator *)
| TCall ({ eexpr = TLocal { v_name = "__js__" } },_) (* we never know *)
-> block e
| _ -> e
in
(* tells if the printed expresssion ends with an if without else *)
let rec has_if e =
match e.eexpr with
| TIf (_,_,None) -> true
| TWhile (_,e,NormalWhile) -> has_if e
| TFor (_,_,e) -> has_if e
| _ -> false
in
match e.eexpr with
| TConst TNull ->
if com.config.pf_static && not (is_nullable e.etype) then begin
let rec loop t = match follow t with
| TMono _ -> () (* in these cases the null will cast to default value *)
| TFun _ -> () (* this is a bit a particular case, maybe flash-specific actually *)
(* TODO: this should use get_underlying_type, but we do not have access to Codegen here. *)
| TAbstract(a,tl) when not (Meta.has Meta.CoreType a.a_meta) -> loop (apply_params a.a_params tl a.a_this)
| _ -> com.error ("On static platforms, null can't be used as basic type " ^ s_type (print_context()) e.etype) e.epos
in
loop e.etype
end;
e
| TBinop (op,e1,e2) ->
let swap op1 op2 =
let p1, left1 = standard_precedence op1 in
let p2, _ = standard_precedence op2 in
left1 && p1 <= p2
in
let rec loop ee left =
match ee.eexpr with
| TBinop (op2,_,_) -> if left then not (swap op2 op) else swap op op2
| TIf _ -> if left then not (swap (OpAssignOp OpAssign) op) else swap op (OpAssignOp OpAssign)
| TCast (e,None) -> loop e left
| _ -> false
in
let e1 = if loop e1 true then parent e1 else e1 in
let e2 = if loop e2 false then parent e2 else e2 in
{ e with eexpr = TBinop (op,e1,e2) }
| TUnop (op,mode,e1) ->
let rec loop ee =
match ee.eexpr with
| TBinop _ | TIf _ | TUnop _ -> parent e1
| TCast (e,None) -> loop e
| _ -> e1
in
{ e with eexpr = TUnop (op,mode,loop e1)}
| TIf (e1,e2,eelse) ->
let e1 = parent e1 in
let e2 = (if (eelse <> None && has_if e2) || (match e2.eexpr with TIf _ -> true | _ -> false) then block e2 else complex e2) in
let eelse = (match eelse with None -> None | Some e -> Some (complex e)) in
{ e with eexpr = TIf (e1,e2,eelse) }
| TWhile (e1,e2,flag) ->
let e1 = parent e1 in
let e2 = complex e2 in
{ e with eexpr = TWhile (e1,e2,flag) }
| TFor (v,e1,e2) ->
let e2 = complex e2 in
{ e with eexpr = TFor (v,e1,e2) }
| TFunction f ->
let f = (match f.tf_expr.eexpr with
| TBlock _ -> f
| _ -> { f with tf_expr = block f.tf_expr }
) in
{ e with eexpr = TFunction f }
| TCall (e2,args) ->
if need_parent e2 then { e with eexpr = TCall(parent e2,args) } else e
| TEnumParameter (e2,ef,i) ->
if need_parent e2 then { e with eexpr = TEnumParameter(parent e2,ef,i) } else e
| TField (e2,f) ->
if need_parent e2 then { e with eexpr = TField(parent e2,f) } else e
| TArray (e1,e2) ->
if need_parent e1 then { e with eexpr = TArray(parent e1,e2) } else e
| TTry (e1,catches) ->
let e1 = block e1 in
let catches = List.map (fun (v,e) -> v, block e) catches in
{ e with eexpr = TTry (e1,catches) }
| TSwitch (e1,cases,def) ->
let e1 = parent e1 in
let cases = List.map (fun (el,e) -> el, complex e) cases in
let def = (match def with None -> None | Some e -> Some (complex e)) in
{ e with eexpr = TSwitch (e1,cases,def) }
| _ ->
e
let reduce_expr com e =
match e.eexpr with
| TSwitch (_,cases,_) ->
List.iter (fun (cl,_) ->
List.iter (fun e ->
match e.eexpr with
| TCall ({ eexpr = TField (_,FEnum _) },_) -> error "Not-constant enum in switch cannot be matched" e.epos
| _ -> ()
) cl
) cases;
e
| TBlock l ->
(match List.rev l with
| [] -> e
| ec :: l ->
(* remove all no-ops : not-final constants in blocks *)
match List.filter (fun e -> match e.eexpr with
| TConst _
| TBlock []
| TObjectDecl [] ->
false
| _ ->
true
) l with
| [] -> ec
| l -> { e with eexpr = TBlock (List.rev (ec :: l)) })
| TParenthesis ec ->