Replace structured constants by their Obj.t representation in CMO files

Before this commit, relocatable literals under the Reloc_literal
constructor were represented by objects
of type Lambda.structured_constant
in the CMO files. These objects were translated into their Obj.t
representation as they were loaded.

With this commit, the translation from Lambda.structured_constant
to Obj.t occurs as part of the compilation rather than when the CMO file
is loaded.

6 files changed, 40 insertions, 71 deletions

diff --git a/.depend b/.depend
index 808d68e450..0b4c4f7f2d 100644
--- a/.depend
+++ b/.depend
@@ -2072,6 +2072,7 @@ bytecomp/dll.cmx : \
 bytecomp/dll.cmi :
 bytecomp/emitcode.cmo : \
     lambda/translmod.cmi \
+    bytecomp/symtable.cmi \
     typing/primitive.cmi \
     bytecomp/opcodes.cmi \
     utils/misc.cmi \
@@ -2089,6 +2090,7 @@ bytecomp/emitcode.cmo : \
     bytecomp/emitcode.cmi
 bytecomp/emitcode.cmx : \
     lambda/translmod.cmx \
+    bytecomp/symtable.cmx \
     typing/primitive.cmx \
     bytecomp/opcodes.cmx \
     utils/misc.cmx \
@@ -3916,7 +3918,6 @@ file_formats/cmi_format.cmi : \
     utils/misc.cmi
 file_formats/cmo_format.cmi : \
     utils/misc.cmi \
-    lambda/lambda.cmi \
     typing/ident.cmi
 file_formats/cmt_format.cmo : \
     typing/types.cmi \
@@ -6918,26 +6919,22 @@ tools/dumpobj.cmo : \
     tools/opnames.cmi \
     bytecomp/opcodes.cmi \
     parsing/location.cmi \
-    lambda/lambda.cmi \
     bytecomp/instruct.cmi \
     typing/ident.cmi \
     utils/config.cmi \
     file_formats/cmo_format.cmi \
     bytecomp/bytesections.cmi \
-    parsing/asttypes.cmi \
     tools/dumpobj.cmi
 tools/dumpobj.cmx : \
     bytecomp/symtable.cmx \
     tools/opnames.cmx \
     bytecomp/opcodes.cmx \
     parsing/location.cmx \
-    lambda/lambda.cmx \
     bytecomp/instruct.cmx \
     typing/ident.cmx \
     utils/config.cmx \
     file_formats/cmo_format.cmi \
     bytecomp/bytesections.cmx \
-    parsing/asttypes.cmi \
     tools/dumpobj.cmi
 tools/dumpobj.cmi :
 tools/eqparsetree.cmo : \
diff --git a/Changes b/Changes
index a9e38cb99d..27f7d9063c 100644
--- a/Changes
+++ b/Changes
@@ -469,6 +469,12 @@ Working version
   in preparation for quadratic-time fix
   (Gabriel Scherer, review by Enguerrand Decorne)
 
+- #11997: translate structured constants into their Obj.t representation
+  at compile time rather than link time. Changes the way dumpobj prints
+  these constants because their representaiton becomes untyped.
+  (Sébastien Hinderer, review by Xavier Leroy, Nicolás Ojeda Bär and
+  Hugo Heuzard)
+
 ### Build system:
 
 - #11590: Allow installing to a destination path containing spaces.
diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
index 8e600d7fa0..9e70bebd9c 100644
--- a/bytecomp/emitcode.ml
+++ b/bytecomp/emitcode.ml
@@ -151,7 +151,7 @@ let enter info =
   reloc_info := (info, !out_position) :: !reloc_info
 
 let slot_for_literal sc =
-  enter (Reloc_literal sc);
+  enter (Reloc_literal (Symtable.transl_const sc));
   out_int 0
 and slot_for_getglobal id =
   enter (Reloc_getglobal id);
diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml
index f45a06b69d..b977095237 100644
--- a/bytecomp/symtable.ml
+++ b/bytecomp/symtable.ml
@@ -63,7 +63,7 @@ module PrimMap = Num_tbl(Misc.Stdlib.String.Map)
 (* Global variables *)
 
 let global_table = ref GlobalMap.empty
-and literal_table = ref([] : (int * structured_constant) list)
+and literal_table = ref([] : (int * Obj.t) list)
 
 let is_global_defined id =
   Ident.Map.mem id (!global_table).tbl
@@ -146,6 +146,30 @@ let output_primitive_table outchan =
   done;
   fprintf outchan "  (char *) 0 };\n"
 
+(* Translate structured constants *)
+
+let rec transl_const = function
+    Const_base(Const_int i) -> Obj.repr i
+  | Const_base(Const_char c) -> Obj.repr c
+  | Const_base(Const_string (s, _, _)) -> Obj.repr s
+  | Const_base(Const_float f) -> Obj.repr (float_of_string f)
+  | 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_immstring s -> Obj.repr s
+  | Const_block(tag, fields) ->
+      let block = Obj.new_block tag (List.length fields) in
+      let transl_field pos cst =
+        Obj.set_field block pos (transl_const cst)
+      in
+      List.iteri transl_field fields;
+      block
+  | Const_float_array fields ->
+      let res = Array.Floatarray.create (List.length fields) in
+      List.iteri (fun i f -> Array.Floatarray.set res i (float_of_string f))
+        fields;
+      Obj.repr res
+
 (* Initialization for batch linking *)
 
 let init () =
@@ -162,7 +186,7 @@ let init () =
             Const_base(Const_int (-i-1))
            ])
       in
-      literal_table := (c, cst) :: !literal_table)
+      literal_table := (c, transl_const cst) :: !literal_table)
     Runtimedef.builtin_exceptions;
   (* Initialize the known C primitives *)
   let set_prim_table_from_file primfile =
@@ -219,36 +243,12 @@ let patch_object buff patchlist =
           patch_int buff pos (of_prim name))
     patchlist
 
-(* Translate structured constants *)
-
-let rec transl_const = function
-    Const_base(Const_int i) -> Obj.repr i
-  | Const_base(Const_char c) -> Obj.repr c
-  | Const_base(Const_string (s, _, _)) -> Obj.repr s
-  | Const_base(Const_float f) -> Obj.repr (float_of_string f)
-  | 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_immstring s -> Obj.repr s
-  | Const_block(tag, fields) ->
-      let block = Obj.new_block tag (List.length fields) in
-      let pos = ref 0 in
-      List.iter
-        (fun c -> Obj.set_field block !pos (transl_const c); incr pos)
-        fields;
-      block
-  | Const_float_array fields ->
-      let res = Array.Floatarray.create (List.length fields) in
-      List.iteri (fun i f -> Array.Floatarray.set res i (float_of_string f))
-        fields;
-      Obj.repr res
-
 (* Build the initial table of globals *)
 
 let initial_global_table () =
   let glob = Array.make !global_table.cnt (Obj.repr 0) in
   List.iter
-    (fun (slot, cst) -> glob.(slot) <- transl_const cst)
+    (fun (slot, cst) -> glob.(slot) <- cst)
     !literal_table;
   literal_table := [];
   glob
@@ -270,7 +270,7 @@ let update_global_table () =
   if ng > Array.length(Meta.global_data()) then Meta.realloc_global_data ng;
   let glob = Meta.global_data() in
   List.iter
-    (fun (slot, cst) -> glob.(slot) <- transl_const cst)
+    (fun (slot, cst) -> glob.(slot) <- cst)
     !literal_table;
   literal_table := []
 
diff --git a/file_formats/cmo_format.mli b/file_formats/cmo_format.mli
index 0952157b37..545e4ec264 100644
--- a/file_formats/cmo_format.mli
+++ b/file_formats/cmo_format.mli
@@ -20,7 +20,7 @@ open Misc
 (* Relocation information *)
 
 type reloc_info =
-    Reloc_literal of Lambda.structured_constant    (* structured constant *)
+    Reloc_literal of Obj.t                  (* structured constant *)
   | Reloc_getglobal of Ident.t              (* reference to a global *)
   | Reloc_setglobal of Ident.t              (* definition of a global *)
   | Reloc_primitive of string               (* C primitive number *)
diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml
index 621cac264f..f914b1ea60 100644
--- a/tools/dumpobj.ml
+++ b/tools/dumpobj.ml
@@ -15,10 +15,8 @@
 
 (* Disassembler for executable and .cmo object files *)
 
-open Asttypes
 open Config
 open Instruct
-open Lambda
 open Location
 open Opcodes
 open Opnames
@@ -76,38 +74,6 @@ let record_events orig evl =
       Hashtbl.add event_table ev.ev_pos ev)
     evl
 
-(* Print a structured constant *)
-
-let print_float f =
-  if String.contains f '.'
-  then printf "%s" f
-  else printf "%s." f
-
-let rec print_struct_const = function
-    Const_base(Const_int i) -> printf "%d" i
-  | Const_base(Const_float f) -> print_float f
-  | Const_base(Const_string (s, _, _)) -> printf "%S" s
-  | Const_immstring s -> printf "%S" s
-  | Const_base(Const_char c) -> printf "%C" c
-  | 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_block(tag, args) ->
-      printf "<%d>" tag;
-      begin match args with
-        [] -> ()
-      | [a1] ->
-          printf "("; print_struct_const a1; printf ")"
-      | a1::al ->
-          printf "("; print_struct_const a1;
-          List.iter (fun a -> printf ", "; print_struct_const a) al;
-          printf ")"
-      end
-  | Const_float_array a ->
-      printf "[|";
-      List.iter (fun f -> print_float f; printf "; ") a;
-      printf "|]"
-
 (* Print an obj *)
 
 let same_custom x y =
@@ -172,7 +138,7 @@ let print_getglobal_name ic =
     begin try
       match find_reloc ic with
           Reloc_getglobal id -> print_string (Ident.name id)
-        | Reloc_literal sc -> print_struct_const sc
+        | Reloc_literal sc -> print_obj sc
         | _ -> print_string "<wrong reloc>"
     with Not_found ->
       print_string "<no reloc>"
@@ -484,7 +450,7 @@ let print_code ic len =
 let print_reloc (info, pos) =
   printf "    %d    (%d)    " pos (pos/4);
   match info with
-    Reloc_literal sc -> print_struct_const sc; printf "\n"
+    Reloc_literal sc -> print_obj sc; printf "\n"
   | Reloc_getglobal id -> printf "require    %s\n" (Ident.name id)
   | Reloc_setglobal id -> printf "provide    %s\n" (Ident.name id)
   | Reloc_primitive s -> printf "prim    %s\n" s