Skip to content

Commit a160212

Browse files
hhugohhugo
committed
WIP
1 parent 2c53333 commit a160212

13 files changed

+81
-79
lines changed

‎compiler/bin-js_of_ocaml/cmd_arg.ml

+8-8
Original file line numberDiff line numberDiff line change
@@ -54,7 +54,7 @@ type t =
5454
; wrap_with_fun : [ `Iife | `Named of string | `Anonymous ]
5555
; target_env : Target_env.t
5656
; shape_files : string list
57-
; shapes : bool
57+
; write_shape : bool
5858
; (* toplevel *)
5959
dynlink : bool
6060
; linkall : bool
@@ -106,11 +106,11 @@ let options =
106106
in
107107
let shape_files =
108108
let doc = "load shape file [$(docv)]." in
109-
Arg.(value & opt_all string [] & info [ "load" ] ~docv:"FILE" ~doc)
109+
Arg.(value & opt_all string [] & info [ "load-shape" ] ~docv:"FILE" ~doc)
110110
in
111-
let shapes =
111+
let write_shape =
112112
let doc = "Emit shape files" in
113-
Arg.(value & flag & info [ "shapes" ] ~doc)
113+
Arg.(value & flag & info [ "write-shape" ] ~doc)
114114
in
115115
let input_file =
116116
let doc =
@@ -290,7 +290,7 @@ let options =
290290
input_file
291291
js_files
292292
shape_files
293-
shapes
293+
write_shape
294294
keep_unit_names =
295295
let inline_source_content = not sourcemap_don't_inline_content in
296296
let chop_extension s = try Filename.chop_extension s with Invalid_argument _ -> s in
@@ -354,7 +354,7 @@ let options =
354354
; source_map
355355
; keep_unit_names
356356
; shape_files
357-
; shapes
357+
; write_shape
358358
}
359359
in
360360
let t =
@@ -386,7 +386,7 @@ let options =
386386
$ input_file
387387
$ js_files
388388
$ shape_files
389-
$ shapes
389+
$ write_shape
390390
$ keep_unit_names)
391391
in
392392
Term.ret t
@@ -584,7 +584,7 @@ let options_runtime_only =
584584
; source_map
585585
; keep_unit_names = false
586586
; shape_files = []
587-
; shapes = false
587+
; write_shape = false
588588
}
589589
in
590590
let t =

‎compiler/bin-js_of_ocaml/cmd_arg.mli

+1-1
Original file line numberDiff line numberDiff line change
@@ -38,7 +38,7 @@ type t =
3838
]
3939
; target_env : Target_env.t
4040
; shape_files : string list
41-
; shapes : bool
41+
; write_shape : bool
4242
; (* toplevel *)
4343
dynlink : bool
4444
; linkall : bool

‎compiler/bin-js_of_ocaml/compile.ml

+9-9
Original file line numberDiff line numberDiff line change
@@ -47,7 +47,7 @@ let source_map_enabled = function
4747
| Inline | File _ -> true
4848

4949
let output_gen
50-
~write_shapes
50+
~write_shape
5151
~standalone
5252
~custom_header
5353
~build_info
@@ -60,7 +60,7 @@ let output_gen
6060
if standalone then header ~custom_header fmt;
6161
if Config.Flag.header () then jsoo_header fmt build_info;
6262
let sm, shapes = f ~standalone ~source_map (k, fmt) in
63-
(if write_shapes
63+
(if write_shape
6464
then
6565
match output_file with
6666
| `Stdout -> ()
@@ -173,7 +173,7 @@ let run
173173
; keep_unit_names
174174
; include_runtime
175175
; shape_files
176-
; shapes = write_shapes
176+
; write_shape
177177
} =
178178
let source_map_base = Option.map ~f:snd source_map in
179179
let source_map =
@@ -388,7 +388,7 @@ let run
388388
}
389389
in
390390
output_gen
391-
~write_shapes
391+
~write_shape
392392
~standalone:true
393393
~custom_header
394394
~build_info:(Build_info.create `Runtime)
@@ -437,7 +437,7 @@ let run
437437
in
438438
if times () then Format.eprintf " parsing: %a@." Timer.print t1;
439439
output_gen
440-
~write_shapes
440+
~write_shape
441441
~standalone:true
442442
~custom_header
443443
~build_info:(Build_info.create `Exe)
@@ -476,7 +476,7 @@ let run
476476
in
477477
if times () then Format.eprintf " parsing: %a@." Timer.print t1;
478478
output_gen
479-
~write_shapes
479+
~write_shape
480480
~standalone:false
481481
~custom_header
482482
~build_info:(Build_info.create `Cmo)
@@ -507,7 +507,7 @@ let run
507507
failwith "use [-o dirname/] or remove [--keep-unit-names]"
508508
in
509509
output_gen
510-
~write_shapes
510+
~write_shape
511511
~standalone:false
512512
~custom_header
513513
~build_info:(Build_info.create `Runtime)
@@ -544,7 +544,7 @@ let run
544544
t1
545545
(Ocaml_compiler.Cmo_format.name cmo);
546546
output_gen
547-
~write_shapes
547+
~write_shape
548548
~standalone:false
549549
~custom_header
550550
~build_info:(Build_info.create `Cma)
@@ -594,7 +594,7 @@ let run
594594
, shapes )
595595
in
596596
output_gen
597-
~write_shapes
597+
~write_shape
598598
~standalone:false
599599
~custom_header
600600
~build_info:(Build_info.create `Cma)

‎compiler/lib/code.ml

+24
Original file line numberDiff line numberDiff line change
@@ -822,6 +822,30 @@ let fold_closures_outermost_first { start; blocks; _ } f accu =
822822
let accu = f None [] (start, []) accu in
823823
visit blocks start f accu
824824

825+
(* Compute the list of variables containing the return values of each
826+
function *)
827+
let return_values p =
828+
fold_closures
829+
p
830+
(fun name_opt _ (pc, _) rets ->
831+
match name_opt with
832+
| None -> rets
833+
| Some name ->
834+
let s =
835+
traverse
836+
{ fold = fold_children }
837+
(fun pc s ->
838+
let block = Addr.Map.find pc p.blocks in
839+
match block.branch with
840+
| Return x -> Var.Set.add x s
841+
| _ -> s)
842+
pc
843+
p.blocks
844+
Var.Set.empty
845+
in
846+
Var.Map.add name s rets)
847+
Var.Map.empty
848+
825849
let eq p1 p2 =
826850
p1.start = p2.start
827851
&& Addr.Map.cardinal p1.blocks = Addr.Map.cardinal p2.blocks

‎compiler/lib/code.mli

+2
Original file line numberDiff line numberDiff line change
@@ -304,6 +304,8 @@ val fold_children_skip_try_body : 'c fold_blocs
304304

305305
val poptraps : block Addr.Map.t -> Addr.t -> Addr.Set.t
306306

307+
val return_values : program -> Var.Set.t Var.Map.t
308+
307309
val traverse :
308310
fold_blocs_poly -> (Addr.t -> 'c -> 'c) -> Addr.t -> block Addr.Map.t -> 'c -> 'c
309311

‎compiler/lib/config.ml

-2
Original file line numberDiff line numberDiff line change
@@ -102,8 +102,6 @@ module Flag = struct
102102

103103
let es6 = o ~name:"es6" ~default:false
104104

105-
let shapes = o ~name:"shapes" ~default:false
106-
107105
let load_shapes_auto = o ~name:"load-shapes-auto" ~default:false
108106
end
109107

‎compiler/lib/config.mli

-2
Original file line numberDiff line numberDiff line change
@@ -75,8 +75,6 @@ module Flag : sig
7575

7676
val es6 : unit -> bool
7777

78-
val shapes : unit -> bool
79-
8078
val load_shapes_auto : unit -> bool
8179

8280
val enable : string -> unit

‎compiler/lib/driver.ml

+6-2
Original file line numberDiff line numberDiff line change
@@ -65,7 +65,10 @@ let inline p =
6565

6666
let specialize_1 (p, info) =
6767
if debug () then Format.eprintf "Specialize...@.";
68-
Specialize.f ~function_arity:(fun f -> Specialize.function_arity info f) p
68+
let return_values = Code.return_values p in
69+
Specialize.f
70+
~function_arity:(fun f -> Specialize.function_arity ~return_values info f)
71+
p
6972

7073
let specialize_js (p, info) =
7174
if debug () then Format.eprintf "Specialize js...@.";
@@ -673,6 +676,7 @@ if (typeof module === 'object' && module.exports) {
673676
let collects_shapes p =
674677
let _, info = Flow.f p in
675678
let pure = Pure_fun.f p in
679+
let return_values = Code.return_values p in
676680
let l = ref StringMap.empty in
677681
Code.Addr.Map.iter
678682
(fun _ block ->
@@ -683,7 +687,7 @@ let collects_shapes p =
683687
, Prim
684688
( Extern "caml_register_global"
685689
, [ _code; Pv block; Pc (NativeString name) ] ) ) ->
686-
let shape = Flow.the_shape_of ~pure info block in
690+
let shape = Flow.the_shape_of ~return_values ~pure info block in
687691
let name =
688692
match name with
689693
| Byte s -> s

‎compiler/lib/flow.ml

+21-25
Original file line numberDiff line numberDiff line change
@@ -40,7 +40,6 @@ module Info = struct
4040
; info_known_origins : Code.Var.Set.t Code.Var.Tbl.t
4141
; info_maybe_unknown : bool Code.Var.Tbl.t
4242
; info_possibly_mutable : Var.ISet.t
43-
; info_blocks : Code.block Addr.Map.t
4443
}
4544

4645
let def t x =
@@ -431,7 +430,7 @@ let direct_approx (info : Info.t) x =
431430
y
432431
| _ -> None
433432

434-
let rec the_shape_of ~pure info x =
433+
let rec the_shape_of ~return_values ~pure info x =
435434
let rec merge (u : Shape.t) (v : Shape.t) =
436435
match u, v with
437436
| ( Function { arity = a1; pure = p1; res = r1 }
@@ -455,30 +454,28 @@ let rec the_shape_of ~pure info x =
455454
| None -> (
456455
match info.info_defs.(Var.idx x) with
457456
| Expr (Block (_, a, _, Immutable)) ->
458-
Shape.Block (List.map ~f:(the_shape_of ~pure info) (Array.to_list a))
459-
| Expr (Closure (l, (pc, _))) ->
457+
Shape.Block
458+
(List.map ~f:(the_shape_of ~return_values ~pure info) (Array.to_list a))
459+
| Expr (Closure (l, _)) ->
460460
let pure = Code.Var.Set.mem x pure in
461-
let blocks = info.info_blocks in
462461
let res =
463-
Code.traverse
464-
{ fold = fold_children }
465-
(fun pc res ->
466-
let block = Addr.Map.find pc blocks in
467-
match block.branch with
468-
| Return x -> (
469-
let s2 = loop info x acc in
470-
match res with
471-
| None -> Some s2
472-
| Some s1 -> Some (merge s1 s2))
473-
| _ -> res)
474-
pc
475-
blocks
476-
None
477-
in
478-
let res : Shape.t =
479-
match res with
480-
| None -> Top "no return"
481-
| Some res -> res
462+
match Var.Map.find x return_values with
463+
| exception Not_found -> Shape.Top "not return_values found"
464+
| set -> (
465+
match
466+
Var.Set.fold
467+
(fun x res ->
468+
let s2 = loop info x acc in
469+
match res with
470+
| None -> Some s2
471+
| Some s1 -> Some (merge s1 s2))
472+
set
473+
None
474+
with
475+
| None ->
476+
assert (Var.Set.is_empty set);
477+
Shape.Top "no return"
478+
| Some res -> res)
482479
in
483480
Shape.Function { arity = List.length l; pure; res }
484481
| Expr (Special (Alias_prim name)) -> (
@@ -565,7 +562,6 @@ let f ?skip_param p =
565562
; info_known_origins = known_origins
566563
; info_maybe_unknown = maybe_unknown
567564
; info_possibly_mutable = possibly_mutable
568-
; info_blocks = p.blocks
569565
}
570566
in
571567
let s = build_subst info vars in

‎compiler/lib/flow.mli

+6-1
Original file line numberDiff line numberDiff line change
@@ -64,6 +64,11 @@ val the_native_string_of :
6464
val the_int :
6565
target:[ `JavaScript | `Wasm ] -> Info.t -> Code.prim_arg -> Targetint.t option
6666

67-
val the_shape_of : pure:Code.Var.Set.t -> Info.t -> Code.Var.t -> Shape.t
67+
val the_shape_of :
68+
return_values:Code.Var.Set.t Code.Var.Map.t
69+
-> pure:Code.Var.Set.t
70+
-> Info.t
71+
-> Code.Var.t
72+
-> Shape.t
6873

6974
val f : ?skip_param:bool -> Code.program -> Code.program * Info.t

‎compiler/lib/global_flow.ml

-26
Original file line numberDiff line numberDiff line change
@@ -33,32 +33,6 @@ open Code
3333

3434
(****)
3535

36-
(* Compute the list of variables containing the return values of each
37-
function *)
38-
let return_values p =
39-
Code.fold_closures
40-
p
41-
(fun name_opt _ (pc, _) rets ->
42-
match name_opt with
43-
| None -> rets
44-
| Some name ->
45-
let s =
46-
Code.traverse
47-
{ fold = fold_children }
48-
(fun pc s ->
49-
let block = Addr.Map.find pc p.blocks in
50-
match block.branch with
51-
| Return x -> Var.Set.add x s
52-
| _ -> s)
53-
pc
54-
p.blocks
55-
Var.Set.empty
56-
in
57-
Var.Map.add name s rets)
58-
Var.Map.empty
59-
60-
(****)
61-
6236
(* A variable is either let-bound, or a parameter, to which we
6337
associate a set of possible arguments.
6438
*)

‎compiler/lib/specialize.ml

+2-2
Original file line numberDiff line numberDiff line change
@@ -20,8 +20,8 @@
2020
open! Stdlib
2121
open Code
2222

23-
let function_arity info x =
24-
match Flow.the_shape_of ~pure:Code.Var.Set.empty info x with
23+
let function_arity ~return_values info x =
24+
match Flow.the_shape_of ~return_values ~pure:Code.Var.Set.empty info x with
2525
| Top _ | Block _ -> None
2626
| Function { arity; _ } -> Some arity
2727

‎compiler/lib/specialize.mli

+2-1
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@
1818
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
1919
*)
2020

21-
val function_arity : Flow.Info.t -> Code.Var.t -> int option
21+
val function_arity :
22+
return_values:Code.Var.Set.t Code.Var.Map.t -> Flow.Info.t -> Code.Var.t -> int option
2223

2324
val f : function_arity:(Code.Var.t -> int option) -> Code.program -> Code.program

0 commit comments

Comments
 (0)