* Re: [Caml-list] Questions about changing lambda IR
2015-08-08 11:28 ` Bob Zhang
@ 2015-08-08 14:13 ` Gabriel Scherer
2015-08-10 2:45 ` Bob Zhang
0 siblings, 1 reply; 6+ messages in thread
From: Gabriel Scherer @ 2015-08-08 14:13 UTC (permalink / raw)
To: Bob Zhang; +Cc: Caml List, Xavier Leroy
[-- Attachment #1.1: Type: text/plain, Size: 3007 bytes --]
Attached to this email is the patch I tried. It's exactly your proposed
change, with necessary dummy changes to make it compile. The following
process works reliably on my trunk:
- make world
- apply the patch
- make bootstrap
- make world
On Sat, Aug 8, 2015 at 1:28 PM, Bob Zhang <bobzhang1988@gmail.com> wrote:
> Before I changed Lambda.lambda, and it works, it might be that we
> serialized structured_constant somewhere in the bootstrapping process?
>
> On Sat, Aug 8, 2015 at 7:25 AM, Bob Zhang <bobzhang1988@gmail.com> wrote:
>
>> It does not work for me. Since it fails to compile, I pushed it to
>> another branch https://github.com/bobzhang/ocaml/tree/fails (sorry for
>> the misinformation)
>>
>> I did `git clean -fxd` and try configure, make world, it failed in the
>> same place.
>> Thank you for your time!
>>
>> On Sat, Aug 8, 2015 at 3:37 AM, Gabriel Scherer <
>> gabriel.scherer@gmail.com> wrote:
>>
>>> You need to run "make bootstrap" to avoid having part of the definition
>>> compiled against the stale definition of lambda.cmi. (I just checked that
>>> it works on your change: after a bootrsap, "make world", "make opt", "make
>>> opt.opt" work.)
>>>
>>> On Sat, Aug 8, 2015 at 5:50 AM, Bob Zhang <bobzhang1988@gmail.com>
>>> wrote:
>>>
>>>>
>>>> Dear caml develpers,
>>>>
>>>> I am working on an experimental branch to pass more information from
>>>> typedtree to lambda to enable ocaml generate user readable javascript code(
>>>> https://github.com/bobzhang/ocaml/tree/master) (online-demo:
>>>> http://zhanghongbo.me/js-demo/)
>>>>
>>>> Here I get a segfault, after I change const_block:
>>>> Below is my minimal change:
>>>>
>>>> ```
>>>> type pointer_info =
>>>> | NullConstructor of string
>>>> | NullVariant of string
>>>> | NAPointer
>>>>
>>>> type tag_info =
>>>> | Constructor of string
>>>> | Tuple
>>>> | Variant of string
>>>> | Record
>>>> | NA
>>>>
>>>> type structured_constant =
>>>> Const_base of constant
>>>> | 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
>>>> ```
>>>> Note that the enriched info is not used in ``emitcode``, now I get a
>>>> segfault in make world:
>>>>
>>>> ```
>>>> ../../boot/ocamlrun ../../ocamlc -nostdlib -I ../../stdlib -c -w
>>>> +33..39 -warn-error A -bin-annot -g -safe-string -I ../../stdlib -I
>>>> ../../utils -I ../../typing -I ../../bytecomp -I ../../asmcomp
>>>> extract_crc.ml
>>>> ../../boot/ocamlrun ../../ocamlc -nostdlib -I ../../stdlib -o
>>>> extract_crc dynlink.cma extract_crc.cmo
>>>> make[3]: *** [extract_crc] Segmentation fault: 11
>>>> make[3]: *** Deleting file `extract_crc'
>>>> make[2]: *** [otherlibraries] Error 2
>>>> make[1]: *** [all] Error 2
>>>> ```
>>>>
>>>> Any help is appreciated : )
>>>>
>>>> --
>>>> Regards
>>>> -- Hongbo Zhang
>>>>
>>>
>>>
>>
>>
>> --
>> Regards
>> -- Hongbo Zhang
>>
>
>
>
> --
> Regards
> -- Hongbo Zhang
>
[-- Attachment #1.2: Type: text/html, Size: 5009 bytes --]
[-- Attachment #2: change-const_block-representation.patch --]
[-- Type: text/x-patch, Size: 15148 bytes --]
From 02ffdf8f2431f9e2d84c651ef4ebc72c872275b9 Mon Sep 17 00:00:00 2001
From: Gabriel Scherer <gabriel.scherer@gmail.com>
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
^ permalink raw reply [flat|nested] 6+ messages in thread