diff --git a/lambda/matching.ml b/lambda/matching.ml index bfd4ea888c..151a5fb544 100644 --- a/lambda/matching.ml +++ b/lambda/matching.ml @@ -1806,16 +1806,9 @@ let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem = if pos > last_pos then argl else -<<<<<<< HEAD - (Lprim (Pfield (pos, Reads_agree), [ arg ], loc), binding_kind, + (Lprim (Pfield (pos, Pointer, Reads_agree), [ arg ], loc), binding_kind, Jkind.Sort.for_constructor_arg, layout_field) :: make_args (pos + 1) -||||||| merged common ancestors - (Lprim (Pfield pos, [ arg ], loc), binding_kind) :: make_args (pos + 1) -======= - (Lprim (Pfield (pos, Pointer, Immutable), [ arg ], loc), - binding_kind) :: make_args (pos + 1) ->>>>>>> ocaml/5.1 in make_args first_pos in @@ -1841,21 +1834,15 @@ let divide_constructor ~scopes ctx pm = let get_expr_args_variant_constant = drop_expr_arg let nonconstant_variant_field index = - Lambda.Pfield(index, Reads_agree) + Lambda.Pfield(index, Pointer, Reads_agree) let get_expr_args_variant_nonconst ~scopes head (arg, _mut, _sort, _layout) rem = let loc = head_loc ~scopes head in -<<<<<<< HEAD let field_prim = nonconstant_variant_field 1 in (Lprim (field_prim, [ arg ], loc), Alias, Jkind.Sort.for_constructor_arg, layout_field) :: rem -||||||| merged common ancestors - (Lprim (Pfield 1, [ arg ], loc), Alias) :: rem -======= - (Lprim (Pfield (1, Pointer, Immutable), [ arg ], loc), Alias) :: rem ->>>>>>> ocaml/5.1 let divide_variant ~scopes row ctx { cases = cl; args; default = def } = let rec divide = function @@ -1924,14 +1911,8 @@ let get_mod_field modname field = lazy (let mod_ident = Ident.create_persistent modname in let env = -<<<<<<< HEAD Env.add_persistent_structure mod_ident - (Lazy.force Env.initial_safe_string) -||||||| merged common ancestors - Env.add_persistent_structure mod_ident Env.initial_safe_string -======= - Env.add_persistent_structure mod_ident Env.initial ->>>>>>> ocaml/5.1 + (Lazy.force Env.initial) in match Env.open_pers_signature modname env with | Error `Not_found -> @@ -1957,14 +1938,7 @@ let code_force_lazy = get_mod_field "CamlinternalLazy" "force_gen" Forward(val_out_of_heap). *) -<<<<<<< HEAD -let lazy_forward_field = Lambda.Pfield (0, Reads_vary) - -let inline_lazy_force_cond arg pos loc = -||||||| merged common ancestors -let inline_lazy_force_cond arg loc = -======= -let call_force_lazy_block varg loc = +let call_force_lazy_block ?(inlined = Default_inlined) varg loc ~pos = (* The argument is wrapped with [Popaque] to prevent the rest of the compiler from making any assumptions on its contents (see comments on [CamlinternalLazy.force_gen], and discussions on PRs #9998 and #10909). @@ -1975,20 +1949,24 @@ let call_force_lazy_block varg loc = { ap_tailcall = Default_tailcall; ap_loc = loc; ap_func = force_fun; - ap_args = [ Lprim (Popaque, [ varg ], loc) ]; - ap_inlined = Default_inline; - ap_specialised = Default_specialise + ap_args = [ Lprim (Popaque Lambda.layout_lazy, [ varg ], loc) ]; + ap_result_layout = Lambda.layout_lazy_contents; + ap_region_close = pos; + ap_mode = alloc_heap; + ap_inlined = inlined; + ap_specialised = Default_specialise; + ap_probe = None; } -let inline_lazy_force_cond arg loc = ->>>>>>> ocaml/5.1 +let lazy_forward_field = Lambda.Pfield (0, Pointer, Reads_vary) + +let inline_lazy_force_cond arg pos loc = let idarg = Ident.create_local "lzarg" in let varg = Lvar idarg in let tag = Ident.create_local "tag" in let test_tag t = Lprim(Pintcomp Ceq, [Lvar tag; Lconst(Const_base(Const_int t))], loc) in - Llet ( Strict, Lambda.layout_lazy, @@ -2000,67 +1978,19 @@ let inline_lazy_force_cond arg loc = tag, Lprim (Pccall prim_obj_tag, [ varg ], loc), Lifthenelse -<<<<<<< HEAD - (* if (tag == Obj.forward_tag) then varg.(0) else ... *) - ( Lprim - ( Pintcomp Ceq, - [ tag_var; Lconst (Const_base (Const_int Obj.forward_tag)) ], - loc ), - Lprim (lazy_forward_field, [ varg ], loc), -||||||| merged common ancestors - (* if (tag == Obj.forward_tag) then varg.(0) else ... *) - ( Lprim - ( Pintcomp Ceq, - [ tag_var; Lconst (Const_base (Const_int Obj.forward_tag)) ], - loc ), - Lprim (Pfield 0, [ varg ], loc), -======= ( (* if (tag == Obj.forward_tag) then varg.(0) else ... *) test_tag Obj.forward_tag, - Lprim (Pfield (0, Pointer, Mutable), [ varg ], loc), ->>>>>>> ocaml/5.1 + Lprim (lazy_forward_field, [ varg ], loc), Lifthenelse -<<<<<<< HEAD - (* if (tag == Obj.lazy_tag) then Lazy.force varg else ... *) - ( Lprim - ( Pintcomp Ceq, - [ tag_var; Lconst (Const_base (Const_int Obj.lazy_tag)) ], - loc ), - Lapply - { ap_tailcall = Default_tailcall; - ap_loc = loc; - ap_func = force_fun; - ap_args = [ varg ]; - ap_result_layout = Lambda.layout_lazy_contents; - ap_region_close = pos; - ap_mode = alloc_heap; - ap_inlined = Never_inlined; - ap_specialised = Default_specialise; - ap_probe=None - }, -||||||| merged common ancestors - (* if (tag == Obj.lazy_tag) then Lazy.force varg else ... *) - ( Lprim - ( Pintcomp Ceq, - [ tag_var; Lconst (Const_base (Const_int Obj.lazy_tag)) ], - loc ), - Lapply - { ap_tailcall = Default_tailcall; - ap_loc = loc; - ap_func = force_fun; - ap_args = [ varg ]; - ap_inlined = Default_inline; - ap_specialised = Default_specialise - }, -======= ( (* ... if tag == Obj.lazy_tag || tag == Obj.forcing_tag then Lazy.force varg else ... *) Lprim (Psequor, [test_tag Obj.lazy_tag; test_tag Obj.forcing_tag], loc), - call_force_lazy_block varg loc, ->>>>>>> ocaml/5.1 + (* nroberts: We probably don't need [Never_inlined] anymore + now that [ap_args] is opaque. *) + call_force_lazy_block ~inlined:Never_inlined varg loc ~pos, (* ... arg *) varg, Lambda.layout_lazy_contents), Lambda.layout_lazy_contents) ) ) @@ -2081,42 +2011,11 @@ let inline_lazy_force_switch arg pos loc = sw_blocks = []; sw_numconsts = 256; (* PR#6033 - tag ranges from 0 to 255 *) -<<<<<<< HEAD - sw_blocks = - [ ( Obj.forward_tag, - Lprim (lazy_forward_field, [ varg ], loc) ); - ( Obj.lazy_tag, - Lapply - { ap_tailcall = Default_tailcall; - ap_loc = loc; - ap_func = force_fun; - ap_args = [ varg ]; - ap_result_layout = Lambda.layout_lazy_contents; - ap_region_close = pos; - ap_mode = alloc_heap; - ap_inlined = Default_inlined; - ap_specialised = Default_specialise; - ap_probe=None; - } ) -||||||| merged common ancestors - sw_blocks = - [ (Obj.forward_tag, Lprim (Pfield 0, [ varg ], loc)); - ( Obj.lazy_tag, - Lapply - { ap_tailcall = Default_tailcall; - ap_loc = loc; - ap_func = force_fun; - ap_args = [ varg ]; - ap_inlined = Default_inline; - ap_specialised = Default_specialise - } ) -======= sw_consts = - [ (Obj.forward_tag, Lprim (Pfield(0, Pointer, Mutable), + [ (Obj.forward_tag, Lprim (Pfield(0, Pointer, Reads_vary), [ varg ], loc)); - (Obj.lazy_tag, call_force_lazy_block varg loc); - (Obj.forcing_tag, call_force_lazy_block varg loc) ->>>>>>> ocaml/5.1 + (Obj.lazy_tag, call_force_lazy_block varg loc ~pos); + (Obj.forcing_tag, call_force_lazy_block varg loc ~pos) ]; sw_failaction = Some varg }, @@ -2132,23 +2031,21 @@ let inline_lazy_force arg pos loc = { ap_tailcall = Default_tailcall; ap_loc = loc; ap_func = Lazy.force code_force_lazy; -<<<<<<< HEAD - ap_args = [ arg ]; + ap_args = [ Lconst (Const_base (Const_int 0)); arg ]; ap_result_layout = Lambda.layout_lazy_contents; ap_region_close = pos; ap_mode = alloc_heap; + (* nroberts: To make sure this wasn't inlined: + - Upstream changed [code_force_lazy] to a non-inlineable + function when compiling with AFL support. + - We just changed this to Never_inlined. + + If these two approaches are solving the same problem, we should + just converge to one. + *) ap_inlined = Never_inlined; ap_specialised = Default_specialise; ap_probe=None; -||||||| merged common ancestors - ap_args = [ arg ]; - ap_inlined = Default_inline; - ap_specialised = Default_specialise -======= - ap_args = [ Lconst (Const_base (Const_int 0)); arg ]; - ap_inlined = Default_inline; - ap_specialised = Default_specialise ->>>>>>> ocaml/5.1 } else if !Clflags.native_code && not (Clflags.is_flambda2 ()) then (* CR vlaviron: Find a way for Flambda 2 to avoid both the call to @@ -2186,16 +2083,9 @@ let get_expr_args_tuple ~scopes head (arg, _mut, _sort, _layout) rem = if pos >= arity then rem else -<<<<<<< HEAD - (Lprim (Pfield (pos, Reads_agree), [ arg ], loc), Alias, + (Lprim (Pfield (pos, Pointer, Reads_agree), [ arg ], loc), Alias, Jkind.Sort.for_tuple_element, layout_field) :: make_args (pos + 1) -||||||| merged common ancestors - (Lprim (Pfield pos, [ arg ], loc), Alias) :: make_args (pos + 1) -======= - (Lprim (Pfield (pos, Pointer, Immutable), [ arg ], loc), - Alias) :: make_args (pos + 1) ->>>>>>> ocaml/5.1 in make_args 0 @@ -2240,8 +2130,8 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem = rem else let lbl = all_labels.(pos) in -<<<<<<< HEAD check_record_field_jkind lbl; + let ptr = Typeopt.maybe_pointer_type head.pat_env lbl.lbl_arg in let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in let lbl_layout = Typeopt.layout_of_sort lbl.lbl_loc lbl_sort in let sem = @@ -2250,17 +2140,10 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem = | Mutable -> Reads_vary in let access, sort, layout = -||||||| merged common ancestors - let access = -======= - let ptr = Typeopt.maybe_pointer_type head.pat_env lbl.lbl_arg in - let access = ->>>>>>> ocaml/5.1 match lbl.lbl_repres with -<<<<<<< HEAD | Record_boxed _ | Record_inlined (_, Variant_boxed _) -> - Lprim (Pfield (lbl.lbl_pos, sem), [ arg ], loc), + Lprim (Pfield (lbl.lbl_pos, ptr, sem), [ arg ], loc), lbl_sort, lbl_layout | Record_unboxed | Record_inlined (_, Variant_unboxed) -> arg, sort, layout @@ -2274,24 +2157,8 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem = (* Here we are projecting an unboxed float from a float record. *) lbl_sort, lbl_layout | Record_inlined (_, Variant_extensible) -> - Lprim (Pfield (lbl.lbl_pos + 1, sem), [ arg ], loc), + Lprim (Pfield (lbl.lbl_pos + 1, ptr, sem), [ arg ], loc), lbl_sort, lbl_layout -||||||| merged common ancestors - | Record_regular - | Record_inlined _ -> - Lprim (Pfield lbl.lbl_pos, [ arg ], loc) - | Record_unboxed _ -> arg - | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [ arg ], loc) - | Record_extension _ -> Lprim (Pfield (lbl.lbl_pos + 1), [ arg ], loc) -======= - | Record_regular - | Record_inlined _ -> - Lprim (Pfield (lbl.lbl_pos, ptr, lbl.lbl_mut), [ arg ], loc) - | Record_unboxed _ -> arg - | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [ arg ], loc) - | Record_extension _ -> - Lprim (Pfield (lbl.lbl_pos + 1, ptr, lbl.lbl_mut), [ arg ], loc) ->>>>>>> ocaml/5.1 in let str = match lbl.lbl_mut with @@ -2624,12 +2491,7 @@ module SArg = struct let make_if kind cond ifso ifnot = Lifthenelse (cond, ifso, ifnot, kind) -<<<<<<< HEAD let make_switch loc kind arg cases acts = -||||||| merged common ancestors - let make_switch loc arg cases acts = -======= - let make_switch loc arg cases acts = (* The [acts] array can contain arbitrary terms. If several entries in the [cases] array point to the same action, we must share it to avoid duplicating terms. @@ -2642,13 +2504,12 @@ module SArg = struct let wrapper = ref (fun lam -> lam) in for j = 0 to Array.length acts - 1 do if act_uses.(j) > 1 then begin - let nfail, wrap = make_catch_delayed acts.(j) in + let nfail, wrap = make_catch_delayed kind acts.(j) in acts.(j) <- make_exit nfail; let prev_wrapper = !wrapper in wrapper := (fun lam -> wrap (prev_wrapper lam)) end; done; ->>>>>>> ocaml/5.1 let l = ref [] in for i = Array.length cases - 1 downto 0 do l := (i, acts.(cases.(i))) :: !l @@ -2661,13 +2522,7 @@ module SArg = struct sw_blocks = []; sw_failaction = None }, -<<<<<<< HEAD - loc, kind ) -||||||| merged common ancestors - loc ) -======= - loc )) ->>>>>>> ocaml/5.1 + loc, kind )) let make_catch = make_catch_delayed @@ -3097,16 +2952,9 @@ let combine_constructor value_kind loc arg pat_env cstr partial ctx def (Lprim (Pintcomp Ceq, [ Lvar tag; ext ], loc), act, rem, value_kind)) nonconsts default in -<<<<<<< HEAD Llet (Alias, Lambda.layout_block, tag, - Lprim (Pfield (0, Reads_agree), [ arg ], loc), + Lprim (Pfield (0, Pointer, Reads_agree), [ arg ], loc), tests) -||||||| merged common ancestors - Llet (Alias, Pgenval, tag, Lprim (Pfield 0, [ arg ], loc), tests) -======= - Llet (Alias, Pgenval, tag, - Lprim (Pfield (0, Pointer, Immutable), [ arg ], loc), tests) ->>>>>>> ocaml/5.1 in List.fold_right (fun (path, act) rem -> @@ -3131,14 +2979,7 @@ let combine_constructor value_kind loc arg pat_env cstr partial ctx def mk_failaction_pos partial constrs ctx def in let descr_lambda_list = fails @ descr_lambda_list in -<<<<<<< HEAD let consts, nonconsts = split_cases descr_lambda_list in -||||||| merged common ancestors - let consts, nonconsts = - split_cases (List.map tag_lambda descr_lambda_list) in -======= - let consts, nonconsts = - split_cases (List.map tag_lambda descr_lambda_list) in (* Our duty below is to generate code, for matching on a list of constructor+action cases, that is good for both bytecode and native-code compilation. (Optimizations that only work well @@ -3161,7 +3002,6 @@ let combine_constructor value_kind loc arg pat_env cstr partial ctx def switcher directly can result in more compact code. This is a reason to deviate from the one-instruction policy. *) ->>>>>>> ocaml/5.1 let lambda1 = match (fail_opt, same_actions descr_lambda_list) with | None, Some act -> @@ -3171,52 +3011,24 @@ let combine_constructor value_kind loc arg pat_env cstr partial ctx def match (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) with -<<<<<<< HEAD | 1, 1, [ (0, act1) ], [ (0, act2) ] when not (Clflags.is_flambda2 ()) -> -||||||| merged common ancestors - | 1, 1, [ (0, act1) ], [ (0, act2) ] -> -======= - | 1, 1, [ (0, act1) ], [ (0, act2) ] -> (* This case is very frequent, it corresponds to options and lists. *) (* Keeping the Pisint test would make the bytecode slightly worse, but it lets the native compiler generate better code -- see #10681. *) ->>>>>>> ocaml/5.1 if !Clflags.native_code then Lifthenelse(Lprim (Pisint { variant_only = true }, [ arg ], loc), act1, act2, value_kind) else -<<<<<<< HEAD - (* PR#10681: we use [arg] directly as the test here; - it generates better bytecode for this common case - (typically options and lists), but would prevent - some optimizations with the native compiler. *) - Lifthenelse (arg, act2, act1, value_kind) -||||||| merged common ancestors - (* PR#10681: we use [arg] directly as the test here; - it generates better bytecode for this common case - (typically options and lists), but would prevent - some optimizations with the native compiler. *) - Lifthenelse (arg, act2, act1) -======= - Lifthenelse(arg, act2, act1) ->>>>>>> ocaml/5.1 + Lifthenelse(arg, act2, act1, value_kind) | n, 0, _, [] -> -<<<<<<< HEAD - (* The type defines constant constructors only *) - call_switcher value_kind loc fail_opt arg 0 (n - 1) consts -||||||| merged common ancestors - (* The type defines constant constructors only *) - call_switcher loc fail_opt arg 0 (n - 1) consts -======= (* The matched type defines constant constructors only. (typically the constant cases are dense, so call_switcher will generate a Lswitch, still one instruction.) *) - call_switcher loc fail_opt arg 0 (n - 1) consts ->>>>>>> ocaml/5.1 + call_switcher value_kind loc fail_opt arg 0 (n - 1) consts | n, _, _, _ -> ( let act0 = (* = Some act when all non-const constructors match to act *) @@ -3280,16 +3092,8 @@ let call_switcher_variant_constr value_kind loc fail arg int_lambda_list = ( Alias, Lambda.layout_int, v, -<<<<<<< HEAD Lprim (nonconstant_variant_field 0, [ arg ], loc), call_switcher value_kind loc fail (Lvar v) min_int max_int int_lambda_list ) -||||||| merged common ancestors - Lprim (Pfield 0, [ arg ], loc), - call_switcher loc fail (Lvar v) min_int max_int int_lambda_list ) -======= - Lprim (Pfield (0, Pointer, Immutable), [ arg ], loc), - call_switcher loc fail (Lvar v) min_int max_int int_lambda_list ) ->>>>>>> ocaml/5.1 let combine_variant value_kind loc row arg partial ctx def (tag_lambda_list, total1, _pats) @@ -3332,30 +3136,16 @@ let combine_variant value_kind loc row arg partial ctx def match (consts, nonconsts) with | [ (_, act1) ], [ (_, act2) ] when fail = None -> test_int_or_block arg act1 act2 -<<<<<<< HEAD - | _, [] -> - begin match fail with - | None -> - make_test_sequence_variant_constant value_kind fail arg consts - | Some act -> - test_int_or_block arg - (make_test_sequence_variant_constant value_kind fail arg consts) - act - end -||||||| merged common ancestors - | _, [] -> - (* One can compare integers and pointers *) - make_test_sequence_variant_constant fail arg consts -======= | _, [] -> ( - let lam = make_test_sequence_variant_constant fail arg consts in + let lam = + make_test_sequence_variant_constant value_kind fail arg consts + in (* PR#11587: Switcher.test_sequence expects integer inputs, so if the type allows pointers we must filter them away. *) match fail with | None -> lam | Some fail -> test_int_or_block arg lam fail ) ->>>>>>> ocaml/5.1 | [], _ -> ( let lam = call_switcher_variant_constr value_kind loc fail arg nonconsts @@ -3870,13 +3660,7 @@ let failure_handler ~scopes loc ~failer () = let sloc = Scoped_location.of_location ~scopes loc in let slot = transl_extension_path sloc -<<<<<<< HEAD - (Lazy.force Env.initial_safe_string) Predef.path_match_failure -||||||| merged common ancestors - Env.initial_safe_string Predef.path_match_failure -======= - Env.initial Predef.path_match_failure ->>>>>>> ocaml/5.1 + (Lazy.force Env.initial) Predef.path_match_failure in let fname, line, char = Location.get_pos_info loc.Location.loc_start in diff --git a/lambda/switch.ml b/lambda/switch.ml index 20d3c9ef6a..544a4a477d 100644 --- a/lambda/switch.ml +++ b/lambda/switch.ml @@ -627,13 +627,6 @@ let rec pkey chan = function end ; !r, !rc -<<<<<<< HEAD - let make_if_test kind test arg i ifso ifnot = - Arg.make_if kind -||||||| merged common ancestors - let make_if_test test arg i ifso ifnot = - Arg.make_if -======= (* Consider the following sequence of interval tests: if a in [2; 10] then @@ -677,9 +670,8 @@ let rec pkey chan = function *) type 'a t_ctx = {off : int ; arg : 'a} - let make_if_test test arg i ifso ifnot = - Arg.make_if ->>>>>>> ocaml/5.1 + let make_if_test kind test arg i ifso ifnot = + Arg.make_if kind (Arg.make_prim test [arg ; Arg.make_const i]) ifso ifnot @@ -737,14 +729,8 @@ let rec pkey chan = function do_make_if_in kind (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) -<<<<<<< HEAD - let rec c_test kind ctx ({cases=cases ; actions=actions} as s) = -||||||| merged common ancestors - let rec c_test ctx ({cases=cases ; actions=actions} as s) = -======= (* Generate the code for a good test sequence. *) - let rec c_test ctx ({cases=cases ; actions=actions} as s) = ->>>>>>> ocaml/5.1 + let rec c_test kind ctx ({cases=cases ; actions=actions} as s) = let lcases = Array.length cases in assert(lcases > 0) ; if lcases = 1 then @@ -896,19 +882,11 @@ let rec pkey chan = function done ; min_clusters.(len-1),k -<<<<<<< HEAD - (* Assume j > i *) - let make_switch loc kind {cases=cases ; actions=actions} i j = -||||||| merged common ancestors - (* Assume j > i *) - let make_switch loc {cases=cases ; actions=actions} i j = -======= (* The code to generate a dense switch is provided by the functor parameter as Arg.make_switch (which will typically use a jump table) *) - let make_switch loc {cases=cases ; actions=actions} i j = + let make_switch loc kind {cases=cases ; actions=actions} i j = (* Assume j > i *) ->>>>>>> ocaml/5.1 let ll,_,_ = cases.(i) and _,hh,_ = cases.(j) in let tbl = Array.make (hh-ll+1) 0 @@ -943,16 +921,8 @@ let rec pkey chan = function (Arg.make_offset ctx.arg (-ll-ctx.off)) (fun arg -> Arg.make_switch loc kind arg tbl acts)) -<<<<<<< HEAD - - let make_clusters loc kind ({cases=cases ; actions=actions} as s) n_clusters k = -||||||| merged common ancestors - - let make_clusters loc ({cases=cases ; actions=actions} as s) n_clusters k = -======= (* Generate code from a clustering choice. *) - let make_clusters loc ({cases=cases ; actions=actions} as s) n_clusters k = ->>>>>>> ocaml/5.1 + let make_clusters loc kind ({cases=cases ; actions=actions} as s) n_clusters k = let len = Array.length cases in let r = Array.make n_clusters (0,0,0) and t = Hashtbl.create 17 @@ -1025,27 +995,15 @@ let rec pkey chan = function actions in !handlers,actions -<<<<<<< HEAD - let zyva loc kind lh arg cases actions = -||||||| merged common ancestors - let zyva loc lh arg cases actions = -======= (* Standard entry point. *) - let zyva loc lh arg cases actions = ->>>>>>> ocaml/5.1 + let zyva loc kind lh arg cases actions = assert (Array.length cases > 0) ; let actions = actions.act_get_shared () in let hs,actions = abstract_shared kind actions in hs (do_zyva loc kind lh arg cases actions) -<<<<<<< HEAD - and test_sequence kind arg cases actions = -||||||| merged common ancestors - and test_sequence arg cases actions = -======= (* Generate code using test sequences only, not Arg.make_switch *) - and test_sequence arg cases actions = ->>>>>>> ocaml/5.1 + and test_sequence kind arg cases actions = assert (Array.length cases > 0) ; let actions = actions.act_get_shared () in let hs,actions = abstract_shared kind actions in @@ -1060,14 +1018,6 @@ let rec pkey chan = function pcases stderr cases ; prerr_endline "" ; *) -<<<<<<< HEAD hs (c_test kind {arg=arg ; off=0} s) - ;; -||||||| merged common ancestors - hs (c_test {arg=arg ; off=0} s) - ;; -======= - hs (c_test {arg=arg ; off=0} s) ->>>>>>> ocaml/5.1 end diff --git a/lambda/translattribute.ml b/lambda/translattribute.ml index c037f4167a..1be078bb68 100644 --- a/lambda/translattribute.ml +++ b/lambda/translattribute.ml @@ -50,10 +50,6 @@ let is_poll_attribute = let is_loop_attribute = [ ["loop"; "ocaml.loop"], true ] -let is_poll_attribute = function - | {txt=("poll")} -> true - | _ -> false - let find_attribute p attributes = let inline_attribute = Builtin_attributes.filter_attributes p attributes in let attr = @@ -249,7 +245,6 @@ let parse_local_attribute attr = ] payload -<<<<<<< HEAD let parse_property_attribute attr property = match attr with | None -> Default_check @@ -293,18 +288,6 @@ let parse_loop_attribute attr = [ "never", Never_loop; "always", Always_loop; -||||||| merged common ancestors -======= -let parse_poll_attribute attr = - match attr with - | None -> Default_poll - | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} -> - parse_id_payload txt loc - ~default:Default_poll - ~empty:Default_poll - [ - "error", Error_poll; ->>>>>>> ocaml/5.1 ] payload @@ -320,7 +303,6 @@ let get_local_attribute l = let attr = find_attribute is_local_attribute l in parse_local_attribute attr -<<<<<<< HEAD let get_property_attribute l p = let attr = find_attribute (is_property_attribute p) l in let res = parse_property_attribute attr p in @@ -345,12 +327,6 @@ let get_poll_attribute l = let get_loop_attribute l = let attr = find_attribute is_loop_attribute l in parse_loop_attribute attr -||||||| merged common ancestors -======= -let get_poll_attribute l = - let attr, _ = find_attribute is_poll_attribute l in - parse_poll_attribute attr ->>>>>>> ocaml/5.1 let check_local_inline loc attr = match attr.local, attr.inline with @@ -362,62 +338,10 @@ let check_local_inline loc attr = let check_poll_inline loc attr = match attr.poll, attr.inline with -<<<<<<< HEAD | Error_poll, (Always_inline | Available_inline | Unroll _) -> -||||||| merged common ancestors -let add_inline_attribute expr loc attributes = - match expr, get_inline_attribute attributes with - | expr, Default_inline -> expr - | Lfunction({ attr = { stub = false } as attr } as funct), inline -> - begin match attr.inline with - | Default_inline -> () - | Always_inline | Hint_inline | Never_inline | Unroll _ -> - Location.prerr_warning loc - (Warnings.Duplicated_attribute "inline") - end; - let attr = { attr with inline } in - check_local_inline loc attr; - Lfunction { funct with attr = attr } - | expr, (Always_inline | Hint_inline | Never_inline | Unroll _) -> -======= - | Error_poll, (Always_inline | Hint_inline | Unroll _) -> - Location.prerr_warning loc - (Warnings.Inlining_impossible - "[@poll error] is incompatible with inlining") - | _ -> - () - -let check_poll_local loc attr = - match attr.poll, attr.local with - | Error_poll, Always_local -> - Location.prerr_warning loc - (Warnings.Inlining_impossible - "[@poll error] is incompatible with local function optimization") - | _ -> - () - -let lfunction_with_attr ~attr { kind; params; return; body; attr=_; loc } = - lfunction ~kind ~params ~return ~body ~attr ~loc - -let add_inline_attribute expr loc attributes = - match expr, get_inline_attribute attributes with - | expr, Default_inline -> expr - | Lfunction({ attr = { stub = false } as attr } as funct), inline -> - begin match attr.inline with - | Default_inline -> () - | Always_inline | Hint_inline | Never_inline | Unroll _ -> - Location.prerr_warning loc - (Warnings.Duplicated_attribute "inline") - end; - let attr = { attr with inline } in - check_local_inline loc attr; - check_poll_inline loc attr; - lfunction_with_attr ~attr funct - | expr, (Always_inline | Hint_inline | Never_inline | Unroll _) -> ->>>>>>> ocaml/5.1 Location.prerr_warning loc (Warnings.Inlining_impossible - "[@poll error] is incompatible with inlining") + "[@poll error] is incompatible with inlining") | _ -> () @@ -468,21 +392,8 @@ let add_specialise_attribute expr loc attributes = end; let attr = { attr with specialise } in lfunction_with_attr ~attr funct -<<<<<<< HEAD end | _ -> expr -||||||| merged common ancestors - Lfunction { funct with attr } - | expr, (Always_specialise | Never_specialise) -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "specialise"); - expr -======= - | expr, (Always_specialise | Never_specialise) -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "specialise"); - expr ->>>>>>> ocaml/5.1 let add_local_attribute expr loc attributes = match expr with @@ -500,7 +411,6 @@ let add_local_attribute expr loc attributes = check_local_inline loc attr; check_poll_local loc attr; lfunction_with_attr ~attr funct -<<<<<<< HEAD end | _ -> expr @@ -573,18 +483,6 @@ let add_loop_attribute expr loc attributes = lfunction_with_attr ~attr funct end | _ -> expr -||||||| merged common ancestors - Lfunction { funct with attr } - | expr, (Always_local | Never_local) -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "local"); - expr -======= - | expr, (Always_local | Never_local) -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "local"); - expr ->>>>>>> ocaml/5.1 let add_tmc_attribute expr loc attributes = match expr with @@ -598,28 +496,10 @@ let add_tmc_attribute expr loc attributes = (Warnings.Duplicated_attribute "tail_mod_cons"); let attr = { funct.attr with tmc_candidate = true } in lfunction_with_attr ~attr funct -<<<<<<< HEAD end | _ -> expr -||||||| merged common ancestors - Lfunction { funct with attr } - | expr -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "tail_mod_cons"); - expr - else - expr -======= - | expr -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "tail_mod_cons"); - expr - else - expr ->>>>>>> ocaml/5.1 let add_poll_attribute expr loc attributes = -<<<<<<< HEAD match expr with | Lfunction({ attr = { stub = false } as attr } as funct) -> begin match get_poll_attribute attributes with @@ -638,50 +518,6 @@ let add_poll_attribute expr loc attributes = lfunction_with_attr ~attr funct end | expr -> expr -||||||| merged common ancestors -(* Get the [@inlined] attribute payload (or default if not present). - It also returns the expression without this attribute. This is - used to ensure that this attribute is not misplaced: If it - appears on any expression, it is an error, otherwise it would - have been removed by this function *) -let get_and_remove_inlined_attribute e = - let attr, exp_attributes = - find_attribute is_inlined_attribute e.exp_attributes - in - let inlined = parse_inline_attribute attr in - inlined, { e with exp_attributes } -======= - match expr, get_poll_attribute attributes with - | expr, Default_poll -> expr - | Lfunction({ attr = { stub = false } as attr } as funct), poll -> - begin match attr.poll with - | Default_poll -> () - | Error_poll -> - Location.prerr_warning loc - (Warnings.Duplicated_attribute "error_poll") - end; - let attr = { attr with poll } in - check_poll_inline loc attr; - check_poll_local loc attr; - let attr = { attr with inline = Never_inline; local = Never_local } in - lfunction_with_attr ~attr funct - | expr, Error_poll -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute "error_poll"); - expr - -(* Get the [@inlined] attribute payload (or default if not present). - It also returns the expression without this attribute. This is - used to ensure that this attribute is not misplaced: If it - appears on any expression, it is an error, otherwise it would - have been removed by this function *) -let get_and_remove_inlined_attribute e = - let attr, exp_attributes = - find_attribute is_inlined_attribute e.exp_attributes - in - let inlined = parse_inline_attribute attr in - inlined, { e with exp_attributes } ->>>>>>> ocaml/5.1 (* Get the [@inlined] attribute payload (or default if not present). *) let get_inlined_attribute e = @@ -711,7 +547,6 @@ let get_specialised_attribute e = parse_specialise_attribute attr let get_tailcall_attribute e = -<<<<<<< HEAD let attr = find_attribute is_tailcall_attribute e.exp_attributes in match attr with | None -> Default_tailcall @@ -723,124 +558,6 @@ let get_tailcall_attribute e = let msg = "Only an optional boolean literal is supported." in Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg)); Default_tailcall -||||||| merged common ancestors - let is_tailcall_attribute = function - | {Parsetree.attr_name = {txt=("tailcall"|"ocaml.tailcall")}; _} -> true - | _ -> false - in - let tailcalls, other_attributes = - List.partition is_tailcall_attribute e.exp_attributes - in - let tailcall_attribute = match tailcalls with - | [] -> Default_tailcall - | {Parsetree.attr_name = {txt; loc}; attr_payload = payload} :: r -> - begin match r with - | [] -> () - | {Parsetree.attr_name = {txt;loc}; _} :: _ -> - Location.prerr_warning loc (Warnings.Duplicated_attribute txt) - end; - match get_optional_payload get_bool_from_exp payload with - | Ok (None | Some true) -> Tailcall_expectation true - | Ok (Some false) -> Tailcall_expectation false - | Error () -> - let msg = "Only an optional boolean literal is supported." in - Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg)); - Default_tailcall - in - tailcall_attribute, { e with exp_attributes = other_attributes } - -let check_attribute e {Parsetree.attr_name = { txt; loc }; _} = - match txt with - | "inline" | "ocaml.inline" - | "specialise" | "ocaml.specialise" -> begin - match e.exp_desc with - | Texp_function _ -> () - | _ -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute txt) - end - | "inlined" | "ocaml.inlined" - | "specialised" | "ocaml.specialised" - | "tailcall" | "ocaml.tailcall" -> - (* Removed by the Texp_apply cases *) - Location.prerr_warning loc - (Warnings.Misplaced_attribute txt) - | _ -> () - -let check_attribute_on_module e {Parsetree.attr_name = { txt; loc }; _} = - match txt with - | "inline" | "ocaml.inline" -> begin - match e.mod_desc with - | Tmod_functor _ -> () - | _ -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute txt) - end - | "inlined" | "ocaml.inlined" -> - (* Removed by the Texp_apply cases *) - Location.prerr_warning loc - (Warnings.Misplaced_attribute txt) - | _ -> () -======= - let is_tailcall_attribute = function - | {Parsetree.attr_name = {txt=("tailcall"|"ocaml.tailcall")}; _} -> true - | _ -> false - in - let tailcalls, other_attributes = - List.partition is_tailcall_attribute e.exp_attributes - in - let tailcall_attribute = match tailcalls with - | [] -> Default_tailcall - | {Parsetree.attr_name = {txt; loc}; attr_payload = payload} :: r -> - begin match r with - | [] -> () - | {Parsetree.attr_name = {txt;loc}; _} :: _ -> - Location.prerr_warning loc (Warnings.Duplicated_attribute txt) - end; - match get_optional_payload get_bool_from_exp payload with - | Ok (None | Some true) -> Tailcall_expectation true - | Ok (Some false) -> Tailcall_expectation false - | Error () -> - let msg = "Only an optional boolean literal is supported." in - Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg)); - Default_tailcall - in - tailcall_attribute, { e with exp_attributes = other_attributes } - -let check_attribute e {Parsetree.attr_name = { txt; loc }; _} = - match txt with - | "inline" | "ocaml.inline" - | "specialise" | "ocaml.specialise" - | "poll" -> begin - match e.exp_desc with - | Texp_function _ -> () - | _ -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute txt) - end - | "inlined" | "ocaml.inlined" - | "specialised" | "ocaml.specialised" - | "tailcall" | "ocaml.tailcall" -> - (* Removed by the Texp_apply cases *) - Location.prerr_warning loc - (Warnings.Misplaced_attribute txt) - | _ -> () - -let check_attribute_on_module e {Parsetree.attr_name = { txt; loc }; _} = - match txt with - | "inline" | "ocaml.inline" -> begin - match e.mod_desc with - | Tmod_functor _ -> () - | _ -> - Location.prerr_warning loc - (Warnings.Misplaced_attribute txt) - end - | "inlined" | "ocaml.inlined" -> - (* Removed by the Texp_apply cases *) - Location.prerr_warning loc - (Warnings.Misplaced_attribute txt) - | _ -> () ->>>>>>> ocaml/5.1 let add_function_attributes lam loc attr = let lam = diff --git a/lambda/translclass.ml b/lambda/translclass.ml index e0579d0720..10f430931c 100644 --- a/lambda/translclass.ml +++ b/lambda/translclass.ml @@ -44,7 +44,6 @@ let lfunction ?(kind=Curried {nlocal=0}) ?(region=true) return_layout params bod Lfunction {kind = Curried _ as kind; params = params'; body = body'; attr; loc} when List.length params + List.length params' <= Lambda.max_arity() -> -<<<<<<< HEAD lfunction ~kind ~params:(params @ params') ~return:return_layout ~body:body' @@ -52,37 +51,13 @@ let lfunction ?(kind=Curried {nlocal=0}) ?(region=true) return_layout params bod ~loc ~mode:alloc_heap ~region -||||||| merged common ancestors - Lfunction {kind = Curried; params = params @ params'; - return = Pgenval; - body = body'; attr; - loc} -======= - lfunction ~kind:Curried ~params:(params @ params') - ~return:Pgenval - ~body:body' - ~attr - ~loc ->>>>>>> ocaml/5.1 | _ -> -<<<<<<< HEAD lfunction ~kind ~params ~return:return_layout ~body ~attr:default_function_attribute ~loc:Loc_unknown ~mode:alloc_heap ~region -||||||| merged common ancestors - Lfunction {kind = Curried; params; return = Pgenval; - body; - attr = default_function_attribute; - loc = Loc_unknown} -======= - lfunction ~kind:Curried ~params ~return:Pgenval - ~body - ~attr:default_function_attribute - ~loc:Loc_unknown ->>>>>>> ocaml/5.1 let lapply ap = match ap.ap_func with @@ -91,7 +66,6 @@ let lapply ap = | _ -> Lapply ap -<<<<<<< HEAD let lparam name layout : Lambda.lparam = { name; layout; attributes = Lambda.default_param_attribute; mode = alloc_heap } @@ -111,41 +85,13 @@ let mkappl (func, args, layout) = ap_specialised=Default_specialise; ap_probe=None; }], - Loc_unknown);; -||||||| merged common ancestors -let mkappl (func, args) = - Lapply { - ap_loc=Loc_unknown; - ap_func=func; - ap_args=args; - ap_tailcall=Default_tailcall; - ap_inlined=Default_inline; - ap_specialised=Default_specialise; - };; -======= -let mkappl (func, args) = - Lapply { - ap_loc=Loc_unknown; - ap_func=func; - ap_args=args; - ap_tailcall=Default_tailcall; - ap_inlined=Default_inline; - ap_specialised=Default_specialise; - } ->>>>>>> ocaml/5.1 + Loc_unknown) let lsequence l1 l2 = if l2 = lambda_unit then l1 else Lsequence(l1, l2) -<<<<<<< HEAD let lfield v i = - Lprim(Pfield (i, Reads_vary), [Lvar v], Loc_unknown) -||||||| merged common ancestors -let lfield v i = Lprim(Pfield i, [Lvar v], Loc_unknown) -======= -let lfield v i = Lprim(Pfield (i, Pointer, Mutable), - [Lvar v], Loc_unknown) ->>>>>>> ocaml/5.1 + Lprim(Pfield (i, Pointer, Reads_vary), [Lvar v], Loc_unknown) let transl_label l = share (Const_immstring l) @@ -217,13 +163,7 @@ let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl = let env = match envs with None -> [] | Some envs -> -<<<<<<< HEAD - [Lprim(Pfield (List.length inh_init + 1, Reads_vary), -||||||| merged common ancestors - [Lprim(Pfield (List.length inh_init + 1), -======= - [Lprim(Pfield (List.length inh_init + 1, Pointer, Mutable), ->>>>>>> ocaml/5.1 + [Lprim(Pfield (List.length inh_init + 1, Pointer, Reads_vary), [Lvar envs], Loc_unknown)] in @@ -269,7 +209,6 @@ let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl = (inh_init, let build params rem = let param = name_pattern "param" pat in -<<<<<<< HEAD let arg_sort = Jkind.Sort.for_class_arg in let arg_layout = Typeopt.layout pat.pat_env pat.pat_loc arg_sort pat.pat_type @@ -288,22 +227,6 @@ let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl = ~body ~mode:alloc_heap ~region:true -||||||| merged common ancestors - Lfunction {kind = Curried; params = (param, Pgenval)::params; - return = Pgenval; - attr = default_function_attribute; - loc = of_location ~scopes pat.pat_loc; - body = Matching.for_function ~scopes pat.pat_loc - None (Lvar param) [pat, rem] partial} -======= - Lambda.lfunction - ~kind:Curried ~params:((param, Pgenval)::params) - ~return:Pgenval - ~attr:default_function_attribute - ~loc:(of_location ~scopes pat.pat_loc) - ~body:(Matching.for_function ~scopes pat.pat_loc - None (Lvar param) [pat, rem] partial) ->>>>>>> ocaml/5.1 in begin match obj_init with Lfunction {kind = Curried {nlocal=0}; params; body = rem} -> @@ -398,7 +321,7 @@ let rec index a = function let bind_id_as_val (id, _) = ("", id) -let class_field i = Pfield (i, Reads_vary) +let class_field i = Pfield (i, Pointer, Reads_vary) let rec build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl = match cl.cl_desc with @@ -406,24 +329,10 @@ let rec build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl = begin match inh_init with | (_, path_lam, obj_init)::inh_init -> (inh_init, -<<<<<<< HEAD Llet (Strict, layout_t, obj_init, mkappl(Lprim(class_field 1, [path_lam], Loc_unknown), (Lvar cla :: if top then [Lprim(class_field 3, [path_lam], Loc_unknown)] else []), layout_t), -||||||| merged common ancestors - Llet (Strict, Pgenval, obj_init, - mkappl(Lprim(Pfield 1, [path_lam], Loc_unknown), Lvar cla :: - if top then [Lprim(Pfield 3, [path_lam], Loc_unknown)] - else []), -======= - Llet (Strict, Pgenval, obj_init, - mkappl(Lprim(Pfield (1, Pointer, Mutable), - [path_lam], Loc_unknown), Lvar cla :: - if top then [Lprim(Pfield (3, Pointer, Mutable), - [path_lam], Loc_unknown)] - else []), ->>>>>>> ocaml/5.1 bind_super cla super cl_init)) | _ -> assert false @@ -588,7 +497,6 @@ let rec transl_class_rebind ~scopes obj_init cl vf = transl_class_rebind ~scopes obj_init cl vf in let build params rem = let param = name_pattern "param" pat in -<<<<<<< HEAD let arg_sort = Jkind.Sort.for_class_arg in let arg_layout = Typeopt.layout pat.pat_env pat.pat_loc arg_sort pat.pat_type @@ -607,22 +515,6 @@ let rec transl_class_rebind ~scopes obj_init cl vf = ~body ~mode:alloc_heap ~region:true -||||||| merged common ancestors - Lfunction {kind = Curried; params = (param, Pgenval)::params; - return = Pgenval; - attr = default_function_attribute; - loc = of_location ~scopes pat.pat_loc; - body = Matching.for_function ~scopes pat.pat_loc - None (Lvar param) [pat, rem] partial} -======= - Lambda.lfunction - ~kind:Curried ~params:((param, Pgenval)::params) - ~return:Pgenval - ~attr:default_function_attribute - ~loc:(of_location ~scopes pat.pat_loc) - ~body:(Matching.for_function ~scopes pat.pat_loc - None (Lvar param) [pat, rem] partial) ->>>>>>> ocaml/5.1 in (path, path_lam, match obj_init with @@ -731,13 +623,7 @@ let rec builtin_meths self env env2 body = | p when const_path p -> "const", [p] | Lprim(Parrayrefu _, [Lvar s; Lvar n], _) when List.mem s self -> "var", [Lvar n] -<<<<<<< HEAD - | Lprim(Pfield (n, _), [Lvar e], _) when Ident.same e env -> -||||||| merged common ancestors - | Lprim(Pfield n, [Lvar e], _) when Ident.same e env -> -======= | Lprim(Pfield(n, _, _), [Lvar e], _) when Ident.same e env -> ->>>>>>> ocaml/5.1 "env", [Lvar env2; Lconst(const_int n)] | Lsend(Self, met, Lvar s, [], _, _, _, _) when List.mem s self -> "meth", [met] @@ -983,7 +869,6 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = let concrete = (vflag = Concrete) and lclass lam = -<<<<<<< HEAD let cl_init = llets layout_function (Lambda.lfunction ~kind:(Curried {nlocal=0}) ~attr:default_function_attribute @@ -993,22 +878,6 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = ~region:true ~params:[lparam cla layout_table] ~body:cl_init) in Llet(Strict, layout_function, class_init, cl_init, lam (free_variables cl_init)) -||||||| merged common ancestors - let cl_init = llets (Lfunction{kind = Curried; - attr = default_function_attribute; - loc = Loc_unknown; - return = Pgenval; - params = [cla, Pgenval]; body = cl_init}) in - Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init)) -======= - let cl_init = llets (Lambda.lfunction - ~kind:Curried - ~attr:default_function_attribute - ~loc:Loc_unknown - ~return:Pgenval - ~params:[cla, Pgenval] ~body:cl_init) in - Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init)) ->>>>>>> ocaml/5.1 and lbody fv = if List.for_all (fun id -> not (Ident.Set.mem id fv)) ids then mkappl (oo_prim "make_class",[transl_meth_list pub_meths; @@ -1024,7 +893,6 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = Lvar class_init; Lvar env_init; lambda_unit], Loc_unknown)))) and lbody_virt lenvs = -<<<<<<< HEAD Lprim(Pmakeblock(0, Immutable, None, alloc_heap), [lambda_unit; Lambda.lfunction ~kind:(Curried {nlocal=0}) @@ -1034,22 +902,6 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = ~mode:alloc_heap ~region:true ~params:[lparam cla layout_table] ~body:cl_init; -||||||| merged common ancestors - Lprim(Pmakeblock(0, Immutable, None), - [lambda_unit; Lfunction{kind = Curried; - attr = default_function_attribute; - loc = Loc_unknown; - return = Pgenval; - params = [cla, Pgenval]; body = cl_init}; -======= - Lprim(Pmakeblock(0, Immutable, None), - [lambda_unit; Lambda.lfunction - ~kind:Curried - ~attr:default_function_attribute - ~loc:Loc_unknown - ~return:Pgenval - ~params:[cla, Pgenval] ~body:cl_init; ->>>>>>> ocaml/5.1 lambda_unit; lenvs], Loc_unknown) in @@ -1076,14 +928,7 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = Loc_unknown) and linh_envs = List.map -<<<<<<< HEAD (fun (_, path_lam, _) -> Lprim(class_field 3, [path_lam], Loc_unknown)) -||||||| merged common ancestors - (fun (_, path_lam, _) -> Lprim(Pfield 3, [path_lam], Loc_unknown)) -======= - (fun (_, path_lam, _) -> - Lprim(Pfield (3, Pointer, Mutable), [path_lam], Loc_unknown)) ->>>>>>> ocaml/5.1 (List.rev inh_init) in let make_envs lam = @@ -1104,17 +949,10 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = let inh_keys = List.map (fun (_, path_lam, _) -> -<<<<<<< HEAD Lprim(class_field 1, [path_lam], Loc_unknown)) -||||||| merged common ancestors - (fun (_, path_lam, _) -> Lprim(Pfield 1, [path_lam], Loc_unknown)) -======= - Lprim(Pfield (1, Pointer, Mutable), [path_lam], Loc_unknown)) ->>>>>>> ocaml/5.1 inh_paths in let lclass lam = -<<<<<<< HEAD Llet(Strict, layout_function, class_init, Lambda.lfunction ~kind:(Curried {nlocal=0}) ~params:[lparam cla layout_table] @@ -1123,21 +961,6 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = ~loc:Loc_unknown ~mode:alloc_heap ~region:true -||||||| merged common ancestors - Llet(Strict, Pgenval, class_init, - Lfunction{kind = Curried; params = [cla, Pgenval]; - return = Pgenval; - attr = default_function_attribute; - loc = Loc_unknown; - body = def_ids cla cl_init}, lam) -======= - Llet(Strict, Pgenval, class_init, - Lambda.lfunction - ~kind:Curried ~params:[cla, Pgenval] - ~return:Pgenval - ~attr:default_function_attribute - ~loc:Loc_unknown ->>>>>>> ocaml/5.1 ~body:(def_ids cla cl_init), lam) and lcache lam = if inh_keys = [] then Llet(Alias, layout_tables, cached, Lvar tables, lam) else @@ -1158,7 +981,6 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = and lclass_virt () = lset cached 0 (Lambda.lfunction -<<<<<<< HEAD ~kind:(Curried {nlocal=0}) ~attr:default_function_attribute ~loc:Loc_unknown @@ -1166,24 +988,6 @@ let transl_class ~scopes ids cl_id pub_meths cl vflag = ~region:true ~return:layout_function ~params:[lparam cla layout_table] -||||||| merged common ancestors - (Lfunction - { - kind = Curried; - attr = default_function_attribute; - loc = Loc_unknown; - return = Pgenval; - params = [cla, Pgenval]; - body = def_ids cla cl_init; - } - ) -======= - ~kind:Curried - ~attr:default_function_attribute - ~loc:Loc_unknown - ~return:Pgenval - ~params:[cla, Pgenval] ->>>>>>> ocaml/5.1 ~body:(def_ids cla cl_init)) in let lupdate_cache = diff --git a/lambda/translcore.ml b/lambda/translcore.ml index e57c4f9441..2312fdf57b 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -135,7 +135,6 @@ let extract_float = function Const_base(Const_float f) -> f | _ -> fatal_error "Translcore.extract_float" -<<<<<<< HEAD let transl_apply_position position = match position with | Default -> Rc_normal @@ -210,15 +209,6 @@ let maybe_region_layout layout lam = let maybe_region_exp sort exp lam = maybe_region (fun () -> layout_exp sort exp) lam -||||||| merged common ancestors -(* Push the default values under the functional abstractions *) -(* Also push bindings of module patterns, since this sound *) - -type binding = - | Bind_value of value_binding list - | Bind_module of Ident.t * string option loc * module_presence * module_expr -======= ->>>>>>> ocaml/5.1 (* Push the default values under the functional abstractions *) let wrap_bindings bindings exp = @@ -231,12 +221,7 @@ let rec trivial_pat pat = match pat.pat_desc with Tpat_var _ | Tpat_any -> true -<<<<<<< HEAD | Tpat_alias (p, _, _, _, _) -> -||||||| merged common ancestors -======= - | Tpat_alias (p, _, _) -> ->>>>>>> ocaml/5.1 trivial_pat p | Tpat_construct (_, cd, [], _) -> not cd.cstr_generalized && cd.cstr_consts = 1 && cd.cstr_nonconsts = 0 @@ -267,25 +252,8 @@ let rec push_defaults loc bindings use_lhs arg_mode arg_sort cases (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] -> push_defaults loc (binds :: bindings) true -<<<<<<< HEAD arg_mode arg_sort [{c_lhs=pat;c_guard=None;c_rhs=e2}] partial warnings -||||||| merged common ancestors - push_defaults loc (Bind_value binds :: bindings) true - [{c_lhs=pat;c_guard=None;c_rhs=e2}] - partial - | [{c_lhs=pat; c_guard=None; - c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#modulepat"};_}]; - exp_desc = Texp_letmodule - (Some id, name, pres, mexpr, - ({exp_desc = Texp_function _} as e2))}}] -> - push_defaults loc (Bind_module (id, name, pres, mexpr) :: bindings) true - [{c_lhs=pat;c_guard=None;c_rhs=e2}] - partial -======= - [{c_lhs=pat;c_guard=None;c_rhs=e2}] - partial ->>>>>>> ocaml/5.1 | [{c_lhs=pat; c_guard=None; c_rhs=exp} as case] when use_lhs || trivial_pat pat && exp.exp_desc <> Texp_unreachable -> [{case with c_rhs = wrap_bindings bindings exp}] @@ -347,13 +315,7 @@ let event_function ~scopes exp lam = let assert_failed loc ~scopes exp = let slot = transl_extension_path Loc_unknown -<<<<<<< HEAD - (Lazy.force Env.initial_safe_string) Predef.path_assert_failure -||||||| merged common ancestors - Env.initial_safe_string Predef.path_assert_failure -======= - Env.initial Predef.path_assert_failure ->>>>>>> ocaml/5.1 + (Lazy.force Env.initial) Predef.path_assert_failure in let (fname, line, char) = Location.get_pos_info loc.Location.loc_start @@ -579,35 +541,19 @@ and transl_exp0 ~in_new_scope ~scopes sort e = let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in check_record_field_sort id.loc lbl_sort lbl.lbl_repres; begin match lbl.lbl_repres with -<<<<<<< HEAD Record_boxed _ | Record_inlined (_, Variant_boxed _) -> - Lprim (Pfield (lbl.lbl_pos, sem), [targ], -||||||| merged common ancestors - Record_regular | Record_inlined _ -> - Lprim (Pfield lbl.lbl_pos, [targ], -======= - Record_regular | Record_inlined _ -> - Lprim (Pfield (lbl.lbl_pos, maybe_pointer e, lbl.lbl_mut), [targ], ->>>>>>> ocaml/5.1 + Lprim (Pfield (lbl.lbl_pos, maybe_pointer e, sem), [targ], of_location ~scopes e.exp_loc) | Record_unboxed | Record_inlined (_, Variant_unboxed) -> targ | Record_float -> let mode = transl_alloc_mode (Option.get alloc_mode) in Lprim (Pfloatfield (lbl.lbl_pos, sem, mode), [targ], of_location ~scopes e.exp_loc) -<<<<<<< HEAD | Record_ufloat -> Lprim (Pufloatfield (lbl.lbl_pos, sem), [targ], of_location ~scopes e.exp_loc) | Record_inlined (_, Variant_extensible) -> - Lprim (Pfield (lbl.lbl_pos + 1, sem), [targ], -||||||| merged common ancestors - | Record_extension _ -> - Lprim (Pfield (lbl.lbl_pos + 1), [targ], -======= - | Record_extension _ -> - Lprim (Pfield (lbl.lbl_pos + 1, maybe_pointer e, lbl.lbl_mut), [targ], ->>>>>>> ocaml/5.1 + Lprim (Pfield (lbl.lbl_pos + 1, maybe_pointer e, sem), [targ], of_location ~scopes e.exp_loc) end | Texp_setfield(arg, arg_mode, id, lbl, newval) -> @@ -785,15 +731,8 @@ and transl_exp0 ~in_new_scope ~scopes sort e = Lapply{ ap_loc=loc; ap_func= -<<<<<<< HEAD - Lprim(Pfield (0, Reads_vary), + Lprim(Pfield (0, Pointer, Reads_vary), [transl_class_path loc e.exp_env cl], loc); -||||||| merged common ancestors - Lprim(Pfield 0, [transl_class_path loc e.exp_env cl], loc); -======= - Lprim(Pfield (0, Pointer, Mutable), - [transl_class_path loc e.exp_env cl], loc); ->>>>>>> ocaml/5.1 ap_args=[lambda_unit]; ap_result_layout=layout_exp sort e; ap_region_close=pos; @@ -839,14 +778,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = | Texp_letmodule(None, loc, Mp_present, modl, body) -> let lam = !transl_module ~scopes Tcoerce_none None modl in Lsequence(Lprim(Pignore, [lam], of_location ~scopes loc.loc), -<<<<<<< HEAD transl_exp ~scopes sort body) -||||||| merged common ancestors - transl_exp ~scopes body) - | Texp_letmodule(Some id, loc, Mp_present, modl, body) -> -======= - transl_exp ~scopes body) ->>>>>>> ocaml/5.1 | Texp_letmodule(Some id, _loc, Mp_present, modl, body) -> let defining_expr = let mod_scopes = enter_module_definition ~scopes id in @@ -862,36 +794,18 @@ and transl_exp0 ~in_new_scope ~scopes sort e = transl_exp ~scopes sort body) | Texp_pack modl -> !transl_module ~scopes Tcoerce_none None modl -<<<<<<< HEAD - | Texp_assert {exp_desc=Texp_construct(_, {cstr_name="false"}, _, _)} -> - assert_failed ~scopes e - | Texp_assert (cond) -> -||||||| merged common ancestors - | Texp_assert {exp_desc=Texp_construct(_, {cstr_name="false"}, _)} -> - assert_failed ~scopes e - | Texp_assert (cond) -> -======= - | Texp_assert ({exp_desc=Texp_construct(_, {cstr_name="false"}, _)}, loc) -> + | Texp_assert ({exp_desc=Texp_construct(_, {cstr_name="false"}, _, _)}, loc) -> assert_failed loc ~scopes e | Texp_assert (cond, loc) -> ->>>>>>> ocaml/5.1 if !Clflags.noassert then lambda_unit -<<<<<<< HEAD else begin Lifthenelse (transl_exp ~scopes Jkind.Sort.for_predef_value cond, lambda_unit, - assert_failed ~scopes e, + assert_failed loc ~scopes e, Lambda.layout_unit) end -||||||| merged common ancestors - else Lifthenelse (transl_exp ~scopes cond, lambda_unit, - assert_failed ~scopes e) -======= - else Lifthenelse (transl_exp ~scopes cond, lambda_unit, - assert_failed loc ~scopes e) ->>>>>>> ocaml/5.1 | Texp_lazy e -> (* when e needs no computation (constants, identifiers, ...), we optimize the translation just as Lazy.lazy_from_val would @@ -925,7 +839,6 @@ and transl_exp0 ~in_new_scope ~scopes sort e = | `Identifier `Other -> transl_exp ~scopes Jkind.Sort.for_lazy_body e | `Other -> -<<<<<<< HEAD (* other cases compile to a lazy block holding a function. The typechecker enforces that e has jkind value. *) let scopes = enter_lazy ~scopes in @@ -944,25 +857,6 @@ and transl_exp0 ~in_new_scope ~scopes sort e = (transl_exp ~scopes Jkind.Sort.for_lazy_body e)) in Lprim(Pmakeblock(Config.lazy_tag, Mutable, None, alloc_heap), [fn], -||||||| merged common ancestors - (* other cases compile to a lazy block holding a function *) - let fn = Lfunction {kind = Curried; - params= [Ident.create_local "param", Pgenval]; - return = Pgenval; - attr = default_function_attribute; - loc = of_location ~scopes e.exp_loc; - body = transl_exp ~scopes e} in - Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [fn], -======= - (* other cases compile to a lazy block holding a function *) - let fn = lfunction ~kind:Curried - ~params:[Ident.create_local "param", Pgenval] - ~return:Pgenval - ~attr:default_function_attribute - ~loc:(of_location ~scopes e.exp_loc) - ~body:(transl_exp ~scopes e) in - Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [fn], ->>>>>>> ocaml/5.1 of_location ~scopes e.exp_loc) end | Texp_object (cs, meths) -> @@ -997,16 +891,8 @@ and transl_exp0 ~in_new_scope ~scopes sort e = module. When that changes, some adjustments may be needed here. *) List.fold_left (fun (body, pos) id -> -<<<<<<< HEAD Llet(Alias, Lambda.layout_module_field, id, Lprim(mod_field pos, [Lvar oid], -||||||| merged common ancestors - Llet(Alias, Pgenval, id, - Lprim(Pfield pos, [Lvar oid], -======= - Llet(Alias, Pgenval, id, - Lprim(Pfield (pos, Pointer, Mutable), [Lvar oid], ->>>>>>> ocaml/5.1 of_location ~scopes od.open_loc), body), pos + 1 ) (transl_exp ~scopes sort e, 0) @@ -1161,16 +1047,8 @@ and transl_guard ~scopes guard rhs_sort rhs = (Lifthenelse(transl_exp ~scopes Jkind.Sort.for_predef_value cond, expr, staticfail, layout)) -<<<<<<< HEAD and transl_case ~scopes rhs_sort {c_lhs; c_guard; c_rhs} = - c_lhs, transl_guard ~scopes c_guard rhs_sort c_rhs -||||||| merged common ancestors -and transl_case ~scopes {c_lhs; c_guard; c_rhs} = - c_lhs, transl_guard ~scopes c_guard c_rhs -======= -and transl_case ~scopes {c_lhs; c_guard; c_rhs} = - (c_lhs, transl_guard ~scopes c_guard c_rhs) ->>>>>>> ocaml/5.1 + (c_lhs, transl_guard ~scopes c_guard rhs_sort c_rhs) and transl_cases ~scopes rhs_sort cases = let cases = @@ -1274,7 +1152,6 @@ and transl_apply ~scopes in let id_arg = Ident.create_local "param" in let body = -<<<<<<< HEAD let loc = map_scopes enter_partial_or_eta_wrapper loc in let mode = transl_alloc_mode mode_closure in let arg_mode = transl_alloc_mode mode_arg in @@ -1300,40 +1177,6 @@ and transl_apply ~scopes lfunction ~kind:(Curried {nlocal}) ~params ~return:result_layout ~body ~mode ~region ~attr:default_stub_attribute ~loc -||||||| merged common ancestors - match build_apply handle ((Lvar id_arg, optional)::args') l with - Lfunction{kind = Curried; params = ids; return; - body = lam; attr; loc} -> - Lfunction{kind = Curried; - params = (id_arg, Pgenval)::ids; - return; - body = lam; attr; - loc} - | Levent(Lfunction{kind = Curried; params = ids; return; - body = lam; attr; loc}, _) -> - Lfunction{kind = Curried; params = (id_arg, Pgenval)::ids; - return; - body = lam; attr; - loc} - | lam -> - Lfunction{kind = Curried; params = [id_arg, Pgenval]; - return = Pgenval; body = lam; - attr = default_stub_attribute; loc = loc} -======= - match build_apply handle ((Lvar id_arg, optional)::args') l with - Lfunction{kind = Curried; params = ids; return; - body = lam; attr; loc} - when List.length ids < Lambda.max_arity () -> - lfunction ~kind:Curried - ~params:((id_arg, Pgenval)::ids) - ~return - ~body:lam ~attr - ~loc - | lam -> - lfunction ~kind:Curried ~params:[id_arg, Pgenval] - ~return:Pgenval ~body:lam - ~attr:default_stub_attribute ~loc ->>>>>>> ocaml/5.1 in List.fold_right (fun (id, layout, lam) body -> Llet(Strict, layout, id, lam, body)) @@ -1543,27 +1386,8 @@ and transl_function ~in_new_scope ~scopes e alloc_mode param arg_mode arg_sort r in let attr = default_function_attribute in let loc = of_location ~scopes e.exp_loc in -<<<<<<< HEAD let body = if region then maybe_region_layout return body else body in let lam = lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~region in -||||||| merged common ancestors - let lam = Lfunction{kind; params; return; body; attr; loc} in - Translattribute.add_function_attributes lam e.exp_loc e.exp_attributes -======= - let lam = lfunction ~kind ~params ~return ~body ~attr ~loc in - let attrs = - (* Collect attributes from the Pexp_newtype node for locally abstract types. - Otherwise we'd ignore the attribute in, e.g.: - fun [@inline] (type a) x -> ... - *) - List.fold_left - (fun attrs (extra_exp, _, extra_attrs) -> - match extra_exp with - | Texp_newtype _ -> extra_attrs @ attrs - | (Texp_constraint _ | Texp_coerce _ | Texp_poly _) -> attrs) - e.exp_attributes e.exp_extra - in ->>>>>>> ocaml/5.1 Translattribute.add_function_attributes lam e.exp_loc attrs (* Like transl_exp, but used when a new scope was just introduced. *) @@ -1662,50 +1486,29 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = typed tree, then. *) let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in match definition with -<<<<<<< HEAD - | Kept (typ, _) -> + | Kept (typ, mut, _) -> let field_kind = record_field_kind (layout env lbl.lbl_loc lbl_sort typ) in let sem = - match lbl.lbl_mut with + match mut with | Immutable -> Reads_agree | Mutable -> Reads_vary in -||||||| merged common ancestors - | Kept typ -> - let field_kind = value_kind env typ in -======= - | Kept (typ, mut) -> - let field_kind = value_kind env typ in ->>>>>>> ocaml/5.1 let access = match repres with -<<<<<<< HEAD Record_boxed _ | Record_inlined (_, Variant_boxed _) -> - Pfield (i, sem) + Pfield (i, maybe_pointer_type env typ, sem) | Record_unboxed | Record_inlined (_, Variant_unboxed) -> assert false - | Record_inlined (_, Variant_extensible) -> Pfield (i + 1, sem) + | Record_inlined (_, Variant_extensible) -> + Pfield (i + 1, maybe_pointer_type env typ, sem) | Record_float -> (* This allocation is always deleted, so it's simpler to leave it Alloc_heap *) Pfloatfield (i, sem, alloc_heap) | Record_ufloat -> Pufloatfield (i, sem) in -||||||| merged common ancestors - Record_regular | Record_inlined _ -> Pfield i - | Record_unboxed _ -> assert false - | Record_extension _ -> Pfield (i + 1) - | Record_float -> Pfloatfield i in -======= - Record_regular | Record_inlined _ -> - Pfield (i, maybe_pointer_type env typ, mut) - | Record_unboxed _ -> assert false - | Record_extension _ -> - Pfield (i + 1, maybe_pointer_type env typ, mut) - | Record_float -> Pfloatfield i in ->>>>>>> ocaml/5.1 Lprim(access, [Lvar init_id], of_location ~scopes loc), field_kind @@ -1776,13 +1579,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in check_record_field_sort lbl.lbl_loc lbl_sort lbl.lbl_repres; match definition with -<<<<<<< HEAD - | Kept (_type, _uu) -> cont -||||||| merged common ancestors - | Kept _type -> cont -======= | Kept _ -> cont ->>>>>>> ocaml/5.1 | Overridden (_lid, expr) -> let upd = match repres with @@ -2004,15 +1801,9 @@ and transl_letop ~scopes loc env let_ ands param param_sort case case_sort in let attr = default_function_attribute in let loc = of_location ~scopes case.c_rhs.exp_loc in -<<<<<<< HEAD let body = maybe_region_layout return body in lfunction ~kind ~params ~return ~body ~attr ~loc ~mode:alloc_heap ~region:true -||||||| merged common ancestors - Lfunction{kind; params; return; body; attr; loc} -======= - lfunction ~kind ~params ~return ~body ~attr ~loc ->>>>>>> ocaml/5.1 in Lapply{ ap_loc = of_location ~scopes loc; diff --git a/lambda/translmod.ml b/lambda/translmod.ml index cce0e779c0..398308b5d1 100644 --- a/lambda/translmod.ml +++ b/lambda/translmod.ml @@ -112,14 +112,8 @@ let rec apply_coercion loc strict restr arg = name_lambda strict arg Lambda.layout_module (fun id -> let get_field pos = if pos < 0 then lambda_unit -<<<<<<< HEAD else Lprim(mod_field pos,[Lvar id], loc) -||||||| merged common ancestors - else Lprim(Pfield pos,[Lvar id], loc) -======= - else Lprim(Pfield (pos, Pointer, Mutable), [Lvar id], loc) ->>>>>>> ocaml/5.1 in let lam = Lprim(Pmakeblock(0, Immutable, None, alloc_heap), @@ -159,38 +153,16 @@ and apply_coercion_result loc strict funct params args cc_res = name_lambda strict funct Lambda.layout_functor (fun id -> lfunction -<<<<<<< HEAD ~kind:(Curried {nlocal=0}) ~params:(List.rev params) ~return:Lambda.layout_module -||||||| merged common ancestors - Lfunction - { - kind = Curried; - params = List.rev params; - return = Pgenval; - attr = { default_function_attribute with -======= - ~kind:Curried - ~params:(List.rev params) - ~return:Pgenval ->>>>>>> ocaml/5.1 ~attr:{ default_function_attribute with is_a_functor = true; -<<<<<<< HEAD check = Ignore_assert_all Zero_alloc; stub = true; } ~loc ~mode:alloc_heap ~region:true -||||||| merged common ancestors - stub = true; }; - loc = loc; - body = apply_coercion -======= - stub = true; } - ~loc ->>>>>>> ocaml/5.1 ~body:(apply_coercion loc Strict cc_res (Lapply{ @@ -203,12 +175,7 @@ and apply_coercion_result loc strict funct params args cc_res = ap_tailcall=Default_tailcall; ap_inlined=Default_inlined; ap_specialised=Default_specialise; -<<<<<<< HEAD ap_probe=None; -||||||| merged common ancestors - })}) -======= ->>>>>>> ocaml/5.1 }))) and wrap_id_pos_list loc id_pos_list get_field lam = @@ -220,18 +187,10 @@ and wrap_id_pos_list loc id_pos_list get_field lam = List.fold_left (fun (lam, fv, s) (id',pos,c) -> if Ident.Set.mem id' fv then let id'' = Ident.create_local (Ident.name id') in -<<<<<<< HEAD - (Llet(Alias, Lambda.layout_module_field, id'', - apply_coercion loc Alias c (get_field pos),lam), -||||||| merged common ancestors - (Llet(Alias, Pgenval, id'', - apply_coercion loc Alias c (get_field pos),lam), -======= let rhs = apply_coercion loc Alias c (get_field pos) in let fv_rhs = free_variables rhs in - (Llet(Alias, Pgenval, id'', rhs, lam), + (Llet(Alias, Lambda.layout_module_field, id'', rhs, lam), Ident.Set.union fv fv_rhs, ->>>>>>> ocaml/5.1 Ident.Map.add id' id'' s) else (lam, fv, s)) (lam, fv, Ident.Map.empty) id_pos_list @@ -618,47 +577,23 @@ let rec compile_functor ~scopes mexp coercion root_path loc = functor_params_rev in lfunction -<<<<<<< HEAD ~kind:(Curried {nlocal=0}) ~params ~return:Lambda.layout_module -||||||| merged common ancestors - Lfunction { - kind = Curried; - params; - return = Pgenval; - attr = { -======= - ~kind:Curried - ~params - ~return:Pgenval ->>>>>>> ocaml/5.1 ~attr:{ inline = inline_attribute; specialise = Default_specialise; local = Default_local; poll = Default_poll; -<<<<<<< HEAD loop = Never_loop; -||||||| merged common ancestors -======= ->>>>>>> ocaml/5.1 is_a_functor = true; check = Ignore_assert_all Zero_alloc; stub = false; tmc_candidate = false; } ~loc -<<<<<<< HEAD ~mode:alloc_heap ~region:true -||||||| merged common ancestors - }; - loc; - body; - } -======= ->>>>>>> ocaml/5.1 ~body (* Compile a module expression *) @@ -675,42 +610,10 @@ and transl_module ~scopes cc rootpath mexp = oo_wrap mexp.mod_env true (fun () -> compile_functor ~scopes mexp cc rootpath loc) () | Tmod_apply(funct, arg, ccarg) -> -<<<<<<< HEAD - let inlined_attribute = - Translattribute.get_inlined_attribute_on_module funct - in - oo_wrap mexp.mod_env true - (apply_coercion loc Strict cc) - (Lapply{ - ap_loc=loc; - ap_func=transl_module ~scopes Tcoerce_none None funct; - ap_args=[transl_module ~scopes ccarg None arg]; - ap_result_layout = Lambda.layout_module; - ap_region_close=Rc_normal; - ap_mode=alloc_heap; - ap_tailcall=Default_tailcall; - ap_inlined=inlined_attribute; - ap_specialised=Default_specialise; - ap_probe=None;}) -||||||| merged common ancestors - let inlined_attribute, funct = - Translattribute.get_and_remove_inlined_attribute_on_module funct - in - oo_wrap mexp.mod_env true - (apply_coercion loc Strict cc) - (Lapply{ - ap_loc=loc; - ap_func=transl_module ~scopes Tcoerce_none None funct; - ap_args=[transl_module ~scopes ccarg None arg]; - ap_tailcall=Default_tailcall; - ap_inlined=inlined_attribute; - ap_specialised=Default_specialise}) -======= let translated_arg = transl_module ~scopes ccarg None arg in transl_apply ~scopes ~loc ~cc mexp.mod_env funct translated_arg | Tmod_apply_unit funct -> transl_apply ~scopes ~loc ~cc mexp.mod_env funct lambda_unit ->>>>>>> ocaml/5.1 | Tmod_constraint(arg, _, _, ccarg) -> transl_module ~scopes (compose_coercions cc ccarg) rootpath arg | Tmod_unpack(arg, _) -> @@ -718,8 +621,8 @@ and transl_module ~scopes cc rootpath mexp = (Translcore.transl_exp ~scopes Jkind.Sort.for_module arg) and transl_apply ~scopes ~loc ~cc mod_env funct translated_arg = - let inlined_attribute, funct = - Translattribute.get_and_remove_inlined_attribute_on_module funct + let inlined_attribute = + Translattribute.get_inlined_attribute_on_module funct in oo_wrap mod_env true (apply_coercion loc Strict cc) @@ -727,9 +630,13 @@ and transl_apply ~scopes ~loc ~cc mod_env funct translated_arg = ap_loc=loc; ap_func=transl_module ~scopes Tcoerce_none None funct; ap_args=[translated_arg]; + ap_result_layout = Lambda.layout_module; + ap_region_close=Rc_normal; + ap_mode=alloc_heap; ap_tailcall=Default_tailcall; ap_inlined=inlined_attribute; - ap_specialised=Default_specialise}) + ap_specialised=Default_specialise; + ap_probe=None;}) and transl_struct ~scopes loc fields cc rootpath {str_final_env; str_items; _} = transl_structure ~scopes loc fields cc rootpath str_final_env str_items @@ -859,21 +766,7 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function of_location ~scopes mb.mb_name.loc), body), size | Some id -> -<<<<<<< HEAD Llet(pure_module mb.mb_expr, Lambda.layout_module, id, module_body, body), size -||||||| merged common ancestors - let module_body = - Levent (module_body, { - lev_loc = of_location ~scopes mb.mb_loc; - lev_kind = Lev_module_definition id; - lev_repr = None; - lev_env = Env.empty; - }) - in - Llet(pure_module mb.mb_expr, Pgenval, id, module_body, body), size -======= - Llet(pure_module mb.mb_expr, Pgenval, id, module_body, body), size ->>>>>>> ocaml/5.1 end | Tstr_module ({mb_presence=Mp_absent}) -> transl_structure ~scopes loc fields cc rootpath final_env rem @@ -920,19 +813,9 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function let body, size = rebind_idents (pos + 1) (id :: newfields) ids in -<<<<<<< HEAD Llet(Alias, Lambda.layout_module_field, id, Lprim(mod_field pos, [Lvar mid], of_location ~scopes incl.incl_loc), body), -||||||| merged common ancestors - Llet(Alias, Pgenval, id, - Lprim(Pfield pos, [Lvar mid], - of_location ~scopes incl.incl_loc), body), -======= - Llet(Alias, Pgenval, id, - Lprim(Pfield (pos, Pointer, Mutable), - [Lvar mid], of_location ~scopes incl.incl_loc), body), ->>>>>>> ocaml/5.1 size in let body, size = rebind_idents 0 fields ids in @@ -970,16 +853,8 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function let body, size = rebind_idents (pos + 1) (id :: newfields) ids in -<<<<<<< HEAD Llet(Alias, Lambda.layout_module_field, id, Lprim(mod_field pos, [Lvar mid], -||||||| merged common ancestors - Llet(Alias, Pgenval, id, - Lprim(Pfield pos, [Lvar mid], -======= - Llet(Alias, Pgenval, id, - Lprim(Pfield (pos, Pointer, Mutable), [Lvar mid], ->>>>>>> ocaml/5.1 of_location ~scopes od.open_loc), body), size in @@ -1027,27 +902,12 @@ let _ = (* Introduce dependencies on modules referenced only by "external". *) let scan_used_globals lam = -<<<<<<< HEAD let globals = ref Compilation_unit.Set.empty in -||||||| merged common ancestors - let globals = ref Ident.Set.empty in -======= - let is_compunit id = not (Ident.is_predef id) in - let globals = ref Ident.Set.empty in ->>>>>>> ocaml/5.1 let rec scan lam = Lambda.iter_head_constructor scan lam; match lam with -<<<<<<< HEAD Lprim ((Pgetglobal cu | Psetglobal cu), _, _) -> globals := Compilation_unit.Set.add cu !globals -||||||| merged common ancestors - Lprim ((Pgetglobal id | Psetglobal id), _, _) -> - globals := Ident.Set.add id !globals -======= - Lprim ((Pgetglobal id | Psetglobal id), _, _) when (is_compunit id) -> - globals := Ident.Set.add id !globals ->>>>>>> ocaml/5.1 | _ -> () in scan lam; !globals @@ -1207,21 +1067,10 @@ and all_idents = function List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ all_idents rem | Tstr_class_type _ -> all_idents rem -<<<<<<< HEAD - | Tstr_include{incl_type; incl_mod={mod_desc = - ( Tmod_constraint ({mod_desc = Tmod_structure str}, - _, _, _) - | Tmod_structure str ) }} -> -||||||| merged common ancestors - | Tstr_include{incl_type; incl_mod={mod_desc = - Tmod_constraint ({mod_desc = Tmod_structure str}, - _, _, _)}} -> -======= | Tstr_include{incl_type; incl_mod={mod_desc = ( Tmod_constraint({mod_desc=Tmod_structure str}, _, _, _) | Tmod_structure str )}} -> ->>>>>>> ocaml/5.1 bound_value_identifiers incl_type @ all_idents str.str_items @ all_idents rem @@ -1260,13 +1109,7 @@ let transl_store_subst = ref Ident.Map.empty let nat_toplevel_name id = try match Ident.Map.find id !transl_store_subst with -<<<<<<< HEAD - | Lprim(Pfield (pos, _), -||||||| merged common ancestors - | Lprim(Pfield pos, [Lprim(Pgetglobal glob, [], _)], _) -> (glob,pos) -======= | Lprim(Pfield (pos, _, _), ->>>>>>> ocaml/5.1 [Lprim(Pgetglobal glob, [], _)], _) -> (glob,pos) | _ -> raise Not_found with Not_found -> @@ -1461,35 +1304,11 @@ let transl_store_structure ~scopes glob map prims aliases str = incl_loc=loc; incl_mod= { mod_desc = Tmod_constraint ( -<<<<<<< HEAD ({mod_desc = Tmod_structure str}), _, _, (Tcoerce_structure _ | Tcoerce_none))} | ({ mod_desc = Tmod_structure str}); -||||||| merged common ancestors - ({mod_desc = Tmod_structure str} as mexp), _, _, - (Tcoerce_structure (map, _)))}; - incl_attributes; -======= - ({mod_desc = Tmod_structure str} as mexp), _, _, - (Tcoerce_structure _ | Tcoerce_none))} - | ({ mod_desc = Tmod_structure str} as mexp); - incl_attributes; ->>>>>>> ocaml/5.1 incl_type; } as incl) -> -<<<<<<< HEAD -||||||| merged common ancestors - } -> - List.iter (Translattribute.check_attribute_on_module mexp) - incl_attributes; - (* Shouldn't we use mod_attributes instead of incl_attributes? - Same question for the Tstr_module cases above, btw. *) -======= - List.iter (Translattribute.check_attribute_on_module mexp) - incl_attributes; - (* Shouldn't we use mod_attributes instead of incl_attributes? - Same question for the Tstr_module cases above, btw. *) ->>>>>>> ocaml/5.1 let lam = transl_store ~scopes None subst lambda_unit str.str_items (* It is tempting to pass rootpath instead of None @@ -1522,13 +1341,7 @@ let transl_store_structure ~scopes glob map prims aliases str = | _ -> assert false in Lsequence(lam, loop ids0 map) -<<<<<<< HEAD -||||||| merged common ancestors - -======= - ->>>>>>> ocaml/5.1 | Tstr_include incl -> let ids = bound_value_identifiers incl.incl_type in let modl = incl.incl_mod in @@ -1538,20 +1351,9 @@ let transl_store_structure ~scopes glob map prims aliases str = | [] -> transl_store ~scopes rootpath (add_idents true ids subst) cont rem | id :: idl -> -<<<<<<< HEAD Llet(Alias, Lambda.layout_module_field, id, Lprim(mod_field pos, [Lvar mid], loc), Lsequence(store_ident loc id, -||||||| merged common ancestors - Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], - of_location ~scopes loc), - Lsequence(store_ident (of_location ~scopes loc) id, -======= - Llet(Alias, Pgenval, id, - Lprim(Pfield (pos, Pointer, Mutable), [Lvar mid], - of_location ~scopes loc), - Lsequence(store_ident (of_location ~scopes loc) id, ->>>>>>> ocaml/5.1 store_idents (pos + 1) idl)) in let modl = @@ -1602,16 +1404,8 @@ let transl_store_structure ~scopes glob map prims aliases str = [] -> transl_store ~scopes rootpath (add_idents true ids subst) cont rem | id :: idl -> -<<<<<<< HEAD Llet(Alias, Lambda.layout_module_field, id, Lprim(mod_field pos, -||||||| merged common ancestors - Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], - loc), -======= - Llet(Alias, Pgenval, id, - Lprim(Pfield (pos, Pointer, Mutable), ->>>>>>> ocaml/5.1 [Lvar mid], loc), Lsequence(store_ident loc id, store_idents (pos + 1) idl)) @@ -1646,13 +1440,7 @@ let transl_store_structure ~scopes glob map prims aliases str = match cc with Tcoerce_none -> Ident.Map.add id -<<<<<<< HEAD (Lprim(mod_field pos, -||||||| merged common ancestors - (Lprim(Pfield pos, -======= - (Lprim(Pfield (pos, Pointer, Immutable), ->>>>>>> ocaml/5.1 [Lprim(Pgetglobal glob, [], Loc_unknown)], Loc_unknown)) subst @@ -1801,16 +1589,8 @@ let toplevel_name id = let toploop_getvalue id = Lapply{ ap_loc=Loc_unknown; -<<<<<<< HEAD ap_func=Lprim(mod_field toploop_getvalue_pos, [Lprim(Pgetglobal toploop_unit, [], Loc_unknown)], -||||||| merged common ancestors - ap_func=Lprim(Pfield toploop_getvalue_pos, - [Lprim(Pgetglobal toploop_ident, [], Loc_unknown)], -======= - ap_func=Lprim(Pfield (toploop_getvalue_pos, Pointer, Mutable), - [Lprim(Pgetglobal toploop_ident, [], Loc_unknown)], ->>>>>>> ocaml/5.1 Loc_unknown); ap_args=[Lconst(Const_base( Const_string (toplevel_name id, Location.none, None)))]; @@ -1826,16 +1606,8 @@ let toploop_getvalue id = let toploop_setvalue id lam = Lapply{ ap_loc=Loc_unknown; -<<<<<<< HEAD ap_func=Lprim(mod_field toploop_setvalue_pos, [Lprim(Pgetglobal toploop_unit, [], Loc_unknown)], -||||||| merged common ancestors - ap_func=Lprim(Pfield toploop_setvalue_pos, - [Lprim(Pgetglobal toploop_ident, [], Loc_unknown)], -======= - ap_func=Lprim(Pfield (toploop_setvalue_pos, Pointer, Mutable), - [Lprim(Pgetglobal toploop_ident, [], Loc_unknown)], ->>>>>>> ocaml/5.1 Loc_unknown); ap_args= [Lconst(Const_base( @@ -1943,14 +1715,7 @@ let transl_toplevel_item ~scopes item = lambda_unit | id :: ids -> Lsequence(toploop_setvalue id -<<<<<<< HEAD (Lprim(mod_field pos, [Lvar mid], Loc_unknown)), -||||||| merged common ancestors - (Lprim(Pfield pos, [Lvar mid], Loc_unknown)), -======= - (Lprim(Pfield (pos, Pointer, Mutable), - [Lvar mid], Loc_unknown)), ->>>>>>> ocaml/5.1 set_idents (pos + 1) ids) in Llet(Strict, Lambda.layout_module, mid, modl, set_idents 0 ids) | Tstr_primitive descr -> @@ -1972,14 +1737,7 @@ let transl_toplevel_item ~scopes item = lambda_unit | id :: ids -> Lsequence(toploop_setvalue id -<<<<<<< HEAD (Lprim(mod_field pos, [Lvar mid], Loc_unknown)), -||||||| merged common ancestors - (Lprim(Pfield pos, [Lvar mid], Loc_unknown)), -======= - (Lprim(Pfield (pos, Pointer, Mutable), - [Lvar mid], Loc_unknown)), ->>>>>>> ocaml/5.1 set_idents (pos + 1) ids) in Llet(pure, Lambda.layout_module, mid, @@ -2078,14 +1836,7 @@ let transl_package_set_fields component_names target_name coercion = (fun pos _id -> Lprim(mod_setfield pos, [Lprim(Pgetglobal target_name, [], Loc_unknown); -<<<<<<< HEAD Lprim(mod_field pos, [Lvar blk], Loc_unknown)], -||||||| merged common ancestors - Lprim(Pfield pos, [Lvar blk], Loc_unknown)], -======= - Lprim(Pfield (pos, Pointer, Mutable), - [Lvar blk], Loc_unknown)], ->>>>>>> ocaml/5.1 Loc_unknown)) 0 pos_cc_list)) (* diff --git a/lambda/translobj.ml b/lambda/translobj.ml index 24ff6b6a56..21133434ec 100644 --- a/lambda/translobj.ml +++ b/lambda/translobj.ml @@ -134,14 +134,8 @@ let transl_label_init_flambda f = let transl_store_label_init glob size f arg = assert(not (Config.flambda || Config.flambda2)); assert(!Clflags.native_code); -<<<<<<< HEAD method_cache := Lprim(mod_field ~read_semantics:Reads_vary size, -||||||| merged common ancestors - method_cache := Lprim(Pfield size, -======= - method_cache := Lprim(Pfield (size, Pointer, Mutable), (* XXX KC: conservative *) ->>>>>>> ocaml/5.1 [Lprim(Pgetglobal glob, [], Loc_unknown)], Loc_unknown); let expr = f arg in diff --git a/lambda/translprim.ml b/lambda/translprim.ml index a5360c503b..094ac311be 100644 --- a/lambda/translprim.ml +++ b/lambda/translprim.ml @@ -97,7 +97,6 @@ type prim = let units_with_used_primitives = Hashtbl.create 7 let add_used_primitive loc env path = match path with -<<<<<<< HEAD Some (Path.Pdot (path, _)) -> let address = Env.find_module_address path env in begin match Env.address_head address with @@ -106,19 +105,6 @@ let add_used_primitive loc env path = then Hashtbl.add units_with_used_primitives cu loc | AHlocal _ -> () end -||||||| merged common ancestors - Some (Path.Pdot _ as path) -> - let path = Env.normalize_path_prefix (Some loc) env path in - let unit = Path.head path in - if Ident.global unit && not (Hashtbl.mem used_primitives path) - then Hashtbl.add used_primitives path loc -======= - Some (Path.Pdot _ as path) -> - let path = Env.normalize_value_path (Some loc) env path in - let unit = Path.head path in - if Ident.global unit && not (Hashtbl.mem used_primitives path) - then Hashtbl.add used_primitives path loc ->>>>>>> ocaml/5.1 | _ -> () let clear_used_primitives () = Hashtbl.clear units_with_used_primitives @@ -137,7 +123,6 @@ let gen_array_set_kind mode = let prim_sys_argv = Primitive.simple_on_values ~name:"caml_sys_argv" ~arity:1 ~alloc:true -<<<<<<< HEAD let to_locality ~poly = function | Prim_global, _ -> alloc_heap | Prim_local, _ -> alloc_local @@ -145,521 +130,6 @@ let to_locality ~poly = function match poly with | None -> assert false | Some locality -> transl_locality_mode locality -||||||| merged common ancestors -let primitives_table = - create_hashtable 57 [ - "%identity", Identity; - "%bytes_to_string", Primitive (Pbytes_to_string, 1); - "%bytes_of_string", Primitive (Pbytes_of_string, 1); - "%ignore", Primitive (Pignore, 1); - "%revapply", Revapply; - "%apply", Apply; - "%loc_LOC", Loc Loc_LOC; - "%loc_FILE", Loc Loc_FILE; - "%loc_LINE", Loc Loc_LINE; - "%loc_POS", Loc Loc_POS; - "%loc_MODULE", Loc Loc_MODULE; - "%loc_FUNCTION", Loc Loc_FUNCTION; - "%field0", Primitive ((Pfield 0), 1); - "%field1", Primitive ((Pfield 1), 1); - "%setfield0", Primitive ((Psetfield(0, Pointer, Assignment)), 2); - "%makeblock", Primitive ((Pmakeblock(0, Immutable, None)), 1); - "%makemutable", Primitive ((Pmakeblock(0, Mutable, None)), 1); - "%raise", Raise Raise_regular; - "%reraise", Raise Raise_reraise; - "%raise_notrace", Raise Raise_notrace; - "%raise_with_backtrace", Raise_with_backtrace; - "%sequand", Primitive (Psequand, 2); - "%sequor", Primitive (Psequor, 2); - "%boolnot", Primitive (Pnot, 1); - "%big_endian", Primitive ((Pctconst Big_endian), 1); - "%backend_type", Primitive ((Pctconst Backend_type), 1); - "%word_size", Primitive ((Pctconst Word_size), 1); - "%int_size", Primitive ((Pctconst Int_size), 1); - "%max_wosize", Primitive ((Pctconst Max_wosize), 1); - "%ostype_unix", Primitive ((Pctconst Ostype_unix), 1); - "%ostype_win32", Primitive ((Pctconst Ostype_win32), 1); - "%ostype_cygwin", Primitive ((Pctconst Ostype_cygwin), 1); - "%frame_pointers", Frame_pointers; - "%negint", Primitive (Pnegint, 1); - "%succint", Primitive ((Poffsetint 1), 1); - "%predint", Primitive ((Poffsetint(-1)), 1); - "%addint", Primitive (Paddint, 2); - "%subint", Primitive (Psubint, 2); - "%mulint", Primitive (Pmulint, 2); - "%divint", Primitive ((Pdivint Safe), 2); - "%modint", Primitive ((Pmodint Safe), 2); - "%andint", Primitive (Pandint, 2); - "%orint", Primitive (Porint, 2); - "%xorint", Primitive (Pxorint, 2); - "%lslint", Primitive (Plslint, 2); - "%lsrint", Primitive (Plsrint, 2); - "%asrint", Primitive (Pasrint, 2); - "%eq", Primitive ((Pintcomp Ceq), 2); - "%noteq", Primitive ((Pintcomp Cne), 2); - "%ltint", Primitive ((Pintcomp Clt), 2); - "%leint", Primitive ((Pintcomp Cle), 2); - "%gtint", Primitive ((Pintcomp Cgt), 2); - "%geint", Primitive ((Pintcomp Cge), 2); - "%incr", Primitive ((Poffsetref(1)), 1); - "%decr", Primitive ((Poffsetref(-1)), 1); - "%intoffloat", Primitive (Pintoffloat, 1); - "%floatofint", Primitive (Pfloatofint, 1); - "%negfloat", Primitive (Pnegfloat, 1); - "%absfloat", Primitive (Pabsfloat, 1); - "%addfloat", Primitive (Paddfloat, 2); - "%subfloat", Primitive (Psubfloat, 2); - "%mulfloat", Primitive (Pmulfloat, 2); - "%divfloat", Primitive (Pdivfloat, 2); - "%eqfloat", Primitive ((Pfloatcomp CFeq), 2); - "%noteqfloat", Primitive ((Pfloatcomp CFneq), 2); - "%ltfloat", Primitive ((Pfloatcomp CFlt), 2); - "%lefloat", Primitive ((Pfloatcomp CFle), 2); - "%gtfloat", Primitive ((Pfloatcomp CFgt), 2); - "%gefloat", Primitive ((Pfloatcomp CFge), 2); - "%string_length", Primitive (Pstringlength, 1); - "%string_safe_get", Primitive (Pstringrefs, 2); - "%string_safe_set", Primitive (Pbytessets, 3); - "%string_unsafe_get", Primitive (Pstringrefu, 2); - "%string_unsafe_set", Primitive (Pbytessetu, 3); - "%bytes_length", Primitive (Pbyteslength, 1); - "%bytes_safe_get", Primitive (Pbytesrefs, 2); - "%bytes_safe_set", Primitive (Pbytessets, 3); - "%bytes_unsafe_get", Primitive (Pbytesrefu, 2); - "%bytes_unsafe_set", Primitive (Pbytessetu, 3); - "%array_length", Primitive ((Parraylength gen_array_kind), 1); - "%array_safe_get", Primitive ((Parrayrefs gen_array_kind), 2); - "%array_safe_set", Primitive ((Parraysets gen_array_kind), 3); - "%array_unsafe_get", Primitive ((Parrayrefu gen_array_kind), 2); - "%array_unsafe_set", Primitive ((Parraysetu gen_array_kind), 3); - "%obj_size", Primitive ((Parraylength gen_array_kind), 1); - "%obj_field", Primitive ((Parrayrefu gen_array_kind), 2); - "%obj_set_field", Primitive ((Parraysetu gen_array_kind), 3); - "%floatarray_length", Primitive ((Parraylength Pfloatarray), 1); - "%floatarray_safe_get", Primitive ((Parrayrefs Pfloatarray), 2); - "%floatarray_safe_set", Primitive ((Parraysets Pfloatarray), 3); - "%floatarray_unsafe_get", Primitive ((Parrayrefu Pfloatarray), 2); - "%floatarray_unsafe_set", Primitive ((Parraysetu Pfloatarray), 3); - "%obj_is_int", Primitive (Pisint, 1); - "%lazy_force", Lazy_force; - "%nativeint_of_int", Primitive ((Pbintofint Pnativeint), 1); - "%nativeint_to_int", Primitive ((Pintofbint Pnativeint), 1); - "%nativeint_neg", Primitive ((Pnegbint Pnativeint), 1); - "%nativeint_add", Primitive ((Paddbint Pnativeint), 2); - "%nativeint_sub", Primitive ((Psubbint Pnativeint), 2); - "%nativeint_mul", Primitive ((Pmulbint Pnativeint), 2); - "%nativeint_div", - Primitive ((Pdivbint { size = Pnativeint; is_safe = Safe }), 2); - "%nativeint_mod", - Primitive ((Pmodbint { size = Pnativeint; is_safe = Safe }), 2); - "%nativeint_and", Primitive ((Pandbint Pnativeint), 2); - "%nativeint_or", Primitive ( (Porbint Pnativeint), 2); - "%nativeint_xor", Primitive ((Pxorbint Pnativeint), 2); - "%nativeint_lsl", Primitive ((Plslbint Pnativeint), 2); - "%nativeint_lsr", Primitive ((Plsrbint Pnativeint), 2); - "%nativeint_asr", Primitive ((Pasrbint Pnativeint), 2); - "%int32_of_int", Primitive ((Pbintofint Pint32), 1); - "%int32_to_int", Primitive ((Pintofbint Pint32), 1); - "%int32_neg", Primitive ((Pnegbint Pint32), 1); - "%int32_add", Primitive ((Paddbint Pint32), 2); - "%int32_sub", Primitive ((Psubbint Pint32), 2); - "%int32_mul", Primitive ((Pmulbint Pint32), 2); - "%int32_div", Primitive ((Pdivbint { size = Pint32; is_safe = Safe }), 2); - "%int32_mod", Primitive ((Pmodbint { size = Pint32; is_safe = Safe }), 2); - "%int32_and", Primitive ((Pandbint Pint32), 2); - "%int32_or", Primitive ( (Porbint Pint32), 2); - "%int32_xor", Primitive ((Pxorbint Pint32), 2); - "%int32_lsl", Primitive ((Plslbint Pint32), 2); - "%int32_lsr", Primitive ((Plsrbint Pint32), 2); - "%int32_asr", Primitive ((Pasrbint Pint32), 2); - "%int64_of_int", Primitive ((Pbintofint Pint64), 1); - "%int64_to_int", Primitive ((Pintofbint Pint64), 1); - "%int64_neg", Primitive ((Pnegbint Pint64), 1); - "%int64_add", Primitive ((Paddbint Pint64), 2); - "%int64_sub", Primitive ((Psubbint Pint64), 2); - "%int64_mul", Primitive ((Pmulbint Pint64), 2); - "%int64_div", Primitive ((Pdivbint { size = Pint64; is_safe = Safe }), 2); - "%int64_mod", Primitive ((Pmodbint { size = Pint64; is_safe = Safe }), 2); - "%int64_and", Primitive ((Pandbint Pint64), 2); - "%int64_or", Primitive ( (Porbint Pint64), 2); - "%int64_xor", Primitive ((Pxorbint Pint64), 2); - "%int64_lsl", Primitive ((Plslbint Pint64), 2); - "%int64_lsr", Primitive ((Plsrbint Pint64), 2); - "%int64_asr", Primitive ((Pasrbint Pint64), 2); - "%nativeint_of_int32", Primitive ((Pcvtbint(Pint32, Pnativeint)), 1); - "%nativeint_to_int32", Primitive ((Pcvtbint(Pnativeint, Pint32)), 1); - "%int64_of_int32", Primitive ((Pcvtbint(Pint32, Pint64)), 1); - "%int64_to_int32", Primitive ((Pcvtbint(Pint64, Pint32)), 1); - "%int64_of_nativeint", Primitive ((Pcvtbint(Pnativeint, Pint64)), 1); - "%int64_to_nativeint", Primitive ((Pcvtbint(Pint64, Pnativeint)), 1); - "%caml_ba_ref_1", - Primitive - ((Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), - 2); - "%caml_ba_ref_2", - Primitive - ((Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), - 3); - "%caml_ba_ref_3", - Primitive - ((Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), - 4); - "%caml_ba_set_1", - Primitive - ((Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), - 3); - "%caml_ba_set_2", - Primitive - ((Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), - 4); - "%caml_ba_set_3", - Primitive - ((Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), - 5); - "%caml_ba_unsafe_ref_1", - Primitive - ((Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), - 2); - "%caml_ba_unsafe_ref_2", - Primitive - ((Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), - 3); - "%caml_ba_unsafe_ref_3", - Primitive - ((Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), - 4); - "%caml_ba_unsafe_set_1", - Primitive - ((Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), - 3); - "%caml_ba_unsafe_set_2", - Primitive - ((Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), - 4); - "%caml_ba_unsafe_set_3", - Primitive - ((Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), - 5); - "%caml_ba_dim_1", Primitive ((Pbigarraydim(1)), 1); - "%caml_ba_dim_2", Primitive ((Pbigarraydim(2)), 1); - "%caml_ba_dim_3", Primitive ((Pbigarraydim(3)), 1); - "%caml_string_get16", Primitive ((Pstring_load_16(false)), 2); - "%caml_string_get16u", Primitive ((Pstring_load_16(true)), 2); - "%caml_string_get32", Primitive ((Pstring_load_32(false)), 2); - "%caml_string_get32u", Primitive ((Pstring_load_32(true)), 2); - "%caml_string_get64", Primitive ((Pstring_load_64(false)), 2); - "%caml_string_get64u", Primitive ((Pstring_load_64(true)), 2); - "%caml_string_set16", Primitive ((Pbytes_set_16(false)), 3); - "%caml_string_set16u", Primitive ((Pbytes_set_16(true)), 3); - "%caml_string_set32", Primitive ((Pbytes_set_32(false)), 3); - "%caml_string_set32u", Primitive ((Pbytes_set_32(true)), 3); - "%caml_string_set64", Primitive ((Pbytes_set_64(false)), 3); - "%caml_string_set64u", Primitive ((Pbytes_set_64(true)), 3); - "%caml_bytes_get16", Primitive ((Pbytes_load_16(false)), 2); - "%caml_bytes_get16u", Primitive ((Pbytes_load_16(true)), 2); - "%caml_bytes_get32", Primitive ((Pbytes_load_32(false)), 2); - "%caml_bytes_get32u", Primitive ((Pbytes_load_32(true)), 2); - "%caml_bytes_get64", Primitive ((Pbytes_load_64(false)), 2); - "%caml_bytes_get64u", Primitive ((Pbytes_load_64(true)), 2); - "%caml_bytes_set16", Primitive ((Pbytes_set_16(false)), 3); - "%caml_bytes_set16u", Primitive ((Pbytes_set_16(true)), 3); - "%caml_bytes_set32", Primitive ((Pbytes_set_32(false)), 3); - "%caml_bytes_set32u", Primitive ((Pbytes_set_32(true)), 3); - "%caml_bytes_set64", Primitive ((Pbytes_set_64(false)), 3); - "%caml_bytes_set64u", Primitive ((Pbytes_set_64(true)), 3); - "%caml_bigstring_get16", Primitive ((Pbigstring_load_16(false)), 2); - "%caml_bigstring_get16u", Primitive ((Pbigstring_load_16(true)), 2); - "%caml_bigstring_get32", Primitive ((Pbigstring_load_32(false)), 2); - "%caml_bigstring_get32u", Primitive ((Pbigstring_load_32(true)), 2); - "%caml_bigstring_get64", Primitive ((Pbigstring_load_64(false)), 2); - "%caml_bigstring_get64u", Primitive ((Pbigstring_load_64(true)), 2); - "%caml_bigstring_set16", Primitive ((Pbigstring_set_16(false)), 3); - "%caml_bigstring_set16u", Primitive ((Pbigstring_set_16(true)), 3); - "%caml_bigstring_set32", Primitive ((Pbigstring_set_32(false)), 3); - "%caml_bigstring_set32u", Primitive ((Pbigstring_set_32(true)), 3); - "%caml_bigstring_set64", Primitive ((Pbigstring_set_64(false)), 3); - "%caml_bigstring_set64u", Primitive ((Pbigstring_set_64(true)), 3); - "%bswap16", Primitive (Pbswap16, 1); - "%bswap_int32", Primitive ((Pbbswap(Pint32)), 1); - "%bswap_int64", Primitive ((Pbbswap(Pint64)), 1); - "%bswap_native", Primitive ((Pbbswap(Pnativeint)), 1); - "%int_as_pointer", Primitive (Pint_as_pointer, 1); - "%opaque", Primitive (Popaque, 1); - "%sys_argv", External prim_sys_argv; - "%send", Send; - "%sendself", Send_self; - "%sendcache", Send_cache; - "%equal", Comparison(Equal, Compare_generic); - "%notequal", Comparison(Not_equal, Compare_generic); - "%lessequal", Comparison(Less_equal, Compare_generic); - "%lessthan", Comparison(Less_than, Compare_generic); - "%greaterequal", Comparison(Greater_equal, Compare_generic); - "%greaterthan", Comparison(Greater_than, Compare_generic); - "%compare", Comparison(Compare, Compare_generic); - ] -======= -let primitives_table = - create_hashtable 57 [ - "%identity", Identity; - "%bytes_to_string", Primitive (Pbytes_to_string, 1); - "%bytes_of_string", Primitive (Pbytes_of_string, 1); - "%ignore", Primitive (Pignore, 1); - "%revapply", Revapply; - "%apply", Apply; - "%loc_LOC", Loc Loc_LOC; - "%loc_FILE", Loc Loc_FILE; - "%loc_LINE", Loc Loc_LINE; - "%loc_POS", Loc Loc_POS; - "%loc_MODULE", Loc Loc_MODULE; - "%loc_FUNCTION", Loc Loc_FUNCTION; - "%field0", Primitive (Pfield(0, Pointer, Mutable), 1); - "%field1", Primitive (Pfield(1, Pointer, Mutable), 1); - "%setfield0", Primitive ((Psetfield(0, Pointer, Assignment)), 2); - "%makeblock", Primitive ((Pmakeblock(0, Immutable, None)), 1); - "%makemutable", Primitive ((Pmakeblock(0, Mutable, None)), 1); - "%raise", Raise Raise_regular; - "%reraise", Raise Raise_reraise; - "%raise_notrace", Raise Raise_notrace; - "%raise_with_backtrace", Raise_with_backtrace; - "%sequand", Primitive (Psequand, 2); - "%sequor", Primitive (Psequor, 2); - "%boolnot", Primitive (Pnot, 1); - "%big_endian", Primitive ((Pctconst Big_endian), 1); - "%backend_type", Primitive ((Pctconst Backend_type), 1); - "%word_size", Primitive ((Pctconst Word_size), 1); - "%int_size", Primitive ((Pctconst Int_size), 1); - "%max_wosize", Primitive ((Pctconst Max_wosize), 1); - "%ostype_unix", Primitive ((Pctconst Ostype_unix), 1); - "%ostype_win32", Primitive ((Pctconst Ostype_win32), 1); - "%ostype_cygwin", Primitive ((Pctconst Ostype_cygwin), 1); - "%frame_pointers", Frame_pointers; - "%negint", Primitive (Pnegint, 1); - "%succint", Primitive ((Poffsetint 1), 1); - "%predint", Primitive ((Poffsetint(-1)), 1); - "%addint", Primitive (Paddint, 2); - "%subint", Primitive (Psubint, 2); - "%mulint", Primitive (Pmulint, 2); - "%divint", Primitive ((Pdivint Safe), 2); - "%modint", Primitive ((Pmodint Safe), 2); - "%andint", Primitive (Pandint, 2); - "%orint", Primitive (Porint, 2); - "%xorint", Primitive (Pxorint, 2); - "%lslint", Primitive (Plslint, 2); - "%lsrint", Primitive (Plsrint, 2); - "%asrint", Primitive (Pasrint, 2); - "%eq", Primitive ((Pintcomp Ceq), 2); - "%noteq", Primitive ((Pintcomp Cne), 2); - "%ltint", Primitive ((Pintcomp Clt), 2); - "%leint", Primitive ((Pintcomp Cle), 2); - "%gtint", Primitive ((Pintcomp Cgt), 2); - "%geint", Primitive ((Pintcomp Cge), 2); - "%incr", Primitive ((Poffsetref(1)), 1); - "%decr", Primitive ((Poffsetref(-1)), 1); - "%intoffloat", Primitive (Pintoffloat, 1); - "%floatofint", Primitive (Pfloatofint, 1); - "%negfloat", Primitive (Pnegfloat, 1); - "%absfloat", Primitive (Pabsfloat, 1); - "%addfloat", Primitive (Paddfloat, 2); - "%subfloat", Primitive (Psubfloat, 2); - "%mulfloat", Primitive (Pmulfloat, 2); - "%divfloat", Primitive (Pdivfloat, 2); - "%eqfloat", Primitive ((Pfloatcomp CFeq), 2); - "%noteqfloat", Primitive ((Pfloatcomp CFneq), 2); - "%ltfloat", Primitive ((Pfloatcomp CFlt), 2); - "%lefloat", Primitive ((Pfloatcomp CFle), 2); - "%gtfloat", Primitive ((Pfloatcomp CFgt), 2); - "%gefloat", Primitive ((Pfloatcomp CFge), 2); - "%string_length", Primitive (Pstringlength, 1); - "%string_safe_get", Primitive (Pstringrefs, 2); - "%string_safe_set", Primitive (Pbytessets, 3); - "%string_unsafe_get", Primitive (Pstringrefu, 2); - "%string_unsafe_set", Primitive (Pbytessetu, 3); - "%bytes_length", Primitive (Pbyteslength, 1); - "%bytes_safe_get", Primitive (Pbytesrefs, 2); - "%bytes_safe_set", Primitive (Pbytessets, 3); - "%bytes_unsafe_get", Primitive (Pbytesrefu, 2); - "%bytes_unsafe_set", Primitive (Pbytessetu, 3); - "%array_length", Primitive ((Parraylength gen_array_kind), 1); - "%array_safe_get", Primitive ((Parrayrefs gen_array_kind), 2); - "%array_safe_set", Primitive ((Parraysets gen_array_kind), 3); - "%array_unsafe_get", Primitive ((Parrayrefu gen_array_kind), 2); - "%array_unsafe_set", Primitive ((Parraysetu gen_array_kind), 3); - "%obj_size", Primitive ((Parraylength gen_array_kind), 1); - "%obj_field", Primitive ((Parrayrefu gen_array_kind), 2); - "%obj_set_field", Primitive ((Parraysetu gen_array_kind), 3); - "%floatarray_length", Primitive ((Parraylength Pfloatarray), 1); - "%floatarray_safe_get", Primitive ((Parrayrefs Pfloatarray), 2); - "%floatarray_safe_set", Primitive ((Parraysets Pfloatarray), 3); - "%floatarray_unsafe_get", Primitive ((Parrayrefu Pfloatarray), 2); - "%floatarray_unsafe_set", Primitive ((Parraysetu Pfloatarray), 3); - "%obj_is_int", Primitive (Pisint, 1); - "%lazy_force", Lazy_force; - "%nativeint_of_int", Primitive ((Pbintofint Pnativeint), 1); - "%nativeint_to_int", Primitive ((Pintofbint Pnativeint), 1); - "%nativeint_neg", Primitive ((Pnegbint Pnativeint), 1); - "%nativeint_add", Primitive ((Paddbint Pnativeint), 2); - "%nativeint_sub", Primitive ((Psubbint Pnativeint), 2); - "%nativeint_mul", Primitive ((Pmulbint Pnativeint), 2); - "%nativeint_div", - Primitive ((Pdivbint { size = Pnativeint; is_safe = Safe }), 2); - "%nativeint_mod", - Primitive ((Pmodbint { size = Pnativeint; is_safe = Safe }), 2); - "%nativeint_and", Primitive ((Pandbint Pnativeint), 2); - "%nativeint_or", Primitive ( (Porbint Pnativeint), 2); - "%nativeint_xor", Primitive ((Pxorbint Pnativeint), 2); - "%nativeint_lsl", Primitive ((Plslbint Pnativeint), 2); - "%nativeint_lsr", Primitive ((Plsrbint Pnativeint), 2); - "%nativeint_asr", Primitive ((Pasrbint Pnativeint), 2); - "%int32_of_int", Primitive ((Pbintofint Pint32), 1); - "%int32_to_int", Primitive ((Pintofbint Pint32), 1); - "%int32_neg", Primitive ((Pnegbint Pint32), 1); - "%int32_add", Primitive ((Paddbint Pint32), 2); - "%int32_sub", Primitive ((Psubbint Pint32), 2); - "%int32_mul", Primitive ((Pmulbint Pint32), 2); - "%int32_div", Primitive ((Pdivbint { size = Pint32; is_safe = Safe }), 2); - "%int32_mod", Primitive ((Pmodbint { size = Pint32; is_safe = Safe }), 2); - "%int32_and", Primitive ((Pandbint Pint32), 2); - "%int32_or", Primitive ( (Porbint Pint32), 2); - "%int32_xor", Primitive ((Pxorbint Pint32), 2); - "%int32_lsl", Primitive ((Plslbint Pint32), 2); - "%int32_lsr", Primitive ((Plsrbint Pint32), 2); - "%int32_asr", Primitive ((Pasrbint Pint32), 2); - "%int64_of_int", Primitive ((Pbintofint Pint64), 1); - "%int64_to_int", Primitive ((Pintofbint Pint64), 1); - "%int64_neg", Primitive ((Pnegbint Pint64), 1); - "%int64_add", Primitive ((Paddbint Pint64), 2); - "%int64_sub", Primitive ((Psubbint Pint64), 2); - "%int64_mul", Primitive ((Pmulbint Pint64), 2); - "%int64_div", Primitive ((Pdivbint { size = Pint64; is_safe = Safe }), 2); - "%int64_mod", Primitive ((Pmodbint { size = Pint64; is_safe = Safe }), 2); - "%int64_and", Primitive ((Pandbint Pint64), 2); - "%int64_or", Primitive ( (Porbint Pint64), 2); - "%int64_xor", Primitive ((Pxorbint Pint64), 2); - "%int64_lsl", Primitive ((Plslbint Pint64), 2); - "%int64_lsr", Primitive ((Plsrbint Pint64), 2); - "%int64_asr", Primitive ((Pasrbint Pint64), 2); - "%nativeint_of_int32", Primitive ((Pcvtbint(Pint32, Pnativeint)), 1); - "%nativeint_to_int32", Primitive ((Pcvtbint(Pnativeint, Pint32)), 1); - "%int64_of_int32", Primitive ((Pcvtbint(Pint32, Pint64)), 1); - "%int64_to_int32", Primitive ((Pcvtbint(Pint64, Pint32)), 1); - "%int64_of_nativeint", Primitive ((Pcvtbint(Pnativeint, Pint64)), 1); - "%int64_to_nativeint", Primitive ((Pcvtbint(Pint64, Pnativeint)), 1); - "%caml_ba_ref_1", - Primitive - ((Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), - 2); - "%caml_ba_ref_2", - Primitive - ((Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), - 3); - "%caml_ba_ref_3", - Primitive - ((Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), - 4); - "%caml_ba_set_1", - Primitive - ((Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), - 3); - "%caml_ba_set_2", - Primitive - ((Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), - 4); - "%caml_ba_set_3", - Primitive - ((Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), - 5); - "%caml_ba_unsafe_ref_1", - Primitive - ((Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), - 2); - "%caml_ba_unsafe_ref_2", - Primitive - ((Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), - 3); - "%caml_ba_unsafe_ref_3", - Primitive - ((Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), - 4); - "%caml_ba_unsafe_set_1", - Primitive - ((Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)), - 3); - "%caml_ba_unsafe_set_2", - Primitive - ((Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)), - 4); - "%caml_ba_unsafe_set_3", - Primitive - ((Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)), - 5); - "%caml_ba_dim_1", Primitive ((Pbigarraydim(1)), 1); - "%caml_ba_dim_2", Primitive ((Pbigarraydim(2)), 1); - "%caml_ba_dim_3", Primitive ((Pbigarraydim(3)), 1); - "%caml_string_get16", Primitive ((Pstring_load_16(false)), 2); - "%caml_string_get16u", Primitive ((Pstring_load_16(true)), 2); - "%caml_string_get32", Primitive ((Pstring_load_32(false)), 2); - "%caml_string_get32u", Primitive ((Pstring_load_32(true)), 2); - "%caml_string_get64", Primitive ((Pstring_load_64(false)), 2); - "%caml_string_get64u", Primitive ((Pstring_load_64(true)), 2); - "%caml_string_set16", Primitive ((Pbytes_set_16(false)), 3); - "%caml_string_set16u", Primitive ((Pbytes_set_16(true)), 3); - "%caml_string_set32", Primitive ((Pbytes_set_32(false)), 3); - "%caml_string_set32u", Primitive ((Pbytes_set_32(true)), 3); - "%caml_string_set64", Primitive ((Pbytes_set_64(false)), 3); - "%caml_string_set64u", Primitive ((Pbytes_set_64(true)), 3); - "%caml_bytes_get16", Primitive ((Pbytes_load_16(false)), 2); - "%caml_bytes_get16u", Primitive ((Pbytes_load_16(true)), 2); - "%caml_bytes_get32", Primitive ((Pbytes_load_32(false)), 2); - "%caml_bytes_get32u", Primitive ((Pbytes_load_32(true)), 2); - "%caml_bytes_get64", Primitive ((Pbytes_load_64(false)), 2); - "%caml_bytes_get64u", Primitive ((Pbytes_load_64(true)), 2); - "%caml_bytes_set16", Primitive ((Pbytes_set_16(false)), 3); - "%caml_bytes_set16u", Primitive ((Pbytes_set_16(true)), 3); - "%caml_bytes_set32", Primitive ((Pbytes_set_32(false)), 3); - "%caml_bytes_set32u", Primitive ((Pbytes_set_32(true)), 3); - "%caml_bytes_set64", Primitive ((Pbytes_set_64(false)), 3); - "%caml_bytes_set64u", Primitive ((Pbytes_set_64(true)), 3); - "%caml_bigstring_get16", Primitive ((Pbigstring_load_16(false)), 2); - "%caml_bigstring_get16u", Primitive ((Pbigstring_load_16(true)), 2); - "%caml_bigstring_get32", Primitive ((Pbigstring_load_32(false)), 2); - "%caml_bigstring_get32u", Primitive ((Pbigstring_load_32(true)), 2); - "%caml_bigstring_get64", Primitive ((Pbigstring_load_64(false)), 2); - "%caml_bigstring_get64u", Primitive ((Pbigstring_load_64(true)), 2); - "%caml_bigstring_set16", Primitive ((Pbigstring_set_16(false)), 3); - "%caml_bigstring_set16u", Primitive ((Pbigstring_set_16(true)), 3); - "%caml_bigstring_set32", Primitive ((Pbigstring_set_32(false)), 3); - "%caml_bigstring_set32u", Primitive ((Pbigstring_set_32(true)), 3); - "%caml_bigstring_set64", Primitive ((Pbigstring_set_64(false)), 3); - "%caml_bigstring_set64u", Primitive ((Pbigstring_set_64(true)), 3); - "%bswap16", Primitive (Pbswap16, 1); - "%bswap_int32", Primitive ((Pbbswap(Pint32)), 1); - "%bswap_int64", Primitive ((Pbbswap(Pint64)), 1); - "%bswap_native", Primitive ((Pbbswap(Pnativeint)), 1); - "%int_as_pointer", Primitive (Pint_as_pointer, 1); - "%opaque", Primitive (Popaque, 1); - "%sys_argv", External prim_sys_argv; - "%send", Send; - "%sendself", Send_self; - "%sendcache", Send_cache; - "%equal", Comparison(Equal, Compare_generic); - "%notequal", Comparison(Not_equal, Compare_generic); - "%lessequal", Comparison(Less_equal, Compare_generic); - "%lessthan", Comparison(Less_than, Compare_generic); - "%greaterequal", Comparison(Greater_equal, Compare_generic); - "%greaterthan", Comparison(Greater_than, Compare_generic); - "%compare", Comparison(Compare, Compare_generic); - "%atomic_load", - Primitive ((Patomic_load {immediate_or_pointer=Pointer}), 1); - "%atomic_exchange", Primitive (Patomic_exchange, 2); - "%atomic_cas", Primitive (Patomic_cas, 3); - "%atomic_fetch_add", Primitive (Patomic_fetch_add, 2); - "%runstack", Primitive (Prunstack, 3); - "%reperform", Primitive (Preperform, 3); - "%perform", Primitive (Pperform, 1); - "%resume", Primitive (Presume, 3); - "%dls_get", Primitive (Pdls_get, 1); - ] ->>>>>>> ocaml/5.1 let to_modify_mode ~poly = function | Prim_global, _ -> modify_heap @@ -692,10 +162,10 @@ let lookup_primitive loc poly pos p = | "%loc_POS" -> Loc Loc_POS | "%loc_MODULE" -> Loc Loc_MODULE | "%loc_FUNCTION" -> Loc Loc_FUNCTION - | "%field0" -> Primitive (Pfield (0, Reads_vary), 1) - | "%field1" -> Primitive (Pfield (1, Reads_vary), 1) - | "%field0_immut" -> Primitive ((Pfield (0, Reads_agree)), 1) - | "%field1_immut" -> Primitive ((Pfield (1, Reads_agree)), 1) + | "%field0" -> Primitive (Pfield (0, Pointer, Reads_vary), 1) + | "%field1" -> Primitive (Pfield (1, Pointer, Reads_vary), 1) + | "%field0_immut" -> Primitive ((Pfield (0, Pointer, Reads_agree)), 1) + | "%field1_immut" -> Primitive ((Pfield (1, Pointer, Reads_agree)), 1) | "%setfield0" -> let mode = get_first_arg_mode () in Primitive ((Psetfield(0, Pointer, Assignment mode)), 2) @@ -948,6 +418,16 @@ let lookup_primitive loc poly pos p = | "%unbox_float" -> Primitive(Punbox_float, 1) | "%box_float" -> Primitive(Pbox_float mode, 1) | "%get_header" -> Primitive (Pget_header mode, 1) + | "%atomic_load" -> + Primitive ((Patomic_load {immediate_or_pointer=Pointer}), 1) + | "%atomic_exchange" -> Primitive (Patomic_exchange, 2) + | "%atomic_cas" -> Primitive (Patomic_cas, 3) + | "%atomic_fetch_add" -> Primitive (Patomic_fetch_add, 2) + | "%runstack" -> Primitive (Prunstack, 3) + | "%reperform" -> Primitive (Preperform, 3) + | "%perform" -> Primitive (Pperform, 1) + | "%resume" -> Primitive (Presume, 3) + | "%dls_get" -> Primitive (Pdls_get, 1) | s when String.length s > 0 && s.[0] = '%' -> raise(Error(loc, Unknown_builtin_primitive s)) | _ -> External p @@ -1463,7 +943,6 @@ let transl_primitive loc p env ty ~poly_mode path = match params with | [] -> lambda_of_prim p.prim_name prim loc args None | _ -> -<<<<<<< HEAD let loc = Debuginfo.Scoped_location.map_scopes (fun ~scopes -> Debuginfo.Scoped_location.enter_partial_or_eta_wrapper ~scopes) @@ -1491,21 +970,6 @@ let transl_primitive loc p env ty ~poly_mode path = ~body ~mode:alloc_heap ~region -||||||| merged common ancestors - Lfunction{ kind = Curried; - params; - return = Pgenval; - attr = default_stub_attribute; - loc; - body; } -======= - lfunction ~kind:Curried - ~params - ~return:Pgenval - ~attr:default_stub_attribute - ~loc - ~body ->>>>>>> ocaml/5.1 let lambda_primitive_needs_event_after = function (* We add an event after any primitive resulting in a C call that @@ -1525,14 +989,8 @@ let lambda_primitive_needs_event_after = function | Pbytes_load_64 _ | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _ | Pbigstring_load_16 _ | Pbigstring_load_32 _ | Pbigstring_load_64 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _ -<<<<<<< HEAD - | Pbbswap _ | Pobj_dup | Pget_header _ -> true -||||||| merged common ancestors - | Pbbswap _ -> true -======= | Prunstack | Pperform | Preperform | Presume - | Pbbswap _ -> true ->>>>>>> ocaml/5.1 + | Pbbswap _ | Pobj_dup | Pget_header _ -> true | Pbytes_to_string | Pbytes_of_string | Parray_to_iarray | Parray_of_iarray @@ -1548,23 +1006,13 @@ let lambda_primitive_needs_event_after = function | Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat | Pcompare_ints | Pcompare_floats | Pfloatcomp _ | Pstringlength | Pstringrefu | Pbyteslength | Pbytesrefu -<<<<<<< HEAD | Pbytessetu | Pmakearray ((Pintarray | Paddrarray | Pfloatarray), _, _) | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint _ | Pisout | Pprobe_is_enabled _ + | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _ | Pintofbint _ | Pctconst _ | Pbswap16 | Pint_as_pointer _ | Popaque _ + | Pdls_get | Pobj_magic _ | Punbox_float | Punbox_int _ -> false -||||||| merged common ancestors - | Pbytessetu | Pmakearray ((Pintarray | Paddrarray | Pfloatarray), _) - | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint | Pisout - | Pintofbint _ | Pctconst _ | Pbswap16 | Pint_as_pointer | Popaque -> false -======= - | Pbytessetu | Pmakearray ((Pintarray | Paddrarray | Pfloatarray), _) - | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint | Pisout - | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _ - | Pintofbint _ | Pctconst _ | Pbswap16 | Pint_as_pointer | Popaque | Pdls_get - -> false ->>>>>>> ocaml/5.1 (* Determine if a primitive should be surrounded by an "after" debug event *) let primitive_needs_event_after = function