diff --git a/.depend b/.depend index 51cf9cd035bd..0ade7c77e83c 100644 --- a/.depend +++ b/.depend @@ -579,16 +579,16 @@ bytecomp/lambda.cmi : typing/types.cmi typing/typedtree.cmi \ typing/primitive.cmi typing/path.cmi parsing/location.cmi \ typing/ident.cmi typing/env.cmi parsing/asttypes.cmi bytecomp/matching.cmo : typing/types.cmi typing/typeopt.cmi \ - typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \ - typing/primitive.cmi typing/predef.cmi typing/path.cmi \ - typing/parmatch.cmi utils/misc.cmi parsing/longident.cmi \ + typing/typedtree.cmi typing/typecore.cmi bytecomp/switch.cmi \ + bytecomp/printlambda.cmi typing/primitive.cmi typing/predef.cmi \ + typing/path.cmi typing/parmatch.cmi utils/misc.cmi parsing/longident.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ typing/datarepr.cmi utils/config.cmi utils/clflags.cmi typing/btype.cmi \ parsing/asttypes.cmi bytecomp/matching.cmi bytecomp/matching.cmx : typing/types.cmx typing/typeopt.cmx \ - typing/typedtree.cmx bytecomp/switch.cmx bytecomp/printlambda.cmx \ - typing/primitive.cmx typing/predef.cmx typing/path.cmx \ - typing/parmatch.cmx utils/misc.cmx parsing/longident.cmx \ + typing/typedtree.cmx typing/typecore.cmx bytecomp/switch.cmx \ + bytecomp/printlambda.cmx typing/primitive.cmx typing/predef.cmx \ + typing/path.cmx typing/parmatch.cmx utils/misc.cmx parsing/longident.cmx \ parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ typing/datarepr.cmx utils/config.cmx utils/clflags.cmx typing/btype.cmx \ parsing/asttypes.cmi bytecomp/matching.cmi @@ -659,15 +659,17 @@ bytecomp/translattribute.cmx : utils/warnings.cmx typing/typedtree.cmx \ bytecomp/translattribute.cmi : typing/typedtree.cmi parsing/parsetree.cmi \ parsing/location.cmi bytecomp/lambda.cmi bytecomp/translclass.cmo : typing/types.cmi typing/typeopt.cmi \ - typing/typedtree.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \ - typing/path.cmi bytecomp/matching.cmi parsing/location.cmi \ - bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/clflags.cmi \ - typing/btype.cmi parsing/asttypes.cmi bytecomp/translclass.cmi + typing/typedtree.cmi typing/typecore.cmi bytecomp/translobj.cmi \ + bytecomp/translcore.cmi typing/path.cmi bytecomp/matching.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + bytecomp/translclass.cmi bytecomp/translclass.cmx : typing/types.cmx typing/typeopt.cmx \ - typing/typedtree.cmx bytecomp/translobj.cmx bytecomp/translcore.cmx \ - typing/path.cmx bytecomp/matching.cmx parsing/location.cmx \ - bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/clflags.cmx \ - typing/btype.cmx parsing/asttypes.cmi bytecomp/translclass.cmi + typing/typedtree.cmx typing/typecore.cmx bytecomp/translobj.cmx \ + bytecomp/translcore.cmx typing/path.cmx bytecomp/matching.cmx \ + parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + bytecomp/translclass.cmi bytecomp/translclass.cmi : typing/typedtree.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi bytecomp/translcore.cmo : typing/types.cmi typing/typeopt.cmi \ diff --git a/.gitattributes b/.gitattributes index 0d7fefb049cf..882d913f2003 100644 --- a/.gitattributes +++ b/.gitattributes @@ -103,7 +103,11 @@ yacc/*.[ch] ocaml-typo=long-line,very-long-line,unused-prop *.precheck text eol=lf *.runner text eol=lf +clone-flexdll text eol=lf configure text eol=lf +configure-windows text eol=lf +esy-configure text eol=lf +esy-build text eol=lf config/auto-aux/hasgot text eol=lf config/auto-aux/hasgot2 text eol=lf config/auto-aux/runtest text eol=lf diff --git a/.gitmodules b/.gitmodules deleted file mode 100644 index dca1e0d28f7a..000000000000 --- a/.gitmodules +++ /dev/null @@ -1,3 +0,0 @@ -[submodule "flexdll"] - path = flexdll - url = https://github.com/alainfrisch/flexdll.git diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 120f1f54602b..e647d96bd2b0 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -43,7 +43,7 @@ let rec split_list n l = let rec build_closure_env env_param pos = function [] -> Tbl.empty | id :: rem -> - Tbl.add id (Uprim(Pfield (pos, Fld_na), [Uvar env_param], Debuginfo.none)) + Tbl.add id (Uprim(Pfield (pos, Lambda.fld_na), [Uvar env_param], Debuginfo.none)) (build_closure_env env_param (pos+1) rem) (* Auxiliary for accessing globals. We change the name of the global @@ -765,7 +765,7 @@ let check_constant_result lam ulam approx = let glb = Uprim(Pgetglobal (Ident.create_persistent id), [], Debuginfo.none) in - Uprim(Pfield (i,Fld_na), [glb], Debuginfo.none), approx + Uprim(Pfield (i,Lambda.fld_na), [glb], Debuginfo.none), approx end | _ -> (ulam, approx) diff --git a/asmcomp/flambda_to_clambda.ml b/asmcomp/flambda_to_clambda.ml index 6f2af71741f1..1cb8bb60ed36 100644 --- a/asmcomp/flambda_to_clambda.ml +++ b/asmcomp/flambda_to_clambda.ml @@ -365,7 +365,7 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda = Flambda.print_named named end | Read_symbol_field (symbol, field) -> - Uprim (Pfield (field, Fld_na), [to_clambda_symbol env symbol], Debuginfo.none) + Uprim (Pfield (field, Lambda.fld_na), [to_clambda_symbol env symbol], Debuginfo.none) | Set_of_closures set_of_closures -> to_clambda_set_of_closures t env set_of_closures | Project_closure { set_of_closures; closure_id } -> @@ -390,11 +390,11 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda = let fun_offset = get_fun_offset t closure_id in let var_offset = get_fv_offset t var in let pos = var_offset - fun_offset in - Uprim (Pfield (pos, Fld_na), + Uprim (Pfield (pos, Lambda.fld_na), [check_field (check_closure ulam (Expr (Var closure))) pos (Some named)], Debuginfo.none) | Prim (Pfield (index,_), [block], dbg) -> - Uprim (Pfield (index, Fld_na), [check_field (subst_var env block) index None], dbg) + Uprim (Pfield (index, Lambda.fld_na), [check_field (subst_var env block) index None], dbg) | Prim (Psetfield (index, maybe_ptr, init, dbg_info), [block; new_value], dbg) -> Uprim (Psetfield (index, maybe_ptr, init, dbg_info), [ check_field (subst_var env block) index None; @@ -492,7 +492,7 @@ and to_clambda_set_of_closures t env in let pos = var_offset - fun_offset in Env.add_subst env id - (Uprim (Pfield (pos, Fld_na), [Clambda.Uvar env_var], Debuginfo.none)) + (Uprim (Pfield (pos, Lambda.fld_na), [Clambda.Uvar env_var], Debuginfo.none)) in let env = Variable.Map.fold add_env_free_variable free_vars env in (* Add the Clambda expressions for all functions defined in the current diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index 0ed5d5b1ab65..1d7446f1f6e7 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -35,7 +35,7 @@ type loc_kind = | Loc_POS type tag_info = - | Blk_constructor of string * int (* Number of non-const constructors*) + | Blk_constructor of {name : string ; num_nonconst : int} | Blk_tuple | Blk_array | Blk_poly_var of string @@ -47,10 +47,9 @@ type tag_info = | Blk_na of string | Blk_some | Blk_some_not_nested (* ['a option] where ['a] can not inhabit a non-like value *) - | Blk_record_inlined of string array * string * int + | Blk_record_inlined of { name : string ; num_nonconst : int; fields : string array} | Blk_record_ext of string array | Blk_lazy_general - | Blk_lazy_forward | Blk_class (* Ocaml style class*) let default_tag_info : tag_info = Blk_na "" @@ -64,15 +63,15 @@ let blk_record_ext = ref (fun fields -> Blk_record_ext all_labels_info ) -let blk_record_inlined = ref (fun fields name num_nonconsts -> - let all_labels_info = fields |> Array.map (fun (x,_) -> x.Types.lbl_name) in - Blk_record_inlined (all_labels_info, name, num_nonconsts) +let blk_record_inlined = ref (fun fields name num_nonconst -> + let fields = fields |> Array.map (fun (x,_) -> x.Types.lbl_name) in + Blk_record_inlined {fields; name; num_nonconst} ) let ref_tag_info : tag_info = Blk_record [| "contents" |] type field_dbg_info = - | Fld_na + | Fld_na of string | Fld_record of {name : string; mutable_flag : Asttypes.mutable_flag} | Fld_module of {name : string } | Fld_record_inline of { name : string} @@ -80,12 +79,17 @@ type field_dbg_info = | Fld_tuple | Fld_poly_var_tag | Fld_poly_var_content - | Fld_extension_slot + | Fld_extension + | Fld_variant + | Fld_cons + | Fld_array + let fld_record = ref (fun (lbl : Types.label_description) -> Fld_record {name = lbl.lbl_name; mutable_flag = Mutable}) let ref_field_info : field_dbg_info = Fld_record { name = "contents"; mutable_flag = Mutable} +let fld_na = Fld_na "" type set_field_dbg_info = | Fld_set_na @@ -250,11 +254,12 @@ and raise_kind = | Raise_notrace type pointer_info = - | Pt_constructor of {name : string; cstrs : int * int } + | Pt_constructor of {name : string; const : int ; non_const : int } | Pt_variant of {name : string} | Pt_module_alias | Pt_builtin_boolean | Pt_shape_none + | Pt_assertfalse | Pt_na @@ -364,9 +369,9 @@ type program = not necessary "()", it can be used as a place holder for module alias etc. *) -let const_unit = Const_pointer(0, Pt_na) +let const_unit = Const_pointer(0, Pt_constructor{name = "()"; const = 1; non_const = 0}) -let lambda_assert_false = Lconst (Const_pointer(0, Pt_constructor {name = "assert false"; cstrs = (1,0)})) +let lambda_assert_false = Lconst (Const_pointer(0, Pt_assertfalse)) let lambda_module_alias = Lconst (Const_pointer(0, Pt_module_alias)) @@ -398,7 +403,7 @@ let make_key e = (* make_key is used for normalizing let-bound variables *) let rec tr_rec env e = incr count ; - if !count > max_raw then raise Not_simple ; (* Too big ! *) + if !count > max_raw then raise_notrace Not_simple ; (* Too big ! *) match e with | Lvar id -> begin @@ -407,7 +412,7 @@ let make_key e = end | Lconst (Const_base (Const_string _)) -> (* Mutable constants are not shared *) - raise Not_simple + raise_notrace Not_simple | Lconst _ -> e | Lapply ap -> Lapply {ap with ap_func = tr_rec env ap.ap_func; @@ -453,7 +458,7 @@ let make_key e = (* Beware: (PR#6412) the event argument to Levent may include cyclic structure of type Type.typexpr *) | Levent _ -> - raise Not_simple + raise_notrace Not_simple and tr_recs env es = List.map (tr_rec env) es diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index a6100b7b00ca..19f477d521fb 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -35,7 +35,7 @@ type loc_kind = | Loc_POS type tag_info = - | Blk_constructor of string * int (* Number of non-const constructors*) + | Blk_constructor of {name : string ; num_nonconst : int} | Blk_tuple | Blk_array | Blk_poly_var of string @@ -57,10 +57,9 @@ type tag_info = | Blk_na of string (* This string only for debugging*) | Blk_some | Blk_some_not_nested (* ['a option] where ['a] can not inhabit a non-like value *) - | Blk_record_inlined of string array * string * int + | Blk_record_inlined of { name : string ; num_nonconst : int ; fields : string array} | Blk_record_ext of string array - | Blk_lazy_general - | Blk_lazy_forward + | Blk_lazy_general | Blk_class (* ocaml style class *) val blk_record : @@ -88,7 +87,7 @@ val default_tag_info : tag_info val ref_tag_info : tag_info type field_dbg_info = - | Fld_na + | Fld_na of string | Fld_record of {name : string; mutable_flag : Asttypes.mutable_flag} | Fld_module of {name : string} | Fld_record_inline of {name : string} @@ -96,13 +95,19 @@ type field_dbg_info = | Fld_tuple | Fld_poly_var_tag | Fld_poly_var_content - | Fld_extension_slot + | Fld_extension + | Fld_variant + | Fld_cons + | Fld_array + val fld_record : (Types.label_description -> field_dbg_info) ref val ref_field_info : field_dbg_info +val fld_na : field_dbg_info + type set_field_dbg_info = | Fld_set_na | Fld_record_set of string @@ -134,11 +139,12 @@ type is_safe = | Unsafe type pointer_info = - | Pt_constructor of {name : string; cstrs : int * int} + | Pt_constructor of {name : string; const : int ; non_const : int} | Pt_variant of {name : string} | Pt_module_alias | Pt_builtin_boolean | Pt_shape_none + | Pt_assertfalse | Pt_na diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 8bf1b516424d..676f9f13622c 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -1249,11 +1249,11 @@ let divide_constant ctx m = (* Matching against a constructor *) -let make_field_args loc binding_kind arg first_pos last_pos argl = +let make_field_args ~fld_info loc binding_kind arg first_pos last_pos argl = let rec make_args pos = if pos > last_pos then argl - else (Lprim(Pfield (pos, Fld_na), [arg], loc), binding_kind) :: make_args (pos + 1) + else (Lprim(Pfield (pos, fld_info), [arg], loc), binding_kind) :: make_args (pos + 1) in make_args first_pos let get_key_constr = function @@ -1352,9 +1352,12 @@ let make_constr_matching p def ctx = function | Cstr_constant _ | Cstr_block _ -> make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl + ~fld_info:(if cstr.cstr_name = "::" then Fld_cons else Fld_variant) | Cstr_unboxed -> (arg, Alias) :: argl | Cstr_extension _ -> - make_field_args p.pat_loc Alias arg 1 cstr.cstr_arity argl in + make_field_args p.pat_loc Alias arg 1 cstr.cstr_arity argl + ~fld_info:Fld_extension + in {pm= {cases = []; args = newargs; default = make_default (matcher_constr cstr) def} ; @@ -1424,10 +1427,10 @@ let divide_variant row ctx {cases = cl; args = al; default=def} = match pato with None -> add (make_variant_matching_constant p lab def ctx) variants - (=) (Cstr_constant tag) (patl, action) al + (=) (lab,Cstr_constant tag) (patl, action) al | Some pat -> add (make_variant_matching_nonconst p lab def ctx) variants - (=) (Cstr_block tag) (pat :: patl, action) al + (=) (lab,Cstr_block tag) (pat :: patl, action) al end | _ -> [] in @@ -1522,7 +1525,7 @@ let inline_lazy_force_cond arg loc = Lprim(Pintcomp Ceq, [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))], loc), - Lprim(Pfield (0, Fld_na), [varg], loc), (*TODO: lazy field *) + Lprim(Pfield (0, Lambda.fld_na (*IRRELEVANT*)), [varg], loc), Lifthenelse( (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *) Lprim(Pintcomp Ceq, @@ -1549,7 +1552,7 @@ let inline_lazy_force_switch arg loc = { sw_numconsts = 0; sw_consts = []; sw_numblocks = 256; (* PR#6033 - tag ranges from 0 to 255 *) sw_blocks = - [ (Obj.forward_tag, Lprim(Pfield (0, Fld_na) (* TODO: lazy*), [varg], loc)); + [ (Obj.forward_tag, Lprim(Pfield (0, Lambda.fld_na (*IRRELEVANT*)), [varg], loc)); (Obj.lazy_tag, Lapply{ap_should_be_tailcall=false; ap_loc=loc; @@ -2315,6 +2318,21 @@ let split_cases tag_lambda_list = let const, nonconst = split_rec tag_lambda_list in sort_int_lambda_list const, sort_int_lambda_list nonconst + +(* refine [split_cases] and [split_variant_cases] *) +let split_variant_cases tag_lambda_list = + let rec split_rec = function + [] -> ([], []) + | ((name,cstr), act) :: rem -> + let (consts, nonconsts) = split_rec rem in + match cstr with + Cstr_constant n -> ((n, (name, act)) :: consts, nonconsts) + | Cstr_block n -> (consts, (n, (name, act)) :: nonconsts) + | Cstr_unboxed -> assert false + | Cstr_extension _ -> assert false in + let const, nonconst = split_rec tag_lambda_list in + sort_int_lambda_list const, + sort_int_lambda_list nonconst let split_extension_cases tag_lambda_list = let rec split_rec = function @@ -2322,12 +2340,15 @@ let split_extension_cases tag_lambda_list = | (cstr, act) :: rem -> let (consts, nonconsts) = split_rec rem in match cstr with - Cstr_extension(path, true) -> ((path, act) :: consts, nonconsts) - | Cstr_extension(path, false) -> (consts, (path, act) :: nonconsts) + Cstr_extension(path, true) when not !Config.bs_only -> ((path, act) :: consts, nonconsts) + | Cstr_extension(path, _) -> (consts, (path, act) :: nonconsts) | _ -> assert false in split_rec tag_lambda_list - +let extension_slot_eq : Primitive.description = + Primitive.simple ~name:"#extension_slot_eq" ~arity:2 ~alloc:false +let extension_slot_eq () = + if !Config.bs_only then Pccall extension_slot_eq else Pintcomp Ceq let combine_constructor sw_names loc arg ex_pat cstr partial ctx def (tag_lambda_list, total1, pats) = if cstr.cstr_consts < 0 then begin @@ -2354,17 +2375,20 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def List.fold_right (fun (path, act) rem -> let ext = transl_extension_path ex_pat.pat_env path in - Lifthenelse(Lprim(Pintcomp Ceq, [Lvar tag; ext], loc), + Lifthenelse(Lprim(extension_slot_eq (), [Lvar tag; ext], loc), act, rem)) nonconsts default in - Llet(Alias, Pgenval,tag, Lprim(Pfield (0, Fld_extension_slot), [arg], loc), tests) + if !Config.bs_only then + Llet(Alias, Pgenval,tag, arg, tests) + else + Llet(Alias, Pgenval,tag, Lprim(Pfield (0, Lambda.fld_na (*IRRELEVANT*)), [arg], loc), tests) in List.fold_right (fun (path, act) rem -> let ext = transl_extension_path ex_pat.pat_env path in - Lifthenelse(Lprim(Pintcomp Ceq, [arg; ext], loc), + Lifthenelse(Lprim(extension_slot_eq (), [arg; ext], loc), act, rem)) consts nonconst_lambda @@ -2436,18 +2460,50 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def let make_test_sequence_variant_constant fail arg int_lambda_list = let _, (cases, actions) = - as_interval fail min_int max_int int_lambda_list in + as_interval fail min_int max_int (List.map (fun (a,(_,c)) -> (a,c)) int_lambda_list) in Switcher.test_sequence arg cases actions let call_switcher_variant_constant loc fail arg int_lambda_list names = - call_switcher loc fail arg min_int max_int int_lambda_list names + call_switcher loc fail arg min_int max_int (List.map (fun (a,(_,c)) -> (a,c)) int_lambda_list) names let call_switcher_variant_constr loc fail arg int_lambda_list names = let v = Ident.create "variant" in Llet(Alias, Pgenval, v, Lprim(Pfield (0, Fld_poly_var_tag), [arg], loc), call_switcher loc - fail (Lvar v) min_int max_int int_lambda_list names) + fail (Lvar v) min_int max_int (List.map (fun (a,(_,c)) -> (a,c)) int_lambda_list) names) + +let call_switcher_variant_constant : + (Location.t -> + Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Lambda.switch_names option -> + Lambda.lambda) + ref= ref call_switcher_variant_constant + +let call_switcher_variant_constr : + (Location.t -> + Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Lambda.switch_names option -> + Lambda.lambda) + ref + = ref call_switcher_variant_constr + +let make_test_sequence_variant_constant : + (Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Lambda.lambda) + ref + = ref make_test_sequence_variant_constant + +let is_poly_var_constant : Lambda.primitive lazy_t = lazy ( + if !Config.bs_only then + Pccall (Primitive.simple ~name:"#is_poly_var_const" ~arity:1 ~alloc:false) + else Pisint ) let combine_variant names loc row arg partial ctx def (tag_lambda_list, total1, _pats) = @@ -2463,9 +2519,9 @@ let combine_variant names loc row arg partial ctx def else num_constr := max_int; let test_int_or_block arg if_int if_block = - Lifthenelse(Lprim (Pisint, [arg], loc), if_int, if_block) in + Lifthenelse(Lprim (Lazy.force is_poly_var_constant, [arg], loc), if_int, if_block) in let sig_complete = List.length tag_lambda_list = !num_constr - and one_action = same_actions tag_lambda_list in + and one_action = same_actions tag_lambda_list in (* reduandant work under bs context *) let fail, local_jumps = if sig_complete || (match partial with Total -> true | _ -> false) @@ -2473,17 +2529,17 @@ let combine_variant names loc row arg partial ctx def None, jumps_empty else mk_failaction_neg partial ctx def in - let (consts, nonconsts) = split_cases tag_lambda_list in + let (consts, nonconsts) = split_variant_cases tag_lambda_list in let lambda1 = match fail, one_action with | None, Some act -> act | _,_ -> match (consts, nonconsts) with - | ([_, act1], [_, act2]) when fail=None -> + | ([_, (_,act1)], [_, (_,act2)]) when fail=None -> test_int_or_block arg act1 act2 | (_, []) -> (* One can compare integers and pointers *) - make_test_sequence_variant_constant fail arg consts + !make_test_sequence_variant_constant fail arg consts | ([], _) -> - let lam = call_switcher_variant_constr loc + let lam = !call_switcher_variant_constr loc fail arg nonconsts names in (* One must not dereference integers *) begin match fail with @@ -2492,10 +2548,10 @@ let combine_variant names loc row arg partial ctx def end | (_, _) -> let lam_const = - call_switcher_variant_constant loc + !call_switcher_variant_constant loc fail arg consts names and lam_nonconst = - call_switcher_variant_constr loc + !call_switcher_variant_constr loc fail arg nonconsts names in test_int_or_block arg lam_const lam_nonconst in @@ -2708,10 +2764,9 @@ let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = let rec name_pattern default = function (pat :: _, _) :: rem -> - begin match pat.pat_desc with - Tpat_var (id, _) -> id - | Tpat_alias(_, id, _) -> id - | _ -> name_pattern default rem + begin match Typecore.id_of_pattern pat with + | Some id -> id + | None -> name_pattern default rem end | _ -> Ident.create default @@ -2723,7 +2778,7 @@ let arg_to_var arg cls = match arg with (* To be set by Lam_compile *) let names_from_construct_pattern : (pattern -> switch_names option) ref = - ref (fun _ -> assert false) + ref (fun _ -> None) (* The main compilation function. @@ -2795,9 +2850,7 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with (combine_constant names pat.pat_loc arg cst partial) ctx pm | Tpat_construct (_, cstr, _) -> - let sw_names = if !Config.bs_only - then !names_from_construct_pattern pat - else None in + let sw_names = !names_from_construct_pattern pat in compile_test (compile_match repr partial) partial divide_constructor @@ -3211,12 +3264,12 @@ let do_for_multiple_match loc paraml pat_act_list partial = let raise_num = next_raise_count () in raise_num, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None), paraml, loc), Strict]; + args = [Lprim(Pmakeblock(0, Blk_tuple, Immutable, None), paraml, loc), Strict]; default = [[[omega]],raise_num] } | _ -> -1, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None), paraml, loc), Strict]; + args = [Lprim(Pmakeblock(0, Blk_tuple, Immutable, None), paraml, loc), Strict]; default = [] } in try diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli index ec2e3ec3890d..136a4b565893 100644 --- a/bytecomp/matching.mli +++ b/bytecomp/matching.mli @@ -18,7 +18,31 @@ open Typedtree open Lambda +val call_switcher_variant_constant : + (Location.t -> + Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Lambda.switch_names option -> + Lambda.lambda) + ref +val call_switcher_variant_constr : + (Location.t -> + Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Lambda.switch_names option -> + Lambda.lambda) + ref + +val make_test_sequence_variant_constant : + (Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Lambda.lambda) + ref + (* Entry points to match compiler *) val for_function: Location.t -> int ref option -> lambda -> (pattern * lambda) list -> diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index a851a7be429d..30027ba51559 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -60,11 +60,11 @@ let value_kind = function | Pfloatval -> "[float]" | Pboxedintval bi -> Printf.sprintf "[%s]" (boxed_integer_name bi) -let field_kind = function +(* let field_kind = function | Pgenval -> "*" | Pintval -> "int" | Pfloatval -> "float" - | Pboxedintval bi -> boxed_integer_name bi + | Pboxedintval bi -> boxed_integer_name bi *) let print_boxed_integer_conversion ppf bi1 bi2 = fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1) @@ -116,7 +116,7 @@ let string_of_loc_kind = function | Loc_POS -> "loc_POS" | Loc_LOC -> "loc_LOC" -let block_shape ppf shape = match shape with +(* let block_shape ppf shape = match shape with | None | Some [] -> () | Some l when List.for_all ((=) Pgenval) l -> () | Some [elt] -> @@ -126,18 +126,40 @@ let block_shape ppf shape = match shape with List.iter (fun elt -> Format.fprintf ppf ",%s" (field_kind elt)) t; - Format.fprintf ppf ")" + Format.fprintf ppf ")" *) let str_of_field_info (fld_info : Lambda.field_dbg_info)= match fld_info with | (Fld_module {name } | Fld_record {name} | Fld_record_inline {name} | Fld_record_extension {name}) -> name - | Fld_na -> "na" + | Fld_na s -> if s = "" then "na" else "" | Fld_tuple -> "[]" | Fld_poly_var_tag->"`" | Fld_poly_var_content -> "#" - | Fld_extension_slot -> "ext" + | Fld_extension -> "ext" + | Fld_variant -> "var" + | Fld_cons -> "cons" + | Fld_array -> "[||]" +let print_taginfo ppf = function + | Blk_extension -> fprintf ppf "ext" + | Blk_record_ext ss -> fprintf ppf "[%s]" (String.concat ";" (Array.to_list ss) ) + | Blk_tuple -> fprintf ppf "tuple" + | Blk_constructor {name ;num_nonconst} -> fprintf ppf "%s/%i" name num_nonconst + | Blk_array -> fprintf ppf "array" + | Blk_poly_var name -> fprintf ppf "`%s" name + | Blk_record ss -> fprintf ppf "[%s]" (String.concat ";" (Array.to_list ss) ) + | Blk_module ss -> fprintf ppf "[%s]" (String.concat ";" ss) + | Blk_extension_slot -> fprintf ppf "ext_slot" + | Blk_na s -> fprintf ppf "%s" s + | Blk_some -> fprintf ppf "some" + | Blk_some_not_nested -> fprintf ppf "some_not_nested" + | Blk_lazy_general -> fprintf ppf "lazy_general" + | Blk_class -> fprintf ppf "class" + | Blk_module_export _ -> fprintf ppf "module/exports" + | Blk_record_inlined {fields = ss } + -> fprintf ppf "[%s]" (String.concat ";" (Array.to_list ss) ) + let primitive ppf = function | Pidentity -> fprintf ppf "id" | Pbytes_to_string -> fprintf ppf "bytes_to_string" @@ -148,10 +170,10 @@ let primitive ppf = function | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind) | Pgetglobal id -> fprintf ppf "global %a" Ident.print id | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id - | Pmakeblock(tag, _, Immutable, shape) -> - fprintf ppf "makeblock %i%a" tag block_shape shape - | Pmakeblock(tag, _, Mutable, shape) -> - fprintf ppf "makemutable %i%a" tag block_shape shape + | Pmakeblock(tag, taginfo, Immutable, _) -> + fprintf ppf "makeblock %i/%a" tag print_taginfo taginfo + | Pmakeblock(tag, taginfo, Mutable, _) -> + fprintf ppf "makemutable %i/%a" tag print_taginfo taginfo | Pfield (n, fld) -> fprintf ppf "field:%s/%i" (str_of_field_info fld) n | Pfield_computed -> fprintf ppf "field_computed" | Psetfield(n, ptr, init, _) -> diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 0b07f88ababe..df178535fee0 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -139,7 +139,7 @@ let init () = try List.assoc name Predef.builtin_values with Not_found -> fatal_error "Symtable.init" in let c = slot_for_setglobal id in - let cst = Const_block(Obj.object_tag, Lambda.default_tag_info, + let cst = Const_block(Obj.object_tag, Lambda.default_tag_info (*IIRELEVANT*), [Const_base(Const_string (name, None)); Const_base(Const_int (-i-1)) ]) diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 57be964aed76..2c37f8e49673 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -56,7 +56,7 @@ let mkappl (func, args) = let lsequence l1 l2 = if l2 = lambda_unit then l1 else Lsequence(l1, l2) -let lfield v i = Lprim(Pfield (i, Fld_na), [Lvar v], Location.none) +let lfield ~fld_info v i = Lprim(Pfield (i, fld_info), [Lvar v], Location.none) let transl_label l = share (Const_immstring l) @@ -114,10 +114,9 @@ let create_object cl obj init = end let name_pattern default p = - match p.pat_desc with - | Tpat_var (id, _) -> id - | Tpat_alias(_, id, _) -> id - | _ -> Ident.create default + match Typecore.id_of_pattern p with + | Some id -> id + | None -> Ident.create default let normalize_cl_path cl path = Env.normalize_path (Some cl.cl_loc) cl.cl_env path @@ -130,7 +129,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = let env = match envs with None -> [] | Some envs -> - [Lprim(Pfield (List.length inh_init + 1, Fld_na), + [Lprim(Pfield (List.length inh_init + 1, Lambda.fld_na), [Lvar envs], Location.none)] in @@ -237,7 +236,7 @@ let bind_methods tbl meths vals cl_init = [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), List.fold_right (fun (_lab,id) lam -> decr i; Llet(StrictOpt, Pgenval, id, - lfield ids !i, lam)) + lfield ~fld_info:Fld_array ids !i, lam)) (methl @ vals) cl_init) let output_methods tbl methods lam = @@ -361,20 +360,20 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = List.fold_left (fun init (nm, id, _) -> Llet(StrictOpt, Pgenval, id, - lfield inh (index nm concr_meths + ofs), + lfield inh (index nm concr_meths + ofs) ~fld_info:Fld_array, init)) cl_init methids in let cl_init = List.fold_left (fun init (nm, id) -> Llet(StrictOpt, Pgenval, id, - lfield inh (index nm vals + 1), init)) + lfield inh (index nm vals + 1) ~fld_info:Fld_array, init)) cl_init valids in (inh_init, Llet (Strict, Pgenval, inh, mkappl(oo_prim "inherits", narrow_args @ [lpath; Lconst(Const_pointer((if top then 1 else 0),Pt_builtin_boolean))]), - Llet(StrictOpt, Pgenval, obj_init, lfield inh 0, cl_init))) + Llet(StrictOpt, Pgenval, obj_init, lfield inh 0 ~fld_info:Fld_array, cl_init))) | _ -> let core cl_init = build_class_init cla true super inh_init cl_init msubst top cl @@ -491,15 +490,15 @@ let transl_class_rebind cl vf = Llet( Alias, Pgenval, cla, transl_normal_path path, Lprim(Pmakeblock(0, Lambda.Blk_class, Immutable, None), - [mkappl(Lvar new_init, [lfield cla 0]); + [mkappl(Lvar new_init, [lfield ~fld_info:Fld_tuple cla 0]); lfunction [table] (Llet(Strict, Pgenval, env_init, - mkappl(lfield cla 1, [Lvar table]), + mkappl(lfield ~fld_info:Fld_tuple cla 1, [Lvar table]), lfunction [envs] (mkappl(Lvar new_init, [mkappl(Lvar env_init, [Lvar envs])])))); - lfield cla 2; - lfield cla 3], + lfield ~fld_info:Fld_tuple cla 2; + lfield ~fld_info:Fld_tuple cla 3], Location.none))) with Exit -> lambda_unit @@ -662,7 +661,7 @@ let transl_class ids cl_id pub_meths cl vflag = let i = ref (i0-1) in List.fold_left (fun subst id -> - incr i; Ident.add id (lfield env !i) subst) + incr i; Ident.add id (lfield env !i ~fld_info:Fld_array) subst) (* can not be of type {!tables} since it's either of size 0 or 3 *) Ident.empty !new_ids' in let new_ids_meths = ref [] in @@ -699,9 +698,9 @@ let transl_class ids cl_id pub_meths cl vflag = if top then lam else (* must be called only once! *) let lam = subst_lambda (subst env1 lam 1 new_ids_init) lam in - Llet(Alias, Pgenval, env1, (if l = [] then Lvar envs else lfield envs 0), + Llet(Alias, Pgenval, env1, (if l = [] then Lvar envs else lfield envs 0 ~fld_info:(if !Config.bs_only then assert false else Lambda.fld_na)), Llet(Alias, Pgenval, env1', - (if !new_ids_init = [] then Lvar env1 else lfield env1 0), + (if !new_ids_init = [] then Lvar env1 else lfield env1 0 ~fld_info:(if !Config.bs_only then assert false else Lambda.fld_na)), lam)) in @@ -829,17 +828,17 @@ let transl_class ids cl_id pub_meths cl vflag = [Lvar tables; Lprim(Pmakeblock(0, Lambda.Blk_array, Immutable, None), inh_keys, Location.none)]), lam) - and lset cached i lam = - Lprim(Psetfield(i, Pointer, Assignment, Fld_set_na), + and lset cached lam = + Lprim(Psetfield(0, Pointer, Assignment, Lambda.Fld_record_inline_set "key"), [Lvar cached; lam], Location.none) in let ldirect () = ltable cla (Llet(Strict, Pgenval, env_init, def_ids cla cl_init, Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), - lset cached 0 (Lvar env_init)))) + lset cached (Lvar env_init)))) and lclass_virt () = - lset cached 0 (Lfunction{kind = Curried; attr = default_function_attribute; + lset cached (Lfunction{kind = Curried; attr = default_function_attribute; loc = Location.none; params = [cla]; body = def_ids cla cl_init}) in @@ -856,19 +855,19 @@ let transl_class ids cl_id pub_meths cl vflag = so that the program's behaviour does not change between runs *) lupdate_cache else - Lifthenelse(lfield cached 0, lambda_unit, lupdate_cache) in + Lifthenelse(lfield ~fld_info:(Fld_record_inline {name = "key"}) cached 0, lambda_unit, lupdate_cache) in llets ( lcache ( Lsequence(lcheck_cache, make_envs ( - if ids = [] then mkappl (lfield cached 0, [lenvs]) else + if ids = [] then mkappl (lfield ~fld_info:(Fld_record_inline {name = "key"}) cached 0, [lenvs]) else Lprim(Pmakeblock(0, Lambda.Blk_class, Immutable, None), (if concrete then - [mkappl (lfield cached 0, [lenvs]); - lfield cached 1; - lfield cached 0; + [mkappl (lfield ~fld_info:(Fld_record_inline {name = "key"}) cached 0, [lenvs]); + lfield ~fld_info:(Fld_record_inline {name = "data"}) cached 1; + lfield ~fld_info:(Fld_record_inline {name = "key"}) cached 0; lenvs] - else [lambda_unit; lfield cached 0; lambda_unit; lenvs]), + else [lambda_unit; lfield ~fld_info:(Fld_record_inline {name = "key"}) cached 0; lambda_unit; lenvs]), Location.none ))))) diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index e5433f21e19a..2b77d466a7f3 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -30,7 +30,7 @@ type error = | Unreachable_reached exception Error of Location.t * error - +let wrap_single_field_record = ref (fun _ _ lam -> lam) let use_dup_for_constant_arrays_bigger_than = 4 (* Forward declaration -- to be filled in by Translmod.transl_module *) @@ -58,9 +58,11 @@ let transl_extension_constructor env path ext = match ext.ext_kind with Text_decl _ -> let tag_info = Blk_extension_slot in + let ext_name = Lconst (Const_base (Const_string (name, None))) in Lprim (Pmakeblock (Obj.object_tag, tag_info, Immutable, None), - [Lconst (Const_base (Const_string (name, None))); - Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)], + (if !Config.bs_only then [ ext_name ] + else [ ext_name; + Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)]), loc) | Text_rebind(path, _lid) -> transl_extension_path ~loc env path @@ -269,9 +271,10 @@ let comparisons_table = Lazy.from_fun @@ fun _ -> ] let gen_array_kind = - if not !Config.bs_only && Config.flat_float_array then Pgenarray else Paddrarray + if Config.flat_float_array then Pgenarray else Paddrarray -let primitives_table = create_hashtable 57 [ +let primitives_table = lazy ( if !Config.bs_only then +create_hashtable 57 [ "%identity", Pidentity; "%bytes_to_string", Pbytes_to_string; "%bytes_of_string", Pbytes_of_string; @@ -283,12 +286,152 @@ let primitives_table = create_hashtable 57 [ "%loc_LINE", Ploc Loc_LINE; "%loc_POS", Ploc Loc_POS; "%loc_MODULE", Ploc Loc_MODULE; - "%field0", Pfield (0, Fld_na); + (* BEGIN Triples for ref data type *) + "%bs_ref_setfield0", Psetfield(0, Pointer, Assignment, Lambda.ref_field_set_info); "%bs_ref_field0", Pfield(0, Lambda.ref_field_info); - "%field1", Pfield (1, Fld_na); + "%makemutable", Pmakeblock(0, Lambda.ref_tag_info, Mutable, None); + "%incr", Poffsetref(1); + "%decr", Poffsetref(-1); + (* Finish Triples for ref data type *) + + "%field0", Pfield (0, Fld_tuple); + "%field1", Pfield (1, Fld_tuple); + "%obj_field", Parrayrefu Pgenarray; + "%obj_set_field", Parraysetu Pgenarray; + "%obj_is_int", Pisint; + "%raise", Praise Raise_regular; + "%reraise", Praise Raise_reraise; + "%raise_notrace", Praise Raise_notrace; + "%sequand", Psequand; + "%sequor", Psequor; + "%boolnot", Pnot; + "%big_endian", Pctconst Big_endian; + "%backend_type", Pctconst Backend_type; + "%word_size", Pctconst Word_size; + "%int_size", Pctconst Int_size; + "%max_wosize", Pctconst Max_wosize; + "%ostype_unix", Pctconst Ostype_unix; + "%ostype_win32", Pctconst Ostype_win32; + "%ostype_cygwin", Pctconst Ostype_cygwin; + "%negint", Pnegint; + "%succint", Poffsetint 1; + "%predint", Poffsetint(-1); + "%addint", Paddint; + "%subint", Psubint; + "%mulint", Pmulint; + "%divint", Pdivint Safe; + "%modint", Pmodint Safe; + "%andint", Pandint; + "%orint", Porint; + "%xorint", Pxorint; + "%lslint", Plslint; + "%lsrint", Plsrint; + "%asrint", Pasrint; + "%eq", Pintcomp Ceq; + "%noteq", Pintcomp Cneq; + "%ltint", Pintcomp Clt; + "%leint", Pintcomp Cle; + "%gtint", Pintcomp Cgt; + "%geint", Pintcomp Cge; + "%intoffloat", Pintoffloat; + "%floatofint", Pfloatofint; + "%negfloat", Pnegfloat; + "%absfloat", Pabsfloat; + "%addfloat", Paddfloat; + "%subfloat", Psubfloat; + "%mulfloat", Pmulfloat; + "%divfloat", Pdivfloat; + "%eqfloat", Pfloatcomp Ceq; + "%noteqfloat", Pfloatcomp Cneq; + "%ltfloat", Pfloatcomp Clt; + "%lefloat", Pfloatcomp Cle; + "%gtfloat", Pfloatcomp Cgt; + "%gefloat", Pfloatcomp Cge; + "%string_length", Pstringlength; + "%string_safe_get", Pstringrefs; + "%string_unsafe_get", Pstringrefu; + "%bytes_length", Pbyteslength; + "%bytes_safe_get", Pbytesrefs; + "%bytes_safe_set", Pbytessets; + "%bytes_unsafe_get", Pbytesrefu; + "%bytes_unsafe_set", Pbytessetu; + "%array_length", Parraylength Pgenarray; + "%array_safe_get", Parrayrefs Pgenarray; + "%array_safe_set", Parraysets Pgenarray; + "%array_unsafe_get", Parrayrefu Pgenarray; + "%array_unsafe_set", Parraysetu Pgenarray; + "%floatarray_length", Parraylength Pfloatarray; + "%floatarray_safe_get", Parrayrefs Pfloatarray; + "%floatarray_safe_set", Parraysets Pfloatarray; + "%floatarray_unsafe_get", Parrayrefu Pfloatarray; + "%floatarray_unsafe_set", Parraysetu Pfloatarray; + "%lazy_force", Plazyforce; + "%nativeint_of_int", Pbintofint Pnativeint; + "%nativeint_to_int", Pintofbint Pnativeint; + "%nativeint_neg", Pnegbint Pnativeint; + "%nativeint_add", Paddbint Pnativeint; + "%nativeint_sub", Psubbint Pnativeint; + "%nativeint_mul", Pmulbint Pnativeint; + "%nativeint_div", Pdivbint { size = Pnativeint; is_safe = Safe }; + "%nativeint_mod", Pmodbint { size = Pnativeint; is_safe = Safe }; + "%nativeint_and", Pandbint Pnativeint; + "%nativeint_or", Porbint Pnativeint; + "%nativeint_xor", Pxorbint Pnativeint; + "%nativeint_lsl", Plslbint Pnativeint; + "%nativeint_lsr", Plsrbint Pnativeint; + "%nativeint_asr", Pasrbint Pnativeint; + "%int32_of_int", Pbintofint Pint32; + "%int32_to_int", Pintofbint Pint32; + "%int32_neg", Pnegbint Pint32; + "%int32_add", Paddbint Pint32; + "%int32_sub", Psubbint Pint32; + "%int32_mul", Pmulbint Pint32; + "%int32_div", Pdivbint { size = Pint32; is_safe = Safe }; + "%int32_mod", Pmodbint { size = Pint32; is_safe = Safe }; + "%int32_and", Pandbint Pint32; + "%int32_or", Porbint Pint32; + "%int32_xor", Pxorbint Pint32; + "%int32_lsl", Plslbint Pint32; + "%int32_lsr", Plsrbint Pint32; + "%int32_asr", Pasrbint Pint32; + "%int64_of_int", Pbintofint Pint64; + "%int64_to_int", Pintofbint Pint64; + "%int64_neg", Pnegbint Pint64; + "%int64_add", Paddbint Pint64; + "%int64_sub", Psubbint Pint64; + "%int64_mul", Pmulbint Pint64; + "%int64_div", Pdivbint { size = Pint64; is_safe = Safe }; + "%int64_mod", Pmodbint { size = Pint64; is_safe = Safe }; + "%int64_and", Pandbint Pint64; + "%int64_or", Porbint Pint64; + "%int64_xor", Pxorbint Pint64; + "%int64_lsl", Plslbint Pint64; + "%int64_lsr", Plsrbint Pint64; + "%int64_asr", Pasrbint Pint64; + "%nativeint_of_int32", Pcvtbint(Pint32, Pnativeint); + "%nativeint_to_int32", Pcvtbint(Pnativeint, Pint32); + "%int64_of_int32", Pcvtbint(Pint32, Pint64); + "%int64_to_int32", Pcvtbint(Pint64, Pint32); + "%int64_of_nativeint", Pcvtbint(Pnativeint, Pint64); + "%int64_to_nativeint", Pcvtbint(Pint64, Pnativeint); + "%opaque", Popaque; +] +else create_hashtable 57 [ + "%identity", Pidentity; + "%bytes_to_string", Pbytes_to_string; + "%bytes_of_string", Pbytes_of_string; + "%ignore", Pignore; + "%revapply", Prevapply; + "%apply", Pdirapply; + "%loc_LOC", Ploc Loc_LOC; + "%loc_FILE", Ploc Loc_FILE; + "%loc_LINE", Ploc Loc_LINE; + "%loc_POS", Ploc Loc_POS; + "%loc_MODULE", Ploc Loc_MODULE; + "%field0", Pfield (0, Lambda.fld_na (*IRRELEVANT*)); + "%field1", Pfield (1, Lambda.fld_na (*IRRELEVANT*)); "%setfield0", Psetfield(0, Pointer, Assignment, Fld_set_na); - "%bs_ref_setfield0", Psetfield(0, Pointer, Assignment, Lambda.ref_field_set_info); - "%makeblock", Pmakeblock(0, Lambda.default_tag_info, Immutable, None); + "%makeblock", Pmakeblock(0, Lambda.default_tag_info (*IRRELEVANT*), Immutable, None); "%makemutable", Pmakeblock(0, Lambda.ref_tag_info, Mutable, None); "%raise", Praise Raise_regular; "%reraise", Praise Raise_reraise; @@ -470,10 +613,10 @@ let primitives_table = create_hashtable 57 [ "%bswap_native", Pbbswap(Pnativeint); "%int_as_pointer", Pint_as_pointer; "%opaque", Popaque; -] +]) let find_primitive prim_name = - Hashtbl.find primitives_table prim_name + Hashtbl.find (Lazy.force primitives_table) prim_name let prim_restore_raw_backtrace = Primitive.simple ~name:"caml_restore_raw_backtrace" ~arity:2 ~alloc:false @@ -982,7 +1125,7 @@ and transl_exp0 e = | Longident.Lident "None" when Datarepr.constructor_has_optional_shape cstr -> Pt_shape_none - | _ -> (Lambda.Pt_constructor {name = cstr.cstr_name; cstrs = cstr.cstr_consts,cstr.cstr_nonconsts}) + | _ -> Pt_constructor {name = cstr.cstr_name; const = cstr.cstr_consts; non_const = cstr.cstr_nonconsts} )) | Cstr_unboxed -> (match ll with [v] -> v | _ -> assert false) @@ -998,14 +1141,14 @@ and transl_exp0 e = | _ -> Blk_some end - else (Lambda.Blk_constructor (cstr.cstr_name, cstr.cstr_nonconsts)) in + else Blk_constructor {name = cstr.cstr_name; num_nonconst = cstr.cstr_nonconsts} in begin try Lconst(Const_block(n, tag_info, List.map extract_constant ll)) with Not_constant -> Lprim(Pmakeblock(n, tag_info, Immutable, Some shape), ll, e.exp_loc) end | Cstr_extension(path, is_const) -> - if is_const then + if not !Config.bs_only && is_const then transl_extension_path e.exp_env path else Lprim(Pmakeblock(0, Blk_extension, Immutable, Some (Pgenval :: shape)), @@ -1192,6 +1335,9 @@ and transl_exp0 e = (* when e needs no computation (constants, identifiers, ...), we optimize the translation just as Lazy.lazy_from_val would do *) + if !Config.bs_only then + Lprim(Pmakeblock(Config.lazy_tag, Blk_lazy_general, Mutable, None), [transl_exp e], e.exp_loc) + else begin match Typeopt.classify_lazy_argument e with | `Constant_or_function -> (* a constant expr of type <> float gets compiled as itself *) @@ -1199,7 +1345,7 @@ and transl_exp0 e = | `Float -> (* We don't need to wrap with Popaque: this forward block will never be shortcutted since it points to a float. *) - Lprim(Pmakeblock(Obj.forward_tag, Lambda.Blk_lazy_forward, Immutable, None), + Lprim(Pmakeblock(Obj.forward_tag, Lambda.default_tag_info (*IIRELEVANT*), Immutable, None), [transl_exp e], e.exp_loc) | `Identifier `Forward_value -> (* CR-someday mshinwell: Consider adding a new primitive @@ -1209,7 +1355,7 @@ and transl_exp0 e = block doesn't really match what is going on here. This value may subsequently turn into an immediate... *) Lprim (Popaque, - [Lprim(Pmakeblock(Obj.forward_tag, Lambda.Blk_lazy_forward, Immutable, None), + [Lprim(Pmakeblock(Obj.forward_tag, Lambda.default_tag_info (*IIRELEVANT*), Immutable, None), [transl_exp e], e.exp_loc)], e.exp_loc) | `Identifier `Other -> @@ -1220,7 +1366,7 @@ and transl_exp0 e = attr = default_function_attribute; loc = e.exp_loc; body = transl_exp e} in - Lprim(Pmakeblock(Config.lazy_tag, Lambda.Blk_lazy_general, Mutable, None), [fn], e.exp_loc) + Lprim(Pmakeblock(Config.lazy_tag, Lambda.default_tag_info (*IIRELEVANT*), Mutable, None), [fn], e.exp_loc) end | Texp_object (cs, meths) -> let cty = cs.cstr_type in @@ -1420,6 +1566,11 @@ and transl_setinstvar loc self var expr = [self; transl_normal_path var; transl_exp expr], loc) and transl_record loc env fields repres opt_init_expr = + match opt_init_expr, repres, fields with + | None, Record_unboxed _, [|{lbl_name; lbl_loc}, Overridden (_,expr)|] + -> + !wrap_single_field_record lbl_loc lbl_name (transl_exp expr) + | _ -> let size = Array.length fields in (* Determine if there are "enough" fields (only relevant if this is a functional-style record update *) diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index 75c26f8d1e5b..0671ce698c77 100644 --- a/bytecomp/translcore.mli +++ b/bytecomp/translcore.mli @@ -20,6 +20,13 @@ open Asttypes open Typedtree open Lambda +val wrap_single_field_record : + ( + Location.t -> + string -> + lambda -> + lambda) ref + val transl_exp: expression -> lambda val transl_apply: ?should_be_tailcall:bool -> ?inlined:inline_attribute diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 575d1b105cc5..21dc73fb0900 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -190,25 +190,8 @@ let record_primitive = function | _ -> () (* Utilities for compiling "module rec" definitions *) -let bs_init_mod args loc : Lambda.lambda = - Lprim(Pccall (Primitive.simple - ~name:"#init_mod" - ~arity:2 - ~alloc:true), args, loc) -let bs_update_mod args loc : Lambda.lambda = - Lprim(Pccall (Primitive.simple - ~name:"#update_mod" - ~arity:3 - ~alloc:true), args, loc) let mod_prim name args loc = - if !Config.bs_only then - if name = "init_mod" then - bs_init_mod args loc - else if name = "update_mod" then - bs_update_mod args loc - else assert false - else try Lapply { @@ -233,14 +216,15 @@ let undefined_location loc = [Const_base(Const_string (fname, None)); Const_base(Const_int line); Const_base(Const_int char)])) -let cstrs = (3,2) +let cstr_const = 3 +let cstr_non_const = 2 let init_shape modl = let add_name x id = if !Config.bs_only then Const_block (0, Blk_tuple, [x; Const_base (Const_string (Ident.name id, None))]) else x in - let module_tag_info : Lambda.tag_info = Blk_constructor ("Module",2) in - let value_tag_info : Lambda.tag_info = Blk_constructor("value",2) in + let module_tag_info : Lambda.tag_info = Blk_constructor {name = "Module"; num_nonconst = 2} in + let value_tag_info : Lambda.tag_info = Blk_constructor { name = "value"; num_nonconst = 2} in let rec init_shape_mod env mty = match Mtype.scrape env mty with Mty_ident _ -> @@ -258,9 +242,9 @@ let init_shape modl = let init_v = match Ctype.expand_head env ty with {desc = Tarrow(_,_,_,_)} -> - Const_pointer (0, Pt_constructor{name = "Function"; cstrs}) + Const_pointer (0, Pt_constructor{name = "Function"; const = cstr_const; non_const = cstr_non_const}) | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t -> - Const_pointer (1, Pt_constructor{name = "Lazy"; cstrs}) + Const_pointer (1, Pt_constructor{name = "Lazy"; const = cstr_const; non_const = cstr_non_const}) | _ -> raise Not_found in (add_name init_v id) :: init_shape_struct env rem | Sig_value(_, {val_kind=Val_prim _}) :: rem -> @@ -278,7 +262,7 @@ let init_shape modl = | Sig_modtype(id, minfo) :: rem -> init_shape_struct (Env.add_modtype id minfo env) rem | Sig_class (id,_,_) :: rem -> - (add_name (Const_pointer (2, Pt_constructor{name = "Class";cstrs})) id) + (add_name (Const_pointer (2, Pt_constructor{name = "Class";const = cstr_const; non_const = cstr_non_const})) id) :: init_shape_struct env rem | Sig_class_type _ :: rem -> init_shape_struct env rem @@ -354,8 +338,9 @@ let eval_rec_bindings bindings cont = in bind_inits bindings +let eval_rec_bindings = ref eval_rec_bindings let compile_recmodule compile_rhs bindings cont = - eval_rec_bindings + !eval_rec_bindings (reorder_rec_bindings (List.map (fun {mb_id=id; mb_expr=modl; mb_loc=loc; _} -> @@ -928,7 +913,7 @@ let transl_store_structure glob map prims str = Lsequence(lam, Llet(Strict, Pgenval, id, subst_lambda subst - (Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None), + (Lprim(Pmakeblock(0, Lambda.default_tag_info (*IIRELEVANT*), Immutable, None), List.map (fun id -> Lvar id) (defined_idents str.str_items), loc)), Lsequence(store_ident loc id, @@ -956,7 +941,7 @@ let transl_store_structure glob map prims str = Lsequence(lam, Llet(Strict, Pgenval, id, subst_lambda subst - (Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None), + (Lprim(Pmakeblock(0, Lambda.default_tag_info (*IIRELEVANT*), Immutable, None), List.map field map, loc)), Lsequence(store_ident loc id, transl_store rootpath @@ -1039,7 +1024,7 @@ let transl_store_structure glob map prims str = let rec store_idents pos = function [] -> transl_store rootpath (add_idents true ids subst) rem | id :: idl -> - Llet(Alias, Pgenval, id, Lprim(Pfield (pos, Fld_na), [Lvar mid], loc), + Llet(Alias, Pgenval, id, Lprim(Pfield (pos, Lambda.fld_na (*IRRELEVANT*)), [Lvar mid], loc), Lsequence(store_ident loc id, store_idents (pos + 1) idl)) in @@ -1071,7 +1056,7 @@ let transl_store_structure glob map prims str = match cc with Tcoerce_none -> Ident.add id - (Lprim(Pfield (pos, Fld_na), + (Lprim(Pfield (pos, Lambda.fld_na (*IRRELEVANT*)), [Lprim(Pgetglobal glob, [], Location.none)], Location.none)) subst @@ -1186,7 +1171,7 @@ let toplevel_name id = let toploop_getvalue id = Lapply{ap_should_be_tailcall=false; ap_loc=Location.none; - ap_func=Lprim(Pfield (toploop_getvalue_pos, Fld_na), + ap_func=Lprim(Pfield (toploop_getvalue_pos, Lambda.fld_na(*IRRELEVANT*)), [Lprim(Pgetglobal toploop_ident, [], Location.none)], Location.none); ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)))]; @@ -1196,7 +1181,7 @@ let toploop_getvalue id = let toploop_setvalue id lam = Lapply{ap_should_be_tailcall=false; ap_loc=Location.none; - ap_func=Lprim(Pfield (toploop_setvalue_pos, Fld_na), + ap_func=Lprim(Pfield (toploop_setvalue_pos, Lambda.fld_na(*IRRELEVANT*)), [Lprim(Pgetglobal toploop_ident, [], Location.none)], Location.none); ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None))); @@ -1265,7 +1250,7 @@ let transl_toplevel_item item = lambda_unit | id :: ids -> Lsequence(toploop_setvalue id - (Lprim(Pfield (pos, Fld_na), [Lvar mid], Location.none)), + (Lprim(Pfield (pos, Lambda.fld_na (*IRRELEVANT*)), [Lvar mid], Location.none)), set_idents (pos + 1) ids) in Llet(Strict, Pgenval, mid, transl_module Tcoerce_none None modl, set_idents 0 ids) @@ -1303,13 +1288,13 @@ let transl_package_flambda component_names coercion = in size, apply_coercion Location.none Strict coercion - (Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None), (*NOTE: not relevant in flambda *) + (Lprim(Pmakeblock(0, Lambda.default_tag_info (*IIRELEVANT*), Immutable, None), (*NOTE: not relevant in flambda *) List.map get_component component_names, Location.none)) let transl_package component_names target_name coercion = let components = - Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None), + Lprim(Pmakeblock(0, Lambda.default_tag_info (*IIRELEVANT*), Immutable, None), List.map get_component component_names, Location.none) in Lprim(Psetglobal target_name, [apply_coercion Location.none Strict coercion components], @@ -1347,7 +1332,7 @@ let transl_store_package component_names target_name coercion = 0 component_names) | Tcoerce_structure (pos_cc_list, _id_pos_list, _) -> let components = - Lprim(Pmakeblock(0, Lambda.default_tag_info, Immutable, None), + Lprim(Pmakeblock(0, Lambda.default_tag_info (*IIRELEVANT*), Immutable, None), List.map get_component component_names, Location.none) in @@ -1359,7 +1344,7 @@ let transl_store_package component_names target_name coercion = (fun pos _id -> Lprim(Psetfield(pos, Pointer, Root_initialization, Fld_set_na), [Lprim(Pgetglobal target_name, [], Location.none); - Lprim(Pfield (pos, Fld_na), [Lvar blk], Location.none)], + Lprim(Pfield (pos, Lambda.fld_na (*IRRELEVANT*)), [Lvar blk], Location.none)], Location.none)) 0 pos_cc_list)) (* diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli index 3986e754f865..5bea29e89d78 100644 --- a/bytecomp/translmod.mli +++ b/bytecomp/translmod.mli @@ -19,6 +19,10 @@ open Typedtree open Lambda +val eval_rec_bindings: + ((Ident.t * (Lambda.lambda * Lambda.lambda) option * Lambda.lambda) list -> + Lambda.lambda -> Lambda.lambda) ref + val transl_implementation: string -> structure * module_coercion -> Lambda.program val transl_store_phrases: string -> structure -> int * lambda diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index 9284564a39f1..af96a6b1bd46 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -132,7 +132,7 @@ let transl_label_init_flambda f = let transl_store_label_init glob size f arg = assert(not Config.flambda); assert(!Clflags.native_code); - method_cache := Lprim(Pfield (size, Fld_na), + method_cache := Lprim(Pfield (size, Lambda.fld_na (*IRRELEVANT*)), [Lprim(Pgetglobal glob, [], Location.none)], Location.none); let expr = f arg in @@ -184,7 +184,7 @@ let oo_wrap env req f x = List.fold_left (fun lambda id -> Llet(StrictOpt, Pgenval, id, - Lprim(Pmakeblock(0, Lambda.Blk_constructor ("Cons",1), Mutable, None), + Lprim(Pmakeblock(0, Blk_record_inlined {name = "Cons"; num_nonconst = 1; fields = [|"key";"data";"next"|]}, Mutable, None), [lambda_unit; lambda_unit; lambda_unit], Location.none), lambda)) diff --git a/clone-flexdll b/clone-flexdll new file mode 100755 index 000000000000..fbeb13c607ae --- /dev/null +++ b/clone-flexdll @@ -0,0 +1,16 @@ +#! /bin/sh + +# clone-flexdll +# +# Brings in flexdll, if necessary + +if [ -d "flexdll" ]; then + echo "[Flexdll] Already present, no need to clone." +else + echo "[Flexdll] Cloning..." + git clone https://github.com/esy-ocaml/flexdll.git + cd flexdll + git checkout f84baaeae463f96f9582883a9cfb7dd1096757ff + cd .. + echo "[Flexdll] Clone successful!" +fi diff --git a/config/Makefile.mingw64 b/config/Makefile.mingw64 index 0466e63c0b60..8403fef58af1 100644 --- a/config/Makefile.mingw64 +++ b/config/Makefile.mingw64 @@ -32,7 +32,7 @@ BINDIR=$(PREFIX)/bin BYTERUN=ocamlrun ### Where to install the standard library -LIBDIR=$(PREFIX)/lib +LIBDIR=$(PREFIX)/lib/ocaml ### Where to install the stub DLLs STUBLIBDIR=$(LIBDIR)/stublibs diff --git a/configure-windows b/configure-windows new file mode 100755 index 000000000000..ae6ca8ce6672 --- /dev/null +++ b/configure-windows @@ -0,0 +1,34 @@ +#! /bin/sh + +# configure-windows +# +# Creates a native Windows MingW build, based on: +# https://github.com/ocaml/ocaml/blob/trunk/README.win32.adoc + + +export prefix=C:/ocamlmgw64 +while : ; do + case "$1" in + "") break;; + -prefix|--prefix) + prefix=$2; shift;; + esac + shift +done + +echo "[configure-windows] Prefix path: $prefix" + +echo "[configure-windows] Copying architecture headers." +cp config/m-nt.h byterun/caml/m.h +cp config/s-nt.h byterun/caml/s.h + +# TODO: Differentiate based on architecture - use 'Makefile.mingw' for 32-bit environments +echo "[configure-windows] Bringing over mingw64 Makefile." +cp config/Makefile.mingw64 config/Makefile + +echo "[configure-windows] Replace prefix path with: $prefix." +sed -i "s#PREFIX=C:/ocamlmgw64#PREFIX=$prefix#g" config/Makefile + +echo "[configure-windows] Setting up flexdll" +./clone-flexdll +make flexdll diff --git a/driver/compenv.ml b/driver/compenv.ml index 210ac9aea9ed..27e850add348 100644 --- a/driver/compenv.ml +++ b/driver/compenv.ml @@ -549,7 +549,7 @@ let get_objfiles ~with_ocamlparam = - +#if undefined BS_ONLY then type deferred_action = | ProcessImplementation of string | ProcessInterface of string @@ -645,3 +645,4 @@ let process_deferred_actions env = fatal "Option -a cannot be used with .cmxa input files."; List.iter (process_action env) (List.rev !deferred_actions); output_name := final_output_name; +#end \ No newline at end of file diff --git a/driver/compenv.mli b/driver/compenv.mli index 0ee9871a6ce8..952ed6f5eef2 100644 --- a/driver/compenv.mli +++ b/driver/compenv.mli @@ -51,7 +51,7 @@ val is_unit_name : string -> bool (* [check_unit_name ppf filename name] prints a warning in [filename] on [ppf] if [name] should not be used as a module name. *) val check_unit_name : Format.formatter -> string -> string -> unit - +#if undefined BS_ONLY then (* Deferred actions of the compiler, while parsing arguments *) type deferred_action = @@ -69,6 +69,7 @@ val anonymous : string -> unit val impl : string -> unit val intf : string -> unit + val process_deferred_actions : Format.formatter * (Format.formatter -> string -> string -> unit) * (* compile implementation *) @@ -76,3 +77,4 @@ val process_deferred_actions : string * (* ocaml module extension *) string -> (* ocaml library extension *) unit +#end \ No newline at end of file diff --git a/esy-build b/esy-build new file mode 100755 index 000000000000..789edc99874e --- /dev/null +++ b/esy-build @@ -0,0 +1,24 @@ +#! /bin/bash + +# esy-build +# +# Wrapper to execute appropriate build strategy, based on platform + +set -u +set -e +set -o pipefail + +case "$(uname -s)" in + CYGWIN*|MINGW32*|MSYS*) + echo "[esy-build] Detected windows environment..." + make -j1 world.opt + make flexlink.opt + ;; + *) + echo "[esy-build] Detected OSX / Linux environment" + make -j4 world.opt + ;; +esac + +# Common build steps +make install diff --git a/esy-configure b/esy-configure new file mode 100755 index 000000000000..85a8d2da80c1 --- /dev/null +++ b/esy-configure @@ -0,0 +1,29 @@ +#! /bin/bash + +# esy-configure +# +# Wrapper to delegate to configuration to the +# appropriate `configure` strategy based on the active platform. +# +# Today, OCaml has separate build strategies: +# - Linux, OSX, Cygwin (gcc) - https://github.com/ocaml/ocaml/blob/trunk/INSTALL.adoc +# - Windows, Cygin (mingw) - https://github.com/ocaml/ocaml/blob/trunk/README.win32.adoc +# +# We want `esy` to work cross-platform, so this is a shim script that will delegate to the +# appropriate script depending on the platform. We assume that if the platform is `CYGWIN` +# that the `mingw` (native executable) strategy is desired. + +set -u +set -e +set -o pipefail + +case "$(uname -s)" in + CYGWIN*|MINGW32*|MSYS*) + echo "[esy-configure] Detected windows environment..." + ./configure-windows "$@" + ;; + *) + echo "[esy-configure] Detected OSX / Linux environment" + ./configure "$@" + ;; +esac diff --git a/flexdll b/flexdll deleted file mode 160000 index 7f565ef8647a..000000000000 --- a/flexdll +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 7f565ef8647a16e6a2cd2b30c8e6a4894558eaaa diff --git a/middle_end/closure_conversion.ml b/middle_end/closure_conversion.ml index d139d7441104..c9b5b4fac846 100755 --- a/middle_end/closure_conversion.ml +++ b/middle_end/closure_conversion.ml @@ -91,7 +91,7 @@ let tupled_function_call_stub original_params unboxed_version let _, body = List.fold_left (fun (pos, body) param -> let lam : Flambda.named = - Prim (Pfield (pos, Fld_na), [tuple_param_var], Debuginfo.none) + Prim (Pfield (pos, Lambda.fld_na), [tuple_param_var], Debuginfo.none) in pos + 1, Flambda.create_let param lam body) (0, call) params @@ -673,9 +673,9 @@ let lambda_to_flambda ~backend ~module_ident ~size ~filename lam Flambda.create_let sym_v (Symbol block_symbol) (Flambda.create_let result_v - (Prim (Pfield (0, Fld_na), [sym_v], Debuginfo.none)) + (Prim (Pfield (0, Lambda.fld_na), [sym_v], Debuginfo.none)) (Flambda.create_let value_v - (Prim (Pfield (pos, Fld_na), [result_v], Debuginfo.none)) + (Prim (Pfield (pos, Lambda.fld_na), [result_v], Debuginfo.none)) (Var value_v)))) in let module_initializer : Flambda.program_body = diff --git a/middle_end/flambda_utils.ml b/middle_end/flambda_utils.ml index f8632934ecab..5724cacfc8e4 100644 --- a/middle_end/flambda_utils.ml +++ b/middle_end/flambda_utils.ml @@ -554,7 +554,7 @@ let substitute_read_symbol_field_for_variables Expr ( Flambda.create_let block (make_named t) (Flambda.create_let field - (Prim (Pfield (h, Fld_na), [block], Debuginfo.none)) + (Prim (Pfield (h, Lambda.fld_na), [block], Debuginfo.none)) (Var field))) in Flambda.create_let fresh_var (make_named path) expr @@ -914,7 +914,7 @@ let projection_to_named (projection : Projection.t) : Flambda.named = | Project_closure project_closure -> Project_closure project_closure | Move_within_set_of_closures move -> Move_within_set_of_closures move | Field (field_index, var) -> - Prim (Pfield (field_index, Fld_na), [var], Debuginfo.none) + Prim (Pfield (field_index, Lambda.fld_na), [var], Debuginfo.none) type specialised_to_same_as = | Not_specialised diff --git a/package.json b/package.json index 719b5aa920b8..c6f8e1ad05c3 100644 --- a/package.json +++ b/package.json @@ -4,11 +4,50 @@ "description": "BuckleScript's OCaml Compiler as an npm Package", "esy": { "build": [ - "./configure -no-cfi -prefix $cur__install", - "make -j world.opt" - ], - "install": [ - "make install" + "./esy-configure -no-cfi -prefix #{self.install}", + "./esy-build", + [ + "cp", + "-r", + "-f", + "#{self.root / 'utils'}", + "#{self.install / 'utils'}" + ], + [ + "cp", + "-r", + "-f", + "#{self.root / 'parsing'}", + "#{self.install / 'parsing'}" + ], + [ + "cp", + "-r", + "-f", + "#{self.root / 'typing'}", + "#{self.install / 'typing'}" + ], + [ + "cp", + "-r", + "-f", + "#{self.root / 'bytecomp'}", + "#{self.install / 'bytecomp'}" + ], + [ + "cp", + "-r", + "-f", + "#{self.root / 'driver'}", + "#{self.install / 'driver'}" + ], + [ + "cp", + "-r", + "-f", + "#{self.root / 'tools'}", + "#{self.install / 'tools'}" + ] ], "buildsInSource": true, "exportedEnv": { diff --git a/parsing/builtin_attributes.ml b/parsing/builtin_attributes.ml index 7a3d92a16132..e0de1b0e670b 100755 --- a/parsing/builtin_attributes.ml +++ b/parsing/builtin_attributes.ml @@ -110,8 +110,8 @@ let check_bs_attributes_inclusion = None ) -let check_duplicated_labels = ref (fun _lbls -> - failwith "check_duplicated_label not implemented" +let check_duplicated_labels : (_ -> _ option ) ref = ref (fun _lbls -> + None ) let rec deprecated_of_sig = function diff --git a/parsing/lexer.mli b/parsing/lexer.mli index 1d284a63da29..16da20297802 100644 --- a/parsing/lexer.mli +++ b/parsing/lexer.mli @@ -42,10 +42,7 @@ type error = exception Error of error * Location.t -open Format -val report_error: formatter -> error -> unit - (* Deprecated. Use Location.{error_of_exn, report_error}. *) val in_comment : unit -> bool;; val in_string : unit -> bool;; diff --git a/parsing/location.ml b/parsing/location.ml index 7ab5e86c5e8d..30a9d1b75678 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -72,154 +72,10 @@ let set_input_name name = if name <> "" then input_name := name (* Terminal info *) -let status = ref Terminfo.Uninitialised +(* let status = ref Terminfo.Uninitialised *) let num_loc_lines = ref 0 (* number of lines already printed after input *) -let print_updating_num_loc_lines ppf f arg = - let open Format in - let out_functions = pp_get_formatter_out_functions ppf () in - let out_string str start len = - let rec count i c = - if i = start + len then c - else if String.get str i = '\n' then count (succ i) (succ c) - else count (succ i) c in - num_loc_lines := !num_loc_lines + count start 0 ; - out_functions.out_string str start len in - pp_set_formatter_out_functions ppf - { out_functions with out_string } ; - f ppf arg ; - pp_print_flush ppf (); - pp_set_formatter_out_functions ppf out_functions - -(* Highlight the locations using standout mode. *) - -let highlight_terminfo ppf num_lines lb locs = - Format.pp_print_flush ppf (); (* avoid mixing Format and normal output *) - (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *) - let pos0 = -lb.lex_abs_pos in - (* Do nothing if the buffer does not contain the whole phrase. *) - if pos0 < 0 then raise Exit; - (* Count number of lines in phrase *) - let lines = ref !num_loc_lines in - for i = pos0 to lb.lex_buffer_len - 1 do - if Bytes.get lb.lex_buffer i = '\n' then incr lines - done; - (* If too many lines, give up *) - if !lines >= num_lines - 2 then raise Exit; - (* Move cursor up that number of lines *) - flush stdout; Terminfo.backup !lines; - (* Print the input, switching to standout for the location *) - let bol = ref false in - print_string "# "; - for pos = 0 to lb.lex_buffer_len - pos0 - 1 do - if !bol then (print_string " "; bol := false); - if List.exists (fun loc -> pos = loc.loc_start.pos_cnum) locs then - Terminfo.standout true; - if List.exists (fun loc -> pos = loc.loc_end.pos_cnum) locs then - Terminfo.standout false; - let c = Bytes.get lb.lex_buffer (pos + pos0) in - print_char c; - bol := (c = '\n') - done; - (* Make sure standout mode is over *) - Terminfo.standout false; - (* Position cursor back to original location *) - Terminfo.resume !num_loc_lines; - flush stdout - -(* Highlight the location by printing it again. *) - -let highlight_dumb ppf lb loc = - (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *) - let pos0 = -lb.lex_abs_pos in - (* Do nothing if the buffer does not contain the whole phrase. *) - if pos0 < 0 then raise Exit; - let end_pos = lb.lex_buffer_len - pos0 - 1 in - (* Determine line numbers for the start and end points *) - let line_start = ref 0 and line_end = ref 0 in - for pos = 0 to end_pos do - if Bytes.get lb.lex_buffer (pos + pos0) = '\n' then begin - if loc.loc_start.pos_cnum > pos then incr line_start; - if loc.loc_end.pos_cnum > pos then incr line_end; - end - done; - (* Print character location (useful for Emacs) *) - Format.fprintf ppf "@[Characters %i-%i:@," - loc.loc_start.pos_cnum loc.loc_end.pos_cnum; - (* Print the input, underlining the location *) - Format.pp_print_string ppf " "; - let line = ref 0 in - let pos_at_bol = ref 0 in - for pos = 0 to end_pos do - match Bytes.get lb.lex_buffer (pos + pos0) with - | '\n' -> - if !line = !line_start && !line = !line_end then begin - (* loc is on one line: underline location *) - Format.fprintf ppf "@, "; - for _i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do - Format.pp_print_char ppf ' ' - done; - for _i = loc.loc_start.pos_cnum to loc.loc_end.pos_cnum - 1 do - Format.pp_print_char ppf '^' - done - end; - if !line >= !line_start && !line <= !line_end then begin - Format.fprintf ppf "@,"; - if pos < loc.loc_end.pos_cnum then Format.pp_print_string ppf " " - end; - incr line; - pos_at_bol := pos + 1 - | '\r' -> () (* discard *) - | c -> - if !line = !line_start && !line = !line_end then - (* loc is on one line: print whole line *) - Format.pp_print_char ppf c - else if !line = !line_start then - (* first line of multiline loc: - print a dot for each char before loc_start *) - if pos < loc.loc_start.pos_cnum then - Format.pp_print_char ppf '.' - else - Format.pp_print_char ppf c - else if !line = !line_end then - (* last line of multiline loc: print a dot for each char - after loc_end, even whitespaces *) - if pos < loc.loc_end.pos_cnum then - Format.pp_print_char ppf c - else - Format.pp_print_char ppf '.' - else if !line > !line_start && !line < !line_end then - (* intermediate line of multiline loc: print whole line *) - Format.pp_print_char ppf c - done; - Format.fprintf ppf "@]" - -(* Highlight the location using one of the supported modes. *) - -let rec highlight_locations ppf locs = - match !status with - Terminfo.Uninitialised -> - status := Terminfo.setup stdout; highlight_locations ppf locs - | Terminfo.Bad_term -> - begin match !input_lexbuf with - None -> false - | Some lb -> - let norepeat = - try Sys.getenv "TERM" = "norepeat" with Not_found -> false in - if norepeat then false else - let loc1 = List.hd locs in - try highlight_dumb ppf lb loc1; true - with Exit -> false - end - | Terminfo.Good_term num_lines -> - begin match !input_lexbuf with - None -> false - | Some lb -> - try highlight_terminfo ppf num_lines lb locs; true - with Exit -> false - end - (* Print the location in some way or another *) open Format @@ -239,6 +95,7 @@ let absolute_path s = (* This function could go into Filename *) aux s let show_filename file = + let file = if file = "_none_" then !input_name else file in if !absname then absolute_path file else file let print_filename ppf file = @@ -261,13 +118,15 @@ let setup_colors () = let print_loc ppf loc = setup_colors (); let (file, line, startchar) = get_pos_info loc.loc_start in -#if undefined BS_NO_COMPILER_PATCH then +#if true then let startchar = if Clflags.bs_vscode then startchar + 1 else startchar in #end let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in if file = "//toplevel//" then begin +#if false then if highlight_locations ppf [loc] then () else +#end fprintf ppf "Characters %i-%i" loc.loc_start.pos_cnum loc.loc_end.pos_cnum end else begin @@ -280,9 +139,12 @@ let print_loc ppf loc = let default_printer ppf loc = setup_colors (); +#if false then if loc.loc_start.pos_fname = "//toplevel//" - && highlight_locations ppf [loc] then () - else fprintf ppf "@{%a@}%s@," print_loc loc msg_colon + && highlight_locations ppf [loc] then () + else +#end + fprintf ppf "@{%a@}%s@," print_loc loc msg_colon ;; let printer = ref default_printer @@ -297,9 +159,12 @@ let print_error_prefix ppf = ;; let print_compact ppf loc = +#if false then if loc.loc_start.pos_fname = "//toplevel//" && highlight_locations ppf [loc] then () - else begin + else +#end + begin let (file, line, startchar) = get_pos_info loc.loc_start in let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in fprintf ppf "%a:%i" print_filename file line; @@ -316,15 +181,11 @@ let print_error_cur_file ppf () = print_error ppf (in_file !input_name);; let default_warning_printer loc ppf w = match Warnings.report w with | `Inactive -> () - | `Active { Warnings. number; message; is_error; sub_locs } -> + | `Active { Warnings. number; message; sub_locs } -> setup_colors (); fprintf ppf "@["; print ppf loc; - if is_error - then - fprintf ppf "%t (%s %d): %s@," print_error_prefix - (String.uncapitalize_ascii warning_prefix) number message - else fprintf ppf "@{%s@} %d: %s@," warning_prefix number message; + fprintf ppf "@{%s@} %d: %s@," warning_prefix number message; List.iter (fun (loc, msg) -> if loc <> none then fprintf ppf " %a %s@," print loc msg @@ -335,8 +196,8 @@ let default_warning_printer loc ppf w = let warning_printer = ref default_warning_printer ;; -let print_warning loc ppf w = - print_updating_num_loc_lines ppf (!warning_printer loc) w +let print_warning loc ppf w = + !warning_printer loc ppf w ;; let formatter_for_warnings = ref err_formatter;; @@ -412,29 +273,16 @@ let error_of_exn exn = in loop !error_of_exn -let rec default_error_reporter ppf ({loc; msg; sub; if_highlight} as err) = - let highlighted = - if if_highlight <> "" && loc.loc_start.pos_fname = "//toplevel//" then - let rec collect_locs locs {loc; sub; _} = - List.fold_left collect_locs (loc :: locs) sub - in - let locs = collect_locs [] err in - highlight_locations ppf locs - else - false - in - if highlighted then - Format.pp_print_string ppf if_highlight - else begin + +let rec default_error_reporter ppf ({loc; msg; sub}) = fprintf ppf "@[%a %s" print_error loc msg; List.iter (Format.fprintf ppf "@,@[<2>%a@]" default_error_reporter) sub; fprintf ppf "@]" - end - + let error_reporter = ref default_error_reporter let report_error ppf err = - print_updating_num_loc_lines ppf !error_reporter err + !error_reporter ppf err ;; let error_of_printer loc print x = diff --git a/parsing/location.mli b/parsing/location.mli index f4bc64e0f43d..1fb36beac97b 100644 --- a/parsing/location.mli +++ b/parsing/location.mli @@ -58,8 +58,10 @@ val get_pos_info: Lexing.position -> string * int * int (* file, line, char *) val print_loc: formatter -> t -> unit val print_error: formatter -> t -> unit val print_error_cur_file: formatter -> unit -> unit +#if undefined BS_ONLY then val print_warning: t -> formatter -> Warnings.t -> unit val formatter_for_warnings : formatter ref +#end val prerr_warning: t -> Warnings.t -> unit val echo_eof: unit -> unit val reset: unit -> unit @@ -73,8 +75,6 @@ val warning_printer : (t -> formatter -> Warnings.t -> unit) ref val default_warning_printer : t -> formatter -> Warnings.t -> unit (** Original warning printer for use in hooks. *) -val highlight_locations: formatter -> t list -> bool - type 'a loc = { txt : 'a; loc : t; @@ -111,7 +111,7 @@ exception Error of error val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error -#if undefined BS_NO_COMPILER_PATCH then +#if true then val print_error_prefix : Format.formatter -> unit val pp_ksprintf : ?before:(formatter -> unit) -> (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b #end diff --git a/typing/ctype.ml b/typing/ctype.ml index df46de1f6763..357aaa981d84 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -397,10 +397,11 @@ let rec class_type_arity = (*******************************************) (* Miscellaneous operations on row types *) (*******************************************) +type row_fields = (Asttypes.label * Types.row_field) list +type row_pairs = (Asttypes.label * Types.row_field * Types.row_field) list +let sort_row_fields : row_fields -> row_fields = List.sort (fun (p,_) (q,_) -> compare (p : string) q) -let sort_row_fields = List.sort (fun (p,_) (q,_) -> compare p q) - -let rec merge_rf r1 r2 pairs fi1 fi2 = +let rec merge_rf (r1 : row_fields) (r2 : row_fields) (pairs : row_pairs) (fi1 : row_fields) (fi2 : row_fields) = match fi1, fi2 with (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' -> if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else @@ -409,7 +410,7 @@ let rec merge_rf r1 r2 pairs fi1 fi2 = | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs) | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs) -let merge_row_fields fi1 fi2 = +let merge_row_fields (fi1 : row_fields) (fi2 : row_fields) : row_fields * row_fields * row_pairs = match fi1, fi2 with [], _ | _, [] -> (fi1, fi2, []) | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, []) @@ -2630,7 +2631,8 @@ and unify_row env row1 row2 = let rm1 = row_more row1 and rm2 = row_more row2 in if unify_eq rm1 rm2 then () else let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in - if r1 <> [] && r2 <> [] then begin + if not !Config.bs_only && (r1 <> [] && r2 <> []) then begin + (* pairs are the intersection, r1 , r2 should be disjoint *) let ht = Hashtbl.create (List.length r1) in List.iter (fun (l,_) -> Hashtbl.add ht (hash_variant l) l) r1; List.iter diff --git a/typing/datarepr.ml b/typing/datarepr.ml index 948706936b7c..9310573efca2 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -242,11 +242,11 @@ let rec find_constr tag num_const num_nonconst = function [] -> raise Constr_not_found | {cd_args = Cstr_tuple []; _} as c :: rem -> - if tag = Cstr_constant num_const + if Types.equal_tag tag (Cstr_constant num_const) then c else find_constr tag (num_const + 1) num_nonconst rem | c :: rem -> - if tag = Cstr_block num_nonconst || tag = Cstr_unboxed + if Types.equal_tag tag (Cstr_block num_nonconst) || tag = Cstr_unboxed then c else find_constr tag num_const (num_nonconst + 1) rem diff --git a/typing/oprint.ml b/typing/oprint.ml index b24957097231..ffd433c477ce 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -283,62 +283,19 @@ and print_simple_out_type ppf = else tyl in fprintf ppf "@[<0>(%a@ [@bs])@]" print_out_type_1 res - | Otyp_constr (Oide_dot (Oide_ident "Js_internalOO", "meth" ) as id , - ([Otyp_variant(_,Ovar_fields [ variant, _, tys], _,_); result] as tyl)) + | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js_OO", "Meth" ),name), + [tyl]) -> - (* Otyp_arrow*) - let make tys result = - if tys = [] then - Otyp_arrow ("", Otyp_constr (Oide_ident "unit", []),result) - else - match tys with - | [ Otyp_tuple tys as single] -> - if variant = "Arity_1" then - Otyp_arrow ("", single, result) - else - List.fold_right (fun x acc -> Otyp_arrow("",x,acc) ) tys result - | [single] -> - Otyp_arrow ("", single, result) - | _ -> - raise_notrace Not_found - in - begin match (make tys result) with - | exception _ -> - begin - pp_open_box ppf 0; - print_typargs ppf tyl; - print_ident ppf id; - pp_close_box ppf () - end - | res -> - fprintf ppf "@[<0>(%a@ [@bs.meth])@]" print_out_type_1 res - end - | Otyp_constr (Oide_dot (Oide_ident "Js_internalOO", "meth_callback" ) as id , - ([Otyp_variant(_,Ovar_fields [ variant, _, tys], _,_); result] as tyl)) - -> - let make tys result = - match tys with - | [ Otyp_tuple tys as single ] -> - if variant = "Arity_1" then Otyp_arrow ("", single, result) - else - List.fold_right (fun x acc -> Otyp_arrow("",x,acc) ) tys result - | [single] -> - Otyp_arrow ("", single, result) - | _ -> - raise_notrace Not_found - in - begin match (make tys result) with - | exception _ -> - begin - pp_open_box ppf 0; - print_typargs ppf tyl; - print_ident ppf id; - pp_close_box ppf () - end - | res -> - fprintf ppf "@[<0>(%a@ [@bs.this])@]" print_out_type_1 res - - end + let res = + if name = "arity0" then + Otyp_arrow ("", Otyp_constr (Oide_ident "unit", []),tyl) + else tyl + in + fprintf ppf "@[<0>(%a@ [@bs.meth])@]" print_out_type_1 res + | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js_OO", "Callback" ), _), + [tyl]) + -> + fprintf ppf "@[<0>(%a@ [@bs.this])@]" print_out_type_1 tyl #end | Otyp_constr (id, tyl) -> pp_open_box ppf 0; diff --git a/typing/predef.ml b/typing/predef.ml index c9594ca14f4b..4453f5c517c6 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -47,13 +47,24 @@ and ident_string = ident_create "string" and ident_extension_constructor = ident_create "extension_constructor" and ident_floatarray = ident_create "floatarray" -let type_is_builtin_path_but_option (p : Path.t) = +type test = + | For_sure_yes + | For_sure_no + | NA + +let type_is_builtin_path_but_option (p : Path.t) : test = match p with | Pident {Ident.stamp} -> - stamp >= ident_int.Ident.stamp - && stamp <= ident_floatarray.Ident.stamp - && (stamp <> ident_option.Ident.stamp) - | _ -> false + if + stamp >= ident_int.Ident.stamp + && stamp <= ident_floatarray.Ident.stamp + then + if (stamp = ident_option.Ident.stamp) + || (stamp = ident_unit.Ident.stamp) then + For_sure_no + else For_sure_yes + else NA + | _ -> NA let path_int = Pident ident_int and path_char = Pident ident_char diff --git a/typing/predef.mli b/typing/predef.mli index c21b470285ac..5d9866f9762d 100644 --- a/typing/predef.mli +++ b/typing/predef.mli @@ -78,4 +78,10 @@ val builtin_idents: (string * Ident.t) list val ident_division_by_zero: Ident.t val all_predef_exns : Ident.t list -val type_is_builtin_path_but_option : Path.t -> bool +type test = + | For_sure_yes + | For_sure_no + | NA + +val type_is_builtin_path_but_option : + Path.t -> test diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 9bcbcbb12425..9f97006a18c8 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -308,8 +308,9 @@ and expression i ppf x = line i ppf "Texp_let %a\n" fmt_rec_flag rf; list i value_binding ppf l; expression i ppf e; - | Texp_function { arg_label = p; param = _; cases; partial = _; } -> + | Texp_function { arg_label = p; param ; cases; partial = _; } -> line i ppf "Texp_function\n"; + line i ppf "%a" Ident.print param; arg_label i ppf p; list i case ppf cases; | Texp_apply (e, l) -> diff --git a/typing/typecore.ml b/typing/typecore.ml index a97f1b594697..0a8eb775bdbe 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -2578,15 +2578,22 @@ let proper_exp_loc exp = in aux exp.exp_extra +let id_of_pattern : Typedtree.pattern -> Ident.t option = fun pat -> + match pat.pat_desc with + | Tpat_var (id, _) -> Some id + | Tpat_alias(_, id, _) -> Some id + | Tpat_construct (_,_, + [{pat_desc = (Tpat_var (id,_) | Tpat_alias(_,id,_))}]) + -> Some (Ident.rename id) + | _ -> None (* To find reasonable names for let-bound and lambda-bound idents *) let rec name_pattern default = function [] -> Ident.create default | {c_lhs=p; _} :: rem -> - match p.pat_desc with - Tpat_var (id, _) -> id - | Tpat_alias(_, id, _) -> id - | _ -> name_pattern default rem + match id_of_pattern p with + | None -> name_pattern default rem + | Some id -> id (* Typing of expressions *) @@ -4924,6 +4931,22 @@ let report_error env ppf = function fprintf ppf "Variable %s must occur on both sides of this | pattern" (Ident.name id); spellcheck_idents ppf id valid_idents + | Expr_type_clash ( + (_, {desc = Tarrow _}) :: + (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),_,_)}) :: _ + ) -> + fprintf ppf "This function is a curried function where an uncurried function is expected" + | Expr_type_clash ( + (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),a,_),_,_)}) :: + (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),b,_),_,_)}) :: _ + ) when a <> b -> + fprintf ppf "This function has %s but was expected %s" a b + | Expr_type_clash ( + (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js_OO"},"Meth",_),a,_),_,_)}) :: + (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js_OO"},"Meth",_),b,_),_,_)}) :: _ + ) when a <> b -> + fprintf ppf "This method has %s but was expected %s" a b + | Expr_type_clash trace -> report_unification_error ppf env trace (function ppf -> @@ -4938,6 +4961,8 @@ let report_error env ppf = function type_expr typ; fprintf ppf "@ @[It is applied to too many arguments;@ %s@]@]" "maybe you forgot a `;'." + | Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),_,_) -> + fprintf ppf "This function has uncurried type, it needs to be applied in ucurried style"; | _ -> fprintf ppf "@[@[<2>This expression has type@ %a@]@ %s@]" type_expr typ @@ -5041,6 +5066,10 @@ let report_error env ppf = function fprintf ppf "it should have type@ %a" type_expr ty end else begin + match ty with + | {desc = Tconstr (Pdot (Pdot(Pident {name = "Js"},"Fn",_),_,_),_,_)} -> + fprintf ppf "This expression is excpeted to have an uncurried function" + | _ -> fprintf ppf "This expression should not be a function,@ "; fprintf ppf "the expected type is@ %a" type_expr ty @@ -5072,7 +5101,7 @@ let report_error env ppf = function | Not_a_variant_type lid -> fprintf ppf "The type %a@ is not a variant type" longident lid | Incoherent_label_order -> - fprintf ppf "This function is applied to arguments@ "; + fprintf ppf "This labeled function is applied to arguments@ "; fprintf ppf "in an order different from other calls.@ "; fprintf ppf "This is only allowed when the real type is known." | Less_general (kind, trace) -> diff --git a/typing/typecore.mli b/typing/typecore.mli index c1fe53bb462e..6b9e6b603ab9 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -66,6 +66,7 @@ val generalizable: int -> type_expr -> bool val reset_delayed_checks: unit -> unit val force_delayed_checks: unit -> unit +val id_of_pattern : Typedtree.pattern -> Ident.t option val name_pattern : string -> Typedtree.case list -> Ident.t val self_coercion : (Path.t * Location.t list ref) list ref diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 6f64cd7e7013..1a12a44957b7 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -444,7 +444,7 @@ let transl_declaration env sdecl id = raise(Error(sdecl.ptype_loc, Duplicate_constructor name)); all_constrs := StringSet.add name !all_constrs) scstrs; - if List.length + if not !Config.bs_only && List.length (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs) > (Config.max_tag + 1) then raise(Error(sdecl.ptype_loc, Too_many_constructors)); diff --git a/typing/typeopt.ml b/typing/typeopt.ml index 364ac5ab7e6b..df8ba4ad3309 100644 --- a/typing/typeopt.ml +++ b/typing/typeopt.ml @@ -51,22 +51,28 @@ let cannot_inhabit_none_like_value (typ : Types.type_expr) (env : Env.t) = int, char, float, bool, unit, exn, array, list, nativeint, int32, int64, lazy_t, bytes *) - if Predef.type_is_builtin_path_but_option p then true - else + (match Predef.type_is_builtin_path_but_option p with + | For_sure_yes -> true + | For_sure_no -> false + | NA -> + begin match (Env.find_type p env).type_kind with | exception _ -> false | Types.Type_abstract | Types.Type_open -> false | Types.Type_record _ -> true - | Types.Type_variant - ([{cd_id = {Ident.name="None"}; cd_args = Types.Cstr_tuple [] }; - {cd_id = {Ident.name = "Some"}; cd_args = Types.Cstr_tuple [_]}] - | - [{cd_id = {Ident.name="Some"}; cd_args = Types.Cstr_tuple [_] }; - {cd_id = {Ident.name = "None"}; cd_args = Types.Cstr_tuple []}] - ) -> false (* conservative *) - | Types.Type_variant _ -> true - end + | (Types.Type_variant + ([{cd_id = {name="None"}; cd_args = Cstr_tuple [] }; + {cd_id = {name = "Some"}; cd_args = Cstr_tuple [_]}] + | + [{cd_id = {name="Some"}; cd_args = Cstr_tuple [_] }; + {cd_id = {name = "None"}; cd_args = Cstr_tuple []}] + | [{cd_id= {name = "()"}; cd_args = Cstr_tuple []}] + )) + (* | Types.Type_variant *) + -> false (* conservative *) + | _ -> true + end) | Ttuple _ | Tvariant _ | Tpackage _ diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 5347c42da223..064d862b0e37 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -512,19 +512,25 @@ and transl_type_aux env policy styp = row_bound=(); row_closed=true; row_fixed=false; row_name=None}) in let hfields = Hashtbl.create 17 in + let collection_detect = Hashtbl.create 17 in let add_typed_field loc l f = - let h = Btype.hash_variant l in + if not !Config.bs_only then begin + let h = Btype.hash_variant l in + if Hashtbl.mem collection_detect h then + let l' = Hashtbl.find collection_detect h in + (* Check for tag conflicts *) + if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l'))); + else Hashtbl.add collection_detect h l + end ; try - let (l',f') = Hashtbl.find hfields h in - (* Check for tag conflicts *) - if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l'))); + let (_,f') = Hashtbl.find hfields l in let ty = mkfield l f and ty' = mkfield l f' in if equal env false [ty] [ty'] then () else try unify env ty ty' with Unify _trace -> raise(Error(loc, env, Constructor_mismatch (ty,ty'))) with Not_found -> - Hashtbl.add hfields h (l,f) + Hashtbl.add hfields l (l,f) in let add_field = function Rtag (l, attrs, c, stl) -> @@ -555,13 +561,10 @@ and transl_type_aux env policy styp = {desc=Tconstr(p, tl, _)} -> Some(p, tl) | _ -> None in - begin try + begin (* Set name if there are no fields yet *) - Hashtbl.iter (fun _ _ -> raise Exit) hfields; - name := nm - with Exit -> - (* Unset it otherwise *) - name := None + if Hashtbl.length hfields <> 0 then name := None + else name := nm end; let fl = match expand_head env cty.ctyp_type, nm with {desc=Tvariant row}, _ when Btype.static_row row -> diff --git a/utils/clflags.ml b/utils/clflags.ml index b5f9523f109e..105ac82531a6 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -369,6 +369,7 @@ let color = ref None ;; (* -color *) let unboxed_types = ref false +#if undefined BS_ONLY then let arg_spec = ref [] let arg_names = ref Misc.StringMap.empty @@ -403,6 +404,7 @@ let parse_arguments f msg = with | Arg.Bad msg -> Printf.eprintf "%s" msg; exit 2 | Arg.Help msg -> Printf.printf "%s" msg; exit 0 +#end #if true then type mli_status = Mli_na | Mli_exists | Mli_non_exists diff --git a/utils/clflags.mli b/utils/clflags.mli index d9c87d5d0cf0..b04d3fcdf88d 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -211,6 +211,7 @@ val color : Misc.Color.setting option ref val unboxed_types : bool ref +#if undefined BS_ONLY then val arg_spec : (string * Arg.spec * string) list ref (* [add_arguments __LOC__ args] will add the arguments from [args] at @@ -231,7 +232,7 @@ val print_arguments : string -> unit (* [reset_arguments ()] clear all declared arguments *) val reset_arguments : unit -> unit - +#end #if true then type mli_status = Mli_na | Mli_exists | Mli_non_exists val no_implicit_current_dir : bool ref diff --git a/utils/config.mli b/utils/config.mli index d6c167c05a98..c4fa6c0b40b9 100644 --- a/utils/config.mli +++ b/utils/config.mli @@ -21,6 +21,8 @@ val version: string val standard_library: string (* The directory containing the standard libraries *) +val syntax_kind : [ `ml | `reason | `rescript ] ref + val bs_only : bool ref val standard_runtime: string diff --git a/utils/config.mlp b/utils/config.mlp index d5228556644b..dc861e39d105 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -34,6 +34,7 @@ let standard_library = #end standard_library_default let bs_only = ref false +let syntax_kind = ref `ml let standard_runtime = "%%BYTERUN%%" let ccomp_type = "%%CCOMPTYPE%%" let c_compiler = "%%CC%%" diff --git a/utils/warnings.ml b/utils/warnings.ml index 25e16c6be978..5fade38a7a41 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -57,7 +57,9 @@ type t = | Wildcard_arg_to_constant_constr (* 28 *) | Eol_in_string (* 29 *) | Duplicate_definitions of string * string * string * string (*30 *) +#if undefined BS_ONLY then | Multiple_definition of string * string * string (* 31 *) +#end | Unused_value_declaration of string (* 32 *) | Unused_open of string (* 33 *) | Unused_type_declaration of string (* 34 *) @@ -77,14 +79,18 @@ type t = | Eliminated_optional_arguments of string list (* 48 *) | No_cmi_file of string * string option (* 49 *) | Bad_docstring of bool (* 50 *) +#if undefined BS_ONLY then | Expect_tailcall (* 51 *) +#end | Fragile_literal_pattern (* 52 *) | Misplaced_attribute of string (* 53 *) | Duplicated_attribute of string (* 54 *) | Inlining_impossible of string (* 55 *) | Unreachable_case (* 56 *) | Ambiguous_pattern of string list (* 57 *) +#if undefined BS_ONLY then | No_cmx_file of string (* 58 *) +#end | Assignment_to_non_mutable_value (* 59 *) | Unused_module of string (* 60 *) | Unboxable_type_in_prim_decl of string (* 61 *) @@ -139,7 +145,9 @@ let number = function | Wildcard_arg_to_constant_constr -> 28 | Eol_in_string -> 29 | Duplicate_definitions _ -> 30 +#if undefined BS_ONLY then | Multiple_definition _ -> 31 +#end | Unused_value_declaration _ -> 32 | Unused_open _ -> 33 | Unused_type_declaration _ -> 34 @@ -159,14 +167,18 @@ let number = function | Eliminated_optional_arguments _ -> 48 | No_cmi_file _ -> 49 | Bad_docstring _ -> 50 +#if undefined BS_ONLY then | Expect_tailcall -> 51 +#end | Fragile_literal_pattern -> 52 | Misplaced_attribute _ -> 53 | Duplicated_attribute _ -> 54 | Inlining_impossible _ -> 55 | Unreachable_case -> 56 | Ambiguous_pattern _ -> 57 +#if undefined BS_ONLY then | No_cmx_file _ -> 58 +#end | Assignment_to_non_mutable_value -> 59 | Unused_module _ -> 60 | Unboxable_type_in_prim_decl _ -> 61 @@ -244,7 +256,11 @@ let backup () = !current let restore x = current := x let is_active x = not !disabled && (!current).active.(number x);; -let is_error x = not !disabled && (!current).error.(number x);; + +let is_error = + if !Config.bs_only then is_active else + fun x -> not !disabled && (!current).error.(number x) + let mk_lazy f = let state = backup () in @@ -360,15 +376,27 @@ let message = function ("the following methods are overridden by the class" :: cname :: ":\n " :: slist) | Method_override [] -> assert false +#if true then + | Partial_match "" -> + "You forgot to handle a possible case here, though we don't have more information on the value." + | Partial_match s -> + "You forgot to handle a possible case here, for example: \n " ^ s +#else | Partial_match "" -> "this pattern-matching is not exhaustive." | Partial_match s -> "this pattern-matching is not exhaustive.\n\ Here is an example of a case that is not matched:\n" ^ s +#end | Non_closed_record_pattern s -> "the following labels are not bound in this record pattern:\n" ^ s ^ "\nEither bind these labels explicitly or add '; _' to the pattern." +#if true then + | Statement_type -> + "This expression returns a value, but you're not doing anything with it. If this is on purpose, wrap it with `ignore`." +#else | Statement_type -> "this expression should have type unit." +#end | Unused_match -> "this match case is unused." | Unused_pat -> "this sub-pattern is unused." | Instance_variable_override [lab] -> @@ -384,7 +412,17 @@ let message = function | Implicit_public_methods l -> "the following private methods were made public implicitly:\n " ^ String.concat " " l ^ "." +#if true then + | Unerasable_optional_argument -> + String.concat "" + ["This optional parameter in final position will, in practice, not be optional.\n"; + " Reorder the parameters so that at least one non-optional one is in final position or, if all parameters are optional, insert a final ().\n\n"; + " Explanation: If the final parameter is optional, it'd be unclear whether a function application that omits it should be considered fully applied, or partially applied. Imagine writing `let title = display(\"hello!\")`, only to realize `title` isn't your desired result, but a curried call that takes a final optional argument, e.g. `~showDate`.\n\n"; + " Formal rule: an optional argument is considered intentionally omitted when the 1st positional (i.e. neither labeled nor optional) argument defined after it is passed in." + ] +#else | Unerasable_optional_argument -> "this optional argument cannot be erased." +#end | Undeclared_virtual_method m -> "the virtual method "^m^" is not declared." | Not_principal s -> s^" is not principal." | Without_principality s -> s^" without principality." @@ -393,10 +431,21 @@ let message = function "this statement never returns (or has an unsound type.)" | Preprocessor s -> s | Useless_record_with -> + begin match !Config.syntax_kind with + | `ml -> "all the fields are explicitly listed in this record:\n\ the 'with' clause is useless." + | `reason | `rescript -> + "All the fields are already explicitly listed in this record. You can remove the `...` spread." + end +#if true then | Bad_module_name (modname) -> + "This file's name is potentially invalid. The build systems conventionally turn a file name into a module name by upper-casing the first letter. " ^ modname ^ " isn't a valid module name.\n" ^ + "Note: some build systems might e.g. turn kebab-case into CamelCase module, which is why this isn't a hard error." +#else + | Bad_module_name (modname) -> "bad source file name: \"" ^ modname ^ "\" is not a valid module name." +#end | All_clauses_guarded -> "this pattern-matching is not exhaustive.\n\ All clauses in this pattern-matching are guarded." @@ -408,10 +457,12 @@ let message = function | Duplicate_definitions (kind, cname, tc1, tc2) -> Printf.sprintf "the %s %s is defined in both types %s and %s." kind cname tc1 tc2 +#if undefined BS_ONLY then | Multiple_definition(modname, file1, file2) -> Printf.sprintf "files %s and %s both define a module named %s" file1 file2 modname +#end | Unused_value_declaration v -> "unused value " ^ v ^ "." | Unused_open s -> "unused open " ^ s ^ "." | Unused_type_declaration s -> "unused type " ^ s ^ "." @@ -491,8 +542,10 @@ let message = function | Bad_docstring unattached -> if unattached then "unattached documentation comment (ignored)" else "ambiguous documentation comment" +#if undefined BS_ONLY then | Expect_tailcall -> Printf.sprintf "expected tailcall" +#end | Fragile_literal_pattern -> Printf.sprintf "Code should not depend on the actual values of\n\ @@ -521,10 +574,12 @@ let message = function "Ambiguous or-pattern variables under guard;\n\ %s may match different arguments. (See manual section 8.5)" msg +#if undefined BS_ONLY then | No_cmx_file name -> Printf.sprintf "no cmx file was found in path for module %s, \ and its interface was not compiled with -opaque" name +#end | Assignment_to_non_mutable_value -> "A potential assignment to a non-mutable value was detected \n\ in this source file. Such assignments may generate incorrect code \n\ @@ -541,21 +596,23 @@ let message = function #if true then | Bs_unused_attribute s -> - "Unused BuckleScript attribute: " ^ s + "Unused attribute: " ^ s ^ "\n\ + This means such annotation is not annotated properly. \n\ + for example, some annotations is only meaningful in externals \n" | Bs_polymorphic_comparison -> - "polymorphic comparison introduced (maybe unsafe)" + "Polymorphic comparison introduced (maybe unsafe)" | Bs_ffi_warning s -> - "BuckleScript FFI warning: " ^ s + "FFI warning: " ^ s | Bs_derive_warning s -> - "BuckleScript bs.deriving warning: " ^ s + "bs.deriving warning: " ^ s | Bs_fragile_external s -> - "BuckleScript warning: " ^ s ^" : the external name is inferred from val name is unsafe from refactoring when changing value name" + s ^ " : the external name is inferred from val name is unsafe from refactoring when changing value name" | Bs_unimplemented_primitive s -> - "BuckleScript warning: Unimplemented primitive used:" ^ s + "Unimplemented primitive used:" ^ s | Bs_integer_literal_overflow -> - "BuckleScript warning: Integer literal exceeds the range of representable integers of type int" + "Integer literal exceeds the range of representable integers of type int" | Bs_uninterpreted_delimiters s -> - "BuckleScript warning: Uninterpreted delimiters" ^ s + "Uninterpreted delimiters " ^ s #end ;; @@ -577,6 +634,12 @@ type reporting_information = } let report w = + match w with + | Name_out_of_scope _ (* 40 *) + | Disambiguated_name _ (* 42 *) + | Unboxable_type_in_prim_decl _ (* 61 *) -> `Inactive + (* TODO: we could simplify the code even more *) + | _ -> match is_active w with | false -> `Inactive | true -> @@ -586,17 +649,7 @@ let report w = } ;; -#if true then -let super_report message w = - match is_active w with - | false -> `Inactive - | true -> - if is_error w then incr nerrors; - `Active { number = number w; message = message w; is_error = is_error w; - sub_locs = sub_locs w; - } -;; -#end + exception Errors;; let reset_fatal () = @@ -686,14 +739,14 @@ let descriptions = 62, "Type constraint on GADT type declaration"; #if true then - 101, "BuckleScript warning: Unused bs attributes"; - 102, "BuckleScript warning: polymorphic comparison introduced (maybe unsafe)"; - 103, "BuckleScript warning: about fragile FFI definitions" ; - 104, "BuckleScript warning: bs.deriving warning with customized message "; - 105, "BuckleScript warning: the external name is inferred from val name is unsafe from refactoring when changing value name"; - 106, "BuckleScript warning: Unimplemented primitive used:"; - 107, "BuckleScript warning: Integer literal exceeds the range of representable integers of type int"; - 108, "BuckleScript warning: Uninterpreted delimiters (for unicode)" + 101, "Unused bs attributes"; + 102, "Polymorphic comparison introduced (maybe unsafe)"; + 103, "Fragile FFI definitions" ; + 104, "bs.deriving warning with customized message "; + 105, "External name is inferred from val name is unsafe from refactoring when changing value name"; + 106, "Unimplemented primitive used:"; + 107, "Integer literal exceeds the range of representable integers of type int"; + 108, "Uninterpreted delimiters (for unicode)" #end ] ;; diff --git a/utils/warnings.mli b/utils/warnings.mli index d05ae3a45815..08ada7c9602b 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -50,7 +50,9 @@ type t = | Wildcard_arg_to_constant_constr (* 28 *) | Eol_in_string (* 29 *) | Duplicate_definitions of string * string * string * string (* 30 *) +#if undefined BS_ONLY then | Multiple_definition of string * string * string (* 31 *) +#end | Unused_value_declaration of string (* 32 *) | Unused_open of string (* 33 *) | Unused_type_declaration of string (* 34 *) @@ -70,14 +72,18 @@ type t = | Eliminated_optional_arguments of string list (* 48 *) | No_cmi_file of string * string option (* 49 *) | Bad_docstring of bool (* 50 *) +#if undefined BS_ONLY then | Expect_tailcall (* 51 *) +#end | Fragile_literal_pattern (* 52 *) | Misplaced_attribute of string (* 53 *) | Duplicated_attribute of string (* 54 *) | Inlining_impossible of string (* 55 *) | Unreachable_case (* 56 *) | Ambiguous_pattern of string list (* 57 *) +#if undefined BS_ONLY then | No_cmx_file of string (* 58 *) +#end | Assignment_to_non_mutable_value (* 59 *) | Unused_module of string (* 60 *) | Unboxable_type_in_prim_decl of string (* 61 *) @@ -127,10 +133,8 @@ val mk_lazy: (unit -> 'a) -> 'a Lazy.t (** Like [Lazy.of_fun], but the function is applied with the warning settings at the time [mk_lazy] is called. *) -#if undefined BS_NO_COMPILER_PATCH then +#if true then +val nerrors : int ref val message : t -> string val number: t -> int -val super_report : - (t -> string) -> - t -> [ `Active of reporting_information | `Inactive ] #end