Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Remove Const_pointer from Lambda and Clambda (#9585) 

Lambda and Clambda distinguish Const_int from Const_pointer only so
that they can pass the information to Cmm. But now that that
Const_pointer is gone from Cmm (#9578), there's no need for the
distinction in Lambda either.

This PR requires a bootstrap, because the .cmo format changes:
Lambda.structured_constant has one fewer constructor.  The bootstrap
is in the following commit.
master
Stephen Dolan 2020-06-02 11:17:17 +02:00 committed by Xavier Leroy
parent a8e2f2b170
commit 0d44a6cfe6
37 changed files with 115 additions and 216 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
asmcomp/cmmgen.ml
View File

@ -178,18 +178,12 @@ let rec expr_size env = function
let transl_constant dbg = function
| Uconst_int n ->
int_const dbg n
| Uconst_ptr n ->
if n <= max_repr_int && n >= min_repr_int
then Cconst_int((n lsl 1) + 1, dbg)
else Cconst_natint
(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n,
dbg)
| Uconst_ref (label, _) ->
Cconst_symbol (label, dbg)
let emit_constant cst cont =
match cst with
| Uconst_int n | Uconst_ptr n ->
| Uconst_int n ->
cint_const n
:: cont
| Uconst_ref (sym, _) ->
@ -435,7 +429,7 @@ let rec transl env e =
Cphantom_const_symbol sym
| Uphantom_read_symbol_field { sym; field; } ->
Cphantom_read_symbol_field { sym; field; }
| Uphantom_const (Uconst_int i) | Uphantom_const (Uconst_ptr i) ->
| Uphantom_const (Uconst_int i) ->
Cphantom_const_int (targetint_const i)
| Uphantom_var var -> Cphantom_var var
| Uphantom_read_field { var; field; } ->
@ -1178,9 +1172,9 @@ and transl_if env (approx : then_else)
(then_dbg : Debuginfo.t) then_
(else_dbg : Debuginfo.t) else_ =
match cond with
| Uconst (Uconst_ptr 0) -> else_
| Uconst (Uconst_ptr 1) -> then_
| Uifthenelse (arg1, arg2, Uconst (Uconst_ptr 0)) ->
| Uconst (Uconst_int 0) -> else_
| Uconst (Uconst_int 1) -> then_
| Uifthenelse (arg1, arg2, Uconst (Uconst_int 0)) ->
(* CR mshinwell: These Debuginfos will flow through from Clambda *)
let inner_dbg = Debuginfo.none in
let ifso_dbg = Debuginfo.none in
@ -1195,7 +1189,7 @@ and transl_if env (approx : then_else)
inner_dbg arg2
then_dbg then_
else_dbg else_
| Uifthenelse (arg1, Uconst (Uconst_ptr 1), arg2) ->
| Uifthenelse (arg1, Uconst (Uconst_int 1), arg2) ->
let inner_dbg = Debuginfo.none in
let ifnot_dbg = Debuginfo.none in
transl_sequor env approx
@ -1214,13 +1208,13 @@ and transl_if env (approx : then_else)
dbg arg
else_dbg else_
then_dbg then_
| Uifthenelse (Uconst (Uconst_ptr 1), ifso, _) ->
| Uifthenelse (Uconst (Uconst_int 1), ifso, _) ->
let ifso_dbg = Debuginfo.none in
transl_if env approx
ifso_dbg ifso
then_dbg then_
else_dbg else_
| Uifthenelse (Uconst (Uconst_ptr 0), _, ifnot) ->
| Uifthenelse (Uconst (Uconst_int 0), _, ifnot) ->
let ifnot_dbg = Debuginfo.none in
transl_if env approx
ifnot_dbg ifnot

9
bytecomp/emitcode.ml
View File

@ -77,7 +77,6 @@ exception AsInt
let const_as_int = function
| Const_base(Const_int i) -> i
| Const_base(Const_char c) -> Char.code c
| Const_pointer i -> i
| _ -> raise AsInt
let is_immed i = immed_min <= i && i <= immed_max
@ -240,10 +239,6 @@ let emit_instr = function
else (out opCONSTINT; out_int i)
| Const_base(Const_char c) ->
out opCONSTINT; out_int (Char.code c)
| Const_pointer i ->
if i >= 0 && i <= 3
then out (opCONST0 + i)
else (out opCONSTINT; out_int i)
| Const_block(t, []) ->
if t = 0 then out opATOM0 else (out opATOM; out_int t)
| _ ->
@ -372,10 +367,6 @@ let rec emit = function
else (out opPUSHCONSTINT; out_int i)
| Const_base(Const_char c) ->
out opPUSHCONSTINT; out_int(Char.code c)
| Const_pointer i ->
if i >= 0 && i <= 3
then out (opPUSHCONST0 + i)
else (out opPUSHCONSTINT; out_int i)
| Const_block(t, []) ->
if t = 0 then out opPUSHATOM0 else (out opPUSHATOM; out_int t)
| _ ->

1
bytecomp/symtable.ml
View File

@ -222,7 +222,6 @@ let rec transl_const = function
| Const_base(Const_int32 i) -> Obj.repr i
| Const_base(Const_int64 i) -> Obj.repr i
| Const_base(Const_nativeint i) -> Obj.repr i
| Const_pointer i -> Obj.repr i
| Const_immstring s -> Obj.repr s
| Const_block(tag, fields) ->
let block = Obj.new_block tag (List.length fields) in

5
lambda/lambda.ml
View File

@ -207,7 +207,6 @@ let equal_value_kind x y =
type structured_constant =
Const_base of constant
| Const_pointer of int
| Const_block of int * structured_constant list
| Const_float_array of string list
| Const_immstring of string
@ -342,7 +341,9 @@ type program =
required_globals : Ident.Set.t;
code : lambda }
let const_unit = Const_pointer 0
let const_int n = Const_base (Const_int n)
let const_unit = const_int 0
let lambda_unit = Lconst const_unit

2
lambda/lambda.mli
View File

@ -198,7 +198,6 @@ val equal_boxed_integer : boxed_integer -> boxed_integer -> bool
type structured_constant =
Const_base of constant
| Const_pointer of int
| Const_block of int * structured_constant list
| Const_float_array of string list
| Const_immstring of string
@ -341,6 +340,7 @@ type program =
val make_key: lambda -> lambda option
val const_unit: structured_constant
val const_int : int -> structured_constant
val lambda_unit: lambda
val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda
val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda

1
lambda/printlambda.ml
View File

@ -29,7 +29,6 @@ let rec struct_const ppf = function
| Const_base(Const_int32 n) -> fprintf ppf "%lil" n
| Const_base(Const_int64 n) -> fprintf ppf "%LiL" n
| Const_base(Const_nativeint n) -> fprintf ppf "%nin" n
| Const_pointer n -> fprintf ppf "%ia" n
| Const_block(tag, []) ->
fprintf ppf "[%i]" tag
| Const_block(tag, sc1::scl) ->

8
lambda/translclass.ml
View File

@ -64,7 +64,7 @@ let lfield v i = Lprim(Pfield i, [Lvar v], Loc_unknown)
let transl_label l = share (Const_immstring l)
let transl_meth_list lst =
if lst = [] then Lconst (Const_pointer 0) else
if lst = [] then Lconst (const_int 0) else
share (Const_block
(0, List.map (fun lab -> Const_immstring lab) lst))
@ -379,7 +379,7 @@ let rec build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl =
Llet (Strict, Pgenval, inh,
mkappl(oo_prim "inherits", narrow_args @
[path_lam;
Lconst(Const_pointer(if top then 1 else 0))]),
Lconst(const_int (if top then 1 else 0))]),
Llet(StrictOpt, Pgenval, obj_init, lfield inh 0, cl_init)))
| _ ->
let core cl_init =
@ -547,7 +547,7 @@ let rec builtin_meths self env env2 body =
| Lprim(Parrayrefu _, [Lvar s; Lvar n], _) when List.mem s self ->
"var", [Lvar n]
| Lprim(Pfield n, [Lvar e], _) when Ident.same e env ->
"env", [Lvar env2; Lconst(Const_pointer n)]
"env", [Lvar env2; Lconst(const_int n)]
| Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
"meth", [met]
| _ -> raise Not_found
@ -618,7 +618,7 @@ module M = struct
| "send_env" -> SendEnv
| "send_meth" -> SendMeth
| _ -> assert false
in Lconst(Const_pointer(Obj.magic tag)) :: args
in Lconst(const_int (Obj.magic tag)) :: args
end
open M

10
lambda/translcore.ml
View File

@ -64,7 +64,7 @@ let transl_extension_constructor ~scopes env path ext =
Text_decl _ ->
Lprim (Pmakeblock (Obj.object_tag, Immutable, None),
[Lconst (Const_base (Const_string (name, ext.ext_loc, None)));
Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)],
Lprim (prim_fresh_oo_id, [Lconst (const_int 0)], loc)],
loc)
| Text_rebind(path, _lid) ->
transl_extension_path loc env path
@ -309,7 +309,7 @@ and transl_exp0 ~scopes e =
| _ -> assert false
end else begin match cstr.cstr_tag with
Cstr_constant n ->
Lconst(Const_pointer n)
Lconst(const_int n)
| Cstr_unboxed ->
(match ll with [v] -> v | _ -> assert false)
| Cstr_block n ->
@ -332,15 +332,15 @@ and transl_exp0 ~scopes e =
| Texp_variant(l, arg) ->
let tag = Btype.hash_variant l in
begin match arg with
None -> Lconst(Const_pointer tag)
None -> Lconst(const_int tag)
| Some arg ->
let lam = transl_exp ~scopes arg in
try
Lconst(Const_block(0, [Const_base(Const_int tag);
Lconst(Const_block(0, [const_int tag;
extract_constant lam]))
with Not_constant ->
Lprim(Pmakeblock(0, Immutable, None),
[Lconst(Const_base(Const_int tag)); lam],
[Lconst(const_int tag); lam],
of_location ~scopes e.exp_loc)
end
| Texp_record {fields; representation; extended_expression} ->

10
lambda/translmod.ml
View File

@ -217,8 +217,8 @@ let undefined_location loc =
let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
Lconst(Const_block(0,
[Const_base(Const_string (fname, loc, None));
Const_base(Const_int line);
Const_base(Const_int char)]))
const_int line;
const_int char]))
exception Initialization_failure of unsafe_info
@ -242,9 +242,9 @@ let init_shape id modl =
let init_v =
match Ctype.expand_head env ty with
{desc = Tarrow(_,_,_,_)} ->
Const_pointer 0 (* camlinternalMod.Function *)
const_int 0 (* camlinternalMod.Function *)
| {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t ->
Const_pointer 1 (* camlinternalMod.Lazy *)
const_int 1 (* camlinternalMod.Lazy *)
| _ ->
let not_a_function =
Unsafe {reason=Unsafe_non_function; loc; subid }
@ -270,7 +270,7 @@ let init_shape id modl =
| Sig_modtype(id, minfo, _) :: rem ->
init_shape_struct (Env.add_modtype id minfo env) rem
| Sig_class _ :: rem ->
Const_pointer 2 (* camlinternalMod.Class *)
const_int 2 (* camlinternalMod.Class *)
:: init_shape_struct env rem
| Sig_class_type _ :: rem ->
init_shape_struct env rem

2
lambda/translprim.ml
View File

@ -644,7 +644,7 @@ let lambda_of_prim prim_name prim loc args arg_exps =
| Primitive (prim, arity), args when arity = List.length args ->
Lprim(prim, args, loc)
| External prim, args when prim = prim_sys_argv ->
Lprim(Pccall prim, Lconst (Const_pointer 0) :: args, loc)
Lprim(Pccall prim, Lconst (const_int 0) :: args, loc)
| External prim, args ->
Lprim(Pccall prim, args, loc)
| Comparison(comp, knd), ([_;_] as args) ->

4
middle_end/clambda.ml
View File

@ -34,7 +34,6 @@ type ustructured_constant =
and uconstant =
| Uconst_ref of string * ustructured_constant option
| Uconst_int of int
| Uconst_ptr of int
and uphantom_defining_expr =
| Uphantom_const of uconstant
@ -162,11 +161,8 @@ let compare_constants c1 c2 =
match, because of string constants that must not be
reshared. *)
| Uconst_int n1, Uconst_int n2 -> Stdlib.compare n1 n2
| Uconst_ptr n1, Uconst_ptr n2 -> Stdlib.compare n1 n2
| Uconst_ref _, _ -> -1
| Uconst_int _, Uconst_ref _ -> 1
| Uconst_int _, Uconst_ptr _ -> -1
| Uconst_ptr _, _ -> 1
let rec compare_constant_lists l1 l2 =
match l1, l2 with

1
middle_end/clambda.mli
View File

@ -34,7 +34,6 @@ type ustructured_constant =
and uconstant =
| Uconst_ref of string * ustructured_constant option
| Uconst_int of int
| Uconst_ptr of int
and uphantom_defining_expr =
| Uphantom_const of uconstant

29
middle_end/closure/closure.ml
View File

@ -237,8 +237,7 @@ let make_const_ref c =
make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c,
Some c))
let make_const_int n = make_const (Uconst_int n)
let make_const_ptr n = make_const (Uconst_ptr n)
let make_const_bool b = make_const_ptr(if b then 1 else 0)
let make_const_bool b = make_const_int(if b then 1 else 0)
let make_integer_comparison cmp x y =
let open Clambda_primitives in
@ -279,7 +278,7 @@ let simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg =
let default = (Uprim(p, args, dbg), Value_unknown) in
match approxs with
(* int (or enumerated type) *)
| [ Value_const(Uconst_int n1 | Uconst_ptr n1) ] ->
| [ Value_const(Uconst_int n1) ] ->
begin match p with
| Pnot -> make_const_bool (n1 = 0)
| Pnegint -> make_const_int (- n1)
@ -293,8 +292,8 @@ let simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg =
| _ -> default
end
(* int (or enumerated type), int (or enumerated type) *)
| [ Value_const(Uconst_int n1 | Uconst_ptr n1);
Value_const(Uconst_int n2 | Uconst_ptr n2) ] ->
| [ Value_const(Uconst_int n1);
Value_const(Uconst_int n2) ] ->
begin match p with
| Psequand -> make_const_bool (n1 <> 0 && n2 <> 0)
| Psequor -> make_const_bool (n1 <> 0 || n2 <> 0)
@ -493,7 +492,7 @@ let simplif_prim_pure ~backend fpc p (args, approxs) dbg =
(* Kind test *)
| Pisint, _, [a1] ->
begin match a1 with
| Value_const(Uconst_int _ | Uconst_ptr _) -> make_const_bool true
| Value_const(Uconst_int _) -> make_const_bool true
| Value_const(Uconst_ref _) -> make_const_bool false
| Value_closure _ | Value_tuple _ -> make_const_bool false
| _ -> (Uprim(p, args, dbg), Value_unknown)
@ -607,7 +606,7 @@ let rec substitute loc ((backend, fpc) as st) sb rn ulam =
match sarg with
| Uconst (Uconst_ref (_, Some (Uconst_block (tag, _)))) ->
find_action sw.us_index_blocks sw.us_actions_blocks tag
| Uconst (Uconst_ptr tag) ->
| Uconst (Uconst_int tag) ->
find_action sw.us_index_consts sw.us_actions_consts tag
| _ -> None
in
@ -663,7 +662,7 @@ let rec substitute loc ((backend, fpc) as st) sb rn ulam =
(V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2)
| Uifthenelse(u1, u2, u3) ->
begin match substitute loc st sb rn u1 with
Uconst (Uconst_ptr n) ->
Uconst (Uconst_int n) ->
if n <> 0 then
substitute loc st sb rn u2
else
@ -799,8 +798,7 @@ let direct_apply env fundesc ufunct uargs ~loc ~attribute =
then app
else Usequence(ufunct, app)
(* Add [Value_integer] or [Value_constptr] info to the approximation
of an application *)
(* Add [Value_integer] info to the approximation of an application *)
let strengthen_approx appl approx =
match approx_ulam appl with
@ -808,7 +806,7 @@ let strengthen_approx appl approx =
intapprox
| _ -> approx
(* If a term has approximation Value_integer or Value_constptr and is pure,
(* If a term has approximation Value_integer and is pure,
replace it by an integer constant *)
let check_constant_result ulam approx =
@ -875,7 +873,6 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam =
let rec transl = function
| Const_base(Const_int n) -> Uconst_int n
| Const_base(Const_char c) -> Uconst_int (Char.code c)
| Const_pointer n -> Uconst_ptr n
| Const_block (tag, fields) ->
str (Uconst_block (tag, List.map transl fields))
| Const_float_array sl ->
@ -1057,13 +1054,13 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam =
| Ostype_win32 -> make_const_bool (Sys.os_type = "Win32")
| Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin")
| Backend_type ->
make_const_ptr 0 (* tag 0 is the same as Native here *)
make_const_int 0 (* tag 0 is the same as Native here *)
in
let arg, _approx = close env arg in
let id = Ident.create_local "dummy" in
Ulet(Immutable, Pgenval, VP.create id, arg, cst), approx
| Lprim(Pignore, [arg], _loc) ->
let expr, approx = make_const_ptr 0 in
let expr, approx = make_const_int 0 in
Usequence(fst (close env arg), expr), approx
| Lprim((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _loc) ->
close env arg
@ -1161,7 +1158,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam =
(Utrywith(ubody, VP.create id, uhandler), Value_unknown)
| Lifthenelse(arg, ifso, ifnot) ->
begin match close env arg with
(uarg, Value_const (Uconst_ptr n)) ->
(uarg, Value_const (Uconst_int n)) ->
sequence_constant_expr uarg
(close env (if n = 0 then ifnot else ifso))
| (uarg, _ ) ->
@ -1435,7 +1432,7 @@ let collect_exported_structured_constants a =
Compilenv.add_exported_constant s;
structured_constant c
| Uconst_ref (_s, None) -> assert false (* Cannot be generated *)
| Uconst_int _ | Uconst_ptr _ -> ()
| Uconst_int _ -> ()
and structured_constant = function
| Uconst_block (_, ul) -> List.iter const ul
| Uconst_float _ | Uconst_int32 _

8
middle_end/flambda/build_export_info.ml
View File

@ -171,7 +171,7 @@ end = struct
| export_id -> export_id
let new_unit_descr t =
new_descr t (Value_constptr 0)
new_descr t (Value_int 0)
let add_approx t var approx =
if Variable.Map.mem var t.var then begin
@ -199,12 +199,8 @@ end
let descr_of_constant (c : Flambda.const) : Export_info.descr =
match c with
(* [Const_pointer] is an immediate value of a type whose values may be
boxed (typically a variant type with both constant and non-constant
constructors). *)
| Int i -> Value_int i
| Char c -> Value_char c
| Const_pointer i -> Value_constptr i
let descr_of_allocated_constant (c : Allocated_const.t) : Export_info.descr =
match c with
@ -602,7 +598,6 @@ let build_transient ~(backend : (module Backend_intf.S))
| Value_mutable_block _
| Value_int _
| Value_char _
| Value_constptr _
| Value_float _
| Value_float_array _
| Value_string _
@ -644,7 +639,6 @@ let build_transient ~(backend : (module Backend_intf.S))
| Value_mutable_block _
| Value_int _
| Value_char _
| Value_constptr _
| Value_float _
| Value_float_array _
| Value_string _

13
middle_end/flambda/closure_conversion.ml
View File

@ -137,7 +137,6 @@ let rec declare_const t (const : Lambda.structured_constant)
Names.const_int64
| Const_base (Const_nativeint c) ->
register_const t (Allocated_const (Nativeint c)) Names.const_nativeint
| Const_pointer c -> Const (Const_pointer c), Names.const_ptr
| Const_immstring c ->
register_const t (Allocated_const (Immutable_string c))
Names.const_immstring
@ -162,9 +161,9 @@ let close_const t (const : Lambda.structured_constant)
let lambda_const_bool b : Lambda.structured_constant =
if b then
Const_pointer 1
Lambda.const_int 1
else
Const_pointer 0
Lambda.const_int 0
let lambda_const_int i : Lambda.structured_constant =
Const_base (Const_int i)
@ -391,7 +390,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t =
let arg2 = close t env arg2 in
let const_true = Variable.create Names.const_true in
let cond = Variable.create Names.cond_sequor in
Flambda.create_let const_true (Const (Const_pointer 1))
Flambda.create_let const_true (Const (Int 1))
(Flambda.create_let cond (Expr arg1)
(If_then_else (cond, Var const_true, arg2)))
| Lprim (Psequand, [arg1; arg2], _) ->
@ -399,7 +398,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t =
let arg2 = close t env arg2 in
let const_false = Variable.create Names.const_false in
let cond = Variable.create Names.const_sequand in
Flambda.create_let const_false (Const (Const_pointer 0))
Flambda.create_let const_false (Const (Int 0))
(Flambda.create_let cond (Expr arg1)
(If_then_else (cond, arg2, Var const_false)))
| Lprim ((Psequand | Psequor), _, _) ->
@ -412,7 +411,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t =
close_let_bound_expression t var env arg
in
Flambda.create_let var defining_expr
(name_expr (Const (Const_pointer 0)) ~name:Names.unit)
(name_expr (Const (Int 0)) ~name:Names.unit)
| Lprim (Pdirapply, [funct; arg], loc)
| Lprim (Prevapply, [arg; funct], loc) ->
let apply : Lambda.lambda_apply =
@ -448,7 +447,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t =
| Ostype_win32 -> lambda_const_bool (String.equal Sys.os_type "Win32")
| Ostype_cygwin -> lambda_const_bool (String.equal Sys.os_type "Cygwin")
| Backend_type ->
Lambda.Const_pointer 0 (* tag 0 is the same as Native *)
Lambda.const_int 0 (* tag 0 is the same as Native *)
end
in
close t env

9
middle_end/flambda/export_info.ml
View File

@ -41,7 +41,6 @@ type descr =
| Value_mutable_block of Tag.t * int
| Value_int of int
| Value_char of char
| Value_constptr of int
| Value_float of float
| Value_float_array of value_float_array
| Value_boxed_int : 'a A.boxed_int * 'a -> descr
@ -113,8 +112,6 @@ let equal_descr (d1:descr) (d2:descr) : bool =
i1 = i2
| Value_char c1, Value_char c2 ->
c1 = c2
| Value_constptr i1, Value_constptr i2 ->
i1 = i2
| Value_float f1, Value_float f2 ->
f1 = f2
| Value_float_array s1, Value_float_array s2 ->
@ -129,12 +126,12 @@ let equal_descr (d1:descr) (d2:descr) : bool =
| Value_set_of_closures s1, Value_set_of_closures s2 ->
equal_set_of_closures s1 s2
| ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _
| Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _
| Value_char _ | Value_float _ | Value_float_array _
| Value_boxed_int _ | Value_string _ | Value_closure _
| Value_set_of_closures _
| Value_unknown_descr ),
( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _
| Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _
| Value_char _ | Value_float _ | Value_float_array _
| Value_boxed_int _ | Value_string _ | Value_closure _
| Value_set_of_closures _
| Value_unknown_descr ) ->
@ -396,7 +393,6 @@ let print_raw_descr ppf descr =
fprintf ppf "(Value_mutable-block (%a %d))" Tag.print tag i
| Value_int i -> fprintf ppf "(Value_int %d)" i
| Value_char c -> fprintf ppf "(Value_char %c)" c
| Value_constptr p -> fprintf ppf "(Value_constptr %d)" p
| Value_float f -> fprintf ppf "(Value_float %.3f)" f
| Value_float_array value_float_array ->
fprintf ppf "(Value_float_array %a)"
@ -445,7 +441,6 @@ let print_approx_components ppf ~symbol_id ~values
match descr with
| Value_int i -> Format.pp_print_int ppf i
| Value_char c -> fprintf ppf "%c" c
| Value_constptr i -> fprintf ppf "%ip" i
| Value_block (tag, fields) ->
fprintf ppf "[%a:%a]" Tag.print tag print_fields fields
| Value_mutable_block (tag, size) ->

1
middle_end/flambda/export_info.mli
View File

@ -44,7 +44,6 @@ type descr =
| Value_mutable_block of Tag.t * int
| Value_int of int
| Value_char of char
| Value_constptr of int
| Value_float of float
| Value_float_array of value_float_array
| Value_boxed_int : 'a A.boxed_int * 'a -> descr

1
middle_end/flambda/export_info_for_pack.ml
View File

@ -99,7 +99,6 @@ let import_descr_for_pack units pack (descr : Export_info.descr)
match descr with
| Value_int _
| Value_char _
| Value_constptr _
| Value_string _
| Value_float _
| Value_float_array _

9
middle_end/flambda/flambda.ml
View File

@ -24,7 +24,6 @@ type call_kind =
type const =
| Int of int
| Char of char
| Const_pointer of int
type apply = {
func : Variable.t;
@ -428,7 +427,6 @@ and print_const ppf (c : const) =
match c with
| Int n -> fprintf ppf "%i" n
| Char c -> fprintf ppf "%C" c
| Const_pointer n -> fprintf ppf "%ia" n
let print_function_declarations ppf (fd : function_declarations) =
let funs ppf =
@ -1189,11 +1187,8 @@ let compare_const (c1:const) (c2:const) =
match c1, c2 with
| Int i1, Int i2 -> compare i1 i2
| Char i1, Char i2 -> Char.compare i1 i2
| Const_pointer i1, Const_pointer i2 -> compare i1 i2
| Int _, (Char _ | Const_pointer _) -> -1
| (Char _ | Const_pointer _), Int _ -> 1
| Char _, Const_pointer _ -> -1
| Const_pointer _, Char _ -> 1
| Int _, Char _ -> -1
| Char _, Int _ -> 1
let compare_constant_defining_value_block_field
(c1:constant_defining_value_block_field)

4
middle_end/flambda/flambda.mli
View File

@ -29,10 +29,6 @@ type const =
| Int of int
| Char of char
(** [Char] is kept separate from [Int] to improve printing *)
| Const_pointer of int
(** [Const_pointer] is an immediate value of a type whose values may be
boxed (typically a variant type with both constant and non-constant
constructors). *)
(** The application of a function to a list of arguments. *)
type apply = {

7
middle_end/flambda/flambda_to_clambda.ml
View File

@ -232,7 +232,6 @@ let to_clambda_const env (const : Flambda.constant_defining_value_block_field)
| Symbol symbol -> to_clambda_symbol' env symbol
| Const (Int i) -> Uconst_int i
| Const (Char c) -> Uconst_int (Char.code c)
| Const (Const_pointer i) -> Uconst_ptr i
let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda =
match flam with
@ -357,7 +356,6 @@ let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda =
and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda =
match named with
| Symbol sym -> to_clambda_symbol env sym
| Const (Const_pointer n) -> Uconst (Uconst_ptr n)
| Const (Int n) -> Uconst (Uconst_int n)
| Const (Char c) -> Uconst (Uconst_int (Char.code c))
| Allocated_const _ ->
@ -612,7 +610,7 @@ let to_clambda_initialize_symbol t env symbol fields : Clambda.ulambda =
Debuginfo.none)
in
match fields with
| [] -> Uconst (Uconst_ptr 0)
| [] -> Uconst (Uconst_int 0)
| h :: t ->
List.fold_left (fun acc (p, field) ->
Clambda.Usequence (build_setfield (p, field), acc))
@ -681,7 +679,6 @@ let to_clambda_program t env constants (program : Flambda.program) =
match const with
| Int i -> i
| Char c -> Char.code c
| Const_pointer i -> i
in
Some (Clambda.Uconst_field_int n)
| Some (Flambda.Symbol sym) ->
@ -705,7 +702,7 @@ let to_clambda_program t env constants (program : Flambda.program) =
let e2, constants, preallocated_blocks = loop env constants program in
Usequence (e1, e2), constants, preallocated_blocks
| End _ ->
Uconst (Uconst_ptr 0), constants, []
Uconst (Uconst_int 0), constants, []
in
loop env constants program.program_body

1
middle_end/flambda/import_approx.ml
View File

@ -126,7 +126,6 @@ let rec import_ex ex =
| Value_unknown_descr -> A.value_unknown Other
| Value_int i -> A.value_int i
| Value_char c -> A.value_char c
| Value_constptr i -> A.value_constptr i
| Value_float f -> A.value_float f
| Value_float_array float_array ->
begin match float_array.contents with

5
middle_end/flambda/inline_and_simplify.ml
View File

@ -175,7 +175,6 @@ let simplify_const (const : Flambda.const) =
match const with
| Int i -> A.value_int i
| Char c -> A.value_char c
| Const_pointer i -> A.value_constptr i
let approx_for_allocated_const (const : Allocated_const.t) =
match const with
@ -1213,10 +1212,10 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t =
if arg is not effectful we can also drop it. *)
simplify_free_variable env arg ~f:(fun env arg arg_approx ->
begin match arg_approx.descr with
| Value_constptr 0 | Value_int 0 -> (* Constant [false]: keep [ifnot] *)
| Value_int 0 -> (* Constant [false]: keep [ifnot] *)
let ifnot, r = simplify env r ifnot in
ifnot, R.map_benefit r B.remove_branch
| Value_constptr _ | Value_int _
| Value_int _
| Value_block _ -> (* Constant [true]: keep [ifso] *)
let ifso, r = simplify env r ifso in
ifso, R.map_benefit r B.remove_branch

2
middle_end/flambda/remove_unused_arguments.ml
View File

@ -35,7 +35,7 @@ let remove_params unused (fun_decl: Flambda.function_declaration)
in
let body =
List.fold_left (fun body param ->
Flambda.create_let (Parameter.var param) (Const (Const_pointer 0)) body)
Flambda.create_let (Parameter.var param) (Const (Int 0)) body)
fun_decl.body
unused_params
in

54
middle_end/flambda/simple_value_approx.ml
View File

@ -48,7 +48,6 @@ and descr =
| Value_block of Tag.t * t array
| Value_int of int
| Value_char of char
| Value_constptr of int
| Value_float of float option
| Value_boxed_int : 'a boxed_int * 'a -> descr
| Value_set_of_closures of value_set_of_closures
@ -171,7 +170,6 @@ let print_function_declarations ppf (fd : function_declarations) =
let rec print_descr ppf = function
| Value_int i -> Format.pp_print_int ppf i
| Value_char c -> Format.fprintf ppf "%c" c
| Value_constptr i -> Format.fprintf ppf "%ia" i
| Value_block (tag,fields) ->
let p ppf fields =
Array.iter (fun v -> Format.fprintf ppf "%a@ " print v) fields in
@ -253,7 +251,6 @@ let augment_with_kind t (kind:Lambda.value_kind) =
| Value_block _
| Value_int _
| Value_char _
| Value_constptr _
| Value_boxed_int _
| Value_set_of_closures _
| Value_closure _
@ -280,7 +277,6 @@ let augment_kind_with_approx t (kind:Lambda.value_kind) : Lambda.value_kind =
let value_unknown reason = approx (Value_unknown reason)
let value_int i = approx (Value_int i)
let value_char i = approx (Value_char i)
let value_constptr i = approx (Value_constptr i)
let value_float f = approx (Value_float (Some f))
let value_any_float = approx (Value_float None)
let value_boxed_int bi i = approx (Value_boxed_int (bi,i))
@ -392,19 +388,8 @@ let make_const_char n =
let name = Internal_variable_names.const_char in
name_expr_fst (make_const_char_named n) ~name
let make_const_ptr_named n : Flambda.named * t =
Const (Const_pointer n), value_constptr n
let make_const_ptr (n : int) =
let name =
match n with
| 0 -> Internal_variable_names.const_ptr_zero
| 1 -> Internal_variable_names.const_ptr_one
| _ -> Internal_variable_names.const_ptr
in
name_expr_fst (make_const_ptr_named n) ~name
let make_const_bool_named b : Flambda.named * t =
make_const_ptr_named (if b then 1 else 0)
make_const_int_named (if b then 1 else 0)
let make_const_bool b =
name_expr_fst (make_const_bool_named b)
~name:Internal_variable_names.const_bool
@ -444,9 +429,6 @@ let simplify t (lam : Flambda.t) : simplification_result =
| Value_char n ->
let const, approx = make_const_char n in
const, Replaced_term, approx
| Value_constptr n ->
let const, approx = make_const_ptr n in
const, Replaced_term, approx
| Value_float (Some f) ->
let const, approx = make_const_float f in
const, Replaced_term, approx
@ -472,9 +454,6 @@ let simplify_named t (named : Flambda.named) : simplification_result_named =
| Value_char n ->
let const, approx = make_const_char_named n in
const, Replaced_term, approx
| Value_constptr n ->
let const, approx = make_const_ptr_named n in
const, Replaced_term, approx
| Value_float (Some f) ->
let const, approx = make_const_float_named f in
const, Replaced_term, approx
@ -496,7 +475,6 @@ let simplify_var t : (Flambda.named * t) option =
match t.descr with
| Value_int n -> Some (make_const_int_named n)
| Value_char n -> Some (make_const_char_named n)
| Value_constptr n -> Some (make_const_ptr_named n)
| Value_float (Some f) -> Some (make_const_float_named f)
| Value_boxed_int (t, i) -> Some (make_const_boxed_int_named t i)
| Value_symbol sym -> Some (Symbol sym, t)
@ -559,14 +537,14 @@ let known t =
| Value_unknown _ -> false
| Value_string _ | Value_float_array _
| Value_bottom | Value_block _ | Value_int _ | Value_char _
| Value_constptr _ | Value_set_of_closures _ | Value_closure _
| Value_set_of_closures _ | Value_closure _
| Value_extern _ | Value_float _ | Value_boxed_int _ | Value_symbol _ -> true
let useful t =
match t.descr with
| Value_unresolved _ | Value_unknown _ | Value_bottom -> false
| Value_string _ | Value_float_array _ | Value_block _ | Value_int _
| Value_char _ | Value_constptr _ | Value_set_of_closures _
| Value_char _ | Value_set_of_closures _
| Value_float _ | Value_boxed_int _ | Value_closure _ | Value_extern _
| Value_symbol _ -> true
@ -576,7 +554,7 @@ let warn_on_mutation t =
match t.descr with
| Value_block(_, fields) -> Array.length fields > 0
| Value_string { contents = Some _ }
| Value_int _ | Value_char _ | Value_constptr _
| Value_int _ | Value_char _
| Value_set_of_closures _ | Value_float _ | Value_boxed_int _
| Value_closure _ -> true
| Value_string { contents = None } | Value_float_array _
@ -601,7 +579,7 @@ let get_field t ~field_index:i : get_field_result =
(* CR-someday mshinwell: This should probably return Unreachable in more
cases. I added a couple more. *)
| Value_bottom
| Value_int _ | Value_char _ | Value_constptr _ ->
| Value_int _ | Value_char _ ->
(* Something seriously wrong is happening: either the user is doing
something exceptionally unsafe, or it is an unreachable branch.
We consider this as unreachable and mark the result accordingly. *)
@ -637,7 +615,7 @@ let check_approx_for_block t =
| Value_block (tag, fields) ->
Ok (tag, fields)
| Value_bottom
| Value_int _ | Value_char _ | Value_constptr _
| Value_int _ | Value_char _
| Value_float_array _
| Value_string _ | Value_float _ | Value_boxed_int _
| Value_set_of_closures _ | Value_closure _
@ -687,8 +665,6 @@ let equal_floats f1 f2 =
let rec meet_descr ~really_import_approx d1 d2 = match d1, d2 with
| Value_int i, Value_int j when i = j ->
d1
| Value_constptr i, Value_constptr j when i = j ->
d1
| Value_symbol s1, Value_symbol s2 when Symbol.equal s1 s2 ->
d1
| Value_extern e1, Value_extern e2 when Export_id.equal e1 e2 ->
@ -780,7 +756,7 @@ let check_approx_for_set_of_closures t : checked_approx_for_set_of_closures =
to the set now out of scope. *)
Ok (t.var, value_set_of_closures)
| Value_closure _ | Value_block _ | Value_int _ | Value_char _
| Value_constptr _ | Value_float _ | Value_boxed_int _ | Value_unknown _
| Value_float _ | Value_boxed_int _ | Value_unknown _
| Value_bottom | Value_extern _ | Value_string _ | Value_float_array _
| Value_symbol _ ->
Wrong
@ -818,7 +794,7 @@ let check_approx_for_closure_allowing_unresolved t
symbol, value_set_of_closures)
| Value_unresolved _
| Value_closure _ | Value_block _ | Value_int _ | Value_char _
| Value_constptr _ | Value_float _ | Value_boxed_int _ | Value_unknown _
| Value_float _ | Value_boxed_int _ | Value_unknown _
| Value_bottom | Value_extern _ | Value_string _ | Value_float_array _
| Value_symbol _ ->
Wrong
@ -827,7 +803,7 @@ let check_approx_for_closure_allowing_unresolved t
Unknown_because_of_unresolved_value value
| Value_unresolved symbol -> Unresolved symbol
| Value_set_of_closures _ | Value_block _ | Value_int _ | Value_char _
| Value_constptr _ | Value_float _ | Value_boxed_int _
| Value_float _ | Value_boxed_int _
| Value_bottom | Value_extern _ | Value_string _ | Value_float_array _
| Value_symbol _ ->
Wrong
@ -866,7 +842,7 @@ let check_approx_for_float t : float option =
| Value_unresolved _
| Value_unknown _ | Value_string _ | Value_float_array _
| Value_bottom | Value_block _ | Value_int _ | Value_char _
| Value_constptr _ | Value_set_of_closures _ | Value_closure _
| Value_set_of_closures _ | Value_closure _
| Value_extern _ | Value_boxed_int _ | Value_symbol _ ->
None
@ -883,7 +859,7 @@ let float_array_as_constant (t:value_float_array) : float list option =
(Value_float None | Value_unresolved _
| Value_unknown _ | Value_string _ | Value_float_array _
| Value_bottom | Value_block _ | Value_int _ | Value_char _
| Value_constptr _ | Value_set_of_closures _ | Value_closure _
| Value_set_of_closures _ | Value_closure _
| Value_extern _ | Value_boxed_int _ | Value_symbol _)
-> None)
contents (Some [])
@ -895,7 +871,7 @@ let check_approx_for_string t : string option =
| Value_unresolved _
| Value_unknown _ | Value_float_array _
| Value_bottom | Value_block _ | Value_int _ | Value_char _
| Value_constptr _ | Value_set_of_closures _ | Value_closure _
| Value_set_of_closures _ | Value_closure _
| Value_extern _ | Value_boxed_int _ | Value_symbol _ ->
None
@ -913,11 +889,11 @@ let potentially_taken_const_switch_branch t branch =
(* In theory symbol cannot contain integers but this shouldn't
matter as this will always be an imported approximation *)
Can_be_taken
| Value_constptr i | Value_int i when i = branch ->
| Value_int i when i = branch ->
Must_be_taken
| Value_char c when Char.code c = branch ->
Must_be_taken
| Value_constptr _ | Value_int _ | Value_char _ ->
| Value_int _ | Value_char _ ->
Cannot_be_taken
| Value_block _ | Value_float _ | Value_float_array _
| Value_string _ | Value_closure _ | Value_set_of_closures _
@ -931,7 +907,7 @@ let potentially_taken_block_switch_branch t tag =
| Value_extern _
| Value_symbol _) ->
Can_be_taken
| (Value_constptr _ | Value_int _| Value_char _) ->
| (Value_int _| Value_char _) ->
Cannot_be_taken
| Value_block (block_tag, _) when Tag.to_int block_tag = tag ->
Must_be_taken

4
middle_end/flambda/simple_value_approx.mli
View File

@ -124,7 +124,6 @@ and descr = private
| Value_block of Tag.t * t array
| Value_int of int
| Value_char of char
| Value_constptr of int
| Value_float of float option
| Value_boxed_int : 'a boxed_int * 'a -> descr
| Value_set_of_closures of value_set_of_closures
@ -248,7 +247,6 @@ val value_mutable_float_array : size:int -> t
val value_immutable_float_array : t array -> t
val value_string : int -> string option -> t
val value_boxed_int : 'i boxed_int -> 'i -> t
val value_constptr : int -> t
val value_block : Tag.t -> t array -> t
val value_extern : Export_id.t -> t
val value_symbol : Symbol.t -> t
@ -280,14 +278,12 @@ val value_set_of_closures
together with an Flambda expression representing it. *)
val make_const_int : int -> Flambda.t * t
val make_const_char : char -> Flambda.t * t
val make_const_ptr : int -> Flambda.t * t
val make_const_bool : bool -> Flambda.t * t
val make_const_float : float -> Flambda.t * t
val make_const_boxed_int : 'i boxed_int -> 'i -> Flambda.t * t
val make_const_int_named : int -> Flambda.named * t
val make_const_char_named : char -> Flambda.named * t
val make_const_ptr_named : int -> Flambda.named * t
val make_const_bool_named : bool -> Flambda.named * t
val make_const_float_named : float -> Flambda.named * t
val make_const_boxed_int_named : 'i boxed_int -> 'i -> Flambda.named * t

5
middle_end/flambda/simplify_common.ml
View File

@ -35,11 +35,6 @@ let const_char_expr expr c =
let (new_expr, approx) = A.make_const_char_named c in
new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero
else expr, A.value_char c, C.Benefit.zero
let const_ptr_expr expr n =
if Effect_analysis.no_effects_named expr then
let (new_expr, approx) = A.make_const_ptr_named n in
new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero
else expr, A.value_constptr n, C.Benefit.zero
let const_bool_expr expr b =
const_int_expr expr (if b then 1 else 0)
let const_float_expr expr f =

5
middle_end/flambda/simplify_common.mli
View File

@ -42,11 +42,6 @@ val const_bool_expr
-> bool
-> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t
val const_ptr_expr
: Flambda.named
-> int
-> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t
val const_float_expr
: Flambda.named
-> float

24
middle_end/flambda/simplify_primitives.ml
View File

@ -40,7 +40,7 @@ let phys_equal (approxs:A.t list) =
let is_known_to_be_some_kind_of_int (arg:A.descr) =
match arg with
| Value_int _ | Value_char _ | Value_constptr _ -> true
| Value_int _ | Value_char _ -> true
| Value_block (_, _) | Value_float _ | Value_set_of_closures _
| Value_closure _ | Value_string _ | Value_float_array _
| A.Value_boxed_int _ | Value_unknown _ | Value_extern _
@ -50,13 +50,13 @@ let is_known_to_be_some_kind_of_block (arg:A.descr) =
match arg with
| Value_block _ | Value_float _ | Value_float_array _ | A.Value_boxed_int _
| Value_closure _ | Value_string _ -> true
| Value_set_of_closures _ | Value_int _ | Value_char _ | Value_constptr _
| Value_set_of_closures _ | Value_int _ | Value_char _
| Value_unknown _ | Value_extern _ | Value_symbol _
| Value_unresolved _ | Value_bottom -> false
let rec structurally_different (arg1:A.t) (arg2:A.t) =
match arg1.descr, arg2.descr with
| (Value_int n1 | Value_constptr n1), (Value_int n2 | Value_constptr n2)
| (Value_int n1), (Value_int n2)
when n1 <> n2 ->
true
| Value_block (tag1, fields1), Value_block (tag2, fields2) ->
@ -171,6 +171,7 @@ let primitive (p : Clambda_primitives.primitive) (args, approxs)
| Pnot -> S.const_bool_expr expr (x = 0)
| Pnegint -> S.const_int_expr expr (-x)
| Pbswap16 -> S.const_int_expr expr (S.swap16 x)
| Pisint -> S.const_bool_expr expr true
| Poffsetint y -> S.const_int_expr expr (x + y)
| Pfloatofint when fpc -> S.const_float_expr expr (float_of_int x)
| Pbintofint Pnativeint ->
@ -179,7 +180,7 @@ let primitive (p : Clambda_primitives.primitive) (args, approxs)
| Pbintofint Pint64 -> S.const_boxed_int_expr expr Int64 (Int64.of_int x)
| _ -> expr, A.value_unknown Other, C.Benefit.zero
end
| [(Value_int x | Value_constptr x); (Value_int y | Value_constptr y)] ->
| [Value_int x; Value_int y] ->
let shift_precond = 0 <= y && y < 8 * size_int in
begin match p with
| Paddint -> S.const_int_expr expr (x + y)
@ -204,15 +205,6 @@ let primitive (p : Clambda_primitives.primitive) (args, approxs)
| Pcompare_ints -> S.const_int_expr expr (Char.compare x y)
| _ -> expr, A.value_unknown Other, C.Benefit.zero
end
| [Value_constptr x] ->
begin match p with
(* [Pidentity] should probably never appear, but is here for
completeness. *)
| Pnot -> S.const_bool_expr expr (x = 0)
| Pisint -> S.const_bool_expr expr true
| Poffsetint y -> S.const_ptr_expr expr (x + y)
| _ -> expr, A.value_unknown Other, C.Benefit.zero
end
| [Value_float (Some x)] when fpc ->
begin match p with
| Pintoffloat -> S.const_int_expr expr (int_of_float x)
@ -258,7 +250,7 @@ let primitive (p : Clambda_primitives.primitive) (args, approxs)
when (is_pstring_length p || is_pbytes_length p) ->
S.const_int_expr expr size
| [Value_string { size; contents = Some s };
(Value_int x | Value_constptr x)] when x >= 0 && x < size ->
(Value_int x)] when x >= 0 && x < size ->
begin match p with
| Pstringrefu
| Pstringrefs
@ -268,14 +260,14 @@ let primitive (p : Clambda_primitives.primitive) (args, approxs)
| _ -> expr, A.value_unknown Other, C.Benefit.zero
end
| [Value_string { size; contents = None };
(Value_int x | Value_constptr x)]
(Value_int x)]
when x >= 0 && x < size && is_pstringrefs p ->
Flambda.Prim (Pstringrefu, args, dbg),
A.value_unknown Other,
(* we improved it, but there is no way to account for that: *)
C.Benefit.zero
| [Value_string { size; contents = None };
(Value_int x | Value_constptr x)]
(Value_int x)]
when x >= 0 && x < size && is_pbytesrefs p ->
Flambda.Prim (Pbytesrefu, args, dbg),
A.value_unknown Other,

1
middle_end/printclambda.ml
View File

@ -95,7 +95,6 @@ and uconstant ppf = function
fprintf ppf "%S=%a" s structured_constant c
| Uconst_ref (s, None) -> fprintf ppf "%S"s
| Uconst_int i -> fprintf ppf "%i" i
| Uconst_ptr i -> fprintf ppf "%ia" i
and lam ppf = function
| Uvar id ->

4
testsuite/tests/basic-modules/anonymous.ocamlc.reference
View File

@ -13,11 +13,11 @@
(apply (field 1 (global CamlinternalMod!)) [0: [0]] B
(module-defn(B) Anonymous anonymous.ml(33):703-773
(let (x = [0: "foo" "bar"]) (makeblock 0))))
(let (f = (function param 0a) s = (makemutable 0 ""))
(let (f = (function param 0) s = (makemutable 0 ""))
(seq
(ignore
(let (*match* = (setfield_ptr 0 s "Hello World!"))
(makeblock 0)))
(let
(drop = (function param 0a) *match* = (apply drop (field 0 s)))
(drop = (function param 0) *match* = (apply drop (field 0 s)))
(makeblock 0 A B f s drop))))))))

5
testsuite/tests/basic-modules/anonymous.ocamlopt.flambda.reference
View File

@ -12,10 +12,9 @@
(apply (field 1 (global CamlinternalMod!)) [0: [0]] B
(module-defn(B) Anonymous anonymous.ml(33):703-773
(let (x = [0: "foo" "bar"]) (makeblock 0))))
(let (f = (function param 0a) s = (makemutable 0 ""))
(let (f = (function param 0) s = (makemutable 0 ""))
(seq
(ignore
(let (*match* = (setfield_ptr 0 s "Hello World!")) (makeblock 0)))
(let
(drop = (function param 0a) *match* = (apply drop (field 0 s)))
(let (drop = (function param 0) *match* = (apply drop (field 0 s)))
(makeblock 0 A B f s drop)))))))

8
testsuite/tests/basic-modules/anonymous.ocamlopt.reference
View File

@ -12,7 +12,7 @@
(let (x = [0: "foo" "bar"]) (makeblock 0)))
(setfield_ptr(root-init) 0 (global Anonymous!) A)
(setfield_ptr(root-init) 1 (global Anonymous!) B)
(let (f = (function param 0a))
(let (f = (function param 0))
(setfield_ptr(root-init) 2 (global Anonymous!) f))
(let (s = (makemutable 0 ""))
(setfield_ptr(root-init) 3 (global Anonymous!) s))
@ -21,11 +21,11 @@
(*match* =
(setfield_ptr 0 (field 3 (global Anonymous!)) "Hello World!"))
(makeblock 0)))
(let (drop = (function param 0a))
(let (drop = (function param 0))
(setfield_ptr(root-init) 4 (global Anonymous!) drop))
(let
(*match* =
(apply (field 4 (global Anonymous!))
(field 0 (field 3 (global Anonymous!)))))
0a)
0a)))
0)
0)))

2
testsuite/tests/basic/patmatch_split_no_or.ml
View File

@ -49,7 +49,7 @@ val last_is_vars : bool * bool -> int = <fun>
type t = ..
type t += A | B of unit | C of bool * int;;
[%%expect{|
0a
0
type t = ..
(let
(A/25 = (makeblock 248 "A" (caml_fresh_oo_id 0))

20
testsuite/tests/translprim/comparison_table.compilers.reference
View File

@ -137,14 +137,14 @@
eta_int32_ge = (function prim prim stub (Int32.>= prim prim))
eta_int64_ge = (function prim prim stub (Int64.>= prim prim))
eta_nativeint_ge = (function prim prim stub (Nativeint.>= prim prim))
int_vec = [0: [0: 1 1] [0: [0: 1 2] [0: [0: 2 1] 0a]]]
bool_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
intlike_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]]
float_vec = [0: [0: 1. 1.] [0: [0: 1. 2.] [0: [0: 2. 1.] 0a]]]
string_vec = [0: [0: "1" "1"] [0: [0: "1" "2"] [0: [0: "2" "1"] 0a]]]
int32_vec = [0: [0: 1l 1l] [0: [0: 1l 2l] [0: [0: 2l 1l] 0a]]]
int64_vec = [0: [0: 1L 1L] [0: [0: 1L 2L] [0: [0: 2L 1L] 0a]]]
nativeint_vec = [0: [0: 1n 1n] [0: [0: 1n 2n] [0: [0: 2n 1n] 0a]]]
int_vec = [0: [0: 1 1] [0: [0: 1 2] [0: [0: 2 1] 0]]]
bool_vec = [0: [0: 0 0] [0: [0: 0 1] [0: [0: 1 0] 0]]]
intlike_vec = [0: [0: 0 0] [0: [0: 0 1] [0: [0: 1 0] 0]]]
float_vec = [0: [0: 1. 1.] [0: [0: 1. 2.] [0: [0: 2. 1.] 0]]]
string_vec = [0: [0: "1" "1"] [0: [0: "1" "2"] [0: [0: "2" "1"] 0]]]
int32_vec = [0: [0: 1l 1l] [0: [0: 1l 2l] [0: [0: 2l 1l] 0]]]
int64_vec = [0: [0: 1L 1L] [0: [0: 1L 2L] [0: [0: 2L 1L] 0]]]
nativeint_vec = [0: [0: 1n 1n] [0: [0: 1n 2n] [0: [0: 2n 1n] 0]]]
test_vec =
(function cmp eq ne lt gt le ge vec
(let
@ -163,7 +163,7 @@
(makeblock 0 (makeblock 0 gen_lt lt)
(makeblock 0 (makeblock 0 gen_gt gt)
(makeblock 0 (makeblock 0 gen_le le)
(makeblock 0 (makeblock 0 gen_ge ge) 0a)))))))))))
(makeblock 0 (makeblock 0 gen_ge ge) 0)))))))))))
(seq
(apply test_vec int_cmp int_eq int_ne int_lt int_gt int_le int_ge
int_vec)
@ -203,7 +203,7 @@
(makeblock 0 (makeblock 0 eta_gen_lt lt)
(makeblock 0 (makeblock 0 eta_gen_gt gt)
(makeblock 0 (makeblock 0 eta_gen_le le)
(makeblock 0 (makeblock 0 eta_gen_ge ge) 0a)))))))))))
(makeblock 0 (makeblock 0 eta_gen_ge ge) 0)))))))))))
(seq
(apply eta_test_vec eta_int_cmp eta_int_eq eta_int_ne eta_int_lt
eta_int_gt eta_int_le eta_int_ge int_vec)

34
testsuite/tests/translprim/ref_spec.compilers.reference
View File

@ -1,27 +1,27 @@
(setglobal Ref_spec!
(let
(int_ref = (makemutable 0 (int) 1)
var_ref = (makemutable 0 65a)
vargen_ref = (makemutable 0 65a)
cst_ref = (makemutable 0 0a)
gen_ref = (makemutable 0 0a)
var_ref = (makemutable 0 65)
vargen_ref = (makemutable 0 65)
cst_ref = (makemutable 0 0)
gen_ref = (makemutable 0 0)
flt_ref = (makemutable 0 (float) 0.))
(seq (setfield_imm 0 int_ref 2) (setfield_imm 0 var_ref 66a)
(setfield_ptr 0 vargen_ref [0: 66 0]) (setfield_ptr 0 vargen_ref 67a)
(setfield_imm 0 cst_ref 1a) (setfield_ptr 0 gen_ref [0: "foo"])
(setfield_ptr 0 gen_ref 0a) (setfield_ptr 0 flt_ref 1.)
(seq (setfield_imm 0 int_ref 2) (setfield_imm 0 var_ref 66)
(setfield_ptr 0 vargen_ref [0: 66 0]) (setfield_ptr 0 vargen_ref 67)
(setfield_imm 0 cst_ref 1) (setfield_ptr 0 gen_ref [0: "foo"])
(setfield_ptr 0 gen_ref 0) (setfield_ptr 0 flt_ref 1.)
(let
(int_rec = (makemutable 0 (*,int) 0a 1)
var_rec = (makemutable 0 0a 65a)
vargen_rec = (makemutable 0 0a 65a)
cst_rec = (makemutable 0 0a 0a)
gen_rec = (makemutable 0 0a 0a)
flt_rec = (makemutable 0 (*,float) 0a 0.)
(int_rec = (makemutable 0 (*,int) 0 1)
var_rec = (makemutable 0 0 65)
vargen_rec = (makemutable 0 0 65)
cst_rec = (makemutable 0 0 0)
gen_rec = (makemutable 0 0 0)
flt_rec = (makemutable 0 (*,float) 0 0.)
flt_rec' = (makearray[float] 0. 0.))
(seq (setfield_imm 1 int_rec 2) (setfield_imm 1 var_rec 66a)
(seq (setfield_imm 1 int_rec 2) (setfield_imm 1 var_rec 66)
(setfield_ptr 1 vargen_rec [0: 66 0])
(setfield_ptr 1 vargen_rec 67a) (setfield_imm 1 cst_rec 1a)
(setfield_ptr 1 gen_rec [0: "foo"]) (setfield_ptr 1 gen_rec 0a)
(setfield_ptr 1 vargen_rec 67) (setfield_imm 1 cst_rec 1)
(setfield_ptr 1 gen_rec [0: "foo"]) (setfield_ptr 1 gen_rec 0)
(setfield_ptr 1 flt_rec 1.) (setfloatfield 1 flt_rec' 1.)
(let
(set_open_poly = (function r y (setfield_ptr 0 r y))

1
tools/dumpobj.ml
View File

@ -92,7 +92,6 @@ let rec print_struct_const = function
| Const_base(Const_int32 i) -> printf "%ldl" i
| Const_base(Const_nativeint i) -> printf "%ndn" i
| Const_base(Const_int64 i) -> printf "%LdL" i
| Const_pointer n -> printf "%da" n
| Const_block(tag, args) ->
printf "<%d>" tag;
begin match args with