string-concat

Author: hhugo

compiler/lib/generate.ml

@@ -1234,6 +1234,11 @@ let rec translate_expr ctx queue loc _x e level : _ * J.statement_list =
             in
             e, const_p, queue
         | Extern "caml_alloc_dummy_function", _ -> assert false
+        | Extern "%string_concat", [ a; b ] when Config.Flag.use_js_string () ->
+            let (_pa, ca), queue = access_queue' ~ctx queue a in
+            let (_pb, cb), queue = access_queue' ~ctx queue b in
+            let e = J.EBin (J.Plus, ca, cb) in
+            e, const_p, queue
         | Extern name, l -> (
             let name = Primitive.resolve name in
             match internal_prim name with
@@ -1989,6 +1994,7 @@ let init () =
     [ "%int_mul", "caml_mul"
     ; "%int_div", "caml_div"
     ; "%int_mod", "caml_mod"
+    ; "%string_concat", "caml_string_concat"
     ; "caml_int32_neg", "%int_neg"
     ; "caml_int32_add", "%int_add"
     ; "caml_int32_sub", "%int_sub"

compiler/lib/specialize_js.ml

@@ -136,10 +136,38 @@ let specialize_instr info i =
       | _ -> i)
   | _ -> i
 
+let all_equal = function
+  | [] -> true
+  | x :: xs -> List.for_all xs ~f:(fun y -> Var.equal x y)
+
 let specialize_instrs info l =
   let rec aux info checks l acc =
     match l with
     | [] -> List.rev acc
+    | Let (alen, Prim (Extern "caml_ml_string_length", [ Pv a ]))
+      :: Let (blen, Prim (Extern "caml_ml_string_length", [ Pv b ]))
+      :: Let (len, Prim (Extern "%int_add", [ Pv alen'; Pv blen' ]))
+      :: Let (bytes, Prim (Extern "caml_create_bytes", [ Pv len' ]))
+      :: Let
+           ( _
+           , Prim
+               ( Extern "caml_blit_string"
+               , [ Pv a'; Pc (Int 0l); Pv bytes'; Pc (Int 0l); Pv alen'' ] ) )
+      :: Let
+           ( _
+           , Prim
+               ( Extern "caml_blit_string"
+               , [ Pv b'; Pc (Int 0l); Pv bytes''; Pv alen'''; Pv blen'' ] ) )
+      :: Let (res, Prim (Extern "caml_string_of_bytes", [ Pv bytes''' ]))
+      :: rest
+      when all_equal [ a; a' ]
+           && all_equal [ b; b' ]
+           && all_equal [ len; len' ]
+           && all_equal [ alen; alen'; alen''; alen''' ]
+           && all_equal [ blen; blen'; blen'' ]
+           && all_equal [ bytes; bytes'; bytes''; bytes''' ] ->
+        Let (res, Prim (Extern "%string_concat", [ Pv a; Pv b ]))
+        :: aux info checks rest acc
     | i :: r -> (
         (* We make bound checking explicit. Then, we can remove duplicated
            bound checks. Also, it appears to be more efficient to inline

compiler/lib/var_printer.ml

@@ -99,6 +99,7 @@ let name t v nm_orig =
       match str, nm_orig with
       | "", ">>=" -> "symbol_bind"
       | "", ">>|" -> "symbol_map"
+      | "", "^" -> "symbol_concat"
       | "", _ -> "symbol"
       | str, _ -> str
     in

compiler/tests-check-prim/main.output

@@ -164,8 +164,10 @@ caml_marshal_constants
 From +mlBytes.js:
 caml_array_of_bytes
 caml_array_of_string
+caml_bytes_concat
 caml_bytes_of_utf16_jsstring
 caml_new_string
+caml_string_concat
 caml_string_set16
 caml_string_set32
 caml_string_set64

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

@@ -273,8 +273,10 @@ caml_marshal_constants
 From +mlBytes.js:
 caml_array_of_bytes
 caml_array_of_string
+caml_bytes_concat
 caml_bytes_of_utf16_jsstring
 caml_new_string
+caml_string_concat
 caml_string_set16
 caml_string_set32
 caml_string_set64

compiler/tests-compiler/dune.inc

@@ -402,6 +402,19 @@
  (preprocess
   (pps ppx_expect)))
 
+(library
+ (name jsooexp_test_string)
+ (modules test_string)
+ (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper)
+ (inline_tests
+  (flags -allow-output-patterns)
+  (deps
+   (file ../../compiler/bin-js_of_ocaml/js_of_ocaml.exe)
+   (file ../../compiler/bin-jsoo_minify/jsoo_minify.exe)))
+ (flags (:standard -open Jsoo_compiler_expect_tests_helper))
+ (preprocess
+  (pps ppx_expect)))
+
 (library
  (name jsooexp_unix_fs)
  (modules unix_fs)

compiler/tests-compiler/test_string.ml

@@ -0,0 +1,87 @@
+(* Js_of_ocaml tests
+ * http://www.ocsigen.org/js_of_ocaml/
+ * Copyright (C) 2019 Ty Overby
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *)
+
+open Util
+
+let%expect_test _ =
+  let program =
+    compile_and_parse
+      ~debug:false
+      ~flags:[ "--enable"; "use-js-string" ]
+      {|
+external string_length : string -> int = "%string_length"
+external bytes_create : int -> bytes = "caml_create_bytes"
+external string_blit : string -> int -> bytes -> int -> int -> unit
+                     = "caml_blit_string" [@@noalloc]
+external bytes_unsafe_to_string : bytes -> string = "%bytes_to_string"
+
+let ( ^ ) s1 s2 =
+  let l1 = string_length s1 and l2 = string_length s2 in
+  let s = bytes_create (l1 + l2) in
+  string_blit s1 0 s 0 l1;
+  string_blit s2 0 s l1 l2;
+  bytes_unsafe_to_string s
+
+let here () =
+  let a = "a" in
+  let b = "b" in
+  a ^ a ^ b ^ b
+
+let (_ : string) = here ()
+    |}
+  in
+  print_fun_decl program None;
+  [%expect
+    {|
+    function _b_(_c_){return cst_a + (cst_a + (cst_b + cst_b))} |}]
+
+let%expect_test _ =
+  let program =
+    compile_and_parse
+      ~debug:false
+      ~flags:[ "--disable"; "use-js-string" ]
+      {|
+external string_length : string -> int = "%string_length"
+external bytes_create : int -> bytes = "caml_create_bytes"
+external string_blit : string -> int -> bytes -> int -> int -> unit
+                     = "caml_blit_string" [@@noalloc]
+
+external bytes_unsafe_to_string : bytes -> string = "%bytes_to_string"
+
+let ( ^ ) s1 s2 =
+  let l1 = string_length s1 and l2 = string_length s2 in
+  let s = bytes_create (l1 + l2) in
+  string_blit s1 0 s 0 l1;
+  string_blit s2 0 s l1 l2;
+  bytes_unsafe_to_string s
+
+let here () =
+  let a = "a" in
+  let b = "b" in
+  a ^ a ^ b ^ b
+
+let (_ : string) = here ()
+    |}
+  in
+  print_fun_decl program None;
+  [%expect
+    {|
+    function _b_(_c_)
+     {return caml_string_concat
+              (cst_a,caml_string_concat(cst_a,caml_string_concat(cst_b,cst_b)))} |}]

runtime/mlBytes.js

@@ -438,6 +438,14 @@ MlBytes.prototype.slice = function (){
   return new MlBytes(this.t,content,this.l);
 }
 
+//Provides: caml_bytes_concat
+//Requires: caml_convert_string_to_bytes, MlBytes
+function caml_bytes_concat(s1,s2){
+  (s1.t & 6) && caml_convert_string_to_bytes(s1);
+  (s2.t & 6) && caml_convert_string_to_bytes(s2);
+  return new MlBytes(s1.t,s1.c+s2.c,s1.l+s2.l)
+}
+
 //Provides: caml_convert_string_to_bytes
 //Requires: caml_str_repeat, caml_subarray_to_jsbytes
 function caml_convert_string_to_bytes (s) {
@@ -645,6 +653,15 @@ function caml_blit_string(a,b,c,d,e) {
 //Provides: caml_ml_bytes_length const
 function caml_ml_bytes_length(s) { return s.l }
 
+//Provides: caml_string_concat
+//If: js-string
+function caml_string_concat(a,b) { return a + b }
+
+//Provides: caml_string_concat
+//Requires: caml_bytes_concat
+//If: !js-string
+function caml_string_concat(a,b) { return caml_bytes_concat(a,b) }
+
 //Provides: caml_string_unsafe_get const
 //If: js-string
 function caml_string_unsafe_get (s, i) {