string-concat

Author: hhugo

compiler/lib/generate.ml

@@ -748,6 +748,7 @@ let _ =
     [ "%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"
@@ -1186,6 +1187,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

compiler/lib/specialize_js.ml

@@ -150,9 +150,37 @@ let specialize_instr info i rem =
       :: rem
   | _ -> i :: rem
 
+let all_equal = function
+  | [] -> true
+  | x :: xs -> List.for_all xs ~f:(fun y -> Var.equal x y)
+
 let rec specialize_instrs info checks l =
   match l with
   | [] -> []
+  | 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 ]))
+      :: specialize_instrs info checks rest
   | 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-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) {
@@ -649,6 +657,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) {