From cbdc229feff316495c90f7afefa8fe32403c87cf Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Tue, 15 Nov 2022 23:44:54 -0500 Subject: [PATCH] Thread more locations through primitive nodes --- jscomp/core/js_dump.ml | 4 +- jscomp/core/js_exp_make.ml | 52 +++--- jscomp/core/js_exp_make.mli | 31 ++-- jscomp/core/js_long.ml | 89 ++++++----- jscomp/core/js_long.mli | 4 +- jscomp/core/js_of_lam_array.ml | 16 +- jscomp/core/js_of_lam_array.mli | 18 ++- jscomp/core/js_of_lam_block.ml | 8 +- jscomp/core/js_of_lam_block.mli | 9 +- jscomp/core/js_of_lam_option.ml | 41 ++--- jscomp/core/js_of_lam_option.mli | 23 +-- jscomp/core/js_of_lam_string.ml | 26 +-- jscomp/core/js_of_lam_string.mli | 23 ++- jscomp/core/lam_compile_primitive.ml | 213 ++++++++++++++----------- jscomp/core/lam_dispatch_primitive.ml | 161 +++++++++++-------- jscomp/core/lam_dispatch_primitive.mli | 8 +- jscomp/core/lam_eta_conversion.ml | 6 + 17 files changed, 417 insertions(+), 315 deletions(-) diff --git a/jscomp/core/js_dump.ml b/jscomp/core/js_dump.ml index cb85674fe5..f7cd5eef40 100644 --- a/jscomp/core/js_dump.ml +++ b/jscomp/core/js_dump.ml @@ -913,7 +913,7 @@ and array_element_list cxt (el : E.t list) : cxt = and arguments cxt (l : E.t list) : cxt = iter_lst cxt l (expression ~level:1) comma_sp -and variable_declaration top cxt (variable : J.variable_declaration) : cxt = +and variable_declaration ~top cxt (variable : J.variable_declaration) : cxt = (* TODO: print [const/var] for different backends *) match variable with | { ident = i; value = None; ident_info; _ } -> @@ -997,7 +997,7 @@ and statement_desc top cxt (s : J.statement_desc) : cxt = let cxt = statements top cxt b in ipp_comment cxt L.end_block; cxt - | Variable l -> variable_declaration top cxt l + | Variable l -> variable_declaration ~top cxt l | If (e, s1, s2) -> ( (* TODO: always brace those statements *) string cxt L.if_; diff --git a/jscomp/core/js_exp_make.ml b/jscomp/core/js_exp_make.ml index f63757e5ab..4a6ce15ba6 100644 --- a/jscomp/core/js_exp_make.ml +++ b/jscomp/core/js_exp_make.ml @@ -107,8 +107,8 @@ let ml_module_as_var ?loc ?comment (id : Ident.t) : t = make_expression ?loc ?comment (Var (Qualified ({ id; kind = Ml }, None))) (* Static_index .....................*) -let runtime_call module_name fn_name args = - call ~info:Js_call_info.builtin_runtime_call +let runtime_call ?loc module_name fn_name args = + call ?loc ~info:Js_call_info.builtin_runtime_call (runtime_var_dot module_name fn_name) args @@ -117,7 +117,8 @@ let pure_runtime_call ?loc module_name fn_name args = (runtime_var_dot module_name fn_name) args -let runtime_ref module_name fn_name = runtime_var_dot module_name fn_name +let runtime_ref ?loc module_name fn_name = + runtime_var_dot ?loc module_name fn_name let str ?(pure = true) ?loc ?comment s : t = make_expression ?loc ?comment (Str (pure, s)) @@ -133,11 +134,11 @@ let array ?loc ?comment mt es : t = let some_comment = None -let optional_block e : J.expression = - make_expression ?comment:some_comment (Optional_block (e, false)) +let optional_block ?loc e : J.expression = + make_expression ?loc ?comment:some_comment (Optional_block (e, false)) -let optional_not_nest_block e : J.expression = - make_expression (Optional_block (e, true)) +let optional_not_nest_block ?loc e : J.expression = + make_expression ?loc (Optional_block (e, true)) (* used in normal property like [e.length], no dependency introduced @@ -592,7 +593,7 @@ let or_ ?loc ?comment (e1 : t) (e2 : t) = (* TODO: when comparison with Int it is right that !(x > 3 ) -> x <= 3 *) -let not (e : t) : t = +let not ?loc (e : t) : t = match e.expression_desc with | Number (Int { i; _ }) -> bool (i = 0l) | Js_not e -> e @@ -603,7 +604,7 @@ let not (e : t) : t = | Bin (Ge, a, b) -> { e with expression_desc = Bin (Lt, a, b) } | Bin (Le, a, b) -> { e with expression_desc = Bin (Gt, a, b) } | Bin (Gt, a, b) -> { e with expression_desc = Bin (Le, a, b) } - | _ -> make_expression (Js_not e) + | _ -> make_expression ?loc (Js_not e) let not_empty_branch (x : t) = match x.expression_desc with @@ -720,15 +721,15 @@ let tag ?loc ?comment e : t = it's reduced to 31 bits for hash *) (* FIXME: unused meth_name *) -let public_method_call _meth_name obj label cache args = +let public_method_call ?loc _meth_name obj label cache args = let len = List.length args in (* econd (int_equal (tag obj ) obj_int_tag_literal) *) if len <= 7 then - runtime_call Js_runtime_modules.caml_oo_curry + runtime_call ?loc Js_runtime_modules.caml_oo_curry ("js" ^ string_of_int (len + 1)) (label :: int cache :: obj :: args) else - runtime_call Js_runtime_modules.caml_oo_curry "js" + runtime_call ?loc Js_runtime_modules.caml_oo_curry "js" [ label; int cache; obj; array NA (obj :: args) ] (* TODO: handle arbitrary length of args .. @@ -926,10 +927,10 @@ let to_uint32 ?loc ?comment (e : J.expression) : J.expression = we can apply a more general optimization here, do some algebraic rewerite rules to rewrite [triple_equal] *) -let rec is_out ?comment (e : t) (range : t) : t = +let rec is_out ?loc ?comment (e : t) (range : t) : t = match (range.expression_desc, e.expression_desc) with | Number (Int { i = 1l }), Var _ -> - not + not ?loc (or_ (triple_equal e zero_int_literal) (triple_equal e one_int_literal)) | ( Number (Int { i = 1l }), ( Bin @@ -940,7 +941,7 @@ let rec is_out ?comment (e : t) (range : t) : t = ( Plus, ({ expression_desc = Var _; _ } as x), { expression_desc = Number (Int { i; _ }) } ) ) ) -> - not + not ?loc (or_ (triple_equal x (int (Int32.neg i))) (triple_equal x (int (Int32.sub Int32.one i)))) @@ -949,19 +950,20 @@ let rec is_out ?comment (e : t) (range : t) : t = ( Minus, ({ expression_desc = Var _; _ } as x), { expression_desc = Number (Int { i; _ }) } ) ) -> - not (or_ (triple_equal x (int (Int32.add i 1l))) (triple_equal x (int i))) + not ?loc + (or_ (triple_equal x (int (Int32.add i 1l))) (triple_equal x (int i))) (* (x - i >>> 0 ) > k *) | ( Number (Int { i = k }), Bin ( Minus, ({ expression_desc = Var _; _ } as x), { expression_desc = Number (Int { i; _ }) } ) ) -> - or_ (int_comp Cgt x (int (Int32.add i k))) (int_comp Clt x (int i)) + or_ ?loc (int_comp Cgt x (int (Int32.add i k))) (int_comp Clt x (int i)) | Number (Int { i = k }), Var _ -> (* Note that js support [ 1 < x < 3], we can optimize it into [ not ( 0<= x <= k)] *) - or_ (int_comp Cgt e (int k)) (int_comp Clt e zero_int_literal) + or_ ?loc (int_comp Cgt e (int k)) (int_comp Clt e zero_int_literal) | ( _, Bin ( Bor, @@ -978,8 +980,8 @@ let rec is_out ?comment (e : t) (range : t) : t = } as e), { expression_desc = Number (Int { i = 0l } | Uint 0l); _ } ) ) -> (* TODO: check correctness *) - is_out ?comment e range - | _, _ -> int_comp ?comment Cgt (to_uint32 e) range + is_out ?loc ?comment e range + | _, _ -> int_comp ?loc ?comment Cgt (to_uint32 e) range let rec float_add ?loc ?comment (e1 : t) (e2 : t) = match (e1.expression_desc, e2.expression_desc) with @@ -1022,8 +1024,8 @@ and float_minus ?loc ?comment (e1 : t) (e2 : t) : t = let unchecked_int32_add ?loc ?comment e1 e2 = float_add ?loc ?comment e1 e2 let int32_add ?loc ?comment e1 e2 = to_int32 ?loc (float_add ?comment e1 e2) -let offset e1 (offset : int) = - if offset = 0 then e1 else int32_add e1 (small_int offset) +let offset ?loc e1 (offset : int) = + if offset = 0 then e1 else int32_add ?loc e1 (small_int offset) let int32_minus ?loc ?comment e1 e2 : J.expression = to_int32 ?loc (float_minus ?comment e1 e2) @@ -1196,9 +1198,9 @@ let neq_null_undefined_boolean ?loc ?comment (a : t) (b : t) = (* TODO: in the future add a flag to set globalThis *) -let resolve_and_apply (s : string) (args : t list) : t = - call ~info:Js_call_info.builtin_runtime_call - (runtime_call Js_runtime_modules.external_polyfill "resolve" [ str s ]) +let resolve_and_apply ?loc (s : string) (args : t list) : t = + call ?loc ~info:Js_call_info.builtin_runtime_call + (runtime_call ?loc Js_runtime_modules.external_polyfill "resolve" [ str s ]) args let make_exception ~loc (s : string) = diff --git a/jscomp/core/js_exp_make.mli b/jscomp/core/js_exp_make.mli index 0b7865238c..1576843dfe 100644 --- a/jscomp/core/js_exp_make.mli +++ b/jscomp/core/js_exp_make.mli @@ -70,10 +70,14 @@ val external_var : val ml_module_as_var : ?loc:Location.t -> ?comment:string -> Ident.t -> t val runtime_call : - string -> (* module_name *) - string -> (* fn_name *) - t list -> (* args *) - t + ?loc:Location.t -> + string -> + (* module_name *) + string -> + (* fn_name *) + t list -> + (* args *) + t val pure_runtime_call : ?loc:Location.t -> @@ -85,8 +89,11 @@ val pure_runtime_call : (* args *) t -val runtime_ref : string -> string -> t -val public_method_call : string -> t -> t -> Int32.t -> t list -> t +val runtime_ref : ?loc:Location.t -> string -> string -> t + +val public_method_call : + ?loc:Location.t -> string -> t -> t -> Int32.t -> t list -> t + val str : ?pure:bool -> ?loc:Location.t -> ?comment:string -> string -> t val unicode : ?loc:Location.t -> ?comment:string -> string -> t @@ -122,7 +129,7 @@ val zero_int_literal : t val zero_float_lit : t (* val obj_int_tag_literal : t *) -val is_out : ?comment:string -> t -> t -> t +val is_out : ?loc:Location.t -> ?comment:string -> t -> t -> t (** [is_out e range] is equivalent to [e > range or e <0] *) @@ -194,7 +201,7 @@ val to_int32 : ?loc:Location.t -> ?comment:string -> t -> t val to_uint32 : ?loc:Location.t -> ?comment:string -> t -> t val unchecked_int32_add : ?loc:Location.t -> ?comment:string -> t -> t -> t val int32_add : ?loc:Location.t -> ?comment:string -> t -> t -> t -val offset : t -> int -> t +val offset : ?loc:Location.t -> t -> int -> t val unchecked_int32_minus : ?loc:Location.t -> ?comment:string -> t -> t -> t val int32_minus : ?loc:Location.t -> ?comment:string -> t -> t -> t val int32_mul : ?loc:Location.t -> ?comment:string -> t -> t -> t @@ -254,7 +261,7 @@ val js_comp : t -> t -val not : t -> t +val not : ?loc:Location.t -> t -> t val call : ?loc:Location.t -> ?comment:string -> info:Js_call_info.t -> t -> t list -> t @@ -267,8 +274,8 @@ val new_ : val array : ?loc:Location.t -> ?comment:string -> J.mutable_flag -> J.expression list -> t -val optional_block : J.expression -> J.expression -val optional_not_nest_block : J.expression -> J.expression +val optional_block : ?loc:Location.t -> J.expression -> J.expression +val optional_not_nest_block : ?loc:Location.t -> J.expression -> J.expression val make_block : ?loc:Location.t -> @@ -320,5 +327,5 @@ val is_null : ?loc:Location.t -> ?comment:string -> t -> t val is_undef : ?loc:Location.t -> ?comment:string -> t -> t val for_sure_js_null_undefined : J.expression -> bool val is_null_undefined : ?loc:Location.t -> ?comment:string -> t -> t -val resolve_and_apply : string -> t list -> t +val resolve_and_apply : ?loc:Location.t -> string -> t list -> t val make_exception : loc:Location.t -> string -> t diff --git a/jscomp/core/js_long.ml b/jscomp/core/js_long.ml index 3ef76d2c30..1a142b1663 100644 --- a/jscomp/core/js_long.ml +++ b/jscomp/core/js_long.ml @@ -24,39 +24,40 @@ module E = Js_exp_make -type int64_call = J.expression list -> J.expression +type int64_call = ?loc:Location.t -> J.expression list -> J.expression -let int64_call (fn : string) args = - E.runtime_call Js_runtime_modules.int64 fn args +let int64_call ?loc (fn : string) args = + E.runtime_call ?loc Js_runtime_modules.int64 fn args (* below should not depend on layout *) -let of_const (v : Int64.t) = +let of_const ?loc (v : Int64.t) = match v with - | 0L -> E.runtime_var_dot Js_runtime_modules.int64 "zero" - | 1L -> E.runtime_var_dot Js_runtime_modules.int64 "one" - | -1L -> E.runtime_var_dot Js_runtime_modules.int64 "neg_one" - | 9223372036854775807L -> E.runtime_var_dot Js_runtime_modules.int64 "max_int" + | 0L -> E.runtime_var_dot ?loc Js_runtime_modules.int64 "zero" + | 1L -> E.runtime_var_dot ?loc Js_runtime_modules.int64 "one" + | -1L -> E.runtime_var_dot ?loc Js_runtime_modules.int64 "neg_one" + | 9223372036854775807L -> + E.runtime_var_dot ?loc Js_runtime_modules.int64 "max_int" | -9223372036854775808L -> - E.runtime_var_dot Js_runtime_modules.int64 "min_int" + E.runtime_var_dot ?loc Js_runtime_modules.int64 "min_int" | _ -> let unsigned_lo = E.uint32 (Int64.to_int32 v) in let hi = E.int (Int64.to_int32 (Int64.shift_right v 32)) in - E.array Immutable [ hi; unsigned_lo ] + E.array ?loc Immutable [ hi; unsigned_lo ] (* Assume the encoding of Int64 *) -let to_int32 args = int64_call "to_int32" args +let to_int32 ?loc args = int64_call ?loc "to_int32" args (* let get_lo x = E.array_index_by_int x 1l *) (* E.to_int32 @@ get_lo (Ext_list.singleton_exn args) *) -let of_int32 (args : J.expression list) = +let of_int32 ?loc (args : J.expression list) = match args with | [ { expression_desc = Number (Int { i }); _ } ] -> - of_const (Int64.of_int32 i) - | _ -> int64_call "of_int32" args + of_const ?loc (Int64.of_int32 i) + | _ -> int64_call ?loc "of_int32" args -let comp (cmp : Lam_compat.integer_comparison) args = - E.runtime_call Js_runtime_modules.caml_primitive +let comp (cmp : Lam_compat.integer_comparison) ?loc args = + E.runtime_call ?loc Js_runtime_modules.caml_primitive (match cmp with | Ceq -> "i64_eq" | Cne -> "i64_neq" @@ -66,20 +67,24 @@ let comp (cmp : Lam_compat.integer_comparison) args = | Cge -> "i64_ge") args -let min args = E.runtime_call Js_runtime_modules.caml_primitive "i64_min" args -let max args = E.runtime_call Js_runtime_modules.caml_primitive "i64_max" args -let neg args = int64_call "neg" args -let add args = int64_call "add" args -let sub args = int64_call "sub" args -let mul args = int64_call "mul" args -let div args = int64_call "div" args +let min ?loc args = + E.runtime_call ?loc Js_runtime_modules.caml_primitive "i64_min" args + +let max ?loc args = + E.runtime_call ?loc Js_runtime_modules.caml_primitive "i64_max" args + +let neg ?loc args = int64_call ?loc "neg" args +let add ?loc args = int64_call ?loc "add" args +let sub ?loc args = int64_call ?loc "sub" args +let mul ?loc args = int64_call ?loc "mul" args +let div ?loc args = int64_call ?loc "div" args (** Note if operands are not pure, we need hold shared value, which is a statement [var x = ... ; x ], it does not fit current pipe-line fall back to a function call *) -let bit_op (* op : E.t -> E.t -> E.t*) runtime_call args = - int64_call runtime_call args +let bit_op ?loc (* op : E.t -> E.t -> E.t*) runtime_call args = + int64_call ?loc runtime_call args (*disable optimizations relying on int64 representations this maybe outdated when we switch to bigint *) @@ -93,14 +98,14 @@ let bit_op (* op : E.t -> E.t -> E.t*) runtime_call args = else | _ -> assert false *) -let xor = bit_op "xor" -let or_ = bit_op "or_" -let and_ = bit_op "and_" -let lsl_ args = int64_call "lsl_" args -let lsr_ args = int64_call "lsr_" args -let asr_ args = int64_call "asr_" args -let mod_ args = int64_call "mod_" args -let swap args = int64_call "swap" args +let xor ?loc args = bit_op ?loc "xor" args +let or_ ?loc args = bit_op ?loc "or_" args +let and_ ?loc args = bit_op ?loc "and_" args +let lsl_ ?loc args = int64_call ?loc "lsl_" args +let lsr_ ?loc args = int64_call ?loc "lsr_" args +let asr_ ?loc args = int64_call ?loc "asr_" args +let mod_ ?loc args = int64_call ?loc "mod_" args +let swap ?loc args = int64_call ?loc "swap" args (* Safe constant propgation {[ @@ -114,19 +119,19 @@ let swap args = int64_call "swap" args Note that [Number._SAFE_INTEGER] is in ES6, we can hard code this number without bringing browser issue. *) -let of_float (args : J.expression list) = int64_call "of_float" args -let compare (args : J.expression list) = int64_call "compare" args +let of_float ?loc (args : J.expression list) = int64_call ?loc "of_float" args +let compare ?loc (args : J.expression list) = int64_call ?loc "compare" args (* let of_string (args : J.expression list) = int64_call "of_string" args *) (* let get64 = int64_call "get64" *) -let float_of_bits = int64_call "float_of_bits" -let bits_of_float = int64_call "bits_of_float" -let equal_null args = int64_call "equal_null" args -let equal_undefined args = int64_call "equal_undefined" args -let equal_nullable args = int64_call "equal_nullable" args +let float_of_bits ?loc args = int64_call ?loc "float_of_bits" args +let bits_of_float ?loc args = int64_call ?loc "bits_of_float" args +let equal_null ?loc args = int64_call ?loc "equal_null" args +let equal_undefined ?loc args = int64_call ?loc "equal_undefined" args +let equal_nullable ?loc args = int64_call ?loc "equal_nullable" args -let to_float (args : J.expression list) = +let to_float ?loc (args : J.expression list) = match args with (* | [ {expression_desc *) (* = Caml_block ( *) @@ -136,5 +141,5 @@ let to_float (args : J.expression list) = (* {expression_desc = Number (Int {i = hi; _}) }; *) (* ], _, _, _); _ }] *) (* -> *) - | [ _ ] -> int64_call "to_float" args + | [ _ ] -> int64_call ?loc "to_float" args | _ -> assert false diff --git a/jscomp/core/js_long.mli b/jscomp/core/js_long.mli index df89804320..de9ae84bb0 100644 --- a/jscomp/core/js_long.mli +++ b/jscomp/core/js_long.mli @@ -22,11 +22,11 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type int64_call = J.expression list -> J.expression +type int64_call = ?loc:Location.t -> J.expression list -> J.expression (* val make_const : lo:Int32.t -> hi:Int32.t -> J.expression *) -val of_const : int64 -> J.expression +val of_const : ?loc:Location.t -> int64 -> J.expression val to_int32 : int64_call val of_int32 : int64_call val comp : Lam_compat.integer_comparison -> int64_call diff --git a/jscomp/core/js_of_lam_array.ml b/jscomp/core/js_of_lam_array.ml index 99c7e7140f..83f246b6e6 100644 --- a/jscomp/core/js_of_lam_array.ml +++ b/jscomp/core/js_of_lam_array.ml @@ -1,5 +1,5 @@ (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -17,7 +17,7 @@ * 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. *) @@ -27,10 +27,10 @@ set array, ref array, - Also make sure, don't call any primitive array method, i.e [E.array_index_by_int] + Also make sure, don't call any primitive array method, i.e [E.array_index_by_int] - We also need check primitive [caml_make_vect], i.e, - [Caml_primitive['caml_make_vect']] see if it's correct + We also need check primitive [caml_make_vect], i.e, + [Caml_primitive['caml_make_vect']] see if it's correct [caml_make_vect] [caml_array_sub] @@ -47,6 +47,6 @@ module E = Js_exp_make (* Parrayref(u|s) *) -let make_array mt args = E.array mt args -let set_array e e0 e1 = E.assign (E.array_index e e0) e1 -let ref_array e e0 = E.array_index e e0 +let make_array ?loc mt args = E.array ?loc mt args +let set_array ?loc e e0 e1 = E.assign ?loc (E.array_index e e0) e1 +let ref_array ?loc e e0 = E.array_index ?loc e e0 diff --git a/jscomp/core/js_of_lam_array.mli b/jscomp/core/js_of_lam_array.mli index 9da46f92c7..7f6154ca82 100644 --- a/jscomp/core/js_of_lam_array.mli +++ b/jscomp/core/js_of_lam_array.mli @@ -1,5 +1,5 @@ (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -17,19 +17,25 @@ * 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. *) (** Utilities for creating Array of JS IR *) -val make_array : J.mutable_flag -> J.expression list -> J.expression +val make_array : + ?loc:Location.t -> J.mutable_flag -> J.expression list -> J.expression (** create an array *) -val set_array : J.expression -> J.expression -> J.expression -> J.expression -(** Here we don't care about [array_kind], +val set_array : + ?loc:Location.t -> + J.expression -> + J.expression -> + J.expression -> + J.expression +(** Here we don't care about [array_kind], In the future, we might used TypedArray for FloatArray *) -val ref_array : J.expression -> J.expression -> J.expression +val ref_array : ?loc:Location.t -> J.expression -> J.expression -> J.expression diff --git a/jscomp/core/js_of_lam_block.ml b/jscomp/core/js_of_lam_block.ml index 042f36fef6..a55c334b33 100644 --- a/jscomp/core/js_of_lam_block.ml +++ b/jscomp/core/js_of_lam_block.ml @@ -40,10 +40,10 @@ let make_block ?loc mutable_flag (tag_info : Lam_tag_info.t) tag args = (* (E.int ?comment:(Lam_compile_util.comment_of_tag_info tag_info) tag *) (* :: args) *) -let field (field_info : Lam_compat.field_dbg_info) e (i : int32) = +let field ?loc (field_info : Lam_compat.field_dbg_info) e (i : int32) = match field_info with | Fld_na _ | Fld_tuple | Fld_array -> - E.array_index_by_int + E.array_index_by_int ?loc ?comment:(Lam_compat.str_of_field_info field_info) e i | Fld_poly_var_content -> E.poly_var_value_access e @@ -58,9 +58,9 @@ let field (field_info : Lam_compat.field_dbg_info) e (i : int32) = let field_by_exp e i = E.array_index e i -let set_field (field_info : Lam_compat.set_field_dbg_info) e i e0 = +let set_field ?loc (field_info : Lam_compat.set_field_dbg_info) e i e0 = match field_info with - | Fld_set_na -> E.assign_by_int e i e0 + | Fld_set_na -> E.assign_by_int ?loc e i e0 | Fld_record_extension_set name -> E.extension_assign e i name e0 | Fld_record_inline_set name | Fld_record_set name -> E.record_assign e i name e0 diff --git a/jscomp/core/js_of_lam_block.mli b/jscomp/core/js_of_lam_block.mli index f3022a449e..d86c321966 100644 --- a/jscomp/core/js_of_lam_block.mli +++ b/jscomp/core/js_of_lam_block.mli @@ -32,10 +32,17 @@ val make_block : J.expression list -> J.expression -val field : Lam_compat.field_dbg_info -> J.expression -> int32 -> J.expression +val field : + ?loc:Location.t -> + Lam_compat.field_dbg_info -> + J.expression -> + int32 -> + J.expression + val field_by_exp : J.expression -> J.expression -> J.expression val set_field : + ?loc:Location.t -> Lam_compat.set_field_dbg_info -> J.expression -> int32 -> diff --git a/jscomp/core/js_of_lam_option.ml b/jscomp/core/js_of_lam_option.ml index 3198bd2136..ebf2dbf21d 100644 --- a/jscomp/core/js_of_lam_option.ml +++ b/jscomp/core/js_of_lam_option.ml @@ -1,5 +1,5 @@ (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -17,7 +17,7 @@ * 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. *) @@ -26,7 +26,7 @@ module E = Js_exp_make type option_unwrap_time = Static_unwrapped | Runtime_maybe_unwrapped -(** Another way: +(** Another way: {[ | Var _ -> can only bd detected at runtime thing @@ -38,35 +38,36 @@ let none : J.expression = E.undefined let is_none_static (arg : J.expression_desc) = arg = Undefined -let is_not_none (e : J.expression) : J.expression = +let is_not_none ?loc (e : J.expression) : J.expression = let desc = e.expression_desc in if is_none_static desc then E.false_ else match desc with | Optional_block _ -> E.true_ - | _ -> E.not (E.triple_equal e none) + | _ -> E.not ?loc (E.triple_equal e none) (** - Invrariant: + Invrariant: - optional encoding - None encoding - when no argumet is supplied, [undefined] - if we detect that all rest arguments are [null], + when no argumet is supplied, [undefined] + if we detect that all rest arguments are [null], we can remove them - avoid duplicate evlauation of [arg] when it is not a variable - {!Js_ast_util.named_expression} does not help + {!Js_ast_util.named_expression} does not help since we need an expression here, it might be a statement *) -let val_from_option (arg : J.expression) = +let val_from_option ?loc (arg : J.expression) = match arg.expression_desc with | Optional_block (x, _) -> x - | _ -> E.runtime_call Js_runtime_modules.option "valFromOption" [ arg ] + | _ -> E.runtime_call ?loc Js_runtime_modules.option "valFromOption" [ arg ] -let get_default_undefined_from_optional (arg : J.expression) : J.expression = +let get_default_undefined_from_optional ?loc (arg : J.expression) : J.expression + = let desc = arg.expression_desc in if is_none_static desc then E.undefined else @@ -75,17 +76,17 @@ let get_default_undefined_from_optional (arg : J.expression) : J.expression = | _ -> if Js_analyzer.is_okay_to_duplicate arg then (* FIXME: no need do such inlining*) - E.econd (is_not_none arg) (val_from_option arg) E.undefined - else E.runtime_call Js_runtime_modules.option "option_get" [ arg ] + E.econd ?loc (is_not_none arg) (val_from_option arg) E.undefined + else E.runtime_call ?loc Js_runtime_modules.option "option_get" [ arg ] -let option_unwrap (arg : J.expression) : J.expression = +let option_unwrap ?loc (arg : J.expression) : J.expression = let desc = arg.expression_desc in if is_none_static desc then E.undefined else match desc with | Optional_block (x, _) -> E.poly_var_value_access x (* invariant: option encoding *) - | _ -> E.runtime_call Js_runtime_modules.option "option_unwrap" [ arg ] + | _ -> E.runtime_call ?loc Js_runtime_modules.option "option_unwrap" [ arg ] let destruct_optional ~for_sure_none ~for_sure_some ~not_sure (arg : J.expression) = @@ -97,6 +98,8 @@ let destruct_optional ~for_sure_none ~for_sure_some ~not_sure | _ -> not_sure () let some = E.optional_block -let null_to_opt e = E.econd (E.is_null e) none (some e) -let undef_to_opt e = E.econd (E.is_undef e) none (some e) -let null_undef_to_opt e = E.econd (E.is_null_undefined e) none (some e) +let null_to_opt ?loc e = E.econd ?loc (E.is_null e) none (some e) +let undef_to_opt ?loc e = E.econd ?loc (E.is_undef e) none (some e) + +let null_undef_to_opt ?loc e = + E.econd ?loc (E.is_null_undefined e) none (some e) diff --git a/jscomp/core/js_of_lam_option.mli b/jscomp/core/js_of_lam_option.mli index 059b289025..d127314ca0 100644 --- a/jscomp/core/js_of_lam_option.mli +++ b/jscomp/core/js_of_lam_option.mli @@ -1,5 +1,5 @@ (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -17,21 +17,22 @@ * 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. *) type option_unwrap_time = Static_unwrapped | Runtime_maybe_unwrapped -val val_from_option : J.expression -> J.expression +val val_from_option : ?loc:Location.t -> J.expression -> J.expression (** Given [Some a ], return [a] *) -val get_default_undefined_from_optional : J.expression -> J.expression +val get_default_undefined_from_optional : + ?loc:Location.t -> J.expression -> J.expression (** Given [Some x] or [None], return [x]*) -val option_unwrap : J.expression -> J.expression -(** Given [Some (`a x)] or [None], +val option_unwrap : ?loc:Location.t -> J.expression -> J.expression +(** Given [Some (`a x)] or [None], return [x] *) val destruct_optional : @@ -41,8 +42,8 @@ val destruct_optional : J.expression -> 'a -val some : J.expression -> J.expression -val is_not_none : J.expression -> J.expression -val null_to_opt : J.expression -> J.expression -val undef_to_opt : J.expression -> J.expression -val null_undef_to_opt : J.expression -> J.expression +val some : ?loc:Location.t -> J.expression -> J.expression +val is_not_none : ?loc:Location.t -> J.expression -> J.expression +val null_to_opt : ?loc:Location.t -> J.expression -> J.expression +val undef_to_opt : ?loc:Location.t -> J.expression -> J.expression +val null_undef_to_opt : ?loc:Location.t -> J.expression -> J.expression diff --git a/jscomp/core/js_of_lam_string.ml b/jscomp/core/js_of_lam_string.ml index a64bfad9c6..e31d3a0f29 100644 --- a/jscomp/core/js_of_lam_string.ml +++ b/jscomp/core/js_of_lam_string.ml @@ -1,5 +1,5 @@ (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -17,7 +17,7 @@ * 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. *) @@ -34,35 +34,35 @@ let caml_char_of_int (v : J.expression) = v let caml_char_to_int v = v (* string [s[i]] expects to return a [ocaml_char] *) -let ref_string e e1 = E.char_to_int (E.string_index e e1) +let ref_string ?loc e e1 = E.char_to_int ?loc (E.string_index e e1) (* [s[i]] excepts to return a [ocaml_char] We use normal array for [bytes] TODO: we can use [Buffer] in the future *) -let ref_byte e e0 = E.array_index e e0 +let ref_byte ?loc e e0 = E.array_index ?loc e e0 (* {Bytes.set : bytes -> int -> char -> unit }*) -let set_byte e e0 e1 = E.assign (E.array_index e e0) e1 +let set_byte ?loc e e0 e1 = E.assign ?loc (E.array_index e e0) e1 (** - Note that [String.fromCharCode] also works, but it only - work for small arrays, however, for {bytes_to_string} it is likely the bytes + Note that [String.fromCharCode] also works, but it only + work for small arrays, however, for {bytes_to_string} it is likely the bytes will become big {[ String.fromCharCode.apply(null,[87,97]) "Wa" String.fromCharCode(87,97) - "Wa" + "Wa" ]} This does not work for large arrays {[ - String.fromCharCode.apply(null, prim = Array[1048576]) + String.fromCharCode.apply(null, prim = Array[1048576]) Maxiume call stack size exceeded ]} *) -let bytes_to_string e = - E.runtime_call Js_runtime_modules.bytes "bytes_to_string" [ e ] +let bytes_to_string ?loc e = + E.runtime_call ?loc Js_runtime_modules.bytes "bytes_to_string" [ e ] -let bytes_of_string s = - E.runtime_call Js_runtime_modules.bytes "bytes_of_string" [ s ] +let bytes_of_string ?loc s = + E.runtime_call ?loc Js_runtime_modules.bytes "bytes_of_string" [ s ] diff --git a/jscomp/core/js_of_lam_string.mli b/jscomp/core/js_of_lam_string.mli index ca2aa3fd2e..24e4bee1b4 100644 --- a/jscomp/core/js_of_lam_string.mli +++ b/jscomp/core/js_of_lam_string.mli @@ -1,5 +1,5 @@ (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -17,22 +17,29 @@ * 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. *) -(** Utilities to wrap [string] and [bytes] compilation, +(** Utilities to wrap [string] and [bytes] compilation, this is isolated, so that we can swap different representation in the future. [string] is Immutable, so there is not [set_string] method *) -val ref_string : J.expression -> J.expression -> J.expression -val ref_byte : J.expression -> J.expression -> J.expression -val set_byte : J.expression -> J.expression -> J.expression -> J.expression +val ref_string : ?loc:Location.t -> J.expression -> J.expression -> J.expression +val ref_byte : ?loc:Location.t -> J.expression -> J.expression -> J.expression + +val set_byte : + ?loc:Location.t -> + J.expression -> + J.expression -> + J.expression -> + J.expression + val caml_char_of_int : J.expression -> J.expression val caml_char_to_int : J.expression -> J.expression val const_char : char -> J.expression -val bytes_to_string : J.expression -> J.expression -val bytes_of_string : J.expression -> J.expression +val bytes_to_string : ?loc:Location.t -> J.expression -> J.expression +val bytes_of_string : ?loc:Location.t -> J.expression -> J.expression diff --git a/jscomp/core/lam_compile_primitive.ml b/jscomp/core/lam_compile_primitive.ml index 7311cc200b..7b1bc4c4f7 100644 --- a/jscomp/core/lam_compile_primitive.ml +++ b/jscomp/core/lam_compile_primitive.ml @@ -40,61 +40,69 @@ let translate loc (cxt : Lam_compile_context.t) (prim : Lam_primitive.t) (args : J.expression list) : J.expression = match prim with | Pis_not_none -> - Js_of_lam_option.is_not_none + Js_of_lam_option.is_not_none ~loc { (Ext_list.singleton_exn args) with loc = Some loc } | Pcreate_extension s -> E.make_exception ~loc s | Pwrap_exn -> - E.runtime_call Js_runtime_modules.caml_js_exceptions + E.runtime_call ~loc Js_runtime_modules.caml_js_exceptions "internalToOCamlException" args | Praw_js_code { code; code_info } -> - E.raw_js_code code_info code + E.raw_js_code ~loc code_info code (* FIXME: save one allocation trim can not be done before syntax checking otherwise location is incorrect *) | Pjs_runtime_apply -> ( - match args with [ f; args ] -> E.flat_call f args | _ -> assert false) + match args with + | [ f; args ] -> E.flat_call ~loc f args + | _ -> assert false) | Pjs_apply -> ( match args with - | fn :: rest -> E.call ~info:{ arity = Full; call_info = Call_na } fn rest + | fn :: rest -> + E.call ~loc ~info:{ arity = Full; call_info = Call_na } fn rest | _ -> assert false) | Pnull_to_opt -> ( match args with | [ e ] -> ( match e.expression_desc with - | Var _ | Undefined | Null -> Js_of_lam_option.null_to_opt e - | _ -> E.runtime_call Js_runtime_modules.option "null_to_opt" args) + | Var _ | Undefined | Null -> Js_of_lam_option.null_to_opt ~loc e + | _ -> + E.runtime_call ~loc Js_runtime_modules.option "null_to_opt" args) | _ -> assert false) | Pundefined_to_opt -> ( match args with | [ e ] -> ( match e.expression_desc with - | Var _ | Undefined | Null -> Js_of_lam_option.undef_to_opt e + | Var _ | Undefined | Null -> Js_of_lam_option.undef_to_opt ~loc e | _ -> - E.runtime_call Js_runtime_modules.option "undefined_to_opt" args) + E.runtime_call ~loc Js_runtime_modules.option "undefined_to_opt" + args) | _ -> assert false) | Pnull_undefined_to_opt -> ( match args with | [ e ] -> ( match e.expression_desc with - | Var _ | Undefined | Null -> Js_of_lam_option.null_undef_to_opt e - | _ -> E.runtime_call Js_runtime_modules.option "nullable_to_opt" args - ) + | Var _ | Undefined | Null -> + Js_of_lam_option.null_undef_to_opt ~loc e + | _ -> + E.runtime_call ~loc Js_runtime_modules.option "nullable_to_opt" + args) | _ -> assert false) - | Pjs_function_length -> E.function_length (Ext_list.singleton_exn args) - | Pcaml_obj_length -> E.obj_length (Ext_list.singleton_exn args) - | Pis_null -> E.is_null (Ext_list.singleton_exn args) - | Pis_undefined -> E.is_undef (Ext_list.singleton_exn args) - | Pis_null_undefined -> E.is_null_undefined (Ext_list.singleton_exn args) - | Pjs_typeof -> E.typeof (Ext_list.singleton_exn args) + | Pjs_function_length -> E.function_length ~loc (Ext_list.singleton_exn args) + | Pcaml_obj_length -> E.obj_length ~loc (Ext_list.singleton_exn args) + | Pis_null -> E.is_null ~loc (Ext_list.singleton_exn args) + | Pis_undefined -> E.is_undef ~loc (Ext_list.singleton_exn args) + | Pis_null_undefined -> E.is_null_undefined ~loc (Ext_list.singleton_exn args) + | Pjs_typeof -> E.typeof ~loc (Ext_list.singleton_exn args) | Pjs_unsafe_downgrade _ | Pdebugger | Pvoid_run | Pfull_apply | Pjs_fn_make _ -> assert false (* already handled by {!Lam_compile} *) | Pjs_fn_method -> assert false | Pstringadd -> ( - match args with [ a; b ] -> E.string_append a b | _ -> assert false) - | Pinit_mod -> E.runtime_call Js_runtime_modules.module_ "init_mod" args - | Pupdate_mod -> E.runtime_call Js_runtime_modules.module_ "update_mod" args + match args with [ a; b ] -> E.string_append ~loc a b | _ -> assert false) + | Pinit_mod -> E.runtime_call ~loc Js_runtime_modules.module_ "init_mod" args + | Pupdate_mod -> + E.runtime_call ~loc Js_runtime_modules.module_ "update_mod" args | Psome -> ( let arg = Ext_list.singleton_exn args in match arg.expression_desc with @@ -103,16 +111,17 @@ let translate loc (cxt : Lam_compile_context.t) (prim : Lam_primitive.t) is not available at the definition site, and inline recovered it *) - E.optional_not_nest_block arg - | _ -> E.optional_block arg) - | Psome_not_nest -> E.optional_not_nest_block (Ext_list.singleton_exn args) + E.optional_not_nest_block ~loc arg + | _ -> E.optional_block ~loc arg) + | Psome_not_nest -> + E.optional_not_nest_block ~loc (Ext_list.singleton_exn args) | Pmakeblock (tag, tag_info, mutable_flag) -> (* RUNTIME *) Js_of_lam_block.make_block ~loc (Js_op_util.of_lam_mutable_flag mutable_flag) tag_info (E.small_int tag) args | Pval_from_option -> - Js_of_lam_option.val_from_option (Ext_list.singleton_exn args) + Js_of_lam_option.val_from_option ~loc (Ext_list.singleton_exn args) | Pval_from_option_not_nest -> Ext_list.singleton_exn args | Pfield (i, fld_info) -> Js_of_lam_block.field fld_info @@ -125,94 +134,109 @@ let translate loc (cxt : Lam_compile_context.t) (prim : Lam_primitive.t) | _ -> assert false (* Negate boxed int *)) | Pnegint -> (* #977 *) - E.int32_minus E.zero_int_literal (Ext_list.singleton_exn args) - | Pnegint64 -> Js_long.neg args - | Pnegfloat -> E.float_minus E.zero_float_lit (Ext_list.singleton_exn args) + E.int32_minus ~loc E.zero_int_literal (Ext_list.singleton_exn args) + | Pnegint64 -> Js_long.neg ~loc args + | Pnegfloat -> + E.float_minus ~loc E.zero_float_lit (Ext_list.singleton_exn args) (* Negate boxed int end*) (* Int addition and subtraction *) | Paddint -> ( match args with [ e1; e2 ] -> E.int32_add ~loc e1 e2 | _ -> assert false) - | Paddint64 -> Js_long.add args + | Paddint64 -> Js_long.add ~loc args | Paddfloat -> ( - match args with [ e1; e2 ] -> E.float_add e1 e2 | _ -> assert false) + match args with [ e1; e2 ] -> E.float_add ~loc e1 e2 | _ -> assert false) | Psubint -> ( - match args with [ e1; e2 ] -> E.int32_minus e1 e2 | _ -> assert false) - | Psubint64 -> Js_long.sub args + match args with + | [ e1; e2 ] -> E.int32_minus ~loc e1 e2 + | _ -> assert false) + | Psubint64 -> Js_long.sub ~loc args | Psubfloat -> ( - match args with [ e1; e2 ] -> E.float_minus e1 e2 | _ -> assert false) + match args with + | [ e1; e2 ] -> E.float_minus ~loc e1 e2 + | _ -> assert false) | Pmulint -> ( - match args with [ e1; e2 ] -> E.int32_mul e1 e2 | _ -> assert false) - | Pmulint64 -> Js_long.mul args + match args with [ e1; e2 ] -> E.int32_mul ~loc e1 e2 | _ -> assert false) + | Pmulint64 -> Js_long.mul ~loc args | Pmulfloat -> ( - match args with [ e1; e2 ] -> E.float_mul e1 e2 | _ -> assert false) + match args with [ e1; e2 ] -> E.float_mul ~loc e1 e2 | _ -> assert false) | Pdivfloat -> ( - match args with [ e1; e2 ] -> E.float_div e1 e2 | _ -> assert false) + match args with [ e1; e2 ] -> E.float_div ~loc e1 e2 | _ -> assert false) | Pdivint -> ( match args with - | [ e1; e2 ] -> E.int32_div ~checked:!Js_config.check_div_by_zero e1 e2 + | [ e1; e2 ] -> + E.int32_div ~loc ~checked:!Js_config.check_div_by_zero e1 e2 | _ -> assert false) - | Pdivint64 -> Js_long.div args + | Pdivint64 -> Js_long.div ~loc args | Pmodint -> ( match args with - | [ e1; e2 ] -> E.int32_mod ~checked:!Js_config.check_div_by_zero e1 e2 + | [ e1; e2 ] -> + E.int32_mod ~loc ~checked:!Js_config.check_div_by_zero e1 e2 | _ -> assert false) - | Pmodint64 -> Js_long.mod_ args + | Pmodint64 -> Js_long.mod_ ~loc args | Plslint -> ( - match args with [ e1; e2 ] -> E.int32_lsl e1 e2 | _ -> assert false) - | Plslint64 -> Js_long.lsl_ args + match args with [ e1; e2 ] -> E.int32_lsl ~loc e1 e2 | _ -> assert false) + | Plslint64 -> Js_long.lsl_ ~loc args | Plsrint -> ( match args with | [ e1; { J.expression_desc = Number (Int { i = 0l; _ } | Uint 0l); _ } ] -> e1 - | [ e1; e2 ] -> E.to_int32 @@ E.int32_lsr e1 e2 + | [ e1; e2 ] -> E.to_int32 ~loc (E.int32_lsr ~loc e1 e2) | _ -> assert false) - | Plsrint64 -> Js_long.lsr_ args + | Plsrint64 -> Js_long.lsr_ ~loc args | Pasrint -> ( - match args with [ e1; e2 ] -> E.int32_asr e1 e2 | _ -> assert false) - | Pasrint64 -> Js_long.asr_ args + match args with [ e1; e2 ] -> E.int32_asr ~loc e1 e2 | _ -> assert false) + | Pasrint64 -> Js_long.asr_ ~loc args | Pandint -> ( - match args with [ e1; e2 ] -> E.int32_band e1 e2 | _ -> assert false) - | Pandint64 -> Js_long.and_ args + match args with + | [ e1; e2 ] -> E.int32_band ~loc e1 e2 + | _ -> assert false) + | Pandint64 -> Js_long.and_ ~loc args | Porint -> ( match args with [ e1; e2 ] -> E.int32_bor ~loc e1 e2 | _ -> assert false) - | Porint64 -> Js_long.or_ args + | Porint64 -> Js_long.or_ ~loc args | Pxorint -> ( - match args with [ e1; e2 ] -> E.int32_bxor e1 e2 | _ -> assert false) - | Pxorint64 -> Js_long.xor args + match args with + | [ e1; e2 ] -> E.int32_bxor ~loc e1 e2 + | _ -> assert false) + | Pxorint64 -> Js_long.xor ~loc args | Pjscomp cmp -> ( - match args with [ l; r ] -> E.js_comp cmp l r | _ -> assert false) + match args with [ l; r ] -> E.js_comp ~loc cmp l r | _ -> assert false) | Pfloatcomp cmp -> ( - match args with [ e1; e2 ] -> E.float_comp cmp e1 e2 | _ -> assert false) + match args with + | [ e1; e2 ] -> E.float_comp ~loc cmp e1 e2 + | _ -> assert false) | Pintcomp cmp -> ( (* Global Builtin Exception is an int, like [Not_found] or [Invalid_argument] ? *) - match args with [ e1; e2 ] -> E.int_comp cmp e1 e2 | _ -> assert false) + match args with + | [ e1; e2 ] -> E.int_comp ~loc cmp e1 e2 + | _ -> assert false) (* List --> stamp = 0 Assert_false --> stamp = 26 *) - | Pint64comp cmp -> Js_long.comp cmp args + | Pint64comp cmp -> Js_long.comp ~loc cmp args | Pintoffloat -> ( - match args with [ e ] -> E.to_int32 e | _ -> assert false) - | Pint64ofint -> Js_long.of_int32 args + match args with [ e ] -> E.to_int32 ~loc e | _ -> assert false) + | Pint64ofint -> Js_long.of_int32 ~loc args | Pfloatofint -> Ext_list.singleton_exn args - | Pintofint64 -> Js_long.to_int32 args - | Pnot -> E.not (Ext_list.singleton_exn args) - | Poffsetint n -> E.offset (Ext_list.singleton_exn args) n + | Pintofint64 -> Js_long.to_int32 ~loc args + | Pnot -> E.not ~loc (Ext_list.singleton_exn args) + | Poffsetint n -> E.offset ~loc (Ext_list.singleton_exn args) n | Poffsetref n -> let v = - Js_of_lam_block.field Lambda.ref_field_info + Js_of_lam_block.field ~loc Lambda.ref_field_info (Ext_list.singleton_exn args) 0l in E.seq (E.assign v (E.offset v n)) E.unit | Psequand -> ( (* TODO: rhs is possibly a tail call *) - match args with [ e1; e2 ] -> E.and_ e1 e2 | _ -> assert false) + match args with [ e1; e2 ] -> E.and_ ~loc e1 e2 | _ -> assert false) | Psequor -> ( (* TODO: rhs is possibly a tail call *) - match args with [ e1; e2 ] -> E.or_ e1 e2 | _ -> assert false) + match args with [ e1; e2 ] -> E.or_ ~loc e1 e2 | _ -> assert false) | Pisout off -> ( match args with (* predicate: [x > range or x < 0 ] @@ -225,33 +249,34 @@ let translate loc (cxt : Lam_compile_context.t) (prim : Lam_primitive.t) a normal case of the compiler is that it will do a shift in the first step [ (x - 1) > 1 or ( x - 1 ) < 0 ] *) - | [ range; e ] -> E.is_out (E.offset e off) range + | [ range; e ] -> E.is_out ~loc (E.offset e off) range | _ -> assert false) | Pbytes_of_string -> (* TODO: write a js primitive - or is it necessary ? if we have byte_get/string_get still necessary, since you can set it now. *) - Js_of_lam_string.bytes_of_string (Ext_list.singleton_exn args) + Js_of_lam_string.bytes_of_string ~loc (Ext_list.singleton_exn args) | Pbytes_to_string -> - Js_of_lam_string.bytes_to_string (Ext_list.singleton_exn args) - | Pstringlength -> E.string_length (Ext_list.singleton_exn args) - | Pbyteslength -> E.bytes_length (Ext_list.singleton_exn args) + Js_of_lam_string.bytes_to_string ~loc (Ext_list.singleton_exn args) + | Pstringlength -> E.string_length ~loc (Ext_list.singleton_exn args) + | Pbyteslength -> E.bytes_length ~loc (Ext_list.singleton_exn args) (* This should only be Pbyteset(u|s), which in js, is an int array Bytes is an int array in javascript *) | Pbytessetu -> ( match args with | [ e; e0; e1 ] -> - ensure_value_unit cxt.continuation (Js_of_lam_string.set_byte e e0 e1) + ensure_value_unit cxt.continuation + (Js_of_lam_string.set_byte ~loc e e0 e1) | _ -> assert false) - | Pbytessets -> E.runtime_call Js_runtime_modules.bytes "set" args + | Pbytessets -> E.runtime_call ~loc Js_runtime_modules.bytes "set" args | Pbytesrefu -> ( match args with - | [ e; e1 ] -> Js_of_lam_string.ref_byte e e1 + | [ e; e1 ] -> Js_of_lam_string.ref_byte ~loc e e1 | _ -> assert false) - | Pbytesrefs -> E.runtime_call Js_runtime_modules.bytes "get" args - | Pstringrefs -> E.runtime_call Js_runtime_modules.string "get" args + | Pbytesrefs -> E.runtime_call ~loc Js_runtime_modules.bytes "get" args + | Pstringrefs -> E.runtime_call ~loc Js_runtime_modules.string "get" args (* For bytes and string, they both return [int] in ocaml we need tell Pbyteref from Pstringref 1. Pbyteref -> a[i] @@ -259,18 +284,18 @@ let translate loc (cxt : Lam_compile_context.t) (prim : Lam_primitive.t) *) | Pstringrefu -> ( match args with - | [ e; e1 ] -> Js_of_lam_string.ref_string e e1 + | [ e; e1 ] -> Js_of_lam_string.ref_string ~loc e e1 | _ -> assert false) (* only when Lapply -> expand = true*) | Praise -> assert false (* handled before here *) (* Runtime encoding relevant *) - | Parraylength -> E.array_length (Ext_list.singleton_exn args) + | Parraylength -> E.array_length ~loc (Ext_list.singleton_exn args) | Psetfield (i, field_info) -> ( match args with | [ e0; e1 ] -> (* RUNTIME *) ensure_value_unit cxt.continuation - (Js_of_lam_block.set_field field_info e0 (Int32.of_int i) e1) + (Js_of_lam_block.set_field ~loc field_info e0 (Int32.of_int i) e1) (*TODO: get rid of [E.unit ()]*) | _ -> assert false) | Psetfield_computed -> ( @@ -281,37 +306,39 @@ let translate loc (cxt : Lam_compile_context.t) (prim : Lam_primitive.t) | _ -> assert false) | Parrayrefu -> ( match args with - | [ e; e1 ] -> Js_of_lam_array.ref_array e e1 (* Todo: Constant Folding *) + | [ e; e1 ] -> + Js_of_lam_array.ref_array ~loc e e1 (* Todo: Constant Folding *) | _ -> assert false) - | Parrayrefs -> E.runtime_call Js_runtime_modules.array "get" args - | Parraysets -> E.runtime_call Js_runtime_modules.array "set" args - | Pmakearray -> Js_of_lam_array.make_array Mutable args + | Parrayrefs -> E.runtime_call ~loc Js_runtime_modules.array "get" args + | Parraysets -> E.runtime_call ~loc Js_runtime_modules.array "set" args + | Pmakearray -> Js_of_lam_array.make_array ~loc Mutable args | Parraysetu -> ( match args with (* wrong*) | [ e; e0; e1 ] -> - ensure_value_unit cxt.continuation (Js_of_lam_array.set_array e e0 e1) + ensure_value_unit cxt.continuation + (Js_of_lam_array.set_array ~loc e e0 e1) | _ -> assert false) - | Pccall prim -> Lam_dispatch_primitive.translate loc prim.prim_name args + | Pccall prim -> Lam_dispatch_primitive.translate ~loc prim.prim_name args (* Lam_compile_external_call.translate loc cxt prim args *) (* Test if the argument is a block or an immediate integer *) | Pjs_object_create _ -> assert false | Pjs_call { arg_types; ffi } -> Lam_compile_external_call.translate_ffi cxt ~loc arg_types ffi args (* FIXME, this can be removed later *) - | Pisint -> E.is_type_number (Ext_list.singleton_exn args) - | Pis_poly_var_const -> E.is_type_string (Ext_list.singleton_exn args) + | Pisint -> E.is_type_number ~loc (Ext_list.singleton_exn args) + | Pis_poly_var_const -> E.is_type_string ~loc (Ext_list.singleton_exn args) | Pctconst ct -> ( match ct with | Big_endian -> E.bool Sys.big_endian - | Ostype -> E.runtime_call Js_runtime_modules.sys "os_type" args + | Ostype -> E.runtime_call ~loc Js_runtime_modules.sys "os_type" args | Ostype_unix -> - E.string_equal - (E.runtime_call Js_runtime_modules.sys "os_type" args) + E.string_equal ~loc + (E.runtime_call ~loc Js_runtime_modules.sys "os_type" args) (E.str "Unix") | Ostype_win32 -> - E.string_equal - (E.runtime_call Js_runtime_modules.sys "os_type" args) + E.string_equal ~loc + (E.runtime_call ~loc Js_runtime_modules.sys "os_type" args) (E.str "Win32") (* | Max_wosize -> (* max_array_length*) @@ -319,12 +346,12 @@ let translate loc (cxt : Lam_compile_context.t) (prim : Lam_primitive.t) (* 4_294_967_295l not representable*) (* 2 ^ 32 - 1*) | Backend_type -> - E.make_block E.zero_int_literal + E.make_block ~loc E.zero_int_literal (Blk_constructor { name = "Other"; num_nonconst = 1 }) [ E.str "BS" ] Immutable) | Pduprecord (Record_regular | Record_extension | Record_inlined _) -> - Lam_dispatch_primitive.translate loc "caml_obj_dup" args + Lam_dispatch_primitive.translate ~loc "caml_obj_dup" args | Plazyforce (* FIXME: we don't inline lazy force or at least let buckle handle it @@ -336,4 +363,4 @@ let translate loc (cxt : Lam_compile_context.t) (prim : Lam_primitive.t) (*we dont use [throw] here, since [throw] is an statement *) let s = Lam_print.primitive_to_string prim in Bs_warnings.warn_missing_primitive loc s; - E.resolve_and_apply s args + E.resolve_and_apply ~loc s args diff --git a/jscomp/core/lam_dispatch_primitive.ml b/jscomp/core/lam_dispatch_primitive.ml index 9fccb45986..ab4aabf0f0 100644 --- a/jscomp/core/lam_dispatch_primitive.ml +++ b/jscomp/core/lam_dispatch_primitive.ml @@ -51,32 +51,36 @@ let args_const_unbox_approx_int_two (args : J.expression list) = TODO: return type to be expression is ugly, we should allow return block *) -let translate loc (prim_name : string) (args : J.expression list) : J.expression - = - let[@inline] call m = E.runtime_call m prim_name args in +let translate ~loc (prim_name : string) (args : J.expression list) : + J.expression = + let[@inline] call m = E.runtime_call ~loc m prim_name args in match prim_name with | "caml_add_float" -> ( match args with - | [ e0; e1 ] -> E.float_add e0 e1 (* TODO float plus*) + | [ e0; e1 ] -> E.float_add ~loc e0 e1 (* TODO float plus*) | _ -> assert false) | "caml_div_float" -> ( - match args with [ e0; e1 ] -> E.float_div e0 e1 | _ -> assert false) + match args with [ e0; e1 ] -> E.float_div ~loc e0 e1 | _ -> assert false) | "caml_sub_float" -> ( - match args with [ e0; e1 ] -> E.float_minus e0 e1 | _ -> assert false) + match args with + | [ e0; e1 ] -> E.float_minus ~loc e0 e1 + | _ -> assert false) | "caml_eq_float" -> ( - match args with [ e0; e1 ] -> E.float_equal e0 e1 | _ -> assert false) + match args with + | [ e0; e1 ] -> E.float_equal ~loc e0 e1 + | _ -> assert false) | "caml_ge_float" -> ( match args with - | [ e0; e1 ] -> E.float_comp CFge e0 e1 + | [ e0; e1 ] -> E.float_comp ~loc CFge e0 e1 | _ -> assert false) | "caml_gt_float" -> ( match args with - | [ e0; e1 ] -> E.float_comp CFgt e0 e1 + | [ e0; e1 ] -> E.float_comp ~loc CFgt e0 e1 | _ -> assert false) | "caml_float_of_int" -> ( match args with [ e ] -> e | _ -> assert false) | "caml_int32_of_int" -> ( match args with [ e ] -> e | _ -> assert false) | "caml_int32_of_float" | "caml_int_of_float" -> ( - match args with [ e ] -> E.to_int32 e | _ -> assert false) + match args with [ e ] -> E.to_int32 ~loc e | _ -> assert false) | "caml_int32_to_float" | "caml_int32_to_int" -> ( match args with | [ e ] -> e (* TODO: do more checking when [to_int32]*) @@ -86,37 +90,45 @@ let translate loc (prim_name : string) (args : J.expression list) : J.expression call Js_runtime_modules.bytes | "caml_int64_succ" -> E.runtime_call Js_runtime_modules.int64 "succ" args | "caml_int64_to_string" -> - E.runtime_call Js_runtime_modules.int64 "to_string" args - | "caml_int64_equal_null" -> Js_long.equal_null args - | "caml_int64_equal_undefined" -> Js_long.equal_undefined args - | "caml_int64_equal_nullable" -> Js_long.equal_nullable args - | "caml_int64_to_float" -> Js_long.to_float args - | "caml_int64_of_float" -> Js_long.of_float args - | "caml_int64_compare" -> Js_long.compare args - | "caml_int64_bits_of_float" -> Js_long.bits_of_float args - | "caml_int64_float_of_bits" -> Js_long.float_of_bits args - | "caml_int64_bswap" -> Js_long.swap args - | "caml_int64_min" -> Js_long.min args - | "caml_int64_max" -> Js_long.max args + E.runtime_call ~loc Js_runtime_modules.int64 "to_string" args + | "caml_int64_equal_null" -> Js_long.equal_null ~loc args + | "caml_int64_equal_undefined" -> Js_long.equal_undefined ~loc args + | "caml_int64_equal_nullable" -> Js_long.equal_nullable ~loc args + | "caml_int64_to_float" -> Js_long.to_float ~loc args + | "caml_int64_of_float" -> Js_long.of_float ~loc args + | "caml_int64_compare" -> Js_long.compare ~loc args + | "caml_int64_bits_of_float" -> Js_long.bits_of_float ~loc args + | "caml_int64_float_of_bits" -> Js_long.float_of_bits ~loc args + | "caml_int64_bswap" -> Js_long.swap ~loc args + | "caml_int64_min" -> Js_long.min ~loc args + | "caml_int64_max" -> Js_long.max ~loc args | "caml_int32_float_of_bits" | "caml_int32_bits_of_float" | "caml_modf_float" | "caml_ldexp_float" | "caml_frexp_float" | "caml_copysign_float" | "caml_expm1_float" | "caml_hypot_float" -> call Js_runtime_modules.float | "caml_fmod_float" (* float module like js number module *) -> ( - match args with [ e0; e1 ] -> E.float_mod e0 e1 | _ -> assert false) + match args with [ e0; e1 ] -> E.float_mod ~loc e0 e1 | _ -> assert false) | "caml_string_equal" -> ( - match args with [ e0; e1 ] -> E.string_equal e0 e1 | _ -> assert false) + match args with + | [ e0; e1 ] -> E.string_equal ~loc e0 e1 + | _ -> assert false) | "caml_string_notequal" -> ( match args with - | [ e0; e1 ] -> E.string_comp NotEqEq e0 e1 + | [ e0; e1 ] -> E.string_comp ~loc NotEqEq e0 e1 (* TODO: convert to ocaml ones*) | _ -> assert false) | "caml_string_lessequal" -> ( - match args with [ e0; e1 ] -> E.string_comp Le e0 e1 | _ -> assert false) + match args with + | [ e0; e1 ] -> E.string_comp ~loc Le e0 e1 + | _ -> assert false) | "caml_string_lessthan" -> ( - match args with [ e0; e1 ] -> E.string_comp Lt e0 e1 | _ -> assert false) + match args with + | [ e0; e1 ] -> E.string_comp ~loc Lt e0 e1 + | _ -> assert false) | "caml_string_greaterequal" -> ( - match args with [ e0; e1 ] -> E.string_comp Ge e0 e1 | _ -> assert false) + match args with + | [ e0; e1 ] -> E.string_comp ~loc Ge e0 e1 + | _ -> assert false) | "caml_string_repeat" -> ( match args with | [ n; { expression_desc = Number (Int { i }) } ] -> ( @@ -124,41 +136,55 @@ let translate loc (prim_name : string) (args : J.expression list) : J.expression match n.expression_desc with | Number (Int { i = 1l }) -> E.str str | _ -> - E.call + E.call ~loc (E.dot (E.str str) "repeat") [ n ] ~info:Js_call_info.builtin_runtime_call) - | _ -> E.runtime_call Js_runtime_modules.string "make" args) + | _ -> E.runtime_call ~loc Js_runtime_modules.string "make" args) | "caml_string_greaterthan" -> ( - match args with [ e0; e1 ] -> E.string_comp Gt e0 e1 | _ -> assert false) + match args with + | [ e0; e1 ] -> E.string_comp ~loc Gt e0 e1 + | _ -> assert false) | "caml_bool_notequal" -> ( match args with - | [ e0; e1 ] -> E.bool_comp Cne e0 e1 + | [ e0; e1 ] -> E.bool_comp ~loc Cne e0 e1 (* TODO: specialized in OCaml ones*) | _ -> assert false) | "caml_bool_lessequal" -> ( - match args with [ e0; e1 ] -> E.bool_comp Cle e0 e1 | _ -> assert false) + match args with + | [ e0; e1 ] -> E.bool_comp ~loc Cle e0 e1 + | _ -> assert false) | "caml_bool_lessthan" -> ( - match args with [ e0; e1 ] -> E.bool_comp Clt e0 e1 | _ -> assert false) + match args with + | [ e0; e1 ] -> E.bool_comp ~loc Clt e0 e1 + | _ -> assert false) | "caml_bool_greaterequal" -> ( - match args with [ e0; e1 ] -> E.bool_comp Cge e0 e1 | _ -> assert false) + match args with + | [ e0; e1 ] -> E.bool_comp ~loc Cge e0 e1 + | _ -> assert false) | "caml_bool_greaterthan" -> ( - match args with [ e0; e1 ] -> E.bool_comp Cgt e0 e1 | _ -> assert false) + match args with + | [ e0; e1 ] -> E.bool_comp ~loc Cgt e0 e1 + | _ -> assert false) | "caml_bool_equal" | "caml_bool_equal_null" | "caml_bool_equal_nullable" | "caml_bool_equal_undefined" -> ( - match args with [ e0; e1 ] -> E.bool_comp Ceq e0 e1 | _ -> assert false) + match args with + | [ e0; e1 ] -> E.bool_comp ~loc Ceq e0 e1 + | _ -> assert false) | "caml_int_equal_null" | "caml_int_equal_nullable" | "caml_int_equal_undefined" | "caml_int32_equal_null" | "caml_int32_equal_nullable" | "caml_int32_equal_undefined" -> ( - match args with [ e0; e1 ] -> E.int_comp Ceq e0 e1 | _ -> assert false) + match args with + | [ e0; e1 ] -> E.int_comp ~loc Ceq e0 e1 + | _ -> assert false) | "caml_float_equal_null" | "caml_float_equal_nullable" | "caml_float_equal_undefined" -> ( match args with - | [ e0; e1 ] -> E.float_comp CFeq e0 e1 + | [ e0; e1 ] -> E.float_comp ~loc CFeq e0 e1 | _ -> assert false) | "caml_string_equal_null" | "caml_string_equal_nullable" | "caml_string_equal_undefined" -> ( match args with - | [ e0; e1 ] -> E.string_comp EqEqEq e0 e1 + | [ e0; e1 ] -> E.string_comp ~loc EqEqEq e0 e1 | _ -> assert false) | "caml_create_bytes" -> ( (* Bytes.create *) @@ -169,18 +195,20 @@ let translate loc (prim_name : string) (args : J.expression list) : J.expression match args with | [ { expression_desc = Number (Int { i; _ }); _ } ] when i < 8l -> (*Invariants: assuming bytes are [int array]*) - E.array NA + E.array ~loc NA (if i = 0l then [] else Ext_list.init (Int32.to_int i) (fun _ -> E.zero_int_literal)) - | _ -> E.runtime_call Js_runtime_modules.bytes "caml_create_bytes" args) + | _ -> + E.runtime_call ~loc Js_runtime_modules.bytes "caml_create_bytes" args) | "caml_bool_compare" -> ( match args with | [ { expression_desc = Bool a }; { expression_desc = Bool b } ] -> let c = compare (a : bool) b in - E.int (if c = 0 then 0l else if c > 0 then 1l else -1l) + E.int ~loc (if c = 0 then 0l else if c > 0 then 1l else -1l) | _ -> call Js_runtime_modules.caml_primitive) | "caml_int_compare" | "caml_int32_compare" -> - E.runtime_call Js_runtime_modules.caml_primitive "caml_int_compare" args + E.runtime_call ~loc Js_runtime_modules.caml_primitive "caml_int_compare" + args | "caml_float_compare" | "caml_string_compare" -> call Js_runtime_modules.caml_primitive | "caml_bool_min" | "caml_int_min" | "caml_float_min" | "caml_string_min" @@ -190,7 +218,7 @@ let translate loc (prim_name : string) (args : J.expression list) : J.expression if Js_analyzer.is_okay_to_duplicate a && Js_analyzer.is_okay_to_duplicate b - then E.econd (E.js_comp Clt a b) a b + then E.econd ~loc (E.js_comp Clt a b) a b else call Js_runtime_modules.caml_primitive | _ -> assert false) | "caml_bool_max" | "caml_int_max" | "caml_float_max" | "caml_string_max" @@ -200,10 +228,11 @@ let translate loc (prim_name : string) (args : J.expression list) : J.expression if Js_analyzer.is_okay_to_duplicate a && Js_analyzer.is_okay_to_duplicate b - then E.econd (E.js_comp Cgt a b) a b + then E.econd ~loc (E.js_comp Cgt a b) a b else call Js_runtime_modules.caml_primitive | _ -> assert false) - | "caml_string_get" -> E.runtime_call Js_runtime_modules.string "get" args + | "caml_string_get" -> + E.runtime_call ~loc Js_runtime_modules.string "get" args | "caml_fill_bytes" | "bytes_to_string" | "bytes_of_string" | "caml_blit_string" | "caml_blit_bytes" -> call Js_runtime_modules.bytes @@ -239,13 +268,15 @@ let translate loc (prim_name : string) (args : J.expression list) : J.expression call Js_runtime_modules.parser | "caml_make_float_vect" | "caml_floatarray_create" (* TODO: compile float array into TypedArray*) -> - E.runtime_call Js_runtime_modules.array "make_float" args - | "caml_array_sub" -> E.runtime_call Js_runtime_modules.array "sub" args - | "caml_array_concat" -> E.runtime_call Js_runtime_modules.array "concat" args + E.runtime_call ~loc Js_runtime_modules.array "make_float" args + | "caml_array_sub" -> E.runtime_call ~loc Js_runtime_modules.array "sub" args + | "caml_array_concat" -> + E.runtime_call ~loc Js_runtime_modules.array "concat" args (*external concat: 'a array list -> 'a array Not good for inline *) - | "caml_array_blit" -> E.runtime_call Js_runtime_modules.array "blit" args - | "caml_make_vect" -> E.runtime_call Js_runtime_modules.array "make" args + | "caml_array_blit" -> + E.runtime_call ~loc Js_runtime_modules.array "blit" args + | "caml_make_vect" -> E.runtime_call ~loc Js_runtime_modules.array "make" args | "caml_ml_flush" | "caml_ml_out_channels_list" | "caml_ml_output_char" | "caml_ml_output" -> call Js_runtime_modules.io @@ -259,7 +290,7 @@ let translate loc (prim_name : string) (args : J.expression list) : J.expression and discarded it immediately This could be canceled *) - | _ -> E.runtime_call Js_runtime_modules.array "dup" args) + | _ -> E.runtime_call ~loc Js_runtime_modules.array "dup" args) | _ -> assert false) | "caml_format_float" | "caml_hexstring_of_float" | "caml_nativeint_format" | "caml_int32_format" | "caml_float_of_string" @@ -275,7 +306,7 @@ let translate loc (prim_name : string) (args : J.expression list) : J.expression | [ a1; b1 ] when E.for_sure_js_null_undefined a1 || E.for_sure_js_null_undefined b1 -> - E.neq_null_undefined_boolean a1 b1 + E.neq_null_undefined_boolean ~loc a1 b1 (* FIXME address_equal *) | _ -> Location.prerr_warning loc Warnings.Bs_polymorphic_comparison; @@ -285,7 +316,7 @@ let translate loc (prim_name : string) (args : J.expression list) : J.expression | [ a1; b1 ] when E.for_sure_js_null_undefined a1 || E.for_sure_js_null_undefined b1 -> - E.eq_null_undefined_boolean a1 b1 (* FIXME address_equal *) + E.eq_null_undefined_boolean ~loc a1 b1 (* FIXME address_equal *) | _ -> Location.prerr_warning loc Warnings.Bs_polymorphic_comparison; call Js_runtime_modules.obj_runtime) @@ -298,40 +329,40 @@ let translate loc (prim_name : string) (args : J.expression list) : J.expression (* Note that in ocaml, [int] has tag [1000] and [string] has tag [252] also now we need do nullary check *) - match args with [ e ] -> E.tag e | _ -> assert false) + match args with [ e ] -> E.tag ~loc e | _ -> assert false) | "caml_get_public_method" -> call Js_runtime_modules.oo (* TODO: Primitives not implemented yet ...*) | "caml_install_signal_handler" -> ( match args with - | [ num; behavior ] -> E.seq num behavior (*TODO:*) + | [ num; behavior ] -> E.seq ~loc num behavior (*TODO:*) | _ -> assert false) | "caml_md5_string" -> call Js_runtime_modules.md5 | "caml_hash_mix_string" | "caml_hash_mix_int" | "caml_hash_final_mix" -> call Js_runtime_modules.hash_primitive | "caml_hash" -> call Js_runtime_modules.hash | "caml_ml_open_descriptor_in" when args_const_unbox_approx_int_zero args -> - E.runtime_ref Js_runtime_modules.io "stdin" + E.runtime_ref ~loc Js_runtime_modules.io "stdin" | "caml_ml_open_descriptor_out" when args_const_unbox_approx_int_one args -> - E.runtime_ref Js_runtime_modules.io "stdout" + E.runtime_ref ~loc Js_runtime_modules.io "stdout" | "caml_ml_open_descriptor_out" when args_const_unbox_approx_int_two args -> - E.runtime_ref Js_runtime_modules.io "stderr" + E.runtime_ref ~loc Js_runtime_modules.io "stderr" | "nativeint_add" -> ( match args with - | [ e1; e2 ] -> E.unchecked_int32_add e1 e2 + | [ e1; e2 ] -> E.unchecked_int32_add ~loc e1 e2 | _ -> assert false) | "nativeint_div" -> ( match args with - | [ e1; e2 ] -> E.int32_div e1 e2 ~checked:false + | [ e1; e2 ] -> E.int32_div ~loc e1 e2 ~checked:false | _ -> assert false) | "nativeint_mod" -> ( match args with - | [ e1; e2 ] -> E.int32_mod e1 e2 ~checked:false + | [ e1; e2 ] -> E.int32_mod ~loc e1 e2 ~checked:false | _ -> assert false) | "nativeint_lsr" -> ( - match args with [ e1; e2 ] -> E.int32_lsr e1 e2 | _ -> assert false) + match args with [ e1; e2 ] -> E.int32_lsr ~loc e1 e2 | _ -> assert false) | "nativeint_mul" -> ( match args with - | [ e1; e2 ] -> E.unchecked_int32_mul e1 e2 + | [ e1; e2 ] -> E.unchecked_int32_mul ~loc e1 e2 | _ -> assert false) | _ -> Bs_warnings.warn_missing_primitive loc prim_name; diff --git a/jscomp/core/lam_dispatch_primitive.mli b/jscomp/core/lam_dispatch_primitive.mli index ce463c7230..b093992743 100644 --- a/jscomp/core/lam_dispatch_primitive.mli +++ b/jscomp/core/lam_dispatch_primitive.mli @@ -1,5 +1,5 @@ (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -17,14 +17,14 @@ * 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. *) (** Compile lambda primitives (note this is different external c calls) *) -val translate : Location.t -> string -> J.expression list -> J.expression -(** +val translate : loc:Location.t -> string -> J.expression list -> J.expression +(** @return None when the primitives are not handled in pre-processing *) diff --git a/jscomp/core/lam_eta_conversion.ml b/jscomp/core/lam_eta_conversion.ml index 1b0a8fb8f5..c0b5c66b02 100644 --- a/jscomp/core/lam_eta_conversion.ml +++ b/jscomp/core/lam_eta_conversion.ml @@ -66,11 +66,15 @@ let transform_under_supply n ap_info fn args = Lam.function_ ~arity:n ~params:extra_args ~attr:Lambda.default_function_attribute ~body:(Lam.apply fn (Ext_list.append args extra_lambdas) ap_info) + (* TODO(anmonteiro): check this loc *) + ~loc:ap_info.ap_loc | fn :: args, bindings -> let rest : Lam.t = Lam.function_ ~arity:n ~params:extra_args ~attr:Lambda.default_function_attribute ~body:(Lam.apply fn (Ext_list.append args extra_lambdas) ap_info) + (* TODO(anmonteiro): check this loc *) + ~loc:ap_info.ap_loc in Ext_list.fold_left bindings rest (fun lam (id, x) -> Lam.let_ Strict id x lam) @@ -149,6 +153,8 @@ let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : Lam.function_ ~attr:Lambda.default_function_attribute ~arity:0 ~params:[] ~body:(Lam.apply new_fn [ Lam.unit ] ap_info) + (* TODO(anmonteiro): check this loc *) + ~loc in match wrapper with