Skip to content

Commit a160212

Browse files
hhugohhugo
committed
WIP
1 parent 2c53333 commit a160212

File tree

13 files changed

+81
-79
lines changed

13 files changed

+81
-79
lines changed

‎compiler/bin-js_of_ocaml/cmd_arg.ml‎

Lines changed: 8 additions & 8 deletions
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‎

Lines changed: 1 addition & 1 deletion
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‎

Lines changed: 9 additions & 9 deletions
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‎

Lines changed: 24 additions & 0 deletions
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‎

Lines changed: 2 additions & 0 deletions
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‎

Lines changed: 0 additions & 2 deletions
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‎

Lines changed: 0 additions & 2 deletions
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‎

Lines changed: 6 additions & 2 deletions
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‎

Lines changed: 21 additions & 25 deletions
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‎

Lines changed: 6 additions & 1 deletion
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

0 commit comments

Comments
 (0)