Skip to content

Commit ab6a5ae

Browse files
vouillonvouillon
committed
Wat file preprocessor: support use-js-string
1 parent 3669b48 commit ab6a5ae

File tree

3 files changed

+218
-18
lines changed

3 files changed

+218
-18
lines changed

‎compiler/lib-wasm/wat_preprocess.ml

Lines changed: 123 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -282,6 +282,9 @@ type st =
282282
; mutable pos : pos
283283
; variables : value StringMap.t
284284
; buf : Buffer.t
285+
; mutable head : int
286+
; head_buf : Buffer.t
287+
; mutable id : int (* to generate distinct string id names *)
285288
}
286289

287290
let value_type v : typ =
@@ -406,6 +409,11 @@ let insert st s =
406409
let pred_position { loc; byte_loc } =
407410
{ loc = { loc with pos_cnum = loc.pos_cnum - 1 }; byte_loc = byte_loc - 1 }
408411

412+
let generate_id st _ =
413+
let id = Printf.sprintf "$js$string$%d$" st.id in
414+
st.id <- st.id + 1;
415+
id
416+
409417
let rec rewrite_list st l = List.iter ~f:(rewrite st) l
410418

411419
and rewrite st elt =
@@ -502,35 +510,116 @@ and rewrite st elt =
502510
then raise (Error (position_of_loc loc_value, "Expecting a string"));
503511
let s = parse_string loc_value value in
504512
write st pos;
513+
if variable_is_set st "use-js-string"
514+
then (
515+
Printf.bprintf
516+
st.head_buf
517+
"(import \"\" %s (global %s$string externref)) "
518+
value
519+
name;
520+
insert
521+
st
522+
(Printf.sprintf
523+
"(global %s (ref eq) (struct.new $string (any.convert_extern (global.get \
524+
%s$string))))"
525+
name
526+
name))
527+
else
528+
insert
529+
st
530+
(Format.asprintf
531+
"(global %s (ref eq) (array.new_fixed $bytes %d%a))"
532+
name
533+
(String.length s)
534+
(fun f s ->
535+
String.iter
536+
~f:(fun c -> Format.fprintf f " (i32.const %d)" (Char.code c))
537+
s)
538+
s);
539+
skip st pos'
540+
| { desc = List [ { desc = Atom "@string"; _ }; { desc = Atom value; loc = loc_value } ]
541+
; loc = pos, pos'
542+
} ->
543+
if not (is_string value)
544+
then raise (Error (position_of_loc loc_value, "Expecting a string"));
545+
let s = parse_string loc_value value in
546+
let name = generate_id st s in
547+
write st pos;
548+
if variable_is_set st "use-js-string"
549+
then (
550+
Printf.bprintf
551+
st.head_buf
552+
"(import \"\" %s (global %s$string externref)) "
553+
value
554+
name;
555+
insert
556+
st
557+
(Printf.sprintf
558+
"(struct.new $string (any.convert_extern (global.get %s$string)))"
559+
name))
560+
else
561+
insert
562+
st
563+
(Format.asprintf
564+
"(array.new_fixed $bytes %d%a)"
565+
(String.length s)
566+
(fun f s ->
567+
String.iter
568+
~f:(fun c -> Format.fprintf f " (i32.const %d)" (Char.code c))
569+
s)
570+
s);
571+
skip st pos'
572+
| { desc =
573+
List
574+
[ { desc = Atom "@jsstring"; _ }
575+
; { desc = Atom name; _ }
576+
; { desc = Atom value; _ }
577+
]
578+
; loc = pos, pos'
579+
} ->
580+
write st pos;
581+
Printf.bprintf
582+
st.head_buf
583+
"(import \"\" %s (global %s$string externref)) "
584+
value
585+
name;
505586
insert
506587
st
507-
(Format.asprintf
508-
"(global %s (ref eq) (array.new_fixed $bytes %d%a))"
588+
(Printf.sprintf
589+
"(global %s (ref eq) (struct.new $js (any.convert_extern (global.get \
590+
%s$string))))"
509591
name
510-
(String.length s)
511-
(fun f s ->
512-
String.iter ~f:(fun c -> Format.fprintf f " (i32.const %d)" (Char.code c)) s)
513-
s);
592+
name);
514593
skip st pos'
515-
| { desc = List [ { desc = Atom "@string"; _ }; { desc = Atom value; loc = loc_value } ]
594+
| { desc =
595+
List [ { desc = Atom "@jsstring"; _ }; { desc = Atom value; loc = loc_value } ]
516596
; loc = pos, pos'
517597
} ->
518598
if not (is_string value)
519599
then raise (Error (position_of_loc loc_value, "Expecting a string"));
520600
let s = parse_string loc_value value in
601+
let name = generate_id st s in
521602
write st pos;
603+
Printf.bprintf
604+
st.head_buf
605+
"(import \"\" %s (global %s$string externref)) "
606+
value
607+
name;
522608
insert
523609
st
524-
(Format.asprintf
525-
"(array.new_fixed $bytes %d%a)"
526-
(String.length s)
527-
(fun f s ->
528-
String.iter ~f:(fun c -> Format.fprintf f " (i32.const %d)" (Char.code c)) s)
529-
s);
610+
(Printf.sprintf
611+
"(struct.new $%s (any.convert_extern (global.get %s$string))))"
612+
(if variable_is_set st "use-js-string" then "string" else "js")
613+
name);
530614
skip st pos'
531-
| { desc = List [ { desc = Atom "@string"; loc = _, pos } ]; loc = _, pos' } ->
615+
| { desc = List [ { desc = Atom ("@string" | "@jsstring"); loc = _, pos } ]
616+
; loc = _, pos'
617+
} ->
532618
raise (Error ((pos.loc, pos'.loc), Printf.sprintf "Expecting an id or a string.\n"))
533-
| { desc = List ({ desc = Atom "@string"; _ } :: _ :: _ :: { loc; _ } :: _); _ } ->
619+
| { desc =
620+
List ({ desc = Atom ("@string" | "@jsstring"); _ } :: _ :: _ :: { loc; _ } :: _)
621+
; _
622+
} ->
534623
raise
535624
(Error (position_of_loc loc, Printf.sprintf "Expecting a closing parenthesis.\n"))
536625
| { desc = List [ { desc = Atom "@char"; _ }; { desc = Atom value; loc = loc_value } ]
@@ -570,6 +659,9 @@ and rewrite st elt =
570659
insert st (Printf.sprintf " $%s " (parse_string export_loc export_name));
571660
skip st pos';
572661
rewrite_list st l
662+
| { desc = List ({ desc = Atom "module"; loc = _, pos } :: _ as l); _ } ->
663+
st.head <- pos.byte_loc;
664+
rewrite_list st l
573665
| { desc = List l; _ } -> rewrite_list st l
574666
| _ -> ()
575667

@@ -579,7 +671,7 @@ let ocaml_version =
579671
Scanf.sscanf Sys.ocaml_version "%d.%d.%d" (fun major minor patchlevel ->
580672
Version (major, minor, patchlevel))
581673

582-
let default_settings = [ "name-wasm-functions", Bool true ]
674+
let default_settings = [ "name-wasm-functions", Bool true; "use-js-string", Bool false ]
583675

584676
let f ~variables ~filename ~contents:text =
585677
let variables =
@@ -593,10 +685,23 @@ let f ~variables ~filename ~contents:text =
593685
Sedlexing.set_filename lexbuf filename;
594686
try
595687
let t, (pos, end_pos) = parse lexbuf in
596-
let st = { text; pos; variables; buf = Buffer.create (String.length text) } in
688+
let st =
689+
{ text
690+
; pos
691+
; variables
692+
; buf = Buffer.create (String.length text)
693+
; head_buf = Buffer.create 128
694+
; head = 0
695+
; id = 0
696+
}
697+
in
597698
rewrite_list st t;
598699
write st end_pos;
599-
Buffer.contents st.buf
700+
let head = Buffer.contents st.head_buf in
701+
let contents = Buffer.contents st.buf in
702+
String.sub contents ~pos:0 ~len:st.head
703+
^ head
704+
^ String.sub contents ~pos:st.head ~len:(String.length contents - st.head)
600705
with Error (loc, msg) -> report_error loc msg
601706

602707
type source =

‎compiler/tests-wasm_of_ocaml/preprocess/dune

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -17,5 +17,26 @@
1717
(action
1818
(diff tests.expected tests.output)))
1919

20+
(rule
21+
(with-stdout-to
22+
tests-js-string.output
23+
(run
24+
%{bin:wasm_of_ocaml}
25+
pp
26+
--enable
27+
use-js-string
28+
--enable
29+
a
30+
--disable
31+
b
32+
--set
33+
c=1
34+
%{dep:tests.txt})))
35+
36+
(rule
37+
(alias runtest)
38+
(action
39+
(diff tests-js-string.expected tests-js-string.output)))
40+
2041
(cram
2142
(deps %{bin:wasm_of_ocaml}))

‎compiler/tests-wasm_of_ocaml/preprocess/tests-js-string.expected

Lines changed: 74 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,74 @@
1+
(import "" "abcd" (global $s$string externref)) (import "" "abcd" (global $js$string$0$$string externref)) (import "" "\\\'\28\n" (global $js$string$1$$string externref)) (import "" "abcd" (global $js$string$2$$string externref)) (import "" "abcd" (global $js$string$3$$string externref)) ;; conditional
2+
a is true
3+
b is false
4+
a is true
5+
6+
7+
;; nested conditionals
8+
a is true and b is false
9+
10+
11+
;; not
12+
13+
b is false
14+
15+
;; and
16+
true
17+
a is true
18+
19+
20+
a is true and b is false
21+
22+
23+
24+
;; or
25+
26+
a is true
27+
28+
a or b is true
29+
a is true or b is false
30+
31+
a or b is false
32+
33+
;; strings
34+
newline
35+
quote
36+
37+
;; string comparisons
38+
c is 1
39+
40+
41+
c is not 2
42+
43+
;; version comparisons
44+
45+
(4 1 1) = (4 1 1)
46+
47+
(4 1 1) <> (4 1 0)
48+
49+
(4 1 1) <> (4 1 2)
50+
51+
(4 1 1) <= (4 1 1)
52+
(4 1 1) <= (4 1 2)
53+
(4 1 1) >= (4 1 0)
54+
(4 1 1) >= (4 1 1)
55+
56+
(4 1 1) > (4 1 0)
57+
58+
59+
60+
;; version comparisons: lexicographic order
61+
62+
63+
(4 1 1) < (4 1 2)
64+
65+
(4 1 1) < (4 2 0)
66+
(4 1 1) < (5 0 1)
67+
68+
69+
;; strings
70+
(global $s (ref eq) (struct.new $string (any.convert_extern (global.get $s$string))))
71+
(struct.new $string (any.convert_extern (global.get $js$string$0$$string)))
72+
(struct.new $string (any.convert_extern (global.get $js$string$1$$string)))
73+
(struct.new $string (any.convert_extern (global.get $js$string$2$$string)))
74+
(struct.new $string (any.convert_extern (global.get $js$string$3$$string)))

0 commit comments

Comments
 (0)