From 02ffdf8f2431f9e2d84c651ef4ebc72c872275b9 Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Sat, 8 Aug 2015 09:30:16 +0200 Subject: [PATCH] change const_block representation --- asmcomp/closure.ml | 4 ++-- bytecomp/emitcode.ml | 10 +++++----- bytecomp/lambda.ml | 21 +++++++++++++++++---- bytecomp/lambda.mli | 16 ++++++++++++++-- bytecomp/matching.ml | 2 +- bytecomp/printlambda.ml | 6 +++--- bytecomp/symtable.ml | 6 +++--- bytecomp/translclass.ml | 10 +++++----- bytecomp/translcore.ml | 18 +++++++++--------- bytecomp/translmod.ml | 12 ++++++------ bytecomp/translobj.ml | 2 +- tools/dumpobj.ml | 4 ++-- 12 files changed, 68 insertions(+), 43 deletions(-) diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 175932c..569e06b 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -822,8 +822,8 @@ let rec close fenv cenv = function 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) -> + | Const_pointer (n, _) -> Uconst_ptr n + | Const_block (tag, _, fields) -> str (Uconst_block (tag, List.map transl fields)) | Const_float_array sl -> (* constant float arrays are really immutable *) diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 81e00b7..e3ba00b 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -50,7 +50,7 @@ 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 + | Const_pointer (i, _) -> i | _ -> raise AsInt let is_immed i = immed_min <= i && i <= immed_max @@ -210,11 +210,11 @@ 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 -> + | Const_pointer (i, _) -> if i >= 0 && i <= 3 then out (opCONST0 + i) else (out opCONSTINT; out_int i) - | Const_block(t, []) -> + | Const_block(t, _, []) -> if t = 0 then out opATOM0 else (out opATOM; out_int t) | _ -> out opGETGLOBAL; slot_for_literal sc @@ -336,11 +336,11 @@ 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 -> + | Const_pointer (i, _) -> if i >= 0 && i <= 3 then out (opPUSHCONST0 + i) else (out opPUSHCONSTINT; out_int i) - | Const_block(t, []) -> + | Const_block(t, _, []) -> if t = 0 then out opPUSHATOM0 else (out opPUSHATOM; out_int t) | _ -> out opPUSHGETGLOBAL; slot_for_literal sc diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index 7783368..17249b3 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -154,10 +154,23 @@ and raise_kind = | Raise_reraise | Raise_notrace + +type pointer_info = + | NullConstructor of string + | NullVariant of string + | NA + +type tag_info = + | Constructor of string + | Tuple + | Variant of string + | Record + | NA + type structured_constant = Const_base of constant - | Const_pointer of int - | Const_block of int * structured_constant list + | Const_pointer of int * pointer_info + | Const_block of int * tag_info * structured_constant list | Const_float_array of string list | Const_immstring of string @@ -226,7 +239,7 @@ and lambda_event_kind = | Lev_after of Types.type_expr | Lev_function -let const_unit = Const_pointer 0 +let const_unit = Const_pointer (0, NA) let lambda_unit = Lconst const_unit @@ -549,7 +562,7 @@ let lam_of_loc kind loc = loc_start.Lexing.pos_cnum + cnum in match kind with | Loc_POS -> - Lconst (Const_block (0, [ + Lconst (Const_block (0, NA, [ Const_immstring file; Const_base (Const_int lnum); Const_base (Const_int cnum); diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index eba9593..4cd880a 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -154,10 +154,22 @@ and raise_kind = | Raise_reraise | Raise_notrace +type pointer_info = + | NullConstructor of string + | NullVariant of string + | NA + +type tag_info = + | Constructor of string + | Tuple + | Variant of string + | Record + | NA + type structured_constant = Const_base of constant - | Const_pointer of int - | Const_block of int * structured_constant list + | Const_pointer of int * pointer_info + | Const_block of int * tag_info * structured_constant list | Const_float_array of string list | Const_immstring of string diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 1bdeef8..fb5fc68 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -3000,7 +3000,7 @@ let partial_function loc () = let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable), [transl_normal_path Predef.path_match_failure; - Lconst(Const_block(0, + Lconst(Const_block(0, NA, [Const_base(Const_string (fname, None)); Const_base(Const_int line); Const_base(Const_int char)]))])]) diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 591822f3..392293d 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -26,10 +26,10 @@ 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, []) -> + | Const_pointer (n, _) -> fprintf ppf "%ia" n + | Const_block(tag, _, []) -> fprintf ppf "[%i]" tag - | Const_block(tag, sc1::scl) -> + | Const_block(tag, _, sc1::scl) -> let sconsts ppf scl = List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index a0ce273..57a567e 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -142,7 +142,7 @@ let init () = try List.assoc name Predef.builtin_values with Not_found -> fatal_error "Symtable.init" in let c = slot_for_setglobal id in - let cst = Const_block(Obj.object_tag, + let cst = Const_block(Obj.object_tag, NA, [Const_base(Const_string (name, None)); Const_base(Const_int (-i-1)) ]) @@ -213,9 +213,9 @@ 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_pointer (i, _) -> Obj.repr i | Const_immstring s -> Obj.repr s - | Const_block(tag, fields) -> + | Const_block(tag, _, fields) -> let block = Obj.new_block tag (List.length fields) in let pos = ref 0 in List.iter diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index f172e9a..6ee6579 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -48,9 +48,9 @@ let lfield v i = Lprim(Pfield i, [Lvar v]) 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_pointer (0, NA)) else share (Const_block - (0, List.map (fun lab -> Const_immstring lab) lst)) + (0, NA, List.map (fun lab -> Const_immstring lab) lst)) let set_inst_var obj id expr = let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in @@ -358,7 +358,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = (inh_init, Llet (Strict, inh, mkappl(oo_prim "inherits", narrow_args @ - [lpath; Lconst(Const_pointer(if top then 1 else 0))]), + [lpath; Lconst(Const_pointer((if top then 1 else 0), NA))]), Llet(StrictOpt, obj_init, lfield inh 0, cl_init))) | _ -> let core cl_init = @@ -503,7 +503,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_pointer (n, NA))] | Lsend(Self, met, Lvar s, [], _) when List.mem s self -> "meth", [met] | _ -> raise Not_found @@ -574,7 +574,7 @@ module M = struct | "send_env" -> SendEnv | "send_meth" -> SendMeth | _ -> assert false - in Lconst(Const_pointer(Obj.magic tag)) :: args + in Lconst(Const_pointer(Obj.magic tag, NA)) :: args end open M diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index e7f5a3a..f145050 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -648,7 +648,7 @@ let assert_failed exp = Lprim(Praise Raise_regular, [event_after exp (Lprim(Pmakeblock(0, Immutable), [transl_normal_path Predef.path_assert_failure; - Lconst(Const_block(0, + Lconst(Const_block(0, NA, [Const_base(Const_string (fname, None)); Const_base(Const_int line); Const_base(Const_int char)]))]))]) @@ -779,7 +779,7 @@ and transl_exp0 e = | Texp_tuple el -> let ll = transl_list el in begin try - Lconst(Const_block(0, List.map extract_constant ll)) + Lconst(Const_block(0, NA, List.map extract_constant ll)) with Not_constant -> Lprim(Pmakeblock(0, Immutable), ll) end @@ -790,10 +790,10 @@ and transl_exp0 e = | _ -> assert false end else begin match cstr.cstr_tag with Cstr_constant n -> - Lconst(Const_pointer n) + Lconst(Const_pointer (n, NA)) | Cstr_block n -> begin try - Lconst(Const_block(n, List.map extract_constant ll)) + Lconst(Const_block(n, NA, List.map extract_constant ll)) with Not_constant -> Lprim(Pmakeblock(n, Immutable), ll) end @@ -807,11 +807,11 @@ and transl_exp0 e = | Texp_variant(l, arg) -> let tag = Btype.hash_variant l in begin match arg with - None -> Lconst(Const_pointer tag) + None -> Lconst(Const_pointer (tag, NA)) | Some arg -> let lam = transl_exp arg in try - Lconst(Const_block(0, [Const_base(Const_int tag); + Lconst(Const_block(0, NA, [Const_base(Const_int tag); extract_constant lam])) with Not_constant -> Lprim(Pmakeblock(0, Immutable), @@ -849,7 +849,7 @@ and transl_exp0 e = let master = match kind with | Paddrarray | Pintarray -> - Lconst(Const_block(0, cl)) + Lconst(Const_block(0, NA, cl)) | Pfloatarray -> Lconst(Const_float_array(List.map extract_float cl)) | Pgenarray -> @@ -1154,8 +1154,8 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr = if mut = Mutable then raise Not_constant; let cl = List.map extract_constant ll in match repres with - | Record_regular -> Lconst(Const_block(0, cl)) - | Record_inlined tag -> Lconst(Const_block(tag, cl)) + | Record_regular -> Lconst(Const_block(0, NA, cl)) + | Record_inlined tag -> Lconst(Const_block(tag, NA, cl)) | Record_float -> Lconst(Const_float_array(List.map extract_float cl)) | Record_extension -> diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 4ff70b7..896eaae 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -189,7 +189,7 @@ let mod_prim name = let undefined_location loc = let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in - Lconst(Const_block(0, + Lconst(Const_block(0, NA, [Const_base(Const_string (fname, None)); Const_base(Const_int line); Const_base(Const_int char)])) @@ -200,9 +200,9 @@ let init_shape modl = Mty_ident _ -> raise Not_found | Mty_alias _ -> - Const_block (1, [Const_pointer 0]) + Const_block (1, NA, [Const_pointer (0, NA)]) | Mty_signature sg -> - Const_block(0, [Const_block(0, init_shape_struct env sg)]) + Const_block(0, NA, [Const_block(0, NA, init_shape_struct env sg)]) | Mty_functor(id, arg, res) -> raise Not_found (* can we do better? *) and init_shape_struct env sg = @@ -212,9 +212,9 @@ let init_shape modl = let init_v = match Ctype.expand_head env vdesc.val_type with {desc = Tarrow(_,_,_,_)} -> - Const_pointer 0 (* camlinternalMod.Function *) + Const_pointer (0, NA) (* camlinternalMod.Function *) | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t -> - Const_pointer 1 (* camlinternalMod.Lazy *) + Const_pointer (1, NA) (* camlinternalMod.Lazy *) | _ -> raise Not_found in init_v :: init_shape_struct env rem | Sig_type(id, tdecl, _) :: rem -> @@ -227,7 +227,7 @@ let init_shape modl = | Sig_modtype(id, minfo) :: rem -> init_shape_struct (Env.add_modtype id minfo env) rem | Sig_class(id, cdecl, _) :: rem -> - Const_pointer 2 (* camlinternalMod.Class *) + Const_pointer (2, NA) (* camlinternalMod.Class *) :: init_shape_struct env rem | Sig_class_type(id, ctyp, _) :: rem -> init_shape_struct env rem diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index 02731ec..37a0516 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -31,7 +31,7 @@ let consts : (structured_constant, Ident.t) Hashtbl.t = Hashtbl.create 17 let share c = match c with - Const_block (n, l) when l <> [] -> + Const_block (n, _, l) when l <> [] -> begin try Lvar (Hashtbl.find consts c) with Not_found -> diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml index 7fd3e43..68559b0 100644 --- a/tools/dumpobj.ml +++ b/tools/dumpobj.ml @@ -88,8 +88,8 @@ 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) -> + | Const_pointer (n, _) -> printf "%da" n + | Const_block(tag, _, args) -> printf "<%d>" tag; begin match args with [] -> () -- 2.1.0