diff --git a/bin/dune b/bin/dune index e2e7972dfe..51687091b6 100644 --- a/bin/dune +++ b/bin/dune @@ -4,7 +4,7 @@ (flags :standard -open Melange_compiler_libs) (libraries js_parser - ext + melstd melange_compiler_libs melange_ffi melangelib diff --git a/bin/jsoo_main.ml b/bin/jsoo_main.ml index c2fa22807a..e7ea0de6b4 100644 --- a/bin/jsoo_main.ml +++ b/bin/jsoo_main.ml @@ -22,6 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Melstd open Melangelib open Melange_compiler_libs module Js = Jsoo_common.Js @@ -53,7 +54,7 @@ let playground_warning_reporter (loc : Location.t) w : Location.report option = let main = { Location.loc; txt = msg_of_str message } in let sub = List.map - (fun (loc, sub_message) -> + ~f:(fun (loc, sub_message) -> { Location.loc; txt = msg_of_str sub_message }) sub_locs in @@ -235,11 +236,8 @@ let compile = Js_dump_program.pp_deps_program ~output_prefix:"" ~package_info:Js_packages_info.empty ~output_info: - { - Js_packages_info.module_system = Es6; - suffix = Ext_js_suffix.default; - } - (Ext_pp.from_buffer buffer) + { Js_packages_info.module_system = Es6; suffix = Js_suffix.default } + (Js_pp.from_buffer buffer) (Lam_compile_main.compile "" lam) in let v = Buffer.contents buffer in @@ -249,7 +247,8 @@ let compile = [| ("js_code", Js.string v); ( "warnings", - List.rev_map Jsoo_common.warning_error_to_js !warnings_collected + List.rev_map ~f:Jsoo_common.warning_error_to_js + !warnings_collected |> Array.of_list |> Js.array ); ("type_hints", type_hints); |]) @@ -270,7 +269,7 @@ let compile = | warnings -> let type_ = "warning_errors" in let jsErrors = - List.rev_map Jsoo_common.warning_error_to_js warnings + List.rev_map ~f:Jsoo_common.warning_error_to_js warnings |> Array.of_list in Js.obj diff --git a/bin/melc.ml b/bin/melc.ml index 4e8b513085..89be34d615 100644 --- a/bin/melc.ml +++ b/bin/melc.ml @@ -10,6 +10,8 @@ (* *) (***********************************************************************) +open Melstd + #ifndef BS_RELEASE_BUILD let print_backtrace () = let raw_bt = Printexc.backtrace_slots (Printexc.get_raw_backtrace ()) in @@ -26,7 +28,7 @@ let print_backtrace () = | [] -> acc := [ bt ] | hd :: _ -> if hd <> bt then acc := bt :: !acc) done; - List.iter (fun (bt: Printexc.location) -> + List.iter ~f:(fun (bt: Printexc.location) -> Printf.eprintf "File \"%s\", line %d, characters %d-%d\n" bt.filename bt.line_number bt.start_char bt.end_char) !acc #endif @@ -34,7 +36,7 @@ let print_backtrace () = let set_abs_input_name sourcefile = let sourcefile = if !Clflags.absname && Filename.is_relative sourcefile then - Ext_path.absolute_cwd_path sourcefile + Path.absolute_cwd_path sourcefile else sourcefile in Location.set_input_name sourcefile; sourcefile @@ -48,7 +50,7 @@ let process_file sourcefile *) let kind = match kind with - | None -> Artifact_extension.Valid_input.classify (Ext_filename.get_extension_maybe sourcefile) + | None -> Artifact_extension.Valid_input.classify (Filename.get_extension_maybe sourcefile) | Some kind -> kind in match kind with | Ml -> @@ -143,7 +145,7 @@ let anonymous = else begin if !Js_config.syntax_only then begin - Ext_list.rev_iter rev_args (fun filename -> + List.rev_iter rev_args (fun filename -> begin (* Clflags.reset_dump_state (); *) (* Warnings.reset (); *) @@ -186,7 +188,7 @@ let eval (s : string) = ret let print_standard_library () = - print_endline (String.concat ":" (Js_config.std_include_dirs ())); + print_endline (String.concat ~sep:":" (Js_config.std_include_dirs ())); exit 0 let bs_version_string = @@ -274,7 +276,7 @@ let main: Melc_cli.t -> _ Cmdliner.Term.ret (* The OCaml compiler expects include_dirs in reverse CLI order, but cmdliner returns it in CLI order. *) List.rev_append include_dirs !Clflags.include_dirs; - List.iter Warnings.parse_alert_option alerts; + List.iter ~f:Warnings.parse_alert_option alerts; begin match warnings with | [] -> () @@ -285,7 +287,7 @@ let main: Melc_cli.t -> _ Cmdliner.Term.ret "+20" (so we override it). *) Melc_warnings.parse_warnings ~warn_error:false first; Melc_warnings.parse_warnings ~warn_error:false "-20"; - List.iter (Melc_warnings.parse_warnings ~warn_error:false) rest; + List.iter ~f:(Melc_warnings.parse_warnings ~warn_error:false) rest; end; Option.iter @@ -307,17 +309,17 @@ let main: Melc_cli.t -> _ Cmdliner.Term.ret | Some bs_module_type, [] -> let suffix = match output_name with | Some output_name -> - (match Ext_filename.get_all_extensions_maybe output_name with + (match Filename.get_all_extensions_maybe output_name with | None -> raise (Arg.Bad "`-o FILENAME` needs to include a valid extension") - | Some ext -> Ext_js_suffix.of_string ext) + | Some ext -> Js_suffix.of_string ext) | None -> raise (Arg.Bad "`-o FILENAME` is required when passing `-bs-module-type`") in Js_packages_state.set_output_info ~suffix bs_module_type | None, bs_package_output -> List.iter - (Js_packages_state.update_npm_package_path ?module_name:bs_module_name) + ~f:(Js_packages_state.update_npm_package_path ?module_name:bs_module_name) bs_package_output; | Some _, _ :: _ -> raise (Arg.Bad ("Can't pass both `-bs-package-output` and `-bs-module-type`")) @@ -365,7 +367,7 @@ let main: Melc_cli.t -> _ Cmdliner.Term.ret if short_paths then Clflags.real_paths := false; if unsafe then Clflags.unsafe := unsafe; if warn_help then Warnings.help_warnings (); - List.iter (Melc_warnings.parse_warnings ~warn_error:true) warn_error ; + List.iter ~f:(Melc_warnings.parse_warnings ~warn_error:true) warn_error ; if bs_stop_after_cmj then Js_config.cmj_only := bs_stop_after_cmj; Option.iter (fun s -> @@ -407,7 +409,7 @@ let file_level_flags_handler (e : Parsetree.expression option) = | None -> () | Some { pexp_desc = Pexp_array args; pexp_loc; _ } -> let args = - ( List.map (fun (e: Parsetree.expression) -> + ( List.map ~f:(fun (e: Parsetree.expression) -> match e.pexp_desc with | Pexp_constant (Pconst_string(name,_,_)) -> name | _ -> Location.raise_errorf ~loc:e.pexp_loc "string literal expected" ) args) diff --git a/bin/melc_cli.ml b/bin/melc_cli.ml index 2fef31dd1f..286402cdbf 100644 --- a/bin/melc_cli.ml +++ b/bin/melc_cli.ml @@ -23,6 +23,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open Cmdliner +open Melstd type t = { include_dirs : string list; @@ -32,7 +33,7 @@ type t = { ppx : string list; open_modules : string list; bs_package_output : string list; - bs_module_type : Ext_module_system.t option; + bs_module_type : Module_system.t option; bs_syntax_only : bool; bs_g : bool; bs_package_name : string option; @@ -261,13 +262,11 @@ module Internal = struct let bs_module_type = let module_system_conv = let parse m = - match Ext_module_system.of_string m with + match Module_system.of_string m with | Some module_system -> Ok module_system | None -> Error (`Msg (Format.asprintf "Invalid module system %s" m)) in - let print fmt ms = - Format.fprintf fmt "%s" (Ext_module_system.to_string ms) - in + let print fmt ms = Format.fprintf fmt "%s" (Module_system.to_string ms) in Arg.conv ~docv:"method" (parse, print) in let doc = "Specify the module type for JS imports" in @@ -596,4 +595,4 @@ let normalize_argv argv = incr nidx); incr idx done; - if !nidx < len then Array.sub normalized 0 !nidx else normalized + if !nidx < len then Array.sub normalized ~pos:0 ~len:!nidx else normalized diff --git a/jscomp/common/dune b/jscomp/common/dune index 370eba969f..969b635dea 100644 --- a/jscomp/common/dune +++ b/jscomp/common/dune @@ -3,7 +3,7 @@ (package melange) (flags :standard -open Melange_compiler_libs) (modules_without_implementation js_raw_info lam_tag_info) - (libraries ext melange_compiler_libs js_parser)) + (libraries melstd melange_compiler_libs js_parser)) (rule (target oprint_mel_primitive_name.ml) diff --git a/jscomp/common/external_ffi_types.ml b/jscomp/common/external_ffi_types.ml index 6d7819778e..66f88fbc56 100644 --- a/jscomp/common/external_ffi_types.ml +++ b/jscomp/common/external_ffi_types.ml @@ -22,6 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import open External_ffi_types0 module Literals = struct @@ -104,7 +105,7 @@ type t = let valid_js_char = let a = - Array.init 256 (fun i -> + Array.init 256 ~f:(fun i -> let c = Char.chr i in (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') @@ -115,7 +116,7 @@ let valid_js_char = let valid_first_js_char = let a = - Array.init 256 (fun i -> + Array.init 256 ~f:(fun i -> let c = Char.chr i in (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c = '_' || c = '$') in @@ -143,9 +144,9 @@ let is_package_relative_path (x : string) = let valid_global_name ?loc txt = if not (valid_ident txt) then - let v = Ext_string.split_by ~keep_empty:true (fun x -> x = '.') txt in + let v = String.split_by ~keep_empty:true (fun x -> x = '.') txt in List.iter - (fun s -> + ~f:(fun s -> if not (valid_ident s) then Location.raise_errorf ?loc "Not a valid global name %s" txt) v diff --git a/jscomp/common/import.ml b/jscomp/common/import.ml new file mode 100644 index 0000000000..1375347156 --- /dev/null +++ b/jscomp/common/import.ml @@ -0,0 +1 @@ +include Melstd diff --git a/jscomp/common/lam_constant.ml b/jscomp/common/lam_constant.ml index cc0c820ed9..6f10ff946a 100644 --- a/jscomp/common/lam_constant.ml +++ b/jscomp/common/lam_constant.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + type constructor_tag = { name : string; const : int; non_const : int } type pointer_info = @@ -75,11 +77,11 @@ let rec eq_approx (x : t) (y : t) = | Const_block (ix, _, ixs) -> ( match y with | Const_block (iy, _, iys) -> - ix = iy && Ext_list.for_all2_no_exn ixs iys eq_approx + ix = iy && List.for_all2_no_exn ixs iys eq_approx | _ -> false) | Const_float_array ixs -> ( match y with - | Const_float_array iys -> Ext_list.for_all2_no_exn ixs iys String.equal + | Const_float_array iys -> List.for_all2_no_exn ixs iys String.equal | _ -> false) | Const_some ix -> ( match y with Const_some iy -> eq_approx ix iy | _ -> false) diff --git a/jscomp/common/lam_methname.ml b/jscomp/common/lam_methname.ml index 822ba8ccfc..da9bbcb498 100644 --- a/jscomp/common/lam_methname.ml +++ b/jscomp/common/lam_methname.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (** {[ _open -> open @@ -59,7 +61,7 @@ (* Copied from [ocaml/parsing/lexer.mll] *) let key_words = - Hash_set_string.of_array + String.Hash_set.of_array [| "and"; "as"; @@ -132,17 +134,17 @@ let valid_start_char x = match x with '_' | 'a' .. 'z' -> true | _ -> false let translate name = assert (String.length name > 0); - let i = Ext_string.rfind ~sub:double_underscore name in + let i = String.rfind ~sub:double_underscore name in if i < 0 then let name_len = String.length name in if name.[0] = '_' then - let try_key_word = String.sub name 1 (name_len - 1) in + let try_key_word = String.sub name ~pos:1 ~len:(name_len - 1) in if name_len > 1 && ((not (valid_start_char try_key_word.[0])) - || Hash_set_string.mem key_words try_key_word) + || String.Hash_set.mem key_words try_key_word) then try_key_word else name else name else if i = 0 then name - else String.sub name 0 i + else String.sub name ~pos:0 ~len:i diff --git a/jscomp/core/ast_config.ml b/jscomp/core/ast_config.ml index 7d6d0677cf..f76ad37720 100644 --- a/jscomp/core/ast_config.ml +++ b/jscomp/core/ast_config.ml @@ -22,21 +22,23 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type action_table = (Parsetree.expression option -> unit) Map_string.t +open Import + +type action_table = (Parsetree.expression option -> unit) String.Map.t let structural_config_table : action_table ref = ref - (Map_string.singleton "no_export" (fun x -> + (String.Map.singleton "no_export" (fun x -> Js_config.no_export := match x with Some e -> Ast_payload.assert_bool_lit e | None -> true)) let add_structure k v = - structural_config_table := Map_string.add !structural_config_table k v + structural_config_table := String.Map.add !structural_config_table k v -let signature_config_table : action_table ref = ref Map_string.empty +let signature_config_table : action_table ref = ref String.Map.empty let add_signature k v = - signature_config_table := Map_string.add !signature_config_table k v + signature_config_table := String.Map.add !signature_config_table k v let rec iter_on_mel_config_stru (x : Parsetree.structure) = match x with @@ -53,7 +55,7 @@ let rec iter_on_mel_config_stru (x : Parsetree.structure) = } :: _ -> List.iter - (fun x -> + ~f:(fun x -> Ast_payload.table_dispatch !structural_config_table x |> ignore) (Ast_payload.ident_or_record_as_config loc payload) (* [ppxlib] adds a wrapper like: @@ -98,7 +100,7 @@ let rec iter_on_mel_config_sigi (x : Parsetree.signature) = } :: _ -> List.iter - (fun x -> + ~f:(fun x -> Ast_payload.table_dispatch !signature_config_table x |> ignore) (Ast_payload.ident_or_record_as_config loc payload) | { psig_desc = Psig_attribute _; _ } :: rest -> iter_on_mel_config_sigi rest diff --git a/jscomp/core/ast_payload.ml b/jscomp/core/ast_payload.ml index 624dd9ea9d..301c06c2f9 100644 --- a/jscomp/core/ast_payload.ml +++ b/jscomp/core/ast_payload.ml @@ -22,13 +22,12 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import module Parser_flow = Js_parser.Parser_flow module Parser_env = Js_parser.Parser_env type t = Parsetree.payload -type lid = string Asttypes.loc -type label_expr = lid * Parsetree.expression -type action = lid * Parsetree.expression option +type action = string Asttypes.loc * Parsetree.expression option (* None means punning is hit {[ { x } ]} otherwise it comes with a payload @@ -58,7 +57,7 @@ let ident_or_record_as_config loc (x : t) : match with_obj with | None -> List.map - (fun u -> + ~f:(fun u -> match u with | ( { Asttypes.txt = Longident.Lident name; loc }, { @@ -100,7 +99,7 @@ let assert_bool_lit (e : Parsetree.expression) = let table_dispatch table (action : action) = match action with | { txt = name; loc }, y -> ( - match Map_string.find_exn table name with + match String.Map.find_exn table name with | fn -> Some (fn y) | exception _ -> Location.prerr_warning loc (Mel_unused_attribute name); diff --git a/jscomp/core/ast_payload.mli b/jscomp/core/ast_payload.mli index 66af934cb1..91ea80953a 100644 --- a/jscomp/core/ast_payload.mli +++ b/jscomp/core/ast_payload.mli @@ -22,16 +22,16 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + type t = Parsetree.payload (** A utility module used when destructuring parsetree attributes, used for compiling FFI attributes and built-in ppx *) -type lid = string Asttypes.loc -type label_expr = lid * Parsetree.expression -type action = lid * Parsetree.expression option +type action = string Asttypes.loc * Parsetree.expression option val ident_or_record_as_config : Location.t -> t -> action list val assert_bool_lit : Parsetree.expression -> bool val table_dispatch : - (Parsetree.expression option -> 'a) Map_string.t -> action -> 'a option + (Parsetree.expression option -> 'a) String.Map.t -> action -> 'a option diff --git a/jscomp/core/compile_rec_module.ml b/jscomp/core/compile_rec_module.ml index e1bf33f3c5..7176c8756f 100644 --- a/jscomp/core/compile_rec_module.ml +++ b/jscomp/core/compile_rec_module.ml @@ -1,27 +1,25 @@ -type t = Lambda.lambda +open Import (* Utilities for compiling "module rec" definitions *) -type loc = t - type binding = Translmod.id_or_ignore_loc * (Lambda.lambda * Lambda.lambda) option * Lambda.lambda let eval_rec_bindings_aux = - let mel_init_mod (args : t list) loc : t = - Lprim + let mel_init_mod args loc = + Lambda.Lprim ( Pccall (Primitive.simple ~name:"#init_mod" ~arity:2 ~alloc:true), args, loc ) - and mel_update_mod (args : t list) loc : t = - Lprim + and mel_update_mod args loc = + Lambda.Lprim ( Pccall (Primitive.simple ~name:"#update_mod" ~arity:3 ~alloc:true), args, loc ) in - fun (bindings : binding list) (cont : t) : t -> + fun (bindings : binding list) cont -> let rec bind_inits args acc = match args with | [] -> acc @@ -48,7 +46,7 @@ let eval_rec_bindings_aux = | (_id, None, _rhs) :: rem -> patch_forwards rem | (Translmod.Ignore_loc _, _, _rhs) :: rem -> patch_forwards rem | (Id id, Some (_loc, shape), rhs) :: rem -> - Lsequence + Lambda.Lsequence ( mel_update_mod [ shape; Lvar id; rhs ] Loc_unknown, patch_forwards rem ) in @@ -63,20 +61,19 @@ let rec is_function_or_const_block (lam : Lambda.lambda) acc = | Levent (lam, _) -> is_function_or_const_block lam acc | Lprim (Pmakeblock _, args, _) -> List.for_all - (fun (x : loc) -> - match x with - | Lvar id -> Set_ident.mem acc id + ~f:(function + | Lambda.Lvar id -> Ident.Set.mem acc id | Lfunction _ | Lconst _ -> true | _ -> false) args | Llet (_, _, id, Lfunction _, cont) | Lmutlet (_, id, Lfunction _, cont) -> - is_function_or_const_block cont (Set_ident.add acc id) + is_function_or_const_block cont (Ident.Set.add acc id) | Lletrec (bindings, cont) -> ( let rec aux_bindings bindings acc = match bindings with | [] -> Some acc | (id, Lambda.Lfunction _) :: rest -> - aux_bindings rest (Set_ident.add acc id) + aux_bindings rest (Ident.Set.add acc id) | (_, _) :: _ -> None in match aux_bindings bindings acc with @@ -85,16 +82,16 @@ let rec is_function_or_const_block (lam : Lambda.lambda) acc = | Llet (_, _, _, Lconst _, cont) | Lmutlet (_, _, Lconst _, cont) -> is_function_or_const_block cont acc | (Llet (_, _, id1, Lvar id2, cont) | Lmutlet (_, id1, Lvar id2, cont)) - when Set_ident.mem acc id2 -> - is_function_or_const_block cont (Set_ident.add acc id1) + when Ident.Set.mem acc id2 -> + is_function_or_const_block cont (Ident.Set.add acc id1) | _ -> false let is_strict_or_all_functions (xs : binding list) = List.for_all - (fun (_, opt, rhs) -> + ~f:(fun (_, opt, rhs) -> match opt with | None -> true - | _ -> is_function_or_const_block rhs Set_ident.empty) + | _ -> is_function_or_const_block rhs Ident.Set.empty) xs (* Without such optimizations: @@ -130,11 +127,11 @@ let is_strict_or_all_functions (xs : binding list) = ]} *) -let eval_rec_bindings (bindings : binding list) (cont : t) : t = +let eval_rec_bindings (bindings : binding list) cont = if is_strict_or_all_functions bindings then Lambda.Lletrec ( List.filter_map - (fun (binding : binding) -> + ~f:(fun (binding : binding) -> match binding with Id id, _, rhs -> Some (id, rhs) | _ -> None) bindings, cont ) diff --git a/jscomp/core/dune b/jscomp/core/dune index 95cff81df5..2877d77ee9 100644 --- a/jscomp/core/dune +++ b/jscomp/core/dune @@ -3,7 +3,12 @@ (flags (:standard -open Melange_compiler_libs)) (modules_without_implementation js_op j) - (libraries ext melange_compiler_libs melange_ffi ppxlib.ast dune-build-info)) + (libraries + melstd + melange_compiler_libs + melange_ffi + ppxlib.ast + dune-build-info)) (rule (target include_dirs.ml) diff --git a/jscomp/core/import.ml b/jscomp/core/import.ml new file mode 100644 index 0000000000..1375347156 --- /dev/null +++ b/jscomp/core/import.ml @@ -0,0 +1 @@ +include Melstd diff --git a/jscomp/core/include_dirs.dev.ml b/jscomp/core/include_dirs.dev.ml index a4d89677c3..86c4176859 100644 --- a/jscomp/core/include_dirs.dev.ml +++ b/jscomp/core/include_dirs.dev.ml @@ -22,9 +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. *) +open Import + let paths = let jscomp = "jscomp" in - Ext_path. + Path. [ (* [melange] / [Stdlib] *) jscomp // "stdlib" // ".stdlib.objs"; diff --git a/jscomp/core/include_dirs.release.ml b/jscomp/core/include_dirs.release.ml index 397d163614..ceeaefdd0c 100644 --- a/jscomp/core/include_dirs.release.ml +++ b/jscomp/core/include_dirs.release.ml @@ -22,9 +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. *) +open Import + let paths = let lib = "lib" and package_name = "melange" in - Ext_path. + Path. [ (* [melange] / [Stdlib] *) lib // package_name; diff --git a/jscomp/core/j.mli b/jscomp/core/j.mli index 3f4c8f2c45..7acfb5680a 100644 --- a/jscomp/core/j.mli +++ b/jscomp/core/j.mli @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (* Javascript IR It's a subset of Javascript AST specialized for OCaml lambda backend @@ -317,7 +319,7 @@ and variable_declaration = { be concatenated in both ways *) and block = statement list -and program = { block : block; exports : exports; export_set : Set_ident.t } +and program = { block : block; exports : exports; export_set : Ident.Set.t } and deps_program = { program : program; diff --git a/jscomp/core/js_analyzer.ml b/jscomp/core/js_analyzer.ml index 98217c5f2e..77723828e2 100644 --- a/jscomp/core/js_analyzer.ml +++ b/jscomp/core/js_analyzer.ml @@ -22,13 +22,15 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + type idents_stats = { - mutable used_idents : Set_ident.t; - mutable defined_idents : Set_ident.t; + mutable used_idents : Ident.Set.t; + mutable defined_idents : Ident.Set.t; } let add_defined_idents (x : idents_stats) ident = - x.defined_idents <- Set_ident.add x.defined_idents ident + x.defined_idents <- Ident.Set.add x.defined_idents ident (* Assume that functions already calculated closure correctly Maybe in the future, we should add a dirty flag, to mark the calcuated @@ -48,8 +50,8 @@ let free_variables (stats : idents_stats) = match st.value with None -> () | Some v -> self.expression self v); ident = (fun _ id -> - if not (Set_ident.mem stats.defined_idents id) then - stats.used_idents <- Set_ident.add stats.used_idents id); + if not (Ident.Set.mem stats.defined_idents id) then + stats.used_idents <- Ident.Set.add stats.used_idents id); expression = (fun self exp -> match exp.expression_desc with @@ -58,26 +60,26 @@ let free_variables (stats : idents_stats) = if it's already comuted *) -> stats.used_idents <- - Set_ident.union (Js_fun_env.get_unbounded env) stats.used_idents + Ident.Set.union (Js_fun_env.get_unbounded env) stats.used_idents | _ -> super.expression self exp); } -let init = { used_idents = Set_ident.empty; defined_idents = Set_ident.empty } +let init = { used_idents = Ident.Set.empty; defined_idents = Ident.Set.empty } let obj = free_variables init let clean_up init = - init.used_idents <- Set_ident.empty; - init.defined_idents <- Set_ident.empty + init.used_idents <- Ident.Set.empty; + init.defined_idents <- Ident.Set.empty let free_variables_of_statement st = clean_up init; obj.statement obj st; - Set_ident.diff init.used_idents init.defined_idents + Ident.Set.diff init.used_idents init.defined_idents let free_variables_of_expression st = clean_up init; obj.expression obj st; - Set_ident.diff init.used_idents init.defined_idents + Ident.Set.diff init.used_idents init.defined_idents let rec no_side_effect_expression_desc (x : J.expression_desc) = match x with @@ -96,9 +98,9 @@ let rec no_side_effect_expression_desc (x : J.expression_desc) = the block is mutable does not mean this operation is non-pure *) - List.for_all no_side_effect xs + List.for_all ~f:no_side_effect xs | Optional_block (x, _) -> no_side_effect x - | Object kvs -> List.for_all (fun (_, x) -> no_side_effect x) kvs + | Object kvs -> List.for_all ~f:(fun (_, x) -> no_side_effect x) kvs | String_append (a, b) | Seq (a, b) -> no_side_effect a && no_side_effect b | Length (e, _) | Char_of_int e | Char_to_int e | Caml_block_tag e | Typeof e -> @@ -210,10 +212,10 @@ let rec eq_expression ({ expression_desc = x0; _ } : J.expression) | Number (Uint _) -> false -and eq_expression_list xs ys = Ext_list.for_all2_no_exn xs ys eq_expression +and eq_expression_list xs ys = List.for_all2_no_exn xs ys eq_expression and eq_block (xs : J.block) (ys : J.block) = - Ext_list.for_all2_no_exn xs ys eq_statement + List.for_all2_no_exn xs ys eq_statement and eq_statement ({ statement_desc = x0; _ } : J.statement) ({ statement_desc = y0; _ } : J.statement) = diff --git a/jscomp/core/js_analyzer.mli b/jscomp/core/js_analyzer.mli index 2a7883d56f..b10427c7c5 100644 --- a/jscomp/core/js_analyzer.mli +++ b/jscomp/core/js_analyzer.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,38 +17,40 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (** Analyzing utilities for [J] module *) (** for example, whether it has side effect or not. *) -val free_variables_of_statement : J.statement -> Set_ident.t -val free_variables_of_expression : J.finish_ident_expression -> Set_ident.t +val free_variables_of_statement : J.statement -> Ident.Set.t +val free_variables_of_expression : J.finish_ident_expression -> Ident.Set.t (* val no_side_effect_expression_desc : J.expression_desc -> bool *) val no_side_effect_expression : J.expression -> bool -(** [no_side_effect] means this expression has no side effect, +(** [no_side_effect] means this expression has no side effect, but it might *depend on value store*, so you can not just move it around, for example, when you want to do a deep copy, the expression passed to you is pure - but you still have to call the function to make a copy, + but you still have to call the function to make a copy, since it maybe changed later *) val no_side_effect_statement : J.statement -> bool -(** - here we say +(** + here we say {[ var x = no_side_effect_expression ]} - is [no side effect], but it is actually side effect, - since we are defining a variable, however, if it is not exported or used, + is [no side effect], but it is actually side effect, + since we are defining a variable, however, if it is not exported or used, then it's fine, so we delay this check later *) @@ -62,7 +64,7 @@ val rev_toplevel_flatten : J.block -> J.block (* val is_constant : J.expression -> bool *) -(** Simple expression, +(** Simple expression, no computation involved so that it is okay to be duplicated *) diff --git a/jscomp/core/js_ast_util.ml b/jscomp/core/js_ast_util.ml index fe25dba1e4..bbb8afcb35 100644 --- a/jscomp/core/js_ast_util.ml +++ b/jscomp/core/js_ast_util.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,18 +17,17 @@ * 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. *) -(* module E = Js_exp_make *) - +open Import module S = Js_stmt_make let named_expression (e : J.expression) : (J.statement * Ident.t) option = if Js_analyzer.is_okay_to_duplicate e then None else - let obj = Ext_ident.create_tmp () in + let obj = Ident.create_tmp () in let obj_code = S.define_variable ~kind:Strict obj e in Some (obj_code, obj) diff --git a/jscomp/core/js_closure.ml b/jscomp/core/js_closure.ml index 2f32be0a98..97f60b4bd7 100644 --- a/jscomp/core/js_closure.ml +++ b/jscomp/core/js_closure.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,13 +17,15 @@ * 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 t = { mutable outer_loop_mutable_values : Set_ident.t } +open Import + +type t = { mutable outer_loop_mutable_values : Ident.Set.t } -let empty () = { outer_loop_mutable_values = Set_ident.empty } +let empty () = { outer_loop_mutable_values = Ident.Set.empty } let set_lexical_scope t v = t.outer_loop_mutable_values <- v let get_lexical_scope t = t.outer_loop_mutable_values diff --git a/jscomp/core/js_closure.mli b/jscomp/core/js_closure.mli index 6c112eb5d0..9de0892683 100644 --- a/jscomp/core/js_closure.mli +++ b/jscomp/core/js_closure.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,17 +17,19 @@ * 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. *) -(** Define a type used in JS IR to help convert lexical scope to JS [var] +open Import + +(** Define a type used in JS IR to help convert lexical scope to JS [var] based scope convention *) -type t = { mutable outer_loop_mutable_values : Set_ident.t } +type t = { mutable outer_loop_mutable_values : Ident.Set.t } val empty : unit -> t -val get_lexical_scope : t -> Set_ident.t -val set_lexical_scope : t -> Set_ident.t -> unit +val get_lexical_scope : t -> Ident.Set.t +val set_lexical_scope : t -> Ident.Set.t -> unit diff --git a/jscomp/core/js_cmj_format.ml b/jscomp/core/js_cmj_format.ml index a0d5d322ff..6b39436974 100644 --- a/jscomp/core/js_cmj_format.ml +++ b/jscomp/core/js_cmj_format.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + type arity = Single of Lam_arity.t | Submodule of Lam_arity.t array (* TODO: add a magic number *) @@ -51,11 +53,11 @@ type t = { delayed_program : J.deps_program; } -let make ~(values : cmj_value Map_string.t) ~effect ~package_spec ~case +let make ~(values : cmj_value String.Map.t) ~effect ~package_spec ~case ~delayed_program : t = { values = - Map_string.to_sorted_array_with_f values (fun k v -> + String.Map.to_sorted_array_with_f values (fun k v -> { name = k; arity = v.arity; @@ -106,7 +108,7 @@ let to_file name (v : t) = output_string oc s; close_out oc) -let keyComp (a : string) b = Map_string.compare_key a b.name +let keyComp (a : string) b = String.Map.compare_key a b.name let not_found key = { name = key; arity = single_na; persistent_closed_lambda = None } diff --git a/jscomp/core/js_cmj_format.mli b/jscomp/core/js_cmj_format.mli index b4d5344991..bc2acd1f16 100644 --- a/jscomp/core/js_cmj_format.mli +++ b/jscomp/core/js_cmj_format.mli @@ -22,8 +22,9 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(** Define intemediate format to be serialized for cross module optimization - *) +open Import + +(** Define intemediate format to be serialized for cross module optimization *) (** In this module, currently only arity information is exported, @@ -70,7 +71,7 @@ type t = { } val make : - values:cmj_value Map_string.t -> + values:cmj_value String.Map.t -> effect:effect -> package_spec:Js_packages_info.t -> case:Js_packages_info.file_case -> diff --git a/jscomp/core/js_config.ml b/jscomp/core/js_config.ml index c58d1ec25e..44b5e0a421 100644 --- a/jscomp/core/js_config.ml +++ b/jscomp/core/js_config.ml @@ -22,24 +22,29 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + let executable_name = - lazy (Unix.realpath (Ext_path.normalize_absolute_path Sys.executable_name)) + lazy (Unix.realpath (Path.normalize_absolute_path Sys.executable_name)) let stdlib_paths = - let ( // ) = Ext_path.( // ) in + let ( // ) = Path.( // ) in let package_name = "melange" in lazy (match Sys.getenv "MELANGELIB" with | value -> ( let dirs = - String.split_on_char Ext_path.path_sep value - |> List.filter (fun s -> String.length s > 0) - |> List.map (fun dir -> - if Filename.is_relative dir then - Filename.dirname (Lazy.force executable_name) // dir - else dir) + String.split_on_char ~sep:Path.path_sep value + |> List.filter_map ~f:(function + | "" -> None + | dir -> + Some + (if Filename.is_relative dir then + Filename.dirname (Lazy.force executable_name) // dir + else dir)) in - match List.exists (fun dir -> not (Sys.is_directory dir)) dirs with + + match List.exists ~f:(fun dir -> not (Sys.is_directory dir)) dirs with | false -> dirs | true -> raise (Arg.Bad "$MELANGELIB should only contain directories") | exception Sys_error _ -> raise (Arg.Bad "$MELANGELIB dirs must exist") @@ -50,7 +55,9 @@ let stdlib_paths = Lazy.force executable_name |> Filename.dirname |> Filename.dirname in (* //melange *) - List.map (fun path -> root // path // package_name) Include_dirs.paths) + List.map + ~f:(fun path -> root // path // package_name) + Include_dirs.paths) let no_version_header = ref false let cross_module_inline = ref false diff --git a/jscomp/core/js_dump.ml b/jscomp/core/js_dump.ml index 917eb93732..5bcb555198 100644 --- a/jscomp/core/js_dump.ml +++ b/jscomp/core/js_dump.ml @@ -20,6 +20,8 @@ *) (* Authors: Jérôme Vouillon, Hongbo Zhang *) +open Import + (* http://stackoverflow.com/questions/2846283/what-are-the-rules-for-javascripts-automatic-semicolon-insertion-asi ASI catch up @@ -71,37 +73,37 @@ module L = Js_dump_lit (our call Js_fun_env.get_unbounded env) is not precise *) -type cxt = { scope : Ext_pp_scope.t; pp : Ext_pp.t } +type cxt = { scope : Pp_scope.t; pp : Js_pp.t } -let from_pp pp = { scope = Ext_pp_scope.empty; pp } -let from_buffer buf = from_pp (Ext_pp.from_buffer buf) +let from_pp pp = { scope = Pp_scope.empty; pp } +let from_buffer buf = from_pp (Js_pp.from_buffer buf) let update_scope cxt scope = { cxt with scope } -let ident cxt id = update_scope cxt (Ext_pp_scope.ident cxt.scope cxt.pp id) -let string cxt s = Ext_pp.string cxt.pp s -let group cxt = Ext_pp.group cxt.pp -let newline cxt = Ext_pp.newline cxt.pp -let paren_group cxt = Ext_pp.paren_group cxt.pp -let paren_vgroup cxt = Ext_pp.paren_vgroup cxt.pp -let vgroup cxt = Ext_pp.vgroup cxt.pp -let space cxt = Ext_pp.space cxt.pp -let cond_paren_group cxt = Ext_pp.cond_paren_group cxt.pp -let paren cxt = Ext_pp.paren cxt.pp -let brace_vgroup cxt = Ext_pp.brace_vgroup cxt.pp -let bracket_group cxt = Ext_pp.bracket_group cxt.pp -let bracket_vgroup cxt = Ext_pp.bracket_vgroup cxt.pp +let ident cxt id = update_scope cxt (Pp_scope.ident cxt.scope cxt.pp id) +let string cxt s = Js_pp.string cxt.pp s +let group cxt = Js_pp.group cxt.pp +let newline cxt = Js_pp.newline cxt.pp +let paren_group cxt = Js_pp.paren_group cxt.pp +let paren_vgroup cxt = Js_pp.paren_vgroup cxt.pp +let vgroup cxt = Js_pp.vgroup cxt.pp +let space cxt = Js_pp.space cxt.pp +let cond_paren_group cxt = Js_pp.cond_paren_group cxt.pp +let paren cxt = Js_pp.paren cxt.pp +let brace_vgroup cxt = Js_pp.brace_vgroup cxt.pp +let bracket_group cxt = Js_pp.bracket_group cxt.pp +let bracket_vgroup cxt = Js_pp.bracket_vgroup cxt.pp let merge_scope cxt l = - let scope = Ext_pp_scope.merge cxt.scope l in + let scope = Pp_scope.merge cxt.scope l in { cxt with scope } -let sub_scope cxt l = update_scope cxt (Ext_pp_scope.sub_scope cxt.scope l) +let sub_scope cxt l = update_scope cxt (Pp_scope.sub_scope cxt.scope l) let str_of_ident cxt id = - let str, scope = Ext_pp_scope.str_of_ident cxt.scope id in + let str, scope = Pp_scope.str_of_ident cxt.scope id in (str, update_scope cxt scope) -let at_least_two_lines cxt = Ext_pp.at_least_two_lines cxt.pp -let flush cxt () = Ext_pp.flush cxt.pp () +let at_least_two_lines cxt = Js_pp.at_least_two_lines cxt.pp +let flush cxt () = Js_pp.flush cxt.pp () module Curry_gen = struct let pp_curry_dot cxt = @@ -123,8 +125,8 @@ module Curry_gen = struct string cxt (Printf.sprintf "%d" len) end -let return_indent = String.length L.return / Ext_pp.indent_length -let throw_indent = String.length L.throw / Ext_pp.indent_length +let return_indent = String.length L.return / Js_pp.indent_length +let throw_indent = String.length L.throw / Js_pp.indent_length let semi cxt = string cxt L.semi let comma cxt = string cxt L.comma @@ -140,9 +142,9 @@ let exn_block_as_obj ~(stack : bool) (el : J.expression list) (ext : J.tag_info) in Object (if stack then - List.mapi (fun i e -> (Js_op.Lit (field_name i), e)) el + List.mapi ~f:(fun i e -> (Js_op.Lit (field_name i), e)) el @ [ (Js_op.Lit "Error", E.new_ (E.js_global "Error") []) ] - else List.mapi (fun i e -> (Js_op.Lit (field_name i), e)) el) + else List.mapi ~f:(fun i e -> (Js_op.Lit (field_name i), e)) el) let rec iter_lst cxt ls element inter = match ls with @@ -155,7 +157,7 @@ let rec iter_lst cxt ls element inter = let raw_snippet_exp_simple_enough (s : string) = String.for_all - (function 'a' .. 'z' | 'A' .. 'Z' | '_' | '.' -> true | _ -> false) + ~f:(function 'a' .. 'z' | 'A' .. 'Z' | '_' | '.' -> true | _ -> false) s (* Parentheses are required when the expression starts syntactically with "{" or "function" @@ -202,9 +204,9 @@ let pp_paren_params (cxt : cxt) (lexical : Ident.t list) : unit = (* Print as underscore for unused vars, may not be needed in the future *) (* let ipp_ident cxt id (un_used : bool) = - Ext_pp_scope.ident cxt ( + Pp_scope.ident cxt ( if un_used then - Ext_ident.make_unused () + Ident.make_unused () else id) *) @@ -359,14 +361,14 @@ and pp_function ~return_unit ~is_method cxt ~fn_state (l : Ident.t list) it can be optimized in to either [u] or [Curry.__n(u)] *) (not is_method) - && Ext_list.for_all2_no_exn ls l is_var + && List.for_all2_no_exn ls l is_var && match v with (* This check is needed to avoid some edge cases {[function(x){return x(x)}]} here the function is also called `x` *) - | Id id -> not (List.exists (fun x -> Ident.same x id) l) + | Id id -> not (List.exists ~f:(fun x -> Ident.same x id) l) | Qualified _ -> true -> ( let optimize len ~p cxt v = if p then try_optimize_curry cxt len function_id else vident cxt v @@ -383,12 +385,12 @@ and pp_function ~return_unit ~is_method cxt ~fn_state (l : Ident.t list) if fn_state = Is_return then return_sp cxt; optimize len ~p:(arity = NA && len <= 8) cxt v) | _ -> - let set_env : Set_ident.t = + let set_env = (* identifiers will be printed cxtollowing*) match fn_state with | Is_return | No_name _ -> Js_fun_env.get_unbounded env | Name_top id | Name_non_top id -> - Set_ident.add (Js_fun_env.get_unbounded env) id + Ident.Set.add (Js_fun_env.get_unbounded env) id in (* the context will be continued after this function *) let outer_cxt = merge_scope cxt set_env in @@ -423,10 +425,10 @@ and pp_function ~return_unit ~is_method cxt ~fn_state (l : Ident.t list) space cxt; brace_vgroup cxt 1 (fun _ -> function_body ~return_unit cxt b) in - let lexical : Set_ident.t = Js_fun_env.get_lexical_scope env in + let lexical : Ident.Set.t = Js_fun_env.get_lexical_scope env in let enclose lexical = let handle lexical = - if Set_ident.is_empty lexical then ( + if Ident.Set.is_empty lexical then ( match fn_state with | Is_return -> return_sp cxt; @@ -455,7 +457,7 @@ and pp_function ~return_unit ~is_method cxt ~fn_state (l : Ident.t list) {[(function(x,y){ return function(..){...}} (x,y))]} Maybe changed to `let` in the future *) - let lexical = Set_ident.elements lexical in + let lexical = Ident.Set.elements lexical in (match fn_state with | Is_return -> return_sp cxt | No_name _ -> () @@ -480,10 +482,10 @@ and pp_function ~return_unit ~is_method cxt ~fn_state (l : Ident.t list) in handle (match fn_state with - | (Name_top name | Name_non_top name) when Set_ident.mem lexical name + | (Name_top name | Name_non_top name) when Ident.Set.mem lexical name -> (*TODO: when calculating lexical we should not include itself *) - Set_ident.remove lexical name + Ident.Set.remove lexical name | _ -> lexical) in enclose lexical; @@ -524,7 +526,9 @@ and pp_one_case_clause : 'a. _ -> (_ -> 'a -> unit) -> 'a * J.case_clause -> _ = and loop_case_clauses : 'a. _ -> (_ -> 'a -> unit) -> ('a * _) list -> _ = fun cxt pp_cond cases -> - List.fold_left (fun acc x -> pp_one_case_clause acc pp_cond x) cxt cases + List.fold_left + ~f:(fun acc x -> pp_one_case_clause acc pp_cond x) + ~init:cxt cases and vident cxt (v : J.vident) = match v with @@ -537,7 +541,7 @@ and vident cxt (v : J.vident) = string cxt L.dot; string cxt (if name = Js_dump_import_export.default_export then name - else Ext_ident.convert name); + else Ident.convert name); cxt | Qualified ({ id; kind = External _ }, Some name) -> let cxt = ident cxt id in @@ -576,7 +580,7 @@ and expression_desc cxt ~(level : int) x : cxt = It seems the optimizer already did work to make sure {[ Call (Raw_js_code (s, Exp i), el, {Full}) - when Ext_list.length_equal el i + when List.length_equal el i ]} *) | Call (e, el, info) -> @@ -761,15 +765,14 @@ and expression_desc cxt ~(level : int) x : cxt = | Caml_block (el, _, _, Blk_module fields) -> expression_desc cxt ~level (Object - (Ext_list.map_combine fields el (fun x -> - Js_op.Lit (Ext_ident.convert x)))) + (List.map_combine fields el (fun x -> Js_op.Lit (Ident.convert x)))) (*name convention of Record is slight different from modules*) | Caml_block (el, mutable_flag, _, Blk_record fields) -> if block_has_all_int_fields fields then expression_desc cxt ~level (Array (el, mutable_flag)) else expression_desc cxt ~level - (Object (Ext_list.map_combine_array fields el (fun i -> Js_op.Lit i))) + (Object (List.map_combine_array fields el (fun i -> Js_op.Lit i))) | Caml_block (el, _, _, Blk_poly_var) -> ( match el with | [ { expression_desc = Str (_, name); _ }; value ] -> @@ -785,7 +788,7 @@ and expression_desc cxt ~(level : int) x : cxt = | Caml_block (el, _, tag, Blk_record_inlined p) -> let objs = let tails = - Ext_list.map_combine_array_append p.fields el + List.map_combine_array_append p.fields el (if !Js_config.debug then [ (name_symbol, E.str p.name) ] else []) (fun i -> Js_op.Lit i) in @@ -804,7 +807,7 @@ and expression_desc cxt ~(level : int) x : cxt = let objs = let tails = List.mapi - (fun i e -> + ~f:(fun i e -> ( Js_op.Lit (Js_exp_make.variant_pos ~constr:p.name (Int32.of_int i)), e )) @@ -1083,9 +1086,7 @@ and statement_desc top cxt (s : J.statement_desc) : cxt = in space cxt; comma cxt; - let id = - Ext_ident.create (Ident.name id ^ "_finish") - in + let id = Ident.create (Ident.name id ^ "_finish") in let cxt = ident cxt id in space cxt; string cxt L.eq; @@ -1093,9 +1094,7 @@ and statement_desc top cxt (s : J.statement_desc) : cxt = (expression ~level:1 cxt finish, Some id) | None, (Number _ | Var _) -> (cxt, None) | None, _ -> - let id = - Ext_ident.create (Ident.name id ^ "_finish") - in + let id = Ident.create (Ident.name id ^ "_finish") in let cxt = pp_var_assign cxt id in (expression ~level:15 cxt finish, Some id) in @@ -1133,14 +1132,14 @@ and statement_desc top cxt (s : J.statement_desc) : cxt = brace_block cxt s) in let lexical = Js_closure.get_lexical_scope env in - if Set_ident.is_empty lexical then action cxt + if Ident.Set.is_empty lexical then action cxt else (* unlike function, [print for loop] has side effect, we should take it out *) let inner_cxt = merge_scope cxt lexical in - let lexical = Set_ident.elements lexical in + let lexical = Ident.Set.elements lexical in vgroup cxt 0 (fun _ -> string cxt L.lparen; string cxt L.function_; diff --git a/jscomp/core/js_dump.mli b/jscomp/core/js_dump.mli index 7f08f3cb16..c6bfc2d167 100644 --- a/jscomp/core/js_dump.mli +++ b/jscomp/core/js_dump.mli @@ -20,10 +20,11 @@ *) (* Authors: Jérôme Vouillon, Hongbo Zhang *) -val statements : bool -> Ext_pp_scope.t -> Ext_pp.t -> J.block -> Ext_pp_scope.t -(** Print JS IR to vanilla Javascript code - Called by module {!Js_dump_program} -*) +open Import + +val statements : bool -> Pp_scope.t -> Js_pp.t -> J.block -> Pp_scope.t +(** Print JS IR to vanilla Javascript code + Called by module {!Js_dump_program} *) val string_of_block : J.block -> string (** 2 functions Only used for debugging *) diff --git a/jscomp/core/js_dump_import_export.ml b/jscomp/core/js_dump_import_export.ml index 19773ab793..48b6ae7130 100644 --- a/jscomp/core/js_dump_import_export.ml +++ b/jscomp/core/js_dump_import_export.ml @@ -22,7 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -module P = Ext_pp +open Import +module P = Js_pp module L = Js_dump_lit let default_export = "default" @@ -34,7 +35,7 @@ let rev_iter_inter lst f inter = | [] -> () | [ a ] -> f a | a :: rest -> - Ext_list.rev_iter rest (fun x -> + List.rev_iter rest (fun x -> f x; inter ()); f a @@ -43,16 +44,16 @@ let rev_iter_inter lst f inter = let exports cxt f (idents : Ident.t list) = let outer_cxt, reversed_list = List.fold_left - (fun (cxt, acc) id -> + ~f:(fun (cxt, acc) id -> let id_name = Ident.name id in - let s = Ext_ident.convert id_name in - let str, cxt = Ext_pp_scope.str_of_ident cxt id in + let s = Ident.convert id_name in + let str, cxt = Pp_scope.str_of_ident cxt id in ( cxt, if id_name = default_export then (* TODO check how it will affect AMDJS*) esModule :: (default_export, str) :: acc else (s, str) :: acc )) - (cxt, []) idents + ~init:(cxt, []) idents in P.at_least_two_lines f; rev_iter_inter reversed_list @@ -73,14 +74,14 @@ let exports cxt f (idents : Ident.t list) = let es6_export cxt f (idents : Ident.t list) = let outer_cxt, reversed_list = List.fold_left - (fun (cxt, acc) id -> + ~f:(fun (cxt, acc) id -> let id_name = Ident.name id in - let s = Ext_ident.convert id_name in - let str, cxt = Ext_pp_scope.str_of_ident cxt id in + let s = Ident.convert id_name in + let str, cxt = Pp_scope.str_of_ident cxt id in ( cxt, if id_name = default_export then (default_export, str) :: acc else (s, str) :: acc )) - (cxt, []) idents + ~init:(cxt, []) idents in P.at_least_two_lines f; P.string f L.export; @@ -104,13 +105,13 @@ let requires require_lit cxt f (modules : (Ident.t * string * bool) list) = (* the context used to print the following program *) let outer_cxt, reversed_list = List.fold_left - (fun (cxt, acc) (id, s, b) -> - let str, cxt = Ext_pp_scope.str_of_ident cxt id in + ~f:(fun (cxt, acc) (id, s, b) -> + let str, cxt = Pp_scope.str_of_ident cxt id in (cxt, (str, s, b) :: acc)) - (cxt, []) modules + ~init:(cxt, []) modules in P.at_least_two_lines f; - Ext_list.rev_iter reversed_list (fun (s, file, default) -> + List.rev_iter reversed_list (fun (s, file, default) -> P.string f L.var; P.space f; P.string f s; @@ -129,13 +130,13 @@ let imports cxt f (modules : (Ident.t * string * bool) list) = (* the context used to print the following program *) let outer_cxt, reversed_list = List.fold_left - (fun (cxt, acc) (id, s, b) -> - let str, cxt = Ext_pp_scope.str_of_ident cxt id in + ~f:(fun (cxt, acc) (id, s, b) -> + let str, cxt = Pp_scope.str_of_ident cxt id in (cxt, (str, s, b) :: acc)) - (cxt, []) modules + ~init:(cxt, []) modules in P.at_least_two_lines f; - Ext_list.rev_iter reversed_list (fun (s, file, default) -> + List.rev_iter reversed_list (fun (s, file, default) -> P.string f L.import; P.space f; if default then ( diff --git a/jscomp/core/js_dump_import_export.mli b/jscomp/core/js_dump_import_export.mli index ac5fd52990..1b44d85d7d 100644 --- a/jscomp/core/js_dump_import_export.mli +++ b/jscomp/core/js_dump_import_export.mli @@ -22,16 +22,18 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + val default_export : string -val exports : Ext_pp_scope.t -> Ext_pp.t -> Ident.t list -> Ext_pp_scope.t -val es6_export : Ext_pp_scope.t -> Ext_pp.t -> Ident.t list -> Ext_pp_scope.t +val exports : Pp_scope.t -> Js_pp.t -> Ident.t list -> Pp_scope.t +val es6_export : Pp_scope.t -> Js_pp.t -> Ident.t list -> Pp_scope.t val requires : string -> - Ext_pp_scope.t -> - Ext_pp.t -> + Pp_scope.t -> + Js_pp.t -> (Ident.t * string * bool) list -> - Ext_pp_scope.t + Pp_scope.t val imports : - Ext_pp_scope.t -> Ext_pp.t -> (Ident.t * string * bool) list -> Ext_pp_scope.t + Pp_scope.t -> Js_pp.t -> (Ident.t * string * bool) list -> Pp_scope.t diff --git a/jscomp/core/js_dump_program.ml b/jscomp/core/js_dump_program.ml index e9a98566a5..7da8bc9526 100644 --- a/jscomp/core/js_dump_program.ml +++ b/jscomp/core/js_dump_program.ml @@ -22,7 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -module P = Ext_pp +open Import +module P = Js_pp module L = Js_dump_lit let empty_explanation = @@ -65,7 +66,7 @@ let program f cxt (x : J.program) = Js_dump_import_export.exports cxt f x.exports let dump_program (x : J.program) oc = - ignore (program (P.from_channel oc) Ext_pp_scope.empty x) + ignore (program (P.from_channel oc) Pp_scope.empty x) let[@inline] is_default (x : Js_op.kind) = match x with External { default; _ } -> default | _ -> false @@ -74,9 +75,9 @@ let node_program ~package_info ~output_info ~output_dir f (x : J.deps_program) = P.string f L.strict_directive; P.newline f; let cxt = - Js_dump_import_export.requires L.require Ext_pp_scope.empty f + Js_dump_import_export.requires L.require Pp_scope.empty f (List.map - (fun (x : J.module_id) -> + ~f:(fun (x : J.module_id) -> ( x.id, Js_name_of_module_id.string_of_module_id ~package_info ~output_info ~output_dir x, @@ -87,9 +88,9 @@ let node_program ~package_info ~output_info ~output_dir f (x : J.deps_program) = let es6_program ~package_info ~output_info ~output_dir f (x : J.deps_program) = let cxt = - Js_dump_import_export.imports Ext_pp_scope.empty f + Js_dump_import_export.imports Pp_scope.empty f (List.map - (fun (x : J.module_id) -> + ~f:(fun (x : J.module_id) -> ( x.id, Js_name_of_module_id.string_of_module_id ~package_info x ~output_dir ~output_info, @@ -111,7 +112,7 @@ let pp_deps_program = let header = "// Generated by Melange" in fun ~package_info ~(output_info : Js_packages_info.output_info) - ~(output_prefix : string) (f : Ext_pp.t) (program : J.deps_program) -> + ~(output_prefix : string) (f : Js_pp.t) (program : J.deps_program) -> Option.iter (fun preamble -> P.string f preamble; @@ -124,7 +125,7 @@ let pp_deps_program = (* This is empty module, it won't be referred anywhere *) else let comments, program = extract_file_comments program in - Ext_list.rev_iter comments (fun comment -> + List.rev_iter comments (fun comment -> P.string f comment; P.newline f); let output_dir = Filename.dirname output_prefix in diff --git a/jscomp/core/js_dump_program.mli b/jscomp/core/js_dump_program.mli index e3c94f240e..77c9cde227 100644 --- a/jscomp/core/js_dump_program.mli +++ b/jscomp/core/js_dump_program.mli @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + val dump_program : J.program -> out_channel -> unit (** only used for debugging purpose *) @@ -37,6 +39,6 @@ val pp_deps_program : package_info:Js_packages_info.t -> output_info:Js_packages_info.output_info -> output_prefix:string -> - Ext_pp.t -> + Js_pp.t -> J.deps_program -> unit diff --git a/jscomp/core/js_dump_property.ml b/jscomp/core/js_dump_property.ml index ea1d4bf2c0..eada43b5bb 100644 --- a/jscomp/core/js_dump_property.ml +++ b/jscomp/core/js_dump_property.ml @@ -22,7 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -module P = Ext_pp +open Import +module P = Js_pp module L = Js_dump_lit (** @@ -32,15 +33,15 @@ module L = Js_dump_lit Let's not do smart things {[ - { 003 : 1} + { 003 : 1} ]} - becomes + becomes {[ { 3 : 1} ]} *) -(** used in printing keys +(** used in printing keys {[ {"x" : x};; {x : x } @@ -55,13 +56,13 @@ let obj_property_no_need_quot s = if len > 0 then match String.unsafe_get s 0 with | '$' | '_' | 'a' .. 'z' | 'A' .. 'Z' -> - Ext_string.for_all_from s 1 (function + String.for_all_from s 1 (function | 'a' .. 'z' | 'A' .. 'Z' | '$' | '_' | '0' .. '9' -> true | _ -> false) | _ -> false else false -(** used in property access +(** used in property access {[ f.x ;; f["x"];; diff --git a/jscomp/core/js_dump_property.mli b/jscomp/core/js_dump_property.mli index 3587e10ab7..50ddb5d43f 100644 --- a/jscomp/core/js_dump_property.mli +++ b/jscomp/core/js_dump_property.mli @@ -22,5 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val property_access : Ext_pp.t -> string -> unit +open Import + +val property_access : Js_pp.t -> string -> unit val property_key : J.property_name -> string diff --git a/jscomp/core/js_dump_string.ml b/jscomp/core/js_dump_string.ml index bc4d842609..811fb912c5 100644 --- a/jscomp/core/js_dump_string.ml +++ b/jscomp/core/js_dump_string.ml @@ -22,14 +22,13 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -module P = Ext_pp +open Import +module P = Js_pp (** Avoid to allocate single char string too many times*) -let array_str1 = Array.init 256 (fun i -> String.make 1 (Char.chr i)) +let array_str1 = Array.init 256 ~f:(fun i -> String.make 1 (Char.chr i)) -(** For converting - -*) +(* For converting *) let array_conv = [| "0"; diff --git a/jscomp/core/js_dump_string.mli b/jscomp/core/js_dump_string.mli index 965ec78aab..4389cf5c07 100644 --- a/jscomp/core/js_dump_string.mli +++ b/jscomp/core/js_dump_string.mli @@ -22,8 +22,10 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (* Make sure the escaped string conforms to JS lexing convention *) val escape_to_string : string -> string -val pp_string : Ext_pp.t -> string -> unit +val pp_string : Js_pp.t -> string -> unit diff --git a/jscomp/core/js_exp_make.ml b/jscomp/core/js_exp_make.ml index 0ae0f4fe45..42263a11b8 100644 --- a/jscomp/core/js_exp_make.ml +++ b/jscomp/core/js_exp_make.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + module L = struct let js_type_number = "number" let js_type_string = "string" @@ -55,7 +57,7 @@ let rec remove_pure_sub_exp (x : t) : t option = | Array_index (a, b) -> if is_pure_sub_exp a && is_pure_sub_exp b then None else Some x | Array (xs, _mutable_flag) -> - if List.for_all is_pure_sub_exp xs then None else Some x + if List.for_all ~f:is_pure_sub_exp xs then None else Some x | Seq (a, b) -> ( match (remove_pure_sub_exp a, remove_pure_sub_exp b) with | None, None -> None @@ -75,9 +77,7 @@ let var ?loc ?comment id : t = make_expression ?loc ?comment (Var (Id id)) (* only used in property access, Invariant: it should not call an external module .. *) -let js_global ?loc ?comment (v : string) = - var ?loc ?comment (Ext_ident.create_js v) - +let js_global ?loc ?comment (v : string) = var ?loc ?comment (Ident.create_js v) let undefined : t = make_expression Undefined let nil : t = make_expression Null @@ -159,7 +159,7 @@ let dot ?loc ?comment (e0 : t) (e1 : string) : t = make_expression ?loc ?comment (Static_index (e0, e1, None)) let module_access (e : t) (name : string) (pos : int32) = - let name = Ext_ident.convert name in + let name = Ident.convert name in match e.expression_desc with | Caml_block (l, _, _, _) when no_side_effect e -> ( match List.nth_opt l (Int32.to_int pos) with @@ -245,7 +245,7 @@ let rec seq ?loc ?comment (e0 : t) (e1 : t) : t = | (Number _ | Var _ | Undefined), _ -> e1 | _ -> make_expression ?loc ?comment (Seq (e0, e1)) -let fuse_to_seq x xs = if xs = [] then x else List.fold_left seq x xs +let fuse_to_seq x xs = if xs = [] then x else List.fold_left ~f:seq ~init:x xs (* let empty_string_literal : t = make_expression (Str (true,"")) *) diff --git a/jscomp/core/js_fun_env.ml b/jscomp/core/js_fun_env.ml index 57b2759592..8698ef454c 100644 --- a/jscomp/core/js_fun_env.ml +++ b/jscomp/core/js_fun_env.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (* Make it mutable so that we can do in-place change without constructing a new one -- however, it's a design choice -- to be reviewed later @@ -43,8 +45,8 @@ type immutable_mask = | Immutable_mask of bool array type t = { - mutable unbounded : Set_ident.t; - mutable bound_loop_mutable_values : Set_ident.t; + mutable unbounded : Ident.Set.t; + mutable bound_loop_mutable_values : Ident.Set.t; used_mask : bool array; immutable_mask : immutable_mask; } @@ -52,13 +54,13 @@ type t = { let make ?immutable_mask n = { - unbounded = Set_ident.empty; + unbounded = Ident.Set.empty; used_mask = Array.make n false; immutable_mask = (match immutable_mask with | Some x -> Immutable_mask x | None -> All_immutable_and_no_tail_call); - bound_loop_mutable_values = Set_ident.empty; + bound_loop_mutable_values = Ident.Set.empty; } let no_tailcall x = @@ -73,20 +75,20 @@ let get_unused t i = t.used_mask.(i) (* let to_string env = String.concat "," - (Ext_list.map (Set_ident.elements env.unbounded ) + (Ext_list.map (Ident.Set.elements env.unbounded ) (fun id -> Printf.sprintf "%s/%d" id.name id.stamp) ) *) let get_mutable_params (params : Ident.t list) (x : t) = match x.immutable_mask with | All_immutable_and_no_tail_call -> [] - | Immutable_mask xs -> List.filteri (fun i _p -> not xs.(i)) params + | Immutable_mask xs -> List.filteri ~f:(fun i _p -> not xs.(i)) params let get_unbounded t = t.unbounded let set_unbounded env v = (* Ext_log.err "%s -- set @." (to_string env); *) - (* if Set_ident.is_empty env.bound then *) + (* if Ident.Set.is_empty env.bound then *) env.unbounded <- v (* else assert false *) @@ -98,4 +100,4 @@ let get_lexical_scope env = env.bound_loop_mutable_values (* TODO: can be refined if it only enclose toplevel variables *) -(* let is_empty t = Set_ident.is_empty t.unbounded *) +(* let is_empty t = Ident.Set.is_empty t.unbounded *) diff --git a/jscomp/core/js_fun_env.mli b/jscomp/core/js_fun_env.mli index f9ef6206ba..6492c21162 100644 --- a/jscomp/core/js_fun_env.mli +++ b/jscomp/core/js_fun_env.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,31 +17,24 @@ * 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. *) -(** Define type t used in JS IR to collect some meta data - for a function,like its closures, etc -*) +open Import + +(** Define type t used in JS IR to collect some meta data for a function,like + its closures, etc *) type t val make : ?immutable_mask:bool array -> int -> t val no_tailcall : t -> bool list - -(* val is_empty : t -> bool *) - -val set_unbounded : t -> Set_ident.t -> unit -val set_lexical_scope : t -> Set_ident.t -> unit -val get_lexical_scope : t -> Set_ident.t - -(* val to_string : t -> string *) - +val set_unbounded : t -> Ident.Set.t -> unit +val set_lexical_scope : t -> Ident.Set.t -> unit +val get_lexical_scope : t -> Ident.Set.t val mark_unused : t -> int -> unit val get_unused : t -> int -> bool val get_mutable_params : Ident.t list -> t -> Ident.t list -val get_unbounded : t -> Set_ident.t - -(* val get_length : t -> int *) +val get_unbounded : t -> Ident.Set.t diff --git a/jscomp/core/js_implementation.ml b/jscomp/core/js_implementation.ml index f7c53a693e..113da6fce7 100644 --- a/jscomp/core/js_implementation.ml +++ b/jscomp/core/js_implementation.ml @@ -10,6 +10,8 @@ (* *) (***********************************************************************) +open Import + (* adapted by rescript from [driver/compile.ml] for convenience *) module Ppx_entry = struct @@ -128,7 +130,7 @@ let interface ~parser ppf fname = let all_module_alias (ast : Parsetree.structure) = List.for_all - (fun { Parsetree.pstr_desc; _ } -> + ~f:(fun { Parsetree.pstr_desc; _ } -> match pstr_desc with | Pstr_module { pmb_expr = { pmod_desc = Pmod_ident _; _ }; _ } -> true | Pstr_attribute _ -> true @@ -212,7 +214,7 @@ let implementation_cmj _ppf fname = case, we need to make sure we're removing all the extensions from the output prefix. *) let output_prefix = - output_prefix ~f:Ext_filename.chop_all_extensions_maybe fname + output_prefix ~f:Filename.chop_all_extensions_maybe fname in Lam_compile_main.lambda_as_module ~package_info:cmj.package_spec cmj.delayed_program output_prefix diff --git a/jscomp/core/js_name_of_module_id.ml b/jscomp/core/js_name_of_module_id.ml index ccc9e134f6..cf6a468328 100644 --- a/jscomp/core/js_name_of_module_id.ml +++ b/jscomp/core/js_name_of_module_id.ml @@ -21,16 +21,15 @@ * 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. *) -(* -let (=) (x : int) (y:float) = assert false -*) -let ( // ) = Ext_path.( // ) +open Import + +let ( // ) = Path.( // ) let fix_path_for_windows : string -> string = let replace_backward_slash (x : string) = match String.index x '\\' with - | _i -> String.map (function '\\' -> '/' | x -> x) x + | _i -> String.map ~f:(function '\\' -> '/' | x -> x) x | exception Not_found -> x in if Sys.win32 || Sys.cygwin then replace_backward_slash else fun s -> s @@ -40,7 +39,7 @@ let js_name_of_modulename s (case : Js_packages_info.file_case) suffix : string let s = match case with Lowercase -> String.uncapitalize_ascii s | Uppercase -> s in - s ^ Ext_js_suffix.to_string suffix + s ^ Js_suffix.to_string suffix let js_file_name ~(path_info : Js_packages_info.path_info) ~case ~suffix (dep_module_id : Lam_module_ident.t) = @@ -60,22 +59,21 @@ let get_runtime_module_path ~package_info ~output_info in match Js_packages_info.query_package_infos package_info module_system with | Package_not_found -> assert false - | Package_script -> Ext_module_system.runtime_package_path js_file + | Package_script -> Module_system.runtime_package_path js_file | Package_found _path_info -> ( match module_system with - | NodeJS | Es6 -> Ext_module_system.runtime_package_path js_file + | NodeJS | Es6 -> Module_system.runtime_package_path js_file (* Note we did a post-processing when working on Windows *) | Es6_global -> (* lib/ocaml/xx.cmj -- HACKING: FIXME maybe we can caching relative package path calculation or employ package map *) - let dep_path = "lib" // Ext_module_system.runtime_dir module_system in + let dep_path = "lib" // Module_system.runtime_dir module_system in (* TODO(anmonteiro): This doesn't work yet *) - Ext_path.rel_normalized_absolute_path + Path.rel_normalized_absolute_path ~from: (Js_packages_info.get_output_dir - package_info - (* ~package_dir:(Lazy.force Ext_path.package_dir) *) + package_info (* ~package_dir:(Lazy.force Path.package_dir) *) ~package_dir:(Sys.getcwd ()) module_system) (* Invariant: the package path to `node_modules/melange`, it is used to calculate relative js path *) @@ -130,18 +128,18 @@ let string_of_module_id ~package_info ~output_info | true -> (* If this is the same package, we know all imports are relative. *) - Ext_path.node_rebase_file ~from:cur_pkg.rel_path + Path.node_rebase_file ~from:cur_pkg.rel_path ~to_:dep_info.rel_path js_file | false -> ( match module_system with | NodeJS | Es6 -> dep_info.pkg_rel_path // js_file (* Note we did a post-processing when working on Windows *) | Es6_global -> - Ext_path.rel_normalized_absolute_path + Path.rel_normalized_absolute_path ~from: (Js_packages_info.get_output_dir package_info - (* ~package_dir:(Lazy.force Ext_path.package_dir) *) + (* ~package_dir:(Lazy.force Path.package_dir) *) (* FIXME *) ~package_dir:(Sys.getcwd ()) module_system) (* FIXME: https://github.com/melange-re/melange/issues/559 *) @@ -150,15 +148,15 @@ let string_of_module_id ~package_info ~output_info let js_file = js_name_of_modulename (Ident.name dep_module_id.id) - case Ext_js_suffix.default + case Js_suffix.default in match Initialization.find_in_path_exn js_file with | file -> let basename = Filename.basename file in let dirname = Filename.dirname file in - Ext_path.node_rebase_file - ~from:(Ext_path.absolute_cwd_path output_dir) - ~to_:(Ext_path.absolute_cwd_path dirname) + Path.node_rebase_file + ~from:(Path.absolute_cwd_path output_dir) + ~to_:(Path.absolute_cwd_path dirname) basename | exception Not_found -> Mel_exception.error (Js_not_found js_file)) )) diff --git a/jscomp/core/js_packages_info.ml b/jscomp/core/js_packages_info.ml index 442514e46c..10b760c787 100644 --- a/jscomp/core/js_packages_info.ml +++ b/jscomp/core/js_packages_info.ml @@ -22,15 +22,12 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let ( // ) = Ext_path.( // ) +open Import -type file_case = Uppercase | Lowercase - -type output_info = { - module_system : Ext_module_system.t; - suffix : Ext_js_suffix.t; -} +let ( // ) = Path.( // ) +type file_case = Uppercase | Lowercase +type output_info = { module_system : Module_system.t; suffix : Js_suffix.t } type batch_info = { path : string; output_info : output_info } type package_info = @@ -59,8 +56,8 @@ let from_name ?(t = empty) (name : string) : t = { t with name = Some name } let dump_output_info fmt { module_system; suffix } = Format.fprintf fmt "%s %s" - (Ext_module_system.to_string module_system) - (Ext_js_suffix.to_string suffix) + (Module_system.to_string module_system) + (Js_suffix.to_string suffix) let dump_package_info (fmt : Format.formatter) ({ path = name; output_info } : batch_info) = @@ -104,8 +101,7 @@ type info_query = (* Note that package-name has to be exactly the same as npm package name, otherwise the path resolution will be wrong *) -let query_package_infos (t : t) (module_system : Ext_module_system.t) : - info_query = +let query_package_infos (t : t) (module_system : Module_system.t) : info_query = match t.info with | Empty -> ( match t.name with Some _ -> Package_not_found | None -> Package_script) @@ -124,8 +120,8 @@ let query_package_infos (t : t) (module_system : Ext_module_system.t) : | Batch_compilation module_systems -> ( match List.find - (fun k -> - Ext_module_system.compatible ~dep:k.output_info.module_system + ~f:(fun k -> + Module_system.compatible ~dep:k.output_info.module_system module_system) module_systems with @@ -142,12 +138,11 @@ let query_package_infos (t : t) (module_system : Ext_module_system.t) : | None -> Package_script)) let get_js_path (module_systems : batch_info list) - (module_system : Ext_module_system.t) : string = + (module_system : Module_system.t) : string = let k = List.find - (fun k -> - Ext_module_system.compatible ~dep:k.output_info.module_system - module_system) + ~f:(fun k -> + Module_system.compatible ~dep:k.output_info.module_system module_system) module_systems in k.path @@ -168,7 +163,7 @@ let add_npm_package_path (t : t) ?module_name s = | Batch_compilation xs -> xs in let new_info = - match Ext_string.split ~keep_empty:true s ':' with + match String.split ~keep_empty:true s ':' with | [ path ] -> (* `--mel-package-output just/the/path/segment' means module system / js extension to come later; separate emission *) @@ -182,9 +177,8 @@ let add_npm_package_path (t : t) ?module_name s = path; output_info = { - module_system = - Ext_module_system.of_string_exn module_system; - suffix = Ext_js_suffix.default; + module_system = Module_system.of_string_exn module_system; + suffix = Js_suffix.default; }; } :: existing) @@ -196,9 +190,8 @@ let add_npm_package_path (t : t) ?module_name s = path; output_info = { - module_system = - Ext_module_system.of_string_exn module_system; - suffix = Ext_js_suffix.of_string suffix; + module_system = Module_system.of_string_exn module_system; + suffix = Js_suffix.of_string suffix; }; } :: existing) @@ -229,13 +222,13 @@ let module_case t ~output_prefix = | false -> Uppercase let default_output_info = - { suffix = Ext_js_suffix.default; module_system = Ext_module_system.default } + { suffix = Js_suffix.default; module_system = Module_system.default } let assemble_output_info (t : t) = match t.info with | Empty -> [ default_output_info ] | Batch_compilation infos -> - List.map (fun { output_info; _ } -> output_info) infos + List.map ~f:(fun { output_info; _ } -> output_info) infos | Separate_emission _ -> (* Combination of `-mel-package-output -just-dir` and the absence of `-mel-module-type` *) diff --git a/jscomp/core/js_packages_info.mli b/jscomp/core/js_packages_info.mli index 920c052e1f..73f34025b1 100644 --- a/jscomp/core/js_packages_info.mli +++ b/jscomp/core/js_packages_info.mli @@ -22,11 +22,9 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type output_info = { - module_system : Ext_module_system.t; - suffix : Ext_js_suffix.t; -} +open Import +type output_info = { module_system : Module_system.t; suffix : Js_suffix.t } type t val same_package_by_name : t -> t -> bool @@ -53,8 +51,8 @@ type info_query = | Package_not_found | Package_found of path_info -val get_output_dir : t -> package_dir:string -> Ext_module_system.t -> string -val query_package_infos : t -> Ext_module_system.t -> info_query +val get_output_dir : t -> package_dir:string -> Module_system.t -> string +val query_package_infos : t -> Module_system.t -> info_query (* Note here we compare the package info by order in theory, we can compare it by set semantics *) diff --git a/jscomp/core/js_packages_state.mli b/jscomp/core/js_packages_state.mli index 6aad9aa858..1eeb166002 100644 --- a/jscomp/core/js_packages_state.mli +++ b/jscomp/core/js_packages_state.mli @@ -22,9 +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. *) +open Import + val set_package_name : string -> unit val get_packages_info : unit -> Js_packages_info.t val get_packages_info_for_cmj : unit -> Js_packages_info.t val update_npm_package_path : ?module_name:string -> string -> unit -val set_output_info : suffix:Ext_js_suffix.t -> Ext_module_system.t -> unit +val set_output_info : suffix:Js_suffix.t -> Module_system.t -> unit val get_output_info : unit -> Js_packages_info.output_info list diff --git a/jscomp/core/js_pass_debug.dev.ml b/jscomp/core/js_pass_debug.dev.ml index 921e5b7515..385381d974 100644 --- a/jscomp/core/js_pass_debug.dev.ml +++ b/jscomp/core/js_pass_debug.dev.ml @@ -22,17 +22,18 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + let log_counter = ref 0 let dump name (prog : J.program) = let () = if !Js_config.diagnose then ( incr log_counter; - Ext_log.warn ~loc:(Loc.of_pos __POS__) - (Pp.textf "@[[TIME:]%s: %f@]@." name (Sys.time () *. 1000.)); + Ext_log.dwarn ~__POS__ "\n@[[TIME:]%s: %f@]@." name (Sys.time () *. 1000.); let oc = let fn = - Ext_filename.new_extension !Location.input_name + Filename.new_extension !Location.input_name (Printf.sprintf ".%02d.%s.jsx" !log_counter name) in open_out_bin fn diff --git a/jscomp/core/js_pass_flatten_and_mark_dead.ml b/jscomp/core/js_pass_flatten_and_mark_dead.ml index e2b196bb2c..7eaea2adff 100644 --- a/jscomp/core/js_pass_flatten_and_mark_dead.ml +++ b/jscomp/core/js_pass_flatten_and_mark_dead.ml @@ -22,6 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import module E = Js_exp_make module S = Js_stmt_make @@ -30,16 +31,16 @@ type meta_info = Info of J.ident_info | Recursive let super = Js_record_iter.super let mark_dead_code (js : J.program) : J.program = - let ident_use_stats : meta_info Hash_ident.t = Hash_ident.create 17 in + let ident_use_stats : meta_info Ident.Hash.t = Ident.Hash.create 17 in let mark_dead = { super with ident = (fun _ ident -> - match Hash_ident.find_opt ident_use_stats ident with + match Ident.Hash.find_opt ident_use_stats ident with | None -> (* First time *) - Hash_ident.add ident_use_stats ident Recursive + Ident.Hash.add ident_use_stats ident Recursive (* recursive identifiers *) | Some Recursive -> () | Some (Info x) -> Js_op_util.update_used_stats x Used); @@ -63,13 +64,13 @@ let mark_dead_code (js : J.program) : J.program = Js_analyzer.no_side_effect_expression x in let () = - if Set_ident.mem js.export_set ident then + if Ident.Set.mem js.export_set ident then Js_op_util.update_used_stats ident_info Exported in - match Hash_ident.find_opt ident_use_stats ident with + match Ident.Hash.find_opt ident_use_stats ident with | Some Recursive -> Js_op_util.update_used_stats ident_info Used; - Hash_ident.replace ident_use_stats ident (Info ident_info) + Ident.Hash.replace ident_use_stats ident (Info ident_info) | Some (Info _) -> (* check [camlinternlFormat,box_type] inlined twice FIXME: seems we have redeclared identifiers @@ -78,13 +79,13 @@ let mark_dead_code (js : J.program) : J.program = (* assert false *) | None -> (* First time *) - Hash_ident.add ident_use_stats ident (Info ident_info); + Ident.Hash.add ident_use_stats ident (Info ident_info); Js_op_util.update_used_stats ident_info (if pure then Scanning_pure else Scanning_non_pure))); } in mark_dead.program mark_dead js; - Hash_ident.iter ident_use_stats (fun _id (info : meta_info) -> + Ident.Hash.iter ident_use_stats (fun _id (info : meta_info) -> match info with | Info ({ used_stats = Scanning_pure } as info) -> Js_op_util.update_used_stats info Dead_pure @@ -149,9 +150,9 @@ let mark_dead_code (js : J.program) : J.program = let super = Js_record_map.super let add_substitue substitution (ident : Ident.t) (e : J.expression) = - Hash_ident.replace substitution ident e + Ident.Hash.replace substitution ident e -let subst_map (substitution : J.expression Hash_ident.t) = +let subst_map (substitution : J.expression Ident.Hash.t) = { super with statement = @@ -194,7 +195,7 @@ let subst_map (substitution : J.expression Hash_ident.t) = *) let _, e, bindings = List.fold_left - (fun (i, e, acc) (x : J.expression) -> + ~f:(fun (i, e, acc) (x : J.expression) -> match x.expression_desc with | Var _ | Number _ | Str _ | Unicode _ | J.Bool _ | Undefined -> @@ -209,7 +210,7 @@ let subst_map (substitution : J.expression Hash_ident.t) = *) let v' = self.expression self x in let match_id = - Ext_ident.create + Ident.create (Ident.name ident ^ "_" ^ match tag_info with @@ -225,7 +226,7 @@ let subst_map (substitution : J.expression Hash_ident.t) = | _ -> Printf.sprintf "%d" i) in (i + 1, E.var match_id :: e, (match_id, v') :: acc)) - (0, [], []) ls + ~init:(0, [], []) ls in let e = { @@ -249,7 +250,7 @@ let subst_map (substitution : J.expression Hash_ident.t) = S.block (List.rev_append (List.map - (fun (id, v) -> S.define_variable ~kind:Strict id v) + ~f:(fun (id, v) -> S.define_variable ~kind:Strict id v) bindings) [ original_statement ])) | _ -> super.statement self v); @@ -260,7 +261,7 @@ let subst_map (substitution : J.expression Hash_ident.t) = ( { expression_desc = Var (Id id); _ }, { expression_desc = Number (Int { i; _ }); _ } ) | Static_index ({ expression_desc = Var (Id id); _ }, _, Some i) -> ( - match Hash_ident.find_opt substitution id with + match Ident.Hash.find_opt substitution id with | Some { expression_desc = Caml_block (ls, Immutable, _, _); _ } -> ( (* user program can be wrong, we should not @@ -285,7 +286,7 @@ let subst_map (substitution : J.expression Hash_ident.t) = *) let program (js : J.program) = - let obj = subst_map (Hash_ident.create 32) in + let obj = subst_map (Ident.Hash.create 32) in let js = obj.program obj js in mark_dead_code js (* |> mark_dead_code *) diff --git a/jscomp/core/js_pass_get_used.ml b/jscomp/core/js_pass_get_used.ml index 3691db06f1..4de7dc2d8a 100644 --- a/jscomp/core/js_pass_get_used.ml +++ b/jscomp/core/js_pass_get_used.ml @@ -22,12 +22,14 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let add_use stats id = Hash_ident.add_or_update stats id 1 ~update:succ +open Import + +let add_use stats id = Ident.Hash.add_or_update stats id 1 ~update:succ let post_process_stats my_export_set - (defined_idents : J.variable_declaration Hash_ident.t) stats = - Hash_ident.iter defined_idents (fun ident v -> - if Set_ident.mem my_export_set ident then + (defined_idents : J.variable_declaration Ident.Hash.t) stats = + Ident.Hash.iter defined_idents (fun ident v -> + if Ident.Set.mem my_export_set ident then Js_op_util.update_used_stats v.ident_info Exported else let pure = @@ -35,7 +37,7 @@ let post_process_stats my_export_set | None -> false (* can not happen *) | Some x -> Js_analyzer.no_side_effect_expression x in - match Hash_ident.find_opt stats ident with + match Ident.Hash.find_opt stats ident with | None -> Js_op_util.update_used_stats v.ident_info (if pure then Dead_pure else Dead_non_pure) @@ -52,22 +54,22 @@ let post_process_stats my_export_set *) let super = Js_record_iter.super -let count_collects (* collect used status*) (stats : int Hash_ident.t) +let count_collects (* collect used status*) (stats : int Ident.Hash.t) (* collect all def sites *) - (defined_idents : J.variable_declaration Hash_ident.t) = + (defined_idents : J.variable_declaration Ident.Hash.t) = { super with variable_declaration = (fun self ({ ident; value; property = _; ident_info = _ } as v) -> - Hash_ident.add defined_idents ident v; + Ident.Hash.add defined_idents ident v; match value with None -> () | Some x -> self.expression self x); ident = (fun _ id -> add_use stats id); } -let get_stats (program : J.program) : J.variable_declaration Hash_ident.t = - let stats : int Hash_ident.t = Hash_ident.create 83 in - let defined_idents : J.variable_declaration Hash_ident.t = - Hash_ident.create 83 +let get_stats (program : J.program) : J.variable_declaration Ident.Hash.t = + let stats : int Ident.Hash.t = Ident.Hash.create 83 in + let defined_idents : J.variable_declaration Ident.Hash.t = + Ident.Hash.create 83 in let my_export_set = program.export_set in let obj = count_collects stats defined_idents in diff --git a/jscomp/core/js_pass_get_used.mli b/jscomp/core/js_pass_get_used.mli index e62d7ba261..293b2f534f 100644 --- a/jscomp/core/js_pass_get_used.mli +++ b/jscomp/core/js_pass_get_used.mli @@ -1,5 +1,5 @@ (* Copyright (C) 2020- Authors of ReScript - * + * * 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,9 +17,11 @@ * 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. *) -val get_stats : J.program -> J.variable_declaration Hash_ident.t +open Import + +val get_stats : J.program -> J.variable_declaration Ident.Hash.t diff --git a/jscomp/core/js_pass_scope.ml b/jscomp/core/js_pass_scope.ml index e1dce4ab50..899963e1fe 100644 --- a/jscomp/core/js_pass_scope.ml +++ b/jscomp/core/js_pass_scope.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (* Base line @@ -92,21 +94,21 @@ ]} *) type state = { - defined_idents : Set_ident.t; - used_idents : Set_ident.t; - loop_mutable_values : Set_ident.t; - mutable_values : Set_ident.t; - closured_idents : Set_ident.t; + defined_idents : Ident.Set.t; + used_idents : Ident.Set.t; + loop_mutable_values : Ident.Set.t; + mutable_values : Ident.Set.t; + closured_idents : Ident.Set.t; in_loop : bool; } let init_state = { - defined_idents = Set_ident.empty; - used_idents = Set_ident.empty; - loop_mutable_values = Set_ident.empty; - mutable_values = Set_ident.empty; - closured_idents = Set_ident.empty; + defined_idents = Ident.Set.empty; + used_idents = Ident.Set.empty; + loop_mutable_values = Ident.Set.empty; + mutable_values = Ident.Set.empty; + closured_idents = Ident.Set.empty; in_loop = false; } @@ -116,18 +118,18 @@ let with_in_loop (st : state) b = let add_loop_mutable_variable (st : state) id = { st with - loop_mutable_values = Set_ident.add st.loop_mutable_values id; - mutable_values = Set_ident.add st.mutable_values id; + loop_mutable_values = Ident.Set.add st.loop_mutable_values id; + mutable_values = Ident.Set.add st.mutable_values id; } let add_mutable_variable (st : state) id = - { st with mutable_values = Set_ident.add st.mutable_values id } + { st with mutable_values = Ident.Set.add st.mutable_values id } let add_defined_ident (st : state) id = - { st with defined_idents = Set_ident.add st.defined_idents id } + { st with defined_idents = Ident.Set.add st.defined_idents id } let add_used_ident (st : state) id = - { st with used_idents = Set_ident.add st.used_idents id } + { st with used_idents = Ident.Set.add st.used_idents id } let super = Js_record_fold.super @@ -146,7 +148,7 @@ let record_scope_pass = *) (* Note that [used_idents] is not complete it ignores some locally defined idents *) - let param_set = Set_ident.of_list params in + let param_set = Ident.Set.of_list params in let { defined_idents = defined_idents'; used_idents = used_idents'; @@ -156,7 +158,7 @@ let record_scope_pass = { init_state with mutable_values = - Set_ident.of_list (Js_fun_env.get_mutable_params params env); + Ident.Set.of_list (Js_fun_env.get_mutable_params params env); } block in @@ -164,12 +166,12 @@ let record_scope_pass = obj#get_defined_idents, obj#get_used_idents in *) (* mark which param is used *) params - |> List.iteri (fun i v -> - if not (Set_ident.mem used_idents' v) then + |> List.iteri ~f:(fun i v -> + if not (Ident.Set.mem used_idents' v) then Js_fun_env.mark_unused env i); let closured_idents' = (* pass param_set down *) - Set_ident.(diff used_idents' (union defined_idents' param_set)) + Ident.Set.(diff used_idents' (union defined_idents' param_set)) in (* Noe that we don't know which variables are exactly mutable yet .. @@ -177,16 +179,16 @@ let record_scope_pass = *) Js_fun_env.set_unbounded env closured_idents'; let lexical_scopes = - Set_ident.(inter closured_idents' state.loop_mutable_values) + Ident.Set.(inter closured_idents' state.loop_mutable_values) in Js_fun_env.set_lexical_scope env lexical_scopes; (* tailcall , note that these varibles are used in another pass *) { state with - used_idents = Set_ident.union state.used_idents closured_idents'; + used_idents = Ident.Set.union state.used_idents closured_idents'; (* There is a bug in ocaml -dsource*) closured_idents = - Set_ident.union state.closured_idents closured_idents'; + Ident.Set.union state.closured_idents closured_idents'; } | _ -> ( let obj = super.expression self state x in @@ -225,11 +227,11 @@ let record_scope_pass = match x.expression_desc with | Fun _ | Number _ | Str _ | Unicode _ -> state | _ -> - (* if Set_ident.(is_empty @@ *) + (* if Ident.Set.(is_empty @@ *) (* inter self#get_mutable_values *) (* ( ({< *) - (* defined_idents = Set_ident.empty; *) - (* used_idents = Set_ident.empty; *) + (* defined_idents = Ident.Set.empty; *) + (* used_idents = Ident.Set.empty; *) (* >} # expression x) # get_used_idents)) then *) (* (\* FIXME: still need to check expression is pure or not*\) *) (* self *) @@ -256,11 +258,11 @@ let record_scope_pass = super.statement self { in_loop = true; - loop_mutable_values = Set_ident.singleton loop_id; - used_idents = Set_ident.empty; + loop_mutable_values = Ident.Set.singleton loop_id; + used_idents = Ident.Set.empty; (* TODO: if unused, can we generate better code? *) - defined_idents = Set_ident.singleton loop_id; - closured_idents = Set_ident.empty; + defined_idents = Ident.Set.singleton loop_id; + closured_idents = Ident.Set.empty; (* Think about nested for blocks *) (* Invariant: Finish id is never used *) mutable_values = state.mutable_values; @@ -273,7 +275,7 @@ let record_scope_pass = (* let defined_idents', used_idents', closured_idents' = obj#get_defined_idents, obj#get_used_idents, obj#get_closured_idents in *) let lexical_scope = - Set_ident.( + Ident.Set.( inter (diff closured_idents' defined_idents') state.loop_mutable_values) @@ -282,20 +284,20 @@ let record_scope_pass = (* set scope *) { state with - used_idents = Set_ident.union state.used_idents used_idents'; + used_idents = Ident.Set.union state.used_idents used_idents'; (* walk around ocaml -dsource bug {[ - Set_ident.(union used_idents used_idents) + Ident.Set.(union used_idents used_idents) ]} *) defined_idents = - Set_ident.union state.defined_idents defined_idents'; + Ident.Set.union state.defined_idents defined_idents'; (* TODO: if we our generated code also follow lexical scope, this is not necessary ; [varaibles] are mutable or not is known at definition *) closured_idents = - Set_ident.union state.closured_idents lexical_scope; + Ident.Set.union state.closured_idents lexical_scope; } | While (_label, pred, body, _env) -> with_in_loop @@ -316,19 +318,19 @@ let record_scope_pass = *) { state with - used_idents = Set_ident.add state.used_idents x; - defined_idents = Set_ident.add state.defined_idents x; + used_idents = Ident.Set.add state.used_idents x; + defined_idents = Ident.Set.add state.defined_idents x; }); for_ident = (fun _ state x -> { state with - loop_mutable_values = Set_ident.add state.loop_mutable_values x; + loop_mutable_values = Ident.Set.add state.loop_mutable_values x; }); ident = (fun _ state x -> - if Set_ident.mem state.defined_idents x then state - else { state with used_idents = Set_ident.add state.used_idents x }); + if Ident.Set.mem state.defined_idents x then state + else { state with used_idents = Ident.Set.add state.used_idents x }); } let program js = diff --git a/jscomp/core/js_pass_scope.mli b/jscomp/core/js_pass_scope.mli index 20758cab1c..e5606429e2 100644 --- a/jscomp/core/js_pass_scope.mli +++ b/jscomp/core/js_pass_scope.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,11 +17,13 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (** A module to do scope analysis over JS IR *) -val program : J.program -> Set_ident.t +val program : J.program -> Ident.Set.t diff --git a/jscomp/core/js_pass_tailcall_inline.ml b/jscomp/core/js_pass_tailcall_inline.ml index 5c5b1aa3da..d6c276e0e2 100644 --- a/jscomp/core/js_pass_tailcall_inline.ml +++ b/jscomp/core/js_pass_tailcall_inline.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (* When we inline a function call, if we don't do a beta-reduction immediately, there is a chance that it is ignored, (we can not assume that each pass is robust enough) @@ -37,8 +39,8 @@ module S = Js_stmt_make let super = Js_record_map.super -let substitute_variables (map : Ident.t Map_ident.t) = - { super with ident = (fun _ id -> Map_ident.find_default map id id) } +let substitute_variables (map : Ident.t Ident.Map.t) = + { super with ident = (fun _ id -> Ident.Map.find_default map id id) } (* 1. recursive value ? let rec x = 1 :: x non-terminating @@ -84,21 +86,21 @@ let inline_call = let map, block = if immutable_list = [] then List.fold_right2 - (fun param (arg : J.expression) (map, acc) -> + ~f:(fun param (arg : J.expression) (map, acc) -> match arg.expression_desc with - | Var (Id id) -> (Map_ident.add map param id, acc) + | Var (Id id) -> (Ident.Map.add map param id, acc) | _ -> (map, S.define_variable ~kind:Variable param arg :: acc)) params args - (Map_ident.empty, processed_blocks) + ~init:(Ident.Map.empty, processed_blocks) else fold_right3 params args immutable_list - ~init:(Map_ident.empty, processed_blocks) + ~init:(Ident.Map.empty, processed_blocks) ~f:(fun param arg mask (map, acc) -> match (mask, arg.expression_desc) with - | true, Var (Id id) -> (Map_ident.add map param id, acc) + | true, Var (Id id) -> (Ident.Map.add map param id, acc) | _ -> (map, S.define_variable ~kind:Variable param arg :: acc)) in - if Map_ident.is_empty map then block + if Ident.Map.is_empty map then block else let obj = substitute_variables map in obj.block obj block @@ -130,8 +132,8 @@ let inline_call = *) let super = Js_record_map.super -let subst (export_set : Set_ident.t) - (stats : J.variable_declaration Hash_ident.t) = +let subst (export_set : Ident.Set.t) + (stats : J.variable_declaration Ident.Hash.t) = { super with statement = @@ -151,7 +153,7 @@ let subst (export_set : Set_ident.t) does rely on this (otherwise, when you do beta-reduction you have to regenerate names) *) let v = super.variable_declaration self v in - Hash_ident.add stats ident v; + Ident.Hash.add stats ident v; (* see #278 before changes *) v); block = @@ -165,10 +167,10 @@ let subst (export_set : Set_ident.t) comment = _; } as st) :: rest -> ( - let is_export = Set_ident.mem export_set vd.ident in + let is_export = Ident.Set.mem export_set vd.ident in if is_export then self.statement self st :: self.block self rest else - match Hash_ident.find_opt stats vd.ident with + match Ident.Hash.find_opt stats vd.ident with (* TODO: could be improved as [mem] *) | None -> if Js_analyzer.no_side_effect_expression v then @@ -187,7 +189,7 @@ let subst (export_set : Set_ident.t) _; } as st); ] -> ( - match Hash_ident.find_opt stats id with + match Ident.Hash.find_opt stats id with | Some ({ value = @@ -205,7 +207,7 @@ let subst (export_set : Set_ident.t) ident_info = { used_stats = Once_pure }; ident = _; } as v) - when Ext_list.same_length params args -> + when List.same_length params args -> Js_op_util.update_used_stats v.ident_info Dead_pure; let no_tailcall = Js_fun_env.no_tailcall env in let processed_blocks = @@ -240,7 +242,7 @@ let subst (export_set : Set_ident.t) _; }; ] - when Ext_list.same_length params args -> + when List.same_length params args -> let no_tailcall = Js_fun_env.no_tailcall env in let processed_blocks = self.block self block diff --git a/jscomp/core/js_pass_tailcall_inline.mli b/jscomp/core/js_pass_tailcall_inline.mli index d9d0e99b9e..315ea15a1b 100644 --- a/jscomp/core/js_pass_tailcall_inline.mli +++ b/jscomp/core/js_pass_tailcall_inline.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,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. *) (** This pass detect functions used once and if it is used in used - in the tail position, it will get inlined, this will help + in the tail position, it will get inlined, this will help remove some common use cases like This {[ - let length x = - let rec aux n x = - match x with - | [] -> n + let length x = + let rec aux n x = + match x with + | [] -> n | _ :: rest -> aux (n + 1) rest in - aux 0 x - ]} + aux 0 x + ]} *) val tailcall_inline : J.program -> J.program diff --git a/jscomp/core/js_shake.ml b/jscomp/core/js_shake.ml index 884312e190..4976233459 100644 --- a/jscomp/core/js_shake.ml +++ b/jscomp/core/js_shake.ml @@ -22,23 +22,24 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(** we also need make it complete - *) +open Import + +(** we also need make it complete *) let get_initial_exports count_non_variable_declaration_statement - (export_set : Set_ident.t) (block : J.block) = + (export_set : Ident.Set.t) (block : J.block) = let result = List.fold_left - (fun acc (st : J.statement) -> + ~f:(fun acc (st : J.statement) -> match st.statement_desc with | Variable { ident; value; _ } -> ( - if Set_ident.mem acc ident then + if Ident.Set.mem acc ident then match value with | None -> acc | Some x -> (* If not a function, we have to calcuate again and again TODO: add hashtbl for a cache *) - Set_ident.( + Ident.Set.( union (Js_analyzer.free_variables_of_expression x) acc) else match value with @@ -46,7 +47,7 @@ let get_initial_exports count_non_variable_declaration_statement | Some x -> if Js_analyzer.no_side_effect_expression x then acc else - Set_ident.( + Ident.Set.( union (Js_analyzer.free_variables_of_expression x) (add acc ident))) @@ -57,47 +58,30 @@ let get_initial_exports count_non_variable_declaration_statement || not count_non_variable_declaration_statement then acc else - Set_ident.(union (Js_analyzer.free_variables_of_statement st) acc)) - export_set block + Ident.Set.(union (Js_analyzer.free_variables_of_statement st) acc)) + ~init:export_set block in - (result, Set_ident.(diff result export_set)) + (result, Ident.Set.(diff result export_set)) let shake_program (program : J.program) = let shake_block block export_set = let block = List.rev @@ Js_analyzer.rev_toplevel_flatten block in - let loop block export_set : Set_ident.t = + let loop block export_set : Ident.Set.t = let rec aux acc block = let result, diff = get_initial_exports false acc block in - (* let _d () = *) - (* if Ext_string.ends_with program.name debug_file then *) - (* begin *) - (* Ext_log.err "@[%a@]@." Set_ident.print result ; *) - (* end *) - (* in *) - if Set_ident.is_empty diff then result else aux result block + if Ident.Set.is_empty diff then result else aux result block in let first_iteration, delta = get_initial_exports true export_set block in - - (* let _d () = *) - (* if Ext_string.ends_with program.name debug_file then *) - (* begin *) - (* Ext_log.err "@[%a@ %a@]@." *) - (* Set_ident.print first_iteration *) - (* Set_ident.print delta (\* TODO: optimization, don't add persistent variables *\) *) - (* ; *) - (* Ext_log.err "init ---- @." *) - (* end *) - (* in *) - if not @@ Set_ident.is_empty delta then aux first_iteration block + if not @@ Ident.Set.is_empty delta then aux first_iteration block else first_iteration in let really_set = loop block export_set in List.fold_right - (fun (st : J.statement) acc -> + ~f:(fun (st : J.statement) acc -> match st.statement_desc with | Variable { ident; value; _ } -> ( - if Set_ident.mem really_set ident then st :: acc + if Ident.Set.mem really_set ident then st :: acc else match value with | None -> acc @@ -106,7 +90,6 @@ let shake_program (program : J.program) = else st :: acc) | _ -> if Js_analyzer.no_side_effect_statement st then acc else st :: acc) - block [] + block ~init:[] in - { program with block = shake_block program.block program.export_set } diff --git a/jscomp/core/js_shake.mli b/jscomp/core/js_shake.mli index bdcfd145d9..a02033af02 100644 --- a/jscomp/core/js_shake.mli +++ b/jscomp/core/js_shake.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. *) (** A module to shake JS IR - - Tree shaking is not going to change the closure + + Tree shaking is not going to change the closure *) val shake_program : J.program -> J.program diff --git a/jscomp/core/lam.ml b/jscomp/core/lam.ml index 6ab819d3b4..fb8ff1ca3d 100644 --- a/jscomp/core/lam.ml +++ b/jscomp/core/lam.ml @@ -22,6 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import module Constant = Melange_ffi.Lam_constant module Methname = Melange_ffi.Lam_methname module Tag_info = Melange_ffi.Lam_tag_info @@ -175,7 +176,7 @@ let inner_map (l : t) (f : t -> X.t) : X.t = ((* Obj.magic *) l : X.t) | Lapply { ap_func; ap_args; ap_info } -> let ap_func = f ap_func in - let ap_args = List.map f ap_args in + let ap_args = List.map ~f ap_args in Lapply { ap_func; ap_args; ap_info } | Lfunction { body; arity; params; attr } -> let body = f body in @@ -190,11 +191,11 @@ let inner_map (l : t) (f : t -> X.t) : X.t = Lmutlet (id, arg, body) | Lletrec (decl, body) -> let body = f body in - let decl = Ext_list.map_snd decl f in + let decl = List.map_snd decl f in Lletrec (decl, body) | Lglobal_module _ -> (l : X.t) | Lprim { args; primitive; loc } -> - let args = List.map f args in + let args = List.map ~f args in Lprim { args; primitive; loc } | Lswitch ( arg, @@ -207,8 +208,8 @@ let inner_map (l : t) (f : t -> X.t) : X.t = sw_names; } ) -> let arg = f arg in - let sw_consts = Ext_list.map_snd sw_consts f in - let sw_blocks = Ext_list.map_snd sw_blocks f in + let sw_consts = List.map_snd sw_consts f in + let sw_blocks = List.map_snd sw_blocks f in let sw_failaction = Option.map f sw_failaction in Lswitch ( arg, @@ -222,11 +223,11 @@ let inner_map (l : t) (f : t -> X.t) : X.t = } ) | Lstringswitch (arg, cases, default) -> let arg = f arg in - let cases = Ext_list.map_snd cases f in + let cases = List.map_snd cases f in let default = Option.map f default in Lstringswitch (arg, cases, default) | Lstaticraise (id, args) -> - let args = List.map f args in + let args = List.map ~f args in Lstaticraise (id, args) | Lstaticcatch (e1, vars, e2) -> let e1 = f e1 in @@ -260,7 +261,7 @@ let inner_map (l : t) (f : t -> X.t) : X.t = | Lsend (k, met, obj, args, loc) -> let met = f met in let obj = f obj in - let args = List.map f args in + let args = List.map ~f args in Lsend (k, met, obj, args, loc) | Lifused (v, e) -> Lifused (v, f e) @@ -350,8 +351,8 @@ let rec apply fn args (ap_info : ap_info) : t = Lsequence (Lprim { primitive_call with args; loc = ap_info.ap_loc }, const) | exception _ -> Lapply { ap_func = fn; ap_args = args; ap_info }) - (* | Lfunction {params;body} when Ext_list.same_length params args -> - Ext_list.fold_right2 (fun p arg acc -> + (* | Lfunction {params;body} when List.same_length params args -> + List.fold_right2 (fun p arg acc -> Llet(Strict,p,arg,acc) ) params args body *) (* TODO: more rigirous analysis on [let_kind] *) @@ -408,7 +409,7 @@ let rec eq_approx (l1 : t) (l2 : t) = match l2 with | Lstringswitch (arg2, patterns2, default2) -> eq_approx arg arg2 && eq_option default default2 - && Ext_list.for_all2_no_exn patterns patterns2 + && List.for_all2_no_exn patterns patterns2 (fun ((k : string), v) (k2, v2) -> k = k2 && eq_approx v v2) | _ -> false) | Lfunction _ @@ -428,7 +429,7 @@ and eq_option l1 l2 = | None -> l2 = None | Some l1 -> ( match l2 with Some l2 -> eq_approx l1 l2 | None -> false) -and eq_approx_list ls ls1 = Ext_list.for_all2_no_exn ls ls1 eq_approx +and eq_approx_list ls ls1 = List.for_all2_no_exn ls ls1 eq_approx let assoc_with_opt_default ~default i xs = match List.assoc i xs with @@ -458,7 +459,7 @@ let unit : t = Lconst Const_js_undefined let rec seq (a : t) b : t = match a with | Lprim { primitive = Pmakeblock _; args = x :: xs; _ } -> - seq (List.fold_left seq x xs) b + seq (List.fold_left ~f:seq ~init:x xs) b | Lprim { primitive = Pnull_to_opt | Pundefined_to_opt | Pnull_undefined_to_opt; diff --git a/jscomp/core/lam_arity.ml b/jscomp/core/lam_arity.ml index 7aa2465919..41a4405648 100644 --- a/jscomp/core/lam_arity.ml +++ b/jscomp/core/lam_arity.ml @@ -22,14 +22,13 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + type t = | Arity_info of int list * bool - (** - the last one means it can take any params later, - for an exception: it is (Determin (true,[], true)) - 1. approximation sound but not complete - - *) + (** The last one means it can take any params later, for an exception: it + is (Determin (true,[], true)) + 1. approximation sound but not complete *) | Arity_na let equal (x : t) y = @@ -38,7 +37,7 @@ let equal (x : t) y = | Arity_info (xs, a) -> ( match y with | Arity_info (ys, b) -> - a = b && Ext_list.for_all2_no_exn xs ys (fun x y -> x = y) + a = b && List.for_all2_no_exn xs ys (fun x y -> x = y) | Arity_na -> false) let pp = Format.fprintf diff --git a/jscomp/core/lam_arity_analysis.ml b/jscomp/core/lam_arity_analysis.ml index 1946c3b3c2..2d5be8c8ed 100644 --- a/jscomp/core/lam_arity_analysis.ml +++ b/jscomp/core/lam_arity_analysis.ml @@ -22,11 +22,13 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + let arity_of_var (meta : Lam_stats.t) (v : Ident.t) = (* for functional parameter, if it is a high order function, if it's not from function parameter, we should warn *) - match Hash_ident.find_opt meta.ident_tbl v with + match Ident.Hash.find_opt meta.ident_tbl v with | Some (FunctionId { arity; _ }) -> arity | Some _ | None -> Lam_arity.na @@ -122,12 +124,12 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) : Lam_arity.t = _; } ) -> all_lambdas meta - (let rest = List.map snd sw_consts @ List.map snd sw_blocks in + (let rest = List.map ~f:snd sw_consts @ List.map ~f:snd sw_blocks in match sw_failaction with None -> rest | Some x -> x :: rest) | Lstringswitch (_, sw, d) -> ( match d with - | None -> all_lambdas meta (List.map snd sw) - | Some v -> all_lambdas meta (v :: List.map snd sw)) + | None -> all_lambdas meta (List.map ~f:snd sw) + | Some v -> all_lambdas meta (v :: List.map ~f:snd sw)) | Lstaticcatch (_, _, handler) -> get_arity meta handler | Ltrywith (l1, _, l2) -> all_lambdas meta [ l1; l2 ] | Lifthenelse (_, l2, l3) -> all_lambdas meta [ l2; l3 ] diff --git a/jscomp/core/lam_beta_reduce.ml b/jscomp/core/lam_beta_reduce.ml index b6a1c22dc9..e86ed91c55 100644 --- a/jscomp/core/lam_beta_reduce.ml +++ b/jscomp/core/lam_beta_reduce.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (* A naive beta reduce would break the invariants of the optmization. @@ -51,39 +53,39 @@ let propogate_beta_reduce (meta : Lam_stats.t) (params : Ident.t list) | None -> let rest_bindings, rev_new_params = List.fold_left2 - (fun (rest_bindings, acc) old_param (arg : Lam.t) -> + ~f:(fun (rest_bindings, acc) old_param (arg : Lam.t) -> match arg with | Lconst _ | Lvar _ -> (rest_bindings, arg :: acc) | _ -> let p = Ident.rename old_param in ((p, arg) :: rest_bindings, Lam.var p :: acc)) - ([], []) params args + ~init:([], []) params args in let new_body = Lam_bounded_vars.rewrite - (Hash_ident.of_list2 (List.rev params) rev_new_params) + (Ident.Hash.of_list2 (List.rev params) rev_new_params) body in List.fold_right - (fun (param, arg) l -> + ~f:(fun (param, arg) l -> (match arg with | Lam.Lprim { primitive = Pmakeblock (_, _, Immutable); args; _ } -> - Hash_ident.replace meta.ident_tbl param + Ident.Hash.replace meta.ident_tbl param (Lam_util.kind_of_lambda_block args) | Lprim { primitive = Psome | Psome_not_nest; args = [ v ]; _ } -> - Hash_ident.replace meta.ident_tbl param (Normal_optional v) + Ident.Hash.replace meta.ident_tbl param (Normal_optional v) | _ -> ()); Lam_util.refine_let ~kind:Strict param arg l) - rest_bindings new_body + rest_bindings ~init:new_body let propogate_beta_reduce_with_map (meta : Lam_stats.t) - (map : Lam_var_stats.stats Map_ident.t) params body args = + (map : Lam_var_stats.stats Ident.Map.t) params body args = match Lam_beta_reduce_util.simple_beta_reduce params body args with | Some x -> x | None -> let rest_bindings, rev_new_params = List.fold_left2 - (fun (rest_bindings, acc) old_param arg -> + ~f:(fun (rest_bindings, acc) old_param arg -> match arg with | Lam.Lconst _ | Lvar _ -> (rest_bindings, arg :: acc) | Lglobal_module _ -> @@ -91,7 +93,7 @@ let propogate_beta_reduce_with_map (meta : Lam_stats.t) ((p, arg) :: rest_bindings, Lam.var p :: acc) | _ -> if Lam_analysis.no_side_effects arg then - match Map_ident.find_exn map old_param with + match Ident.Map.find_exn map old_param with | stat -> if Lam_var_stats.top_and_used_zero_or_one stat then (rest_bindings, arg :: acc) @@ -101,29 +103,29 @@ let propogate_beta_reduce_with_map (meta : Lam_stats.t) else let p = Ident.rename old_param in ((p, arg) :: rest_bindings, Lam.var p :: acc)) - ([], []) params args + ~init:([], []) params args in let new_body = Lam_bounded_vars.rewrite - (Hash_ident.of_list2 (List.rev params) rev_new_params) + (Ident.Hash.of_list2 (List.rev params) rev_new_params) body in List.fold_right - (fun (param, (arg : Lam.t)) l -> + ~f:(fun (param, (arg : Lam.t)) l -> (match arg with | Lprim { primitive = Pmakeblock (_, _, Immutable); args; _ } -> - Hash_ident.replace meta.ident_tbl param + Ident.Hash.replace meta.ident_tbl param (Lam_util.kind_of_lambda_block args) | Lprim { primitive = Psome | Psome_not_nest; args = [ v ]; _ } -> - Hash_ident.replace meta.ident_tbl param (Normal_optional v) + Ident.Hash.replace meta.ident_tbl param (Normal_optional v) | _ -> ()); Lam_util.refine_let ~kind:Strict param arg l) - rest_bindings new_body + rest_bindings ~init:new_body let no_names_beta_reduce params body args = match Lam_beta_reduce_util.simple_beta_reduce params body args with | Some x -> x | None -> List.fold_left2 - (fun l param arg -> Lam_util.refine_let ~kind:Strict param arg l) - body params args + ~f:(fun l param arg -> Lam_util.refine_let ~kind:Strict param arg l) + ~init:body params args diff --git a/jscomp/core/lam_beta_reduce.mli b/jscomp/core/lam_beta_reduce.mli index 96ca196c04..e24c40b987 100644 --- a/jscomp/core/lam_beta_reduce.mli +++ b/jscomp/core/lam_beta_reduce.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,11 +17,13 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (** Beta reduction of lambda IR *) val no_names_beta_reduce : Ident.t list -> Lam.t -> Lam.t list -> Lam.t @@ -37,8 +39,8 @@ val no_names_beta_reduce : Ident.t list -> Lam.t -> Lam.t list -> Lam.t *) (* - Refresh all the identifiers, - otherwise the identifier property can not be preserved, + Refresh all the identifiers, + otherwise the identifier property can not be preserved, the obvious example is parameter *) @@ -47,28 +49,28 @@ val propogate_beta_reduce : val propogate_beta_reduce_with_map : Lam_stats.t -> - Lam_var_stats.stats Map_ident.t -> + Lam_var_stats.stats Ident.Map.t -> Ident.t list -> Lam.t -> Lam.t list -> Lam.t -(** - {[ Lam_beta_reduce.propogate_beta_reduce_with_map +(** + {[ Lam_beta_reduce.propogate_beta_reduce_with_map meta param_map params body args]} [param_map] collect the usage of parameters, it's readonly - it can be produced by + it can be produced by - {[!Lam_analysis.free_variables meta.export_idents + {[!Lam_analysis.free_variables meta.export_idents (Lam_analysis.param_map_of_list params) body]} TODO: - replace [propogate_beta_reduce] with such implementation + replace [propogate_beta_reduce] with such implementation {[ - let propogate_beta_reduce meta params body args = - let (_, param_map) = - Lam_analysis.is_closed_with_map Set_ident.empty params body in - propogate_beta_reduce_with_map meta param_map params body args + let propogate_beta_reduce meta params body args = + let (_, param_map) = + Lam_analysis.is_closed_with_map Set_ident.empty params body in + propogate_beta_reduce_with_map meta param_map params body args ]} *) diff --git a/jscomp/core/lam_beta_reduce_util.ml b/jscomp/core/lam_beta_reduce_util.ml index 7bbe2d2a5f..41f8a378d9 100644 --- a/jscomp/core/lam_beta_reduce_util.ml +++ b/jscomp/core/lam_beta_reduce_util.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (* Principle: since in ocaml, the apply order is not specified rules: @@ -33,7 +35,7 @@ type value = { mutable used : bool; lambda : Lam.t } -let param_hash : _ Hash_ident.t = Hash_ident.create 20 +let param_hash : _ Ident.Hash.t = Ident.Hash.create 20 (* optimize cases like (fun f (a,b){ g (a,b,1)} (e0, e1)) @@ -52,7 +54,7 @@ let param_hash : _ Hash_ident.t = Hash_ident.create 20 let simple_beta_reduce params body args = let exception Not_simple_apply in let find_param_exn v opt = - match Hash_ident.find_opt param_hash v with + match Ident.Hash.find_opt param_hash v with | Some exp -> if exp.used then raise_notrace Not_simple_apply else exp.used <- true; exp.lambda @@ -71,21 +73,22 @@ let simple_beta_reduce params body args = (* catch a special case of primitives *) let () = List.iter2 - (fun p a -> Hash_ident.add param_hash p { lambda = a; used = false }) + ~f:(fun p a -> + Ident.Hash.add param_hash p { lambda = a; used = false }) params args in try let new_args = aux_exn [] ap_args in let result = - Hash_ident.fold param_hash (Lam.prim ~primitive ~args:new_args ap_loc) + Ident.Hash.fold param_hash (Lam.prim ~primitive ~args:new_args ap_loc) (fun _param stats acc -> let { lambda; used } = stats in if not used then Lam.seq lambda acc else acc) in - Hash_ident.clear param_hash; + Ident.Hash.clear param_hash; Some result with Not_simple_apply -> - Hash_ident.clear param_hash; + Ident.Hash.clear param_hash; None) | Lapply { @@ -98,7 +101,8 @@ let simple_beta_reduce params body args = } -> ( let () = List.iter2 - (fun p a -> Hash_ident.add param_hash p { lambda = a; used = false }) + ~f:(fun p a -> + Ident.Hash.add param_hash p { lambda = a; used = false }) params args in (*since we adde each param only once, @@ -112,14 +116,14 @@ let simple_beta_reduce params body args = match f with Lvar fn_name -> find_param_exn fn_name f | _ -> f in let result = - Hash_ident.fold param_hash (Lam.apply f new_args ap_info) + Ident.Hash.fold param_hash (Lam.apply f new_args ap_info) (fun _param stat acc -> let { lambda; used } = stat in if not used then Lam.seq lambda acc else acc) in - Hash_ident.clear param_hash; + Ident.Hash.clear param_hash; Some result with Not_simple_apply -> - Hash_ident.clear param_hash; + Ident.Hash.clear param_hash; None) | _ -> None diff --git a/jscomp/core/lam_bounded_vars.ml b/jscomp/core/lam_bounded_vars.ml index a4d2c13cbb..d998dd6c0a 100644 --- a/jscomp/core/lam_bounded_vars.ml +++ b/jscomp/core/lam_bounded_vars.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (* Given an [map], rewrite all let bound variables into new variables, note that the [map] is changed @@ -61,17 +63,17 @@ 2. number of invoked times 3. arguments are const or not *) -let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = +let rewrite (map : _ Ident.Hash.t) (lam : Lam.t) : Lam.t = let rebind i = let i' = Ident.rename i in - Hash_ident.add map i (Lam.var i'); + Ident.Hash.add map i (Lam.var i'); i' in (* order matters, especially for let bindings *) let rec option_map op = match op with None -> None | Some x -> Some (aux x) and aux (lam : Lam.t) : Lam.t = match lam with - | Lvar v | Lmutvar v -> Hash_ident.find_default map v lam + | Lvar v | Lmutvar v -> Ident.Hash.find_default map v lam | Llet (str, v, l1, l2) -> let v = rebind v in let l1 = aux l1 in @@ -84,19 +86,19 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = Lam.mutlet v l1 l2 | Lletrec (bindings, body) -> (*order matters see GPR #405*) - let vars = List.map (fun (k, _) -> rebind k) bindings in + let vars = List.map ~f:(fun (k, _) -> rebind k) bindings in let bindings = - List.map2 (fun var (_, l) -> (var, aux l)) vars bindings + List.map2 ~f:(fun var (_, l) -> (var, aux l)) vars bindings in let body = aux body in Lam.letrec bindings body | Lfunction { arity; params; body; attr } -> - let params = List.map rebind params in + let params = List.map ~f:rebind params in let body = aux body in Lam.function_ ~arity ~params ~body ~attr | Lstaticcatch (l1, (i, xs), l2) -> let l1 = aux l1 in - let xs = List.map rebind xs in + let xs = List.map ~f:rebind xs in let l2 = aux l2 in Lam.staticcatch l1 (i, xs) l2 | Lfor (ident, l1, l2, dir, l3) -> @@ -108,11 +110,11 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = | Lconst _ -> lam | Lprim { primitive; args; loc } -> (* here it makes sure that global vars are not rebound *) - Lam.prim ~primitive ~args:(List.map aux args) loc + Lam.prim ~primitive ~args:(List.map ~f:aux args) loc | Lglobal_module _ -> lam | Lapply { ap_func; ap_args; ap_info } -> let fn = aux ap_func in - let args = List.map aux ap_args in + let args = List.map ~f:aux ap_args in Lam.apply fn args ap_info | Lswitch ( l, @@ -127,8 +129,8 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = let l = aux l in Lam.switch l { - sw_consts = Ext_list.map_snd sw_consts aux; - sw_blocks = Ext_list.map_snd sw_blocks aux; + sw_consts = List.map_snd sw_consts aux; + sw_blocks = List.map_snd sw_blocks aux; sw_consts_full; sw_blocks_full; sw_failaction = option_map sw_failaction; @@ -136,8 +138,8 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = } | Lstringswitch (l, sw, d) -> let l = aux l in - Lam.stringswitch l (Ext_list.map_snd sw aux) (option_map d) - | Lstaticraise (i, ls) -> Lam.staticraise i (List.map aux ls) + Lam.stringswitch l (List.map_snd sw aux) (option_map d) + | Lstaticraise (i, ls) -> Lam.staticraise i (List.map ~f:aux ls) | Ltrywith (l1, v, l2) -> let l1 = aux l1 in let v = rebind v in @@ -160,12 +162,10 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = | Lsend (u, m, o, ll, v) -> let m = aux m in let o = aux o in - let ll = List.map aux ll in + let ll = List.map ~f:aux ll in Lam.send u m o ll v | Lifused (v, l) -> let l = aux l in Lam.ifused v l in aux lam - -(* let refresh lam = rewrite (Hash_ident.create 17 : Lam.t Hash_ident.t ) lam *) diff --git a/jscomp/core/lam_bounded_vars.mli b/jscomp/core/lam_bounded_vars.mli index 0eccffeaa9..5710d646ba 100644 --- a/jscomp/core/lam_bounded_vars.mli +++ b/jscomp/core/lam_bounded_vars.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,17 +17,13 @@ * 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. *) -val rewrite : Lam.t Hash_ident.t -> Lam.t -> Lam.t -(** [rewrite tbl lam] - Given a [tbl] to rewrite all bounded variables in [lam] -*) +open Import -(** refresh lambda to replace all bounded vars for new ones *) -(* val refresh : - Lam.t -> - Lam.t *) +val rewrite : Lam.t Ident.Hash.t -> Lam.t -> Lam.t +(** [rewrite tbl lam] + Given a [tbl] to rewrite all bounded variables in [lam] *) diff --git a/jscomp/core/lam_check.ml b/jscomp/core/lam_check.ml index 8df62226e1..4ee0ece595 100644 --- a/jscomp/core/lam_check.ml +++ b/jscomp/core/lam_check.ml @@ -22,33 +22,35 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (** checks 1. variables are not bound twice 2. all variables are of right scope *) let check file lam = - let defined_variables = Hash_set_ident.create 1000 in + let defined_variables = Ident.Hash_set.create 1000 in let success = ref true in let use (id : Ident.t) = - if not @@ Hash_set_ident.mem defined_variables id then ( + if not @@ Ident.Hash_set.mem defined_variables id then ( Format.fprintf Format.err_formatter "\n[SANITY]:%s/%d used before defined in %s@." (Ident.name id) - (Ext_ident.stamp id) file; + (Ident.stamp id) file; success := false) in let def (id : Ident.t) = - if Hash_set_ident.mem defined_variables id then ( + if Ident.Hash_set.mem defined_variables id then ( Format.fprintf Format.err_formatter "\n[SANITY]:%s/%d bound twice in %s@." - (Ident.name id) (Ext_ident.stamp id) file; + (Ident.name id) (Ident.stamp id) file; success := false) - else Hash_set_ident.add defined_variables id + else Ident.Hash_set.add defined_variables id in (* TODO: replaced by a slow version of {!Lam_iter.inner_iter} *) let rec check_list xs (cxt : Set_int.t) = - List.iter (fun x -> check_staticfails x cxt) xs + List.iter ~f:(fun x -> check_staticfails x cxt) xs and check_list_snd : 'a. ('a * Lam.t) list -> _ -> unit = - fun xs cxt -> List.iter (fun (_, x) -> check_staticfails x cxt) xs + fun xs cxt -> List.iter ~f:(fun (_, x) -> check_staticfails x cxt) xs and check_staticfails (l : Lam.t) (cxt : Set_int.t) = match l with | Lvar _ | Lmutvar _ | Lconst _ | Lglobal_module _ -> () @@ -93,9 +95,9 @@ let check file lam = | Lsend (_k, met, obj, args, _) -> check_list (met :: obj :: args) cxt | Lifused (_v, e) -> check_staticfails e cxt in - let rec iter_list xs = List.iter iter xs + let rec iter_list xs = List.iter ~f:iter xs and iter_list_snd : 'a. ('a * Lam.t) list -> unit = - fun xs -> List.iter (fun (_, x) -> iter x) xs + fun xs -> List.iter ~f:(fun (_, x) -> iter x) xs and iter (l : Lam.t) = match l with | Lvar id | Lmutvar id -> use id @@ -106,14 +108,14 @@ let check file lam = iter ap_func; iter_list ap_args | Lfunction { body; params; _ } -> - List.iter def params; + List.iter ~f:def params; iter body | Llet (_, id, arg, body) | Lmutlet (id, arg, body) -> iter arg; def id; iter body | Lletrec (decl, body) -> - List.iter (fun (x, _) -> def x) decl; + List.iter ~f:(fun (x, _) -> def x) decl; iter_list_snd decl; iter body | Lswitch (arg, sw) -> @@ -131,7 +133,7 @@ let check file lam = | Lstaticraise (_i, args) -> iter_list args | Lstaticcatch (e1, (_, vars), e2) -> iter e1; - List.iter def vars; + List.iter ~f:def vars; iter e2 | Ltrywith (e1, exn, e2) -> iter e1; diff --git a/jscomp/core/lam_closure.ml b/jscomp/core/lam_closure.ml index 7070d98515..50cc8e468f 100644 --- a/jscomp/core/lam_closure.ml +++ b/jscomp/core/lam_closure.ml @@ -22,21 +22,23 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + type position = Lam_var_stats.position type stats = Lam_var_stats.stats -let adjust (fv : stats Map_ident.t) (pos : position) (v : Ident.t) : - stats Map_ident.t = - Map_ident.adjust fv v (fun v -> +let adjust (fv : stats Ident.Map.t) (pos : position) (v : Ident.t) : + stats Ident.Map.t = + Ident.Map.adjust fv v (fun v -> let stat = match v with None -> Lam_var_stats.fresh_stats | Some v -> v in Lam_var_stats.update stat pos) -let param_map_of_list lst : stats Map_ident.t = +let param_map_of_list lst : stats Ident.Map.t = List.fold_left - (fun acc l -> Map_ident.add acc l Lam_var_stats.fresh_stats) - Map_ident.empty lst + ~f:(fun acc l -> Ident.Map.add acc l Lam_var_stats.fresh_stats) + ~init:Ident.Map.empty lst (** Sanity check, remove all varaibles in [local_set] in the last pass *) let sink_pos = Lam_var_stats.sink @@ -49,18 +51,18 @@ let sink_pos = Lam_var_stats.sink An enriched version of [free_varaibles] in {!Lam_free_variables} *) -let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) - (lam : Lam.t) : stats Map_ident.t = +let free_variables (export_idents : Ident.Set.t) (params : stats Ident.Map.t) + (lam : Lam.t) : stats Ident.Map.t = let fv = ref params in let local_set = ref export_idents in - let local_add k = local_set := Set_ident.add !local_set k in + let local_add k = local_set := Ident.Set.add !local_set k in let local_add_list ks = - local_set := List.fold_left Set_ident.add !local_set ks + local_set := List.fold_left ~f:Ident.Set.add ~init:!local_set ks in (* base don the envrionmet, recoring the use cases of arguments relies on [identifier] uniquely bound *) let used (cur_pos : position) (v : Ident.t) = - if not (Set_ident.mem !local_set v) then fv := adjust !fv cur_pos v + if not (Ident.Set.mem !local_set v) then fv := adjust !fv cur_pos v in let rec iter (top : position) (lam : Lam.t) = @@ -70,10 +72,10 @@ let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) | Lapply { ap_func; ap_args; _ } -> iter top ap_func; let top = Lam_var_stats.new_position_after_lam ap_func top in - List.iter (fun lam -> iter top lam) ap_args + List.iter ~f:(fun lam -> iter top lam) ap_args | Lprim { args; _ } -> (* Check: can top be propoaged for all primitives *) - List.iter (iter top) args + List.iter ~f:(iter top) args | Lglobal_module _ -> () | Lfunction { params; body; _ } -> local_add_list params; @@ -85,9 +87,9 @@ let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) | Lletrec (decl, body) -> local_set := List.fold_left - (fun acc (id, _) -> Set_ident.add acc id) - !local_set decl; - List.iter (fun (_, exp) -> iter sink_pos exp) decl; + ~f:(fun acc (id, _) -> Ident.Set.add acc id) + ~init:!local_set decl; + List.iter ~f:(fun (_, exp) -> iter sink_pos exp) decl; iter sink_pos body | Lswitch ( arg, @@ -101,8 +103,8 @@ let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) } ) -> ( iter top arg; let top = Lam_var_stats.new_position_after_lam arg top in - List.iter (fun (_, case) -> iter top case) sw_consts; - List.iter (fun (_, case) -> iter top case) sw_blocks; + List.iter ~f:(fun (_, case) -> iter top case) sw_consts; + List.iter ~f:(fun (_, case) -> iter top case) sw_blocks; match sw_failaction with | None -> () | Some x -> @@ -111,9 +113,9 @@ let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) | Lstringswitch (arg, cases, default) -> ( iter top arg; let top = Lam_var_stats.new_position_after_lam arg top in - List.iter (fun (_, act) -> iter top act) cases; + List.iter ~f:(fun (_, act) -> iter top act) cases; match default with None -> () | Some x -> iter top x) - | Lstaticraise (_, args) -> List.iter (iter sink_pos) args + | Lstaticraise (_, args) -> List.iter ~f:(iter sink_pos) args | Lstaticcatch (e1, (_, vars), e2) -> iter sink_pos e1; local_add_list vars; @@ -143,23 +145,23 @@ let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) | Lsend (_k, met, obj, args, _) -> iter sink_pos met; iter sink_pos obj; - List.iter (iter sink_pos) args + List.iter ~f:(iter sink_pos) args | Lifused (_v, e) -> iter sink_pos e in iter Lam_var_stats.fresh_env lam; !fv -(* let is_closed_by (set : Set_ident.t) (lam : Lam.t) : bool = - Map_ident.is_empty (free_variables set (Map_ident.empty ) lam ) *) +(* let is_closed_by (set : Ident.Set.t) (lam : Lam.t) : bool = + Ident.Map.is_empty (free_variables set (Ident.Map.empty ) lam ) *) (** A bit consverative , it should be empty *) let is_closed lam = - Map_ident.for_all (free_variables Set_ident.empty Map_ident.empty lam) + Ident.Map.for_all (free_variables Ident.Set.empty Ident.Map.empty lam) (fun k _ -> Ident.global k) -let is_closed_with_map (exports : Set_ident.t) (params : Ident.t list) - (body : Lam.t) : bool * stats Map_ident.t = +let is_closed_with_map (exports : Ident.Set.t) (params : Ident.t list) + (body : Lam.t) : bool * stats Ident.Map.t = let param_map = free_variables exports (param_map_of_list params) body in let old_count = List.length params in - let new_count = Map_ident.cardinal param_map in + let new_count = Ident.Map.cardinal param_map in (old_count = new_count, param_map) diff --git a/jscomp/core/lam_closure.mli b/jscomp/core/lam_closure.mli index 7aee43db9a..73f846ab9e 100644 --- a/jscomp/core/lam_closure.mli +++ b/jscomp/core/lam_closure.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,11 +17,13 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (** [is_closed_by map lam] return [true] if all unbound variables belongs to the given [map] *) @@ -30,11 +32,11 @@ val is_closed : Lam.t -> bool val is_closed_with_map : - Set_ident.t -> Ident.t list -> Lam.t -> bool * Lam_var_stats.stats Map_ident.t + Ident.Set.t -> Ident.t list -> Lam.t -> bool * Lam_var_stats.stats Ident.Map.t (** The output is mostly used in betat reduction *) val free_variables : - Set_ident.t -> - Lam_var_stats.stats Map_ident.t -> + Ident.Set.t -> + Lam_var_stats.stats Ident.Map.t -> Lam.t -> - Lam_var_stats.stats Map_ident.t + Lam_var_stats.stats Ident.Map.t diff --git a/jscomp/core/lam_coercion.ml b/jscomp/core/lam_coercion.ml index a01cdd6f55..cc190a1527 100644 --- a/jscomp/core/lam_coercion.ml +++ b/jscomp/core/lam_coercion.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (* Invariant: The last one is always [exports] Compile definitions @@ -71,8 +73,8 @@ type t = { export_list : Ident.t list; - export_set : Set_ident.t; - export_map : Lam.t Map_ident.t; + export_set : Ident.Set.t; + export_map : Lam.t Ident.Map.t; (* not used in code generation, mostly used for store some information in cmj files *) groups : Lam_group.t list; @@ -82,14 +84,14 @@ type t = { let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) (reverse_input : Lam_group.t list) = let (original_exports : Ident.t list) = meta.exports in - let (original_export_set : Set_ident.t) = meta.export_idents in + let (original_export_set : Ident.Set.t) = meta.export_idents in let len = List.length original_exports in - let tbl = Hash_set_string.create len in + let tbl = String.Hash_set.create len in let ({ export_list; export_set; _ } as result) = List.fold_right2 - (fun (original_export_id : Ident.t) (lam : Lam.t) (acc : t) -> + ~f:(fun (original_export_id : Ident.t) (lam : Lam.t) (acc : t) -> let original_name = Ident.name original_export_id in - if not @@ Hash_set_string.check_add tbl original_name then + if not @@ String.Hash_set.check_add tbl original_name then Mel_exception.error (Mel_duplicate_exports original_name); match lam with | Lvar id | Lmutvar id -> @@ -98,11 +100,11 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) acc with export_list = id :: acc.export_list; export_set = - (if Ext_ident.stamp id = Ext_ident.stamp original_export_id - then acc.export_set + (if Ident.stamp id = Ident.stamp original_export_id then + acc.export_set else - Set_ident.add - (Set_ident.remove acc.export_set original_export_id) + Ident.Set.add + (Ident.Set.remove acc.export_set original_export_id) id); } else @@ -112,7 +114,7 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) { acc with export_list = newid :: acc.export_list; - export_map = Map_ident.add acc.export_map newid lam; + export_map = Ident.Map.add acc.export_map newid lam; groups = Single ( (match lam with @@ -143,7 +145,7 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) let newid = Ident.rename original_export_id in (let arity = Lam_arity_analysis.get_arity meta lam in if not (Lam_arity.first_arity_na arity) then - Hash_ident.add meta.ident_tbl newid + Ident.Hash.add meta.ident_tbl newid (FunctionId { arity; @@ -155,30 +157,31 @@ let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) { acc with export_list = newid :: acc.export_list; - export_map = Map_ident.add acc.export_map newid lam; + export_map = Ident.Map.add acc.export_map newid lam; groups = Single (Strict, newid, lam) :: acc.groups; }) original_exports lambda_exports - { - export_list = []; - export_set = original_export_set; - export_map = Map_ident.empty; - groups = []; - } + ~init: + { + export_list = []; + export_set = original_export_set; + export_map = Ident.Map.empty; + groups = []; + } in let export_map, coerced_input = List.fold_left - (fun (export_map, acc) (x : Lam_group.t) -> + ~f:(fun (export_map, acc) (x : Lam_group.t) -> ( (match x with - | Single (_, id, lam) when Set_ident.mem export_set id -> - Map_ident.add export_map id lam + | Single (_, id, lam) when Ident.Set.mem export_set id -> + Ident.Map.add export_map id lam (* relies on the Invariant that [eoid] can not be bound before FIX: such invariant may not hold *) | _ -> export_map), x :: acc )) - (result.export_map, result.groups) + ~init:(result.export_map, result.groups) reverse_input in { result with export_map; groups = Lam_dce.remove export_list coerced_input } @@ -228,7 +231,7 @@ let coerce_and_group_big_lambda (meta : Lam_stats.t) lam : t * Lam_stats.t = (* { export_list = meta.exports; export_set = meta.export_idents; - export_map = Map_ident.empty ; + export_map = Ident.Map.empty ; (* not used in code generation, mostly used for store some information in cmj files *) groups = [Nop lam] ; diff --git a/jscomp/core/lam_coercion.mli b/jscomp/core/lam_coercion.mli index 61d3b3e8f9..76cca88c59 100644 --- a/jscomp/core/lam_coercion.mli +++ b/jscomp/core/lam_coercion.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,15 +17,17 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + type t = { export_list : Ident.t list; - export_set : Set_ident.t; - export_map : Lam.t Map_ident.t; + export_set : Ident.Set.t; + export_map : Lam.t Ident.Map.t; groups : Lam_group.t list; } diff --git a/jscomp/core/lam_compile.ml b/jscomp/core/lam_compile.ml index 5c05cce72f..a1df320a1a 100644 --- a/jscomp/core/lam_compile.ml +++ b/jscomp/core/lam_compile.ml @@ -22,12 +22,13 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import module E = Js_exp_make module S = Js_stmt_make let args_either_function_or_const (args : Lam.t list) = List.for_all - (fun (x : Lam.t) -> + ~f:(fun (x : Lam.t) -> match x with Lfunction _ | Lconst _ -> true | _ -> false) args @@ -46,16 +47,16 @@ let rec apply_with_arity_aux (fn : J.expression) (arity : int list) let x = if x = 0 then 1 else x in (* Relax when x = 0 *) if len >= x then - let first_part, continue = Ext_list.split_at args x in + let first_part, continue = List.split_at args x in apply_with_arity_aux (E.call ~info:{ arity = Full; call_info = Call_ml } fn first_part) rest continue (len - x) else if (* GPR #1423 *) - List.for_all Js_analyzer.is_okay_to_duplicate args + List.for_all ~f:Js_analyzer.is_okay_to_duplicate args then let params = - List.init (x - len) (fun _ -> Ext_ident.create "param") + List.init ~len:(x - len) ~f:(fun _ -> Ident.create "param") in E.ocaml_fun params (* unknown info *) ~return_unit:false @@ -64,7 +65,7 @@ let rec apply_with_arity_aux (fn : J.expression) (arity : int list) (E.call ~info:{ arity = Full; call_info = Call_ml } fn - (List.append args @@ List.map E.var params)); + (List.append args @@ List.map ~f:E.var params)); ] else E.call ~info:Js_call_info.dummy fn args (* alpha conversion now? -- @@ -112,7 +113,8 @@ let rec flat_catches (acc : Lam_compile_context.handler list) (x : Lam.t) : || not (Lam_exit_code.has_exit_code handler (fun exit -> List.exists - (fun (x : Lam_compile_context.handler) -> x.label = exit) + ~f:(fun (x : Lam_compile_context.handler) -> + x.label = exit) acc)) -> (* #1698 should not crush exit code here without checking *) flat_catches ({ label; handler; bindings } :: acc) l @@ -130,9 +132,8 @@ let morph_declare_to_assign (cxt : Lam_compile_context.t) k = let group_apply cases callback = List.concat_map - (fun group -> Ext_list.map_last group callback) - (Ext_list.stable_group cases (fun (_, lam) (_, lam1) -> - Lam.eq_approx lam lam1)) + ~f:(fun group -> List.map_last group callback) + (List.stable_group cases (fun (_, lam) (_, lam1) -> Lam.eq_approx lam lam1)) (* TODO: for expression generation, name, should_return is not needed, @@ -229,11 +230,10 @@ and compile_external_field_apply (appinfo : Lam.apply) (module_id : Ident.t) in let ap_args = appinfo.ap_args in match ident_info.persistent_closed_lambda with - | Some (Lfunction { params; body; _ }) - when Ext_list.same_length params ap_args -> + | Some (Lfunction { params; body; _ }) when List.same_length params ap_args -> (* TODO: serialize it when exporting to save compile time *) let _, param_map = - Lam_closure.is_closed_with_map Set_ident.empty params body + Lam_closure.is_closed_with_map Ident.Set.empty params body in compile_lambda lambda_cxt (Lam_beta_reduce.propogate_beta_reduce_with_map lambda_cxt.meta @@ -245,12 +245,12 @@ and compile_external_field_apply (appinfo : Lam.apply) (module_id : Ident.t) else let arg_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in List.fold_right - (fun arg_lambda (args_code, args) -> + ~f:(fun arg_lambda (args_code, args) -> match compile_lambda arg_cxt arg_lambda with | { block; value = Some b; _ } -> (List.append block args_code, b :: args) | _ -> assert false) - ap_args dummy + ap_args ~init:dummy in let fn = E.ml_var_dot module_id ident_info.name in @@ -294,7 +294,7 @@ and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) label = continue_label; params; immutable_mask = Array.make (List.length params) true; - new_params = Map_ident.empty; + new_params = Ident.Map.empty; triggered = false; } in @@ -321,12 +321,12 @@ and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) *) ~return_unit ~immutable_mask:ret.immutable_mask (List.map - (fun x -> Map_ident.find_default ret.new_params x x) + ~f:(fun x -> Ident.Map.find_default ret.new_params x x) params) [ S.while_ (* ~label:continue_label *) E.true_ - (Map_ident.fold ret.new_params body_block + (Ident.Map.fold ret.new_params body_block (fun old new_param acc -> S.define_variable ~kind:Alias old (E.var new_param) :: acc)); ] @@ -356,13 +356,13 @@ and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) _; } when List.for_all - (fun (x : Lam.t) -> + ~f:(fun (x : Lam.t) -> match x with | Lvar pid -> Ident.same pid id || not @@ List.exists - (fun (other, _) -> Ident.same other pid) + ~f:(fun (other, _) -> Ident.same other pid) all_bindings | Lconst _ -> true | _ -> false) @@ -377,7 +377,7 @@ and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) ( Js_output.make (S.define_variable ~kind:Variable id (E.dummy_obj tag_info) :: List.mapi - (fun i (x : Lam.t) -> + ~f:(fun i (x : Lam.t) -> S.exp (Js_of_lam_block.set_field (match tag_info with @@ -446,12 +446,12 @@ and compile_recursive_lets_aux cxt (id_args : Lam_scc.bindings) : Js_output.t = (* #1716 *) let output_code, ids = List.fold_right - (fun (ident, arg) (acc, ids) -> + ~f:(fun (ident, arg) (acc, ids) -> let code, declare_ids = compile_recursive_let ~all_bindings:id_args cxt ident arg in (Js_output.append_output code acc, List.append declare_ids ids)) - id_args (Js_output.dummy, []) + id_args ~init:(Js_output.dummy, []) in match ids with | [] -> output_code @@ -467,9 +467,9 @@ and compile_recursive_lets cxt id_args : Js_output.t = | first :: rest -> let acc = compile_recursive_lets_aux cxt first in List.fold_left - (fun acc x -> + ~f:(fun acc x -> Js_output.append_output acc (compile_recursive_lets_aux cxt x)) - acc rest) + ~init:acc rest) and compile_general_cases : 'a. @@ -645,7 +645,7 @@ and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch) match e.expression_desc with | J.Var _ -> [ dispatch e ] | _ -> - let v = Ext_ident.create_tmp () in + let v = Ident.create_tmp () in (* Necessary avoid duplicated computation*) [ S.define_variable ~kind:Variable v e; dispatch (E.var v) ]) in @@ -656,7 +656,7 @@ and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch) the same value for different branches -- can be optmized when branches are minimial (less than 2) *) - let v = Ext_ident.create_tmp () in + let v = Ident.create_tmp () in Js_output.make (S.declare_variable ~kind:Variable v :: compile_whole { lambda_cxt with continuation = Assign v }) @@ -695,7 +695,7 @@ and compile_stringswitch l cases default (lambda_cxt : Lam_compile_context.t) = match lambda_cxt.continuation with (* TODO: can be avoided when cases are less than 3 *) | NeedValue _ -> - let v = Ext_ident.create_tmp () in + let v = Ident.create_tmp () in Js_output.make (List.append block (compile_string_cases @@ -723,7 +723,7 @@ and compile_staticraise i (largs : Lam.t list) match Lam_compile_context.find_exn lambda_cxt i with | { exit_id; bindings; order_id } -> List.fold_right2 - (fun (larg : Lam.t) bind acc -> + ~f:(fun (larg : Lam.t) bind acc -> let new_output = match larg with | Lvar id -> Js_output.make [ S.assign bind (E.var id) ] @@ -735,9 +735,10 @@ and compile_staticraise i (largs : Lam.t list) in Js_output.append_output new_output acc) largs bindings - (Js_output.make - (if order_id >= 0 then [ S.assign exit_id (E.small_int order_id) ] - else [])) + ~init: + (Js_output.make + (if order_id >= 0 then [ S.assign exit_id (E.small_int order_id) ] + else [])) (* Invariant: exit_code can not be reused (catch l with (32) (handler)) @@ -770,7 +771,7 @@ and compile_staticraise i (largs : Lam.t list) and compile_staticcatch (lam : Lam.t) (lambda_cxt : Lam_compile_context.t) = let code_table, body = flatten_nested_caches lam in - let exit_id = Ext_ident.create_tmp ~name:"exit" () in + let exit_id = Ident.create_tmp ~name:"exit" () in match (lambda_cxt.continuation, code_table) with | ( EffectCall (Maybe_tail_is_return (Tail_with_name { in_staticcatch = false; _ }) as @@ -793,7 +794,7 @@ and compile_staticcatch (lam : Lam.t) (lambda_cxt : Lam_compile_context.t) = let lbody = compile_lambda new_cxt body in let declares = List.map - (fun x -> S.declare_variable ~kind:Variable x) + ~f:(fun x -> S.declare_variable ~kind:Variable x) code_table.bindings in Js_output.append_output (Js_output.make declares) @@ -809,14 +810,14 @@ and compile_staticcatch (lam : Lam.t) (lambda_cxt : Lam_compile_context.t) = S.define_variable ~kind:Variable exit_id E.zero_int_literal :: (* we should always make it zero here, since [zero] is reserved in our mapping*) List.concat_map - (fun { Lam_compile_context.bindings; _ } -> - List.map (S.declare_variable ~kind:Variable) bindings) + ~f:(fun { Lam_compile_context.bindings; _ } -> + List.map ~f:(S.declare_variable ~kind:Variable) bindings) code_table in match lambda_cxt.continuation with (* could be optimized when cases are less than 3 *) | NeedValue _ -> - let v = Ext_ident.create_tmp () in + let v = Ident.create_tmp () in let new_cxt = { lambda_cxt with jmp_table; continuation = Assign v } in @@ -898,7 +899,7 @@ and compile_sequand (l : Lam.t) (r : Lam.t) (lambda_cxt : Lam_compile_context.t) S.if_ l_expr (r_block @ [ S.assign v r_expr ]); ]) | EffectCall _ | NeedValue _ -> - let v = Ext_ident.create_tmp () in + let v = Ident.create_tmp () in Js_output.make ((S.define_variable ~kind:Variable v E.false_ :: l_block) @ [ S.if_ l_expr (r_block @ [ S.assign v r_expr ]) ]) @@ -938,7 +939,7 @@ and compile_sequor (l : Lam.t) (r : Lam.t) (lambda_cxt : Lam_compile_context.t) S.if_ (E.not l_expr) (r_block @ [ S.assign v r_expr ]); ]) | EffectCall _ | NeedValue _ -> - let v = Ext_ident.create_tmp () in + let v = Ident.create_tmp () in Js_output.make (l_block @ [ @@ -1076,7 +1077,7 @@ and compile_trywith lam id catch (lambda_cxt : Lam_compile_context.t) = Js_output.make (S.declare_variable ~kind id :: aux context context) | Assign _ -> Js_output.make (aux lambda_cxt lambda_cxt) | NeedValue _ -> - let v = Ext_ident.create_tmp () in + let v = Ident.create_tmp () in let context = { lambda_cxt with continuation = Assign v } in Js_output.make (S.declare_variable ~kind:Variable v :: aux context context) @@ -1138,11 +1139,11 @@ and compile_send (meth_kind : Lam_compat.meth_kind) (met : Lam.t) (obj : Lam.t) (args : Lam.t list) (lambda_cxt : Lam_compile_context.t) = let new_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in match - Ext_list.split_map (met :: obj :: args) (fun x -> + List.split_map (met :: obj :: args) (fun x -> match x with | Lprim { primitive = Pccall { prim_name; _ }; args = []; _ } (* nullary external call*) -> - ([], E.var (Ext_ident.create_js prim_name)) + ([], E.var (Ident.create_js prim_name)) | _ -> ( match compile_lambda new_cxt x with | { value = None; _ } -> assert false @@ -1219,7 +1220,7 @@ and compile_ifthenelse (predicate : Lam.t) (t_branch : Lam.t) (f_branch : Lam.t) | _, _ -> ( (* we can not reuse -- here we need they have the same name, TODO: could be optimized by inspecting assigment statement *) - let id = Ext_ident.create_tmp () in + let id = Ident.create_tmp () in let assign_cxt = { lambda_cxt with continuation = Assign id } in match ( compile_lambda assign_cxt t_branch, @@ -1386,13 +1387,13 @@ and compile_apply (appinfo : Lam.apply) (lambda_cxt : Lam_compile_context.t) = let new_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in let[@ocaml.warning "-partial-match"] args_code, fn_code :: args = List.fold_right - (fun x (args_code, fn_code) -> + ~f:(fun x (args_code, fn_code) -> match compile_lambda new_cxt x with | { block; value = Some b; _ } -> (List.append block args_code, b :: fn_code) | { value = None; _ } -> assert false) (ap_func :: appinfo.ap_args) - ([], []) + ~init:([], []) in match (ap_func, lambda_cxt.continuation) with | ( Lvar fn_id, @@ -1419,28 +1420,28 @@ and compile_apply (appinfo : Lam.apply) (lambda_cxt : Lam_compile_context.t) = (* TODO: use [fold]*) let _, assigned_params, new_params = List.fold_left2 - (fun (i, assigns, new_params) param arg -> + ~f:(fun (i, assigns, new_params) param arg -> match arg with | { J.expression_desc = Var (Id x); _ } when Ident.same x param -> (i + 1, assigns, new_params) | _ -> let new_param, m = - match Map_ident.find_opt ret.new_params param with + match Ident.Map.find_opt ret.new_params param with | None -> ret.immutable_mask.(i) <- false; - let v = Ext_ident.create ("_" ^ Ident.name param) in - (v, Map_ident.add new_params param v) + let v = Ident.create ("_" ^ Ident.name param) in + (v, Ident.Map.add new_params param v) | Some v -> (v, new_params) in (i + 1, (new_param, arg) :: assigns, m)) - (0, [], Map_ident.empty) ret.params args + ~init:(0, [], Ident.Map.empty) ret.params args in ret.new_params <- - Map_ident.disjoint_merge_exn new_params ret.new_params (fun _ _ _ -> + Ident.Map.disjoint_merge_exn new_params ret.new_params (fun _ _ _ -> assert false); let block = - List.map (fun (param, arg) -> S.assign param arg) assigned_params + List.map ~f:(fun (param, arg) -> S.assign param arg) assigned_params @ [ S.continue_ ] in (* Note true and continue needed to be handled together*) @@ -1601,7 +1602,7 @@ and compile_prim (prim_info : Lam.prim_info) if args = [] then ([], []) else let new_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in - Ext_list.split_map args (fun x -> + List.split_map args (fun x -> match compile_lambda new_cxt x with | { block; value = Some b; _ } -> (block, b) | { value = None; _ } -> assert false) @@ -1617,7 +1618,7 @@ and compile_prim (prim_info : Lam.prim_info) if args = [] then ([], []) else let new_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in - Ext_list.split_map args (fun x -> + List.split_map args (fun x -> match compile_lambda new_cxt x with | { block; value = Some b; _ } -> (block, b) | { value = None; _ } -> assert false) diff --git a/jscomp/core/lam_compile_context.ml b/jscomp/core/lam_compile_context.ml index 0b85b95529..b6ed213331 100644 --- a/jscomp/core/lam_compile_context.ml +++ b/jscomp/core/lam_compile_context.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + type jbl_label = int module HandlerMap = Map_int @@ -36,7 +38,7 @@ type return_label = { label : J.label; params : Ident.t list; immutable_mask : bool array; - mutable new_params : Ident.t Map_ident.t; + mutable new_params : Ident.t Ident.Map.t; mutable triggered : bool; } @@ -91,7 +93,7 @@ let no_static_raise_in_handler (x : handler) : bool = let add_jmps (m : jmp_table) (exit_id : Ident.t) (code_table : handler list) : jmp_table * (int * Lam.t) list = let map, handlers = - Ext_list.fold_left_with_offset code_table (m, []) + List.fold_left_with_offset code_table (m, []) (HandlerMap.cardinal m + 1) (fun { label; handler; bindings } (acc, handlers) order_id -> ( HandlerMap.add acc label { exit_id; bindings; order_id }, diff --git a/jscomp/core/lam_compile_context.mli b/jscomp/core/lam_compile_context.mli index cae477973a..49d895bc46 100644 --- a/jscomp/core/lam_compile_context.mli +++ b/jscomp/core/lam_compile_context.mli @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (** Type definition to keep track of compilation state *) @@ -36,7 +38,7 @@ type return_label = { label : J.label; params : Ident.t list; immutable_mask : bool array; - mutable new_params : Ident.t Map_ident.t; + mutable new_params : Ident.t Ident.Map.t; mutable triggered : bool; } diff --git a/jscomp/core/lam_compile_env.ml b/jscomp/core/lam_compile_env.ml index 7002260e8c..8d1d385b95 100644 --- a/jscomp/core/lam_compile_env.ml +++ b/jscomp/core/lam_compile_env.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + type env_value = | Ml of Js_cmj_format.cmj_load_info | External @@ -69,7 +71,7 @@ let add_js_module (hint_name : Melange_ffi.External_ffi_types.module_bind_name) (* make sure the module name is capitalized TODO: maybe a warning if the user hint is not good *) - | Phint_nothing -> Ext_modulename.js_id_name_of_hint_name module_name) + | Phint_nothing -> Modulename.js_id_name_of_hint_name module_name) in let lam_module_ident : J.module_id = { id; kind = External { name = module_name; default } } diff --git a/jscomp/core/lam_compile_external_call.ml b/jscomp/core/lam_compile_external_call.ml index f763d4bcaf..03c4f925d3 100644 --- a/jscomp/core/lam_compile_external_call.ml +++ b/jscomp/core/lam_compile_external_call.ml @@ -22,6 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import module E = Js_exp_make let splice_fn_apply fn args = @@ -233,19 +234,19 @@ let translate_scoped_module_val let start = E.external_var_field ~external_name:bundle ~field:x ~default id in - List.fold_left E.dot start (List.append rest [ fn ])) + List.fold_left ~f:E.dot ~init:start (List.append rest [ fn ])) | None -> ( (* no [@@module], assume it's global *) match scopes with | [] -> E.js_global fn | x :: rest -> let start = E.js_global x in - List.fold_left E.dot start (rest @ [ fn ])) + List.fold_left ~f:E.dot ~init:start (rest @ [ fn ])) let translate_scoped_access scopes obj = match scopes with | [] -> obj - | x :: xs -> List.fold_left E.dot (E.dot obj x) xs + | x :: xs -> List.fold_left ~f:E.dot ~init:(E.dot obj x) xs let translate_ffi (cxt : Lam_compile_context.t) arg_types (ffi : Melange_ffi.External_ffi_types.external_spec) @@ -304,8 +305,8 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types (* splice should not happen *) (* assert (js_splice = false) ; *) if splice then - let args, self = Ext_list.split_at_last args in - let arg_types, _ = Ext_list.split_at_last arg_types in + let args, self = List.split_at_last args in + let arg_types, _ = List.split_at_last arg_types in let args, eff, dynamic = assemble_args_has_splice arg_types args in add_eff eff (let self = translate_scoped_access js_send_scopes self in @@ -315,8 +316,8 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types ~info:{ arity = Full; call_info = Call_na } (E.dot self name) args) else - let args, self = Ext_list.split_at_last args in - let arg_types, _ = Ext_list.split_at_last arg_types in + let args, self = List.split_at_last args in + let arg_types, _ = List.split_at_last arg_types in let args, eff = assemble_args_no_splice arg_types args in add_eff eff (let self = translate_scoped_access js_send_scopes self in @@ -365,8 +366,8 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types add_eff eff ((match cxt.continuation with | Declare (let_kind, id) -> - cxt.continuation <- Declare (let_kind, Ext_ident.make_js_object id) - | Assign id -> cxt.continuation <- Assign (Ext_ident.make_js_object id) + cxt.continuation <- Declare (let_kind, Ident.make_js_object id) + | Assign id -> cxt.continuation <- Assign (Ident.make_js_object id) | EffectCall _ | NeedValue _ -> ()); E.new_ fn args) | Js_get { js_get_name = name; js_get_scopes = scopes } -> ( diff --git a/jscomp/core/lam_compile_external_obj.ml b/jscomp/core/lam_compile_external_obj.ml index b89c966e98..b907511def 100644 --- a/jscomp/core/lam_compile_external_obj.ml +++ b/jscomp/core/lam_compile_external_obj.ml @@ -22,6 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import module E = Js_exp_make module S = Js_stmt_make @@ -100,15 +101,17 @@ let assemble_obj_args (labels : Melange_ffi.External_arg_spec.obj_params) | [] -> E.obj map | x :: xs -> E.seq (E.fuse_to_seq x xs) (E.obj map) ) | _ -> - let v = Ext_ident.create_tmp () in + let v = Ident.create_tmp () in let var_v = E.var v in ( S.define_variable ~kind:Variable v (match eff with | [] -> E.obj map | x :: xs -> E.seq (E.fuse_to_seq x xs) (E.obj map)) :: List.concat_map - (fun ( (xlabel : Melange_ffi.External_arg_spec.obj_param), - (arg : J.expression) ) -> + ~f:(fun + ( (xlabel : Melange_ffi.External_arg_spec.obj_param), + (arg : J.expression) ) + -> match xlabel with | { obj_arg_label = diff --git a/jscomp/core/lam_compile_main.cppo.ml b/jscomp/core/lam_compile_main.cppo.ml index a18e5d7b67..401daf64c1 100644 --- a/jscomp/core/lam_compile_main.cppo.ml +++ b/jscomp/core/lam_compile_main.cppo.ml @@ -22,16 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - - - - - - -(* module E = Js_exp_make *) -(* module S = Js_stmt_make *) - +open Import let compile_group (meta : Lam_stats.t) (x : Lam_group.t) : Js_output.t = @@ -82,7 +73,7 @@ let compile_group (meta : Lam_stats.t) (* Also need analyze its depenency is pure or not *) let no_side_effects (rest : Lam_group.t list) : string option = - List.find_map (function + List.find_map ~f:(function | Lam_group.Single(kind,id,body) -> begin match kind with @@ -93,7 +84,7 @@ let no_side_effects (rest : Lam_group.t list) : string option = | _ -> None end | Recursive bindings -> - List.find_map (fun (id,lam) -> + List.find_map ~f:(fun (id,lam) -> if not @@ Lam_analysis.no_side_effects lam then Some (Printf.sprintf "%s" (Ident.name id) ) else None) @@ -109,7 +100,7 @@ let no_side_effects (rest : Lam_group.t list) : string option = let _d = fun s lam -> #ifndef BS_RELEASE_BUILD - Lam_util.dump s lam ; + Lam_dump.dump s lam ; Ext_log.dwarn ~__POS__ "START CHECKING PASS %s@." s; ignore @@ Lam_check.check !Location.input_name lam; Ext_log.dwarn ~__POS__ "FINISH CHECKING PASS %s@." s; @@ -125,12 +116,12 @@ let compile (output_prefix : string) (lam : Lambda.lambda) = let export_idents = Translmod.get_export_identifiers() in - let export_ident_sets = Set_ident.of_list export_idents in + let export_ident_sets = Ident.Set.of_list export_idents in (* To make toplevel happy - reentrant for js-demo *) let () = #ifndef BS_RELEASE_BUILD List.iter - (fun id -> Ext_log.dwarn ~__POS__ "export idents: %s/%d" (Ident.name id) (Ext_ident.stamp id)) + ~f:(fun id -> Ext_log.dwarn ~__POS__ "export idents: %s/%d" (Ident.name id) (Ident.stamp id)) export_idents ; #endif Lam_compile_env.reset () ; @@ -210,7 +201,7 @@ let () = Ext_log.dwarn ~__POS__ "After coercion: %a@." Lam_stats.print meta ; if !Js_config.diagnose then let f = - Ext_filename.new_extension !Location.input_name ".lambda" in + Filename.new_extension !Location.input_name ".lambda" in let chan = open_out_bin f in Fun.protect ~finally:(fun () -> close_out chan) @@ -228,7 +219,7 @@ let () = Ext_log.dwarn ~__POS__ "\n@[[TIME:]Pre-compile: %f@]@." (Sys.time () * #endif let body = groups - |> List.map (fun group -> compile_group meta group) + |> List.map ~f:(fun group -> compile_group meta group) |> Js_output.concat |> Js_output.output_as_block in @@ -236,7 +227,7 @@ in let () = Ext_log.dwarn ~__POS__ "\n@[[TIME:]Post-compile: %f@]@." (Sys.time () *. 1000.) in #endif let meta_exports = meta.exports in -let export_set = Set_ident.of_list meta_exports in +let export_set = Ident.Set.of_list meta_exports in let js : J.program = { exports = meta_exports ; @@ -270,7 +261,7 @@ js |> Array.of_list in Array.sort - (fun id1 id2 -> + ~cmp:(fun id1 id2 -> String.compare (Lam_module_ident.name id1) (Lam_module_ident.name id2)) arr; Array.to_list arr @@ -307,8 +298,6 @@ js ) ;; -let (//) = Ext_path.(//) - let write_to_file ~package_info ~output_info ~output_prefix lambda_output file = let oc = open_out_bin file in Fun.protect @@ -321,45 +310,42 @@ let write_to_file ~package_info ~output_info ~output_prefix lambda_output file lambda_output oc) -let lambda_as_module - ~package_info - (lambda_output : J.deps_program) - (output_prefix : string) - : unit = - let make_basename suffix = - (Filename.basename output_prefix) ^ (Ext_js_suffix.to_string suffix) - in - match (!Js_config.js_stdout, !Clflags.output_name) with - | (true, None) -> - Js_dump_program.dump_deps_program - ~package_info - ~output_info:Js_packages_info.default_output_info - ~output_prefix - lambda_output stdout - | false, None -> - raise (Arg.Bad ("no output specified (use -o .js)")) - | (_, Some _) -> - (* We use `-mel-module-type` to emit a single JS file after `.cmj` - generation. In this case, we don't want the `package_info` from the - `.cmj`, because the suffix and paths will be different. *) - List.iter (fun (output_info : Js_packages_info.output_info) -> - let basename = make_basename output_info.suffix in - let target_file = Filename.dirname output_prefix // basename in - if not !Clflags.dont_write_files then begin - write_to_file - ~package_info - ~output_info - ~output_prefix - lambda_output - target_file - end) - (Js_packages_state.get_output_info ()) - - +let lambda_as_module = + let (//) = Path.(//) in + fun ~package_info (lambda_output : J.deps_program) (output_prefix : string) -> + let make_basename suffix = + (Filename.basename output_prefix) ^ (Js_suffix.to_string suffix) + in + match (!Js_config.js_stdout, !Clflags.output_name) with + | (true, None) -> + Js_dump_program.dump_deps_program + ~package_info + ~output_info:Js_packages_info.default_output_info + ~output_prefix + lambda_output stdout + | false, None -> + raise (Arg.Bad ("no output specified (use -o .js)")) + | (_, Some _) -> + (* We use `-mel-module-type` to emit a single JS file after `.cmj` + generation. In this case, we don't want the `package_info` from the + `.cmj`, because the suffix and paths will be different. *) + List.iter ~f:(fun (output_info : Js_packages_info.output_info) -> + let basename = make_basename output_info.suffix in + let target_file = Filename.dirname output_prefix // basename in + if not !Clflags.dont_write_files then begin + write_to_file + ~package_info + ~output_info + ~output_prefix + lambda_output + target_file + end) + (Js_packages_state.get_output_info ()) (* We can use {!Env.current_unit = "Pervasives"} to tell if it is some specific module, - We need handle some definitions in standard libraries in a special way, most are io specific, - includes {!Pervasives.stdin, Pervasives.stdout, Pervasives.stderr} + We need handle some definitions in standard libraries in a special way, most are io specific, + includes {!Pervasives.stdin, Pervasives.stdout, Pervasives.stderr} - However, use filename instead of {!Env.current_unit} is more honest, since node-js module system is coupled with the file name + However, use filename instead of {!Env.current_unit} is more honest, since + Node.js module system is coupled with the file name *) diff --git a/jscomp/core/lam_convert.ml b/jscomp/core/lam_convert.ml index 43c7595edf..746a965ca0 100644 --- a/jscomp/core/lam_convert.ml +++ b/jscomp/core/lam_convert.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + let caml_id_field_info : Lambda.field_dbg_info = Fld_record { name = Js_dump_lit.exception_id; mutable_flag = Immutable } @@ -71,8 +73,8 @@ let exception_id_destructed (l : Lam.t) (fv : Ident.t) : bool = let rec hit_opt (x : _ option) = match x with None -> false | Some a -> hit a and hit_list_snd : 'a. ('a * _) list -> bool = - fun x -> List.exists (fun (_, x) -> hit x) x - and hit_list xs = List.exists hit xs + fun x -> List.exists ~f:(fun (_, x) -> hit x) x + and hit_list xs = List.exists ~f:hit xs and hit (l : Lam.t) = match l with (* | Lprim {primitive = Pintcomp _ ; @@ -134,7 +136,7 @@ let happens_to_be_diff (sw_consts : (int * Lam.t) list) : int32 option = if Int32.sub b0 b = diff then if List.for_all - (fun (x, lam) -> + ~f:(fun (x, lam) -> match lam with | Lam.Lconst (Const_int { i = x0; comment = _ }) when no_over_flow_int32 x0 && no_over_flow x -> @@ -174,7 +176,7 @@ let convert_record_repr (x : Types.record_representation) : let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = match p with | Pint_as_pointer - (* | Pidentity -> Ext_list.singleton_exn args *) + (* | Pidentity -> List.singleton_exn args *) | Pccall _ -> assert false | Pbytes_to_string (* handled very early *) -> @@ -450,10 +452,10 @@ let rec rename_optional_parameters map params (body : Lam.t) = && Ident.name sth2 = "*sth*" && Ident.name opt = "*opt*" && Ident.name opt2 = "*opt*" - && Ident.same opt opt2 && List.mem opt params -> + && Ident.same opt opt2 && List.mem opt ~set:params -> let map, rest = rename_optional_parameters map params rest in let new_id = Ident.create_local (Ident.name id ^ "Opt") in - ( Map_ident.add map opt new_id, + ( Ident.Map.add map opt new_id, Lam.let_ k id (Lam.if_ (Lam.prim ~primitive:p ~args:[ Lam.var new_id ] p_loc) @@ -470,10 +472,10 @@ let rec rename_optional_parameters map params (body : Lam.t) = rest ) when Ident.name opt = "*opt*" && Ident.name opt2 = "*opt*" - && Ident.same opt opt2 && List.mem opt params -> + && Ident.same opt opt2 && List.mem opt ~set:params -> let map, rest = rename_optional_parameters map params rest in let new_id = Ident.create_local (Ident.name id ^ "Opt") in - ( Map_ident.add map opt new_id, + ( Ident.Map.add map opt new_id, Lam.let_ k id (Lam.if_ (Lam.prim ~primitive:p ~args:[ Lam.var new_id ] p_loc) @@ -489,10 +491,10 @@ let rec rename_optional_parameters map params (body : Lam.t) = rest ) when Ident.name opt = "*opt*" && Ident.name opt2 = "*opt*" - && Ident.same opt opt2 && List.mem opt params -> + && Ident.same opt opt2 && List.mem opt ~set:params -> let map, rest = rename_optional_parameters map params rest in let new_id = Ident.create_local (Ident.name id ^ "Opt") in - ( Map_ident.add map opt new_id, + ( Ident.Map.add map opt new_id, Lam.mutlet id (Lam.if_ (Lam.prim ~primitive:p ~args:[ Lam.var new_id ] p_loc) @@ -514,9 +516,9 @@ let nat_of_string_exn = let acc = int_of_string_aux s 0 0 (String.length s) in if acc < 0 then invalid_arg s else acc -let convert (exports : Set_ident.t) (lam : Lambda.lambda) : +let convert (exports : Ident.Set.t) (lam : Lambda.lambda) : Lam.t * Lam_module_ident.Hash_set.t = - let alias_tbl = Hash_ident.create 64 in + let alias_tbl = Ident.Hash.create 64 in let exit_map = Hash_int.create 0 in let may_depends = Lam_module_ident.Hash_set.create 0 in @@ -531,25 +533,25 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : if prim_name_len > 0 && String.unsafe_get prim_name 0 = '#' then convert_js_primitive a_prim args loc else - let args = List.map convert_aux args in + let args = List.map ~f:convert_aux args in prim ~primitive:(Pccall { prim_name }) ~args loc | Ffi_obj_create labels -> - let args = List.map convert_aux args in + let args = List.map ~f:convert_aux args in prim ~primitive:(Pjs_object_create labels) ~args loc | Ffi_mel (arg_types, result_type, ffi) -> let arg_types = match arg_types with | Params ls -> ls | Param_number i -> - List.init i (fun _ -> Melange_ffi.External_arg_spec.dummy) + List.init ~len:i ~f:(fun _ -> Melange_ffi.External_arg_spec.dummy) in - let args = List.map convert_aux args in + let args = List.map ~f:convert_aux args in Lam.handle_mel_non_obj_ffi arg_types result_type ffi args loc prim_name | Ffi_inline_const i -> Lam.const i and convert_js_primitive (p : Primitive.description) (args : Lambda.lambda list) loc = let s = p.prim_name in - let args = List.map convert_aux args in + let args = List.map ~f:convert_aux args in match () with | _ when s = "#is_not_none" -> prim ~primitive:Pis_not_none ~args loc | _ when s = "#val_from_unnest_option" -> @@ -647,8 +649,8 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : else prim ~primitive ~args loc and convert_aux (lam : Lambda.lambda) : Lam.t = match lam with - | Lvar x -> Lam.var (Hash_ident.find_default alias_tbl x x) - | Lmutvar x -> Lam.mutvar (Hash_ident.find_default alias_tbl x x) + | Lvar x -> Lam.var (Ident.Hash.find_default alias_tbl x x) + | Lmutvar x -> Lam.mutvar (Ident.Hash.find_default alias_tbl x x) | Lconst x -> Lam.const (Lam_constant_convert.convert_constant x) | Lapply { ap_func = fn; ap_args = [ arg ]; ap_loc = loc; _ } -> let arg = convert_aux arg in @@ -657,36 +659,38 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : | Lapply { ap_func = fn; ap_args = args; ap_loc = loc; ap_inlined; _ } -> (* we need do this eargly in case [aux fn] add some wrapper *) Lam.apply (convert_aux fn) - (List.map convert_aux args) + (List.map ~f:convert_aux args) { ap_loc = Debuginfo.Scoped_location.to_location loc; ap_inlined; ap_status = App_na; } | Lfunction { params; body; attr; _ } -> - let just_params = List.map fst params in + let just_params = List.map ~f:fst params in let body = convert_aux body in let new_map, body = - rename_optional_parameters Map_ident.empty just_params body + rename_optional_parameters Ident.Map.empty just_params body in let params = - if Map_ident.is_empty new_map then just_params + if Ident.Map.is_empty new_map then just_params else - List.map (fun x -> Map_ident.find_default new_map x x) just_params + List.map + ~f:(fun x -> Ident.Map.find_default new_map x x) + just_params in Lam.function_ ~attr ~arity:(List.length params) ~params ~body | Llet (kind, _value_kind, id, e, body) (*FIXME*) -> convert_let kind id e body | Lmutlet (_value_kind, id, e, body) (*FIXME*) -> convert_mutlet id e body | Lletrec (bindings, body) -> - let bindings = Ext_list.map_snd bindings convert_aux in + let bindings = List.map_snd bindings convert_aux in let body = convert_aux body in let lam = Lam.letrec bindings body in Lam_scc.scc bindings lam body | Lprim (Pccall a, args, loc) -> convert_ccall a args (Debuginfo.Scoped_location.to_location loc) | Lprim (Pgetglobal id, args, _) -> - let args = List.map convert_aux args in + let args = List.map ~f:convert_aux args in if Ident.is_predef id then Lam.const (Const_string { s = Ident.name id; unicode = false }) else ( @@ -694,23 +698,24 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : assert (args = []); Lam.global_module id) | Lprim (primitive, args, loc) -> - let args = List.map convert_aux args in + let args = List.map ~f:convert_aux args in lam_prim ~primitive ~args (Debuginfo.Scoped_location.to_location loc) | Lswitch (e, s, _loc) -> convert_switch e s | Lstringswitch (e, cases, default, _) -> Lam.stringswitch (convert_aux e) - (Ext_list.map_snd cases convert_aux) + (List.map_snd cases convert_aux) (Option.map convert_aux default) | Lstaticraise (id, []) -> Lam.staticraise (Hash_int.find_default exit_map id id) [] - | Lstaticraise (id, args) -> Lam.staticraise id (List.map convert_aux args) + | Lstaticraise (id, args) -> + Lam.staticraise id (List.map ~f:convert_aux args) | Lstaticcatch (b, (i, []), Lstaticraise (j, [])) -> (* peep-hole [i] aliased to [j] *) Hash_int.add exit_map i (Hash_int.find_default exit_map j j); convert_aux b | Lstaticcatch (b, (i, ids), handler) -> Lam.staticcatch (convert_aux b) - (i, List.map fst ids) + (i, List.map ~f:fst ids) (convert_aux handler) | Ltrywith (b, id, handler) -> let body = convert_aux b in @@ -732,7 +737,7 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : | Lsend (kind, a, b, ls, outer_loc) -> ( let a = convert_aux a in let b = convert_aux b in - let ls = List.map convert_aux ls in + let ls = List.map ~f:convert_aux ls in (* Format.fprintf Format.err_formatter "%a@." Printlambda.lambda b ; *) match b with | Lprim { primitive = Pjs_unsafe_downgrade { loc; _ }; args; _ } -> ( @@ -745,7 +750,8 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : let property = if setter then Lam.Methname.translate - (String.sub name 0 String.(length name - length suffix)) + (String.sub name ~pos:0 + ~len:String.(length name - length suffix)) else Lam.Methname.translate name in let lam = @@ -773,9 +779,9 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : let e = convert_aux e in match (kind, e) with | Alias, Lvar u -> - let new_u = Hash_ident.find_default alias_tbl u u in - Hash_ident.add alias_tbl id new_u; - if Set_ident.mem exports id then + let new_u = Ident.Hash.find_default alias_tbl u u in + Ident.Hash.add alias_tbl id new_u; + if Ident.Set.mem exports id then Lam.let_ kind id (Lam.var new_u) (convert_aux body) else convert_aux body | _, _ -> ( @@ -816,13 +822,13 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : && (not (Lam_hit.hit_variable id ifso)) && not (List.exists - (fun (_, x) -> Lam_hit.hit_variable id x) + ~f:(fun (_, x) -> Lam_hit.hit_variable id x) sw_consts) -> Lam.switch matcher { px with sw_consts = - List.map (fun (i, act) -> (i - offset, act)) sw_consts; + List.map ~f:(fun (i, act) -> (i - offset, act)) sw_consts; } | _ -> Lam.let_ kind id e new_body) and convert_mutlet id (e : Lambda.lambda) body : Lam.t = @@ -848,8 +854,8 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : ap_args = args; _; } - when Ext_list.for_all2_no_exn inner_args params lam_is_var - && Ext_list.length_larger_than_n inner_args args 1 -> + when List.for_all2_no_exn inner_args params lam_is_var + && List.length_larger_than_n inner_args args 1 -> Lam.prim ~primitive ~args:(args @ [ x ]) (Debuginfo.Scoped_location.to_location outer_loc) | Lapply { ap_func; ap_args; ap_info } -> @@ -877,7 +883,7 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : sw_numconsts; _; } -> ( - let sw_consts = Ext_list.map_snd sw_consts convert_aux in + let sw_consts = List.map_snd sw_consts convert_aux in match happens_to_be_diff sw_consts with | Some 0l -> e | Some i -> @@ -891,16 +897,16 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : sw_blocks = []; sw_blocks_full = true; sw_consts; - sw_consts_full = Ext_list.length_ge sw_consts sw_numconsts; + sw_consts_full = List.length_ge sw_consts sw_numconsts; sw_names = s.sw_names; }) | _ -> Lam.switch e { - sw_consts_full = Ext_list.length_ge s.sw_consts s.sw_numconsts; - sw_consts = Ext_list.map_snd s.sw_consts convert_aux; - sw_blocks_full = Ext_list.length_ge s.sw_blocks s.sw_numblocks; - sw_blocks = Ext_list.map_snd s.sw_blocks convert_aux; + sw_consts_full = List.length_ge s.sw_consts s.sw_numconsts; + sw_consts = List.map_snd s.sw_consts convert_aux; + sw_blocks_full = List.length_ge s.sw_blocks s.sw_numblocks; + sw_blocks = List.map_snd s.sw_blocks convert_aux; sw_failaction = Option.map convert_aux s.sw_failaction; sw_names = s.sw_names; } @@ -940,7 +946,7 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : | [], [] -> [] | x::xs, [] -> | [], y::ys - if Ext_list.same_length inner_args args then + if List.same_length inner_args args then aux (Lprim(prim,args,inner_loc)) else diff --git a/jscomp/core/lam_convert.mli b/jscomp/core/lam_convert.mli index d4d0da41c1..e90d6b8c5b 100644 --- a/jscomp/core/lam_convert.mli +++ b/jscomp/core/lam_convert.mli @@ -1,5 +1,5 @@ (* Copyright (C) 2018 - Authors of ReScript - * + * * 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,32 +17,31 @@ * 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. *) -(* val happens_to_be_diff: - (int * Lambda.lambda) list -> int option *) +open Import val convert : - Set_ident.t -> Lambda.lambda -> Lam.t * Lam_module_ident.Hash_set.t -(** + Ident.Set.t -> Lambda.lambda -> Lam.t * Lam_module_ident.Hash_set.t +(** [convert exports lam] it also collect [exit_map] and a collection of potential depended modules [may_depends] - In this pass we also synchronized aliases so that + In this pass we also synchronized aliases so that {[ - let a1 = a0 in - let a2 = a1 in - let a3 = a2 in - let a4 = a3 in + let a1 = a0 in + let a2 = a1 in + let a3 = a2 in + let a4 = a3 in ]} - converted to + converted to {[ - let a1 = a0 in - let a2 = a0 in - let a3 = a0 in - let a4 = a0 in + let a1 = a0 in + let a2 = a0 in + let a3 = a0 in + let a4 = a0 in ]} we dont eliminate unused let bindings to leave it for {!Lam_pass_lets_dce} we should remove all those let aliases, otherwise, it will be diff --git a/jscomp/core/lam_dce.ml b/jscomp/core/lam_dce.ml index 8dbec0e19e..3a975a4ce7 100644 --- a/jscomp/core/lam_dce.ml +++ b/jscomp/core/lam_dce.ml @@ -22,66 +22,68 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + let transitive_closure (initial_idents : Ident.t list) - (ident_freevars : Set_ident.t Hash_ident.t) = - let visited = Hash_set_ident.create 31 in + (ident_freevars : Ident.Set.t Ident.Hash.t) = + let visited = Ident.Hash_set.create 31 in let rec dfs (id : Ident.t) : unit = - if not (Hash_set_ident.mem visited id || Ext_ident.is_js_or_global id) then ( - Hash_set_ident.add visited id; - match Hash_ident.find_opt ident_freevars id with + if not (Ident.Hash_set.mem visited id || Ident.is_js_or_global id) then ( + Ident.Hash_set.add visited id; + match Ident.Hash.find_opt ident_freevars id with | None -> Format.ksprintf (fun s -> failwith (__LOC__ ^ s)) - "%s/%d not found" (Ident.name id) (Ext_ident.stamp id) - | Some e -> Set_ident.iter e dfs) + "%s/%d not found" (Ident.name id) (Ident.stamp id) + | Some e -> Ident.Set.iter e dfs) in - List.iter dfs initial_idents; + List.iter ~f:dfs initial_idents; visited let remove export_idents (rest : Lam_group.t list) : Lam_group.t list = - let ident_free_vars : _ Hash_ident.t = Hash_ident.create 17 in + let ident_free_vars : _ Ident.Hash.t = Ident.Hash.create 17 in (* calculate initial required idents, at the same time, populate dependency set [ident_free_vars] *) let initial_idents = List.fold_left - (fun acc (x : Lam_group.t) -> + ~f:(fun acc (x : Lam_group.t) -> match x with | Single (kind, id, lam) -> ( - Hash_ident.add ident_free_vars id + Ident.Hash.add ident_free_vars id (Lam_free_variables.pass_free_variables lam); match kind with | Alias | StrictOpt -> acc | Strict | Variable -> id :: acc) | Recursive bindings -> List.fold_left - (fun acc (id, lam) -> - Hash_ident.add ident_free_vars id + ~f:(fun acc (id, lam) -> + Ident.Hash.add ident_free_vars id (Lam_free_variables.pass_free_variables lam); match lam with Lfunction _ -> acc | _ -> id :: acc) - acc bindings + ~init:acc bindings | Nop lam -> if Lam_analysis.no_side_effects lam then acc else (* its free varaibles here will be defined above *) - Set_ident.fold (Lam_free_variables.pass_free_variables lam) acc + Ident.Set.fold (Lam_free_variables.pass_free_variables lam) acc (fun x acc -> x :: acc)) - export_idents rest + ~init:export_idents rest in let visited = transitive_closure initial_idents ident_free_vars in List.fold_left - (fun acc (x : Lam_group.t) -> + ~f:(fun acc (x : Lam_group.t) -> match x with | Single (_, id, _) -> - if Hash_set_ident.mem visited id then x :: acc else acc + if Ident.Hash_set.mem visited id then x :: acc else acc | Nop _ -> x :: acc | Recursive bindings -> ( let b = List.fold_right - (fun ((id, _) as v) acc -> - if Hash_set_ident.mem visited id then v :: acc else acc) - bindings [] + ~f:(fun ((id, _) as v) acc -> + if Ident.Hash_set.mem visited id then v :: acc else acc) + bindings ~init:[] in match b with [] -> acc | _ -> Recursive b :: acc)) - [] rest + ~init:[] rest |> List.rev diff --git a/jscomp/core/lam_eta_conversion.ml b/jscomp/core/lam_eta_conversion.ml index 16a93c7142..d53bf97d3d 100644 --- a/jscomp/core/lam_eta_conversion.ml +++ b/jscomp/core/lam_eta_conversion.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + module L = struct let param = "param" let partial_arg = "partial_arg" @@ -40,11 +42,11 @@ end Return a function of airty [n] *) let transform_under_supply n ap_info fn args = - let extra_args = List.init n (fun _ -> Ident.create_local L.param) in - let extra_lambdas = List.map Lam.var extra_args in + let extra_args = List.init ~len:n ~f:(fun _ -> Ident.create_local L.param) in + let extra_lambdas = List.map ~f:Lam.var extra_args in match List.fold_right - (fun (lam : Lam.t) (acc, bind) -> + ~f:(fun (lam : Lam.t) (acc, bind) -> match lam with | Lvar _ | Lmutvar _ | Lconst @@ -57,7 +59,7 @@ let transform_under_supply n ap_info fn args = | _ -> let v = Ident.create_local L.partial_arg in (Lam.var v :: acc, (v, lam) :: bind)) - (fn :: args) ([], []) + (fn :: args) ~init:([], []) with | fn :: args, [] -> (* More than no side effect in the [args], @@ -77,7 +79,9 @@ let transform_under_supply n ap_info fn args = ~attr:Lambda.default_function_attribute ~body:(Lam.apply fn (List.append args extra_lambdas) ap_info) in - List.fold_left (fun lam (id, x) -> Lam.let_ Strict id x lam) rest bindings + List.fold_left + ~f:(fun lam (id, x) -> Lam.let_ Strict id x lam) + ~init:rest bindings | _, _ -> assert false (* Invariant: mk0 : (unit -> 'a0) -> 'a0 t @@ -144,7 +148,7 @@ let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : } -> (None, fn) | _ -> - let partial_arg = Ext_ident.create L.partial_arg in + let partial_arg = Ident.create L.partial_arg in (Some partial_arg, Lam.var partial_arg) in @@ -164,15 +168,16 @@ let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : {[ fun x y -> f y ]} *) let extra_args = - List.init (to_ - from) (fun _ -> Ident.create_local L.param) + List.init ~len:(to_ - from) ~f:(fun _ -> + Ident.create_local L.param) in Lam.function_ ~attr:Lambda.default_function_attribute ~arity:to_ ~params:(List.append params extra_args) - ~body:(Lam.apply body (List.map Lam.var extra_args) ap_info) + ~body:(Lam.apply body (List.map ~f:Lam.var extra_args) ap_info) | _ -> ( let arity = to_ in let extra_args = - List.init to_ (fun _ -> Ident.create_local L.param) + List.init ~len:to_ ~f:(fun _ -> Ident.create_local L.param) in let wrapper, new_fn = match fn with @@ -185,21 +190,19 @@ let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : } -> (None, fn) | _ -> - let partial_arg = Ext_ident.create L.partial_arg in + let partial_arg = Ident.create L.partial_arg in (Some partial_arg, Lam.var partial_arg) in let cont = Lam.function_ ~arity ~attr:Lambda.default_function_attribute ~params:extra_args ~body: - (let first_args, rest_args = - Ext_list.split_at extra_args from - in + (let first_args, rest_args = List.split_at extra_args from in Lam.apply (Lam.apply new_fn - (List.map Lam.var first_args) + (List.map ~f:Lam.var first_args) { ap_info with ap_status = App_infer_full }) - (List.map Lam.var rest_args) + (List.map ~f:Lam.var rest_args) ap_info) in match wrapper with @@ -218,7 +221,7 @@ let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : (* TODO check arity = List.length params in debug mode *) -> let arity = to_ in let extra_outer_args, extra_inner_args = - Ext_list.split_at params arity + List.split_at params arity in Lam.function_ ~arity ~attr:Lambda.default_function_attribute ~params:extra_outer_args @@ -228,7 +231,7 @@ let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : ~params:extra_inner_args ~body) | _ -> ( let extra_outer_args = - List.init to_ (fun _ -> Ident.create_local L.param) + List.init ~len:to_ ~f:(fun _ -> Ident.create_local L.param) in let wrapper, new_fn = match fn with @@ -241,7 +244,7 @@ let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : } -> (None, fn) | _ -> - let partial_arg = Ext_ident.create L.partial_arg in + let partial_arg = Ident.create L.partial_arg in (Some partial_arg, Lam.var partial_arg) in let cont = @@ -250,14 +253,15 @@ let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : ~body: (let arity = from - to_ in let extra_inner_args = - List.init arity (fun _ -> Ident.create_local L.param) + List.init ~len:arity ~f:(fun _ -> + Ident.create_local L.param) in Lam.function_ ~arity ~params:extra_inner_args ~attr:Lambda.default_function_attribute ~body: (Lam.apply new_fn - (List.map Lam.var extra_outer_args - @ List.map Lam.var extra_inner_args) + (List.map ~f:Lam.var extra_outer_args + @ List.map ~f:Lam.var extra_inner_args) { ap_info with ap_status = App_infer_full })) in match wrapper with @@ -277,7 +281,7 @@ let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : } -> (None, fn) | _ -> - let partial_arg = Ext_ident.create L.partial_arg in + let partial_arg = Ident.create L.partial_arg in (Some partial_arg, Lam.var partial_arg) in diff --git a/jscomp/core/lam_free_variables.ml b/jscomp/core/lam_free_variables.ml index d7c8bf0da2..8ac62487b6 100644 --- a/jscomp/core/lam_free_variables.ml +++ b/jscomp/core/lam_free_variables.ml @@ -22,41 +22,43 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let pass_free_variables (l : Lam.t) : Set_ident.t = - let fv = ref Set_ident.empty in - let rec free_list xs = List.iter free xs +open Import + +let pass_free_variables (l : Lam.t) : Ident.Set.t = + let fv = ref Ident.Set.empty in + let rec free_list xs = List.iter ~f:free xs and free_list_snd : 'a. ('a * Lam.t) list -> unit = - fun xs -> List.iter (fun (_, x) -> free x) xs + fun xs -> List.iter ~f:(fun (_, x) -> free x) xs and free (l : Lam.t) = match l with - | Lvar id | Lmutvar id -> fv := Set_ident.add !fv id + | Lvar id | Lmutvar id -> fv := Ident.Set.add !fv id | Lassign (id, e) -> free e; - fv := Set_ident.add !fv id + fv := Ident.Set.add !fv id | Lstaticcatch (e1, (_, vars), e2) -> free e1; free e2; - List.iter (fun id -> fv := Set_ident.remove !fv id) vars + List.iter ~f:(fun id -> fv := Ident.Set.remove !fv id) vars | Ltrywith (e1, exn, e2) -> free e1; free e2; - fv := Set_ident.remove !fv exn + fv := Ident.Set.remove !fv exn | Lfunction { body; params; _ } -> free body; - List.iter (fun param -> fv := Set_ident.remove !fv param) params + List.iter ~f:(fun param -> fv := Ident.Set.remove !fv param) params | Llet (_, id, arg, body) | Lmutlet (id, arg, body) -> free arg; free body; - fv := Set_ident.remove !fv id + fv := Ident.Set.remove !fv id | Lletrec (decl, body) -> free body; free_list_snd decl; - List.iter (fun (id, _exp) -> fv := Set_ident.remove !fv id) decl + List.iter ~f:(fun (id, _exp) -> fv := Ident.Set.remove !fv id) decl | Lfor (v, e1, e2, _dir, e3) -> free e1; free e2; free e3; - fv := Set_ident.remove !fv v + fv := Ident.Set.remove !fv v | Lconst _ -> () | Lapply { ap_func; ap_args; _ } -> free ap_func; diff --git a/jscomp/core/lam_free_variables.mli b/jscomp/core/lam_free_variables.mli index 5622ed7f79..436c453193 100644 --- a/jscomp/core/lam_free_variables.mli +++ b/jscomp/core/lam_free_variables.mli @@ -22,4 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val pass_free_variables : Lam.t -> Set_ident.t +open Import + +val pass_free_variables : Lam.t -> Ident.Set.t diff --git a/jscomp/core/lam_hit.ml b/jscomp/core/lam_hit.ml index d412d73aef..5c2bf9e095 100644 --- a/jscomp/core/lam_hit.ml +++ b/jscomp/core/lam_hit.ml @@ -22,15 +22,17 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + type t = Lam.t -let hit_variables (fv : Set_ident.t) (l : t) : bool = +let hit_variables (fv : Ident.Set.t) (l : t) : bool = let rec hit_opt (x : t option) = match x with None -> false | Some a -> hit a - and hit_var (id : Ident.t) = Set_ident.mem fv id + and hit_var (id : Ident.t) = Ident.Set.mem fv id and hit_list_snd : 'a. ('a * t) list -> bool = - fun x -> List.exists (fun (_, x) -> hit x) x - and hit_list xs = List.exists hit xs + fun x -> List.exists ~f:(fun (_, x) -> hit x) x + and hit_list xs = List.exists ~f:hit xs and hit (l : t) = match (l : t) with | Lvar id | Lmutvar id -> hit_var id @@ -64,8 +66,8 @@ let hit_variable (fv : Ident.t) (l : t) : bool = match x with None -> false | Some a -> hit a and hit_var (id : Ident.t) = Ident.same id fv and hit_list_snd : 'a. ('a * t) list -> bool = - fun x -> List.exists (fun (_, x) -> hit x) x - and hit_list xs = List.exists hit xs + fun x -> List.exists ~f:(fun (_, x) -> hit x) x + and hit_list xs = List.exists ~f:hit xs and hit (l : t) = match (l : t) with | Lvar id | Lmutvar id -> hit_var id diff --git a/jscomp/core/lam_hit.mli b/jscomp/core/lam_hit.mli index 2584d232a8..ae492c5479 100644 --- a/jscomp/core/lam_hit.mli +++ b/jscomp/core/lam_hit.mli @@ -22,5 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val hit_variables : Set_ident.t -> Lam.t -> bool +open Import + +val hit_variables : Ident.Set.t -> Lam.t -> bool val hit_variable : Ident.t -> Lam.t -> bool diff --git a/jscomp/core/lam_id_kind.ml b/jscomp/core/lam_id_kind.ml index 16acda6d7c..d789c85e1f 100644 --- a/jscomp/core/lam_id_kind.ml +++ b/jscomp/core/lam_id_kind.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (** Keep track of which identifiers are aliased *) @@ -68,7 +70,7 @@ let print fmt (kind : t) = | OptionalBlock (_, Null_undefined) -> pp fmt "?Nullable" | MutableBlock arr -> pp fmt "Mutable(%d)" (Array.length arr) | Constant _ -> pp fmt "Constant" - | Module id -> pp fmt "%s/%d" (Ident.name id) (Ext_ident.stamp id) + | Module id -> pp fmt "%s/%d" (Ident.name id) (Ident.stamp id) | FunctionId _ -> pp fmt "FunctionID" | Exception -> pp fmt "Exception" | Parameter -> pp fmt "Parameter" diff --git a/jscomp/core/lam_module_ident.ml b/jscomp/core/lam_module_ident.ml index cef9c3b90c..46a4d4ddc0 100644 --- a/jscomp/core/lam_module_ident.ml +++ b/jscomp/core/lam_module_ident.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + type t = J.module_id = { id : Ident.t; kind : Js_op.kind } let id x = x.id @@ -43,7 +45,7 @@ module Cmp = struct | External { name = y_kind; default = y_default } -> x_kind = (y_kind : string) && x_default = y_default | _ -> false) - | Ml | Runtime -> Ext_ident.equal x.id y.id + | Ml | Runtime -> Ident.equal x.id y.id (* #1556 Note the main difference between [Ml] and [Runtime] is @@ -65,7 +67,7 @@ module Cmp = struct Hashtbl.hash x_kind | Ml | Runtime -> let x_id = x.id in - Hashtbl.hash (Ext_ident.stamp x_id, Ident.name x_id) + Hashtbl.hash (Ident.stamp x_id, Ident.name x_id) end module Hash = Hash.Make (Cmp) diff --git a/jscomp/core/lam_module_ident.mli b/jscomp/core/lam_module_ident.mli index 2aaa89536a..b213051bc3 100644 --- a/jscomp/core/lam_module_ident.mli +++ b/jscomp/core/lam_module_ident.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,13 +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. *) -(** A type for qualified identifiers in Lambda IR - *) +open Import + +(** A type for qualified identifiers in Lambda IR *) type t = J.module_id = { (*private*) id : Ident.t; kind : Js_op.kind } diff --git a/jscomp/core/lam_pass_alpha_conversion.ml b/jscomp/core/lam_pass_alpha_conversion.ml index f6468c4ea6..e2ac8197d5 100644 --- a/jscomp/core/lam_pass_alpha_conversion.ml +++ b/jscomp/core/lam_pass_alpha_conversion.ml @@ -22,27 +22,29 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = let rec populateApplyInfo (args_arity : int list) (len : int) (fn : Lam.t) (args : Lam.t list) ap_info : Lam.t = match args_arity with - | 0 :: _ | [] -> Lam.apply (simpl fn) (List.map simpl args) ap_info + | 0 :: _ | [] -> Lam.apply (simpl fn) (List.map ~f:simpl args) ap_info | x :: _ -> if x = len then - Lam.apply (simpl fn) (List.map simpl args) + Lam.apply (simpl fn) (List.map ~f:simpl args) { ap_info with ap_status = App_infer_full } else if x > len then let fn = simpl fn in - let args = List.map simpl args in + let args = List.map ~f:simpl args in Lam_eta_conversion.transform_under_supply (x - len) { ap_info with ap_status = App_infer_full } fn args else - let first, rest = Ext_list.split_at args x in + let first, rest = List.split_at args x in Lam.apply - (Lam.apply (simpl fn) (List.map simpl first) + (Lam.apply (simpl fn) (List.map ~f:simpl first) { ap_info with ap_status = App_infer_full }) - (List.map simpl rest) ap_info + (List.map ~f:simpl rest) ap_info (* TODO refien *) and simpl (lam : Lam.t) = match lam with @@ -58,7 +60,7 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = | Llet (str, v, l1, l2) -> Lam.let_ str v (simpl l1) (simpl l2) | Lmutlet (v, l1, l2) -> Lam.mutlet v (simpl l1) (simpl l2) | Lletrec (bindings, body) -> - let bindings = Ext_list.map_snd bindings simpl in + let bindings = List.map_snd bindings simpl in Lam.letrec bindings (simpl body) | Lglobal_module _ -> lam | Lprim { primitive = Pjs_fn_make len as primitive; args = [ arg ]; loc } @@ -71,7 +73,7 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = Lam_eta_conversion.unsafe_adjust_to_arity loc ~to_:len ~from:x arg | None -> Lam.prim ~primitive ~args:[ simpl arg ] loc) | Lprim { primitive; args; loc } -> - Lam.prim ~primitive ~args:(List.map simpl args) loc + Lam.prim ~primitive ~args:(List.map ~f:simpl args) loc | Lfunction { arity; params; body; attr } -> (* Lam_mk.lfunction kind params (simpl l) *) Lam.function_ ~arity ~params ~body:(simpl body) ~attr @@ -87,18 +89,16 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = } ) -> Lam.switch (simpl l) { - sw_consts = Ext_list.map_snd sw_consts simpl; - sw_blocks = Ext_list.map_snd sw_blocks simpl; + sw_consts = List.map_snd sw_consts simpl; + sw_blocks = List.map_snd sw_blocks simpl; sw_consts_full; sw_blocks_full; sw_failaction = Option.map simpl sw_failaction; sw_names; } | Lstringswitch (l, sw, d) -> - Lam.stringswitch (simpl l) - (Ext_list.map_snd sw simpl) - (Option.map simpl d) - | Lstaticraise (i, ls) -> Lam.staticraise i (List.map simpl ls) + Lam.stringswitch (simpl l) (List.map_snd sw simpl) (Option.map simpl d) + | Lstaticraise (i, ls) -> Lam.staticraise i (List.map ~f:simpl ls) | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (simpl l1) ids (simpl l2) | Ltrywith (l1, v, l2) -> Lam.try_ (simpl l1) v (simpl l2) | Lifthenelse (l1, l2, l3) -> Lam.if_ (simpl l1) (simpl l2) (simpl l3) @@ -111,7 +111,7 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = v's refsimpl *) Lam.assign v (simpl l) | Lsend (u, m, o, ll, v) -> - Lam.send u (simpl m) (simpl o) (List.map simpl ll) v + Lam.send u (simpl m) (simpl o) (List.map ~f:simpl ll) v | Lifused (v, e) -> Lam.ifused v (simpl e) in diff --git a/jscomp/core/lam_pass_collect.ml b/jscomp/core/lam_pass_collect.ml index 384e94f885..d648a7d63d 100644 --- a/jscomp/core/lam_pass_collect.ml +++ b/jscomp/core/lam_pass_collect.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (* Check, it is shared across ident_tbl, Only [Lassign] will break such invariant, how about guarantee that [Lassign] only check the local ref @@ -33,18 +35,18 @@ *) let annotate (meta : Lam_stats.t) rec_flag (k : Ident.t) (arity : Lam_arity.t) lambda = - Hash_ident.add meta.ident_tbl k + Ident.Hash.add meta.ident_tbl k (FunctionId { arity; lambda = Some (lambda, rec_flag) }) (* see #3609 we have to update since bounded function lambda may contain staled unbounded varaibles *) -(* match Hash_ident.find_opt meta.ident_tbl k with +(* match Ident.Hash.find_opt meta.ident_tbl k with | None -> (* FIXME: need do a sanity check of arity is NA or Determin(_,[],_) *) | Some (FunctionId old) -> - Hash_ident.add meta.ident_tbl k + Ident.Hash.add meta.ident_tbl k (FunctionId {arity; lambda = Some (lambda, rec_flag) }) (* old.arity <- arity *) (* due to we keep refining arity analysis after each round*) @@ -58,14 +60,14 @@ let annotate (meta : Lam_stats.t) rec_flag (k : Ident.t) (arity : Lam_arity.t) let collect_info (meta : Lam_stats.t) (lam : Lam.t) = let rec collect_bind rec_flag (ident : Ident.t) (lam : Lam.t) = match lam with - | Lconst v -> Hash_ident.replace meta.ident_tbl ident (Constant v) + | Lconst v -> Ident.Hash.replace meta.ident_tbl ident (Constant v) (* *) | Lprim { primitive = Pmakeblock (_, _, Immutable); args = ls; _ } -> - Hash_ident.replace meta.ident_tbl ident + Ident.Hash.replace meta.ident_tbl ident (Lam_util.kind_of_lambda_block ls); - List.iter collect ls + List.iter ~f:collect ls | Lprim { primitive = Psome | Psome_not_nest; args = [ v ]; _ } -> - Hash_ident.replace meta.ident_tbl ident (Normal_optional v); + Ident.Hash.replace meta.ident_tbl ident (Normal_optional v); collect v | Lprim { @@ -74,15 +76,15 @@ let collect_info (meta : Lam_stats.t) (lam : Lam.t) = args = _; _; } -> - Hash_ident.replace meta.ident_tbl ident + Ident.Hash.replace meta.ident_tbl ident (FunctionId { arity = Lam_arity.info [ arity ] false; lambda = None }) | Lprim { primitive = Pnull_to_opt; args = [ (Lvar _ as l) ]; _ } -> - Hash_ident.replace meta.ident_tbl ident (OptionalBlock (l, Null)) + Ident.Hash.replace meta.ident_tbl ident (OptionalBlock (l, Null)) | Lprim { primitive = Pundefined_to_opt; args = [ (Lvar _ as l) ]; _ } -> - Hash_ident.replace meta.ident_tbl ident (OptionalBlock (l, Undefined)) + Ident.Hash.replace meta.ident_tbl ident (OptionalBlock (l, Undefined)) | Lprim { primitive = Pnull_undefined_to_opt; args = [ (Lvar _ as l) ]; _ } -> - Hash_ident.replace meta.ident_tbl ident + Ident.Hash.replace meta.ident_tbl ident (OptionalBlock (l, Null_undefined)) | Lglobal_module v -> Lam_util.alias_ident_or_global meta ident v (Module v) | Lvar v -> @@ -97,13 +99,13 @@ let collect_info (meta : Lam_stats.t) (lam : Lam.t) = -- since collect would iter everywhere, so -- it would still iterate internally *) - List.iter (fun p -> Hash_ident.add meta.ident_tbl p Parameter) params; + List.iter ~f:(fun p -> Ident.Hash.add meta.ident_tbl p Parameter) params; let arity = Lam_arity_analysis.get_arity meta lam in annotate meta rec_flag ident arity lam; collect body | x -> collect x; - if Set_ident.mem meta.export_idents ident then + if Ident.Set.mem meta.export_idents ident then annotate meta rec_flag ident (Lam_arity_analysis.get_arity meta x) lam and collect (lam : Lam.t) = match lam with @@ -111,10 +113,10 @@ let collect_info (meta : Lam_stats.t) (lam : Lam.t) = | Lvar _ | Lmutvar _ -> () | Lapply { ap_func = l1; ap_args = ll; _ } -> collect l1; - List.iter collect ll + List.iter ~f:collect ll | Lfunction { params; body = l; _ } -> (* functor ? *) - List.iter (fun p -> Hash_ident.add meta.ident_tbl p Parameter) params; + List.iter ~f:(fun p -> Ident.Hash.add meta.ident_tbl p Parameter) params; collect l | Llet (_, ident, arg, body) | Lmutlet (ident, arg, body) -> collect_bind Lam_non_rec ident arg; @@ -124,21 +126,21 @@ let collect_info (meta : Lam_stats.t) (lam : Lam.t) = | [ (ident, arg) ] -> collect_bind Lam_self_rec ident arg | _ -> List.iter - (fun (ident, arg) -> collect_bind Lam_rec ident arg) + ~f:(fun (ident, arg) -> collect_bind Lam_rec ident arg) bindings); collect body | Lglobal_module _ -> () - | Lprim { args; _ } -> List.iter collect args + | Lprim { args; _ } -> List.iter ~f:collect args | Lswitch (l, { sw_failaction; sw_consts; sw_blocks; _ }) -> collect l; - List.iter (fun (_, x) -> collect x) sw_consts; - List.iter (fun (_, x) -> collect x) sw_blocks; + List.iter ~f:(fun (_, x) -> collect x) sw_consts; + List.iter ~f:(fun (_, x) -> collect x) sw_blocks; Option.iter collect sw_failaction | Lstringswitch (l, sw, d) -> collect l; - List.iter (fun (_, x) -> collect x) sw; + List.iter ~f:(fun (_, x) -> collect x) sw; Option.iter collect d - | Lstaticraise (_code, ls) -> List.iter collect ls + | Lstaticraise (_code, ls) -> List.iter ~f:collect ls | Lstaticcatch (l1, (_, _), l2) -> collect l1; collect l2 @@ -166,7 +168,7 @@ let collect_info (meta : Lam_stats.t) (lam : Lam.t) = | Lsend (_, m, o, ll, _) -> collect m; collect o; - List.iter collect ll + List.iter ~f:collect ll | Lifused (_v, e) -> collect e in collect lam diff --git a/jscomp/core/lam_pass_count.ml b/jscomp/core/lam_pass_count.ml index cf4799b3f3..a91abd6309 100644 --- a/jscomp/core/lam_pass_count.ml +++ b/jscomp/core/lam_pass_count.ml @@ -11,7 +11,9 @@ (************************************) (* Adapted for Javascript backend : Hongbo Zhang, *) -(*A naive dead code elimination *) +open Import + +(* A naive dead code elimination *) type used_info = { mutable times : int; mutable captured : bool; @@ -22,10 +24,10 @@ type used_info = { *) } -type occ_tbl = used_info Hash_ident.t +type occ_tbl = used_info Ident.Hash.t (* First pass: count the occurrences of all let-bound identifiers *) -type local_tbl = used_info Map_ident.t +type local_tbl = used_info Ident.Map.t let dummy_info () = { times = 0; captured = false } (* y is untouched *) @@ -40,7 +42,7 @@ let pp_info fmt (x : used_info) = Format.fprintf fmt "(:%d)" x.captured x.times let pp_occ_tbl fmt tbl = - Hash_ident.iter tbl (fun k v -> + Ident.Hash.iter tbl (fun k v -> Format.fprintf fmt "@[%a@ %a@]@." Ident.print k pp_info v) (* The global table [occ] associates to each let-bound identifier @@ -57,11 +59,11 @@ let pp_occ_tbl fmt tbl = its reference count, as above. [bv] is enriched at let bindings but emptied when crossing lambdas and loops. *) let collect_occurs lam : occ_tbl = - let occ : occ_tbl = Hash_ident.create 83 in + let occ : occ_tbl = Ident.Hash.create 83 in (* Current use count of a variable. *) let used v = - match Hash_ident.find_opt occ v with + match Ident.Hash.find_opt occ v with | None -> false | Some { times; _ } -> times > 0 in @@ -69,19 +71,19 @@ let collect_occurs lam : occ_tbl = (* Entering a [let]. Returns updated [bv]. *) let bind_var bv ident = let r = dummy_info () in - Hash_ident.add occ ident r; - Map_ident.add bv ident r + Ident.Hash.add occ ident r; + Ident.Map.add bv ident r in (* Record a use of a variable *) let add_one_use bv ident = - match Map_ident.find_opt bv ident with + match Ident.Map.find_opt bv ident with | Some r -> r.times <- r.times + 1 | None -> ( (* ident is not locally bound, therefore this is a use under a lambda or within a loop. Increase use count by 2 -- enough so that single-use optimizations will not apply. *) - match Hash_ident.find_opt occ ident with + match Ident.Hash.find_opt occ ident with | Some r -> absorb_info r { times = 1; captured = true } | None -> (* Not a let-bound variable, ignore *) @@ -90,17 +92,17 @@ let collect_occurs lam : occ_tbl = let inherit_use bv ident bid = let n = - match Hash_ident.find_opt occ bid with + match Ident.Hash.find_opt occ bid with | None -> dummy_info () | Some v -> v in - match Map_ident.find_opt bv ident with + match Ident.Map.find_opt bv ident with | Some r -> absorb_info r n | None -> ( (* ident is not locally bound, therefore this is a use under a lambda or within a loop. Increase use count by 2 -- enough so that single-use optimizations will not apply. *) - match Hash_ident.find_opt occ ident with + match Ident.Hash.find_opt occ ident with | Some r -> absorb_info r { n with captured = true } | None -> (* Not a let-bound variable, ignore *) @@ -109,7 +111,7 @@ let collect_occurs lam : occ_tbl = let rec count (bv : local_tbl) (lam : Lam.t) = match lam with - | Lfunction { body = l; _ } -> count Map_ident.empty l + | Lfunction { body = l; _ } -> count Ident.Map.empty l (* when entering a function local [bv] is cleaned up, so that all closure variables will not be carried over, since the parameters are never rebound, @@ -118,10 +120,10 @@ let collect_occurs lam : occ_tbl = | Lfor (_, l1, l2, _dir, l3) -> count bv l1; count bv l2; - count Map_ident.empty l3 + count Ident.Map.empty l3 | Lwhile (l1, l2) -> - count Map_ident.empty l1; - count Map_ident.empty l2 + count Ident.Map.empty l1; + count Ident.Map.empty l2 | Lvar v | Lmutvar v -> add_one_use bv v | Llet (_, v, Lvar w, l2) -> (* v will be replaced by w in l2, so each occurrence of v in l2 @@ -141,37 +143,37 @@ let collect_occurs lam : occ_tbl = this ident's refcount *) count bv l | Lglobal_module _ -> () - | Lprim { args; _ } -> List.iter (count bv) args + | Lprim { args; _ } -> List.iter ~f:(count bv) args | Lletrec (bindings, body) -> - List.iter (fun (_v, l) -> count bv l) bindings; + List.iter ~f:(fun (_v, l) -> count bv l) bindings; count bv body (* Note there is a difference here when do beta reduction for *) | Lapply { ap_func = Lfunction { params; body; _ }; ap_args = args; _ } - when Ext_list.same_length params args -> + when List.same_length params args -> count bv (Lam_beta_reduce.no_names_beta_reduce params body args) (* | Lapply{fn = Lfunction{function_kind = Tupled; params; body}; *) (* args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *) - (* when Ext_list.same_length params args -> *) + (* when List.same_length params args -> *) (* count bv (Lam_beta_reduce.beta_reduce params body args) *) | Lapply { ap_func = l1; ap_args = ll; _ } -> count bv l1; - List.iter (count bv) ll + List.iter ~f:(count bv) ll | Lconst _cst -> () | Lswitch (l, sw) -> count_default bv sw; count bv l; - List.iter (fun (_, l) -> count bv l) sw.sw_consts; - List.iter (fun (_, l) -> count bv l) sw.sw_blocks + List.iter ~f:(fun (_, l) -> count bv l) sw.sw_consts; + List.iter ~f:(fun (_, l) -> count bv l) sw.sw_blocks | Lstringswitch (l, sw, d) -> ( count bv l; - List.iter (fun (_, l) -> count bv l) sw; + List.iter ~f:(fun (_, l) -> count bv l) sw; match d with Some d -> count bv d | None -> ()) (* x2 for native backend *) (* begin match sw with *) (* | []|[_] -> count bv d *) (* | _ -> count bv d ; count bv d *) (* end *) - | Lstaticraise (_i, ls) -> List.iter (count bv) ls + | Lstaticraise (_i, ls) -> List.iter ~f:(count bv) ls | Lstaticcatch (l1, (_i, _), l2) -> count bv l1; count bv l2 @@ -188,7 +190,7 @@ let collect_occurs lam : occ_tbl = | Lsend (_, m, o, ll, _) -> count bv m; count bv o; - List.iter (count bv) ll + List.iter ~f:(count bv) ll | Lifused (v, l) -> if used v then count bv l and count_default bv sw = match sw.sw_failaction with @@ -203,5 +205,5 @@ let collect_occurs lam : occ_tbl = assert ((not sw.sw_consts_full) || not sw.sw_blocks_full); count bv al) in - count Map_ident.empty lam; + count Ident.Map.empty lam; occ diff --git a/jscomp/core/lam_pass_count.mli b/jscomp/core/lam_pass_count.mli index 4f2b084f7f..286a50874c 100644 --- a/jscomp/core/lam_pass_count.mli +++ b/jscomp/core/lam_pass_count.mli @@ -11,6 +11,8 @@ (***********************************************************************) (* Adapted for Javascript backend : Hongbo Zhang, *) +open Import + type used_info = { mutable times : int; mutable captured : bool; @@ -21,7 +23,7 @@ type used_info = { *) } -type occ_tbl = used_info Hash_ident.t +type occ_tbl = used_info Ident.Hash.t val dummy_info : unit -> used_info val collect_occurs : Lam.t -> occ_tbl diff --git a/jscomp/core/lam_pass_deep_flatten.ml b/jscomp/core/lam_pass_deep_flatten.ml index 57c2cbb0d9..0386899993 100644 --- a/jscomp/core/lam_pass_deep_flatten.ml +++ b/jscomp/core/lam_pass_deep_flatten.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (* type eliminate = | Not_eliminatable | *) @@ -105,12 +107,12 @@ let rec eliminate_tuple (id : Ident.t) (lam : Lam.t) acc = let lambda_of_groups ~(rev_bindings : Lam_group.t list) (result : Lam.t) : Lam.t = List.fold_left - (fun acc (x : Lam_group.t) -> + ~f:(fun acc (x : Lam_group.t) -> match x with | Nop l -> Lam.seq l acc | Single (kind, ident, lam) -> Lam_util.refine_let ~kind ident lam acc | Recursive bindings -> Lam.letrec bindings acc) - result rev_bindings + ~init:result rev_bindings (* TODO: refine effectful [ket_kind] to be pure or not @@ -205,7 +207,7 @@ let deep_flatten (lam : Lam.t) : Lam.t = match eliminate_tuple id body Map_int.empty with | Some (tuple_mapping, body) -> flatten - (Ext_list.fold_left_with_offset args accux 0 (fun arg acc i -> + (List.fold_left_with_offset args accux 0 (fun arg acc i -> match Map_int.find_opt tuple_mapping i with | None -> Lam_group.nop_cons arg acc | Some key -> Lam_group.single kind key arg :: acc)) @@ -213,7 +215,7 @@ let deep_flatten (lam : Lam.t) : Lam.t = | None -> flatten (Single (kind, id, res) :: accux) body) | _ -> flatten (Single (kind, id, res) :: accux) body) | Lletrec (bind_args, body) -> - flatten (Recursive (Ext_list.map_snd bind_args aux) :: acc) body + flatten (Recursive (List.map_snd bind_args aux) :: acc) body | Lsequence (l, r) -> let res, l = flatten acc l in flatten (Lam_group.nop_cons res l) r @@ -229,9 +231,9 @@ let deep_flatten (lam : Lam.t) : Lam.t = match bind_args with | [] -> (List.rev groups, set) | (id, arg) :: rest -> - iter rest ((id, aux arg) :: groups) (Set_ident.add set id) + iter rest ((id, aux arg) :: groups) (Ident.Set.add set id) in - let groups, collections = iter bind_args [] Set_ident.empty in + let groups, collections = iter bind_args [] Ident.Set.empty in (* Try to extract some value definitions from recursive values as [wrap], it will stop whenever it find it could not move forward {[ @@ -243,14 +245,14 @@ let deep_flatten (lam : Lam.t) : Lam.t = *) let rev_bindings, rev_wrap, _ = List.fold_left - (fun (inner_recursive_bindings, wrap, stop) (id, lam) -> + ~f:(fun (inner_recursive_bindings, wrap, stop) (id, lam) -> if stop || Lam_hit.hit_variables collections lam then ((id, lam) :: inner_recursive_bindings, wrap, true) else ( inner_recursive_bindings, Lam_group.Single (Strict, id, lam) :: wrap, false )) - ([], [], false) groups + ~init:([], [], false) groups in lambda_of_groups ~rev_bindings:rev_wrap @@ -269,7 +271,7 @@ let deep_flatten (lam : Lam.t) : Lam.t = (* when List.length params = List.length args -> *) (* aux (beta_reduce params body args) *) | Lapply { ap_func = l1; ap_args = ll; ap_info } -> - Lam.apply (aux l1) (List.map aux ll) ap_info + Lam.apply (aux l1) (List.map ~f:aux ll) ap_info (* This kind of simple optimizations should be done each time and as early as possible *) (* | Lprim {primitive = Pccall{prim_name = "caml_int64_float_of_bits"; _}; @@ -285,7 +287,7 @@ let deep_flatten (lam : Lam.t) : Lam.t = ( (Const_float (Js_number.to_string (Int64.to_float i) ))) *) | Lglobal_module _ -> lam | Lprim { primitive; args; loc } -> - let args = List.map aux args in + let args = List.map ~f:aux args in Lam.prim ~primitive ~args loc | Lfunction { arity; params; body; attr } -> Lam.function_ ~arity ~params ~body:(aux body) ~attr @@ -301,16 +303,16 @@ let deep_flatten (lam : Lam.t) : Lam.t = } ) -> Lam.switch (aux l) { - sw_consts = Ext_list.map_snd sw_consts aux; - sw_blocks = Ext_list.map_snd sw_blocks aux; + sw_consts = List.map_snd sw_consts aux; + sw_blocks = List.map_snd sw_blocks aux; sw_consts_full; sw_blocks_full; sw_failaction = Option.map aux sw_failaction; sw_names; } | Lstringswitch (l, sw, d) -> - Lam.stringswitch (aux l) (Ext_list.map_snd sw aux) (Option.map aux d) - | Lstaticraise (i, ls) -> Lam.staticraise i (List.map aux ls) + Lam.stringswitch (aux l) (List.map_snd sw aux) (Option.map aux d) + | Lstaticraise (i, ls) -> Lam.staticraise i (List.map ~f:aux ls) | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (aux l1) ids (aux l2) | Ltrywith (l1, v, l2) -> Lam.try_ (aux l1) v (aux l2) | Lifthenelse (l1, l2, l3) -> Lam.if_ (aux l1) (aux l2) (aux l3) @@ -321,7 +323,8 @@ let deep_flatten (lam : Lam.t) : Lam.t = (* Lalias-bound variables are never assigned, so don't increase v's refaux *) Lam.assign v (aux l) - | Lsend (u, m, o, ll, v) -> Lam.send u (aux m) (aux o) (List.map aux ll) v + | Lsend (u, m, o, ll, v) -> + Lam.send u (aux m) (aux o) (List.map ~f:aux ll) v | Lifused (v, l) -> Lam.ifused v (aux l) in aux lam diff --git a/jscomp/core/lam_pass_exits.ml b/jscomp/core/lam_pass_exits.ml index 904501866e..7800cf5f9b 100644 --- a/jscomp/core/lam_pass_exits.ml +++ b/jscomp/core/lam_pass_exits.ml @@ -11,6 +11,8 @@ (************************************) (* Adapted for Javascript backend: Hongbo Zhang *) +open Import + (* [no_bounded_varaibles lambda] checks if [lambda] contains bounded variable, for @@ -19,10 +21,10 @@ to inline directly since if it contains bounded variables it must be rebounded before inlining *) -let rec no_list args = List.for_all no_bounded_variables args +let rec no_list args = List.for_all ~f:no_bounded_variables args and no_list_snd : 'a. ('a * Lam.t) list -> bool = - fun args -> List.for_all (fun (_, x) -> no_bounded_variables x) args + fun args -> List.for_all ~f:(fun (_, x) -> no_bounded_variables x) args and no_opt x = match x with None -> true | Some a -> no_bounded_variables a @@ -185,38 +187,38 @@ let subst_helper ~try_depth (subst : subst_tbl) | Some (_, handler) -> to_lam handler | None -> lam) | Lstaticraise (i, ls) -> ( - let ls = List.map simplif ls in + let ls = List.map ~f:simplif ls in match Hash_int.find_opt subst i with | Some (xs, handler) -> let handler = to_lam handler in - let ys = List.map Ident.rename xs in + let ys = List.map ~f:Ident.rename xs in let env = List.fold_right2 - (fun x y t -> Map_ident.add t x (Lam.var y)) - xs ys Map_ident.empty + ~f:(fun x y t -> Ident.Map.add t x (Lam.var y)) + xs ys ~init:Ident.Map.empty in List.fold_right2 - (fun y l r -> Lam.let_ Strict y l r) + ~f:(fun y l r -> Lam.let_ Strict y l r) ys ls - (Lam_subst.subst env handler) + ~init:(Lam_subst.subst env handler) | None -> Lam.staticraise i ls) | Lvar _ | Lmutvar _ | Lconst _ -> lam | Lapply { ap_func; ap_args; ap_info } -> - Lam.apply (simplif ap_func) (List.map simplif ap_args) ap_info + Lam.apply (simplif ap_func) (List.map ~f:simplif ap_args) ap_info | Lfunction { arity; params; body; attr } -> Lam.function_ ~arity ~params ~body:(simplif body) ~attr | Llet (kind, v, l1, l2) -> Lam.let_ kind v (simplif l1) (simplif l2) | Lmutlet (v, l1, l2) -> Lam.mutlet v (simplif l1) (simplif l2) | Lletrec (bindings, body) -> - Lam.letrec (Ext_list.map_snd bindings simplif) (simplif body) + Lam.letrec (List.map_snd bindings simplif) (simplif body) | Lglobal_module _ -> lam | Lprim { primitive; args; loc } -> - let args = List.map simplif args in + let args = List.map ~f:simplif args in Lam.prim ~primitive ~args loc | Lswitch (l, sw) -> let new_l = simplif l in - let new_consts = Ext_list.map_snd sw.sw_consts simplif in - let new_blocks = Ext_list.map_snd sw.sw_blocks simplif in + let new_consts = List.map_snd sw.sw_consts simplif in + let new_blocks = List.map_snd sw.sw_blocks simplif in let new_fail = Option.map simplif sw.sw_failaction in Lam.switch new_l { @@ -226,8 +228,7 @@ let subst_helper ~try_depth (subst : subst_tbl) sw_failaction = new_fail; } | Lstringswitch (l, sw, d) -> - Lam.stringswitch (simplif l) - (Ext_list.map_snd sw simplif) + Lam.stringswitch (simplif l) (List.map_snd sw simplif) (Option.map simplif d) | Ltrywith (l1, v, l2) -> incr try_depth; @@ -241,7 +242,7 @@ let subst_helper ~try_depth (subst : subst_tbl) Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3) | Lassign (v, l) -> Lam.assign v (simplif l) | Lsend (k, m, o, ll, loc) -> - Lam.send k (simplif m) (simplif o) (List.map simplif ll) loc + Lam.send k (simplif m) (simplif o) (List.map ~f:simplif ll) loc | Lifused (v, l) -> Lam.ifused v (simplif l) in simplif lam diff --git a/jscomp/core/lam_pass_lets_dce.cppo.ml b/jscomp/core/lam_pass_lets_dce.cppo.ml index 5702eadd92..ad0b64783c 100644 --- a/jscomp/core/lam_pass_lets_dce.cppo.ml +++ b/jscomp/core/lam_pass_lets_dce.cppo.ml @@ -11,18 +11,19 @@ (************************************) (* Adapted for Javascript backend : Hongbo Zhang, *) +open Import let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = - let subst : Lam.t Hash_ident.t = Hash_ident.create 32 in - let string_table : string Hash_ident.t = Hash_ident.create 32 in + let subst : Lam.t Ident.Hash.t = Ident.Hash.create 32 in + let string_table : string Ident.Hash.t = Ident.Hash.create 32 in let used v = (count_var v ).times > 0 in let rec simplif (lam : Lam.t) = match lam with - | Lvar v -> Hash_ident.find_default subst v lam + | Lvar v -> Ident.Hash.find_default subst v lam | Lmutvar _ -> lam | Llet( (Strict | Alias | StrictOpt) , v, Lvar w, l2) -> - Hash_ident.add subst v (simplif (Lam.var w)); + Ident.Hash.add subst v (simplif (Lam.var w)); simplif l2 | Llet(Strict as kind, v, (Lprim {primitive = (Pmakeblock(0, _, Mutable) @@ -66,10 +67,10 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = do constant folding independently *) -> - Hash_ident.add subst v (simplif l1); simplif l2 + Ident.Hash.add subst v (simplif l1); simplif l2 | _, Lconst (Const_string {s; unicode = false} ) -> (* only "" added for later inlining *) - Hash_ident.add string_table v s; + Ident.Hash.add string_table v s; Lam.let_ Alias v l1 (simplif l2) (* we need move [simplif l2] later, since adding Hash does have side effect *) | _ -> Lam.let_ Alias v (simplif l1) (simplif l2) @@ -117,7 +118,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = let l1 = simplif l1 in begin match l1 with | Lconst(Const_string { s; unicode = false }) -> - Hash_ident.add string_table v s; + Ident.Hash.add string_table v s; (* we need move [simplif lbody] later, since adding Hash does have side effect *) Lam.let_ Alias v l1 (simplif lbody) | _ -> @@ -140,7 +141,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = begin match kind, l1 with | Strict, Lconst((Const_string { s; unicode = false })) -> - Hash_ident.add string_table v s; + Ident.Hash.add string_table v s; Lam.let_ Alias v l1 (simplif l2) | _ -> Lam_util.refine_let ~kind:(Lam_group.of_lam_kind kind) v l1 (simplif l2) @@ -171,24 +172,24 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = | Lsequence(l1, l2) -> Lam.seq (simplif l1) (simplif l2) | Lapply{ap_func = Lfunction{params; body;_}; ap_args = args; _} - when Ext_list.same_length params args -> + when List.same_length params args -> simplif (Lam_beta_reduce.no_names_beta_reduce params body args) (* | Lapply{ fn = Lfunction{function_kind = Tupled; params; body}; *) (* args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *) (* (\* TODO: keep track of this parameter in ocaml trunk, *) (* can we switch to the tupled backend? *) (* *\) *) - (* when Ext_list.same_length params args -> *) + (* when List.same_length params args -> *) (* simplif (Lam_beta_reduce.beta_reduce params body args) *) | Lapply{ap_func = l1; ap_args = ll; ap_info} -> - Lam.apply (simplif l1) (List.map simplif ll ) ap_info + Lam.apply (simplif l1) (List.map ~f:simplif ll ) ap_info | Lfunction{arity; params; body; attr} -> Lam.function_ ~arity ~params ~body:(simplif body) ~attr | Lconst _ -> lam | Lletrec(bindings, body) -> Lam.letrec - (Ext_list.map_snd bindings simplif) + (List.map_snd bindings simplif) (simplif body) | Lprim {primitive=Pstringadd; args = [l;r]; loc } -> begin @@ -197,7 +198,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = let opt_l = match l' with | Lconst(Const_string { s = ls; unicode = false }) -> Some ls - | Lvar i -> Hash_ident.find_opt string_table i + | Lvar i -> Ident.Hash.find_opt string_table i | _ -> None in match opt_l with | None -> Lam.prim ~primitive:Pstringadd ~args:[l';r'] loc @@ -205,7 +206,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = let opt_r = match r' with | Lconst (Const_string {s = rs; unicode = false}) -> Some rs - | Lvar i -> Hash_ident.find_opt string_table i + | Lvar i -> Ident.Hash.find_opt string_table i | _ -> None in begin match opt_r with | None -> Lam.prim ~primitive:Pstringadd ~args:[l';r'] loc @@ -223,7 +224,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = match l' with | Lconst (Const_string { s = ls; unicode = false }) -> Some ls - | Lvar i -> Hash_ident.find_opt string_table i + | Lvar i -> Ident.Hash.find_opt string_table i | _ -> None in begin match opt_l with | None -> Lam.prim ~primitive ~args:[l';r'] loc @@ -240,11 +241,11 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = end | Lglobal_module _ -> lam | Lprim {primitive; args; loc} - -> Lam.prim ~primitive ~args:(List.map simplif args ) loc + -> Lam.prim ~primitive ~args:(List.map ~f:simplif args ) loc | Lswitch(l, sw) -> let new_l = simplif l - and new_consts = Ext_list.map_snd sw.sw_consts simplif - and new_blocks = Ext_list.map_snd sw.sw_blocks simplif + and new_consts = List.map_snd sw.sw_consts simplif + and new_blocks = List.map_snd sw.sw_blocks simplif and new_fail = Option.map simplif sw.sw_failaction in Lam.switch @@ -253,10 +254,10 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = sw_failaction = new_fail} | Lstringswitch (l,sw,d) -> Lam.stringswitch - (simplif l) (Ext_list.map_snd sw simplif) + (simplif l) (List.map_snd sw simplif) (Option.map simplif d) | Lstaticraise (i,ls) -> - Lam.staticraise i (List.map simplif ls) + Lam.staticraise i (List.map ~f:simplif ls) | Lstaticcatch(l1, (i,args), l2) -> Lam.staticcatch (simplif l1) (i,args) (simplif l2) | Ltrywith(l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2) @@ -269,7 +270,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3) | Lassign(v, l) -> Lam.assign v (simplif l) | Lsend(k, m, o, ll, loc) -> - Lam.send k (simplif m) (simplif o) (List.map simplif ll) loc + Lam.send k (simplif m) (simplif o) (List.map ~f:simplif ll) loc in simplif lam @@ -277,7 +278,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = let apply_lets occ lambda = let count_var v = match - Hash_ident.find_opt occ v + Ident.Hash.find_opt occ v with | None -> Lam_pass_count.dummy_info () | Some v -> v in diff --git a/jscomp/core/lam_pass_remove_alias.ml b/jscomp/core/lam_pass_remove_alias.ml index ad960e9767..cd4e6e6b94 100644 --- a/jscomp/core/lam_pass_remove_alias.ml +++ b/jscomp/core/lam_pass_remove_alias.ml @@ -22,10 +22,12 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + type outcome = Eval_false | Eval_true | Eval_unknown let id_is_for_sure_true_in_boolean (tbl : Lam_stats.ident_tbl) id = - match Hash_ident.find_opt tbl id with + match Ident.Hash.find_opt tbl id with | Some (ImmutableBlock _) | Some (Normal_optional _) | Some (MutableBlock _) @@ -61,17 +63,17 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = args = [ (Lvar v as lvar) ]; _; } as x -> ( - match Hash_ident.find_opt meta.ident_tbl v with + match Ident.Hash.find_opt meta.ident_tbl v with | Some (OptionalBlock (l, _)) -> l | _ -> if p = Pval_from_option_not_nest then lvar else x) | Lglobal_module _ -> lam | Lprim { primitive; args; loc } -> - Lam.prim ~primitive ~args:(List.map simpl args) loc + Lam.prim ~primitive ~args:(List.map ~f:simpl args) loc | Lifthenelse ( (Lprim { primitive = Pis_not_none; args = [ Lvar id ]; _ } as l1), l2, l3 ) -> ( - match Hash_ident.find_opt meta.ident_tbl id with + match Ident.Hash.find_opt meta.ident_tbl id with | Some (ImmutableBlock _ | MutableBlock _ | Normal_optional _) -> simpl l2 | Some (OptionalBlock (l, Null)) -> @@ -108,7 +110,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = | Llet (str, v, l1, l2) -> Lam.let_ str v (simpl l1) (simpl l2) | Lmutlet (v, l1, l2) -> Lam.mutlet v (simpl l1) (simpl l2) | Lletrec (bindings, body) -> - let bindings = Ext_list.map_snd bindings simpl in + let bindings = List.map_snd bindings simpl in Lam.letrec bindings (simpl body) (* complicated 1. inline this function @@ -133,18 +135,18 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = match Lam_compile_env.query_external_id_info ident fld_name with | { persistent_closed_lambda = Some (Lfunction { params; body; _ }); _ } (* be more cautious when do cross module inlining *) - when Ext_list.same_length params args + when List.same_length params args && List.for_all - (fun (arg : Lam.t) -> + ~f:(fun (arg : Lam.t) -> match arg with | Lvar p | Lmutvar p -> ( - match Hash_ident.find_opt meta.ident_tbl p with + match Ident.Hash.find_opt meta.ident_tbl p with | Some v -> v <> Parameter | None -> true) | _ -> true) args -> simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) - | _ -> Lam.apply (simpl l1) (List.map simpl args) ap_info) + | _ -> Lam.apply (simpl l1) (List.map ~f:simpl args) ap_info) (* Function inlining interact with other optimizations... - parameter attributes @@ -155,9 +157,9 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = (* Check info for always inlining *) (* Ext_log.dwarn __LOC__ "%s/%d" v.name v.stamp; *) - let ap_args = List.map simpl ap_args in + let ap_args = List.map ~f:simpl ap_args in let[@local] normal () = Lam.apply (simpl fn) ap_args ap_info in - match Hash_ident.find_opt meta.ident_tbl v with + match Ident.Hash.find_opt meta.ident_tbl v with | Some (FunctionId { @@ -168,10 +170,10 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = rec_flag ); _; }) -> - if Ext_list.same_length ap_args params (* && false *) then + if List.same_length ap_args params (* && false *) then if is_a_functor - (* && (Set_ident.mem v meta.export_idents) && false *) + (* && (Ident.Set.mem v meta.export_idents) && false *) then (* TODO: check l1 if it is exported, if so, maybe not since in that case, @@ -197,7 +199,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = let param_map = Lam_closure.is_closed_with_map meta.export_idents params body in - let is_export_id = Set_ident.mem meta.export_idents v in + let is_export_id = Ident.Set.mem meta.export_idents v in match (is_export_id, param_map) with | false, (_, param_map) | true, (true, param_map) -> ( match rec_flag with @@ -208,7 +210,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = | Lam_non_rec -> if List.exists - (fun lam -> Lam_hit.hit_variable v lam) + ~f:(fun lam -> Lam_hit.hit_variable v lam) ap_args (*avoid nontermination, e.g, `g(g)`*) then normal () @@ -221,17 +223,17 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = else normal () | Some _ | None -> normal ()) | Lapply { ap_func = Lfunction { params; body; _ }; ap_args = args; _ } - when Ext_list.same_length params args -> + when List.same_length params args -> simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) (* | Lapply{ fn = Lfunction{function_kind = Tupled; params; body}; *) (* args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *) (* (\* TODO: keep track of this parameter in ocaml trunk, *) (* can we switch to the tupled backend? *) (* *\) *) - (* when Ext_list.same_length params args -> *) + (* when List.same_length params args -> *) (* simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) *) | Lapply { ap_func = l1; ap_args = ll; ap_info } -> - Lam.apply (simpl l1) (List.map simpl ll) ap_info + Lam.apply (simpl l1) (List.map ~f:simpl ll) ap_info | Lfunction { arity; params; body; attr } -> Lam.function_ ~arity ~params ~body:(simpl body) ~attr | Lswitch @@ -246,8 +248,8 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = } ) -> Lam.switch (simpl l) { - sw_consts = Ext_list.map_snd sw_consts simpl; - sw_blocks = Ext_list.map_snd sw_blocks simpl; + sw_consts = List.map_snd sw_consts simpl; + sw_blocks = List.map_snd sw_blocks simpl; sw_consts_full; sw_blocks_full; sw_failaction = Option.map simpl sw_failaction; @@ -257,13 +259,13 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = let l = match l with | Lvar s | Lmutvar s -> ( - match Hash_ident.find_opt meta.ident_tbl s with + match Ident.Hash.find_opt meta.ident_tbl s with | Some (Constant s) -> Lam.const s | Some _ | None -> simpl l) | _ -> simpl l in - Lam.stringswitch l (Ext_list.map_snd sw simpl) (Option.map simpl d) - | Lstaticraise (i, ls) -> Lam.staticraise i (List.map simpl ls) + Lam.stringswitch l (List.map_snd sw simpl) (Option.map simpl d) + | Lstaticraise (i, ls) -> Lam.staticraise i (List.map ~f:simpl ls) | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (simpl l1) ids (simpl l2) | Ltrywith (l1, v, l2) -> Lam.try_ (simpl l1) v (simpl l2) | Lsequence (l1, l2) -> Lam.seq (simpl l1) (simpl l2) @@ -275,7 +277,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = v's refsimpl *) Lam.assign v (simpl l) | Lsend (u, m, o, ll, v) -> - Lam.send u (simpl m) (simpl o) (List.map simpl ll) v + Lam.send u (simpl m) (simpl o) (List.map ~f:simpl ll) v | Lifused (v, l) -> Lam.ifused v (simpl l) in simpl lam diff --git a/jscomp/core/lam_pass_remove_alias.mli b/jscomp/core/lam_pass_remove_alias.mli index 76e684d0b9..ffe9bbf70f 100644 --- a/jscomp/core/lam_pass_remove_alias.mli +++ b/jscomp/core/lam_pass_remove_alias.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,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,10 +26,10 @@ (** One way: guarantee that all global aliases *would be removed* , - it will not be aliased - - So the only remaining place for globals is either - just Pgetglobal in functor application or + it will not be aliased + + So the only remaining place for globals is either + just Pgetglobal in functor application or `Lprim (Pfield( i ), [Pgetglobal])` This pass does not change meta data diff --git a/jscomp/core/lam_scc.ml b/jscomp/core/lam_scc.ml index e299edfd47..1654571a88 100644 --- a/jscomp/core/lam_scc.ml +++ b/jscomp/core/lam_scc.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (** [hit_mask mask lambda] iters through the lambda set the bit of corresponding [id] if [id] is hit. @@ -34,8 +36,8 @@ let hit_mask (mask : Hash_set_ident_mask.t) (l : Lam.t) : bool = and hit_var (id : Ident.t) = Hash_set_ident_mask.mask_and_check_all_hit mask id and hit_list_snd : 'a. ('a * Lam.t) list -> bool = - fun x -> List.exists (fun (_, x) -> hit x) x - and hit_list xs = List.exists hit xs + fun x -> List.exists ~f:(fun (_, x) -> hit x) x + and hit_list xs = List.exists ~f:hit xs and hit (l : Lam.t) = match l with | Lvar id | Lmutvar id -> hit_var id @@ -73,7 +75,7 @@ let preprocess_deps (groups : bindings) : _ * Ident.t array * Vec_int.t array = in let mask = Hash_set_ident_mask.create len in List.iter - (fun (x, lam) -> + ~f:(fun (x, lam) -> Ordered_hash_map_local_ident.add domain x lam; Hash_set_ident_mask.add_unmask mask x) groups; @@ -92,10 +94,10 @@ let is_function_bind (_, (x : Lam.t)) = match x with Lfunction _ -> true | _ -> false let sort_single_binding_group (group : bindings) = - if List.for_all is_function_bind group then group + if List.for_all ~f:is_function_bind group then group else List.sort - (fun (_, lama) (_, lamb) -> + ~cmp:(fun (_, lama) (_, lamb) -> match ((lama : Lam.t), (lamb : Lam.t)) with | Lfunction _, Lfunction _ -> 0 | Lfunction _, _ -> -1 @@ -109,7 +111,7 @@ let scc_bindings (groups : bindings) : bindings list = | [ _ ] -> [ sort_single_binding_group groups ] | _ -> let domain, int_mapping, node_vec = preprocess_deps groups in - let clusters : Int_vec_vec.t = Ext_scc.graph node_vec in + let clusters : Int_vec_vec.t = Scc.graph node_vec in if Int_vec_vec.length clusters <= 1 then [ sort_single_binding_group groups ] else @@ -135,7 +137,7 @@ let scc (groups : bindings) (lam : Lam.t) (body : Lam.t) = if Lam_hit.hit_variable id bind then lam else Lam.let_ Strict id bind body | _ -> let domain, int_mapping, node_vec = preprocess_deps groups in - let clusters = Ext_scc.graph node_vec in + let clusters = Scc.graph node_vec in if Int_vec_vec.length clusters <= 1 then lam else Int_vec_vec.fold_right diff --git a/jscomp/core/lam_scc.mli b/jscomp/core/lam_scc.mli index 4331c4c5dd..2df71775aa 100644 --- a/jscomp/core/lam_scc.mli +++ b/jscomp/core/lam_scc.mli @@ -1,5 +1,5 @@ (* Copyright (C) 2018 Authors of ReScript - * + * * 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. *) diff --git a/jscomp/core/lam_stats.ml b/jscomp/core/lam_stats.ml index 459993a7b8..eae3c5e4bd 100644 --- a/jscomp/core/lam_stats.ml +++ b/jscomp/core/lam_stats.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,11 +17,13 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (* It can be useful for common sub expression elimination ? if two lambdas are not equal, it should return false, other wise, it might return true , this is only used as a way of optimizaton @@ -36,12 +38,12 @@ in the beginning, when we do alpha conversion, we can instrument the table *) -(* type alias_tbl = Ident.t Hash_ident.t *) +(* type alias_tbl = Ident.t Ident.Hash.t *) -type ident_tbl = Lam_id_kind.t Hash_ident.t +type ident_tbl = Lam_id_kind.t Ident.Hash.t type t = { - export_idents : Set_ident.t; + export_idents : Ident.Set.t; exports : Ident.t list; (*It is kept since order matters? *) ident_tbl : ident_tbl; (** we don't need count arities for all identifiers, for identifiers @@ -52,10 +54,10 @@ type t = { let pp = Format.fprintf (* let pp_alias_tbl fmt (tbl : alias_tbl) = - Hash_ident.iter tbl (fun k v -> pp fmt "@[%a -> %a@]@." Ident.print k Ident.print v) *) + Ident.Hash.iter tbl (fun k v -> pp fmt "@[%a -> %a@]@." Ident.print k Ident.print v) *) let pp_ident_tbl fmt (ident_tbl : ident_tbl) = - Hash_ident.iter ident_tbl (fun k v -> + Ident.Hash.iter ident_tbl (fun k v -> pp fmt "@[%a -> %a@]@." Ident.print k Lam_id_kind.print v) let print fmt (v : t) = @@ -66,7 +68,7 @@ let print fmt (v : t) = let make ~export_idents ~export_ident_sets : t = { - ident_tbl = Hash_ident.create 31; + ident_tbl = Ident.Hash.create 31; exports = export_idents; export_idents = export_ident_sets; } diff --git a/jscomp/core/lam_stats.mli b/jscomp/core/lam_stats.mli index 513193f285..1b5e15ca23 100644 --- a/jscomp/core/lam_stats.mli +++ b/jscomp/core/lam_stats.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,20 +17,21 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (** Types defined for lambda analysis *) -(** Keep track of which identifiers are aliased - *) +(** Keep track of which identifiers are aliased *) -type ident_tbl = Lam_id_kind.t Hash_ident.t +type ident_tbl = Lam_id_kind.t Ident.Hash.t type t = { - export_idents : Set_ident.t; + export_idents : Ident.Set.t; exports : Ident.t list; ident_tbl : ident_tbl; (** we don't need count arities for all identifiers, for identifiers @@ -39,4 +40,4 @@ type t = { } val print : Format.formatter -> t -> unit -val make : export_idents:Ident.t list -> export_ident_sets:Set_ident.t -> t +val make : export_idents:Ident.t list -> export_ident_sets:Ident.Set.t -> t diff --git a/jscomp/core/lam_stats_export.ml b/jscomp/core/lam_stats_export.ml index 379ce9cfbb..74a660d833 100644 --- a/jscomp/core/lam_stats_export.ml +++ b/jscomp/core/lam_stats_export.ml @@ -22,40 +22,41 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(* let pp = Format.fprintf *) +open Import + (* we should exclude meaninglist names and do the convert as well *) (* let meaningless_names = ["*opt*"; "param";] *) let single_na = Js_cmj_format.single_na -let values_of_export (meta : Lam_stats.t) (export_map : Lam.t Map_ident.t) : - Js_cmj_format.cmj_value Map_string.t = +let values_of_export (meta : Lam_stats.t) (export_map : Lam.t Ident.Map.t) : + Js_cmj_format.cmj_value String.Map.t = List.fold_left - (fun acc x -> + ~f:(fun acc x -> let arity : Js_cmj_format.arity = - match Hash_ident.find_opt meta.ident_tbl x with + match Ident.Hash.find_opt meta.ident_tbl x with | Some (FunctionId { arity; _ }) -> Single arity | Some (ImmutableBlock elems) -> (* FIXME: field name for dumping*) Submodule (Array.map - (fun (x : Lam_id_kind.element) -> + ~f:(fun (x : Lam_id_kind.element) -> match x with | NA -> Lam_arity.na | SimpleForm lam -> Lam_arity_analysis.get_arity meta lam) elems) | Some _ | None -> ( - match Map_ident.find_opt export_map x with + match Ident.Map.find_opt export_map x with | Some (Lprim { primitive = Pmakeblock (_, _, Immutable); args; _ }) -> Submodule - (Ext_array.of_list_map args (fun lam -> + (Array.of_list_map args (fun lam -> Lam_arity_analysis.get_arity meta lam)) | Some _ | None -> single_na) in let persistent_closed_lambda = - let optlam = Map_ident.find_opt export_map x in + let optlam = Ident.Map.find_opt export_map x in match optlam with | Some (Lconst @@ -88,12 +89,12 @@ let values_of_export (meta : Lam_stats.t) (export_map : Lam.t Map_ident.t) : 2. [lambda_exports] is not precise *) let free_variables = - Lam_closure.free_variables Set_ident.empty Map_ident.empty + Lam_closure.free_variables Ident.Set.empty Ident.Map.empty lambda in if lam_size < Lam_analysis.small_inline_size - && Map_ident.is_empty free_variables + && Ident.Map.is_empty free_variables then ( Ext_log.dwarn ~__POS__ "%s recorded for inlining @." (Ident.name x); @@ -108,8 +109,8 @@ let values_of_export (meta : Lam_stats.t) (export_map : Lam.t Map_ident.t) : let cmj_value : Js_cmj_format.cmj_value = { arity; persistent_closed_lambda } in - Map_string.add acc (Ident.name x) cmj_value) - Map_string.empty meta.exports + String.Map.add acc (Ident.name x) cmj_value) + ~init:String.Map.empty meta.exports (* ATTENTION: all runtime modules, if it is not hard required, it should be okay to not reference it @@ -119,7 +120,7 @@ let get_dependent_module_effect (maybe_pure : string option) if maybe_pure = None then let non_pure_module = List.find_opt - (fun id -> not (Lam_compile_env.is_pure_module id)) + ~f:(fun id -> not (Lam_compile_env.is_pure_module id)) external_ids in Option.map (fun x -> Lam_module_ident.name x) non_pure_module diff --git a/jscomp/core/lam_stats_export.mli b/jscomp/core/lam_stats_export.mli index 337298c841..fae0849009 100644 --- a/jscomp/core/lam_stats_export.mli +++ b/jscomp/core/lam_stats_export.mli @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + val get_dependent_module_effect : string option -> Lam_module_ident.t list -> string option @@ -29,7 +31,7 @@ val export_to_cmj : case:Js_packages_info.file_case -> Lam_stats.t -> Js_cmj_format.effect -> - Lam.t Map_ident.t -> + Lam.t Ident.Map.t -> (* FIXME: this is a leaky abstraction *) delayed_program:J.deps_program -> Js_cmj_format.t diff --git a/jscomp/core/lam_subst.ml b/jscomp/core/lam_subst.ml index 520f164d01..56fd7b763a 100644 --- a/jscomp/core/lam_subst.ml +++ b/jscomp/core/lam_subst.ml @@ -22,42 +22,44 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (* Apply a substitution to a lambda-term. Assumes that the bound variables of the lambda-term do not belong to the domain of the substitution. Assumes that the image of the substitution is out of reach of the bound variables of the lambda-term (no capture). *) -let subst (s : Lam.t Map_ident.t) lam = +let subst (s : Lam.t Ident.Map.t) lam = let rec subst_aux (x : Lam.t) : Lam.t = match x with - | Lvar id | Lmutvar id -> Map_ident.find_default s id x + | Lvar id | Lmutvar id -> Ident.Map.find_default s id x | Lconst _ -> x | Lapply { ap_func; ap_args; ap_info } -> - Lam.apply (subst_aux ap_func) (List.map subst_aux ap_args) ap_info + Lam.apply (subst_aux ap_func) (List.map ~f:subst_aux ap_args) ap_info | Lfunction { arity; params; body; attr } -> Lam.function_ ~arity ~params ~body:(subst_aux body) ~attr | Llet (str, id, arg, body) -> Lam.let_ str id (subst_aux arg) (subst_aux body) | Lmutlet (id, arg, body) -> Lam.mutlet id (subst_aux arg) (subst_aux body) | Lletrec (decl, body) -> - Lam.letrec (List.map subst_decl decl) (subst_aux body) + Lam.letrec (List.map ~f:subst_decl decl) (subst_aux body) | Lprim { primitive; args; loc } -> - Lam.prim ~primitive ~args:(List.map subst_aux args) loc + Lam.prim ~primitive ~args:(List.map ~f:subst_aux args) loc | Lglobal_module _ -> x | Lswitch (arg, sw) -> Lam.switch (subst_aux arg) { sw with - sw_consts = List.map subst_case sw.sw_consts; - sw_blocks = List.map subst_case sw.sw_blocks; + sw_consts = List.map ~f:subst_case sw.sw_consts; + sw_blocks = List.map ~f:subst_case sw.sw_blocks; sw_failaction = subst_opt sw.sw_failaction; } | Lstringswitch (arg, cases, default) -> Lam.stringswitch (subst_aux arg) - (List.map subst_strcase cases) + (List.map ~f:subst_strcase cases) (subst_opt default) - | Lstaticraise (i, args) -> Lam.staticraise i (List.map subst_aux args) + | Lstaticraise (i, args) -> Lam.staticraise i (List.map ~f:subst_aux args) | Lstaticcatch (e1, io, e2) -> Lam.staticcatch (subst_aux e1) io (subst_aux e2) | Ltrywith (e1, exn, e2) -> Lam.try_ (subst_aux e1) exn (subst_aux e2) @@ -69,7 +71,9 @@ let subst (s : Lam.t Map_ident.t) lam = Lam.for_ v (subst_aux e1) (subst_aux e2) dir (subst_aux e3) | Lassign (id, e) -> Lam.assign id (subst_aux e) | Lsend (k, met, obj, args, loc) -> - Lam.send k (subst_aux met) (subst_aux obj) (List.map subst_aux args) loc + Lam.send k (subst_aux met) (subst_aux obj) + (List.map ~f:subst_aux args) + loc | Lifused (v, e) -> Lam.ifused v (subst_aux e) and subst_decl (id, exp) = (id, subst_aux exp) and subst_case (key, case) = (key, subst_aux case) diff --git a/jscomp/core/lam_subst.mli b/jscomp/core/lam_subst.mli index 00836dc820..99b102835f 100644 --- a/jscomp/core/lam_subst.mli +++ b/jscomp/core/lam_subst.mli @@ -1,5 +1,5 @@ (* Copyright (C) 2017 Authors of ReScript - * + * * 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,15 +17,17 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (* Apply a substitution to a lambda-term. Assumes that the bound variables of the lambda-term do not belong to the domain of the substitution. Assumes that the image of the substitution is out of reach of the bound variables of the lambda-term (no capture). *) -val subst : Lam.t Map_ident.t -> Lam.t -> Lam.t +val subst : Lam.t Ident.Map.t -> Lam.t -> Lam.t diff --git a/jscomp/core/lam_util.ml b/jscomp/core/lam_util.ml index ac13efddf2..30af287439 100644 --- a/jscomp/core/lam_util.ml +++ b/jscomp/core/lam_util.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (* let add_required_modules ( x : Ident.t list) (meta : Lam_stats.t) = let meta_require_modules = meta.required_modules in @@ -117,10 +119,10 @@ let alias_ident_or_global (meta : Lam_stats.t) (k : Ident.t) (v : Ident.t) *) match v_kind with | NA -> ( - match Hash_ident.find_opt meta.ident_tbl v with + match Ident.Hash.find_opt meta.ident_tbl v with | None -> () - | Some ident_info -> Hash_ident.add meta.ident_tbl k ident_info) - | ident_info -> Hash_ident.add meta.ident_tbl k ident_info + | Some ident_info -> Ident.Hash.add meta.ident_tbl k ident_info) + | ident_info -> Ident.Hash.add meta.ident_tbl k ident_info (* share -- it is safe to share most properties, for arity, we might be careful, only [Alias] can share, @@ -166,10 +168,10 @@ let element_of_lambda (lam : Lam.t) : Lam_id_kind.element = | _ -> NA let kind_of_lambda_block (xs : Lam.t list) : Lam_id_kind.t = - ImmutableBlock (Ext_array.of_list_map xs (fun x -> element_of_lambda x)) + ImmutableBlock (Array.of_list_map xs (fun x -> element_of_lambda x)) -let field_flatten_get lam v i info (tbl : Lam_id_kind.t Hash_ident.t) : Lam.t = - match Hash_ident.find_opt tbl v with +let field_flatten_get lam v i info (tbl : Lam_id_kind.t Ident.Hash.t) : Lam.t = + match Ident.Hash.find_opt tbl v with | Some (Module g) -> Lam.prim ~primitive:(Pfield (i, info)) diff --git a/jscomp/core/matching_polyfill.ml b/jscomp/core/matching_polyfill.ml index 460353deda..cca5b55d44 100644 --- a/jscomp/core/matching_polyfill.ml +++ b/jscomp/core/matching_polyfill.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + let is_nullary_variant (x : Types.constructor_arguments) = match x with Types.Cstr_tuple [] -> true | _ -> false @@ -30,19 +32,19 @@ let names_from_construct_pattern let names_from_type_variant (cstrs : Types.constructor_declaration list) = let consts, blocks = List.fold_left - (fun (consts, blocks) (cstr : Types.constructor_declaration) -> + ~f:(fun (consts, blocks) (cstr : Types.constructor_declaration) -> if is_nullary_variant cstr.cd_args then (Ident.name cstr.cd_id :: consts, blocks) else (consts, Ident.name cstr.cd_id :: blocks)) - ([], []) cstrs + ~init:([], []) cstrs in Some { - Lambda.consts = Ext_array.reverse_of_list consts; - blocks = Ext_array.reverse_of_list blocks; + Lambda.consts = Array.reverse_of_list consts; + blocks = Array.reverse_of_list blocks; } in - let rec resolve_path n (path : Path.t) = + let rec resolve_path n path = match Env.find_type path pat.pat_env with | { type_kind = Type_variant (cstrs, _repr); _ } -> names_from_type_variant cstrs diff --git a/jscomp/core/polyvar_pattern_match.ml b/jscomp/core/polyvar_pattern_match.ml index 8f4c4750be..bf3cb957ca 100644 --- a/jscomp/core/polyvar_pattern_match.ml +++ b/jscomp/core/polyvar_pattern_match.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + type lam = Lambda.lambda type hash_names = (int * string) list type input = (int * (string * lam)) list @@ -39,24 +41,24 @@ type value = { stamp : int; hash_names_act : hash_names * lam } let convert (xs : input) : output = let coll = Coll.create 63 in let os : value list ref = ref [] in - xs - |> List.iteri (fun i (hash, (name, act)) -> - match Lambda.make_key act with - | None -> - os := - { stamp = i; hash_names_act = ([ (hash, name) ], act) } :: !os - | Some key -> - Coll.add_or_update coll key - ~update:(fun ({ hash_names_act = hash_names, act; _ } as acc) -> - { acc with hash_names_act = ((hash, name) :: hash_names, act) }) - { hash_names_act = ([ (hash, name) ], act); stamp = i }); + List.iteri + ~f:(fun i (hash, (name, act)) -> + match Lambda.make_key act with + | None -> + os := { stamp = i; hash_names_act = ([ (hash, name) ], act) } :: !os + | Some key -> + Coll.add_or_update coll key + ~update:(fun ({ hash_names_act = hash_names, act; _ } as acc) -> + { acc with hash_names_act = ((hash, name) :: hash_names, act) }) + { hash_names_act = ([ (hash, name) ], act); stamp = i }) + xs; let result = let arr = let result = Coll.to_list coll (fun _ value -> value) @ !os in Array.of_list result in - Array.sort (fun x y -> compare x.stamp y.stamp) arr; - Ext_array.to_list_f arr (fun x -> x.hash_names_act) + Array.sort ~cmp:(fun x y -> compare x.stamp y.stamp) arr; + Array.to_list_f arr (fun x -> x.hash_names_act) in result @@ -70,7 +72,7 @@ let or_list (arg : lam) (hash_names : (int * string) list) = Loc_unknown ) in List.fold_left - (fun acc (hash, name) -> + ~f:(fun acc (hash, name) -> Lambda.Lprim ( Psequor, [ @@ -84,7 +86,7 @@ let or_list (arg : lam) (hash_names : (int * string) list) = Loc_unknown ); ], Loc_unknown )) - init rest + ~init rest | _ -> assert false let make_test_sequence_variant_constant (fail : lam option) (arg : lam) @@ -95,10 +97,10 @@ let make_test_sequence_variant_constant (fail : lam option) (arg : lam) match (int_lambda_list, fail) with | (_, act) :: rest, None | rest, Some act -> List.fold_right - (fun (hash_names, act1) (acc : lam) -> + ~f:(fun (hash_names, act1) (acc : lam) -> let predicate : lam = or_list arg hash_names in Lifthenelse (predicate, act1, acc)) - rest act + rest ~init:act | [], None -> assert false let call_switcher_variant_constant (_loc : Debuginfo.Scoped_location.t) @@ -109,10 +111,10 @@ let call_switcher_variant_constant (_loc : Debuginfo.Scoped_location.t) match (int_lambda_list, fail) with | (_, act) :: rest, None | rest, Some act -> List.fold_right - (fun (hash_names, act1) (acc : lam) -> + ~f:(fun (hash_names, act1) (acc : lam) -> let predicate = or_list arg hash_names in Lifthenelse (predicate, act1, acc)) - rest act + rest ~init:act | [], None -> assert false let call_switcher_variant_constr (loc : Lambda.scoped_location) diff --git a/jscomp/core/record_attributes_check.ml b/jscomp/core/record_attributes_check.ml index 823d74d233..09767c9f74 100644 --- a/jscomp/core/record_attributes_check.ml +++ b/jscomp/core/record_attributes_check.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + type label = Types.label_description let rec find_with_default xs ~f ~default = @@ -106,7 +108,7 @@ let fld_record_extension_set (lbl : label) = let blk_record fields = let all_labels_info = Array.map - (fun ((lbl : label), _) -> + ~f:(fun ((lbl : label), _) -> find_with_default lbl.Types.lbl_attributes ~f:find_name ~default:lbl.lbl_name) fields @@ -116,7 +118,7 @@ let blk_record fields = let blk_record_ext fields = let all_labels_info = Array.map - (fun ((lbl : label), _) -> + ~f:(fun ((lbl : label), _) -> find_with_default lbl.Types.lbl_attributes ~f:find_name ~default:lbl.lbl_name) fields @@ -126,7 +128,7 @@ let blk_record_ext fields = let blk_record_inlined fields name num_nonconst = let fields = Array.map - (fun ((lbl : label), _) -> + ~f:(fun ((lbl : label), _) -> find_with_default lbl.Types.lbl_attributes ~f:find_name ~default:lbl.lbl_name) fields @@ -141,24 +143,24 @@ let check_mel_attributes_inclusion (attrs1 : Parsetree.attributes) let check_duplicated_labels = let rec check_duplicated_labels_aux (lbls : Parsetree.label_declaration list) - (coll : Set_string.t) = + (coll : String.Set.t) = match lbls with | [] -> None | { pld_name = { txt; _ } as pld_name; pld_attributes; _ } :: rest -> ( - if Set_string.mem coll txt then Some pld_name + if String.Set.mem coll txt then Some pld_name else - let coll_with_lbl = Set_string.add coll txt in - match List.find_map find_name_with_loc pld_attributes with + let coll_with_lbl = String.Set.add coll txt in + match List.find_map ~f:find_name_with_loc pld_attributes with | None -> check_duplicated_labels_aux rest coll_with_lbl | Some ({ txt = s; _ } as l) -> if - Set_string.mem coll s + String.Set.mem coll s (*use coll to make check a bit looser allow cases like [ x : int [@as "x"]] *) then Some l else check_duplicated_labels_aux rest - (Set_string.add coll_with_lbl s)) + (String.Set.add coll_with_lbl s)) in - fun lbls -> check_duplicated_labels_aux lbls Set_string.empty + fun lbls -> check_duplicated_labels_aux lbls String.Set.empty diff --git a/jscomp/ext/hash_gen.cppo.ml b/jscomp/ext/hash_gen.cppo.ml deleted file mode 100644 index d759dcc572..0000000000 --- a/jscomp/ext/hash_gen.cppo.ml +++ /dev/null @@ -1,281 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -(* Hash tables *) - - - - -(* We do dynamic hashing, and resize the table and rehash the elements - when buckets become too long. *) - -type ('a, 'b) bucket = - | Empty - | Cons of { - mutable key : 'a ; - mutable data : 'b ; - mutable next : ('a, 'b) bucket - } - -type ('a, 'b) t = - { mutable size: int; (* number of entries *) - mutable data: ('a, 'b) bucket array; (* the buckets *) - initial_size: int; (* initial array size *) - } - - -(** - {[ - (power_2_above 16 63 = 64) - (power_2_above 16 76 = 128) - ]} -*) -let rec power_2_above x n = - if x >= n then x - else if x * 2 > Sys.max_array_length then x - else power_2_above (x * 2) n - -let create initial_size = - let s = power_2_above 16 initial_size in - { initial_size = s; size = 0; data = Array.make s Empty } - -let clear h = - h.size <- 0; - let len = Array.length h.data in - for i = 0 to len - 1 do - Array.unsafe_set h.data i Empty - done - -let reset h = - h.size <- 0; - h.data <- Array.make h.initial_size Empty - - -let length h = h.size - -let resize indexfun h = - let odata = h.data in - let osize = Array.length odata in - let nsize = osize * 2 in - if nsize < Sys.max_array_length then begin - let ndata = Array.make nsize Empty in - let ndata_tail = Array.make nsize Empty in - h.data <- ndata; (* so that indexfun sees the new bucket count *) - let rec insert_bucket = function - Empty -> () - | Cons {key; next; _ } as cell -> - let nidx = indexfun h key in - begin match Array.unsafe_get ndata_tail nidx with - | Empty -> - Array.unsafe_set ndata nidx cell - | Cons tail -> - tail.next <- cell - end; - Array.unsafe_set ndata_tail nidx cell; - insert_bucket next - in - for i = 0 to osize - 1 do - insert_bucket (Array.unsafe_get odata i) - done; - for i = 0 to nsize - 1 do - match Array.unsafe_get ndata_tail i with - | Empty -> () - | Cons tail -> tail.next <- Empty - done - end - - - -let iter h f = - let rec do_bucket = function - | Empty -> - () - | Cons l -> - f l.key l.data; do_bucket l.next in - let d = h.data in - for i = 0 to Array.length d - 1 do - do_bucket (Array.unsafe_get d i) - done - -let fold h init f = - let rec do_bucket b accu = - match b with - Empty -> - accu - | Cons l -> - do_bucket l.next (f l.key l.data accu) in - let d = h.data in - let accu = ref init in - for i = 0 to Array.length d - 1 do - accu := do_bucket (Array.unsafe_get d i) !accu - done; - !accu - -let to_list h f = - fold h [] (fun k data acc -> f k data :: acc) - - - - -let rec small_bucket_mem (lst : _ bucket) eq key = - match lst with - | Empty -> false - | Cons lst -> - eq key lst.key || - match lst.next with - | Empty -> false - | Cons lst -> - eq key lst.key || - match lst.next with - | Empty -> false - | Cons lst -> - eq key lst.key || - small_bucket_mem lst.next eq key - - -let rec small_bucket_opt eq key (lst : _ bucket) : _ option = - match lst with - | Empty -> None - | Cons lst -> - if eq key lst.key then Some lst.data else - match lst.next with - | Empty -> None - | Cons lst -> - if eq key lst.key then Some lst.data else - match lst.next with - | Empty -> None - | Cons lst -> - if eq key lst.key then Some lst.data else - small_bucket_opt eq key lst.next - - -let rec small_bucket_key_opt eq key (lst : _ bucket) : _ option = - match lst with - | Empty -> None - | Cons {key=k; next; _ } -> - if eq key k then Some k else - match next with - | Empty -> None - | Cons {key=k; next;_ } -> - if eq key k then Some k else - match next with - | Empty -> None - | Cons {key=k; next; _} -> - if eq key k then Some k else - small_bucket_key_opt eq key next - - -let rec small_bucket_default eq key default (lst : _ bucket) = - match lst with - | Empty -> default - | Cons lst -> - if eq key lst.key then lst.data else - match lst.next with - | Empty -> default - | Cons lst -> - if eq key lst.key then lst.data else - match lst.next with - | Empty -> default - | Cons lst -> - if eq key lst.key then lst.data else - small_bucket_default eq key default lst.next - -let rec remove_bucket - h (i : int) - key - ~(prec : _ bucket) - (buck : _ bucket) - eq_key = - match buck with - | Empty -> - () - | Cons {key=k; next;_ } -> - if eq_key k key - then begin - h.size <- h.size - 1; - match prec with - | Empty -> Array.unsafe_set h.data i next - | Cons c -> c.next <- next - end - else remove_bucket h i key ~prec:buck next eq_key - -let rec replace_bucket key data (buck : _ bucket) eq_key = - match buck with - | Empty -> - true - | Cons slot -> - if eq_key slot.key key - then (slot.key <- key; slot.data <- data; false) - else replace_bucket key data slot.next eq_key - -module type S = sig - type key - type 'a t - val create: int -> 'a t - val clear: 'a t -> unit - val reset: 'a t -> unit - - val add: 'a t -> key -> 'a -> unit - val add_or_update: - 'a t -> - key -> - update:('a -> 'a) -> - 'a -> unit - val remove: 'a t -> key -> unit - val find_exn: 'a t -> key -> 'a - val find_all: 'a t -> key -> 'a list - val find_opt: 'a t -> key -> 'a option - - (** return the key found in the hashtbl. - Use case: when you find the key existed in hashtbl, - you want to use the one stored in the hashtbl. - (they are semantically equivlanent, but may have other information different) - *) - val find_key_opt: 'a t -> key -> key option - - val find_default: 'a t -> key -> 'a -> 'a - - val replace: 'a t -> key -> 'a -> unit - val mem: 'a t -> key -> bool - val iter: 'a t -> (key -> 'a -> unit) -> unit - val fold: - 'a t -> 'b -> - (key -> 'a -> 'b -> 'b) -> 'b - val length: 'a t -> int - (* val stats: 'a t -> Hashtbl.statistics *) - val to_list : 'a t -> (key -> 'a -> 'c) -> 'c list - val of_list2: key list -> 'a list -> 'a t -end - - - -#if false -let rec bucket_length accu = function - | Empty -> accu - | Cons l -> bucket_length (accu + 1) l.next - -let stats h = - let mbl = - Ext_array.fold_left h.data 0 (fun m b -> max m (bucket_length 0 b)) in - let histo = Array.make (mbl + 1) 0 in - Ext_array.iter h.data - (fun b -> - let l = bucket_length 0 b in - histo.(l) <- histo.(l) + 1) - ; - {Hash. - num_bindings = h.size; - num_buckets = Array.length h.data; - max_bucket_length = mbl; - bucket_histogram = histo } -#endif diff --git a/jscomp/ext/hash_set_gen.cppo.ml b/jscomp/ext/hash_set_gen.cppo.ml deleted file mode 100644 index c572809f71..0000000000 --- a/jscomp/ext/hash_set_gen.cppo.ml +++ /dev/null @@ -1,201 +0,0 @@ -(* 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 - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - -(* We do dynamic hashing, and resize the table and rehash the elements - when buckets become too long. *) - -type 'a bucket = - | Empty - | Cons of { - mutable key : 'a ; - mutable next : 'a bucket - } - -type 'a t = - { mutable size: int; (* number of entries *) - mutable data: 'a bucket array; (* the buckets *) - initial_size: int; (* initial array size *) - } - - - - -let create initial_size = - let s = Hash_gen.power_2_above 16 initial_size in - { initial_size = s; size = 0; data = Array.make s Empty } - -let clear h = - h.size <- 0; - let len = Array.length h.data in - for i = 0 to len - 1 do - Array.unsafe_set h.data i Empty - done - -let reset h = - h.size <- 0; - h.data <- Array.make h.initial_size Empty - -let length h = h.size - -let resize indexfun h = - let odata = h.data in - let osize = Array.length odata in - let nsize = osize * 2 in - if nsize < Sys.max_array_length then begin - let ndata = Array.make nsize Empty in - let ndata_tail = Array.make nsize Empty in - h.data <- ndata; (* so that indexfun sees the new bucket count *) - let rec insert_bucket = function - Empty -> () - | Cons {key; next} as cell -> - let nidx = indexfun h key in - begin match Array.unsafe_get ndata_tail nidx with - | Empty -> - Array.unsafe_set ndata nidx cell - | Cons tail -> - tail.next <- cell - end; - Array.unsafe_set ndata_tail nidx cell; - insert_bucket next - in - for i = 0 to osize - 1 do - insert_bucket (Array.unsafe_get odata i) - done; - for i = 0 to nsize - 1 do - match Array.unsafe_get ndata_tail i with - | Empty -> () - | Cons tail -> tail.next <- Empty - done - end - -let iter h f = - let rec do_bucket = function - | Empty -> - () - | Cons l -> - f l.key ; do_bucket l.next in - let d = h.data in - for i = 0 to Array.length d - 1 do - do_bucket (Array.unsafe_get d i) - done - -let fold h init f = - let rec do_bucket b accu = - match b with - Empty -> - accu - | Cons l -> - do_bucket l.next (f l.key accu) in - let d = h.data in - let accu = ref init in - for i = 0 to Array.length d - 1 do - accu := do_bucket (Array.unsafe_get d i) !accu - done; - !accu - - -let to_list set = - fold set [] List.cons - - - - -let rec small_bucket_mem eq key lst = - match lst with - | Empty -> false - | Cons lst -> - eq key lst.key || - match lst.next with - | Empty -> false - | Cons lst -> - eq key lst.key || - match lst.next with - | Empty -> false - | Cons lst -> - eq key lst.key || - small_bucket_mem eq key lst.next - -let rec remove_bucket - (h : _ t) (i : int) - key - ~(prec : _ bucket) - (buck : _ bucket) - eq_key = - match buck with - | Empty -> - () - | Cons {key=k; next } -> - if eq_key k key - then begin - h.size <- h.size - 1; - match prec with - | Empty -> Array.unsafe_set h.data i next - | Cons c -> c.next <- next - end - else remove_bucket h i key ~prec:buck next eq_key - - -module type S = -sig - type key - type t - val create: int -> t - val clear : t -> unit - val reset : t -> unit - (* val copy: t -> t *) - val remove: t -> key -> unit - val add : t -> key -> unit - val of_array : key array -> t - val check_add : t -> key -> bool - val mem : t -> key -> bool - val iter: t -> (key -> unit) -> unit - val fold: t -> 'b -> (key -> 'b -> 'b) -> 'b - val length: t -> int - (* val stats: t -> Hashtbl.statistics *) - val to_list : t -> key list -end - - -#if false -let rec bucket_length accu = function - | Empty -> accu - | Cons l -> bucket_length (accu + 1) l.next - - - -let stats h = - let mbl = - Ext_array.fold_left h.data 0 (fun m b -> max m (bucket_length 0 b)) in - let histo = Array.make (mbl + 1) 0 in - Ext_array.iter h.data - (fun b -> - let l = bucket_length 0 b in - histo.(l) <- histo.(l) + 1) - ; - {Hashtbl.num_bindings = h.size; - num_buckets = Array.length h.data; - max_bucket_length = mbl; - bucket_histogram = histo } -#endif diff --git a/jscomp/ext/ext_array.ml b/jscomp/melstd/array.ml similarity index 80% rename from jscomp/ext/ext_array.ml rename to jscomp/melstd/array.ml index 1207522107..d6aae49d0e 100644 --- a/jscomp/ext/ext_array.ml +++ b/jscomp/melstd/array.ml @@ -22,24 +22,26 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +include StdLabels.Array + let reverse_range a i len = if len = 0 then () else for k = 0 to (len - 1) / 2 do - let t = Array.unsafe_get a (i + k) in - Array.unsafe_set a (i + k) (Array.unsafe_get a (i + len - 1 - k)); - Array.unsafe_set a (i + len - 1 - k) t + let t = unsafe_get a (i + k) in + unsafe_set a (i + k) (unsafe_get a (i + len - 1 - k)); + unsafe_set a (i + len - 1 - k) t done let reverse_of_list = function | [] -> [||] | hd :: tl as l -> - let len = List.length l in - let a = Array.make len hd in + let len = Stdlib.List.length l in + let a = make len hd in let rec fill i = function | [] -> a | hd :: tl -> - Array.unsafe_set a (len - i - 2) hd; + unsafe_set a (len - i - 2) hd; fill (i + 1) tl in fill 0 tl @@ -47,10 +49,10 @@ let reverse_of_list = function let rec tolist_f_aux a f i res = if i < 0 then res else - let v = Array.unsafe_get a i in + let v = unsafe_get a i in tolist_f_aux a f (i - 1) (f v :: res) -let to_list_f a f = tolist_f_aux a f (Array.length a - 1) [] +let to_list_f a f = tolist_f_aux a f (length a - 1) [] let of_list_map a f = match a with @@ -86,16 +88,16 @@ let of_list_map a f = let b2 = f a2 in let b3 = f a3 in let b4 = f a4 in - let len = List.length tl + 5 in - let arr = Array.make len b0 in - Array.unsafe_set arr 1 b1; - Array.unsafe_set arr 2 b2; - Array.unsafe_set arr 3 b3; - Array.unsafe_set arr 4 b4; + let len = Stdlib.List.length tl + 5 in + let arr = make len b0 in + unsafe_set arr 1 b1; + unsafe_set arr 2 b2; + unsafe_set arr 3 b3; + unsafe_set arr 4 b4; let rec fill i = function | [] -> arr | hd :: tl -> - Array.unsafe_set arr i (f hd); + unsafe_set arr i (f hd); fill (i + 1) tl in fill 5 tl diff --git a/jscomp/ext/ext_array.mli b/jscomp/melstd/array.mli similarity index 96% rename from jscomp/ext/ext_array.mli rename to jscomp/melstd/array.mli index ce15e7d660..99f9a63f82 100644 --- a/jscomp/ext/ext_array.mli +++ b/jscomp/melstd/array.mli @@ -22,6 +22,10 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +include module type of struct + include StdLabels.Array +end + val reverse_range : 'a array -> int -> int -> unit (** Some utilities for {!Array} operations *) diff --git a/jscomp/ext/dune b/jscomp/melstd/dune similarity index 89% rename from jscomp/ext/dune rename to jscomp/melstd/dune index 6f2c153bb0..e12192404c 100644 --- a/jscomp/ext/dune +++ b/jscomp/melstd/dune @@ -1,23 +1,10 @@ (library - (name ext) + (name melstd) (package melange) - (wrapped false) (flags (:standard -open Melange_compiler_libs)) (libraries unix melange_compiler_libs)) -(rule - (targets hash_gen.ml) - (deps hash_gen.cppo.ml) - (action - (run cppo %{env:CPPO_FLAGS=} %{deps} -o %{targets}))) - -(rule - (targets hash_set_gen.ml) - (deps hash_set_gen.cppo.ml) - (action - (run cppo %{env:CPPO_FLAGS=} %{deps} -o %{targets}))) - (rule (targets js_reserved_map.ml) (deps ./gen/keywords.list) diff --git a/jscomp/ext/ext_filename.ml b/jscomp/melstd/filename.ml similarity index 91% rename from jscomp/ext/ext_filename.ml rename to jscomp/melstd/filename.ml index f67e37043a..263093e20c 100644 --- a/jscomp/ext/ext_filename.ml +++ b/jscomp/melstd/filename.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +include Stdlib.Filename + let is_dir_sep = let is_dir_sep_unix c = c = '/' in let is_dir_sep_win_cygwin c = c = '/' || c = '\\' || c = ':' in @@ -31,7 +33,8 @@ let get_extension_maybe name = let name_len = String.length name in let rec search_dot name i name_len = if i < 0 || is_dir_sep (String.unsafe_get name i) then "" - else if String.unsafe_get name i = '.' then String.sub name i (name_len - i) + else if String.unsafe_get name i = '.' then + String.sub name ~pos:i ~len:(name_len - i) else search_dot name (i - 1) name_len in search_dot name (name_len - 1) name_len @@ -46,12 +49,12 @@ let get_all_extensions_maybe name = let name_len = String.length name in let first_dot = search_dot name (name_len - 1) (name_len - 1) name_len in if first_dot = name_len - 1 then None - else Some (String.sub name first_dot (name_len - first_dot)) + else Some (String.sub name ~pos:first_dot ~len:(name_len - first_dot)) let chop_all_extensions_maybe name = let rec search_dot i last = if i < 0 || is_dir_sep (String.unsafe_get name i) then - match last with None -> name | Some i -> String.sub name 0 i + match last with None -> name | Some i -> String.sub name ~pos:0 ~len:i else if String.unsafe_get name i = '.' then search_dot (i - 1) (Some i) else search_dot (i - 1) last in diff --git a/jscomp/ext/ext_filename.mli b/jscomp/melstd/filename.mli similarity index 90% rename from jscomp/ext/ext_filename.mli rename to jscomp/melstd/filename.mli index 4e6c109725..2530ac6fef 100644 --- a/jscomp/ext/ext_filename.mli +++ b/jscomp/melstd/filename.mli @@ -22,10 +22,9 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(* TODO: - Change the module name, this code is not really an extension of the standard - library but rather specific to JS Module name convention. -*) +include module type of struct + include Stdlib.Filename +end (* return an empty string if no extension found *) val get_extension_maybe : string -> string diff --git a/jscomp/ext/gen/build_reserved.ml b/jscomp/melstd/gen/build_reserved.ml similarity index 94% rename from jscomp/ext/gen/build_reserved.ml rename to jscomp/melstd/gen/build_reserved.ml index 4bb05f30b8..65bb5f3109 100644 --- a/jscomp/ext/gen/build_reserved.ml +++ b/jscomp/melstd/gen/build_reserved.ml @@ -195,26 +195,26 @@ let binary_search = let rec binarySearchAux (arr : element array) (lo : int) (hi : int) key : bool = let mid = (lo + hi) / 2 in - let midVal = Array.unsafe_get arr mid in + let midVal = Stdlib.Array.unsafe_get arr mid in (* let c = cmp key midVal [@u] in *) if key = midVal then true else if key < midVal then (* a[lo] =< key < a[mid] <= a[hi] *) - if hi = mid then Array.unsafe_get arr lo = key + if hi = mid then Stdlib.Array.unsafe_get arr lo = key else binarySearchAux arr lo mid key else if (* a[lo] =< a[mid] < key <= a[hi] *) - lo = mid then Array.unsafe_get arr hi = key + lo = mid then Stdlib.Array.unsafe_get arr hi = key else binarySearchAux arr mid hi key in fun (sorted : element array) (key : element) -> - let len = Array.length sorted in + let len = Stdlib.Array.length sorted in if len = 0 then false else - let lo = Array.unsafe_get sorted 0 in + let lo = Stdlib.Array.unsafe_get sorted 0 in (* let c = cmp key lo [@u] in *) if key < lo then false else - let hi = Array.unsafe_get sorted (len - 1) in + let hi = Stdlib.Array.unsafe_get sorted (len - 1) in (* let c2 = cmp key hi [@u]in *) if key > hi then false else binarySearchAux sorted 0 (len - 1) key diff --git a/jscomp/ext/gen/dune b/jscomp/melstd/gen/dune similarity index 100% rename from jscomp/ext/gen/dune rename to jscomp/melstd/gen/dune diff --git a/jscomp/ext/gen/keywords.list b/jscomp/melstd/gen/keywords.list similarity index 100% rename from jscomp/ext/gen/keywords.list rename to jscomp/melstd/gen/keywords.list diff --git a/jscomp/ext/hash.cppo.ml b/jscomp/melstd/hash.cppo.ml similarity index 65% rename from jscomp/ext/hash.cppo.ml rename to jscomp/melstd/hash.cppo.ml index 10a449d5eb..8b0b459801 100644 --- a/jscomp/ext/hash.cppo.ml +++ b/jscomp/melstd/hash.cppo.ml @@ -2,13 +2,13 @@ type key = Ident.t type 'a t = (key, 'a) Hash_gen.t let key_index (h : _ t ) (key : key) = - (Hashtbl.hash ((Ext_ident.stamp key), (Ident.name key)) ) land (Array.length h.data - 1) -let eq_key = Ext_ident.equal + (Hashtbl.hash ((Ident0.stamp key), (Ident.name key)) ) land (Stdlib.Array.length h.data - 1) +let eq_key = Ident0.equal #elif defined TYPE_INT type key = int type 'a t = (key, 'a) Hash_gen.t let key_index (h : _ t ) (key : key) = - (Hashtbl.hash key) land (Array.length h.data - 1) + (Hashtbl.hash key) land (Stdlib.Array.length h.data - 1) let eq_key = Int.equal #elif defined TYPE_FUNCTOR @@ -16,7 +16,7 @@ module Make (Key : Hashtbl.HashedType) = struct type key = Key.t type 'a t = (key, 'a) Hash_gen.t let key_index (h : _ t ) (key : key) = - (Key.hash key ) land (Array.length h.data - 1) + (Key.hash key ) land (Stdlib.Array.length h.data - 1) let eq_key = Key.equal #else @@ -38,9 +38,9 @@ module Make (Key : Hashtbl.HashedType) = struct let add (h : _ t) key data = let i = key_index h key in let h_data = h.data in - Array.unsafe_set h_data i (Cons{key; data; next=Array.unsafe_get h_data i}); + Stdlib.Array.unsafe_set h_data i (Cons{key; data; next=Stdlib.Array.unsafe_get h_data i}); h.size <- h.size + 1; - if h.size > Array.length h_data lsl 1 then Hash_gen.resize key_index h + if h.size > Stdlib.Array.length h_data lsl 1 then Hash_gen.resize key_index h (* after upgrade to 4.04 we should provide an efficient [replace_or_init] *) let add_or_update @@ -56,17 +56,17 @@ module Make (Key : Hashtbl.HashedType) = struct | Empty -> true in let i = key_index h key in let h_data = h.data in - if find_bucket (Array.unsafe_get h_data i) then + if find_bucket (Stdlib.Array.unsafe_get h_data i) then begin - Array.unsafe_set h_data i (Cons{key; data=default; next = Array.unsafe_get h_data i}); + Stdlib.Array.unsafe_set h_data i (Cons{key; data=default; next = Stdlib.Array.unsafe_get h_data i}); h.size <- h.size + 1 ; - if h.size > Array.length h_data lsl 1 then Hash_gen.resize key_index h + if h.size > Stdlib.Array.length h_data lsl 1 then Hash_gen.resize key_index h end let remove (h : _ t ) key = let i = key_index h key in let h_data = h.data in - Hash_gen.remove_bucket h i key ~prec:Empty (Array.unsafe_get h_data i) eq_key + Hash_gen.remove_bucket h i key ~prec:Empty (Stdlib.Array.unsafe_get h_data i) eq_key (* for short bucket list, [find_rec is not called ] *) let rec find_rec key (bucketlist : _ bucket) = match bucketlist with @@ -76,7 +76,7 @@ module Make (Key : Hashtbl.HashedType) = struct if eq_key key rhs.key then rhs.data else find_rec key rhs.next let find_exn (h : _ t) key = - match Array.unsafe_get h.data (key_index h key) with + match Stdlib.Array.unsafe_get h.data (key_index h key) with | Empty -> raise Not_found | Cons rhs -> if eq_key key rhs.key then rhs.data else @@ -90,13 +90,13 @@ module Make (Key : Hashtbl.HashedType) = struct if eq_key key rhs.key then rhs.data else find_rec key rhs.next let find_opt (h : _ t) key = - Hash_gen.small_bucket_opt eq_key key (Array.unsafe_get h.data (key_index h key)) + Hash_gen.small_bucket_opt eq_key key (Stdlib.Array.unsafe_get h.data (key_index h key)) let find_key_opt (h : _ t) key = - Hash_gen.small_bucket_key_opt eq_key key (Array.unsafe_get h.data (key_index h key)) + Hash_gen.small_bucket_key_opt eq_key key (Stdlib.Array.unsafe_get h.data (key_index h key)) let find_default (h : _ t) key default = - Hash_gen.small_bucket_default eq_key key default (Array.unsafe_get h.data (key_index h key)) + Hash_gen.small_bucket_default eq_key key default (Stdlib.Array.unsafe_get h.data (key_index h key)) let find_all (h : _ t) key = let rec find_in_bucket (bucketlist : _ bucket) = match bucketlist with @@ -106,30 +106,30 @@ module Make (Key : Hashtbl.HashedType) = struct if eq_key key rhs.key then rhs.data :: find_in_bucket rhs.next else find_in_bucket rhs.next in - find_in_bucket (Array.unsafe_get h.data (key_index h key)) + find_in_bucket (Stdlib.Array.unsafe_get h.data (key_index h key)) let replace h key data = let i = key_index h key in let h_data = h.data in - let l = Array.unsafe_get h_data i in + let l = Stdlib.Array.unsafe_get h_data i in if Hash_gen.replace_bucket key data l eq_key then begin - Array.unsafe_set h_data i (Cons{key; data; next=l}); + Stdlib.Array.unsafe_set h_data i (Cons{key; data; next=l}); h.size <- h.size + 1; - if h.size > Array.length h_data lsl 1 then Hash_gen.resize key_index h; + if h.size > Stdlib.Array.length h_data lsl 1 then Hash_gen.resize key_index h; end let mem (h : _ t) key = Hash_gen.small_bucket_mem - (Array.unsafe_get h.data (key_index h key)) + (Stdlib.Array.unsafe_get h.data (key_index h key)) eq_key key let of_list2 ks vs = - let len = List.length ks in + let len = Stdlib.List.length ks in let map = create len in - List.iter2 (fun k v -> add map k v) ks vs ; + Stdlib.List.iter2 (fun k v -> add map k v) ks vs ; map #if defined TYPE_FUNCTOR diff --git a/jscomp/ext/hash.mli b/jscomp/melstd/hash.mli similarity index 100% rename from jscomp/ext/hash.mli rename to jscomp/melstd/hash.mli diff --git a/jscomp/melstd/hash_gen.ml b/jscomp/melstd/hash_gen.ml new file mode 100644 index 0000000000..3be7d39ae6 --- /dev/null +++ b/jscomp/melstd/hash_gen.ml @@ -0,0 +1,235 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* Hash tables *) + +(* We do dynamic hashing, and resize the table and rehash the elements + when buckets become too long. *) + +type ('a, 'b) bucket = + | Empty + | Cons of { + mutable key : 'a; + mutable data : 'b; + mutable next : ('a, 'b) bucket; + } + +type ('a, 'b) t = { + mutable size : int; (* number of entries *) + mutable data : ('a, 'b) bucket array; (* the buckets *) + initial_size : int; (* initial array size *) +} + +(** + {[ + (power_2_above 16 63 = 64) + (power_2_above 16 76 = 128) + ]} +*) +let rec power_2_above x n = + if x >= n then x + else if x * 2 > Sys.max_array_length then x + else power_2_above (x * 2) n + +let create initial_size = + let s = power_2_above 16 initial_size in + { initial_size = s; size = 0; data = Stdlib.Array.make s Empty } + +let clear h = + h.size <- 0; + let len = Stdlib.Array.length h.data in + for i = 0 to len - 1 do + Stdlib.Array.unsafe_set h.data i Empty + done + +let reset h = + h.size <- 0; + h.data <- Stdlib.Array.make h.initial_size Empty + +let length h = h.size + +let resize indexfun h = + let odata = h.data in + let osize = Stdlib.Array.length odata in + let nsize = osize * 2 in + if nsize < Sys.max_array_length then ( + let ndata = Stdlib.Array.make nsize Empty in + let ndata_tail = Stdlib.Array.make nsize Empty in + h.data <- ndata; + (* so that indexfun sees the new bucket count *) + let rec insert_bucket = function + | Empty -> () + | Cons { key; next; _ } as cell -> + let nidx = indexfun h key in + (match Stdlib.Array.unsafe_get ndata_tail nidx with + | Empty -> Stdlib.Array.unsafe_set ndata nidx cell + | Cons tail -> tail.next <- cell); + Stdlib.Array.unsafe_set ndata_tail nidx cell; + insert_bucket next + in + for i = 0 to osize - 1 do + insert_bucket (Stdlib.Array.unsafe_get odata i) + done; + for i = 0 to nsize - 1 do + match Stdlib.Array.unsafe_get ndata_tail i with + | Empty -> () + | Cons tail -> tail.next <- Empty + done) + +let iter h f = + let rec do_bucket = function + | Empty -> () + | Cons l -> + f l.key l.data; + do_bucket l.next + in + let d = h.data in + for i = 0 to Stdlib.Array.length d - 1 do + do_bucket (Stdlib.Array.unsafe_get d i) + done + +let fold h init f = + let rec do_bucket b accu = + match b with + | Empty -> accu + | Cons l -> do_bucket l.next (f l.key l.data accu) + in + let d = h.data in + let accu = ref init in + for i = 0 to Stdlib.Array.length d - 1 do + accu := do_bucket (Stdlib.Array.unsafe_get d i) !accu + done; + !accu + +let to_list h f = fold h [] (fun k data acc -> f k data :: acc) + +let rec small_bucket_mem (lst : _ bucket) eq key = + match lst with + | Empty -> false + | Cons lst -> ( + eq key lst.key + || + match lst.next with + | Empty -> false + | Cons lst -> ( + eq key lst.key + || + match lst.next with + | Empty -> false + | Cons lst -> eq key lst.key || small_bucket_mem lst.next eq key)) + +let rec small_bucket_opt eq key (lst : _ bucket) : _ option = + match lst with + | Empty -> None + | Cons lst -> ( + if eq key lst.key then Some lst.data + else + match lst.next with + | Empty -> None + | Cons lst -> ( + if eq key lst.key then Some lst.data + else + match lst.next with + | Empty -> None + | Cons lst -> + if eq key lst.key then Some lst.data + else small_bucket_opt eq key lst.next)) + +let rec small_bucket_key_opt eq key (lst : _ bucket) : _ option = + match lst with + | Empty -> None + | Cons { key = k; next; _ } -> ( + if eq key k then Some k + else + match next with + | Empty -> None + | Cons { key = k; next; _ } -> ( + if eq key k then Some k + else + match next with + | Empty -> None + | Cons { key = k; next; _ } -> + if eq key k then Some k else small_bucket_key_opt eq key next) + ) + +let rec small_bucket_default eq key default (lst : _ bucket) = + match lst with + | Empty -> default + | Cons lst -> ( + if eq key lst.key then lst.data + else + match lst.next with + | Empty -> default + | Cons lst -> ( + if eq key lst.key then lst.data + else + match lst.next with + | Empty -> default + | Cons lst -> + if eq key lst.key then lst.data + else small_bucket_default eq key default lst.next)) + +let rec remove_bucket h (i : int) key ~(prec : _ bucket) (buck : _ bucket) + eq_key = + match buck with + | Empty -> () + | Cons { key = k; next; _ } -> + if eq_key k key then ( + h.size <- h.size - 1; + match prec with + | Empty -> Stdlib.Array.unsafe_set h.data i next + | Cons c -> c.next <- next) + else remove_bucket h i key ~prec:buck next eq_key + +let rec replace_bucket key data (buck : _ bucket) eq_key = + match buck with + | Empty -> true + | Cons slot -> + if eq_key slot.key key then ( + slot.key <- key; + slot.data <- data; + false) + else replace_bucket key data slot.next eq_key + +module type S = sig + type key + type 'a t + + val create : int -> 'a t + val clear : 'a t -> unit + val reset : 'a t -> unit + val add : 'a t -> key -> 'a -> unit + val add_or_update : 'a t -> key -> update:('a -> 'a) -> 'a -> unit + val remove : 'a t -> key -> unit + val find_exn : 'a t -> key -> 'a + val find_all : 'a t -> key -> 'a list + val find_opt : 'a t -> key -> 'a option + + val find_key_opt : 'a t -> key -> key option + (** return the key found in the hashtbl. + Use case: when you find the key existed in hashtbl, + you want to use the one stored in the hashtbl. + (they are semantically equivlanent, but may have other information different) + *) + + val find_default : 'a t -> key -> 'a -> 'a + val replace : 'a t -> key -> 'a -> unit + val mem : 'a t -> key -> bool + val iter : 'a t -> (key -> 'a -> unit) -> unit + val fold : 'a t -> 'b -> (key -> 'a -> 'b -> 'b) -> 'b + val length : 'a t -> int + + (* val stats: 'a t -> Hashtbl.statistics *) + val to_list : 'a t -> (key -> 'a -> 'c) -> 'c list + val of_list2 : key list -> 'a list -> 'a t +end diff --git a/jscomp/ext/hash_ident.mli b/jscomp/melstd/hash_ident.mli similarity index 100% rename from jscomp/ext/hash_ident.mli rename to jscomp/melstd/hash_ident.mli diff --git a/jscomp/ext/hash_int.mli b/jscomp/melstd/hash_int.mli similarity index 100% rename from jscomp/ext/hash_int.mli rename to jscomp/melstd/hash_int.mli diff --git a/jscomp/ext/hash_set.cppo.ml b/jscomp/melstd/hash_set.cppo.ml similarity index 73% rename from jscomp/ext/hash_set.cppo.ml rename to jscomp/melstd/hash_set.cppo.ml index d69d61b28b..1e4d0afb4f 100644 --- a/jscomp/ext/hash_set.cppo.ml +++ b/jscomp/melstd/hash_set.cppo.ml @@ -25,21 +25,21 @@ #ifdef TYPE_STRING type key = string let key_index (h : _ Hash_set_gen.t ) (key : key) = - (Hashtbl.hash key) land (Array.length h.data - 1) -let eq_key = String.equal + (Hashtbl.hash key) land (Stdlib.Array.length h.data - 1) +let eq_key = Stdlib.String.equal type t = key Hash_set_gen.t #elif defined TYPE_IDENT type key = Ident.t let key_index (h : _ Hash_set_gen.t ) (key : key) = - (Hashtbl.hash ((Ident.name key), (Ext_ident.stamp key))) land (Array.length h.data - 1) -let eq_key = Ext_ident.equal + (Hashtbl.hash ((Ident.name key), (Ident0.stamp key))) land (Stdlib.Array.length h.data - 1) +let eq_key = Ident0.equal type t = key Hash_set_gen.t #elif defined TYPE_FUNCTOR module Make (H: Hashtbl.HashedType) : (Hash_set_gen.S with type key = H.t) = struct type key = H.t let eq_key = H.equal let key_index (h : _ Hash_set_gen.t ) key = - (H.hash key) land (Array.length h.data - 1) + (H.hash key) land (Stdlib.Array.length h.data - 1) type t = key Hash_set_gen.t #elif defined TYPE_POLY @@ -47,15 +47,14 @@ module Make (H: Hashtbl.HashedType) : (Hash_set_gen.S with type key = H.t) = str external seeded_hash_param : int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc] let key_index (h : _ Hash_set_gen.t ) (key : 'a) = - seeded_hash_param 10 100 0 key land (Array.length h.data - 1) + seeded_hash_param 10 100 0 key land (Stdlib.Array.length h.data - 1) let eq_key = (=) type 'a t = 'a Hash_set_gen.t #else [%error "unknown type"] #endif - - let create = Hash_set_gen.create + let create = Hash_set_gen.create let clear = Hash_set_gen.clear let reset = Hash_set_gen.reset (* let copy = Hash_set_gen.copy *) @@ -65,51 +64,46 @@ module Make (H: Hashtbl.HashedType) : (Hash_set_gen.S with type key = H.t) = str (* let stats = Hash_set_gen.stats *) let to_list = Hash_set_gen.to_list - - let remove (h : _ Hash_set_gen.t ) key = let i = key_index h key in let h_data = h.data in - Hash_set_gen.remove_bucket h i key ~prec:Empty (Array.unsafe_get h_data i) eq_key - - + Hash_set_gen.remove_bucket h i key ~prec:Empty (Stdlib.Array.unsafe_get h_data i) eq_key let add (h : _ Hash_set_gen.t) key = let i = key_index h key in let h_data = h.data in - let old_bucket = (Array.unsafe_get h_data i) in + let old_bucket = (Stdlib.Array.unsafe_get h_data i) in if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then begin - Array.unsafe_set h_data i (Cons {key = key ; next = old_bucket}); + Stdlib.Array.unsafe_set h_data i (Cons {key = key ; next = old_bucket}); h.size <- h.size + 1 ; - if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h + if h.size > Stdlib.Array.length h_data lsl 1 then Hash_set_gen.resize key_index h end let of_array arr = - let len = Array.length arr in + let len = Stdlib.Array.length arr in let tbl = create len in for i = 0 to len - 1 do - add tbl (Array.unsafe_get arr i); + add tbl (Stdlib.Array.unsafe_get arr i); done ; tbl - let check_add (h : _ Hash_set_gen.t) key : bool = let i = key_index h key in let h_data = h.data in - let old_bucket = (Array.unsafe_get h_data i) in + let old_bucket = (Stdlib.Array.unsafe_get h_data i) in if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then begin - Array.unsafe_set h_data i (Cons { key = key ; next = old_bucket}); + Stdlib.Array.unsafe_set h_data i (Cons { key = key ; next = old_bucket}); h.size <- h.size + 1 ; - if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h; + if h.size > Stdlib.Array.length h_data lsl 1 then Hash_set_gen.resize key_index h; true end else false let mem (h : _ Hash_set_gen.t) key = - Hash_set_gen.small_bucket_mem eq_key key (Array.unsafe_get h.data (key_index h key)) + Hash_set_gen.small_bucket_mem eq_key key (Stdlib.Array.unsafe_get h.data (key_index h key)) #ifdef TYPE_FUNCTOR end diff --git a/jscomp/ext/hash_set.mli b/jscomp/melstd/hash_set.mli similarity index 100% rename from jscomp/ext/hash_set.mli rename to jscomp/melstd/hash_set.mli diff --git a/jscomp/melstd/hash_set_gen.ml b/jscomp/melstd/hash_set_gen.ml new file mode 100644 index 0000000000..c694631662 --- /dev/null +++ b/jscomp/melstd/hash_set_gen.ml @@ -0,0 +1,155 @@ +(* 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 + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +(* We do dynamic hashing, and resize the table and rehash the elements + when buckets become too long. *) + +type 'a bucket = + | Empty + | Cons of { mutable key : 'a; mutable next : 'a bucket } + +type 'a t = { + mutable size : int; (* number of entries *) + mutable data : 'a bucket array; (* the buckets *) + initial_size : int; (* initial array size *) +} + +let create initial_size = + let s = Hash_gen.power_2_above 16 initial_size in + { initial_size = s; size = 0; data = Stdlib.Array.make s Empty } + +let clear h = + h.size <- 0; + let len = Stdlib.Array.length h.data in + for i = 0 to len - 1 do + Stdlib.Array.unsafe_set h.data i Empty + done + +let reset h = + h.size <- 0; + h.data <- Stdlib.Array.make h.initial_size Empty + +let length h = h.size + +let resize indexfun h = + let odata = h.data in + let osize = Stdlib.Array.length odata in + let nsize = osize * 2 in + if nsize < Sys.max_array_length then ( + let ndata = Stdlib.Array.make nsize Empty in + let ndata_tail = Stdlib.Array.make nsize Empty in + h.data <- ndata; + (* so that indexfun sees the new bucket count *) + let rec insert_bucket = function + | Empty -> () + | Cons { key; next } as cell -> + let nidx = indexfun h key in + (match Stdlib.Array.unsafe_get ndata_tail nidx with + | Empty -> Stdlib.Array.unsafe_set ndata nidx cell + | Cons tail -> tail.next <- cell); + Stdlib.Array.unsafe_set ndata_tail nidx cell; + insert_bucket next + in + for i = 0 to osize - 1 do + insert_bucket (Stdlib.Array.unsafe_get odata i) + done; + for i = 0 to nsize - 1 do + match Stdlib.Array.unsafe_get ndata_tail i with + | Empty -> () + | Cons tail -> tail.next <- Empty + done) + +let iter h f = + let rec do_bucket = function + | Empty -> () + | Cons l -> + f l.key; + do_bucket l.next + in + let d = h.data in + for i = 0 to Stdlib.Array.length d - 1 do + do_bucket (Stdlib.Array.unsafe_get d i) + done + +let fold h init f = + let rec do_bucket b accu = + match b with Empty -> accu | Cons l -> do_bucket l.next (f l.key accu) + in + let d = h.data in + let accu = ref init in + for i = 0 to Stdlib.Array.length d - 1 do + accu := do_bucket (Stdlib.Array.unsafe_get d i) !accu + done; + !accu + +let to_list set = fold set [] Stdlib.List.cons + +let rec small_bucket_mem eq key lst = + match lst with + | Empty -> false + | Cons lst -> ( + eq key lst.key + || + match lst.next with + | Empty -> false + | Cons lst -> ( + eq key lst.key + || + match lst.next with + | Empty -> false + | Cons lst -> eq key lst.key || small_bucket_mem eq key lst.next)) + +let rec remove_bucket (h : _ t) (i : int) key ~(prec : _ bucket) + (buck : _ bucket) eq_key = + match buck with + | Empty -> () + | Cons { key = k; next } -> + if eq_key k key then ( + h.size <- h.size - 1; + match prec with + | Empty -> Stdlib.Array.unsafe_set h.data i next + | Cons c -> c.next <- next) + else remove_bucket h i key ~prec:buck next eq_key + +module type S = sig + type key + type t + + val create : int -> t + val clear : t -> unit + val reset : t -> unit + + (* val copy: t -> t *) + val remove : t -> key -> unit + val add : t -> key -> unit + val of_array : key array -> t + val check_add : t -> key -> bool + val mem : t -> key -> bool + val iter : t -> (key -> unit) -> unit + val fold : t -> 'b -> (key -> 'b -> 'b) -> 'b + val length : t -> int + + (* val stats: t -> Hashtbl.statistics *) + val to_list : t -> key list +end diff --git a/jscomp/ext/hash_set_ident.mli b/jscomp/melstd/hash_set_ident.mli similarity index 100% rename from jscomp/ext/hash_set_ident.mli rename to jscomp/melstd/hash_set_ident.mli diff --git a/jscomp/ext/hash_set_ident_mask.ml b/jscomp/melstd/hash_set_ident_mask.ml similarity index 76% rename from jscomp/ext/hash_set_ident_mask.ml rename to jscomp/melstd/hash_set_ident_mask.ml index eae7ce040d..e781243ec7 100644 --- a/jscomp/ext/hash_set_ident_mask.ml +++ b/jscomp/melstd/hash_set_ident_mask.ml @@ -22,7 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(** A speicalized datastructure for scc algorithm *) +(* A specialized datastructure for the SCC (Strongly Connected Components) + algorithm *) type ident = Ident.t @@ -37,12 +38,12 @@ type t = { } let key_index_by_ident (h : t) (key : Ident.t) = - Hashtbl.hash (Ident.name key, Ext_ident.stamp key) - land (Array.length h.data - 1) + Hashtbl.hash (Ident.name key, Mel_ident.stamp key) + land (Stdlib.Array.length h.data - 1) let create initial_size = let s = Hash_gen.power_2_above 8 initial_size in - { size = 0; data = Array.make s Empty; mask_size = 0 } + { size = 0; data = Stdlib.Array.make s Empty; mask_size = 0 } let iter_and_unmask h f = let rec iter_bucket buckets = @@ -61,61 +62,63 @@ let iter_and_unmask h f = iter_bucket k.rest in let d = h.data in - for i = 0 to Array.length d - 1 do - iter_bucket (Array.unsafe_get d i) + for i = 0 to Stdlib.Array.length d - 1 do + iter_bucket (Stdlib.Array.unsafe_get d i) done let rec small_bucket_mem key lst = match lst with | Empty -> false | Cons rst -> ( - Ext_ident.equal key rst.ident + Mel_ident.equal key rst.ident || match rst.rest with | Empty -> false | Cons rst -> ( - Ext_ident.equal key rst.ident + Mel_ident.equal key rst.ident || match rst.rest with | Empty -> false | Cons rst -> - Ext_ident.equal key rst.ident || small_bucket_mem key rst.rest)) + Mel_ident.equal key rst.ident || small_bucket_mem key rst.rest)) let resize indexfun h = let odata = h.data in - let osize = Array.length odata in + let osize = Stdlib.Array.length odata in let nsize = osize * 2 in if nsize < Sys.max_array_length then ( - let ndata = Array.make nsize Empty in + let ndata = Stdlib.Array.make nsize Empty in h.data <- ndata; (* so that indexfun sees the new bucket count *) let rec insert_bucket = function | Empty -> () | Cons { ident = key; mask; rest } -> let nidx = indexfun h key in - Array.unsafe_set ndata nidx - (Cons { ident = key; mask; rest = Array.unsafe_get ndata nidx }); + Stdlib.Array.unsafe_set ndata nidx + (Cons + { ident = key; mask; rest = Stdlib.Array.unsafe_get ndata nidx }); insert_bucket rest in for i = 0 to osize - 1 do - insert_bucket (Array.unsafe_get odata i) + insert_bucket (Stdlib.Array.unsafe_get odata i) done) let add_unmask (h : t) (key : Ident.t) = let i = key_index_by_ident h key in let h_data = h.data in - let old_bucket = Array.unsafe_get h_data i in + let old_bucket = Stdlib.Array.unsafe_get h_data i in if not (small_bucket_mem key old_bucket) then ( - Array.unsafe_set h_data i + Stdlib.Array.unsafe_set h_data i (Cons { ident = key; mask = false; rest = old_bucket }); h.size <- h.size + 1; - if h.size > Array.length h_data lsl 1 then resize key_index_by_ident h) + if h.size > Stdlib.Array.length h_data lsl 1 then + resize key_index_by_ident h) let rec small_bucket_mask key lst = match lst with | Empty -> false | Cons rst -> ( - if Ext_ident.equal key rst.ident then + if Mel_ident.equal key rst.ident then if rst.mask then false else ( rst.mask <- true; @@ -124,7 +127,7 @@ let rec small_bucket_mask key lst = match rst.rest with | Empty -> false | Cons rst -> ( - if Ext_ident.equal key rst.ident then + if Mel_ident.equal key rst.ident then if rst.mask then false else ( rst.mask <- true; @@ -133,7 +136,7 @@ let rec small_bucket_mask key lst = match rst.rest with | Empty -> false | Cons rst -> - if Ext_ident.equal key rst.ident then + if Mel_ident.equal key rst.ident then if rst.mask then false else ( rst.mask <- true; @@ -141,6 +144,8 @@ let rec small_bucket_mask key lst = else small_bucket_mask key rst.rest)) let mask_and_check_all_hit (h : t) (key : Ident.t) = - if small_bucket_mask key (Array.unsafe_get h.data (key_index_by_ident h key)) + if + small_bucket_mask key + (Stdlib.Array.unsafe_get h.data (key_index_by_ident h key)) then h.mask_size <- h.mask_size + 1; h.size = h.mask_size diff --git a/jscomp/ext/hash_set_ident_mask.mli b/jscomp/melstd/hash_set_ident_mask.mli similarity index 100% rename from jscomp/ext/hash_set_ident_mask.mli rename to jscomp/melstd/hash_set_ident_mask.mli diff --git a/jscomp/ext/hash_set_poly.mli b/jscomp/melstd/hash_set_poly.mli similarity index 100% rename from jscomp/ext/hash_set_poly.mli rename to jscomp/melstd/hash_set_poly.mli diff --git a/jscomp/ext/hash_set_string.mli b/jscomp/melstd/hash_set_string.mli similarity index 100% rename from jscomp/ext/hash_set_string.mli rename to jscomp/melstd/hash_set_string.mli diff --git a/jscomp/ext/ext_ident.ml b/jscomp/melstd/ident0.ml similarity index 95% rename from jscomp/ext/ext_ident.ml rename to jscomp/melstd/ident0.ml index 25ef9ea918..ef96eb944d 100644 --- a/jscomp/ext/ext_ident.ml +++ b/jscomp/melstd/ident0.ml @@ -112,17 +112,17 @@ let[@inline] no_escape (c : char) = exception Not_normal_letter of int let name_mangle name = - let len = String.length name in + let len = Stdlib.String.length name in try for i = 0 to len - 1 do - if not (no_escape (String.unsafe_get name i)) then + if not (no_escape (Stdlib.String.unsafe_get name i)) then raise_notrace (Not_normal_letter i) done; name (* Normal letter *) with Not_normal_letter i -> let buffer = Buffer.create len in for j = 0 to len - 1 do - let c = String.unsafe_get name j in + let c = Stdlib.String.unsafe_get name j in if no_escape c then Buffer.add_char buffer c else Buffer.add_string buffer (convert ~op:(i = 0) c) done; @@ -131,7 +131,7 @@ let name_mangle name = (* TODO: check name conflicts with javascript conventions {[ - Ext_ident.convert "^";; + Ident.convert "^";; - : string = "$caret" ]} [convert name] if [name] is a js keyword,add "$$" @@ -155,7 +155,7 @@ let make_unused () = create "_" *) let compare (x : Ident.t) (y : Ident.t) = let u = stamp x - stamp y in - if u = 0 then String.compare (Ident.name x) (Ident.name y) else u + if u = 0 then Stdlib.String.compare (Ident.name x) (Ident.name y) else u let equal (x : Ident.t) (y : Ident.t) = if stamp x <> 0 then stamp x = stamp y diff --git a/jscomp/ext/ext_ident.mli b/jscomp/melstd/ident0.mli similarity index 97% rename from jscomp/ext/ext_ident.mli rename to jscomp/melstd/ident0.mli index c8ab436e6d..9a1fb295b2 100644 --- a/jscomp/ext/ext_ident.mli +++ b/jscomp/melstd/ident0.mli @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(** A wrapper around [Ident] module in compiler-libs*) +(** A wrapper around [Ident] module in compiler-libs *) val is_js : Ident.t -> bool diff --git a/jscomp/ext/int_vec_vec.ml b/jscomp/melstd/int_vec_vec.ml similarity index 100% rename from jscomp/ext/int_vec_vec.ml rename to jscomp/melstd/int_vec_vec.ml diff --git a/jscomp/ext/int_vec_vec.mli b/jscomp/melstd/int_vec_vec.mli similarity index 100% rename from jscomp/ext/int_vec_vec.mli rename to jscomp/melstd/int_vec_vec.mli diff --git a/jscomp/ext/js_reserved_map.mli b/jscomp/melstd/js_reserved_map.mli similarity index 100% rename from jscomp/ext/js_reserved_map.mli rename to jscomp/melstd/js_reserved_map.mli diff --git a/jscomp/ext/ext_js_suffix.ml b/jscomp/melstd/js_suffix.ml similarity index 98% rename from jscomp/ext/ext_js_suffix.ml rename to jscomp/melstd/js_suffix.ml index 6e21a68d95..f18ad43e69 100644 --- a/jscomp/ext/ext_js_suffix.ml +++ b/jscomp/melstd/js_suffix.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +module String = Stdlib.String + type t = string let to_string = Fun.id diff --git a/jscomp/ext/ext_js_suffix.mli b/jscomp/melstd/js_suffix.mli similarity index 100% rename from jscomp/ext/ext_js_suffix.mli rename to jscomp/melstd/js_suffix.mli diff --git a/jscomp/ext/ext_list.ml b/jscomp/melstd/list.ml similarity index 93% rename from jscomp/ext/ext_list.ml rename to jscomp/melstd/list.ml index 21fb78fa5b..2ceef2fbfc 100644 --- a/jscomp/ext/ext_list.ml +++ b/jscomp/melstd/list.ml @@ -22,28 +22,30 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +include StdLabels.List + external ( .!() ) : 'a array -> int -> 'a = "%array_unsafe_get" let rec map_combine l1 l2 f = match (l1, l2) with | [], [] -> [] | a1 :: l1, a2 :: l2 -> (f a1, a2) :: map_combine l1 l2 f - | _, _ -> invalid_arg "Ext_list.map_combine" + | _, _ -> invalid_arg "List.map_combine" let rec arr_list_combine_unsafe arr l i j acc f = if i = j then acc else match l with - | [] -> invalid_arg "Ext_list.combine" + | [] -> invalid_arg "List.combine" | h :: tl -> (f arr.!(i), h) :: arr_list_combine_unsafe arr tl (i + 1) j acc f let map_combine_array_append arr l acc f = - let len = Array.length arr in + let len = Stdlib.Array.length arr in arr_list_combine_unsafe arr l 0 len acc f let map_combine_array arr l f = - let len = Array.length arr in + let len = Stdlib.Array.length arr in arr_list_combine_unsafe arr l 0 len [] f let rec map_snd l f = @@ -116,23 +118,23 @@ let rec same_length xs ys = | _, _ -> false let rec small_split_at n acc l = - if n <= 0 then (List.rev acc, l) + if n <= 0 then (Stdlib.List.rev acc, l) else match l with | x :: xs -> small_split_at (n - 1) (x :: acc) xs - | _ -> invalid_arg "Ext_list.split_at" + | _ -> invalid_arg "List.split_at" let split_at l n = small_split_at n [] l let rec split_at_last_aux acc x = match x with - | [] -> invalid_arg "Ext_list.split_at_last" - | [ x ] -> (List.rev acc, x) + | [] -> invalid_arg "List.split_at_last" + | [ x ] -> (Stdlib.List.rev acc, x) | y0 :: ys -> split_at_last_aux (y0 :: acc) ys let split_at_last (x : 'a list) = match x with - | [] -> invalid_arg "Ext_list.split_at_last" + | [] -> invalid_arg "List.split_at_last" | [ a0 ] -> ([], a0) | [ a0; a1 ] -> ([ a0 ], a1) | [ a0; a1; a2 ] -> ([ a0; a1 ], a2) @@ -173,7 +175,7 @@ let stable_group = if eq x y0 then (x :: y) :: ys else y :: aux eq x ys | _ :: _ -> assert false in - fun lst eq -> group eq lst |> List.rev + fun lst eq -> group eq lst |> Stdlib.List.rev let rec rev_iter l f = match l with diff --git a/jscomp/ext/ext_list.mli b/jscomp/melstd/list.mli similarity index 98% rename from jscomp/ext/ext_list.mli rename to jscomp/melstd/list.mli index d49c36ccef..5ea3e6e564 100644 --- a/jscomp/ext/ext_list.mli +++ b/jscomp/melstd/list.mli @@ -22,6 +22,10 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +include module type of struct + include StdLabels.List +end + val map_combine : 'a list -> 'b list -> ('a -> 'c) -> ('c * 'b) list val map_combine_array : 'a array -> 'b list -> ('a -> 'c) -> ('c * 'b) list diff --git a/jscomp/ext/map.cppo.ml b/jscomp/melstd/map.cppo.ml similarity index 96% rename from jscomp/ext/map.cppo.ml rename to jscomp/melstd/map.cppo.ml index 29ea78edc7..ad26de4d89 100644 --- a/jscomp/ext/map.cppo.ml +++ b/jscomp/melstd/map.cppo.ml @@ -3,7 +3,7 @@ #ifdef TYPE_STRING type key = string -let compare_key = String.compare +let compare_key = Stdlib.String.compare let [@inline] eq_key (x : key) y = x = y #elif defined TYPE_INT type key = int @@ -11,7 +11,7 @@ let compare_key = Int.compare let [@inline] eq_key (x : key) y = x = y #elif defined TYPE_IDENT type key = Ident.t -let compare_key = Ext_ident.compare +let compare_key = Ident0.compare let [@inline] eq_key (x : key) y = Ident.same x y #else [%error "unknown type"] @@ -218,8 +218,8 @@ let disjoint_merge_exn s1 s2 fail = let add_list (xs : _ list ) init = - List.fold_left (fun acc (k,v) -> add acc k v ) init xs + Stdlib.List.fold_left (fun acc (k,v) -> add acc k v ) init xs let of_list xs = add_list xs empty -let of_array xs = Array.fold_left (fun acc (k,v) -> add acc k v ) empty xs +let of_array xs = Stdlib.Array.fold_left (fun acc (k,v) -> add acc k v ) empty xs diff --git a/jscomp/ext/map_gen.ml b/jscomp/melstd/map_gen.ml similarity index 97% rename from jscomp/ext/map_gen.ml rename to jscomp/melstd/map_gen.ml index 17bf63cd50..967d558a0e 100644 --- a/jscomp/ext/map_gen.ml +++ b/jscomp/melstd/map_gen.ml @@ -84,22 +84,22 @@ let rec fill_array_with_f (s : _ t) i arr f : int = match s with | Empty -> i | Leaf { k; v } -> - Array.unsafe_set arr i (f k v); + Stdlib.Array.unsafe_set arr i (f k v); i + 1 | Node { l; k; v; r; _ } -> let inext = fill_array_with_f l i arr f in - Array.unsafe_set arr inext (f k v); + Stdlib.Array.unsafe_set arr inext (f k v); fill_array_with_f r (inext + 1) arr f let rec fill_array_aux (s : _ t) i arr : int = match s with | Empty -> i | Leaf { k; v } -> - Array.unsafe_set arr i (k, v); + Stdlib.Array.unsafe_set arr i (k, v); i + 1 | Node { l; k; v; r; _ } -> let inext = fill_array_aux l i arr in - Array.unsafe_set arr inext (k, v); + Stdlib.Array.unsafe_set arr inext (k, v); fill_array_aux r (inext + 1) arr let to_sorted_array (s : ('key, 'a) t) : ('key * 'a) array = @@ -108,7 +108,7 @@ let to_sorted_array (s : ('key, 'a) t) : ('key * 'a) array = | Leaf { k; v } -> [| (k, v) |] | Node { l; k; v; r; _ } -> let len = cardinal_aux (cardinal_aux 1 r) l in - let arr = Array.make len (k, v) in + let arr = Stdlib.Array.make len (k, v) in ignore (fill_array_aux s 0 arr : int); arr @@ -119,7 +119,7 @@ let to_sorted_array_with_f (type key a b) (s : (key, a) t) (f : key -> a -> b) : | Leaf { k; v } -> [| f k v |] | Node { l; k; v; r; _ } -> let len = cardinal_aux (cardinal_aux 1 r) l in - let arr = Array.make len (f k v) in + let arr = Stdlib.Array.make len (f k v) in ignore (fill_array_with_f s 0 arr f : int); arr diff --git a/jscomp/ext/map_gen.mli b/jscomp/melstd/map_gen.mli similarity index 100% rename from jscomp/ext/map_gen.mli rename to jscomp/melstd/map_gen.mli diff --git a/jscomp/ext/map_ident.mli b/jscomp/melstd/map_ident.mli similarity index 100% rename from jscomp/ext/map_ident.mli rename to jscomp/melstd/map_ident.mli diff --git a/jscomp/ext/map_int.mli b/jscomp/melstd/map_int.mli similarity index 100% rename from jscomp/ext/map_int.mli rename to jscomp/melstd/map_int.mli diff --git a/jscomp/ext/map_string.mli b/jscomp/melstd/map_string.mli similarity index 100% rename from jscomp/ext/map_string.mli rename to jscomp/melstd/map_string.mli diff --git a/jscomp/melstd/mel_ident.ml b/jscomp/melstd/mel_ident.ml new file mode 100644 index 0000000000..acc984e55b --- /dev/null +++ b/jscomp/melstd/mel_ident.ml @@ -0,0 +1,30 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * 2017 - Hongbo Zhang, Authors of ReScript + * 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 + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +include Ident0 +include Ident +module Map = Map_ident +module Set = Set_ident +module Hash = Hash_ident +module Hash_set = Hash_set_ident diff --git a/jscomp/melstd/mel_ident.mli b/jscomp/melstd/mel_ident.mli new file mode 100644 index 0000000000..1bb5576659 --- /dev/null +++ b/jscomp/melstd/mel_ident.mli @@ -0,0 +1,52 @@ +(* 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 + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +(** A wrapper around [Ident] module in compiler-libs *) + +include module type of struct + include Ident +end + +module Map = Map_ident +module Set = Set_ident +module Hash = Hash_ident +module Hash_set = Hash_set_ident + +val is_js : t -> bool + +val create_js : string -> t +(** create identifiers for predefined [js] global variables *) + +val create : string -> t +val make_js_object : t -> t +val create_tmp : ?name:string -> unit -> t +val make_unused : unit -> t +val stamp : t -> int + +val convert : string -> string +(** Invariant: if name is not converted, the reference should be equal *) + +val is_js_or_global : t -> bool +val compare : t -> t -> int +val equal : t -> t -> bool diff --git a/jscomp/melstd/melstd.ml b/jscomp/melstd/melstd.ml new file mode 100644 index 0000000000..1dcfa29dc3 --- /dev/null +++ b/jscomp/melstd/melstd.ml @@ -0,0 +1,51 @@ +(* Copyright (C) 2023- Authors of Melange + * + * 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 + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +module Array = Array +module Filename = Filename +module Hash = Hash +module Hash_gen = Hash_gen +module Hash_int = Hash_int +module Hash_set = Hash_set +module Hash_set_gen = Hash_set_gen +module Hash_set_ident_mask = Hash_set_ident_mask +module Ident = Mel_ident +module Int_vec_vec = Int_vec_vec +module Js_suffix = Js_suffix +module List = List +module Map_gen = Map_gen +module Map_int = Map_int +module Modulename = Modulename +module Module_system = Module_system +module Ordered_hash_map_local_ident = Ordered_hash_map_local_ident +module Polyvariant = Polyvariant +module Path = Path +module Js_pp = Pp +module Pp_scope = Pp_scope +module Scc = Scc +module String = String +module Vec = Vec +module Vec_int = Vec_int +module Set_int = Set_int +module Set_gen = Set_gen diff --git a/jscomp/ext/ext_module_system.ml b/jscomp/melstd/module_system.ml similarity index 98% rename from jscomp/ext/ext_module_system.ml rename to jscomp/melstd/module_system.ml index 4a85178d82..f32dd5730c 100644 --- a/jscomp/ext/ext_module_system.ml +++ b/jscomp/melstd/module_system.ml @@ -38,7 +38,7 @@ let compatible ~dep t = let runtime_dir = function NodeJS -> "js" | Es6 | Es6_global -> "es6" let runtime_package_path = - let ( // ) = Ext_path.( // ) in + let ( // ) = Path.( // ) in let melange_js = "melange.js" in fun js_file -> melange_js // js_file diff --git a/jscomp/ext/ext_module_system.mli b/jscomp/melstd/module_system.mli similarity index 100% rename from jscomp/ext/ext_module_system.mli rename to jscomp/melstd/module_system.mli diff --git a/jscomp/ext/ext_modulename.ml b/jscomp/melstd/modulename.ml similarity index 81% rename from jscomp/ext/ext_modulename.ml rename to jscomp/melstd/modulename.ml index 924101b639..634bc1368e 100644 --- a/jscomp/ext/ext_modulename.ml +++ b/jscomp/melstd/modulename.ml @@ -23,11 +23,11 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let good_hint_name module_name offset = - let len = String.length module_name in + let len = Stdlib.String.length module_name in len > offset && (function 'a' .. 'z' | 'A' .. 'Z' -> true | _ -> false) - (String.unsafe_get module_name offset) - && Ext_string.for_all_from module_name (offset + 1) (function + (Stdlib.String.unsafe_get module_name offset) + && String.for_all_from module_name (offset + 1) (function | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> true | _ -> false) @@ -35,7 +35,7 @@ let rec collect_start buf s off len = if off >= len then () else let next = succ off in - match String.unsafe_get s off with + match Stdlib.String.unsafe_get s off with | 'a' .. 'z' as c -> Buffer.add_char buf (Char.uppercase_ascii c); collect_next buf s next len @@ -48,7 +48,7 @@ and collect_next buf s off len = if off >= len then () else let next = off + 1 in - match String.unsafe_get s off with + match Stdlib.String.unsafe_get s off with | ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_') as c -> Buffer.add_char buf c; collect_next buf s next len @@ -64,20 +64,21 @@ and collect_next buf s off len = Given a name, if duplicated, they should have the same id *) let js_id_name_of_hint_name module_name = - let i = Ext_string.rindex_neg module_name '/' in + let i = String.rindex_neg module_name '/' in if i >= 0 then ( let offset = succ i in if good_hint_name module_name offset then - String.capitalize_ascii (Ext_string.tail_from module_name offset) + Stdlib.String.capitalize_ascii (String.tail_from module_name offset) else - let str_len = String.length module_name in + let str_len = Stdlib.String.length module_name in let buf = Buffer.create str_len in collect_start buf module_name offset str_len; - if Buffer.length buf = 0 then String.capitalize_ascii module_name + if Buffer.length buf = 0 then Stdlib.String.capitalize_ascii module_name else Buffer.contents buf) - else if good_hint_name module_name 0 then String.capitalize_ascii module_name + else if good_hint_name module_name 0 then + Stdlib.String.capitalize_ascii module_name else - let str_len = String.length module_name in + let str_len = Stdlib.String.length module_name in let buf = Buffer.create str_len in collect_start buf module_name 0 str_len; if Buffer.length buf = 0 then module_name else Buffer.contents buf diff --git a/jscomp/ext/ext_modulename.mli b/jscomp/melstd/modulename.mli similarity index 100% rename from jscomp/ext/ext_modulename.mli rename to jscomp/melstd/modulename.mli diff --git a/jscomp/ext/ordered_hash_map.cppo.ml b/jscomp/melstd/ordered_hash_map.cppo.ml similarity index 95% rename from jscomp/ext/ordered_hash_map.cppo.ml rename to jscomp/melstd/ordered_hash_map.cppo.ml index e12ad7d9f9..e592cbf91f 100644 --- a/jscomp/ext/ordered_hash_map.cppo.ml +++ b/jscomp/melstd/ordered_hash_map.cppo.ml @@ -1,3 +1,5 @@ +module Array = Stdlib.Array + #if defined TYPE_FUNCTOR module Make(H: Hashtbl.HashedType): (S with type key = H.t) = struct @@ -10,8 +12,8 @@ struct type key = Ident.t type 'value t = (key,'value) Ordered_hash_map_gen.t let key_index (h : _ t) (key : key) = - (Hashtbl.hash (Ext_ident.stamp key)) land (Array.length h.data - 1) - let equal_key = Ext_ident.equal + (Hashtbl.hash (Mel_ident.stamp key)) land (Array.length h.data - 1) + let equal_key = Mel_ident.equal #else [%error "unknown type"] diff --git a/jscomp/ext/ordered_hash_map_gen.ml b/jscomp/melstd/ordered_hash_map_gen.ml similarity index 81% rename from jscomp/ext/ordered_hash_map_gen.ml rename to jscomp/melstd/ordered_hash_map_gen.ml index 430b75ae86..c08261dbcd 100644 --- a/jscomp/ext/ordered_hash_map_gen.ml +++ b/jscomp/melstd/ordered_hash_map_gen.ml @@ -59,39 +59,39 @@ type ('a, 'b) t = { let create initial_size = let s = Hash_gen.power_2_above 16 initial_size in - { initial_size = s; size = 0; data = Array.make s Empty } + { initial_size = s; size = 0; data = Stdlib.Array.make s Empty } let clear h = h.size <- 0; - let len = Array.length h.data in + let len = Stdlib.Array.length h.data in for i = 0 to len - 1 do - Array.unsafe_set h.data i Empty + Stdlib.Array.unsafe_set h.data i Empty done let reset h = h.size <- 0; - h.data <- Array.make h.initial_size Empty + h.data <- Stdlib.Array.make h.initial_size Empty let length h = h.size let resize indexfun h = let odata = h.data in - let osize = Array.length odata in + let osize = Stdlib.Array.length odata in let nsize = osize * 2 in if nsize < Sys.max_array_length then ( - let ndata = Array.make nsize Empty in + let ndata = Stdlib.Array.make nsize Empty in h.data <- ndata; (* so that indexfun sees the new bucket count *) let rec insert_bucket = function | Empty -> () | Cons { key; ord; data; next } -> let nidx = indexfun h key in - Array.unsafe_set ndata nidx - (Cons { key; ord; data; next = Array.unsafe_get ndata nidx }); + Stdlib.Array.unsafe_set ndata nidx + (Cons { key; ord; data; next = Stdlib.Array.unsafe_get ndata nidx }); insert_bucket next in for i = 0 to osize - 1 do - insert_bucket (Array.unsafe_get odata i) + insert_bucket (Stdlib.Array.unsafe_get odata i) done) let iter h f = @@ -102,26 +102,26 @@ let iter h f = do_bucket next in let d = h.data in - for i = 0 to Array.length d - 1 do - do_bucket (Array.unsafe_get d i) + for i = 0 to Stdlib.Array.length d - 1 do + do_bucket (Stdlib.Array.unsafe_get d i) done let choose h = let rec aux arr offset len = if offset >= len then raise Not_found else - match Array.unsafe_get arr offset with + match Stdlib.Array.unsafe_get arr offset with | Empty -> aux arr (offset + 1) len | Cons { key = k; _ } -> k in - aux h.data 0 (Array.length h.data) + aux h.data 0 (Stdlib.Array.length h.data) let to_sorted_array h = if h.size = 0 then [||] else let v = choose h in - let arr = Array.make h.size v in - iter h (fun k _ i -> Array.unsafe_set arr i k); + let arr = Stdlib.Array.make h.size v in + iter h (fun k _ i -> Stdlib.Array.unsafe_set arr i k); arr let fold h init f = @@ -132,8 +132,8 @@ let fold h init f = in let d = h.data in let accu = ref init in - for i = 0 to Array.length d - 1 do - accu := do_bucket (Array.unsafe_get d i) !accu + for i = 0 to Stdlib.Array.length d - 1 do + accu := do_bucket (Stdlib.Array.unsafe_get d i) !accu done; !accu diff --git a/jscomp/ext/ordered_hash_map_local_ident.mli b/jscomp/melstd/ordered_hash_map_local_ident.mli similarity index 100% rename from jscomp/ext/ordered_hash_map_local_ident.mli rename to jscomp/melstd/ordered_hash_map_local_ident.mli diff --git a/jscomp/ext/ext_path.ml b/jscomp/melstd/path.ml similarity index 80% rename from jscomp/ext/ext_path.ml rename to jscomp/melstd/path.ml index 52662f10e4..4abff7fb48 100644 --- a/jscomp/ext/ext_path.ml +++ b/jscomp/melstd/path.ml @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +module Filename = Stdlib.Filename + let cwd = lazy (Sys.getcwd ()) let path_sep = if Sys.win32 then ';' else ':' @@ -52,27 +54,27 @@ let node_relative_path = let split_by_sep_per_os : string -> string list = if Sys.win32 || Sys.cygwin then fun x -> (* on Windows, we can still accept -mel-package-output lib/js *) - Ext_string.split_by (function '/' | '\\' -> true | _ -> false) x - else fun x -> Ext_string.split x '/' + String.split_by (function '/' | '\\' -> true | _ -> false) x + else fun x -> String.split x '/' in let rec go (dir1 : string list) (dir2 : string list) = match (dir1, dir2) with | "." :: xs, ys -> go xs ys | xs, "." :: ys -> go xs ys | x :: xs, y :: ys when x = y -> go xs ys - | _, _ -> List.map (Fun.const Filename.parent_dir_name) dir2 @ dir1 + | _, _ -> Stdlib.List.map (Fun.const Filename.parent_dir_name) dir2 @ dir1 in fun ~from to_ -> let to_ = split_by_sep_per_os to_ in let from = split_by_sep_per_os from in match go to_ from with - | ".." :: _ as ys -> String.concat node_sep ys - | ys -> String.concat node_sep (Filename.current_dir_name :: ys) + | ".." :: _ as ys -> Stdlib.String.concat node_sep ys + | ys -> Stdlib.String.concat node_sep (Filename.current_dir_name :: ys) let node_rebase_file = let node_concat ~dir base = let buf = - Buffer.create String.(length dir + length node_sep + length base) + Buffer.create Stdlib.String.(length dir + length node_sep + length base) in Buffer.add_string buf dir; Buffer.add_string buf node_sep; @@ -88,17 +90,19 @@ let node_rebase_file = let concat = let strip_trailing_slashes p = - let len = String.length p in - if String.unsafe_get p (len - 1) == '/' && len > 1 then ( + let len = Stdlib.String.length p in + if Stdlib.String.unsafe_get p (len - 1) == '/' && len > 1 then ( let idx = ref 0 in - while String.unsafe_get p (len - 1 - !idx) == '/' && len - 1 - !idx > 0 do + while + Stdlib.String.unsafe_get p (len - 1 - !idx) == '/' && len - 1 - !idx > 0 + do incr idx done; Bytes.(unsafe_to_string (sub (unsafe_of_string p) 0 (len - !idx)))) else p in fun dirname filename -> - if String.length filename = 0 then dirname + if Stdlib.String.length filename = 0 then dirname else if strip_trailing_slashes filename = Filename.current_dir_name then dirname else if strip_trailing_slashes dirname = Filename.current_dir_name then @@ -137,7 +141,7 @@ let split_aux p = if dir = p then (dir, acc) else let new_path = Filename.basename p in - if String.equal new_path Filename.dir_sep then go dir acc + if Stdlib.String.equal new_path Filename.dir_sep then go dir acc (* We could do more path simplification here leave to [rel_normalized_absolute_path] *) @@ -159,25 +163,25 @@ let rel_normalized_absolute_path ~from to_ = let rec go xss yss = match (xss, yss) with | x :: xs, y :: ys -> - if String.equal x y then go xs ys + if Stdlib.String.equal x y then go xs ys else if x = curd then go xs yss else if y = curd then go xss ys else - let start = List.fold_left merge_parent_segment pard xs in - List.fold_left (fun acc v -> acc // v) start yss - | [], [] -> String.empty - | [], y :: ys -> List.fold_left (fun acc x -> acc // x) y ys + let start = Stdlib.List.fold_left merge_parent_segment pard xs in + Stdlib.List.fold_left (fun acc v -> acc // v) start yss + | [], [] -> Stdlib.String.empty + | [], y :: ys -> Stdlib.List.fold_left (fun acc x -> acc // x) y ys | x :: xs, [] -> let start = if x = curd then "" else pard in - List.fold_left merge_parent_segment start xs + Stdlib.List.fold_left merge_parent_segment start xs in let v = go paths1 paths2 in - if String.length v = 0 then Filename.current_dir_name + if Stdlib.String.length v = 0 then Filename.current_dir_name else if v = curd || v = pard - || String.starts_with v ~prefix:(curd ^ Filename.dir_sep) - || String.starts_with v ~prefix:(pard ^ Filename.dir_sep) + || Stdlib.String.starts_with v ~prefix:(curd ^ Filename.dir_sep) + || Stdlib.String.starts_with v ~prefix:(pard ^ Filename.dir_sep) then v else if Filename.is_relative from then (curd ^ Filename.dir_sep) ^ v else v @@ -209,8 +213,9 @@ let normalize_absolute_path x = match paths with | [] -> acc | x :: xs -> - if String.equal x curd then normalize_list acc xs - else if String.equal x pard then normalize_list (drop_if_exist acc) xs + if Stdlib.String.equal x curd then normalize_list acc xs + else if Stdlib.String.equal x pard then + normalize_list (drop_if_exist acc) xs else normalize_list (x :: acc) xs in let root, paths = split_aux x in diff --git a/jscomp/ext/ext_path.mli b/jscomp/melstd/path.mli similarity index 100% rename from jscomp/ext/ext_path.mli rename to jscomp/melstd/path.mli diff --git a/jscomp/melstd/polyvariant.ml b/jscomp/melstd/polyvariant.ml new file mode 100644 index 0000000000..37200977f8 --- /dev/null +++ b/jscomp/melstd/polyvariant.ml @@ -0,0 +1,25 @@ +(* Copyright (C) 2023- Authors of Melange + * + * 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 + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +module Hash_set = Hash_set_poly diff --git a/jscomp/ext/ext_pp.ml b/jscomp/melstd/pp.ml similarity index 95% rename from jscomp/ext/ext_pp.ml rename to jscomp/melstd/pp.ml index e9c7f37a98..d158498cda 100644 --- a/jscomp/ext/ext_pp.ml +++ b/jscomp/melstd/pp.ml @@ -27,7 +27,7 @@ module L = struct let indent_str = " " end -let indent_length = String.length L.indent_str +let indent_length = Stdlib.String.length L.indent_str type kind = Channel of out_channel | Buffer of Buffer.t @@ -45,7 +45,7 @@ let output_string t s = | Channel chan -> output_string chan s | Buffer buf -> Buffer.add_string buf s); let new_line, new_column = - String.fold_left + Stdlib.String.fold_left (fun (line, column) char -> match char with '\n' -> (line + 1, 0) | _c -> (line, column + 1)) (t.line, t.column) s @@ -84,9 +84,9 @@ let from_buffer buf = let string = let ends_with_char s c = - match String.length s with + match Stdlib.String.length s with | 0 -> false - | len -> String.unsafe_get s (len - 1) = c + | len -> Stdlib.String.unsafe_get s (len - 1) = c in fun t s -> output_string t s; @@ -116,7 +116,7 @@ let force_newline t = t.last_new_line <- true let space t = output_string t L.space -let nspace t n = output_string t (String.make n ' ') +let nspace t n = output_string t (Stdlib.String.make n ' ') let group t i action = if i = 0 then action () diff --git a/jscomp/ext/ext_pp.mli b/jscomp/melstd/pp.mli similarity index 100% rename from jscomp/ext/ext_pp.mli rename to jscomp/melstd/pp.mli diff --git a/jscomp/ext/ext_pp_scope.ml b/jscomp/melstd/pp_scope.ml similarity index 92% rename from jscomp/ext/ext_pp_scope.ml rename to jscomp/melstd/pp_scope.ml index f1f8798f66..f21f1d0970 100644 --- a/jscomp/ext/ext_pp_scope.ml +++ b/jscomp/melstd/pp_scope.ml @@ -82,25 +82,25 @@ let add_ident ~mangled:name (stamp : int) (cxt : t) : int * t = *) let str_of_ident (cxt : t) (id : Ident.t) : string * t = - if Ext_ident.is_js id then (* reserved by compiler *) + if Mel_ident.is_js id then (* reserved by compiler *) (Ident.name id, cxt) else let id_name = Ident.name id in - let name = Ext_ident.convert id_name in - let i, new_cxt = add_ident ~mangled:name (Ext_ident.stamp id) cxt in + let name = Mel_ident.convert id_name in + let i, new_cxt = add_ident ~mangled:name (Mel_ident.stamp id) cxt in ((if i == 0 then name else Printf.sprintf "%s$%d" name i), new_cxt) let ident (cxt : t) f (id : Ident.t) : t = let str, cxt = str_of_ident cxt id in - Ext_pp.string f str; + Pp.string f str; cxt let merge (cxt : t) (set : Set_ident.t) = Set_ident.fold set cxt (fun ident acc -> snd (add_ident - ~mangled:(Ext_ident.convert (Ident.name ident)) - (Ext_ident.stamp ident) acc)) + ~mangled:(Mel_ident.convert (Ident.name ident)) + (Mel_ident.stamp ident) acc)) (* Assume that all idents are already in [scope] so both [param/0] and [param/1] are in idents, we don't need @@ -109,7 +109,7 @@ let merge (cxt : t) (set : Set_ident.t) = let sub_scope (scope : t) (idents : Set_ident.t) : t = Set_ident.fold idents empty (fun id acc -> let name = Ident.name id in - let mangled = Ext_ident.convert name in + let mangled = Mel_ident.convert name in match Map_string.find_exn scope mangled with | exception Not_found -> assert false | imap -> diff --git a/jscomp/ext/ext_pp_scope.mli b/jscomp/melstd/pp_scope.mli similarity index 97% rename from jscomp/ext/ext_pp_scope.mli rename to jscomp/melstd/pp_scope.mli index 797ef87ffe..58b3c278d0 100644 --- a/jscomp/ext/ext_pp_scope.mli +++ b/jscomp/melstd/pp_scope.mli @@ -36,4 +36,4 @@ val print : Format.formatter -> t -> unit val sub_scope : t -> Set_ident.t -> t val merge : t -> Set_ident.t -> t val str_of_ident : t -> Ident.t -> string * t -val ident : t -> Ext_pp.t -> Ident.t -> t +val ident : t -> Pp.t -> Ident.t -> t diff --git a/jscomp/ext/ext_scc.ml b/jscomp/melstd/scc.ml similarity index 98% rename from jscomp/ext/ext_scc.ml rename to jscomp/melstd/scc.ml index bb830c2b09..9969b50785 100644 --- a/jscomp/ext/ext_scc.ml +++ b/jscomp/melstd/scc.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,14 +17,16 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Stdlib + type node = Vec_int.t -(** +(** [int] as data for this algorithm Pros: 1. Easy to eoncode algorithm (especially given that the capacity of node is known) @@ -32,7 +34,7 @@ type node = Vec_int.t 3. Node comparison semantics is clear 4. Easy to print output Cons: - 1. post processing input data + 1. post processing input data *) let min_int (x : int) y = if x < y then x else y diff --git a/jscomp/ext/ext_scc.mli b/jscomp/melstd/scc.mli similarity index 100% rename from jscomp/ext/ext_scc.mli rename to jscomp/melstd/scc.mli diff --git a/jscomp/ext/set.cppo.ml b/jscomp/melstd/set.cppo.ml similarity index 96% rename from jscomp/ext/set.cppo.ml rename to jscomp/melstd/set.cppo.ml index 86ee3f3104..0c5bed1a84 100644 --- a/jscomp/ext/set.cppo.ml +++ b/jscomp/melstd/set.cppo.ml @@ -25,16 +25,16 @@ #if defined TYPE_STRING type elt = string -let compare_elt = String.compare +let compare_elt = Stdlib.String.compare let [@inline] eq_elt (x : elt) y = x = y let print_elt = Format.pp_print_string #elif defined TYPE_IDENT type elt = Ident.t let compare_elt (x : elt) (y : elt) = - let a = Int.compare (Ext_ident.stamp x) (Ext_ident.stamp y) in + let a = Int.compare (Ident0.stamp x) (Ident0.stamp y) in if a <> 0 then a else - let b = String.compare (Ident.name x) (Ident.name y) in + let b = Stdlib.String.compare (Ident.name x) (Ident.name y) in if b <> 0 then b else Int.compare (Ident.scope x) (Ident.scope y) let [@inline] eq_elt (x : elt) y = Ident.same x y @@ -222,8 +222,8 @@ let of_list l = | [x0; x1; x2; x3] -> add (add (add (singleton x0) x1 ) x2 ) x3 | [x0; x1; x2; x3; x4] -> add (add (add (add (singleton x0) x1) x2 ) x3 ) x4 | _ -> - let arrs = Array.of_list l in - Array.sort compare_elt arrs ; + let arrs = Stdlib.Array.of_list l in + Stdlib.Array.sort compare_elt arrs ; of_sorted_array arrs diff --git a/jscomp/ext/set_gen.ml b/jscomp/melstd/set_gen.ml similarity index 96% rename from jscomp/ext/set_gen.ml rename to jscomp/melstd/set_gen.ml index a3548ee82c..6b6b669a6b 100644 --- a/jscomp/ext/set_gen.ml +++ b/jscomp/melstd/set_gen.ml @@ -258,26 +258,26 @@ let of_sorted_array l = let rec sub start n l = if n = 0 then empty else if n = 1 then - let x0 = Array.unsafe_get l start in + let x0 = Stdlib.Array.unsafe_get l start in singleton x0 else if n = 2 then - let x0 = Array.unsafe_get l start in - let x1 = Array.unsafe_get l (start + 1) in + let x0 = Stdlib.Array.unsafe_get l start in + let x1 = Stdlib.Array.unsafe_get l (start + 1) in unsafe_node x1 (singleton x0) empty 2 else if n = 3 then - let x0 = Array.unsafe_get l start in - let x1 = Array.unsafe_get l (start + 1) in - let x2 = Array.unsafe_get l (start + 2) in + let x0 = Stdlib.Array.unsafe_get l start in + let x1 = Stdlib.Array.unsafe_get l (start + 1) in + let x2 = Stdlib.Array.unsafe_get l (start + 2) in unsafe_node x1 (singleton x0) (singleton x2) 2 else let nl = n / 2 in let left = sub start nl l in let mid = start + nl in - let v = Array.unsafe_get l mid in + let v = Stdlib.Array.unsafe_get l mid in let right = sub (mid + 1) (n - nl - 1) l in unsafe_node v left right (calc_height (height left) (height right)) in - sub 0 (Array.length l) l + sub 0 (Stdlib.Array.length l) l let is_ordered ~cmp tree = let rec is_ordered_min_max tree = diff --git a/jscomp/ext/set_gen.mli b/jscomp/melstd/set_gen.mli similarity index 100% rename from jscomp/ext/set_gen.mli rename to jscomp/melstd/set_gen.mli diff --git a/jscomp/ext/set_ident.mli b/jscomp/melstd/set_ident.mli similarity index 99% rename from jscomp/ext/set_ident.mli rename to jscomp/melstd/set_ident.mli index 49638c9f46..0290e87140 100644 --- a/jscomp/ext/set_ident.mli +++ b/jscomp/melstd/set_ident.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,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. *) diff --git a/jscomp/ext/set_int.mli b/jscomp/melstd/set_int.mli similarity index 100% rename from jscomp/ext/set_int.mli rename to jscomp/melstd/set_int.mli diff --git a/jscomp/ext/set_string.mli b/jscomp/melstd/set_string.mli similarity index 100% rename from jscomp/ext/set_string.mli rename to jscomp/melstd/set_string.mli diff --git a/jscomp/ext/ext_string.ml b/jscomp/melstd/string.ml similarity index 73% rename from jscomp/ext/ext_string.ml rename to jscomp/melstd/string.ml index a1b7c820d4..4aa9b1d454 100644 --- a/jscomp/ext/ext_string.ml +++ b/jscomp/melstd/string.ml @@ -22,19 +22,22 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(* - {[ split " test_unsafe_obj_ffi_ppx.cmi" ~keep_empty:false ' ']} -*) +include StdLabels.String +module Map = Map_string +module Set = Set_string +module Hash_set = Hash_set_string + +(* {[ split " test_unsafe_obj_ffi_ppx.cmi" ~keep_empty:false ' ']} *) let split_by ?(keep_empty = false) is_delim str = - let len = String.length str in + let len = length str in let rec loop acc last_pos pos = if pos = -1 then if last_pos = 0 && not keep_empty then acc - else String.sub str 0 last_pos :: acc - else if is_delim str.[pos] then + else sub str ~pos:0 ~len:last_pos :: acc + else if is_delim (get str pos) then let new_len = last_pos - pos - 1 in if new_len <> 0 || keep_empty then - let v = String.sub str (pos + 1) new_len in + let v = sub str ~pos:(pos + 1) ~len:new_len in loop (v :: acc) pos (pos - 1) else loop acc pos (pos - 1) else loop acc last_pos (pos - 1) @@ -51,28 +54,26 @@ let for_all_from = user can provide bad input range *) let rec unsafe_for_all_range s ~start ~finish p = start > finish - || p (String.unsafe_get s start) + || p (unsafe_get s start) && unsafe_for_all_range s ~start:(start + 1) ~finish p in fun s start p -> - let len = String.length s in - if start < 0 then invalid_arg "Ext_string.for_all_from" + let len = length s in + if start < 0 then invalid_arg "String.for_all_from" else unsafe_for_all_range s ~start ~finish:(len - 1) p let unsafe_is_sub ~sub i s j ~len = let rec check k = if k = len then true - else - String.unsafe_get sub (i + k) = String.unsafe_get s (j + k) - && check (k + 1) + else unsafe_get sub (i + k) = unsafe_get s (j + k) && check (k + 1) in - j + len <= String.length s && check 0 + j + len <= length s && check 0 let rfind = let exception Local_exit in fun ~sub s -> - let n = String.length sub in - let i = ref (String.length s - n) in + let n = length sub in + let i = ref (length s - n) in try while !i >= 0 do if unsafe_is_sub ~sub 0 s !i ~len:n then raise_notrace Local_exit; @@ -82,14 +83,11 @@ let rfind = with Local_exit -> !i let tail_from s x = - let len = String.length s in - if x > len then - invalid_arg ("Ext_string.tail_from " ^ s ^ " : " ^ string_of_int x) - else String.sub s x (len - x) + let len = length s in + if x > len then invalid_arg ("String.tail_from " ^ s ^ " : " ^ string_of_int x) + else sub s ~pos:x ~len:(len - x) let rec rindex_rec s i c = - if i < 0 then i - else if String.unsafe_get s i = c then i - else rindex_rec s (i - 1) c + if i < 0 then i else if unsafe_get s i = c then i else rindex_rec s (i - 1) c -let rindex_neg s c = rindex_rec s (String.length s - 1) c +let rindex_neg s c = rindex_rec s (length s - 1) c diff --git a/jscomp/ext/ext_string.mli b/jscomp/melstd/string.mli similarity index 90% rename from jscomp/ext/ext_string.mli rename to jscomp/melstd/string.mli index 93fd780c05..411da929ca 100644 --- a/jscomp/ext/ext_string.mli +++ b/jscomp/melstd/string.mli @@ -25,6 +25,14 @@ (** Extension to the standard library [String] module, fixed some bugs like avoiding locale sensitivity *) +include module type of struct + include StdLabels.String +end + +module Map : Map_gen.S with type key = string +module Set : Set_gen.S with type elt = string +module Hash_set : Hash_set_gen.S with type key = string + val split_by : ?keep_empty:bool -> (char -> bool) -> string -> string list (** default is false *) diff --git a/jscomp/ext/vec.cppo.ml b/jscomp/melstd/vec.cppo.ml similarity index 77% rename from jscomp/ext/vec.cppo.ml rename to jscomp/melstd/vec.cppo.ml index 147c85b8e1..6efdd5643c 100644 --- a/jscomp/ext/vec.cppo.ml +++ b/jscomp/melstd/vec.cppo.ml @@ -22,7 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - let [@inline] min (x :int) y = if x < y then x else y #if defined TYPE_FUNCTOR @@ -37,7 +36,7 @@ module Make ( Resize : Vec_gen.ResizeType) = struct type elt = int let null = 0 (* can be optimized *) -let unsafe_blit = Array.blit +let unsafe_blit = Stdlib.Array.blit #else [%error "unknown type"] #endif @@ -53,7 +52,7 @@ let length d = d.len let compact d = let d_arr = d.arr in - if d.len <> Array.length d_arr then + if d.len <> Stdlib.Array.length d_arr then begin let newarr = unsafe_sub d_arr 0 d.len in d.arr <- newarr @@ -83,14 +82,13 @@ let reset d = *) let to_list d = let rec loop (d_arr : elt array) idx accum = - if idx < 0 then accum else loop d_arr (idx - 1) (Array.unsafe_get d_arr idx :: accum) + if idx < 0 then accum else loop d_arr (idx - 1) (Stdlib.Array.unsafe_get d_arr idx :: accum) in loop d.arr (d.len - 1) [] - let of_list lst = - let arr = Array.of_list lst in - { arr ; len = Array.length arr} + let arr = Stdlib.Array.of_list lst in + { arr ; len = Stdlib.Array.length arr} let to_array d = @@ -98,17 +96,17 @@ let to_array d = let of_array src = { - len = Array.length src; - arr = Array.copy src; - (* okay to call {!Array.copy}*) + len = Stdlib.Array.length src; + arr = Stdlib.Array.copy src; + (* okay to call {!Stdlib.Array.copy}*) } let of_sub_array arr off len = { len = len ; - arr = Array.sub arr off len + arr = Stdlib.Array.sub arr off len } let unsafe_internal_array v = v.arr -(* we can not call {!Array.copy} *) +(* we can not call {!Stdlib.Array.copy} *) let copy src = let len = src.len in { @@ -118,12 +116,12 @@ let copy src = (* FIXME *) let reverse_in_place src = - Ext_array.reverse_range src.arr 0 src.len + Array.reverse_range src.arr 0 src.len -(* {!Array.sub} is not enough for error checking, it +(* {!Stdlib.Array.sub} is not enough for error checking, it may contain some garbage *) let sub (src : t) start len = @@ -136,13 +134,13 @@ let sub (src : t) start len = let iter d f = let arr = d.arr in for i = 0 to d.len - 1 do - f (Array.unsafe_get arr i) + f (Stdlib.Array.unsafe_get arr i) done let iteri d f = let arr = d.arr in for i = 0 to d.len - 1 do - f i (Array.unsafe_get arr i) + f i (Stdlib.Array.unsafe_get arr i) done let iter_range d ~from ~to_ f = @@ -150,7 +148,7 @@ let iter_range d ~from ~to_ f = else let d_arr = d.arr in for i = from to to_ do - f (Array.unsafe_get d_arr i) + f (Stdlib.Array.unsafe_get d_arr i) done let iteri_range d ~from ~to_ f = @@ -158,7 +156,7 @@ let iteri_range d ~from ~to_ f = else let d_arr = d.arr in for i = from to to_ do - f i (Array.unsafe_get d_arr i) + f i (Stdlib.Array.unsafe_get d_arr i) done let map_into_array f src = @@ -166,10 +164,10 @@ let map_into_array f src = let src_arr = src.arr in if src_len = 0 then [||] else - let first_one = f (Array.unsafe_get src_arr 0) in - let arr = Array.make src_len first_one in + let first_one = f (Stdlib.Array.unsafe_get src_arr 0) in + let arr = Stdlib.Array.make src_len first_one in for i = 1 to src_len - 1 do - Array.unsafe_set arr i (f (Array.unsafe_get src_arr i)) + Stdlib.Array.unsafe_set arr i (f (Stdlib.Array.unsafe_get src_arr i)) done; arr let map_into_list f src = @@ -179,7 +177,7 @@ let map_into_list f src = else let acc = ref [] in for i = src_len - 1 downto 0 do - acc := f (Array.unsafe_get src_arr i) :: !acc + acc := f (Stdlib.Array.unsafe_get src_arr i) :: !acc done; !acc @@ -188,9 +186,9 @@ let mapi f src = if len = 0 then { len ; arr = [| |] } else let src_arr = src.arr in - let arr = Array.make len (Array.unsafe_get src_arr 0) in + let arr = Stdlib.Array.make len (Stdlib.Array.unsafe_get src_arr 0) in for i = 1 to len - 1 do - Array.unsafe_set arr i (f i (Array.unsafe_get src_arr i)) + Stdlib.Array.unsafe_set arr i (f i (Stdlib.Array.unsafe_get src_arr i)) done; { len ; @@ -200,14 +198,14 @@ let mapi f src = let fold_left f x a = let rec loop a_len (a_arr : elt array) idx x = if idx >= a_len then x else - loop a_len a_arr (idx + 1) (f x (Array.unsafe_get a_arr idx)) + loop a_len a_arr (idx + 1) (f x (Stdlib.Array.unsafe_get a_arr idx)) in loop a.len a.arr 0 x let fold_right f a x = let rec loop (a_arr : elt array) idx x = if idx < 0 then x - else loop a_arr (idx - 1) (f (Array.unsafe_get a_arr idx) x) + else loop a_arr (idx - 1) (f (Stdlib.Array.unsafe_get a_arr idx) x) in loop a.arr (a.len - 1) x @@ -220,11 +218,11 @@ let filter f d = let d_arr = d.arr in let p = ref 0 in for i = 0 to d.len - 1 do - let x = Array.unsafe_get d_arr i in + let x = Stdlib.Array.unsafe_get d_arr i in (* TODO: can be optimized for segments blit *) if f x then begin - Array.unsafe_set new_d_arr !p x; + Stdlib.Array.unsafe_set new_d_arr !p x; incr p; end; done; @@ -236,28 +234,28 @@ let equal eq x y : bool = else let rec aux x_arr y_arr i = if i < 0 then true else - if eq (Array.unsafe_get x_arr i) (Array.unsafe_get y_arr i) then + if eq (Stdlib.Array.unsafe_get x_arr i) (Stdlib.Array.unsafe_get y_arr i) then aux x_arr y_arr (i - 1) else false in aux x.arr y.arr (x.len - 1) let get d i = if i < 0 || i >= d.len then invalid_arg "Vec.get" - else Array.unsafe_get d.arr i -let unsafe_get d i = Array.unsafe_get d.arr i + else Stdlib.Array.unsafe_get d.arr i +let unsafe_get d i = Stdlib.Array.unsafe_get d.arr i let last d = if d.len <= 0 then invalid_arg "Vec.last" - else Array.unsafe_get d.arr (d.len - 1) + else Stdlib.Array.unsafe_get d.arr (d.len - 1) -let capacity d = Array.length d.arr +let capacity d = Stdlib.Array.length d.arr -(* Attention can not use {!Array.exists} since the bound is not the same *) +(* Attention can not use {!Stdlib.Array.exists} since the bound is not the same *) let exists p d = let a = d.arr in let n = d.len in let rec loop i = if i = n then false - else if p (Array.unsafe_get a i) then true + else if p (Stdlib.Array.unsafe_get a i) then true else loop (succ i) in loop 0 @@ -276,10 +274,10 @@ let map f src = *) else let src_arr = src.arr in - let first = f (Array.unsafe_get src_arr 0 ) in - let arr = Array.make src_len first in + let first = f (Stdlib.Array.unsafe_get src_arr 0 ) in + let arr = Stdlib.Array.make src_len first in for i = 1 to src_len - 1 do - Array.unsafe_set arr i (f (Array.unsafe_get src_arr i)) + Stdlib.Array.unsafe_set arr i (f (Stdlib.Array.unsafe_get src_arr i)) done; { len = src_len; @@ -291,9 +289,9 @@ let init len f = else if len = 0 then { len = 0 ; arr = [||] } else let first = f 0 in - let arr = Array.make len first in + let arr = Stdlib.Array.make len first in for i = 1 to len - 1 do - Array.unsafe_set arr i (f i) + Stdlib.Array.unsafe_set arr i (f i) done; { @@ -308,7 +306,7 @@ let init len f = { len = 0; - arr = Array.make initsize null ; + arr = Stdlib.Array.make initsize null ; } @@ -316,17 +314,17 @@ let init len f = let reserve (d : t ) s = let d_len = d.len in let d_arr = d.arr in - if s < d_len || s < Array.length d_arr then () + if s < d_len || s < Stdlib.Array.length d_arr then () else let new_capacity = min Sys.max_array_length s in - let new_d_arr = Array.make new_capacity null in + let new_d_arr = Stdlib.Array.make new_capacity null in unsafe_blit d_arr 0 new_d_arr 0 d_len; d.arr <- new_d_arr let push (d : t) v = let d_len = d.len in let d_arr = d.arr in - let d_arr_len = Array.length d_arr in + let d_arr_len = Stdlib.Array.length d_arr in if d_arr_len = 0 then begin d.len <- 1 ; @@ -341,12 +339,12 @@ let init len f = let new_capacity = min Sys.max_array_length d_len * 2 (* [d_len] can not be zero, so [*2] will enlarge *) in - let new_d_arr = Array.make new_capacity null in + let new_d_arr = Stdlib.Array.make new_capacity null in d.arr <- new_d_arr; unsafe_blit d_arr 0 new_d_arr 0 d_len ; end; d.len <- d_len + 1; - Array.unsafe_set d.arr d_len v + Stdlib.Array.unsafe_set d.arr d_len v end (** delete element at offset [idx], will raise exception when have invalid input *) @@ -360,7 +358,7 @@ let init len f = #ifdef TYPE_INT #else ; - Array.unsafe_set arr idx null + Stdlib.Array.unsafe_set arr idx null #endif (** pop the last element, a specialized version of [delete] *) @@ -371,19 +369,19 @@ let init len f = #ifdef TYPE_INT #else ; - Array.unsafe_set d.arr idx null + Stdlib.Array.unsafe_set d.arr idx null #endif (** pop and return the last element *) let get_last_and_pop (d : t) = let idx = d.len - 1 in if idx < 0 then invalid_arg "Vec.get_last_and_pop"; - let last = Array.unsafe_get d.arr idx in + let last = Stdlib.Array.unsafe_get d.arr idx in d.len <- idx #ifdef TYPE_INT #else ; - Array.unsafe_set d.arr idx null + Stdlib.Array.unsafe_set d.arr idx null #endif ; last @@ -399,7 +397,7 @@ let init len f = #else ; for i = d_len - len to d_len - 1 do - Array.unsafe_set arr i null + Stdlib.Array.unsafe_set arr i null done #endif @@ -414,7 +412,7 @@ let init len f = #ifdef TYPE_INT #else for i = d_len - len to d_len - 1 do - Array.unsafe_set arr i null + Stdlib.Array.unsafe_set arr i null done; #endif {len = len ; arr = value} @@ -426,7 +424,7 @@ let init len f = #ifdef TYPE_INT #else for i = 0 to d.len - 1 do - Array.unsafe_set d.arr i null + Stdlib.Array.unsafe_set d.arr i null done; #endif d.len <- 0 @@ -438,12 +436,12 @@ let init len f = let d_len = d.len in let p = ref 0 in for i = 0 to d_len - 1 do - let x = Array.unsafe_get d_arr i in + let x = Stdlib.Array.unsafe_get d_arr i in if f x then begin let curr_p = !p in (if curr_p <> i then - Array.unsafe_set d_arr curr_p x) ; + Stdlib.Array.unsafe_set d_arr curr_p x) ; incr p end done ; @@ -461,12 +459,12 @@ let init len f = let d_len = d.len in let p = ref start in for i = start to d_len - 1 do - let x = Array.unsafe_get d_arr i in + let x = Stdlib.Array.unsafe_get d_arr i in if f x then begin let curr_p = !p in (if curr_p <> i then - Array.unsafe_set d_arr curr_p x) ; + Stdlib.Array.unsafe_set d_arr curr_p x) ; incr p end done ; @@ -485,12 +483,12 @@ let init len f = let d_len = d.len in let acc = ref acc in for i = 0 to d_len - 1 do - let x = Array.unsafe_get d_arr i in + let x = Stdlib.Array.unsafe_get d_arr i in if f x then begin let curr_p = !p in (if curr_p <> i then - Array.unsafe_set d_arr curr_p x) ; + Stdlib.Array.unsafe_set d_arr curr_p x) ; incr p end else @@ -509,7 +507,7 @@ let init len f = let mem = let rec unsafe_mem_aux arr i (key : int) bound = if i <= bound then - if Array.unsafe_get arr i = (key : int) then true + if Stdlib.Array.unsafe_get arr i = (key : int) then true else unsafe_mem_aux arr (i + 1) key bound else false in diff --git a/jscomp/ext/vec.mli b/jscomp/melstd/vec.mli similarity index 100% rename from jscomp/ext/vec.mli rename to jscomp/melstd/vec.mli diff --git a/jscomp/ext/vec_gen.ml b/jscomp/melstd/vec_gen.ml similarity index 100% rename from jscomp/ext/vec_gen.ml rename to jscomp/melstd/vec_gen.ml diff --git a/jscomp/ext/vec_int.mli b/jscomp/melstd/vec_int.mli similarity index 100% rename from jscomp/ext/vec_int.mli rename to jscomp/melstd/vec_int.mli diff --git a/ppx/ast_external_mk.ml b/ppx/ast_external_mk.ml index 9343baae40..dc0caa820a 100644 --- a/ppx/ast_external_mk.ml +++ b/ppx/ast_external_mk.ml @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Ppxlib +open Import open Ast_helper let local_external_apply loc ?(pval_attributes = []) ~(pval_prim : string list) @@ -61,7 +61,7 @@ let local_external_apply loc ?(pval_attributes = []) ~(pval_prim : string list) pexp_loc_stack = [ loc ]; } : Parsetree.expression) - (List.map (fun x -> (Asttypes.Nolabel, x)) args) + (List.map ~f:(fun x -> (Asttypes.Nolabel, x)) args) ~loc ) let local_external_obj loc ?(pval_attributes = []) ~pval_prim ~pval_type @@ -99,7 +99,7 @@ let local_external_obj loc ?(pval_attributes = []) ~pval_prim ~pval_type pexp_loc_stack = [ loc ]; } : Parsetree.expression) - (List.map (fun (l, a) -> (Asttypes.Labelled l, a)) args) + (List.map ~f:(fun (l, a) -> (Asttypes.Labelled l, a)) args) ~loc ) let local_extern_cont_to_obj loc ?(pval_attributes = []) ~pval_prim ~pval_type @@ -148,30 +148,30 @@ type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list *) let from_labels ~loc arity labels : Parsetree.core_type = let tyvars = - List.init arity (fun i -> Typ.var ~loc ("a" ^ string_of_int i)) + List.init ~len:arity ~f:(fun i -> Typ.var ~loc ("a" ^ string_of_int i)) in let result_type = Ast_comb.to_js_type ~loc (Typ.object_ ~loc - (List.map2 (fun x y -> Of.tag x y) labels tyvars) + (List.map2 ~f:(fun x y -> Of.tag x y) labels tyvars) Closed) in List.fold_right2 - (fun label (* {loc ; txt = label }*) tyvar acc -> + ~f:(fun label (* {loc ; txt = label }*) tyvar acc -> Typ.arrow ~loc:label.loc (Labelled label.txt) tyvar acc) - labels tyvars result_type + labels tyvars ~init:result_type let pval_prim_of_labels (labels : string Asttypes.loc list) = let arg_kinds = List.fold_right - (fun p arg_kinds -> + ~f:(fun p arg_kinds -> let obj_arg_label = Melange_ffi.External_arg_spec.obj_label (Melange_ffi.Lam_methname.translate p.txt) in { Melange_ffi.External_arg_spec.obj_arg_type = Nothing; obj_arg_label } :: arg_kinds) - labels [] + labels ~init:[] in Melange_ffi.External_ffi_types.ffi_obj_as_prims arg_kinds @@ -179,7 +179,7 @@ let pval_prim_of_option_labels (labels : (bool * string Asttypes.loc) list) (ends_with_unit : bool) = let arg_kinds = List.fold_right - (fun (is_option, p) arg_kinds -> + ~f:(fun (is_option, p) arg_kinds -> let label_name = Melange_ffi.Lam_methname.translate p.txt in let obj_arg_label = if is_option then @@ -189,9 +189,10 @@ let pval_prim_of_option_labels (labels : (bool * string Asttypes.loc) list) { Melange_ffi.External_arg_spec.obj_arg_type = Nothing; obj_arg_label } :: arg_kinds) labels - (if ends_with_unit then - [ Melange_ffi.External_arg_spec.empty_kind Extern_unit ] - else []) + ~init: + (if ends_with_unit then + [ Melange_ffi.External_arg_spec.empty_kind Extern_unit ] + else []) in Melange_ffi.External_ffi_types.ffi_obj_as_prims arg_kinds @@ -199,12 +200,12 @@ let record_as_js_object loc (label_exprs : label_exprs) : Parsetree.expression_desc = let labels, args, arity = List.fold_right - (fun ({ txt; loc }, e) (labels, args, i) -> + ~f:(fun ({ txt; loc }, e) (labels, args, i) -> match txt with | Lident x -> ({ Asttypes.loc; txt = x } :: labels, (x, e) :: args, i + 1) | Ldot _ | Lapply _ -> Location.raise_errorf ~loc "invalid js label ") - label_exprs ([], [], 0) + label_exprs ~init:([], [], 0) in local_external_obj loc ~pval_prim:(pval_prim_of_labels labels) diff --git a/ppx/ast_external_mk.mli b/ppx/ast_external_mk.mli index 7520f4bdfc..183160adfc 100644 --- a/ppx/ast_external_mk.mli +++ b/ppx/ast_external_mk.mli @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Ppxlib +open Import val local_external_apply : Location.t -> diff --git a/ppx/ast_payload.ml b/ppx/ast_payload.ml index 234c8c8b9c..1fbec14766 100644 --- a/ppx/ast_payload.ml +++ b/ppx/ast_payload.ml @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Ppxlib +open Import type t = Parsetree.payload @@ -93,7 +93,7 @@ let ident_or_record_as_config (x : t) : try Ok (List.map - (fun u -> + ~f:(fun u -> match u with | ( { txt = Lident name; loc }, { @@ -140,7 +140,7 @@ let assert_strings loc (x : t) : string list = ] -> ( try List.map - (fun e -> + ~f:(fun e -> match (e : Parsetree.expression) with | { pexp_desc = Pexp_constant (Pconst_string (name, _, _)); _ } -> name @@ -164,7 +164,7 @@ let assert_strings loc (x : t) : string list = let table_dispatch table (action : action) = match action with | { txt = name; _ }, y -> ( - match Map_string.find_exn table name with + match String.Map.find_exn table name with | fn -> Ok (fn y) | exception _ -> Error ("Unused attribute: " ^ name) diff --git a/ppx/ast_payload.mli b/ppx/ast_payload.mli index 56c0b825e9..7450de6b94 100644 --- a/ppx/ast_payload.mli +++ b/ppx/ast_payload.mli @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Ppxlib +open Import type t = Parsetree.payload type action = string Asttypes.loc * Parsetree.expression option @@ -31,7 +31,7 @@ val ident_or_record_as_config : Parsetree.payload -> (action list, string) result val table_dispatch : - (Parsetree.expression option -> 'a) Map_string.t -> + (Parsetree.expression option -> 'a) String.Map.t -> action -> ('a, string) result (** A utility module used when destructuring parsetree attributes, used for diff --git a/ppx/ast_polyvar.ml b/ppx/ast_polyvar.ml index 7ca832e8c7..c2d80b6582 100644 --- a/ppx/ast_polyvar.ml +++ b/ppx/ast_polyvar.ml @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Ppxlib +open Import (** Note this is okay with enums, for variants, the underlying representation may change due to @@ -33,14 +33,14 @@ let map_constructor_declarations_into_ints let mark = ref `nothing in let _, acc = List.fold_left - (fun (i, acc) rtag -> + ~f:(fun (i, acc) rtag -> let attrs = rtag.pcd_attributes in match Ast_attributes.iter_process_bs_int_as attrs with | Some j -> if j <> i then if i = 0 then mark := `offset j else mark := `complex; (j + 1, j :: acc) | None -> (i + 1, i :: acc)) - (0, []) row_fields + ~init:(0, []) row_fields in match !mark with | `nothing -> `Offset 0 @@ -49,7 +49,7 @@ let map_constructor_declarations_into_ints let is_enum row_fields = List.for_all - (fun (x : Parsetree.row_field) -> + ~f:(fun (x : Parsetree.row_field) -> match x.prf_desc with Rtag (_label, true, []) -> true | _ -> false) row_fields @@ -63,7 +63,7 @@ let is_enum_polyvar (ty : Parsetree.type_declaration) = let is_enum_constructors (constructors : Parsetree.constructor_declaration list) = List.for_all - (fun (x : Parsetree.constructor_declaration) -> + ~f:(fun (x : Parsetree.constructor_declaration) -> match x with | { pcd_args = @@ -77,7 +77,7 @@ let is_enum_constructors (constructors : Parsetree.constructor_declaration list) let map_row_fields_into_ints ptyp_loc (row_fields : Parsetree.row_field list) = let _, acc = List.fold_left - (fun (i, acc) rtag -> + ~f:(fun (i, acc) rtag -> match rtag.prf_desc with | Rtag ({ txt; _ }, true, []) -> let i = @@ -89,7 +89,7 @@ let map_row_fields_into_ints ptyp_loc (row_fields : Parsetree.row_field list) = in (i + 1, (txt, i) :: acc) | _ -> Error.err ~loc:ptyp_loc Invalid_mel_int_type) - (0, []) row_fields + ~init:(0, []) row_fields in List.rev acc @@ -100,7 +100,7 @@ let map_row_fields_into_strings ptyp_loc (row_fields : Parsetree.row_field list) let has_bs_as = ref false in let case, result = List.fold_right - (fun tag (nullary, acc) -> + ~f:(fun tag (nullary, acc) -> match (nullary, tag.prf_desc) with | (`Nothing | `Null), Rtag ({ txt; _ }, true, []) -> let name = @@ -125,7 +125,7 @@ let map_row_fields_into_strings ptyp_loc (row_fields : Parsetree.row_field list) in (`NonNull, (txt, name) :: acc) | _ -> Error.err ~loc:ptyp_loc Invalid_mel_string_type) - row_fields (`Nothing, []) + row_fields ~init:(`Nothing, []) in match case with | `Nothing -> Error.err ~loc:ptyp_loc Invalid_mel_string_type diff --git a/ppx/ast_polyvar.mli b/ppx/ast_polyvar.mli index 0b1b309641..d33ad3b5cf 100644 --- a/ppx/ast_polyvar.mli +++ b/ppx/ast_polyvar.mli @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Ppxlib +open Import val map_constructor_declarations_into_ints : Parsetree.constructor_declaration list -> [ `Offset of int | `New of int list ] diff --git a/ppx/ast_typ_uncurry.ml b/ppx/ast_typ_uncurry.ml index 4010e57380..da6bab7000 100644 --- a/ppx/ast_typ_uncurry.ml +++ b/ppx/ast_typ_uncurry.ml @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Ppxlib +open Import type typ = Parsetree.core_type type 'a cxt = Ast_helper.loc -> Ast_traverse.map -> 'a @@ -65,15 +65,15 @@ let generate_method_type loc (mapper : Ast_traverse.map) ?alias_type method_name else let tyvars = List.mapi - (fun i x -> (x, Typ.var ~loc (method_name ^ string_of_int i))) + ~f:(fun i x -> (x, Typ.var ~loc (method_name ^ string_of_int i))) (lbl :: Ast_pat.labels_of_fun e) in match tyvars with | (label, x) :: rest -> let method_rest = List.fold_right - (fun (label, v) acc -> Typ.arrow ~loc label v acc) - rest result + ~f:(fun (label, v) acc -> Typ.arrow ~loc label v acc) + rest ~init:result in to_method_callback_type loc mapper Nolabel self_type (Typ.arrow ~loc label x method_rest) @@ -102,15 +102,15 @@ let generate_arg_type loc (mapper : Ast_traverse.map) method_name label pat body else let tyvars = List.mapi - (fun i x -> (x, Typ.var ~loc (method_name ^ string_of_int i))) + ~f:(fun i x -> (x, Typ.var ~loc (method_name ^ string_of_int i))) (label :: Ast_pat.labels_of_fun body) in match tyvars with | (label, x) :: rest -> let method_rest = List.fold_right - (fun (label, v) acc -> Typ.arrow ~loc label v acc) - rest result + ~f:(fun (label, v) acc -> Typ.arrow ~loc label v acc) + rest ~init:result in to_method_type loc mapper label x method_rest | _ -> assert false diff --git a/ppx/ast_typ_uncurry.mli b/ppx/ast_typ_uncurry.mli index 3dc7f91ffc..304654ddf8 100644 --- a/ppx/ast_typ_uncurry.mli +++ b/ppx/ast_typ_uncurry.mli @@ -22,6 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Import + (* Note that currently there is no way to consume [Js.meth_callback] so it is fine to encode it with a freedom, but we need make it better for error message. @@ -34,7 +36,6 @@ For [method_callback], the arity is never zero, so both [method] and [fn] requires (unit -> 'a) to encode arity zero *) -open Ppxlib type typ = Parsetree.core_type type 'a cxt = Ast_helper.loc -> Ast_traverse.map -> 'a diff --git a/ppx/import.ml b/ppx/import.ml new file mode 100644 index 0000000000..a07df429d7 --- /dev/null +++ b/ppx/import.ml @@ -0,0 +1,2 @@ +include Melstd +include Ppxlib diff --git a/ppx/mel_ast_invariant.ml b/ppx/mel_ast_invariant.ml index cd9efe677b..fbbf52e5d8 100644 --- a/ppx/mel_ast_invariant.ml +++ b/ppx/mel_ast_invariant.ml @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Ppxlib +open Import module Warnings = struct type t = @@ -75,8 +75,8 @@ let is_bs_attribute txt = && String.unsafe_get txt 2 = 'l' && String.unsafe_get txt 3 = '.' -let used_attributes : string Asttypes.loc Hash_set_poly.t = - Hash_set_poly.create 16 +let used_attributes : string Asttypes.loc Polyvariant.Hash_set.t = + Polyvariant.Hash_set.create 16 (* #if true *) (* let dump_attribute fmt = (fun (sloc : string Asttypes.loc) -> *) @@ -85,19 +85,19 @@ let used_attributes : string Asttypes.loc Hash_set_poly.t = (* let dump_used_attributes fmt = *) (* Format.fprintf fmt "Used attributes Listing Start:@."; *) -(* Hash_set_poly.iter used_attributes (fun attr -> dump_attribute fmt attr) ; *) +(* Polyvariant.Hash_set.iter used_attributes (fun attr -> dump_attribute fmt attr) ; *) (* Format.fprintf fmt "Used attributes Listing End:@." *) (* #endif *) (* only mark non-ghost used bs attribute *) let mark_used_mel_attribute ({ attr_name = x; _ } : Parsetree.attribute) = - if not x.loc.loc_ghost then Hash_set_poly.add used_attributes x + if not x.loc.loc_ghost then Polyvariant.Hash_set.add used_attributes x let warn_unused_attribute ({ attr_name = { txt; loc } as sloc; _ } : Parsetree.attribute) : unit = if is_bs_attribute txt && (not loc.loc_ghost) - && not (Hash_set_poly.mem used_attributes sloc) + && not (Polyvariant.Hash_set.mem used_attributes sloc) then (* #if true *) (* (*COMMENT*) *) @@ -107,7 +107,7 @@ let warn_unused_attribute warn ~loc (Unused_attribute txt) let warn_discarded_unused_attributes (attrs : Parsetree.attributes) = - if attrs <> [] then List.iter warn_unused_attribute attrs + if attrs <> [] then List.iter ~f:warn_unused_attribute attrs (* Note we only used Bs_ast_iterator here, we can reuse compiler-libs instead of rolling our own *) @@ -118,7 +118,7 @@ let emit_external_warnings : Ast_traverse.iter = method! label_declaration lbl = List.iter - (fun attr -> + ~f:(fun attr -> match attr with | { attr_name = { txt = "mel.as" | "as"; _ }; _ } -> mark_used_mel_attribute attr diff --git a/ppx/utf8_string.ml b/ppx/utf8_string.ml index b93c643139..0efbffea73 100644 --- a/ppx/utf8_string.ml +++ b/ppx/utf8_string.ml @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Ppxlib +open Import let valid_hex x = match x with '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false diff --git a/ppx/utf8_string.mli b/ppx/utf8_string.mli index 8cf985e41e..d1321dead1 100644 --- a/ppx/utf8_string.mli +++ b/ppx/utf8_string.mli @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Ppxlib +open Import module Utf8_string : sig type error = diff --git a/test/unit-tests/dune b/test/unit-tests/dune index 5cf0458d74..373c4a9c4b 100644 --- a/test/unit-tests/dune +++ b/test/unit-tests/dune @@ -2,4 +2,4 @@ (name ounit_tests) (package melange) (flags :standard -open Melange_compiler_libs) - (libraries ounit2 ext melange_compiler_libs str melange.ppx melangelib)) + (libraries ounit2 melstd melange_compiler_libs str melange.ppx melangelib)) diff --git a/test/unit-tests/ounit_array_tests.ml b/test/unit-tests/ounit_array_tests.ml index af394a604e..1985f5ce10 100644 --- a/test/unit-tests/ounit_array_tests.ml +++ b/test/unit-tests/ounit_array_tests.ml @@ -1,15 +1,17 @@ +open Melstd + let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) let ( =~ ) = OUnit.assert_equal let printer_int_array xs = - String.concat "," (List.map string_of_int @@ Array.to_list xs) + String.concat ~sep:"," (List.map ~f:string_of_int @@ Array.to_list xs) let suites = __FILE__ >::: [ ( __LOC__ >:: fun _ -> let ( =~ ) = OUnit.assert_equal ~printer:printer_int_array in - let k x y = Ext_array.of_list_map y x in + let k x y = Array.of_list_map y x in k succ [] =~ [||]; k succ [ 1 ] =~ [| 2 |]; k succ [ 1; 2; 3 ] =~ [| 2; 3; 4 |]; diff --git a/test/unit-tests/ounit_bal_tree_tests.ml b/test/unit-tests/ounit_bal_tree_tests.ml index e0f23a111c..15ba25d8dd 100644 --- a/test/unit-tests/ounit_bal_tree_tests.ml +++ b/test/unit-tests/ounit_bal_tree_tests.ml @@ -1,3 +1,5 @@ +open Melstd + let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) let ( =~ ) = OUnit.assert_equal @@ -5,7 +7,7 @@ module Set_poly = struct include Set_int let of_sorted_list xs = Array.of_list xs |> of_sorted_array - let of_array l = Array.fold_left add empty l + let of_array l = Array.fold_left ~f:add ~init:empty l end let suites = @@ -14,29 +16,29 @@ let suites = ( __LOC__ >:: fun _ -> OUnit.assert_bool __LOC__ (Set_poly.invariant - (Set_poly.of_array (Array.init 1000 (fun n -> n)))) ); + (Set_poly.of_array (Array.init 1000 ~f:(fun n -> n)))) ); ( __LOC__ >:: fun _ -> OUnit.assert_bool __LOC__ (Set_poly.invariant - (Set_poly.of_array (Array.init 1000 (fun n -> 1000 - n)))) ); + (Set_poly.of_array (Array.init 1000 ~f:(fun n -> 1000 - n)))) ); ( __LOC__ >:: fun _ -> OUnit.assert_bool __LOC__ (Set_poly.invariant - (Set_poly.of_array (Array.init 1000 (fun _ -> Random.int 1000)))) - ); + (Set_poly.of_array + (Array.init 1000 ~f:(fun _ -> Random.int 1000)))) ); ( __LOC__ >:: fun _ -> OUnit.assert_bool __LOC__ (Set_poly.invariant (Set_poly.of_sorted_list - (Array.to_list (Array.init 1000 (fun n -> n))))) ); + (Array.to_list (Array.init 1000 ~f:(fun n -> n))))) ); ( __LOC__ >:: fun _ -> - let arr = Array.init 1000 (fun n -> n) in + let arr = Array.init 1000 ~f:(fun n -> n) in let set = Set_poly.of_sorted_array arr in OUnit.assert_bool __LOC__ (Set_poly.invariant set); OUnit.assert_equal 1000 (Set_poly.cardinal set) ); ( __LOC__ >:: fun _ -> for i = 0 to 200 do - let arr = Array.init i (fun n -> n) in + let arr = Array.init i ~f:(fun n -> n) in let set = Set_poly.of_sorted_array arr in OUnit.assert_bool __LOC__ (Set_poly.invariant set); OUnit.assert_equal i (Set_poly.cardinal set) @@ -46,10 +48,12 @@ let suites = let arr_sets = Array.make 200 Set_poly.empty in for i = 0 to arr_size - 1 do let size = Random.int 1000 in - let arr = Array.init size (fun n -> n) in + let arr = Array.init size ~f:(fun n -> n) in arr_sets.(i) <- Set_poly.of_sorted_array arr done; - let large = Array.fold_left Set_poly.union Set_poly.empty arr_sets in + let large = + Array.fold_left ~f:Set_poly.union ~init:Set_poly.empty arr_sets + in OUnit.assert_bool __LOC__ (Set_poly.invariant large) ); ( __LOC__ >:: fun _ -> let arr_size = 1_00_000 in diff --git a/test/unit-tests/ounit_hash_set_tests.ml b/test/unit-tests/ounit_hash_set_tests.ml index c18401ecf1..0305667761 100644 --- a/test/unit-tests/ounit_hash_set_tests.ml +++ b/test/unit-tests/ounit_hash_set_tests.ml @@ -1,3 +1,5 @@ +open Melstd + let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) let ( =~ ) = OUnit.assert_equal @@ -119,33 +121,33 @@ let suites = __FILE__ >::: [ ( __LOC__ >:: fun _ -> - let v = Hash_set_poly.create 31 in + let v = Polyvariant.Hash_set.create 31 in for i = 0 to 1000 do - Hash_set_poly.add v i + Polyvariant.Hash_set.add v i done; - OUnit.assert_equal (Hash_set_poly.length v) 1001 ); + OUnit.assert_equal (Polyvariant.Hash_set.length v) 1001 ); ( __LOC__ >:: fun _ -> - let v = Hash_set_poly.create 31 in + let v = Polyvariant.Hash_set.create 31 in for _ = 0 to 1_0_000 do - Hash_set_poly.add v 0 + Polyvariant.Hash_set.add v 0 done; - OUnit.assert_equal (Hash_set_poly.length v) 1 ); + OUnit.assert_equal (Polyvariant.Hash_set.length v) 1 ); ( __LOC__ >:: fun _ -> - let v = Hash_set_poly.create 30 in + let v = Polyvariant.Hash_set.create 30 in for i = 0 to 2_000 do - Hash_set_poly.add v { name = "x"; stamp = i } + Polyvariant.Hash_set.add v { name = "x"; stamp = i } done; for i = 0 to 2_000 do - Hash_set_poly.add v { name = "x"; stamp = i } + Polyvariant.Hash_set.add v { name = "x"; stamp = i } done; for i = 0 to 2_000 do - assert (Hash_set_poly.mem v { name = "x"; stamp = i }) + assert (Polyvariant.Hash_set.mem v { name = "x"; stamp = i }) done; - OUnit.assert_equal (Hash_set_poly.length v) 2_001; + OUnit.assert_equal (Polyvariant.Hash_set.length v) 2_001; for i = 1990 to 3_000 do - Hash_set_poly.remove v { name = "x"; stamp = i } + Polyvariant.Hash_set.remove v { name = "x"; stamp = i } done; - OUnit.assert_equal (Hash_set_poly.length v) 1990 + OUnit.assert_equal (Polyvariant.Hash_set.length v) 1990 (* OUnit.assert_equal (Hash_set.stats v) *) (* {Hashtbl.num_bindings = 1990; num_buckets = 1024; max_bucket_length = 7; *) (* bucket_histogram = [|139; 303; 264; 178; 93; 32; 12; 3|]} *) ); @@ -188,10 +190,10 @@ let suites = if off >= len then None else let curr = Array.unsafe_get arr off in - if Hash_set_string.check_add tbl curr then aux tbl (off + 1) + if String.Hash_set.check_add tbl curr then aux tbl (off + 1) else Some curr in - aux (Hash_set_string.create len) 0 + aux (String.Hash_set.create len) 0 in let v = [| "if"; "a"; "b"; "c" |] in OUnit.assert_equal (duplicate v) None; @@ -201,14 +203,14 @@ let suites = ( __LOC__ >:: fun _ -> let of_array lst = let len = Array.length lst in - let tbl = Hash_set_string.create len in - Array.iter (Hash_set_string.add tbl) lst; + let tbl = String.Hash_set.create len in + Array.iter ~f:(String.Hash_set.add tbl) lst; tbl in let hash = of_array const_tbl in - let len = Hash_set_string.length hash in - Hash_set_string.remove hash "x"; - OUnit.assert_equal len (Hash_set_string.length hash); - Hash_set_string.remove hash "0"; - OUnit.assert_equal (len - 1) (Hash_set_string.length hash) ); + let len = String.Hash_set.length hash in + String.Hash_set.remove hash "x"; + OUnit.assert_equal len (String.Hash_set.length hash); + String.Hash_set.remove hash "0"; + OUnit.assert_equal (len - 1) (String.Hash_set.length hash) ); ] diff --git a/test/unit-tests/ounit_ident_mask_tests.ml b/test/unit-tests/ounit_ident_mask_tests.ml index 6523c1856b..590429f7ab 100644 --- a/test/unit-tests/ounit_ident_mask_tests.ml +++ b/test/unit-tests/ounit_ident_mask_tests.ml @@ -1,3 +1,5 @@ +open Melstd + let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) let ( =~ ) = OUnit.assert_equal @@ -30,10 +32,10 @@ let suites = ( __LOC__ >:: fun _ -> let len = 1000 in let idents = - Array.init len (fun i -> Ident.create_local (string_of_int i)) + Array.init len ~f:(fun i -> Ident.create_local (string_of_int i)) in let set = Hash_set_ident_mask.create 0 in - Array.iter (fun i -> Hash_set_ident_mask.add_unmask set i) idents; + Array.iter ~f:(fun i -> Hash_set_ident_mask.add_unmask set i) idents; for i = 0 to len - 2 do OUnit.assert_bool __LOC__ (not @@ Hash_set_ident_mask.mask_and_check_all_hit set idents.(i)) diff --git a/test/unit-tests/ounit_int_vec_tests.ml b/test/unit-tests/ounit_int_vec_tests.ml index 77c32e21bf..214df78fd9 100644 --- a/test/unit-tests/ounit_int_vec_tests.ml +++ b/test/unit-tests/ounit_int_vec_tests.ml @@ -1,3 +1,5 @@ +open Melstd + let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) let ( =~ ) = OUnit.assert_equal diff --git a/test/unit-tests/ounit_list_test.ml b/test/unit-tests/ounit_list_test.ml index 656319d5a7..1b7fdb122b 100644 --- a/test/unit-tests/ounit_list_test.ml +++ b/test/unit-tests/ounit_list_test.ml @@ -1,3 +1,5 @@ +open Melstd + let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) let ( =~ ) = OUnit.assert_equal @@ -11,42 +13,41 @@ let suites = >::: [ ( __LOC__ >:: fun _ -> OUnit.assert_equal - (List.concat_map (fun x -> [ x; x ]) [ 1; 2 ]) + (List.concat_map ~f:(fun x -> [ x; x ]) [ 1; 2 ]) [ 1; 1; 2; 2 ] ); ( __LOC__ >:: fun _ -> let ( =~ ) = OUnit.assert_equal ~printer:printer_int_list in - List.concat_map (fun x -> [ succ x ]) [] =~ []; - List.concat_map (fun x -> [ x; succ x ]) [ 1 ] =~ [ 1; 2 ]; - List.concat_map (fun x -> [ x; succ x ]) [ 1; 2 ] =~ [ 1; 2; 2; 3 ]; - List.concat_map (fun x -> [ x; succ x ]) [ 1; 2; 3 ] + List.concat_map ~f:(fun x -> [ succ x ]) [] =~ []; + List.concat_map ~f:(fun x -> [ x; succ x ]) [ 1 ] =~ [ 1; 2 ]; + List.concat_map ~f:(fun x -> [ x; succ x ]) [ 1; 2 ] + =~ [ 1; 2; 2; 3 ]; + List.concat_map ~f:(fun x -> [ x; succ x ]) [ 1; 2; 3 ] =~ [ 1; 2; 2; 3; 3; 4 ] ); ( __LOC__ >:: fun _ -> OUnit.assert_equal - (Ext_list.stable_group [ 1; 2; 3; 4; 3 ] ( = )) + (List.stable_group [ 1; 2; 3; 4; 3 ] ( = )) [ [ 1 ]; [ 2 ]; [ 4 ]; [ 3; 3 ] ] ); ( __LOC__ >:: fun _ -> let ( =~ ) = OUnit.assert_equal ~printer:printer_int_list in let f b _v = if b then 1 else 0 in - Ext_list.map_last [] f =~ []; - Ext_list.map_last [ 0 ] f =~ [ 1 ]; - Ext_list.map_last [ 0; 0 ] f =~ [ 0; 1 ]; - Ext_list.map_last [ 0; 0; 0 ] f =~ [ 0; 0; 1 ]; - Ext_list.map_last [ 0; 0; 0; 0 ] f =~ [ 0; 0; 0; 1 ]; - Ext_list.map_last [ 0; 0; 0; 0; 0 ] f =~ [ 0; 0; 0; 0; 1 ]; - Ext_list.map_last [ 0; 0; 0; 0; 0; 0 ] f =~ [ 0; 0; 0; 0; 0; 1 ]; - Ext_list.map_last [ 0; 0; 0; 0; 0; 0; 0 ] f - =~ [ 0; 0; 0; 0; 0; 0; 1 ] ); + List.map_last [] f =~ []; + List.map_last [ 0 ] f =~ [ 1 ]; + List.map_last [ 0; 0 ] f =~ [ 0; 1 ]; + List.map_last [ 0; 0; 0 ] f =~ [ 0; 0; 1 ]; + List.map_last [ 0; 0; 0; 0 ] f =~ [ 0; 0; 0; 1 ]; + List.map_last [ 0; 0; 0; 0; 0 ] f =~ [ 0; 0; 0; 0; 1 ]; + List.map_last [ 0; 0; 0; 0; 0; 0 ] f =~ [ 0; 0; 0; 0; 0; 1 ]; + List.map_last [ 0; 0; 0; 0; 0; 0; 0 ] f =~ [ 0; 0; 0; 0; 0; 0; 1 ] ); ( __LOC__ >:: fun _ -> OUnit.assert_equal - (List.map (fun x -> string_of_int x) [ 0; 1; 2 ] + (List.map ~f:(fun x -> string_of_int x) [ 0; 1; 2 ] @ [ "1"; "2"; "3" ]) [ "0"; "1"; "2"; "1"; "2"; "3" ] ); ( __LOC__ >:: fun _ -> - let a, b = Ext_list.split_at [ 1; 2; 3; 4; 5; 6 ] 3 in + let a, b = List.split_at [ 1; 2; 3; 4; 5; 6 ] 3 in OUnit.assert_equal (a, b) ([ 1; 2; 3 ], [ 4; 5; 6 ]); - OUnit.assert_equal (Ext_list.split_at [ 1 ] 1) ([ 1 ], []); - OUnit.assert_equal (Ext_list.split_at [ 1; 2; 3 ] 2) ([ 1; 2 ], [ 3 ]) - ); + OUnit.assert_equal (List.split_at [ 1 ] 1) ([ 1 ], []); + OUnit.assert_equal (List.split_at [ 1; 2; 3 ] 2) ([ 1; 2 ], [ 3 ]) ); ( __LOC__ >:: fun _ -> let printer (a, b) = Format.asprintf "([%a],%d)" @@ -54,20 +55,20 @@ let suites = a b in let ( =~ ) = OUnit.assert_equal ~printer in - Ext_list.split_at_last [ 1; 2; 3 ] =~ ([ 1; 2 ], 3); - Ext_list.split_at_last [ 1; 2; 3; 4; 5; 6; 7; 8 ] + List.split_at_last [ 1; 2; 3 ] =~ ([ 1; 2 ], 3); + List.split_at_last [ 1; 2; 3; 4; 5; 6; 7; 8 ] =~ ([ 1; 2; 3; 4; 5; 6; 7 ], 8); - Ext_list.split_at_last [ 1; 2; 3; 4; 5; 6; 7 ] + List.split_at_last [ 1; 2; 3; 4; 5; 6; 7 ] =~ ([ 1; 2; 3; 4; 5; 6 ], 7) ); ( __LOC__ >:: fun _ -> OUnit.assert_bool __LOC__ - (Ext_list.length_larger_than_n [ 1; 2 ] [ 1 ] 1); + (List.length_larger_than_n [ 1; 2 ] [ 1 ] 1); OUnit.assert_bool __LOC__ - (Ext_list.length_larger_than_n [ 1; 2 ] [ 1; 2 ] 0); - OUnit.assert_bool __LOC__ - (Ext_list.length_larger_than_n [ 1; 2 ] [] 2) ); + (List.length_larger_than_n [ 1; 2 ] [ 1; 2 ] 0); + OUnit.assert_bool __LOC__ (List.length_larger_than_n [ 1; 2 ] [] 2) + ); ( __LOC__ >:: fun _ -> - OUnit.assert_bool __LOC__ (Ext_list.length_ge [ 1; 2; 3 ] 3); - OUnit.assert_bool __LOC__ (Ext_list.length_ge [] 0); - OUnit.assert_bool __LOC__ (not (Ext_list.length_ge [] 1)) ); + OUnit.assert_bool __LOC__ (List.length_ge [ 1; 2; 3 ] 3); + OUnit.assert_bool __LOC__ (List.length_ge [] 0); + OUnit.assert_bool __LOC__ (not (List.length_ge [] 1)) ); ] diff --git a/test/unit-tests/ounit_map_tests.ml b/test/unit-tests/ounit_map_tests.ml index 4de4207c04..e5db9b08e8 100644 --- a/test/unit-tests/ounit_map_tests.ml +++ b/test/unit-tests/ounit_map_tests.ml @@ -1,10 +1,12 @@ +open Melstd + let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) let ( =~ ) = OUnit.assert_equal let test_sorted_strict arr = let v = Map_int.of_array arr |> Map_int.to_sorted_array in let arr_copy = Array.copy arr in - Array.sort (fun ((a : int), _) (b, _) -> compare a b) arr_copy; + Array.sort ~cmp:(fun ((a : int), _) (b, _) -> compare a b) arr_copy; v =~ arr_copy let suites = @@ -35,25 +37,25 @@ let suites = test_sorted_strict [| (2, ""); (1, ""); (3, ""); (4, "") |] ); ( __LOC__ >:: fun _ -> Map_int.cardinal - (Map_int.of_array (Array.init 1000 (fun i -> (i, i)))) + (Map_int.of_array (Array.init 1000 ~f:(fun i -> (i, i)))) =~ 1000 ); ( __LOC__ >:: fun _ -> let count = 1000 in - let a = Array.init count (fun x -> x) in + let a = Array.init count ~f:(fun x -> x) in let v = Map_int.empty in let u = let v = Array.fold_left - (fun acc key -> + ~f:(fun acc key -> Map_int.adjust acc key (fun v -> match v with None -> 1 | Some v -> succ v)) - v a + ~init:v a in Array.fold_left - (fun acc key -> + ~f:(fun acc key -> Map_int.adjust acc key (fun v -> match v with None -> 1 | Some v -> succ v)) - v a + ~init:v a in Map_int.iter u (fun _ v -> v =~ 2); Map_int.cardinal u =~ count ); diff --git a/test/unit-tests/ounit_path_tests.ml b/test/unit-tests/ounit_path_tests.ml index e9bc64ca74..2ea8e9c211 100644 --- a/test/unit-tests/ounit_path_tests.ml +++ b/test/unit-tests/ounit_path_tests.ml @@ -1,5 +1,7 @@ +open Melstd + let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) -let normalize = Ext_path.normalize_absolute_path +let normalize = Path.normalize_absolute_path let os_adapt s = let regexp = Str.regexp "\\(/\\)" in @@ -12,7 +14,7 @@ let suites = >::: [ ( "linux path tests" >:: fun _ -> let norm = - Array.map normalize + Array.map ~f:normalize [| "/gsho/./.."; "/a/b/../c../d/e/f"; @@ -49,20 +51,20 @@ let suites = =~ os_adapt "/a/b/c" ); ( __LOC__ >:: fun _ -> let aux a b result = - Ext_path.rel_normalized_absolute_path ~from:a b =~ result; + Path.rel_normalized_absolute_path ~from:a b =~ result; - Ext_path.rel_normalized_absolute_path - ~from:(String.sub a 0 (String.length a - 1)) + Path.rel_normalized_absolute_path + ~from:(String.sub a ~pos:0 ~len:(String.length a - 1)) b =~ result; - Ext_path.rel_normalized_absolute_path ~from:a - (String.sub b 0 (String.length b - 1)) + Path.rel_normalized_absolute_path ~from:a + (String.sub b ~pos:0 ~len:(String.length b - 1)) =~ result; - Ext_path.rel_normalized_absolute_path - ~from:(String.sub a 0 (String.length a - 1)) - (String.sub b 0 (String.length b - 1)) + Path.rel_normalized_absolute_path + ~from:(String.sub a ~pos:0 ~len:(String.length a - 1)) + (String.sub b ~pos:0 ~len:(String.length b - 1)) =~ result in aux "/a/b/c/" "/a/b/c/d/" (os_adapt "d"); @@ -74,50 +76,45 @@ let suites = (* This is still correct just not optimal depends on user's perspective *) ( __LOC__ >:: fun _ -> - Ext_path.rel_normalized_absolute_path ~from:"/a/b/c/d" "/x/y" + Path.rel_normalized_absolute_path ~from:"/a/b/c/d" "/x/y" =~ os_adapt "../../../../x/y"; - Ext_path.rel_normalized_absolute_path + Path.rel_normalized_absolute_path ~from:"/a/b/c/d/e/./src/bindings/Navigation" "/a/b/c/d/e" =~ os_adapt "../../.."; - Ext_path.rel_normalized_absolute_path ~from:"/a/b/c/./d" "/a/b/c" - =~ ".."; + Path.rel_normalized_absolute_path ~from:"/a/b/c/./d" "/a/b/c" =~ ".."; - Ext_path.rel_normalized_absolute_path ~from:"/a/b/c/./src" - "/a/b/d/./src" + Path.rel_normalized_absolute_path ~from:"/a/b/c/./src" "/a/b/d/./src" =~ os_adapt "../../d/src" ); (* used in module system: [es6-global] and [amdjs-global] *) ( __LOC__ >:: fun _ -> - Ext_path.rel_normalized_absolute_path + Path.rel_normalized_absolute_path ~from:"/usr/local/lib/node_modules/" "//" =~ os_adapt "../../../.."; - Ext_path.rel_normalized_absolute_path + Path.rel_normalized_absolute_path ~from:"/usr/local/lib/node_modules/" "/" =~ os_adapt "../../../.."; - Ext_path.rel_normalized_absolute_path ~from:"./" + Path.rel_normalized_absolute_path ~from:"./" "./node_modules/xx/./xx.js" =~ os_adapt "./node_modules/xx/xx.js"; - Ext_path.rel_normalized_absolute_path ~from:"././" + Path.rel_normalized_absolute_path ~from:"././" "./node_modules/xx/./xx.js" =~ os_adapt "./node_modules/xx/xx.js" ); ( __LOC__ >:: fun _ -> - Ext_path.node_rebase_file ~to_:"lib/js/src/a" ~from:"lib/js/src" "b" + Path.node_rebase_file ~to_:"lib/js/src/a" ~from:"lib/js/src" "b" =~ "./a/b"; - Ext_path.node_rebase_file ~to_:"lib/js/src/" ~from:"lib/js/src" "b" + Path.node_rebase_file ~to_:"lib/js/src/" ~from:"lib/js/src" "b" =~ "./b"; - Ext_path.node_rebase_file ~to_:"lib/js/src" ~from:"lib/js/src/a" "b" + Path.node_rebase_file ~to_:"lib/js/src" ~from:"lib/js/src/a" "b" =~ "../b"; - Ext_path.node_rebase_file ~to_:"lib/js/src/a" ~from:"lib/js/" "b" + Path.node_rebase_file ~to_:"lib/js/src/a" ~from:"lib/js/" "b" =~ "./src/a/b"; - Ext_path.node_rebase_file ~to_:"lib/js/./src/a" ~from:"lib/js/src/a/" - "b" + Path.node_rebase_file ~to_:"lib/js/./src/a" ~from:"lib/js/src/a/" "b" =~ "./b"; - Ext_path.node_rebase_file ~to_:"lib/js/src/a" ~from:"lib/js/src/a/" - "b" + Path.node_rebase_file ~to_:"lib/js/src/a" ~from:"lib/js/src/a/" "b" =~ "./b"; - Ext_path.node_rebase_file ~to_:"lib/js/src/a/" ~from:"lib/js/src/a/" - "b" + Path.node_rebase_file ~to_:"lib/js/src/a/" ~from:"lib/js/src/a/" "b" =~ "./b" ); ] diff --git a/test/unit-tests/ounit_scc_tests.ml b/test/unit-tests/ounit_scc_tests.ml index 403b26e8b6..f1a30e4aa2 100644 --- a/test/unit-tests/ounit_scc_tests.ml +++ b/test/unit-tests/ounit_scc_tests.ml @@ -1,3 +1,5 @@ +open Melstd + let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) let ( =~ ) = OUnit.assert_equal @@ -188,16 +190,16 @@ http://algs4.cs.princeton.edu/42digraph/KosarajuSharirSCC.java.html let handle_lines tiny_test_cases = match - Ext_string.split_by + String.split_by (function '\n' | '\r' -> true | _ -> false) tiny_test_cases with | nodes :: _edges :: rest -> let nodes_num = int_of_string nodes in - let node_array = Array.init nodes_num (fun _ -> Vec_int.empty ()) in + let node_array = Array.init nodes_num ~f:(fun _ -> Vec_int.empty ()) in List.iter - (fun x -> - match Ext_string.split x ' ' with + ~f:(fun x -> + match String.split x ' ' with | [ a; b ] -> let a, b = (int_of_string a, int_of_string b) in Vec_int.push node_array.(a) b @@ -209,12 +211,12 @@ let handle_lines tiny_test_cases = let read_file file = let in_chan = open_in_bin file in let nodes_sum = int_of_string (input_line in_chan) in - let node_array = Array.init nodes_sum (fun _ -> Vec_int.empty ()) in + let node_array = Array.init nodes_sum ~f:(fun _ -> Vec_int.empty ()) in let rec aux () = match input_line in_chan with | exception End_of_file -> () | x -> - (match Ext_string.split x ' ' with + (match String.split x ' ' with | [ a; b ] -> let a, b = (int_of_string a, int_of_string b) in Vec_int.push node_array.(a) b @@ -223,7 +225,7 @@ let read_file file = in print_endline "read data into memory"; aux (); - fst (Ext_scc.graph_check node_array) + fst (Scc.graph_check node_array) (* 25 *) let test (input : (string * string list) list) = @@ -236,16 +238,16 @@ let test (input : (string * string list) list) = Hashtbl.add tbl x !idx; incr idx) in - input |> List.iter (fun (x, others) -> List.iter add (x :: others)); + input |> List.iter ~f:(fun (x, others) -> List.iter ~f:add (x :: others)); let nodes_num = Hashtbl.length tbl in - let node_array = Array.init nodes_num (fun _ -> Vec_int.empty ()) in + let node_array = Array.init nodes_num ~f:(fun _ -> Vec_int.empty ()) in input - |> List.iter (fun (x, others) -> + |> List.iter ~f:(fun (x, others) -> let idx = Hashtbl.find tbl x in others - |> List.iter (fun y -> + |> List.iter ~f:(fun y -> Vec_int.push node_array.(idx) (Hashtbl.find tbl y))); - Ext_scc.graph_check node_array + Scc.graph_check node_array let test2 (input : (string * string list) list) = (* string -> int mapping @@ -257,19 +259,19 @@ let test2 (input : (string * string list) list) = Hashtbl.add tbl x !idx; incr idx) in - input |> List.iter (fun (x, others) -> List.iter add (x :: others)); + input |> List.iter ~f:(fun (x, others) -> List.iter ~f:add (x :: others)); let nodes_num = Hashtbl.length tbl in let other_mapping = Array.make nodes_num "" in Hashtbl.iter (fun k v -> other_mapping.(v) <- k) tbl; - let node_array = Array.init nodes_num (fun _ -> Vec_int.empty ()) in + let node_array = Array.init nodes_num ~f:(fun _ -> Vec_int.empty ()) in input - |> List.iter (fun (x, others) -> + |> List.iter ~f:(fun (x, others) -> let idx = Hashtbl.find tbl x in others - |> List.iter (fun y -> + |> List.iter ~f:(fun y -> Vec_int.push node_array.(idx) (Hashtbl.find tbl y))); - let output = Ext_scc.graph node_array in + let output = Scc.graph node_array in output |> Int_vec_vec.map_into_array (fun int_vec -> Vec_int.map_into_array (fun i -> other_mapping.(i)) int_vec) @@ -279,11 +281,11 @@ let suites = >::: [ ( __LOC__ >:: fun _ -> OUnit.assert_equal - (fst @@ Ext_scc.graph_check (handle_lines tiny_test_cases)) + (fst @@ Scc.graph_check (handle_lines tiny_test_cases)) 5 ); ( __LOC__ >:: fun _ -> OUnit.assert_equal - (fst @@ Ext_scc.graph_check (handle_lines medium_test_cases)) + (fst @@ Scc.graph_check (handle_lines medium_test_cases)) 10 ); ( __LOC__ >:: fun _ -> OUnit.assert_equal diff --git a/test/unit-tests/ounit_string_tests.ml b/test/unit-tests/ounit_string_tests.ml index b91ea20c05..ac0f7ced02 100644 --- a/test/unit-tests/ounit_string_tests.ml +++ b/test/unit-tests/ounit_string_tests.ml @@ -1,3 +1,5 @@ +open Melstd + let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) let ( =~ ) = OUnit.assert_equal ~printer:Ounit_test_util.dump let printer_string x = x @@ -7,46 +9,44 @@ let suites = __FILE__ >::: [ ( __LOC__ >:: fun _ -> - OUnit.assert_bool "not found " (Ext_string.rindex_neg "hello" 'x' < 0) - ); + OUnit.assert_bool "not found " (String.rindex_neg "hello" 'x' < 0) ); ( __LOC__ >:: fun _ -> - Ext_string.rindex_neg "hello" 'h' =~ 0; - Ext_string.rindex_neg "hello" 'e' =~ 1; - Ext_string.rindex_neg "hello" 'l' =~ 3; - Ext_string.rindex_neg "hello" 'l' =~ 3; - Ext_string.rindex_neg "hello" 'o' =~ 4 ); + String.rindex_neg "hello" 'h' =~ 0; + String.rindex_neg "hello" 'e' =~ 1; + String.rindex_neg "hello" 'l' =~ 3; + String.rindex_neg "hello" 'l' =~ 3; + String.rindex_neg "hello" 'o' =~ 4 ); ( __LOC__ >:: fun _ -> - OUnit.assert_bool "empty string" (Ext_string.rindex_neg "" 'x' < 0) - ); + OUnit.assert_bool "empty string" (String.rindex_neg "" 'x' < 0) ); ( __LOC__ >:: fun _ -> OUnit.assert_bool __LOC__ (not - (Ext_string.for_all_from "xABc" 1 (function + (String.for_all_from "xABc" 1 (function | 'A' .. 'Z' -> true | _ -> false))); OUnit.assert_bool __LOC__ - (Ext_string.for_all_from "xABC" 1 (function + (String.for_all_from "xABC" 1 (function | 'A' .. 'Z' -> true | _ -> false)); OUnit.assert_bool __LOC__ - (Ext_string.for_all_from "xABC" 1_000 (function + (String.for_all_from "xABC" 1_000 (function | 'A' .. 'Z' -> true | _ -> false)) ); ( __LOC__ >:: fun _ -> - Ext_string.tail_from "ghsogh" 1 =~ "hsogh"; - Ext_string.tail_from "ghsogh" 0 =~ "ghsogh" ); + String.tail_from "ghsogh" 1 =~ "hsogh"; + String.tail_from "ghsogh" 0 =~ "ghsogh" ); (* __LOC__ >:: begin fun _ -> - Ext_string.digits_of_str "11_js" ~offset:0 2 =~ 11 + String.digits_of_str "11_js" ~offset:0 2 =~ 11 end; *) ( __LOC__ >:: fun _ -> let ( =~ ) = OUnit.assert_equal ~printer:printer_string in - Ext_filename.chop_all_extensions_maybe "a.bs.js" =~ "a"; - Ext_filename.chop_all_extensions_maybe "a.js" =~ "a"; - Ext_filename.chop_all_extensions_maybe "a" =~ "a"; - Ext_filename.chop_all_extensions_maybe "a.x.bs.js" =~ "a" ); + Filename.chop_all_extensions_maybe "a.bs.js" =~ "a"; + Filename.chop_all_extensions_maybe "a.js" =~ "a"; + Filename.chop_all_extensions_maybe "a" =~ "a"; + Filename.chop_all_extensions_maybe "a.x.bs.js" =~ "a" ); (* let (=~) = OUnit.assert_equal ~printer:(fun x -> x) in *) ( __LOC__ >:: fun _ -> - let k = Ext_modulename.js_id_name_of_hint_name in + let k = Modulename.js_id_name_of_hint_name in k "xx" =~ "Xx"; k "react-dom" =~ "ReactDom"; k "a/b/react-dom" =~ "ReactDom"; @@ -65,7 +65,8 @@ let suites = OUnit.assert_equal (String.length (Digest.string "")) 16 ); ( __LOC__ >:: fun _ -> let bench = - String.concat ";" (List.init 11 (fun i -> string_of_int i)) + String.concat ~sep:";" + (List.init ~len:11 ~f:(fun i -> string_of_int i)) in let buf = Buffer.create 10 in OUnit.assert_bool __LOC__ (Buffer.contents buf <> bench); @@ -79,17 +80,17 @@ let suites = print_endline bench; *) OUnit.assert_bool __LOC__ (Buffer.contents buf = bench) ); ( __LOC__ >:: fun _ -> - string_eq (Ext_filename.new_extension "a.c" ".xx") "a.xx"; - string_eq (Ext_filename.new_extension "abb.c" ".xx") "abb.xx"; - string_eq (Ext_filename.new_extension ".c" ".xx") ".xx"; - string_eq (Ext_filename.new_extension "a/b" ".xx") "a/b.xx"; - string_eq (Ext_filename.new_extension "a/b." ".xx") "a/b.xx"; - string_eq (Ext_filename.chop_all_extensions_maybe "a.b.x") "a"; - string_eq (Ext_filename.chop_all_extensions_maybe "a.b") "a"; - string_eq (Ext_filename.chop_all_extensions_maybe ".a.b.x") ""; - string_eq (Ext_filename.chop_all_extensions_maybe "abx") "abx" ); + string_eq (Filename.new_extension "a.c" ".xx") "a.xx"; + string_eq (Filename.new_extension "abb.c" ".xx") "abb.xx"; + string_eq (Filename.new_extension ".c" ".xx") ".xx"; + string_eq (Filename.new_extension "a/b" ".xx") "a/b.xx"; + string_eq (Filename.new_extension "a/b." ".xx") "a/b.xx"; + string_eq (Filename.chop_all_extensions_maybe "a.b.x") "a"; + string_eq (Filename.chop_all_extensions_maybe "a.b") "a"; + string_eq (Filename.chop_all_extensions_maybe ".a.b.x") ""; + string_eq (Filename.chop_all_extensions_maybe "abx") "abx" ); ( __LOC__ >:: fun _ -> - Ext_string.split "" ':' =~ []; - Ext_string.split "a:b:" ':' =~ [ "a"; "b" ]; - Ext_string.split "a:b:" ':' ~keep_empty:true =~ [ "a"; "b"; "" ] ); + String.split "" ':' =~ []; + String.split "a:b:" ':' =~ [ "a"; "b" ]; + String.split "a:b:" ':' ~keep_empty:true =~ [ "a"; "b"; "" ] ); ] diff --git a/test/unit-tests/ounit_tests.ml b/test/unit-tests/ounit_tests.ml index ef8eafc5a4..44fe0b0a0b 100644 --- a/test/unit-tests/ounit_tests.ml +++ b/test/unit-tests/ounit_tests.ml @@ -1,22 +1,12 @@ +open Melstd + module Int_array = Vec.Make (struct type t = int let null = 0 end) -[@@@warning "-32"] - -let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) - -let ( =~ ) x y = - OUnit.assert_equal ~cmp:(Int_array.equal (fun (x : int) y -> x = y)) x y - -let ( =~~ ) x y = - OUnit.assert_equal - ~cmp:(Int_array.equal (fun (x : int) y -> x = y)) - x (Int_array.of_array y) - -[@@@warning "+32"] +let ( >::: ) = OUnit.( >::: ) let suites = __FILE__ diff --git a/test/unit-tests/ounit_vec_test.ml b/test/unit-tests/ounit_vec_test.ml index e3397d2d3a..a702e4742d 100644 --- a/test/unit-tests/ounit_vec_test.ml +++ b/test/unit-tests/ounit_vec_test.ml @@ -1,7 +1,6 @@ -let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) - -(* open Ext_json *) +open Melstd +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) let v = Vec_int.init 10 (fun i -> i) let ( =~ ) x y = @@ -35,7 +34,7 @@ let suites = Vec_int.compact v; OUnit.assert_equal (Vec_int.capacity v) 0 ); ( "inplace_filter_from " ^ __LOC__ >:: fun _ -> - let v = Vec_int.of_array (Array.init 10 (fun i -> i)) in + let v = Vec_int.of_array (Array.init 10 ~f:(fun i -> i)) in v =~~ [| 0; 1; 2; 3; 4; 5; 6; 7; 8; 9 |]; Vec_int.push v 96; Vec_int.inplace_filter_from 2 (fun x -> x mod 2 = 0) v; @@ -47,15 +46,15 @@ let suites = Vec_int.compact v; OUnit.assert_equal (Vec_int.capacity v) 1 ); ( "map " ^ __LOC__ >:: fun _ -> - let v = Vec_int.of_array (Array.init 1000 (fun i -> i)) in - Vec_int.map succ v =~~ Array.init 1000 succ; + let v = Vec_int.of_array (Array.init 1000 ~f:(fun i -> i)) in + Vec_int.map succ v =~~ Array.init 1000 ~f:succ; OUnit.assert_bool __LOC__ (Vec_int.exists (fun x -> x >= 999) v); OUnit.assert_bool __LOC__ (not (Vec_int.exists (fun x -> x > 1000) v)); OUnit.assert_equal (Vec_int.last v) 999 ); ( __LOC__ >:: fun _ -> let count = 1000 in - let init_array = Array.init count (fun i -> i) in + let init_array = Array.init count ~f:(fun i -> i) in let u = Vec_int.of_array init_array in let v = Vec_int.inplace_filter_with @@ -65,7 +64,7 @@ let suites = in let even, odd = init_array |> Array.to_list - |> List.partition (fun x -> x mod 2 = 0) + |> List.partition ~f:(fun x -> x mod 2 = 0) in OUnit.assert_equal (Set_int.elements v) odd; u =~~ Array.of_list even ); @@ -85,7 +84,7 @@ let suites = OUnit.assert_equal len !count ); ( __LOC__ >:: fun _ -> let count = 100 in - let v = Vec_int.of_array (Array.init count (fun i -> i)) in + let v = Vec_int.of_array (Array.init count ~f:(fun i -> i)) in OUnit.assert_bool __LOC__ (try Vec_int.delete v count; @@ -143,7 +142,7 @@ let suites = let v = Vec_int.of_list lst in OUnit.assert_equal (Vec_int.map_into_list (fun x -> x + 1) v) - (List.map (fun x -> x + 1) lst) ); + (List.map ~f:(fun x -> x + 1) lst) ); ( __LOC__ >:: fun _ -> let v = Vec_int.make 4 in Vec_int.push v 1;