Compiler: cleanup usage of IString (now NativeString) vs String

CHANGES.md

@@ -5,6 +5,7 @@
 * Compiler: speedup emitting js files (#1174)
 * Compiler: simplify (a | 0) >>> 0 into (a >>> 0) (#1177)
 * Compiler: improve static evaluation of cond (#1178)
+* Compiler: be more consistent dealing with js vs ocaml strings (#984)
 * Lib: add messageEvent to Dom_html (#1164)
 * Lib: add PerformanceObserver API (#1164)
 * Lib: add CSSStyleDeclaration.{setProperty, getPropertyValue, getPropertyPriority, removeProperty} (#1170)

compiler/bin-js_of_ocaml/build_fs.ml

@@ -49,10 +49,10 @@ let options =
 let f { files; output_file; include_dirs } =
   let code =
     {|
-//Provides: caml_create_file_extern
-function caml_create_file_extern(name,content){
-  if(joo_global_object.caml_create_file)
-    joo_global_object.caml_create_file(name,content);
+//Provides: jsoo_create_file_extern
+function jsoo_create_file_extern(name,content){
+  if(joo_global_object.jsoo_create_file)
+    joo_global_object.jsoo_create_file(name,content);
   else {
     if(!joo_global_object.caml_fs_tmp) joo_global_object.caml_fs_tmp = [];
     joo_global_object.caml_fs_tmp.push({name:name,content:content});
@@ -64,11 +64,7 @@ function caml_create_file_extern(name,content){
   let fragments = Linker.parse_string code in
   Linker.load_fragments ~target_env:Isomorphic ~filename:"<dummy>" fragments;
   let instr =
-    Pseudo_fs.f
-      ~prim:`caml_create_file_extern
-      ~cmis:StringSet.empty
-      ~files
-      ~paths:include_dirs
+    Pseudo_fs.f ~prim:`create_file_extern ~cmis:StringSet.empty ~files ~paths:include_dirs
   in
   let code = Code.prepend Code.empty instr in
   Filename.gen_file output_file (fun chan ->

compiler/bin-js_of_ocaml/compile.ml

@@ -137,10 +137,15 @@ let run
     Pseudo_fs.f ~prim ~cmis ~files:fs_files ~paths
   in
   let env_instr () =
-    List.map static_env ~f:(fun (k, v) ->
+    List.concat_map static_env ~f:(fun (k, v) ->
         Primitive.add_external "caml_set_static_env";
-        let args = [ Code.Pc (IString k); Code.Pc (IString v) ] in
-        Code.(Let (Var.fresh (), Prim (Extern "caml_set_static_env", args))))
+        let var_k = Code.Var.fresh () in
+        let var_v = Code.Var.fresh () in
+        Code.
+          [ Let (var_k, Prim (Extern "caml_jsstring_of_string", [ Pc (String k) ]))
+          ; Let (var_v, Prim (Extern "caml_jsstring_of_string", [ Pc (String v) ]))
+          ; Let (Var.fresh (), Prim (Extern "caml_set_static_env", [ Pv var_k; Pv var_v ]))
+          ])
   in
   let output (one : Parse_bytecode.one) ~standalone output_file =
     check_debug one;
@@ -149,7 +154,7 @@ let run
     | `Stdout ->
         let instr =
           List.concat
-            [ pseudo_fs_instr `caml_create_file one.debug one.cmis
+            [ pseudo_fs_instr `create_file one.debug one.cmis
             ; (if init_pseudo_fs then [ Pseudo_fs.init () ] else [])
             ; env_instr ()
             ]
@@ -170,8 +175,8 @@ let run
     | `Name file ->
         let fs_instr1, fs_instr2 =
           match fs_output with
-          | None -> pseudo_fs_instr `caml_create_file one.debug one.cmis, []
-          | Some _ -> [], pseudo_fs_instr `caml_create_file_extern one.debug one.cmis
+          | None -> pseudo_fs_instr `create_file one.debug one.cmis, []
+          | Some _ -> [], pseudo_fs_instr `create_file_extern one.debug one.cmis
         in
         Filename.gen_file file (fun chan ->
             let instr =

compiler/bin-jsoo_fs/jsoo_fs.ml

@@ -76,8 +76,8 @@ let info =
 let f { files; output_file; include_dirs } =
   let code =
     {|
-//Provides: caml_create_file_extern
-function caml_create_file_extern(name,content){
+//Provides: jsoo_create_file_extern
+function jsoo_create_file_extern(name,content){
   if(joo_global_object.caml_create_file)
     joo_global_object.caml_create_file(name,content);
   else {
@@ -91,11 +91,7 @@ function caml_create_file_extern(name,content){
   let fragments = Linker.parse_string code in
   Linker.load_fragments ~target_env:Isomorphic ~filename:"<dummy>" fragments;
   let instr =
-    Pseudo_fs.f
-      ~prim:`caml_create_file_extern
-      ~cmis:StringSet.empty
-      ~files
-      ~paths:include_dirs
+    Pseudo_fs.f ~prim:`create_file_extern ~cmis:StringSet.empty ~files ~paths:include_dirs
   in
   let code = Code.prepend Code.empty instr in
   Filename.gen_file output_file (fun chan ->

compiler/lib/code.ml

@@ -259,7 +259,7 @@ type array_or_not =
 
 type constant =
   | String of string
-  | IString of string
+  | NativeString of string
   | Float of float
   | Float_array of float array
   | Int64 of int64
@@ -269,7 +269,7 @@ type constant =
 let rec constant_equal a b =
   match a, b with
   | String a, String b -> Some (String.equal a b)
-  | IString a, IString b -> Some (String.equal a b)
+  | NativeString a, NativeString b -> Some (String.equal a b)
   | Tuple (ta, a, _), Tuple (tb, b, _) ->
       if ta <> tb || Array.length a <> Array.length b
       then Some false
@@ -286,21 +286,21 @@ let rec constant_equal a b =
   | Float_array a, Float_array b -> Some (Array.equal Float.equal a b)
   | Int a, Int b -> Some (Int32.equal a b)
   | Float a, Float b -> Some (Float.equal a b)
-  | String _, IString _ | IString _, String _ -> None
+  | String _, NativeString _ | NativeString _, String _ -> None
   | Int _, Float _ | Float _, Int _ -> None
   | Tuple ((0 | 254), _, _), Float_array _ -> None
   | Float_array _, Tuple ((0 | 254), _, _) -> None
-  | Tuple _, (String _ | IString _ | Int64 _ | Int _ | Float _ | Float_array _) ->
+  | Tuple _, (String _ | NativeString _ | Int64 _ | Int _ | Float _ | Float_array _) ->
       Some false
-  | Float_array _, (String _ | IString _ | Int64 _ | Int _ | Float _ | Tuple _) ->
+  | Float_array _, (String _ | NativeString _ | Int64 _ | Int _ | Float _ | Tuple _) ->
       Some false
   | String _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false
-  | IString _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false
-  | Int64 _, (String _ | IString _ | Int _ | Float _ | Tuple _ | Float_array _) ->
+  | NativeString _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false
+  | Int64 _, (String _ | NativeString _ | Int _ | Float _ | Tuple _ | Float_array _) ->
       Some false
-  | Float _, (String _ | IString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
+  | Float _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
       Some false
-  | Int _, (String _ | IString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
+  | Int _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
       Some false
 
 type prim_arg =
@@ -360,7 +360,7 @@ module Print = struct
   let rec constant f x =
     match x with
     | String s -> Format.fprintf f "%S" s
-    | IString s -> Format.fprintf f "%S" s
+    | NativeString s -> Format.fprintf f "%Sj" s
     | Float fl -> Format.fprintf f "%.12g" fl
     | Float_array a ->
         Format.fprintf f "[|";

compiler/lib/code.mli

@@ -142,7 +142,7 @@ type array_or_not =
 
 type constant =
   | String of string
-  | IString of string
+  | NativeString of string
   | Float of float
   | Float_array of float array
   | Int64 of int64

compiler/lib/eval.ml

@@ -129,8 +129,7 @@ let eval_prim x =
       | "caml_sin_float", _ -> float_unop l sin
       | "caml_sqrt_float", _ -> float_unop l sqrt
       | "caml_tan_float", _ -> float_unop l tan
-      | ( ("caml_string_get" | "caml_string_unsafe_get")
-        , [ (String s | IString s); Int pos ] ) ->
+      | ("caml_string_get" | "caml_string_unsafe_get"), [ String s; Int pos ] ->
           let pos = Int.to_int pos in
           if Config.Flag.safe_string () && pos >= 0 && pos < String.length s
           then Some (Int (Int.of_int (Char.code s.[pos])))
@@ -153,8 +152,7 @@ let the_length_of info x =
     info
     (fun x ->
       match info.info_defs.(Var.idx x) with
-      | Expr (Constant (String s)) | Expr (Constant (IString s)) ->
-          Some (Int32.of_int (String.length s))
+      | Expr (Constant (String s)) -> Some (Int32.of_int (String.length s))
       | Expr (Prim (Extern "caml_create_string", [ arg ]))
       | Expr (Prim (Extern "caml_create_bytes", [ arg ])) ->
           the_int info arg
@@ -207,7 +205,7 @@ let eval_instr info i =
   | Let (x, Prim (Extern "caml_ml_string_length", [ s ])) -> (
       let c =
         match s with
-        | Pc (String s) | Pc (IString s) -> Some (Int32.of_int (String.length s))
+        | Pc (String s) -> Some (Int32.of_int (String.length s))
         | Pv v -> the_length_of info v
         | _ -> None
       in
@@ -261,7 +259,7 @@ let eval_instr info i =
                   ( prim
                   , List.map2 prim_args prim_args' ~f:(fun arg c ->
                         match c with
-                        | Some ((Int _ | Float _ | IString _) as c) -> Pc c
+                        | Some ((Int _ | Float _ | NativeString _) as c) -> Pc c
                         | Some (String _ as c) when Config.Flag.use_js_string () -> Pc c
                         | Some _
                         (* do not be duplicated other constant as
@@ -312,8 +310,8 @@ let the_cond_of info x =
       | Expr (Constant (Int 0l)) -> Zero
       | Expr
           (Constant
-            (Int _ | Float _ | Tuple _ | String _ | IString _ | Float_array _ | Int64 _))
-        ->
+            ( Int _ | Float _ | Tuple _ | String _ | NativeString _ | Float_array _
+            | Int64 _ )) ->
           Non_zero
       | Expr (Block (_, _, _)) -> Non_zero
       | Expr (Field _ | Closure _ | Prim _ | Apply _) -> Unknown

compiler/lib/flow.ml

@@ -306,7 +306,7 @@ let the_def_of info x =
         info
         (fun x ->
           match info.info_defs.(Var.idx x) with
-          | Expr (Constant (Float _ | Int _ | IString _) as e) -> Some e
+          | Expr (Constant (Float _ | Int _ | NativeString _) as e) -> Some e
           | Expr (Constant (String _) as e) when Config.Flag.safe_string () -> Some e
           | Expr e -> if info.info_possibly_mutable.(Var.idx x) then None else Some e
           | _ -> None)
@@ -322,7 +322,7 @@ let the_const_of info x =
         info
         (fun x ->
           match info.info_defs.(Var.idx x) with
-          | Expr (Constant ((Float _ | Int _ | IString _) as c)) -> Some c
+          | Expr (Constant ((Float _ | Int _ | NativeString _) as c)) -> Some c
           | Expr (Constant (String _ as c)) when Config.Flag.safe_string () -> Some c
           | Expr (Constant c) ->
               if info.info_possibly_mutable.(Var.idx x) then None else Some c
@@ -342,7 +342,12 @@ let the_int info x =
 
 let the_string_of info x =
   match the_const_of info x with
-  | Some (String i | IString i) -> Some i
+  | Some (String i) -> Some i
+  | _ -> None
+
+let the_native_string_of info x =
+  match the_const_of info x with
+  | Some (NativeString i) -> Some i
   | _ -> None
 
 (*XXX Maybe we could iterate? *)

compiler/lib/flow.mli

@@ -58,6 +58,8 @@ val the_const_of : info -> Code.prim_arg -> Code.constant option
 
 val the_string_of : info -> Code.prim_arg -> string option
 
+val the_native_string_of : info -> Code.prim_arg -> string option
+
 val the_int : info -> Code.prim_arg -> int32 option
 
 val update_def : info -> Code.Var.t -> Code.expr -> unit

compiler/lib/generate.ml

@@ -111,12 +111,12 @@ module Share = struct
     then share
     else add_prim "caml_string_of_jsbytes" share
 
-  let add_code_istring s share = add_string s share
+  let add_code_native_string s share = add_string s share
 
   let rec get_constant c t =
     match c with
     | String s -> add_code_string s t
-    | IString s -> add_code_istring s t
+    | NativeString s -> add_code_native_string s t
     | Tuple (_, args, _) -> Array.fold_left args ~init:t ~f:(fun t c -> get_constant c t)
     | _ -> t
 
@@ -139,7 +139,7 @@ module Share = struct
               match i with
               | Let (_, Constant c) -> get_constant c share
               | Let (_, Apply (_, args, false)) -> add_apply (List.length args) share
-              | Let (_, Prim (Extern "%closure", [ Pc (IString name | String name) ])) ->
+              | Let (_, Prim (Extern "%closure", [ Pc (NativeString name) ])) ->
                   let name = Primitive.resolve name in
                   let share =
                     if Primitive.exists name then add_prim name share else share
@@ -332,7 +332,7 @@ let rec constant_rec ~ctx x level instrs =
       let e = Share.get_string str_js s ctx.Ctx.share in
       let e = ocaml_string ~ctx ~loc:J.N e in
       e, instrs
-  | IString s -> Share.get_string str_js s ctx.Ctx.share, instrs
+  | NativeString s -> Share.get_string str_js s ctx.Ctx.share, instrs
   | Float f -> float_const f, instrs
   | Float_array a ->
       ( Mlvalue.Array.make
@@ -1048,9 +1048,8 @@ let rec translate_expr ctx queue loc _x e level : _ * J.statement_list =
             let (px, cx), queue = access_queue' ~ctx queue x in
             let (py, cy), queue = access_queue' ~ctx queue y in
             Mlvalue.Array.field cx cy, or_p mutable_p (or_p px py), queue
-        | Extern "caml_js_var", [ Pc (String nm | IString nm) ]
-        | Extern ("caml_js_expr" | "caml_pure_js_expr"), [ Pc (String nm | IString nm) ]
-          -> (
+        | Extern "caml_js_var", [ Pc (String nm) ]
+        | Extern ("caml_js_expr" | "caml_pure_js_expr"), [ Pc (String nm) ] -> (
             try
               let lexbuf = Lexing.from_string nm in
               let lexbuf =
@@ -1095,9 +1094,10 @@ let rec translate_expr ctx queue loc _x e level : _ * J.statement_list =
                 ~init:([], const_p, queue)
             in
             J.EArr (List.map args ~f:(fun x -> Some x)), prop, queue
-        | Extern "%closure", [ Pc (IString name | String name) ] ->
+        | Extern "%closure", [ Pc (NativeString name) ] ->
             let prim = Share.get_prim (runtime_fun ctx) name ctx.Ctx.share in
             prim, const_p, queue
+        | Extern "%closure", _ -> assert false
         | Extern "%caml_js_opt_call", f :: o :: l ->
             let (pf, cf), queue = access_queue' ~ctx queue f in
             let (po, co), queue = access_queue' ~ctx queue o in
@@ -1121,7 +1121,7 @@ let rec translate_expr ctx queue loc _x e level : _ * J.statement_list =
                 ~init:([], mutator_p, queue)
             in
             ecall cf args loc, or_p pf prop, queue
-        | Extern "%caml_js_opt_meth_call", o :: Pc (String m | IString m) :: l ->
+        | Extern "%caml_js_opt_meth_call", o :: Pc (NativeString m) :: l ->
             let (po, co), queue = access_queue' ~ctx queue o in
             let args, prop, queue =
               List.fold_right
@@ -1132,6 +1132,7 @@ let rec translate_expr ctx queue loc _x e level : _ * J.statement_list =
                 ~init:([], mutator_p, queue)
             in
             ecall (J.EDot (co, m)) args loc, or_p po prop, queue
+        | Extern "%caml_js_opt_meth_call", _ :: Pc (String _) :: _ -> assert false
         | Extern "%caml_js_opt_new", c :: l ->
             let (pc, cc), queue = access_queue' ~ctx queue c in
             let args, prop, queue =
@@ -1145,27 +1146,32 @@ let rec translate_expr ctx queue loc _x e level : _ * J.statement_list =
             ( J.ENew (cc, if List.is_empty args then None else Some args)
             , or_p pc prop
             , queue )
-        | Extern "caml_js_get", [ Pv o; Pc (String f | IString f) ] when J.is_ident f ->
+        | Extern "caml_js_get", [ Pv o; Pc (NativeString f) ] when J.is_ident f ->
             let (po, co), queue = access_queue queue o in
             J.EDot (co, f), or_p po mutable_p, queue
-        | Extern "caml_js_set", [ Pv o; Pc (String f | IString f); v ] when J.is_ident f
-          ->
+        | Extern "caml_js_set", [ Pv o; Pc (NativeString f); v ] when J.is_ident f ->
             let (po, co), queue = access_queue queue o in
             let (pv, cv), queue = access_queue' ~ctx queue v in
             J.EBin (J.Eq, J.EDot (co, f), cv), or_p (or_p po pv) mutator_p, queue
-        | Extern "caml_js_delete", [ Pv o; Pc (String f | IString f) ] when J.is_ident f
-          ->
+        | Extern "caml_js_delete", [ Pv o; Pc (NativeString f) ] when J.is_ident f ->
             let (po, co), queue = access_queue queue o in
             J.EUn (J.Delete, J.EDot (co, f)), or_p po mutator_p, queue
-        | Extern "%overrideMod", [ Pc (String m | IString m); Pc (String f | IString f) ]
-          ->
+        (*
+           This is only useful for debugging:
+           {[
+           | Extern "caml_js_get", [ _; Pc (String _) ] -> assert false
+           | Extern "caml_js_set", [ _; Pc (String s); _ ] -> assert false
+           | Extern "caml_js_delete", [ _; Pc (String _) ] -> assert false
+           ]}
+        *)
+        | Extern "%overrideMod", [ Pc (NativeString m); Pc (NativeString f) ] ->
             runtime_fun ctx (Printf.sprintf "caml_%s_%s" m f), const_p, queue
         | Extern "%overrideMod", _ -> assert false
         | Extern "%caml_js_opt_object", fields ->
             let rec build_fields queue l =
               match l with
               | [] -> const_p, [], queue
-              | Pc (String nm | IString nm) :: x :: r ->
+              | Pc (NativeString nm) :: x :: r ->
                   let (prop, cx), queue = access_queue' ~ctx queue x in
                   let prop', r', queue = build_fields queue r in
                   or_p prop prop', (J.PNS nm, cx) :: r', queue

compiler/lib/inline.ml

@@ -152,7 +152,7 @@ let simple blocks cont mapping =
       | `Ok (x, exp), Return ret when Code.Var.compare x (find_mapping mapping ret) = 0
         -> (
           match exp with
-          | Constant (Float _ | Int64 _ | Int _ | IString _) -> `Exp exp
+          | Constant (Float _ | Int64 _ | Int _ | NativeString _) -> `Exp exp
           | Apply (f, args, true) ->
               `Exp (Apply (map_var mapping f, List.map args ~f:(map_var mapping), true))
           | Prim (prim, args) ->
@@ -257,7 +257,8 @@ let inline closures live_vars outer_optimizable pc (blocks, free_pc) =
                    && Primitive.has_arity prim len
                    && args_equal l args
                 then
-                  Let (x, Prim (Extern "%closure", [ Pc (IString prim) ])) :: rem, state
+                  ( Let (x, Prim (Extern "%closure", [ Pc (NativeString prim) ])) :: rem
+                  , state )
                 else i :: rem, state
             | _ -> i :: rem, state)
         | _ -> i :: rem, state)