Compiler: compile ocaml string as javascript ones

compiler/lib/annot_lexer.mll

@@ -33,7 +33,9 @@ rule initial = parse
   | "object_literal" {TA_Object_literal}
   | "Version" {TVersion}
   | "Weakdef" {TWeakdef}
-  | ['a'-'z''A'-'Z''$''_']['a'-'z''A'-'Z''$''_''0'-'9']* {
+  | "If" {TIf}
+  | "!" {TBang}
+  | ['a'-'z''A'-'Z''$''_']['a'-'z''A'-'Z''$''_''-''0'-'9']* {
       let x = Lexing.lexeme lexbuf in
       TIdent x}
   | ['0'-'9']+ ('.' (['0'-'9']+)) * {

compiler/lib/annot_parser.mli

@@ -9,8 +9,10 @@ type token =
   | TRequires
   | TProvides
   | TOTHER of (string)
+  | TIf
   | TIdent of (string)
   | TComma
+  | TBang
   | TA_Shallow
   | TA_Pure
   | TA_Object_literal

compiler/lib/annot_parser.mly

@@ -17,11 +17,12 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
-%token TProvides TRequires TVersion TWeakdef
+%token TProvides TRequires TVersion TWeakdef TIf
 %token TA_Pure TA_Const TA_Mutable TA_Mutator TA_Shallow TA_Object_literal
 %token<string> TIdent TVNum
 %token TComma TSemi EOF EOL LE LT GE GT EQ LPARENT RPARENT
 %token<string> TOTHER
+%token TBang
 
 %start annot
 %type <Primitive.t> annot
@@ -38,7 +39,10 @@ annot:
   | TVersion TSemi l=separated_nonempty_list(TComma,version) endline
     { `Version (None,l) }
   | TWeakdef { `Weakdef None }
-
+  | TIf TSemi name=TIdent endline
+    { `If (None,name) }
+  | TIf TSemi TBang name=TIdent endline
+                           { `Ifnot (None,name) }
 prim_annot:
   | TA_Pure {`Pure}
   | TA_Const {`Pure}

compiler/lib/config.ml

@@ -80,6 +80,8 @@ module Flag = struct
 
   let safe_string = o ~name:"safestring" ~default:true
 
+  let use_js_string = o ~name:"use-js-string" ~default:false
+
   let check_magic = o ~name:"check-magic-number" ~default:true
 
   let compact_vardecl = o ~name:"vardecl" ~default:false

compiler/lib/config.mli

@@ -59,6 +59,8 @@ module Flag : sig
 
   val safe_string : unit -> bool
 
+  val use_js_string : unit -> bool
+
   val check_magic : unit -> bool
 
   val enable : string -> unit

compiler/lib/eval.ml

@@ -293,7 +293,8 @@ let eval_instr info i =
                 ( prim
                 , List.map2 prim_args prim_args' ~f:(fun arg c ->
                       match c with
-                      | Some ((Int _ | Float _) as c) -> Pc c
+                      | Some ((Int _ | Float _ | IString _) as c) -> Pc c
+                      | Some (String _ as c) when Config.Flag.use_js_string () -> Pc c
                       | Some _
                       (* do not be duplicated other constant as
                           they're not represented with constant in javascript. *)

compiler/lib/generate.ml

@@ -107,7 +107,9 @@ module Share = struct
 
   let add_code_string s share =
     let share = add_string s share in
-    add_prim "caml_new_string" share
+    if Config.Flag.use_js_string ()
+    then share
+    else add_prim "caml_string_of_jsbytes" share
 
   let add_code_istring s share = add_string s share
 
@@ -124,11 +126,12 @@ module Share = struct
         | Pc c -> get_constant c t
         | _ -> t)
 
-  let get
-      ?(alias_strings = false)
-      ?(alias_prims = false)
-      ?(alias_apply = true)
-      { blocks; _ } : t =
+  let get ?alias_strings ?(alias_prims = false) ?(alias_apply = true) { blocks; _ } : t =
+    let alias_strings =
+      match alias_strings with
+      | None -> Config.Flag.use_js_string ()
+      | Some x -> x
+    in
     let count =
       Addr.Map.fold
         (fun _ block share ->
@@ -176,7 +179,7 @@ module Share = struct
         then (
           try J.EVar (StringMap.find s t.vars.strings)
           with Not_found ->
-            let x = Var.fresh_n "str" in
+            let x = Var.fresh_n (Printf.sprintf "cst_%s" s) in
             let v = J.V x in
             t.vars <- { t.vars with strings = StringMap.add s v t.vars.strings };
             J.EVar v)
@@ -309,12 +312,19 @@ let kind k =
   | `Mutable -> mutable_p
   | `Mutator -> mutator_p
 
+let ocaml_string ~ctx ~loc s =
+  if Config.Flag.use_js_string ()
+  then s
+  else
+    let p = Share.get_prim (runtime_fun ctx) "caml_string_of_jsbytes" ctx.Ctx.share in
+    ecall p [ s ] loc
+
 let rec constant_rec ~ctx x level instrs =
   match x with
   | String s ->
       let e = Share.get_string str_js s ctx.Ctx.share in
-      let p = Share.get_prim (runtime_fun ctx) "caml_new_string" ctx.Ctx.share in
-      ecall p [ e ] J.N, instrs
+      let e = ocaml_string ~ctx ~loc:J.N e in
+      e, instrs
   | IString s -> Share.get_string str_js s ctx.Ctx.share, instrs
   | Float f -> float_const f, instrs
   | Float_array a ->
@@ -853,8 +863,8 @@ let register_bin_math_prim name prim =
 
 let _ =
   register_un_prim_ctx "%caml_format_int_special" `Pure (fun ctx cx loc ->
-      let p = Share.get_prim (runtime_fun ctx) "caml_new_string" ctx.Ctx.share in
-      ecall p [ J.EBin (J.Plus, str_js "", cx) ] loc);
+      let s = J.EBin (J.Plus, str_js "", cx) in
+      ocaml_string ~ctx ~loc s);
   register_bin_prim "caml_array_unsafe_get" `Mutable (fun cx cy _ ->
       Mlvalue.Array.field cx cy);
   register_bin_prim "%int_add" `Pure (fun cx cy _ -> to_int (plus_int cx cy));
@@ -908,8 +918,7 @@ let _ =
   register_un_prim "caml_js_from_bool" `Pure (fun cx _ ->
       J.EUn (J.Not, J.EUn (J.Not, cx)));
   register_un_prim "caml_js_to_bool" `Pure (fun cx _ -> to_int cx);
-  register_un_prim "caml_js_from_string" `Mutable (fun cx loc ->
-      J.ECall (J.EDot (cx, "toString"), [], loc));
+
   register_tern_prim "caml_js_set" (fun cx cy cz _ ->
       J.EBin (J.Eq, J.EAccess (cx, cy), cz));
   register_bin_prim "caml_js_get" `Mutable (fun cx cy _ -> J.EAccess (cx, cy));
@@ -921,6 +930,17 @@ let _ =
       bool (J.EBin (J.InstanceOf, cx, cy)));
   register_un_prim "caml_js_typeof" `Pure (fun cx _ -> J.EUn (J.Typeof, cx))
 
+(* This is not correct when switching the js-string flag *)
+(* {[
+    register_un_prim "caml_jsstring_of_string" `Mutable (fun cx loc ->
+      J.ECall (J.EDot (cx, "toString"), [], loc));
+    register_bin_prim "caml_string_notequal" `Pure (fun cx cy _ ->
+      J.EBin (J.NotEqEq, cx, cy));
+    register_bin_prim "caml_string_equal" `Pure (fun cx cy _ ->
+      bool (J.EBin (J.EqEq, cx, cy)))
+     ]}
+   *)
+
 (****)
 (* when raising ocaml exception and [improved_stacktrace] is enabled,
    tag the ocaml exception with a Javascript error (that contain js stacktrace).

compiler/lib/linker.ml

@@ -28,6 +28,7 @@ type fragment =
   ; version_constraint : ((int -> int -> bool) * string) list list
   ; weakdef : bool
   ; code : Javascript.program
+  ; ignore : [ `No | `Because of Primitive.condition ]
   }
 
 let loc pi =
@@ -45,6 +46,8 @@ let parse_annot loc s =
     | `Provides (_, n, k, ka) -> Some (`Provides (Some loc, n, k, ka))
     | `Version (_, l) -> Some (`Version (Some loc, l))
     | `Weakdef _ -> Some (`Weakdef (Some loc))
+    | `If (_, name) -> Some (`If (Some loc, name))
+    | `Ifnot (_, name) -> Some (`Ifnot (Some loc, name))
   with
   | Not_found -> None
   | _ -> None
@@ -105,6 +108,7 @@ let parse_from_lex ~filename lex =
             ; version_constraint = []
             ; weakdef = false
             ; code
+            ; ignore = `No
             }
           in
           List.fold_left annot ~init:fragment ~f:(fun fragment a ->
@@ -114,7 +118,31 @@ let parse_from_lex ~filename lex =
               | `Requires (_, mn) -> { fragment with requires = mn @ fragment.requires }
               | `Version (_, l) ->
                   { fragment with version_constraint = l :: fragment.version_constraint }
-              | `Weakdef _ -> { fragment with weakdef = true })
+              | `Weakdef _ -> { fragment with weakdef = true }
+              | `If (_, "js-string") as reason ->
+                  if not (Config.Flag.use_js_string ())
+                  then { fragment with ignore = `Because reason }
+                  else fragment
+              | `Ifnot (_, "js-string") as reason ->
+                  if Config.Flag.use_js_string ()
+                  then { fragment with ignore = `Because reason }
+                  else fragment
+              | `If (pi, name) | `Ifnot (pi, name) ->
+                  let loc =
+                    match pi with
+                    | None -> ""
+                    | Some loc ->
+                        Format.sprintf "%d:%d" loc.Parse_info.line loc.Parse_info.col
+                  in
+                  let filename =
+                    match pi with
+                    | Some { Parse_info.src = Some x; _ }
+                    | Some { Parse_info.name = Some x; _ } ->
+                        x
+                    | _ -> "??"
+                  in
+                  Format.eprintf "Unkown flag %S in %s %s\n" name filename loc;
+                  fragment)
         with Parse_js.Parsing_error pi ->
           let name =
             match pi with
@@ -288,46 +316,51 @@ let find_named_value code =
   ignore (p#program code);
   !all
 
-let load_fragment ~filename { provides; requires; version_constraint; weakdef; code } =
-  let vmatch =
-    match version_constraint with
-    | [] -> true
-    | l -> List.exists l ~f:version_match
-  in
-  if vmatch
-  then (
-    incr last_code_id;
-    let id = !last_code_id in
-    match provides with
-    | None -> always_included := { filename; program = code } :: !always_included
-    | Some (pi, name, kind, ka) ->
-        let code = Macro.f code in
-        let module J = Javascript in
-        let rec find = function
-          | [] -> None
-          | (J.Function_declaration (J.S { J.name = n; _ }, l, _, _), _) :: _
-            when String.equal name n ->
-              Some (List.length l)
-          | _ :: rem -> find rem
-        in
-        let arity = find code in
-        let named_values = find_named_value code in
-        Primitive.register name kind ka arity;
-        StringSet.iter Primitive.register_named_value named_values;
-        (if Hashtbl.mem provided name
-        then
-          let _, ploc, weakdef = Hashtbl.find provided name in
-          if not weakdef
-          then
-            warn
-              "warning: overriding primitive %S\n  old: %s\n  new: %s@."
-              name
-              (loc ploc)
-              (loc pi));
-        Hashtbl.add provided name (id, pi, weakdef);
-        Hashtbl.add provided_rev id (name, pi);
-        check_primitive ~name pi ~code ~requires;
-        Hashtbl.add code_pieces id (code, requires))
+let load_fragment
+    ~filename
+    { provides; requires; version_constraint; weakdef; code; ignore } =
+  match ignore with
+  | `Because _ -> ()
+  | `No ->
+      let vmatch =
+        match version_constraint with
+        | [] -> true
+        | l -> List.exists l ~f:version_match
+      in
+      if vmatch
+      then (
+        incr last_code_id;
+        let id = !last_code_id in
+        match provides with
+        | None -> always_included := { filename; program = code } :: !always_included
+        | Some (pi, name, kind, ka) ->
+            let code = Macro.f code in
+            let module J = Javascript in
+            let rec find = function
+              | [] -> None
+              | (J.Function_declaration (J.S { J.name = n; _ }, l, _, _), _) :: _
+                when String.equal name n ->
+                  Some (List.length l)
+              | _ :: rem -> find rem
+            in
+            let arity = find code in
+            let named_values = find_named_value code in
+            Primitive.register name kind ka arity;
+            StringSet.iter Primitive.register_named_value named_values;
+            (if Hashtbl.mem provided name
+            then
+              let _, ploc, weakdef = Hashtbl.find provided name in
+              if not weakdef
+              then
+                warn
+                  "warning: overriding primitive %S\n  old: %s\n  new: %s@."
+                  name
+                  (loc ploc)
+                  (loc pi));
+            Hashtbl.add provided name (id, pi, weakdef);
+            Hashtbl.add provided_rev id (name, pi);
+            check_primitive ~name pi ~code ~requires;
+            Hashtbl.add code_pieces id (code, requires))
 
 let add_file filename = List.iter (parse_file filename) ~f:(load_fragment ~filename)
 

compiler/lib/linker.mli

@@ -28,6 +28,7 @@ type fragment =
   ; version_constraint : ((int -> int -> bool) * string) list list
   ; weakdef : bool
   ; code : Javascript.program
+  ; ignore : [ `No | `Because of Primitive.condition ]
   }
 
 val parse_file : string -> fragment list

compiler/lib/parse_bytecode.ml

@@ -2518,7 +2518,7 @@ let predefined_exceptions () =
         let v_name_js = Var.fresh () in
         let v_index = Var.fresh () in
         [ Let (v_name, Constant (String name))
-        ; Let (v_name_js, Prim (Extern "caml_js_from_string", [ Pc (IString name) ]))
+        ; Let (v_name_js, Constant (IString name))
         ; Let (v_index, Constant (Int (Int32.of_int (-index))))
         ; Let (exn, Block (248, [| v_name; v_index |], NotArray))
         ; Let

compiler/lib/primitive.ml

@@ -38,11 +38,17 @@ type kind_arg =
   | `Mutable
   ]
 
+type condition =
+  [ `If of Parse_info.t option * string
+  | `Ifnot of Parse_info.t option * string
+  ]
+
 type t =
   [ `Requires of Parse_info.t option * string list
   | `Provides of Parse_info.t option * string * kind * kind_arg list option
   | `Version of Parse_info.t option * ((int -> int -> bool) * string) list
   | `Weakdef of Parse_info.t option
+  | condition
   ]
 
 let kinds = Hashtbl.create 37

compiler/lib/primitive.mli

@@ -36,11 +36,17 @@ type kind_arg =
   | `Mutable
   ]
 
+type condition =
+  [ `If of Parse_info.t option * string
+  | `Ifnot of Parse_info.t option * string
+  ]
+
 type t =
   [ `Requires of Parse_info.t option * string list
   | `Provides of Parse_info.t option * string * kind * kind_arg list option
   | `Version of Parse_info.t option * ((int -> int -> bool) * string) list
   | `Weakdef of Parse_info.t option
+  | condition
   ]
 
 val kind : string -> kind

compiler/lib/specialize_js.ml

@@ -125,7 +125,7 @@ let specialize_instr info i rem =
       | Some s -> Let (x, Prim (Extern "caml_js_delete", [ o; Pc (String s) ]))
       | _ -> i)
       :: rem
-  | Let (x, Prim (Extern "caml_js_from_string", [ y ])) ->
+  | Let (x, Prim (Extern ("caml_jsstring_of_string" | "caml_js_from_string"), [ y ])) ->
       (match the_string_of info y with
       | Some s when String.is_ascii s -> Let (x, Constant (IString s))
       | _ -> i)

compiler/lib/var_printer.ml

@@ -102,6 +102,11 @@ let name t v nm_orig =
       | "", _ -> "symbol"
       | str, _ -> str
     in
+    (* protect against large names *)
+    let max_len = 30 in
+    let str =
+      if String.length str > max_len then String.sub str ~pos:0 ~len:max_len else str
+    in
     name_raw t v str)
 
 let get_name t v = try Some (Hashtbl.find t.names v) with Not_found -> None