Re: [Caml-list] Questions about changing lambda IR

[Gabriel Scherer <gabriel.scherer@gmail.com>]

[-- 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