Skip to content

Commit 4aeee5e

Browse files
committed
string-concat
1 parent 8ff28ab commit 4aeee5e

File tree

8 files changed

+156
-0
lines changed

8 files changed

+156
-0
lines changed

compiler/lib/generate.ml

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1234,6 +1234,11 @@ let rec translate_expr ctx queue loc _x e level : _ * J.statement_list =
12341234
in
12351235
e, const_p, queue
12361236
| Extern "caml_alloc_dummy_function", _ -> assert false
1237+
| Extern "%string_concat", [ a; b ] when Config.Flag.use_js_string () ->
1238+
let (_pa, ca), queue = access_queue' ~ctx queue a in
1239+
let (_pb, cb), queue = access_queue' ~ctx queue b in
1240+
let e = J.EBin (J.Plus, ca, cb) in
1241+
e, const_p, queue
12371242
| Extern name, l -> (
12381243
let name = Primitive.resolve name in
12391244
match internal_prim name with
@@ -1989,6 +1994,7 @@ let init () =
19891994
[ "%int_mul", "caml_mul"
19901995
; "%int_div", "caml_div"
19911996
; "%int_mod", "caml_mod"
1997+
; "%string_concat", "caml_string_concat"
19921998
; "caml_int32_neg", "%int_neg"
19931999
; "caml_int32_add", "%int_add"
19942000
; "caml_int32_sub", "%int_sub"

compiler/lib/specialize_js.ml

Lines changed: 28 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -136,10 +136,38 @@ let specialize_instr info i =
136136
| _ -> i)
137137
| _ -> i
138138

139+
let all_equal = function
140+
| [] -> true
141+
| x :: xs -> List.for_all xs ~f:(fun y -> Var.equal x y)
142+
139143
let specialize_instrs info l =
140144
let rec aux info checks l acc =
141145
match l with
142146
| [] -> List.rev acc
147+
| Let (alen, Prim (Extern "caml_ml_string_length", [ Pv a ]))
148+
:: Let (blen, Prim (Extern "caml_ml_string_length", [ Pv b ]))
149+
:: Let (len, Prim (Extern "%int_add", [ Pv alen'; Pv blen' ]))
150+
:: Let (bytes, Prim (Extern "caml_create_bytes", [ Pv len' ]))
151+
:: Let
152+
( _
153+
, Prim
154+
( Extern "caml_blit_string"
155+
, [ Pv a'; Pc (Int 0l); Pv bytes'; Pc (Int 0l); Pv alen'' ] ) )
156+
:: Let
157+
( _
158+
, Prim
159+
( Extern "caml_blit_string"
160+
, [ Pv b'; Pc (Int 0l); Pv bytes''; Pv alen'''; Pv blen'' ] ) )
161+
:: Let (res, Prim (Extern "caml_string_of_bytes", [ Pv bytes''' ]))
162+
:: rest
163+
when all_equal [ a; a' ]
164+
&& all_equal [ b; b' ]
165+
&& all_equal [ len; len' ]
166+
&& all_equal [ alen; alen'; alen''; alen''' ]
167+
&& all_equal [ blen; blen'; blen'' ]
168+
&& all_equal [ bytes; bytes'; bytes''; bytes''' ] ->
169+
Let (res, Prim (Extern "%string_concat", [ Pv a; Pv b ]))
170+
:: aux info checks rest acc
143171
| i :: r -> (
144172
(* We make bound checking explicit. Then, we can remove duplicated
145173
bound checks. Also, it appears to be more efficient to inline

compiler/lib/var_printer.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -99,6 +99,7 @@ let name t v nm_orig =
9999
match str, nm_orig with
100100
| "", ">>=" -> "symbol_bind"
101101
| "", ">>|" -> "symbol_map"
102+
| "", "^" -> "symbol_concat"
102103
| "", _ -> "symbol"
103104
| str, _ -> str
104105
in

compiler/tests-check-prim/main.output

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -164,8 +164,10 @@ caml_marshal_constants
164164
From +mlBytes.js:
165165
caml_array_of_bytes
166166
caml_array_of_string
167+
caml_bytes_concat
167168
caml_bytes_of_utf16_jsstring
168169
caml_new_string
170+
caml_string_concat
169171
caml_string_set16
170172
caml_string_set32
171173
caml_string_set64

compiler/tests-check-prim/unix-unix.output

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -273,8 +273,10 @@ caml_marshal_constants
273273
From +mlBytes.js:
274274
caml_array_of_bytes
275275
caml_array_of_string
276+
caml_bytes_concat
276277
caml_bytes_of_utf16_jsstring
277278
caml_new_string
279+
caml_string_concat
278280
caml_string_set16
279281
caml_string_set32
280282
caml_string_set64

compiler/tests-compiler/dune.inc

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -402,6 +402,19 @@
402402
(preprocess
403403
(pps ppx_expect)))
404404

405+
(library
406+
(name jsooexp_test_string)
407+
(modules test_string)
408+
(libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper)
409+
(inline_tests
410+
(flags -allow-output-patterns)
411+
(deps
412+
(file ../../compiler/bin-js_of_ocaml/js_of_ocaml.exe)
413+
(file ../../compiler/bin-jsoo_minify/jsoo_minify.exe)))
414+
(flags (:standard -open Jsoo_compiler_expect_tests_helper))
415+
(preprocess
416+
(pps ppx_expect)))
417+
405418
(library
406419
(name jsooexp_unix_fs)
407420
(modules unix_fs)
Lines changed: 87 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,87 @@
1+
(* Js_of_ocaml tests
2+
* http://www.ocsigen.org/js_of_ocaml/
3+
* Copyright (C) 2019 Ty Overby
4+
*
5+
* This program is free software; you can redistribute it and/or modify
6+
* it under the terms of the GNU General Public License as published by
7+
* the Free Software Foundation; either version 2 of the License, or
8+
* (at your option) any later version.
9+
*
10+
* This program is distributed in the hope that it will be useful,
11+
* but WITHOUT ANY WARRANTY; without even the implied warranty of
12+
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13+
* GNU Lesser General Public License for more details.
14+
*
15+
* You should have received a copy of the GNU Lesser General Public License
16+
* along with this program; if not, write to the Free Software
17+
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
18+
*)
19+
20+
open Util
21+
22+
let%expect_test _ =
23+
let program =
24+
compile_and_parse
25+
~debug:false
26+
~flags:[ "--enable"; "use-js-string" ]
27+
{|
28+
external string_length : string -> int = "%string_length"
29+
external bytes_create : int -> bytes = "caml_create_bytes"
30+
external string_blit : string -> int -> bytes -> int -> int -> unit
31+
= "caml_blit_string" [@@noalloc]
32+
external bytes_unsafe_to_string : bytes -> string = "%bytes_to_string"
33+
34+
let ( ^ ) s1 s2 =
35+
let l1 = string_length s1 and l2 = string_length s2 in
36+
let s = bytes_create (l1 + l2) in
37+
string_blit s1 0 s 0 l1;
38+
string_blit s2 0 s l1 l2;
39+
bytes_unsafe_to_string s
40+
41+
let here () =
42+
let a = "a" in
43+
let b = "b" in
44+
a ^ a ^ b ^ b
45+
46+
let (_ : string) = here ()
47+
|}
48+
in
49+
print_fun_decl program None;
50+
[%expect
51+
{|
52+
function _b_(_c_){return cst_a + (cst_a + (cst_b + cst_b))} |}]
53+
54+
let%expect_test _ =
55+
let program =
56+
compile_and_parse
57+
~debug:false
58+
~flags:[ "--disable"; "use-js-string" ]
59+
{|
60+
external string_length : string -> int = "%string_length"
61+
external bytes_create : int -> bytes = "caml_create_bytes"
62+
external string_blit : string -> int -> bytes -> int -> int -> unit
63+
= "caml_blit_string" [@@noalloc]
64+
65+
external bytes_unsafe_to_string : bytes -> string = "%bytes_to_string"
66+
67+
let ( ^ ) s1 s2 =
68+
let l1 = string_length s1 and l2 = string_length s2 in
69+
let s = bytes_create (l1 + l2) in
70+
string_blit s1 0 s 0 l1;
71+
string_blit s2 0 s l1 l2;
72+
bytes_unsafe_to_string s
73+
74+
let here () =
75+
let a = "a" in
76+
let b = "b" in
77+
a ^ a ^ b ^ b
78+
79+
let (_ : string) = here ()
80+
|}
81+
in
82+
print_fun_decl program None;
83+
[%expect
84+
{|
85+
function _b_(_c_)
86+
{return caml_string_concat
87+
(cst_a,caml_string_concat(cst_a,caml_string_concat(cst_b,cst_b)))} |}]

runtime/mlBytes.js

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -438,6 +438,14 @@ MlBytes.prototype.slice = function (){
438438
return new MlBytes(this.t,content,this.l);
439439
}
440440

441+
//Provides: caml_bytes_concat
442+
//Requires: caml_convert_string_to_bytes, MlBytes
443+
function caml_bytes_concat(s1,s2){
444+
(s1.t & 6) && caml_convert_string_to_bytes(s1);
445+
(s2.t & 6) && caml_convert_string_to_bytes(s2);
446+
return new MlBytes(s1.t,s1.c+s2.c,s1.l+s2.l)
447+
}
448+
441449
//Provides: caml_convert_string_to_bytes
442450
//Requires: caml_str_repeat, caml_subarray_to_jsbytes
443451
function caml_convert_string_to_bytes (s) {
@@ -645,6 +653,15 @@ function caml_blit_string(a,b,c,d,e) {
645653
//Provides: caml_ml_bytes_length const
646654
function caml_ml_bytes_length(s) { return s.l }
647655

656+
//Provides: caml_string_concat
657+
//If: js-string
658+
function caml_string_concat(a,b) { return a + b }
659+
660+
//Provides: caml_string_concat
661+
//Requires: caml_bytes_concat
662+
//If: !js-string
663+
function caml_string_concat(a,b) { return caml_bytes_concat(a,b) }
664+
648665
//Provides: caml_string_unsafe_get const
649666
//If: js-string
650667
function caml_string_unsafe_get (s, i) {

0 commit comments

Comments
 (0)