forked from HaxeFoundation/haxe
-
Notifications
You must be signed in to change notification settings - Fork 0
/
genswf9.ml
2389 lines (2290 loc) · 69.6 KB
/
genswf9.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
(*
The Haxe Compiler
Copyright (C) 2005-2015 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 Ast
open Type
open As3
open As3hl
open Common
type read = Read
type write = Unused__ | Write
type tkind =
| KInt
| KUInt
| KFloat
| KBool
| KType of hl_name
| KDynamic
| KNone
type register = {
rid : int;
rtype : tkind;
mutable rused : bool;
mutable rinit : bool;
mutable rcond : bool;
}
type 'a access =
| VReg of register
| VId of hl_name
| VCast of hl_name * tkind
| VGlobal of hl_name
| VArray
| VScope of hl_slot
| VVolatile of hl_name * tkind option
| VSuper of hl_name
type local =
| LReg of register
| LScope of hl_slot
| LGlobal of hl_name
type code_infos = {
mutable iregs : register DynArray.t;
mutable ipos : int;
mutable istack : int;
mutable imax : int;
mutable iscopes : int;
mutable imaxscopes : int;
mutable iloop : int;
mutable icond : bool;
}
type try_infos = {
tr_pos : int;
tr_end : int;
tr_catch_pos : int;
tr_type : t;
}
type context = {
(* globals *)
com : Common.context;
debugger : bool;
swc : bool;
boot : path;
swf_protected : bool;
need_ctor_skip : bool;
mutable cur_class : tclass;
mutable debug : bool;
mutable last_line : int;
mutable last_file : string;
(* per-function *)
mutable locals : (int,tvar * local) PMap.t;
mutable code : hl_opcode DynArray.t;
mutable infos : code_infos;
mutable trys : try_infos list;
mutable breaks : (unit -> unit) list;
mutable continues : (int -> unit) list;
mutable in_static : bool;
mutable block_vars : (hl_slot * string * hl_name option) list;
mutable try_scope_reg : register option;
mutable for_call : bool;
}
let rec follow t = match Type.follow t with
| TAbstract(a,tl) when not (Meta.has Meta.CoreType a.a_meta) ->
follow (Abstract.get_underlying_type a tl)
| t ->
t
let invalid_expr p = error "Invalid expression" p
let stack_error p = error "Stack error" p
let index_int (x : int) : 'a index = Obj.magic (x + 1)
let index_nz_int (x : int) : 'a index_nz = Obj.magic x
let tid (x : 'a index) : int = Obj.magic x
let ethis = mk (TConst TThis) (mk_mono()) null_pos
let dynamic_prop = HMMultiNameLate [HNPublic (Some "")]
let is_special_compare e1 e2 =
match e1.eexpr, e2.eexpr with
| TConst TNull, _ | _ , TConst TNull -> None
| _ ->
match follow e1.etype, follow e2.etype with
| TInst ({ cl_path = ["flash"],"NativeXml" } as c,_) , _ | _ , TInst ({ cl_path = ["flash"],"NativeXml" } as c,_) -> Some c
| _ -> None
let write ctx op =
DynArray.add ctx.code op;
ctx.infos.ipos <- ctx.infos.ipos + 1;
let s = ctx.infos.istack + As3hlparse.stack_delta op in
ctx.infos.istack <- s;
if s > ctx.infos.imax then ctx.infos.imax <- s;
match op with
| HScope ->
let n = ctx.infos.iscopes + 1 in
ctx.infos.iscopes <- n;
if n > ctx.infos.imaxscopes then ctx.infos.imaxscopes <- n
| HPopScope ->
ctx.infos.iscopes <- ctx.infos.iscopes - 1
| _ ->
()
let jump ctx cond =
let op = DynArray.length ctx.code in
let p = ctx.infos.ipos in
write ctx (HJump (cond,0));
(fun () ->
let delta = ctx.infos.ipos - p in
DynArray.set ctx.code op (HJump (cond,delta))
)
let jump_back ctx =
let p = ctx.infos.ipos in
write ctx HLabel;
(fun cond ->
let delta = p - ctx.infos.ipos in
write ctx (HJump (cond,delta))
)
let real_path = function
| [] , "Int" -> [] , "int"
| [] , "UInt" -> [] , "uint"
| [] , "Float" -> [] , "Number"
| [] , "Bool" -> [] , "Boolean"
| [] , "Enum" -> [] , "Class"
| [] , "EnumValue" -> [] , "Object"
| ["flash";"xml"], "XML" -> [], "XML"
| ["flash";"xml"], "XMLList" -> [], "XMLList"
| ["flash";"utils"], "QName" -> [] , "QName"
| ["flash";"utils"], "Namespace" -> [] , "Namespace"
| ["flash";"utils"], "Object" -> [] , "Object"
| ["flash";"utils"], "Function" -> [] , "Function"
| ["flash"] , "FlashXml__" -> [] , "Xml"
| ["flash";"errors"] , "Error" -> [], "Error"
| ["flash"] , "Vector" -> ["__AS3__";"vec"], "Vector"
| path -> path
let type_path ctx path =
let pack, name = real_path path in
HMPath (pack,name)
let rec follow_basic t =
match t with
| TMono r ->
(match !r with
| Some t -> follow_basic t
| _ -> t)
| TLazy f ->
follow_basic (!f())
| TType ({ t_path = [],"Null" },[tp]) ->
(match follow_basic tp with
| TMono _
| TFun _
| TAbstract ({ a_path = ([],"Int") },[])
| TAbstract ({ a_path = ([],"Float") },[])
| TAbstract ({ a_path = [],"UInt" },[])
| TAbstract ({ a_path = ([],"Bool") },[])
| TInst ({ cl_path = (["haxe"],"Int32") },[]) -> t
| t -> t)
| TType ({ t_path = ["flash";"utils"],"Object" },[])
| TType ({ t_path = ["flash";"utils"],"Function" },[])
| TType ({ t_path = [],"UInt" },[]) ->
t
| TType (t,tl) ->
follow_basic (apply_params t.t_params tl t.t_type)
| TAbstract (a,pl) when not (Meta.has Meta.CoreType a.a_meta) ->
follow_basic (apply_params a.a_params pl a.a_this)
| _ -> t
let rec type_id ctx t =
match follow_basic t with
| TInst ({ cl_path = ["haxe"],"Int32" },_) ->
type_path ctx ([],"Int")
| TInst ({ cl_path = ["flash"],"Vector" } as c,pl) ->
(match pl with
| [TInst({cl_kind = KTypeParameter _},_)] -> type_path ctx ([],"Object")
| _ -> HMParams (type_path ctx c.cl_path,List.map (type_id ctx) pl))
| TInst (c,_) ->
(match c.cl_kind with
| KTypeParameter l ->
(match l with
| [t] -> type_id ctx t
| _ -> type_path ctx ([],"Object"))
| KExtension (c,params) ->
type_id ctx (TInst (c,params))
| _ ->
type_path ctx c.cl_path)
| TAbstract (a,_) ->
type_path ctx a.a_path
| TFun _ | TType ({ t_path = ["flash";"utils"],"Function" },[]) ->
type_path ctx ([],"Function")
| TType ({ t_path = ([],"UInt") as path },_) ->
type_path ctx path
| TEnum ({ e_path = ["flash"],"XmlType"; e_extern = true },_) ->
HMPath ([],"String")
| TEnum (e,_) ->
let rec loop = function
| [] -> type_path ctx e.e_path
| (Meta.FakeEnum,[Ast.EConst (Ast.Ident n),_],_) :: _ -> type_path ctx ([],n)
| _ :: l -> loop l
in
loop e.e_meta
| _ ->
HMPath ([],"Object")
let type_opt ctx t =
match follow_basic t with
| TDynamic _ | TMono _ -> None
| _ -> Some (type_id ctx t)
let type_void ctx t =
match follow t with
| TEnum ({ e_path = [],"Void" },_) | TAbstract ({ a_path = [],"Void" },_) -> Some (HMPath ([],"void"))
| _ -> type_opt ctx t
let classify ctx t =
match follow_basic t with
| TAbstract ({ a_path = [],"Int" },_) | TInst ({ cl_path = [],"Int" },_) | TInst ({ cl_path = ["haxe"],"Int32" },_) ->
KInt
| TAbstract ({ a_path = [],"Float" },_) | TInst ({ cl_path = [],"Float" },_) ->
KFloat
| TAbstract ({ a_path = [],"Bool" },_) | TEnum ({ e_path = [],"Bool" },_) ->
KBool
| TAbstract ({ a_path = [],"Void" },_) | TEnum ({ e_path = [],"Void" },_) ->
KDynamic
| TEnum ({ e_path = ["flash"],"XmlType"; e_extern = true },_) ->
KType (HMPath ([],"String"))
| TEnum (e,_) ->
let rec loop = function
| [] -> KType (type_id ctx t)
| (Meta.FakeEnum,[Ast.EConst (Ident n),_],_) :: _ ->
(match n with
| "Int" -> KInt
| "UInt" -> KUInt
| "String" -> KType (HMPath ([],"String"))
| _ -> assert false)
| _ :: l -> loop l
in
loop e.e_meta
| TAbstract ({ a_path = [],"UInt" },_) | TType ({ t_path = [],"UInt" },_) ->
KUInt
| TFun _ | TType ({ t_path = ["flash";"utils"],"Function" },[]) ->
KType (HMPath ([],"Function"))
| TAnon a ->
(match !(a.a_status) with
| Statics _ -> KNone
| _ -> KDynamic)
| TType ({ t_path = ["flash";"utils"],"Object" },[]) ->
KType (HMPath ([],"Object"))
| TInst _ | TAbstract _ ->
KType (type_id ctx t)
| TMono _
| TType _
| TDynamic _ ->
KDynamic
| TLazy _ ->
assert false
(* some field identifiers might cause issues with SWC *)
let reserved i =
match i with
| "int" -> "_" ^ i
| _ -> i
let ident i =
HMPath ([],reserved i)
let as3 p =
HMName (p,HNNamespace "http://adobe.com/AS3/2006/builtin")
let property ctx p t =
match follow t with
| TInst ({ cl_path = [],"Array" },_) ->
(match p with
| "length" -> ident p, Some KInt, false (* UInt in the spec *)
| "map" | "filter" when Common.defined ctx.com Define.NoFlashOverride -> ident (p ^ "HX"), None, true
| "copy" | "insert" | "remove" | "iterator" | "toString" | "map" | "filter" -> ident p , None, true
| _ -> as3 p, None, false);
| TInst ({ cl_path = ["flash"],"Vector" },_) ->
(match p with
| "length" -> ident p, Some KInt, false (* UInt in the spec *)
| "fixed" | "toString" -> ident p, None, false
| "iterator" -> ident p, None, true
| _ -> as3 p, None, false);
| TInst ({ cl_path = [],"String" },_) ->
(match p with
| "length" (* Int in AS3/Haxe *) -> ident p, None, false
| "charCodeAt" when Common.defined ctx.com Define.NoFlashOverride -> ident (p ^ "HX"), None, true
| "charCodeAt" (* use Haxe version *) -> ident p, None, true
| "cca" -> as3 "charCodeAt", None, false
| _ -> as3 p, None, false);
| TInst ({ cl_path = [],"Date" },_) ->
(match p with
| "toString" when Common.defined ctx.com Define.NoFlashOverride -> ident (p ^ "HX"), None, true
| _ -> ident p, None, false)
| TAnon a ->
(match !(a.a_status) with
| Statics { cl_path = [], "Math" } ->
(match p with
| "POSITIVE_INFINITY" | "NEGATIVE_INFINITY" | "NaN" -> ident p, Some KFloat, false
| "floor" | "ceil" | "round" when ctx.for_call -> ident p, Some KInt, false
| "ffloor" | "fceil" | "fround" -> ident (String.sub p 1 (String.length p - 1)), None, false
| _ -> ident p, None, false)
| _ -> ident p, None, false)
| TInst ({ cl_kind = KExtension _ } as c,params) ->
(* cast type when accessing an extension field *)
(try
let f = PMap.find p c.cl_fields in
ident p, Some (classify ctx (apply_params c.cl_params params f.cf_type)), false
with Not_found ->
ident p, None, false)
| TInst ({ cl_interface = true } as c,_) ->
(* lookup the interface in which the field was actually declared *)
let rec loop c =
try
(match PMap.find p c.cl_fields with
| { cf_kind = Var _ | Method MethDynamic } -> raise Exit (* no vars in interfaces in swf9 *)
| _ -> c)
with Not_found ->
let rec loop2 = function
| [] -> raise Not_found
| (i,_) :: l ->
try loop i with Not_found -> loop2 l
in
loop2 c.cl_implements
in
(try
let c = loop c in
let ns = HMName (reserved p, HNNamespace (match c.cl_path with [],n -> n | l,n -> String.concat "." l ^ ":" ^ n)) in
ns, None, false
with Not_found | Exit ->
ident p, None, false)
| _ ->
ident p, None, false
let default_infos() =
{
ipos = 0;
istack = 0;
imax = 0;
iregs = DynArray.create();
iscopes = 0;
imaxscopes = 0;
iloop = -1;
icond = false;
}
let alloc_reg ctx k =
let regs = ctx.infos.iregs in
try
let p = DynArray.index_of (fun r -> not r.rused && k = r.rtype) regs in
let r = DynArray.unsafe_get regs p in
r.rused <- true;
r.rinit <- false;
r
with
Not_found ->
let r = {
rid = DynArray.length regs + 1;
rused = true;
rinit = false;
rtype = k;
rcond = false;
} in
DynArray.add regs r;
r
let coerce ctx t =
(* it would be useful to know if we don't already have
this type on the stack (as detected by the bytecode verifier)...
maybe this get removed at JIT, so it's only useful to reduce codesize
*)
if t <> KNone then
write ctx (match t with
| KInt -> HToInt
| KUInt -> HToUInt
| KFloat -> HToNumber
| KBool -> HToBool
| KType t -> HCast t
| KDynamic -> HAsAny
| KNone -> assert false
)
let set_reg ctx r =
if not r.rinit then begin
r.rinit <- true;
if ctx.infos.icond then r.rcond <- true;
end;
coerce ctx r.rtype;
write ctx (HSetReg r.rid)
let set_reg_dup ctx r =
if not r.rinit then begin
r.rinit <- true;
if ctx.infos.icond then r.rcond <- true;
end;
coerce ctx r.rtype;
write ctx HDup;
write ctx (HSetReg r.rid)
let free_reg ctx r =
r.rused <- false
let pop ctx n =
let rec loop n =
if n > 0 then begin
write ctx HPop;
loop (n - 1)
end
in
if n < 0 then assert false;
let old = ctx.infos.istack in
loop n;
ctx.infos.istack <- old
let is_member ctx name =
let rec loop c =
PMap.mem name c.cl_fields || (match c.cl_super with None -> false | Some (c,_) -> loop c)
in
loop ctx.cur_class
let rename_block_var ctx v =
(* we need to rename it since slots are accessed on a by-name basis *)
let rec loop i =
let name = v.v_name ^ string_of_int i in
if List.exists (fun(_,x,_) -> name = x) ctx.block_vars || is_member ctx name then
loop (i + 1)
else
v.v_name <- name
in
loop 1
let define_local ctx ?(init=false) v p =
let name = v.v_name in
let t = v.v_type in
let l = (if v.v_capture then begin
let topt = type_opt ctx t in
if List.exists (fun (_,x,_) -> name = x) ctx.block_vars || is_member ctx name then rename_block_var ctx v;
let pos = List.length ctx.block_vars + 1 in
ctx.block_vars <- (pos,v.v_name,topt) :: ctx.block_vars;
LScope pos
end else
let r = alloc_reg ctx (classify ctx t) in
if ctx.debug then write ctx (HDebugReg (name, r.rid, ctx.last_line));
r.rinit <- init;
LReg r
) in
ctx.locals <- PMap.add v.v_id (v,l) ctx.locals
let is_set v = (Obj.magic v) = Write
let gen_local_access ctx v p (forset : 'a) : 'a access =
match snd (try PMap.find v.v_id ctx.locals with Not_found -> error ("Unbound variable " ^ v.v_name) p) with
| LReg r ->
VReg r
| LScope n ->
write ctx (HGetScope 1);
VScope n
| LGlobal p ->
if is_set forset then write ctx (HFindProp p);
VGlobal p
let get_local_register ctx v =
match (try snd (PMap.find v.v_id ctx.locals) with Not_found -> LScope 0) with
| LReg r -> Some r
| _ -> None
let rec setvar ctx (acc : write access) kret =
match acc with
| VReg r ->
if kret <> None then
set_reg_dup ctx r
else
set_reg ctx r;
| VGlobal _ | VId _ | VCast _ | VArray | VScope _ when kret <> None ->
let r = alloc_reg ctx (match kret with None -> assert false | Some k -> k) in
set_reg_dup ctx r;
setvar ctx acc None;
write ctx (HReg r.rid);
free_reg ctx r
| VGlobal g ->
write ctx (HSetProp g)
| VId id | VCast (id,_) ->
write ctx (HInitProp id)
| VVolatile (id,_) ->
write ctx (HArray 1);
write ctx (HInitProp id)
| VArray ->
write ctx (HSetProp dynamic_prop);
ctx.infos.istack <- ctx.infos.istack - 1
| VScope n ->
write ctx (HSetSlot n)
| VSuper id ->
write ctx (HSetSuper id)
let getvar ctx (acc : read access) =
match acc with
| VReg r ->
if not r.rinit then begin
r.rinit <- true;
r.rcond <- true;
end;
write ctx (HReg r.rid)
| VId id ->
write ctx (HGetProp id)
| VVolatile (id,t) ->
write ctx (HGetProp id);
write ctx (HSmallInt 0);
write ctx (HGetProp dynamic_prop);
ctx.infos.istack <- ctx.infos.istack - 1;
(match t with
| None -> ()
| Some t -> coerce ctx t)
| VCast (id,t) ->
write ctx (HGetProp id);
coerce ctx t
| VGlobal g ->
write ctx (HGetLex g);
| VArray ->
write ctx (HGetProp dynamic_prop);
ctx.infos.istack <- ctx.infos.istack - 1
| VScope n ->
write ctx (HGetSlot n)
| VSuper id ->
write ctx (HGetSuper id)
let open_block ctx retval =
let old_stack = ctx.infos.istack in
let old_regs = DynArray.map (fun r -> r.rused) ctx.infos.iregs in
let old_locals = ctx.locals in
(fun() ->
if ctx.infos.istack <> old_stack + (if retval then 1 else 0) then assert false;
let rcount = DynArray.length old_regs + 1 in
DynArray.iter (fun r ->
if r.rid < rcount then
r.rused <- DynArray.unsafe_get old_regs (r.rid - 1)
else
r.rused <- false
) ctx.infos.iregs;
ctx.locals <- old_locals;
)
let begin_branch ctx =
if ctx.infos.icond then
(fun() -> ())
else begin
ctx.infos.icond <- true;
(fun() -> ctx.infos.icond <- false)
end
let begin_switch ctx =
let branch = begin_branch ctx in
let switch_index = DynArray.length ctx.code in
let switch_pos = ctx.infos.ipos in
write ctx (HSwitch (0,[]));
let constructs = ref [] in
let max = ref 0 in
let ftag tag =
if tag > !max then max := tag;
constructs := (tag,ctx.infos.ipos) :: !constructs;
in
let fend() =
let cases = Array.create (!max + 1) 1 in
List.iter (fun (tag,pos) -> Array.set cases tag (pos - switch_pos)) !constructs;
DynArray.set ctx.code switch_index (HSwitch (1,Array.to_list cases));
branch();
in
fend, ftag
let debug_infos ?(is_min=true) ctx p =
if ctx.debug then begin
let line = Lexer.get_error_line (if is_min then p else { p with pmin = p.pmax }) in
if ctx.last_file <> p.pfile then begin
write ctx (HDebugFile (if ctx.debugger then Common.get_full_path p.pfile else p.pfile));
ctx.last_file <- p.pfile;
ctx.last_line <- -1;
end;
if ctx.last_line <> line then begin
write ctx (HDebugLine line);
ctx.last_line <- line;
end
end
let to_utf8 str =
try
UTF8.validate str;
str;
with
UTF8.Malformed_code ->
let b = UTF8.Buf.create 0 in
String.iter (fun c -> UTF8.Buf.add_char b (UChar.of_char c)) str;
UTF8.Buf.contents b
let gen_constant ctx c t p =
match c with
| TInt i ->
let unsigned = classify ctx t = KUInt in
if Int32.compare i (-128l) > 0 && Int32.compare i 128l < 0 then begin
write ctx (HSmallInt (Int32.to_int i));
if unsigned then write ctx HToUInt;
end else
write ctx (if unsigned then HUIntRef i else HIntRef i)
| TFloat f ->
let f = float_of_string f in
write ctx (HFloat f);
| TString s ->
write ctx (HString (to_utf8 s));
| TBool b ->
write ctx (if b then HTrue else HFalse);
| TNull ->
write ctx HNull;
coerce ctx (classify ctx t)
| TThis ->
write ctx HThis
| TSuper ->
assert false
let end_fun ctx args dparams tret =
{
hlmt_index = 0;
hlmt_ret = type_void ctx tret;
hlmt_args = List.map (fun (v,_) -> type_opt ctx v.v_type) args;
hlmt_native = false;
hlmt_var_args = false;
hlmt_debug_name = None;
hlmt_dparams = dparams;
hlmt_pnames = if ctx.swc || ctx.debugger then Some (List.map (fun (v,_) -> Some v.v_name) args) else None;
hlmt_new_block = false;
hlmt_unused_flag = false;
hlmt_arguments_defined = false;
hlmt_uses_dxns = false;
hlmt_function = None;
}
let begin_fun ctx args tret el stat p =
let old_locals = ctx.locals in
let old_code = ctx.code in
let old_infos = ctx.infos in
let old_trys = ctx.trys in
let old_bvars = ctx.block_vars in
let old_static = ctx.in_static in
let last_line = ctx.last_line in
let old_treg = ctx.try_scope_reg in
ctx.infos <- default_infos();
ctx.code <- DynArray.create();
ctx.trys <- [];
ctx.block_vars <- [];
ctx.in_static <- stat;
ctx.last_line <- -1;
ctx.last_file <- "";
debug_infos ctx p;
let rec find_this e =
match e.eexpr with
| TFunction _ -> ()
| TConst TThis | TConst TSuper -> raise Exit
| _ -> Type.iter find_this e
in
let this_reg = try List.iter find_this el; false with Exit -> true in
ctx.locals <- PMap.foldi (fun _ (v,l) acc ->
match l with
| LReg _ -> acc
| LScope _ -> PMap.add v.v_id (v,LGlobal (ident v.v_name)) acc
| LGlobal _ -> PMap.add v.v_id (v,l) acc
) ctx.locals PMap.empty;
let dparams = ref None in
let make_constant_value r c t =
let v = (match classify ctx t, c with
| _, None -> HVNone
| (KInt | KFloat | KUInt | KBool) as kind, Some c ->
(match c with
| TInt i -> if kind = KUInt then HVUInt i else HVInt i
| TFloat s -> HVFloat (float_of_string s)
| TBool b -> HVBool b
| TNull -> error ("In Flash9, null can't be used as basic type " ^ s_type (print_context()) t) p
| _ -> assert false)
| _, Some TNull -> HVNone
| k, Some c ->
write ctx (HReg r.rid);
write ctx HNull;
let j = jump ctx J3Neq in
gen_constant ctx c t p;
coerce ctx k;
write ctx (HSetReg r.rid);
j();
HVNone
) in
match !dparams with
| None -> if c <> None then dparams := Some [v]
| Some l -> dparams := Some (v :: l)
in
let args, varargs = (match List.rev args with
| (({ v_name = "__arguments__"; v_type = t } as v),_) :: l ->
(match follow t with
| TInst ({ cl_path = ([],"Array") },_) -> List.rev l, Some (v,true)
| _ -> List.rev l, Some(v,false))
| _ ->
args, None
) in
List.iter (fun (v,c) ->
let t = v.v_type in
define_local ctx v ~init:true p;
match gen_local_access ctx v null_pos Write with
| VReg r ->
make_constant_value r c t
| acc ->
let r = alloc_reg ctx (classify ctx t) in
make_constant_value r c t;
write ctx (HReg r.rid);
setvar ctx acc None
) args;
(match varargs with
| None -> ()
| Some (v,_) ->
define_local ctx v ~init:true p;
ignore(alloc_reg ctx (classify ctx v.v_type)));
let dparams = (match !dparams with None -> None | Some l -> Some (List.rev l)) in
let is_not_rethrow (_,e) =
match e.eexpr with
| TBlock [{ eexpr = TThrow { eexpr = TNew (_,_,[]) } }] -> false
| _ -> true
in
let rec loop_try e =
match e.eexpr with
| TFunction _ -> ()
| TTry (_,catches) when List.exists is_not_rethrow catches -> raise Exit
| _ -> Type.iter loop_try e
in
ctx.try_scope_reg <- (try List.iter loop_try el; None with Exit -> Some (alloc_reg ctx KDynamic));
(fun () ->
let hasblock = ctx.block_vars <> [] || ctx.try_scope_reg <> None in
let code = DynArray.to_list ctx.code in
let extra = (
if hasblock then begin
let scope = (match ctx.try_scope_reg with
| None -> [HScope]
| Some r -> [HDup; HSetReg r.rid; HScope]
) in
HThis :: HScope :: HNewBlock :: scope
end else if this_reg then
[HThis; HScope]
else
[]
) in
(* add dummy registers initialization *)
let extra = extra @ List.concat (List.map (fun r ->
if not r.rcond then
[]
else
let s = [HSetReg r.rid] in
match r.rtype with
| KInt -> HSmallInt 0 :: s
| KUInt -> HSmallInt 0 :: HToUInt :: s
| KFloat -> HNaN :: s
| KBool -> HFalse :: s
| KType t -> HNull :: HAsType t :: s
| KDynamic -> HNull :: HAsAny :: s
| KNone -> HNull :: HAsType (HMPath ([],"Class")) :: s
) (DynArray.to_list ctx.infos.iregs)) in
let delta = List.length extra in
let f = {
hlf_stack_size = (if ctx.infos.imax = 0 && (hasblock || this_reg) then 1 else ctx.infos.imax);
hlf_nregs = DynArray.length ctx.infos.iregs + 1;
hlf_init_scope = 1;
hlf_max_scope = ctx.infos.imaxscopes + 1 + (if hasblock then 2 else if this_reg then 1 else 0);
hlf_code = MultiArray.of_array (Array.of_list (extra @ code));
hlf_trys = Array.of_list (List.map (fun t ->
{
hltc_start = t.tr_pos + delta;
hltc_end = t.tr_end + delta;
hltc_handle = t.tr_catch_pos + delta;
hltc_type = type_opt ctx t.tr_type;
hltc_name = None;
}
) (List.rev ctx.trys));
hlf_locals = Array.of_list (List.map (fun (id,name,t) -> ident name, t, id, false) ctx.block_vars);
} in
let mt = { (end_fun ctx args dparams tret) with
hlmt_var_args = (match varargs with Some (_,true) -> true | _ -> false);
hlmt_arguments_defined = (match varargs with Some (_,false) -> true | _ -> false);
hlmt_new_block = hasblock;
hlmt_function = Some f;
} in
ctx.locals <- old_locals;
ctx.code <- old_code;
ctx.infos <- old_infos;
ctx.trys <- old_trys;
ctx.block_vars <- old_bvars;
ctx.in_static <- old_static;
ctx.last_line <- last_line;
ctx.try_scope_reg <- old_treg;
mt
)
let empty_method ctx p =
let f = begin_fun ctx [] ctx.com.basic.tvoid [] true p in
write ctx HRetVoid;
f()
let begin_loop ctx =
let old_loop = ctx.infos.iloop in
let old_breaks = ctx.breaks in
let old_conts = ctx.continues in
ctx.infos.iloop <- ctx.infos.istack;
ctx.breaks <- [];
ctx.continues <- [];
(fun cont_pos ->
if ctx.infos.istack <> ctx.infos.iloop then assert false;
List.iter (fun j -> j()) ctx.breaks;
List.iter (fun j -> j cont_pos) ctx.continues;
ctx.infos.iloop <- old_loop;
ctx.breaks <- old_breaks;
ctx.continues <- old_conts;
)
let no_value ctx retval =
(* does not push a null but still increment the stack like if
a real value was pushed *)
if retval then ctx.infos.istack <- ctx.infos.istack + 1
let pop_value ctx retval =
(* if we have multiple branches, make sure to forget about previous
branch value *)
if retval then ctx.infos.istack <- ctx.infos.istack - 1
let gen_expr_ref = ref (fun _ _ _ -> assert false)
let gen_expr ctx e retval = (!gen_expr_ref) ctx e retval
let rec gen_access ctx e (forset : 'a) : 'a access =
match e.eexpr with
| TLocal v ->
gen_local_access ctx v e.epos forset
| TField ({ eexpr = TConst TSuper } as e1,f) ->
let f = field_name f in
let id, _, _ = property ctx f e1.etype in
write ctx HThis;
VSuper id
| TEnumParameter (e1,_,i) ->
gen_expr ctx true e1;
write ctx (HGetProp (ident "params"));
write ctx (HSmallInt i);
VArray
| TField (e1,fa) ->
let f = field_name fa in
let id, k, closure = property ctx f e1.etype in
if closure && not ctx.for_call then error "In Flash9, this method cannot be accessed this way : please define a local function" e1.epos;
(match e1.eexpr with
| TConst (TThis|TSuper) when not ctx.in_static ->
write ctx (HFindProp id)
| _ -> gen_expr ctx true e1);
(match k with
| Some t -> VCast (id,t)
| None ->
match follow e1.etype, follow e.etype with
| _ , TFun _ when not ctx.for_call -> VCast(id,classify ctx e.etype)
| TEnum _, _ -> VId id
| TInst (_,tl), et ->
let is_type_parameter_field = match fa with
| FInstance(_,_,cf) ->
(match follow cf.cf_type with TInst({cl_kind = KTypeParameter _},_) -> true | _ -> false)
| _ ->
List.exists (fun t -> follow t == et) tl
in
(* if the return type is one of the type-parameters, then we need to cast it *)
if is_type_parameter_field then
VCast (id, classify ctx e.etype)
else if Codegen.is_volatile e.etype then
VVolatile (id,None)
else
VId id
| TAnon a, _ when (match !(a.a_status) with Statics _ | EnumStatics _ -> true | _ -> false) ->
if Codegen.is_volatile e.etype then
VVolatile (id,None)
else
VId id
| _ ->
if Codegen.is_volatile e.etype then
VVolatile (id,Some (classify ctx e.etype))
else
VCast (id,classify ctx e.etype)
)
| TArray ({ eexpr = TLocal { v_name = "__global__" } },{ eexpr = TConst (TString s) }) ->
let path = parse_path s in
let id = type_path ctx path in
if is_set forset then write ctx HGetGlobalScope;
VGlobal id
| TArray (e,eindex) ->
gen_expr ctx true e;
gen_expr ctx true eindex;
VArray
| TTypeExpr t ->
let id = type_path ctx (t_path t) in
if is_set forset then write ctx HGetGlobalScope;
VGlobal id
| _ ->
invalid_expr e.epos
let gen_expr_twice ctx e =
match e.eexpr with
| TLocal v ->
(match get_local_register ctx v with
| Some r ->
write ctx (HReg r.rid);
write ctx (HReg r.rid);
| None ->
gen_expr ctx true e;
write ctx HDup)
| TConst _ ->
gen_expr ctx true e;
gen_expr ctx true e;
| _ ->
gen_expr ctx true e;
write ctx HDup
let gen_access_rw ctx e : (read access * write access) =
match e.eexpr with
| TArray ({ eexpr = TLocal _ }, { eexpr = TConst _ })
| TArray ({ eexpr = TLocal _ }, { eexpr = TLocal _ })
| TField ({ eexpr = TLocal _ },_)
| TField ({ eexpr = TConst _ },_)
->
let w = gen_access ctx e Write in
let r = gen_access ctx e Read in
r, w
| TArray (e,eindex) ->
let r = (match e.eexpr with TLocal v -> get_local_register ctx v | _ -> None) in
(match r with
| None ->
let r = alloc_reg ctx (classify ctx e.etype) in
gen_expr ctx true e;
set_reg ctx r;
write ctx (HReg r.rid);
gen_expr_twice ctx eindex;
write ctx (HReg r.rid);
write ctx HSwap;
free_reg ctx r;
| Some r ->
write ctx (HReg r.rid);
gen_expr_twice ctx eindex;
write ctx (HReg r.rid);
write ctx HSwap;
);
VArray, VArray
| TField _ ->
let w = gen_access ctx e Write in
write ctx HDup;
Obj.magic w, w
| _ ->
let w = gen_access ctx e Write in
let r = gen_access ctx e Read in
r, w
let rec gen_type ctx t =