Skip to content

Commit 1fc8301

Browse files
hhugoxclerc
hhugo
and
xclerc
authored
Compiler: cleanup usage of IString (now NativeString) vs String (#984)
 Co-authored-by: Xavier Clerc <xclerc@users.noreply.github.com>
1 parent 5dd6f9d commit 1fc8301

File tree

21 files changed

+221
-171
lines changed

21 files changed

+221
-171
lines changed

‎CHANGES.md

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@
55
* Compiler: speedup emitting js files (#1174)
66
* Compiler: simplify (a | 0) >>> 0 into (a >>> 0) (#1177)
77
* Compiler: improve static evaluation of cond (#1178)
8+
* Compiler: be more consistent dealing with js vs ocaml strings (#984)
89
* Lib: add messageEvent to Dom_html (#1164)
910
* Lib: add PerformanceObserver API (#1164)
1011
* Lib: add CSSStyleDeclaration.{setProperty, getPropertyValue, getPropertyPriority, removeProperty} (#1170)

‎compiler/bin-js_of_ocaml/build_fs.ml

Lines changed: 5 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -49,10 +49,10 @@ let options =
4949
let f { files; output_file; include_dirs } =
5050
let code =
5151
{|
52-
//Provides: caml_create_file_extern
53-
function caml_create_file_extern(name,content){
54-
if(joo_global_object.caml_create_file)
55-
joo_global_object.caml_create_file(name,content);
52+
//Provides: jsoo_create_file_extern
53+
function jsoo_create_file_extern(name,content){
54+
if(joo_global_object.jsoo_create_file)
55+
joo_global_object.jsoo_create_file(name,content);
5656
else {
5757
if(!joo_global_object.caml_fs_tmp) joo_global_object.caml_fs_tmp = [];
5858
joo_global_object.caml_fs_tmp.push({name:name,content:content});
@@ -64,11 +64,7 @@ function caml_create_file_extern(name,content){
6464
let fragments = Linker.parse_string code in
6565
Linker.load_fragments ~target_env:Isomorphic ~filename:"<dummy>" fragments;
6666
let instr =
67-
Pseudo_fs.f
68-
~prim:`caml_create_file_extern
69-
~cmis:StringSet.empty
70-
~files
71-
~paths:include_dirs
67+
Pseudo_fs.f ~prim:`create_file_extern ~cmis:StringSet.empty ~files ~paths:include_dirs
7268
in
7369
let code = Code.prepend Code.empty instr in
7470
Filename.gen_file output_file (fun chan ->

‎compiler/bin-js_of_ocaml/compile.ml

Lines changed: 11 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -137,10 +137,15 @@ let run
137137
Pseudo_fs.f ~prim ~cmis ~files:fs_files ~paths
138138
in
139139
let env_instr () =
140-
List.map static_env ~f:(fun (k, v) ->
140+
List.concat_map static_env ~f:(fun (k, v) ->
141141
Primitive.add_external "caml_set_static_env";
142-
let args = [ Code.Pc (IString k); Code.Pc (IString v) ] in
143-
Code.(Let (Var.fresh (), Prim (Extern "caml_set_static_env", args))))
142+
let var_k = Code.Var.fresh () in
143+
let var_v = Code.Var.fresh () in
144+
Code.
145+
[ Let (var_k, Prim (Extern "caml_jsstring_of_string", [ Pc (String k) ]))
146+
; Let (var_v, Prim (Extern "caml_jsstring_of_string", [ Pc (String v) ]))
147+
; Let (Var.fresh (), Prim (Extern "caml_set_static_env", [ Pv var_k; Pv var_v ]))
148+
])
144149
in
145150
let output (one : Parse_bytecode.one) ~standalone output_file =
146151
check_debug one;
@@ -149,7 +154,7 @@ let run
149154
| `Stdout ->
150155
let instr =
151156
List.concat
152-
[ pseudo_fs_instr `caml_create_file one.debug one.cmis
157+
[ pseudo_fs_instr `create_file one.debug one.cmis
153158
; (if init_pseudo_fs then [ Pseudo_fs.init () ] else [])
154159
; env_instr ()
155160
]
@@ -170,8 +175,8 @@ let run
170175
| `Name file ->
171176
let fs_instr1, fs_instr2 =
172177
match fs_output with
173-
| None -> pseudo_fs_instr `caml_create_file one.debug one.cmis, []
174-
| Some _ -> [], pseudo_fs_instr `caml_create_file_extern one.debug one.cmis
178+
| None -> pseudo_fs_instr `create_file one.debug one.cmis, []
179+
| Some _ -> [], pseudo_fs_instr `create_file_extern one.debug one.cmis
175180
in
176181
Filename.gen_file file (fun chan ->
177182
let instr =

‎compiler/bin-jsoo_fs/jsoo_fs.ml

Lines changed: 3 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -76,8 +76,8 @@ let info =
7676
let f { files; output_file; include_dirs } =
7777
let code =
7878
{|
79-
//Provides: caml_create_file_extern
80-
function caml_create_file_extern(name,content){
79+
//Provides: jsoo_create_file_extern
80+
function jsoo_create_file_extern(name,content){
8181
if(joo_global_object.caml_create_file)
8282
joo_global_object.caml_create_file(name,content);
8383
else {
@@ -91,11 +91,7 @@ function caml_create_file_extern(name,content){
9191
let fragments = Linker.parse_string code in
9292
Linker.load_fragments ~target_env:Isomorphic ~filename:"<dummy>" fragments;
9393
let instr =
94-
Pseudo_fs.f
95-
~prim:`caml_create_file_extern
96-
~cmis:StringSet.empty
97-
~files
98-
~paths:include_dirs
94+
Pseudo_fs.f ~prim:`create_file_extern ~cmis:StringSet.empty ~files ~paths:include_dirs
9995
in
10096
let code = Code.prepend Code.empty instr in
10197
Filename.gen_file output_file (fun chan ->

‎compiler/lib/code.ml

Lines changed: 10 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -259,7 +259,7 @@ type array_or_not =
259259

260260
type constant =
261261
| String of string
262-
| IString of string
262+
| NativeString of string
263263
| Float of float
264264
| Float_array of float array
265265
| Int64 of int64
@@ -269,7 +269,7 @@ type constant =
269269
let rec constant_equal a b =
270270
match a, b with
271271
| String a, String b -> Some (String.equal a b)
272-
| IString a, IString b -> Some (String.equal a b)
272+
| NativeString a, NativeString b -> Some (String.equal a b)
273273
| Tuple (ta, a, _), Tuple (tb, b, _) ->
274274
if ta <> tb || Array.length a <> Array.length b
275275
then Some false
@@ -286,21 +286,21 @@ let rec constant_equal a b =
286286
| Float_array a, Float_array b -> Some (Array.equal Float.equal a b)
287287
| Int a, Int b -> Some (Int32.equal a b)
288288
| Float a, Float b -> Some (Float.equal a b)
289-
| String _, IString _ | IString _, String _ -> None
289+
| String _, NativeString _ | NativeString _, String _ -> None
290290
| Int _, Float _ | Float _, Int _ -> None
291291
| Tuple ((0 | 254), _, _), Float_array _ -> None
292292
| Float_array _, Tuple ((0 | 254), _, _) -> None
293-
| Tuple _, (String _ | IString _ | Int64 _ | Int _ | Float _ | Float_array _) ->
293+
| Tuple _, (String _ | NativeString _ | Int64 _ | Int _ | Float _ | Float_array _) ->
294294
Some false
295-
| Float_array _, (String _ | IString _ | Int64 _ | Int _ | Float _ | Tuple _) ->
295+
| Float_array _, (String _ | NativeString _ | Int64 _ | Int _ | Float _ | Tuple _) ->
296296
Some false
297297
| String _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false
298-
| IString _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false
299-
| Int64 _, (String _ | IString _ | Int _ | Float _ | Tuple _ | Float_array _) ->
298+
| NativeString _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false
299+
| Int64 _, (String _ | NativeString _ | Int _ | Float _ | Tuple _ | Float_array _) ->
300300
Some false
301-
| Float _, (String _ | IString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
301+
| Float _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
302302
Some false
303-
| Int _, (String _ | IString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
303+
| Int _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
304304
Some false
305305

306306
type prim_arg =
@@ -360,7 +360,7 @@ module Print = struct
360360
let rec constant f x =
361361
match x with
362362
| String s -> Format.fprintf f "%S" s
363-
| IString s -> Format.fprintf f "%S" s
363+
| NativeString s -> Format.fprintf f "%Sj" s
364364
| Float fl -> Format.fprintf f "%.12g" fl
365365
| Float_array a ->
366366
Format.fprintf f "[|";

‎compiler/lib/code.mli

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -142,7 +142,7 @@ type array_or_not =
142142

143143
type constant =
144144
| String of string
145-
| IString of string
145+
| NativeString of string
146146
| Float of float
147147
| Float_array of float array
148148
| Int64 of int64

‎compiler/lib/eval.ml

Lines changed: 6 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -129,8 +129,7 @@ let eval_prim x =
129129
| "caml_sin_float", _ -> float_unop l sin
130130
| "caml_sqrt_float", _ -> float_unop l sqrt
131131
| "caml_tan_float", _ -> float_unop l tan
132-
| ( ("caml_string_get" | "caml_string_unsafe_get")
133-
, [ (String s | IString s); Int pos ] ) ->
132+
| ("caml_string_get" | "caml_string_unsafe_get"), [ String s; Int pos ] ->
134133
let pos = Int.to_int pos in
135134
if Config.Flag.safe_string () && pos >= 0 && pos < String.length s
136135
then Some (Int (Int.of_int (Char.code s.[pos])))
@@ -153,8 +152,7 @@ let the_length_of info x =
153152
info
154153
(fun x ->
155154
match info.info_defs.(Var.idx x) with
156-
| Expr (Constant (String s)) | Expr (Constant (IString s)) ->
157-
Some (Int32.of_int (String.length s))
155+
| Expr (Constant (String s)) -> Some (Int32.of_int (String.length s))
158156
| Expr (Prim (Extern "caml_create_string", [ arg ]))
159157
| Expr (Prim (Extern "caml_create_bytes", [ arg ])) ->
160158
the_int info arg
@@ -207,7 +205,7 @@ let eval_instr info i =
207205
| Let (x, Prim (Extern "caml_ml_string_length", [ s ])) -> (
208206
let c =
209207
match s with
210-
| Pc (String s) | Pc (IString s) -> Some (Int32.of_int (String.length s))
208+
| Pc (String s) -> Some (Int32.of_int (String.length s))
211209
| Pv v -> the_length_of info v
212210
| _ -> None
213211
in
@@ -261,7 +259,7 @@ let eval_instr info i =
261259
( prim
262260
, List.map2 prim_args prim_args' ~f:(fun arg c ->
263261
match c with
264-
| Some ((Int _ | Float _ | IString _) as c) -> Pc c
262+
| Some ((Int _ | Float _ | NativeString _) as c) -> Pc c
265263
| Some (String _ as c) when Config.Flag.use_js_string () -> Pc c
266264
| Some _
267265
(* do not be duplicated other constant as
@@ -312,8 +310,8 @@ let the_cond_of info x =
312310
| Expr (Constant (Int 0l)) -> Zero
313311
| Expr
314312
(Constant
315-
(Int _ | Float _ | Tuple _ | String _ | IString _ | Float_array _ | Int64 _))
316-
->
313+
( Int _ | Float _ | Tuple _ | String _ | NativeString _ | Float_array _
314+
| Int64 _ )) ->
317315
Non_zero
318316
| Expr (Block (_, _, _)) -> Non_zero
319317
| Expr (Field _ | Closure _ | Prim _ | Apply _) -> Unknown

‎compiler/lib/flow.ml

Lines changed: 8 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -306,7 +306,7 @@ let the_def_of info x =
306306
info
307307
(fun x ->
308308
match info.info_defs.(Var.idx x) with
309-
| Expr (Constant (Float _ | Int _ | IString _) as e) -> Some e
309+
| Expr (Constant (Float _ | Int _ | NativeString _) as e) -> Some e
310310
| Expr (Constant (String _) as e) when Config.Flag.safe_string () -> Some e
311311
| Expr e -> if info.info_possibly_mutable.(Var.idx x) then None else Some e
312312
| _ -> None)
@@ -322,7 +322,7 @@ let the_const_of info x =
322322
info
323323
(fun x ->
324324
match info.info_defs.(Var.idx x) with
325-
| Expr (Constant ((Float _ | Int _ | IString _) as c)) -> Some c
325+
| Expr (Constant ((Float _ | Int _ | NativeString _) as c)) -> Some c
326326
| Expr (Constant (String _ as c)) when Config.Flag.safe_string () -> Some c
327327
| Expr (Constant c) ->
328328
if info.info_possibly_mutable.(Var.idx x) then None else Some c
@@ -342,7 +342,12 @@ let the_int info x =
342342

343343
let the_string_of info x =
344344
match the_const_of info x with
345-
| Some (String i | IString i) -> Some i
345+
| Some (String i) -> Some i
346+
| _ -> None
347+
348+
let the_native_string_of info x =
349+
match the_const_of info x with
350+
| Some (NativeString i) -> Some i
346351
| _ -> None
347352

348353
(*XXX Maybe we could iterate? *)

‎compiler/lib/flow.mli

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -58,6 +58,8 @@ val the_const_of : info -> Code.prim_arg -> Code.constant option
5858

5959
val the_string_of : info -> Code.prim_arg -> string option
6060

61+
val the_native_string_of : info -> Code.prim_arg -> string option
62+
6163
val the_int : info -> Code.prim_arg -> int32 option
6264

6365
val update_def : info -> Code.Var.t -> Code.expr -> unit

‎compiler/lib/generate.ml

Lines changed: 23 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -111,12 +111,12 @@ module Share = struct
111111
then share
112112
else add_prim "caml_string_of_jsbytes" share
113113

114-
let add_code_istring s share = add_string s share
114+
let add_code_native_string s share = add_string s share
115115

116116
let rec get_constant c t =
117117
match c with
118118
| String s -> add_code_string s t
119-
| IString s -> add_code_istring s t
119+
| NativeString s -> add_code_native_string s t
120120
| Tuple (_, args, _) -> Array.fold_left args ~init:t ~f:(fun t c -> get_constant c t)
121121
| _ -> t
122122

@@ -139,7 +139,7 @@ module Share = struct
139139
match i with
140140
| Let (_, Constant c) -> get_constant c share
141141
| Let (_, Apply (_, args, false)) -> add_apply (List.length args) share
142-
| Let (_, Prim (Extern "%closure", [ Pc (IString name | String name) ])) ->
142+
| Let (_, Prim (Extern "%closure", [ Pc (NativeString name) ])) ->
143143
let name = Primitive.resolve name in
144144
let share =
145145
if Primitive.exists name then add_prim name share else share
@@ -332,7 +332,7 @@ let rec constant_rec ~ctx x level instrs =
332332
let e = Share.get_string str_js s ctx.Ctx.share in
333333
let e = ocaml_string ~ctx ~loc:J.N e in
334334
e, instrs
335-
| IString s -> Share.get_string str_js s ctx.Ctx.share, instrs
335+
| NativeString s -> Share.get_string str_js s ctx.Ctx.share, instrs
336336
| Float f -> float_const f, instrs
337337
| Float_array a ->
338338
( Mlvalue.Array.make
@@ -1048,9 +1048,8 @@ let rec translate_expr ctx queue loc _x e level : _ * J.statement_list =
10481048
let (px, cx), queue = access_queue' ~ctx queue x in
10491049
let (py, cy), queue = access_queue' ~ctx queue y in
10501050
Mlvalue.Array.field cx cy, or_p mutable_p (or_p px py), queue
1051-
| Extern "caml_js_var", [ Pc (String nm | IString nm) ]
1052-
| Extern ("caml_js_expr" | "caml_pure_js_expr"), [ Pc (String nm | IString nm) ]
1053-
-> (
1051+
| Extern "caml_js_var", [ Pc (String nm) ]
1052+
| Extern ("caml_js_expr" | "caml_pure_js_expr"), [ Pc (String nm) ] -> (
10541053
try
10551054
let lexbuf = Lexing.from_string nm in
10561055
let lexbuf =
@@ -1095,9 +1094,10 @@ let rec translate_expr ctx queue loc _x e level : _ * J.statement_list =
10951094
~init:([], const_p, queue)
10961095
in
10971096
J.EArr (List.map args ~f:(fun x -> Some x)), prop, queue
1098-
| Extern "%closure", [ Pc (IString name | String name) ] ->
1097+
| Extern "%closure", [ Pc (NativeString name) ] ->
10991098
let prim = Share.get_prim (runtime_fun ctx) name ctx.Ctx.share in
11001099
prim, const_p, queue
1100+
| Extern "%closure", _ -> assert false
11011101
| Extern "%caml_js_opt_call", f :: o :: l ->
11021102
let (pf, cf), queue = access_queue' ~ctx queue f in
11031103
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 =
11211121
~init:([], mutator_p, queue)
11221122
in
11231123
ecall cf args loc, or_p pf prop, queue
1124-
| Extern "%caml_js_opt_meth_call", o :: Pc (String m | IString m) :: l ->
1124+
| Extern "%caml_js_opt_meth_call", o :: Pc (NativeString m) :: l ->
11251125
let (po, co), queue = access_queue' ~ctx queue o in
11261126
let args, prop, queue =
11271127
List.fold_right
@@ -1132,6 +1132,7 @@ let rec translate_expr ctx queue loc _x e level : _ * J.statement_list =
11321132
~init:([], mutator_p, queue)
11331133
in
11341134
ecall (J.EDot (co, m)) args loc, or_p po prop, queue
1135+
| Extern "%caml_js_opt_meth_call", _ :: Pc (String _) :: _ -> assert false
11351136
| Extern "%caml_js_opt_new", c :: l ->
11361137
let (pc, cc), queue = access_queue' ~ctx queue c in
11371138
let args, prop, queue =
@@ -1145,27 +1146,32 @@ let rec translate_expr ctx queue loc _x e level : _ * J.statement_list =
11451146
( J.ENew (cc, if List.is_empty args then None else Some args)
11461147
, or_p pc prop
11471148
, queue )
1148-
| Extern "caml_js_get", [ Pv o; Pc (String f | IString f) ] when J.is_ident f ->
1149+
| Extern "caml_js_get", [ Pv o; Pc (NativeString f) ] when J.is_ident f ->
11491150
let (po, co), queue = access_queue queue o in
11501151
J.EDot (co, f), or_p po mutable_p, queue
1151-
| Extern "caml_js_set", [ Pv o; Pc (String f | IString f); v ] when J.is_ident f
1152-
->
1152+
| Extern "caml_js_set", [ Pv o; Pc (NativeString f); v ] when J.is_ident f ->
11531153
let (po, co), queue = access_queue queue o in
11541154
let (pv, cv), queue = access_queue' ~ctx queue v in
11551155
J.EBin (J.Eq, J.EDot (co, f), cv), or_p (or_p po pv) mutator_p, queue
1156-
| Extern "caml_js_delete", [ Pv o; Pc (String f | IString f) ] when J.is_ident f
1157-
->
1156+
| Extern "caml_js_delete", [ Pv o; Pc (NativeString f) ] when J.is_ident f ->
11581157
let (po, co), queue = access_queue queue o in
11591158
J.EUn (J.Delete, J.EDot (co, f)), or_p po mutator_p, queue
1160-
| Extern "%overrideMod", [ Pc (String m | IString m); Pc (String f | IString f) ]
1161-
->
1159+
(*
1160+
This is only useful for debugging:
1161+
{[
1162+
| Extern "caml_js_get", [ _; Pc (String _) ] -> assert false
1163+
| Extern "caml_js_set", [ _; Pc (String s); _ ] -> assert false
1164+
| Extern "caml_js_delete", [ _; Pc (String _) ] -> assert false
1165+
]}
1166+
*)
1167+
| Extern "%overrideMod", [ Pc (NativeString m); Pc (NativeString f) ] ->
11621168
runtime_fun ctx (Printf.sprintf "caml_%s_%s" m f), const_p, queue
11631169
| Extern "%overrideMod", _ -> assert false
11641170
| Extern "%caml_js_opt_object", fields ->
11651171
let rec build_fields queue l =
11661172
match l with
11671173
| [] -> const_p, [], queue
1168-
| Pc (String nm | IString nm) :: x :: r ->
1174+
| Pc (NativeString nm) :: x :: r ->
11691175
let (prop, cx), queue = access_queue' ~ctx queue x in
11701176
let prop', r', queue = build_fields queue r in
11711177
or_p prop prop', (J.PNS nm, cx) :: r', queue

0 commit comments

Comments
 (0)