Compiler: recognize and optimize String.concat

Author: hhugo

compiler/lib/generate.ml

@@ -1278,6 +1278,16 @@ let rec translate_expr ctx queue loc x e level : _ * J.statement_list =
             let (py, cy), queue = access_queue' ~ctx queue b in
             let prop = or_p px py in
             bool (J.EBin (J.EqEq, cx, cy)), prop, queue
+        | Extern "caml_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 prop = or_p pa pb in
+            let rec add ca cb =
+              match cb with
+              | J.EBin (J.Plus, cb1, cb2) -> J.EBin (J.Plus, add ca cb1, cb2)
+              | _ -> J.EBin (J.Plus, ca, cb)
+            in
+            add ca cb, prop, queue
         | Extern name, l -> (
             let name = Primitive.resolve name in
             match internal_prim name with

compiler/lib/specialize_js.ml

@@ -147,10 +147,48 @@ let specialize_instr info i =
       | _ -> i)
   | _ -> i
 
+let equal2 a b = Code.Var.equal a b
+
+let equal3 a b c = Code.Var.equal a b && Code.Var.equal b c
+
+let equal4 a b c d = Code.Var.equal a b && Code.Var.equal b c && Code.Var.equal c d
+
 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 ])), _) as len1)
+      ; ((Let (blen, Prim (Extern "caml_ml_string_length", [ Pv b ])), _) as len2)
+      ; ((Let (len, Prim (Extern "%int_add", [ Pv alen'; Pv blen' ])), _) as len3)
+      ; (Let (bytes, Prim (Extern "caml_create_bytes", [ Pv len' ])), _)
+      ; ( Let
+            ( u1
+            , Prim
+                ( Extern "caml_blit_string"
+                , [ Pv a'; Pc (Int 0l); Pv bytes'; Pc (Int 0l); Pv alen'' ] ) )
+        , _ )
+      ; ( Let
+            ( u2
+            , 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''' ])), _)
+      ]
+      when equal2 a a'
+           && equal2 b b'
+           && equal2 len len'
+           && equal4 alen alen' alen'' alen'''
+           && equal3 blen blen' blen''
+           && equal4 bytes bytes' bytes'' bytes''' ->
+        [ len1
+        ; len2
+        ; len3
+        ; Let (u1, Constant (Int 0l)), No
+        ; Let (u2, Constant (Int 0l)), No
+        ; Let (res, Prim (Extern "caml_string_concat", [ Pv a; Pv b ])), No
+        ; Let (bytes, Prim (Extern "caml_bytes_of_string", [ Pv res ])), No
+        ]
     | (i, loc) :: 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

@@ -114,6 +114,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

@@ -157,6 +157,7 @@ caml_array_of_bytes
 caml_array_of_string
 caml_bytes_of_utf16_jsstring
 caml_new_string
+caml_string_concat
 caml_string_set16
 caml_string_set32
 caml_string_set64

compiler/tests-check-prim/main.output5

@@ -138,6 +138,7 @@ From +mlBytes.js:
 caml_array_of_bytes
 caml_array_of_string
 caml_bytes_of_utf16_jsstring
+caml_string_concat
 caml_string_set16
 caml_string_set32
 caml_string_set64

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

@@ -266,6 +266,7 @@ caml_array_of_bytes
 caml_array_of_string
 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.output5

@@ -247,6 +247,7 @@ From +mlBytes.js:
 caml_array_of_bytes
 caml_array_of_string
 caml_bytes_of_utf16_jsstring
+caml_string_concat
 caml_string_set16
 caml_string_set32
 caml_string_set64

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

@@ -230,6 +230,7 @@ From +mlBytes.js:
 caml_array_of_bytes
 caml_array_of_string
 caml_bytes_of_utf16_jsstring
+caml_string_concat
 caml_new_string
 caml_string_set16
 caml_string_set32

compiler/tests-check-prim/unix-win32.output5

@@ -213,6 +213,7 @@ From +mlBytes.js:
 caml_array_of_bytes
 caml_array_of_string
 caml_bytes_of_utf16_jsstring
+caml_string_concat
 caml_string_set16
 caml_string_set32
 caml_string_set64

compiler/tests-compiler/dune.inc

@@ -749,6 +749,21 @@
  (preprocess
   (pps ppx_expect)))
 
+(library
+ ;; compiler/tests-compiler/test_string.ml
+ (name test_string_15)
+ (enabled_if true)
+ (modules test_string)
+ (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper)
+ (inline_tests
+  (enabled_if true)
+  (deps
+   (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe)
+   (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe)))
+ (flags (:standard -open Jsoo_compiler_expect_tests_helper))
+ (preprocess
+  (pps ppx_expect)))
+
 (library
  ;; compiler/tests-compiler/unix_fs.ml
  (name unix_fs_15)

compiler/tests-compiler/test_string.ml

@@ -0,0 +1,118 @@
+(* 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
+      ~use_js_string:true
+      {|
+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_program program;
+  [%expect
+    {|
+    (function(globalThis){
+       "use strict";
+       var
+        runtime = globalThis.jsoo_runtime,
+        cst_a = "a",
+        cst_b = "b",
+        caml_string_concat = runtime.caml_string_concat;
+       function _a_(_b_){return cst_a + cst_a + cst_b + cst_b;}
+       _a_(0);
+       var Test = [0, caml_string_concat, _a_];
+       runtime.caml_register_global(2, Test, "Test");
+       return;
+      }
+      (globalThis));
+    //end |}]
+
+let%expect_test _ =
+  let program =
+    compile_and_parse
+      ~debug:false
+      ~use_js_string:false
+      {|
+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_program program;
+  [%expect
+    {|
+    (function(globalThis){
+       "use strict";
+       var
+        runtime = globalThis.jsoo_runtime,
+        caml_string_concat = runtime.caml_string_concat,
+        caml_string_of_jsbytes = runtime.caml_string_of_jsbytes,
+        cst_a = caml_string_of_jsbytes("a"),
+        cst_b = caml_string_of_jsbytes("b");
+       function _a_(_b_){
+        return caml_string_concat
+                (cst_a,
+                 caml_string_concat(cst_a, caml_string_concat(cst_b, cst_b)));
+       }
+       _a_(0);
+       var Test = [0, caml_string_concat, _a_];
+       runtime.caml_register_global(2, Test, "Test");
+       return;
+      }
+      (globalThis));
+    //end |}]