From 1efce661356df7230fcf600860967688a616c58c Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Tue, 31 Oct 2023 15:36:05 -0700 Subject: [PATCH] refactor: tighten bindings (#855) --- jscomp/core/compile_rec_module.ml | 83 +++++++++++++------------- jscomp/core/record_attributes_check.ml | 45 +++++++------- 2 files changed, 66 insertions(+), 62 deletions(-) diff --git a/jscomp/core/compile_rec_module.ml b/jscomp/core/compile_rec_module.ml index 78e71e8de1..e1bf33f3c5 100644 --- a/jscomp/core/compile_rec_module.ml +++ b/jscomp/core/compile_rec_module.ml @@ -2,16 +2,6 @@ type t = Lambda.lambda (* Utilities for compiling "module rec" definitions *) -let bs_init_mod (args : t list) loc : t = - Lprim - (Pccall (Primitive.simple ~name:"#init_mod" ~arity:2 ~alloc:true), args, loc) - -let bs_update_mod (args : t list) loc : t = - Lprim - ( Pccall (Primitive.simple ~name:"#update_mod" ~arity:3 ~alloc:true), - args, - loc ) - type loc = t type binding = @@ -19,37 +9,50 @@ type binding = * (Lambda.lambda * Lambda.lambda) option * Lambda.lambda -let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = - let rec bind_inits args acc = - match args with - | [] -> acc - | (_id, None, _rhs) :: rem -> bind_inits rem acc - | (Translmod.Ignore_loc _, _, _) :: rem -> bind_inits rem acc - | (Id id, Some (loc, shape), _rhs) :: rem -> - Lambda.Llet - ( Strict, - Pgenval, - id, - bs_init_mod [ loc; shape ] Loc_unknown, - bind_inits rem acc ) - in - let rec bind_strict args acc = - match args with - | [] -> acc - | (Translmod.Id id, None, rhs) :: rem -> - Lambda.Llet (Strict, Pgenval, id, rhs, bind_strict rem acc) - | (_id, (None | Some _), _rhs) :: rem -> bind_strict rem acc - in - let rec patch_forwards args = - match args with - | [] -> cont - | (_id, None, _rhs) :: rem -> patch_forwards rem - | (Translmod.Ignore_loc _, _, _rhs) :: rem -> patch_forwards rem - | (Id id, Some (_loc, shape), rhs) :: rem -> - Lsequence - (bs_update_mod [ shape; Lvar id; rhs ] Loc_unknown, patch_forwards rem) +let eval_rec_bindings_aux = + let mel_init_mod (args : t list) loc : t = + Lprim + ( Pccall (Primitive.simple ~name:"#init_mod" ~arity:2 ~alloc:true), + args, + loc ) + and mel_update_mod (args : t list) loc : t = + Lprim + ( Pccall (Primitive.simple ~name:"#update_mod" ~arity:3 ~alloc:true), + args, + loc ) in - bind_inits bindings (bind_strict bindings (patch_forwards bindings)) + fun (bindings : binding list) (cont : t) : t -> + let rec bind_inits args acc = + match args with + | [] -> acc + | (_id, None, _rhs) :: rem -> bind_inits rem acc + | (Translmod.Ignore_loc _, _, _) :: rem -> bind_inits rem acc + | (Id id, Some (loc, shape), _rhs) :: rem -> + Lambda.Llet + ( Strict, + Pgenval, + id, + mel_init_mod [ loc; shape ] Loc_unknown, + bind_inits rem acc ) + in + let rec bind_strict args acc = + match args with + | [] -> acc + | (Translmod.Id id, None, rhs) :: rem -> + Lambda.Llet (Strict, Pgenval, id, rhs, bind_strict rem acc) + | (_id, (None | Some _), _rhs) :: rem -> bind_strict rem acc + in + let rec patch_forwards args = + match args with + | [] -> cont + | (_id, None, _rhs) :: rem -> patch_forwards rem + | (Translmod.Ignore_loc _, _, _rhs) :: rem -> patch_forwards rem + | (Id id, Some (_loc, shape), rhs) :: rem -> + Lsequence + ( mel_update_mod [ shape; Lvar id; rhs ] Loc_unknown, + patch_forwards rem ) + in + bind_inits bindings (bind_strict bindings (patch_forwards bindings)) (* collect all function declarations if the module creation is just a set of function declarations and consts, diff --git a/jscomp/core/record_attributes_check.ml b/jscomp/core/record_attributes_check.ml index 5fa2aa3bb5..823d74d233 100644 --- a/jscomp/core/record_attributes_check.ml +++ b/jscomp/core/record_attributes_check.ml @@ -139,25 +139,26 @@ let check_mel_attributes_inclusion (attrs1 : Parsetree.attributes) let b = find_with_default attrs2 ~f:find_name ~default:lbl_name in if a = b then None else Some (a, b) -let rec check_duplicated_labels_aux (lbls : Parsetree.label_declaration list) - (coll : Set_string.t) = - match lbls with - | [] -> None - | { pld_name = { txt; _ } as pld_name; pld_attributes; _ } :: rest -> ( - if Set_string.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 - | None -> check_duplicated_labels_aux rest coll_with_lbl - | Some ({ txt = s; _ } as l) -> - if - Set_string.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)) - -let check_duplicated_labels lbls = - check_duplicated_labels_aux lbls Set_string.empty +let check_duplicated_labels = + let rec check_duplicated_labels_aux (lbls : Parsetree.label_declaration list) + (coll : Set_string.t) = + match lbls with + | [] -> None + | { pld_name = { txt; _ } as pld_name; pld_attributes; _ } :: rest -> ( + if Set_string.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 + | None -> check_duplicated_labels_aux rest coll_with_lbl + | Some ({ txt = s; _ } as l) -> + if + Set_string.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)) + in + fun lbls -> check_duplicated_labels_aux lbls Set_string.empty