Skip to content

Commit 8efa8d2

Browse files
vouillonvouillon
committed
Wat file preprocessor: support use-js-string
1 parent f86c643 commit 8efa8d2

File tree

4 files changed

+223
-23
lines changed

4 files changed

+223
-23
lines changed

‎compiler/bin-wasmoo_util/tests/dune‎

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,5 +8,26 @@
88
(action
99
(diff tests.expected tests.output)))
1010

11+
(rule
12+
(with-stdout-to
13+
tests-js-string.output
14+
(run
15+
wasmoo_util
16+
pp
17+
--enable
18+
use-js-string
19+
--enable
20+
a
21+
--disable
22+
b
23+
--set
24+
c=1
25+
%{dep:tests.txt})))
26+
27+
(rule
28+
(alias runtest)
29+
(action
30+
(diff tests-js-string.expected tests-js-string.output)))
31+
1132
(cram
1233
(deps %{bin:wasmoo_util}))

‎compiler/bin-wasmoo_util/tests/tests-js-string.expected‎

Lines changed: 74 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,74 @@
1+
;; 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) (array.new_fixed $bytes 4 (i32.const 97) (i32.const 98) (i32.const 99) (i32.const 100)))
71+
(array.new_fixed $bytes 4 (i32.const 97) (i32.const 98) (i32.const 99) (i32.const 100))
72+
(array.new_fixed $bytes 4 (i32.const 92) (i32.const 39) (i32.const 40) (i32.const 10))
73+
(array.new_fixed $bytes 4 (i32.const 97) (i32.const 98) (i32.const 99) (i32.const 100))
74+
(array.new_fixed $bytes 4 (i32.const 97) (i32.const 98) (i32.const 99) (i32.const 100))

‎compiler/bin-wasmoo_util/tests/tests.expected‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -67,8 +67,8 @@
6767

6868

6969
;; strings
70-
(global $s (ref eq) (array.new_fixed $string 4 (i32.const 97) (i32.const 98) (i32.const 99) (i32.const 100)))
71-
(array.new_fixed $string 4 (i32.const 97) (i32.const 98) (i32.const 99) (i32.const 100))
72-
(array.new_fixed $string 4 (i32.const 92) (i32.const 39) (i32.const 40) (i32.const 10))
73-
(array.new_fixed $string 4 (i32.const 97) (i32.const 98) (i32.const 99) (i32.const 100))
74-
(array.new_fixed $string 4 (i32.const 97) (i32.const 98) (i32.const 99) (i32.const 100))
70+
(global $s (ref eq) (array.new_fixed $bytes 4 (i32.const 97) (i32.const 98) (i32.const 99) (i32.const 100)))
71+
(array.new_fixed $bytes 4 (i32.const 97) (i32.const 98) (i32.const 99) (i32.const 100))
72+
(array.new_fixed $bytes 4 (i32.const 92) (i32.const 39) (i32.const 40) (i32.const 10))
73+
(array.new_fixed $bytes 4 (i32.const 97) (i32.const 98) (i32.const 99) (i32.const 100))
74+
(array.new_fixed $bytes 4 (i32.const 97) (i32.const 98) (i32.const 99) (i32.const 100))

‎compiler/lib-wasm/wat_preprocess.ml‎

Lines changed: 123 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -271,6 +271,9 @@ type st =
271271
; mutable pos : pos
272272
; variables : value StringMap.t
273273
; buf : Buffer.t
274+
; mutable head : int
275+
; head_buf : Buffer.t
276+
; mutable id : int (* to generate distinct string id names *)
274277
}
275278

276279
let value_type v : typ =
@@ -395,6 +398,11 @@ let insert st s =
395398
let pred_position { loc; byte_loc } =
396399
{ loc = { loc with pos_cnum = loc.pos_cnum - 1 }; byte_loc = byte_loc - 1 }
397400

401+
let generate_id st _ =
402+
let id = Printf.sprintf "$js$string$%d$" st.id in
403+
st.id <- st.id + 1;
404+
id
405+
398406
let rec rewrite_list st l = List.iter ~f:(rewrite st) l
399407

400408
and rewrite st elt =
@@ -491,35 +499,116 @@ and rewrite st elt =
491499
then raise (Error (position_of_loc loc_value, "Expecting a string"));
492500
let s = parse_string loc_value value in
493501
write st pos;
502+
if variable_is_set st "use-js-string"
503+
then (
504+
Printf.bprintf
505+
st.head_buf
506+
"(import \"\" %s (global %s$string externref)) "
507+
value
508+
name;
509+
insert
510+
st
511+
(Printf.sprintf
512+
"(global %s (ref eq) (struct.new $string (any.convert_extern (global.get \
513+
%s$string))))"
514+
name
515+
name))
516+
else
517+
insert
518+
st
519+
(Format.asprintf
520+
"(global %s (ref eq) (array.new_fixed $bytes %d%a))"
521+
name
522+
(String.length s)
523+
(fun f s ->
524+
String.iter
525+
~f:(fun c -> Format.fprintf f " (i32.const %d)" (Char.code c))
526+
s)
527+
s);
528+
skip st pos'
529+
| { desc = List [ { desc = Atom "@string"; _ }; { desc = Atom value; loc = loc_value } ]
530+
; loc = pos, pos'
531+
} ->
532+
if not (is_string value)
533+
then raise (Error (position_of_loc loc_value, "Expecting a string"));
534+
let s = parse_string loc_value value in
535+
let name = generate_id st s in
536+
write st pos;
537+
if variable_is_set st "use-js-string"
538+
then (
539+
Printf.bprintf
540+
st.head_buf
541+
"(import \"\" %s (global %s$string externref)) "
542+
value
543+
name;
544+
insert
545+
st
546+
(Printf.sprintf
547+
"(struct.new $string (any.convert_extern (global.get %s$string)))"
548+
name))
549+
else
550+
insert
551+
st
552+
(Format.asprintf
553+
"(array.new_fixed $bytes %d%a)"
554+
(String.length s)
555+
(fun f s ->
556+
String.iter
557+
~f:(fun c -> Format.fprintf f " (i32.const %d)" (Char.code c))
558+
s)
559+
s);
560+
skip st pos'
561+
| { desc =
562+
List
563+
[ { desc = Atom "@jsstring"; _ }
564+
; { desc = Atom name; _ }
565+
; { desc = Atom value; _ }
566+
]
567+
; loc = pos, pos'
568+
} ->
569+
write st pos;
570+
Printf.bprintf
571+
st.head_buf
572+
"(import \"\" %s (global %s$string externref)) "
573+
value
574+
name;
494575
insert
495576
st
496-
(Format.asprintf
497-
"(global %s (ref eq) (array.new_fixed $bytes %d%a))"
577+
(Printf.sprintf
578+
"(global %s (ref eq) (struct.new $js (any.convert_extern (global.get \
579+
%s$string))))"
498580
name
499-
(String.length s)
500-
(fun f s ->
501-
String.iter ~f:(fun c -> Format.fprintf f " (i32.const %d)" (Char.code c)) s)
502-
s);
581+
name);
503582
skip st pos'
504-
| { desc = List [ { desc = Atom "@string"; _ }; { desc = Atom value; loc = loc_value } ]
583+
| { desc =
584+
List [ { desc = Atom "@jsstring"; _ }; { desc = Atom value; loc = loc_value } ]
505585
; loc = pos, pos'
506586
} ->
507587
if not (is_string value)
508588
then raise (Error (position_of_loc loc_value, "Expecting a string"));
509589
let s = parse_string loc_value value in
590+
let name = generate_id st s in
510591
write st pos;
592+
Printf.bprintf
593+
st.head_buf
594+
"(import \"\" %s (global %s$string externref)) "
595+
value
596+
name;
511597
insert
512598
st
513-
(Format.asprintf
514-
"(array.new_fixed $bytes %d%a)"
515-
(String.length s)
516-
(fun f s ->
517-
String.iter ~f:(fun c -> Format.fprintf f " (i32.const %d)" (Char.code c)) s)
518-
s);
599+
(Printf.sprintf
600+
"(struct.new $%s (any.convert_extern (global.get %s$string))))"
601+
(if variable_is_set st "use-js-string" then "string" else "js")
602+
name);
519603
skip st pos'
520-
| { desc = List [ { desc = Atom "@string"; loc = _, pos } ]; loc = _, pos' } ->
604+
| { desc = List [ { desc = Atom ("@string" | "@jsstring"); loc = _, pos } ]
605+
; loc = _, pos'
606+
} ->
521607
raise (Error ((pos.loc, pos'.loc), Printf.sprintf "Expecting an id or a string.\n"))
522-
| { desc = List ({ desc = Atom "@string"; _ } :: _ :: _ :: { loc; _ } :: _); _ } ->
608+
| { desc =
609+
List ({ desc = Atom ("@string" | "@jsstring"); _ } :: _ :: _ :: { loc; _ } :: _)
610+
; _
611+
} ->
523612
raise
524613
(Error (position_of_loc loc, Printf.sprintf "Expecting a closing parenthesis.\n"))
525614
| { desc =
@@ -544,6 +633,9 @@ and rewrite st elt =
544633
insert st (Printf.sprintf " $%s " (parse_string export_loc export_name));
545634
skip st pos';
546635
rewrite_list st l
636+
| { desc = List ({ desc = Atom "module"; loc = _, pos } :: _ as l); _ } ->
637+
st.head <- pos.byte_loc;
638+
rewrite_list st l
547639
| { desc = List l; _ } -> rewrite_list st l
548640
| _ -> ()
549641

@@ -553,7 +645,7 @@ let ocaml_version =
553645
Scanf.sscanf Sys.ocaml_version "%d.%d.%d" (fun major minor patchlevel ->
554646
Version (major, minor, patchlevel))
555647

556-
let default_settings = [ "name-wasm-functions", Bool true ]
648+
let default_settings = [ "name-wasm-functions", Bool true; "use-js-string", Bool false ]
557649

558650
let f ~variables ~filename ~contents:text =
559651
let variables =
@@ -567,10 +659,23 @@ let f ~variables ~filename ~contents:text =
567659
Sedlexing.set_filename lexbuf filename;
568660
try
569661
let t, (pos, end_pos) = parse lexbuf in
570-
let st = { text; pos; variables; buf = Buffer.create (String.length text) } in
662+
let st =
663+
{ text
664+
; pos
665+
; variables
666+
; buf = Buffer.create (String.length text)
667+
; head_buf = Buffer.create 128
668+
; head = 0
669+
; id = 0
670+
}
671+
in
571672
rewrite_list st t;
572673
write st end_pos;
573-
Buffer.contents st.buf
674+
let head = Buffer.contents st.head_buf in
675+
let contents = Buffer.contents st.buf in
676+
String.sub contents ~pos:0 ~len:st.head
677+
^ head
678+
^ String.sub contents ~pos:st.head ~len:(String.length contents - st.head)
574679
with Error (loc, msg) -> report_error loc msg
575680

576681
type source =

0 commit comments

Comments
 (0)