Skip to content

Commit 2b96ea0

Browse files
committed
string-concat
1 parent 30beca9 commit 2b96ea0

File tree

8 files changed

+163
-0
lines changed

8 files changed

+163
-0
lines changed

compiler/lib/generate.ml

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1440,6 +1440,11 @@ let rec translate_expr ctx queue loc in_tail_position e level : _ * J.statement_
14401440
let prim = Share.get_prim (runtime_fun ctx) name ctx.Ctx.share in
14411441
let prim_kind = kind (Primitive.kind name) in
14421442
ecall prim [] loc, prim_kind, queue
1443+
| Extern "%string_concat", [ a; b ] when Config.Flag.use_js_string () ->
1444+
let (_pa, ca), queue = access_queue' ~ctx queue a in
1445+
let (_pb, cb), queue = access_queue' ~ctx queue b in
1446+
let e = J.EBin (J.Plus, ca, cb) in
1447+
e, const_p, queue
14431448
| Extern name, l -> (
14441449
let name = Primitive.resolve name in
14451450
match internal_prim name with
@@ -2129,6 +2134,7 @@ let init () =
21292134
[ "%int_mul", "caml_mul"
21302135
; "%int_div", "caml_div"
21312136
; "%int_mod", "caml_mod"
2137+
; "%string_concat", "caml_string_concat"
21322138
; "caml_int32_neg", "%int_neg"
21332139
; "caml_int32_add", "%int_add"
21342140
; "caml_int32_sub", "%int_sub"

compiler/lib/specialize_js.ml

Lines changed: 28 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -147,10 +147,38 @@ let specialize_instr info i =
147147
| _ -> i)
148148
| _ -> i
149149

150+
let all_equal = function
151+
| [] -> true
152+
| x :: xs -> List.for_all xs ~f:(fun y -> Var.equal x y)
153+
150154
let specialize_instrs info l =
151155
let rec aux info checks l acc =
152156
match l with
153157
| [] -> List.rev acc
158+
| Let (alen, Prim (Extern "caml_ml_string_length", [ Pv a ]))
159+
:: Let (blen, Prim (Extern "caml_ml_string_length", [ Pv b ]))
160+
:: Let (len, Prim (Extern "%int_add", [ Pv alen'; Pv blen' ]))
161+
:: Let (bytes, Prim (Extern "caml_create_bytes", [ Pv len' ]))
162+
:: Let
163+
( _
164+
, Prim
165+
( Extern "caml_blit_string"
166+
, [ Pv a'; Pc (Int 0l); Pv bytes'; Pc (Int 0l); Pv alen'' ] ) )
167+
:: Let
168+
( _
169+
, Prim
170+
( Extern "caml_blit_string"
171+
, [ Pv b'; Pc (Int 0l); Pv bytes''; Pv alen'''; Pv blen'' ] ) )
172+
:: Let (res, Prim (Extern "caml_string_of_bytes", [ Pv bytes''' ]))
173+
:: rest
174+
when all_equal [ a; a' ]
175+
&& all_equal [ b; b' ]
176+
&& all_equal [ len; len' ]
177+
&& all_equal [ alen; alen'; alen''; alen''' ]
178+
&& all_equal [ blen; blen'; blen'' ]
179+
&& all_equal [ bytes; bytes'; bytes''; bytes''' ] ->
180+
Let (res, Prim (Extern "%string_concat", [ Pv a; Pv b ]))
181+
:: aux info checks rest acc
154182
| i :: r -> (
155183
(* We make bound checking explicit. Then, we can remove duplicated
156184
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
@@ -162,8 +162,10 @@ caml_marshal_constants
162162
From +mlBytes.js:
163163
caml_array_of_bytes
164164
caml_array_of_string
165+
caml_bytes_concat
165166
caml_bytes_of_utf16_jsstring
166167
caml_new_string
168+
caml_string_concat
167169
caml_string_set16
168170
caml_string_set32
169171
caml_string_set64

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -271,8 +271,10 @@ caml_marshal_constants
271271
From +mlBytes.js:
272272
caml_array_of_bytes
273273
caml_array_of_string
274+
caml_bytes_concat
274275
caml_bytes_of_utf16_jsstring
275276
caml_new_string
277+
caml_string_concat
276278
caml_string_set16
277279
caml_string_set32
278280
caml_string_set64

compiler/tests-compiler/dune.inc

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -639,6 +639,22 @@
639639
(preprocess
640640
(pps ppx_expect)))
641641

642+
(library
643+
;; compiler/tests-compiler/test_string.ml
644+
(name test_string_15)
645+
(enabled_if true)
646+
(modules test_string)
647+
(libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper)
648+
(inline_tests
649+
(enabled_if true)
650+
(flags -allow-output-patterns)
651+
(deps
652+
(file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe)
653+
(file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe)))
654+
(flags (:standard -open Jsoo_compiler_expect_tests_helper))
655+
(preprocess
656+
(pps ppx_expect)))
657+
642658
(library
643659
;; compiler/tests-compiler/unix_fs.ml
644660
(name unix_fs_15)
Lines changed: 91 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,91 @@
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_)
53+
{return caml_string_concat
54+
(cst_a,caml_string_concat(cst_a,caml_string_concat(cst_b,cst_b)))}
55+
//end |}]
56+
57+
let%expect_test _ =
58+
let program =
59+
compile_and_parse
60+
~debug:false
61+
~flags:[ "--disable"; "use-js-string" ]
62+
{|
63+
external string_length : string -> int = "%string_length"
64+
external bytes_create : int -> bytes = "caml_create_bytes"
65+
external string_blit : string -> int -> bytes -> int -> int -> unit
66+
= "caml_blit_string" [@@noalloc]
67+
68+
external bytes_unsafe_to_string : bytes -> string = "%bytes_to_string"
69+
70+
let ( ^ ) s1 s2 =
71+
let l1 = string_length s1 and l2 = string_length s2 in
72+
let s = bytes_create (l1 + l2) in
73+
string_blit s1 0 s 0 l1;
74+
string_blit s2 0 s l1 l2;
75+
bytes_unsafe_to_string s
76+
77+
let here () =
78+
let a = "a" in
79+
let b = "b" in
80+
a ^ a ^ b ^ b
81+
82+
let (_ : string) = here ()
83+
|}
84+
in
85+
print_fun_decl program None;
86+
[%expect
87+
{|
88+
function _b_(_c_)
89+
{return caml_string_concat
90+
(cst_a,caml_string_concat(cst_a,caml_string_concat(cst_b,cst_b)))}
91+
//end |}]

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)