Skip to content

Commit af8d389

Browse files
committed
loading shapes
1 parent 72f5aaf commit af8d389

File tree

9 files changed

+138
-19
lines changed

9 files changed

+138
-19
lines changed

compiler/bin-js_of_ocaml/build_fs.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -73,7 +73,7 @@ function jsoo_create_file_extern(name,content){
7373
let code = Code.prepend Code.empty instr in
7474
Filename.gen_file output_file (fun chan ->
7575
let pfs_fmt = Pretty_print.to_out_channel chan in
76-
let (_ : Source_map.t option) =
76+
let (_ : Source_map.t option * Shape.t StringMap.t) =
7777
Driver.f
7878
~standalone:true
7979
~wrap_with_fun:`Iife

compiler/bin-js_of_ocaml/cmd_arg.ml

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -53,6 +53,7 @@ type t =
5353
; static_env : (string * string) list
5454
; wrap_with_fun : [ `Iife | `Named of string | `Anonymous ]
5555
; target_env : Target_env.t
56+
; shape_files : string list
5657
; (* toplevel *)
5758
dynlink : bool
5859
; linkall : bool
@@ -102,6 +103,10 @@ let options =
102103
let doc = "Set output file name to [$(docv)]." in
103104
Arg.(value & opt (some string) None & info [ "o" ] ~docv:"FILE" ~doc)
104105
in
106+
let shape_files =
107+
let doc = "load shape file [$(docv)]." in
108+
Arg.(value & opt_all string [] & info [ "load" ] ~docv:"FILE" ~doc)
109+
in
105110
let input_file =
106111
let doc =
107112
"Compile the bytecode program [$(docv)]. "
@@ -280,6 +285,7 @@ let options =
280285
output_file
281286
input_file
282287
js_files
288+
shape_files
283289
keep_unit_names =
284290
let chop_extension s = try Filename.chop_extension s with Invalid_argument _ -> s in
285291
let runtime_files = js_files in
@@ -360,6 +366,7 @@ let options =
360366
; input_file
361367
; source_map
362368
; keep_unit_names
369+
; shape_files
363370
}
364371
in
365372
let t =
@@ -390,6 +397,7 @@ let options =
390397
$ output_file
391398
$ input_file
392399
$ js_files
400+
$ shape_files
393401
$ keep_unit_names)
394402
in
395403
Term.ret t
@@ -599,6 +607,7 @@ let options_runtime_only =
599607
; input_file = None
600608
; source_map
601609
; keep_unit_names = false
610+
; shape_files = []
602611
}
603612
in
604613
let t =

compiler/bin-js_of_ocaml/cmd_arg.mli

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,7 @@ type t =
3737
| `Anonymous
3838
]
3939
; target_env : Target_env.t
40+
; shape_files : string list
4041
; (* toplevel *)
4142
dynlink : bool
4243
; linkall : bool

compiler/bin-js_of_ocaml/compile.ml

Lines changed: 23 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -43,7 +43,13 @@ let output_gen ~standalone ~custom_header ~build_info ~source_map output_file f
4343
Driver.configure fmt;
4444
if standalone then header ~custom_header fmt;
4545
if Config.Flag.header () then jsoo_header fmt build_info;
46-
let sm = f ~standalone ~source_map:(Option.map ~f:snd source_map) (k, fmt) in
46+
let sm, shapes = f ~standalone ~source_map:(Option.map ~f:snd source_map) (k, fmt) in
47+
(match output_file with
48+
| `Stdout -> ()
49+
| `Name name ->
50+
Shape.Store.save'
51+
(Filename.remove_extension name ^ Shape.Store.ext)
52+
(StringMap.bindings shapes));
4753
match source_map, sm with
4854
| None, _ | _, None -> ()
4955
| Some (output_file, _), Some sm ->
@@ -59,7 +65,6 @@ let output_gen ~standalone ~custom_header ~build_info ~source_map output_file f
5965
Pretty_print.newline fmt;
6066
Pretty_print.string fmt (Printf.sprintf "//# sourceMappingURL=%s\n" urlData)
6167
in
62-
6368
match output_file with
6469
| `Stdout -> f stdout `Stdout
6570
| `Name name -> Filename.gen_file name (fun chan -> f chan `File)
@@ -87,6 +92,7 @@ let run
8792
; fs_external
8893
; export_file
8994
; keep_unit_names
95+
; shape_files
9096
} =
9197
let include_cmis = toplevel && not no_cmis in
9298
let custom_header = common.Jsoo_cmdline.Arg.custom_header in
@@ -97,6 +103,7 @@ let run
97103
| `Name _, _ -> ());
98104
List.iter params ~f:(fun (s, v) -> Config.Param.set s v);
99105
List.iter static_env ~f:(fun (s, v) -> Eval.set_static_env s v);
106+
List.iter shape_files ~f:(fun fn -> Shape.Store.load' fn);
100107
let t = Timer.make () in
101108
let include_dirs =
102109
List.filter_map (include_dirs @ [ "+stdlib/" ]) ~f:(fun d -> Findlib.find [] d)
@@ -352,7 +359,7 @@ let run
352359
(fun ~standalone ~source_map output ->
353360
let source_map =
354361
if linkall
355-
then output_runtime ~standalone ~source_map output
362+
then fst (output_runtime ~standalone ~source_map output)
356363
else source_map
357364
in
358365
output_partial cmo code ~standalone ~source_map output)
@@ -395,9 +402,14 @@ let run
395402
let linkall = linkall || toplevel || dynlink in
396403
let f ~standalone ~source_map output =
397404
let source_map =
398-
if linkall then output_runtime ~standalone ~source_map output else source_map
405+
if linkall
406+
then fst (output_runtime ~standalone ~source_map output)
407+
else source_map
399408
in
400-
List.fold_left cma.lib_units ~init:source_map ~f:(fun source_map cmo ->
409+
List.fold_left
410+
cma.lib_units
411+
~init:(source_map, StringMap.empty)
412+
~f:(fun (source_map, shapes) cmo ->
401413
let t1 = Timer.make () in
402414
let code =
403415
Parse_bytecode.from_cmo
@@ -414,7 +426,12 @@ let run
414426
Timer.print
415427
t1
416428
(Ocaml_compiler.Cmo_format.name cmo);
417-
output_partial cmo ~standalone ~source_map code output)
429+
let sm, shapes' = output_partial cmo ~standalone ~source_map code output in
430+
( sm
431+
, StringMap.union
432+
(fun _name s1 s2 -> if Shape.equal s1 s2 then Some s1 else None)
433+
shapes
434+
shapes' ))
418435
in
419436
output_gen
420437
~standalone:false

compiler/lib/driver.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -702,10 +702,10 @@ let full ~standalone ~wrap_with_fun ~profile ~linkall ~source_map formatter d p
702702
(Printf.sprintf "//# shape: %s:%s\n" name (Shape.to_string shape)))
703703
shapes;
704704
let () = if times () then Format.eprintf " optimizations : %a@." Timer.print t in
705-
emit ~live_vars ~cps_calls prog
705+
emit ~live_vars ~cps_calls prog, shapes
706706

707707
let full_no_source_map ~standalone ~wrap_with_fun ~profile ~linkall formatter d p =
708-
let (_ : Source_map.t option) =
708+
let (_ : Source_map.t option * Shape.t StringMap.t) =
709709
full ~standalone ~wrap_with_fun ~profile ~linkall ~source_map:None formatter d p
710710
in
711711
()

compiler/lib/driver.mli

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,8 @@
1818
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
1919
*)
2020

21+
open Stdlib
22+
2123
type profile
2224

2325
val f :
@@ -29,7 +31,7 @@ val f :
2931
-> Pretty_print.t
3032
-> Parse_bytecode.Debug.t
3133
-> Code.program
32-
-> Source_map.t option
34+
-> Source_map.t option * Shape.t StringMap.t
3335

3436
val f' :
3537
?standalone:bool

compiler/lib/parse_bytecode.ml

Lines changed: 10 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -590,6 +590,7 @@ module State = struct
590590
; handlers : handler list
591591
; globals : globals
592592
; immutable : Code.Var.Set.t ref
593+
; includes : string list
593594
}
594595

595596
let fresh_var state loc =
@@ -695,14 +696,15 @@ module State = struct
695696

696697
let pop_handler state = { state with handlers = List.tl state.handlers }
697698

698-
let initial g immutable =
699+
let initial includes g immutable =
699700
{ accu = Unset
700701
; stack = []
701702
; env = [||]
702703
; env_offset = 0
703704
; handlers = []
704705
; globals = g
705706
; immutable
707+
; includes
706708
}
707709

708710
let rec print_stack f l =
@@ -818,7 +820,7 @@ let get_global state instrs i loc =
818820
(match g.named_value.(i) with
819821
| None -> ()
820822
| Some name -> (
821-
match Shape.Store.get ~name with
823+
match Shape.Store.load ~name state.includes with
822824
| None -> ()
823825
| Some shape -> Shape.State.assign x shape));
824826

@@ -2534,9 +2536,9 @@ type one =
25342536
; debug : Debug.t
25352537
}
25362538

2537-
let parse_bytecode code globals debug_data =
2539+
let parse_bytecode ~includes code globals debug_data =
25382540
let immutable = ref Code.Var.Set.empty in
2539-
let state = State.initial globals immutable in
2541+
let state = State.initial includes globals immutable in
25402542
Code.Var.reset ();
25412543
Shape.State.reset ();
25422544
let blocks = Blocks.analyse debug_data code in
@@ -2748,7 +2750,7 @@ let from_exe
27482750
Ocaml_compiler.Symtable.GlobalMap.iter symbols ~f:(fun id n ->
27492751
globals.named_value.(n) <- Some (Ocaml_compiler.Symtable.Global.name id);
27502752
globals.is_exported.(n) <- true);
2751-
let p = parse_bytecode code globals debug_data in
2753+
let p = parse_bytecode ~includes code globals debug_data in
27522754
(* register predefined exception *)
27532755
let body =
27542756
List.fold_left predefined_exceptions ~init:[] ~f:(fun body (i, name) ->
@@ -2872,7 +2874,7 @@ let from_bytes ~prims ~debug (code : bytecode) =
28722874
t
28732875
in
28742876
let globals = make_globals 0 [||] prims in
2875-
let p = parse_bytecode code globals debug_data in
2877+
let p = parse_bytecode ~includes:[] code globals debug_data in
28762878
let gdata = Var.fresh_n "global_data" in
28772879
let need_gdata = ref false in
28782880
let find_name i =
@@ -3011,7 +3013,7 @@ module Reloc = struct
30113013
globals
30123014
end
30133015

3014-
let from_compilation_units ~includes:_ ~include_cmis ~debug_data l =
3016+
let from_compilation_units ~includes ~include_cmis ~debug_data l =
30153017
let reloc = Reloc.create () in
30163018
List.iter l ~f:(fun (compunit, code) -> Reloc.step1 reloc compunit code);
30173019
List.iter l ~f:(fun (compunit, code) -> Reloc.step2 reloc compunit code);
@@ -3020,7 +3022,7 @@ let from_compilation_units ~includes:_ ~include_cmis ~debug_data l =
30203022
let l = List.map l ~f:(fun (_, c) -> Bytes.to_string c) in
30213023
String.concat ~sep:"" l
30223024
in
3023-
let prog = parse_bytecode code globals debug_data in
3025+
let prog = parse_bytecode ~includes code globals debug_data in
30243026
let gdata = Var.fresh_n "global_data" in
30253027
let need_gdata = ref false in
30263028
let body =

compiler/lib/shape.ml

Lines changed: 79 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,20 @@ type t =
2828
; res : t
2929
}
3030

31+
type shape = t
32+
33+
let rec equal a b =
34+
match a, b with
35+
| Top _, Top _ -> true
36+
| ( Function { arity = a1; pure = p1; res = r1 }
37+
, Function { arity = a2; pure = p2; res = r2 } ) ->
38+
a1 = a2 && Bool.(p1 = p2) && equal r1 r2
39+
| Block b1, Block b2 -> (
40+
try List.for_all2 ~f:equal b1 b2 with Invalid_argument _ -> false)
41+
| Top _, (Function _ | Block _)
42+
| Function _, (Top _ | Block _)
43+
| Block _, (Top _ | Function _) -> false
44+
3145
let rec to_string (shape : t) =
3246
match shape with
3347
| Top s -> if true then "N" else Printf.sprintf "N(%s)" s
@@ -43,13 +57,77 @@ module Store = struct
4357
let hash = Hashtbl.hash
4458
end)
4559

60+
let ext = ".jsoo-shape"
61+
62+
let filename ~dir ~name = Filename.concat dir (name ^ ext)
63+
4664
let t = T.create 17
4765

66+
let loaded = Hashtbl.create 17
67+
4868
let set ~name shape = T.replace t name shape
4969

5070
let get ~name = T.find_opt t name
5171

52-
let load ~name:_ _dirs = None
72+
let magic = "JsooShape000"
73+
74+
let load' fn =
75+
let ic = open_in_bin fn in
76+
let m = really_input_string ic (String.length magic) in
77+
if not (String.equal m magic)
78+
then failwith (Printf.sprintf "Invalid magic number for shape file %s" fn);
79+
let shapes : (string * shape) list = Marshal.from_channel ic in
80+
close_in ic;
81+
List.iter shapes ~f:(fun (name, shape) -> set ~name shape)
82+
83+
let load ~name dirs =
84+
if T.mem t name
85+
then get ~name
86+
else
87+
match Fs.find_in_path dirs (filename ~dir:"." ~name) with
88+
| Some f ->
89+
load' f;
90+
get ~name
91+
| None ->
92+
let rec scan : _ -> shape option = function
93+
| [] -> None
94+
| dir :: xs -> (
95+
let l =
96+
Sys.readdir dir
97+
|> Array.to_list
98+
|> List.sort ~cmp:String.compare
99+
|> List.map ~f:(fun n -> Filename.concat dir n)
100+
in
101+
match
102+
List.find_map l ~f:(fun s ->
103+
if Filename.check_suffix s ext && not (Hashtbl.mem loaded s)
104+
then (
105+
load' s;
106+
Hashtbl.add loaded s ();
107+
match get ~name with
108+
| None -> None
109+
| Some shape -> Some (s, shape))
110+
else None)
111+
with
112+
| None -> scan xs
113+
| Some (fn, shape) ->
114+
Format.eprintf "Shape: %s loaded from %s\n" name fn;
115+
Some shape)
116+
in
117+
scan dirs
118+
119+
let save' fn (l : (string * shape) list) =
120+
let oc = open_out_bin fn in
121+
output_string oc magic;
122+
Marshal.to_channel oc l [];
123+
close_out oc
124+
125+
let save ~name ~dir =
126+
match get ~name with
127+
| None -> failwith (Printf.sprintf "Don't know any shape for %s" name)
128+
| Some shape ->
129+
let fn = filename ~dir ~name in
130+
save' fn [ name, shape ]
53131
end
54132

55133
module State = struct

compiler/lib/shape.mli

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,12 +28,22 @@ type t =
2828

2929
val to_string : t -> string
3030

31+
val equal : t -> t -> bool
32+
3133
module Store : sig
34+
val ext : string
35+
3236
val set : name:string -> t -> unit
3337

3438
val get : name:string -> t option
3539

40+
val load' : string -> unit
41+
3642
val load : name:string -> string list -> t option
43+
44+
val save : name:string -> dir:string -> unit
45+
46+
val save' : string -> (string * t) list -> unit
3747
end
3848

3949
module State : sig

0 commit comments

Comments
 (0)