melange-re
diff --git a/‎dune‎
Lines changed: 13 additions & 14 deletions b/‎dune‎
Lines changed: 13 additions & 14 deletions
diff --git a/‎file_formats/cmt_format.ml‎
Lines changed: 33 additions & 10 deletions b/‎file_formats/cmt_format.ml‎
Lines changed: 33 additions & 10 deletions
diff --git a/‎file_formats/cmt_format.mli‎
Lines changed: 2 additions & 0 deletions b/‎file_formats/cmt_format.mli‎
Lines changed: 2 additions & 0 deletions
diff --git a/‎lambda/lambda.ml‎
Lines changed: 31 additions & 22 deletions b/‎lambda/lambda.ml‎
Lines changed: 31 additions & 22 deletions
diff --git a/‎lambda/lambda.mli‎
Lines changed: 20 additions & 15 deletions b/‎lambda/lambda.mli‎
Lines changed: 20 additions & 15 deletions
@@ -1,19 +1,18 @@
 (dirs wrapper lib parsing utils file_formats lambda typing)
+
 (include_subdirs unqualified)
 
 (library
-  (name melange_compiler_libs)
-  (public_name melange-compiler-libs)
-  (flags -w -9)
-  (libraries menhirLib melange_wrapper)
-  (modules :standard \ melange_wrapper)
-  (modules_without_implementation
-   annot
-   value_rec_types))
+ (name melange_compiler_libs)
+ (public_name melange-compiler-libs)
+ (flags -w -9)
+ (libraries menhirLib melange_wrapper)
+ (modules :standard \ melange_wrapper)
+ (modules_without_implementation annot value_rec_types))
 
- (library
-  (name melange_wrapper)
-  (public_name melange-compiler-libs.wrapper)
-  (libraries compiler-libs.common)
-  (modules melange_wrapper)
-  (modules_without_implementation melange_wrapper))
+(library
+ (name melange_wrapper)
+ (public_name melange-compiler-libs.wrapper)
+ (libraries compiler-libs.common)
+ (modules melange_wrapper)
+ (modules_without_implementation melange_wrapper))
@@ -153,21 +153,21 @@ let iter_on_occurrences
   let path_in_type typ name =
     match Types.get_desc typ with
     | Tconstr (type_path, _, _) ->
-      Some (Path.Pdot (type_path,  name))
+      Some (Path.Pextra_ty(type_path, Pcstr_ty name))
     | _ -> None
   in
   let add_constructor_description env lid =
     function
-    | { Types.cstr_tag = Cstr_extension {path; _}; _ } ->
+    | { Data_types.cstr_tag = Cstr_extension {path; _}; _ } ->
         f ~namespace:Extension_constructor env path lid
-    | { Types.cstr_uid = Predef name; _} ->
+    | { Data_types.cstr_uid = Predef name; _} ->
         let id = List.assoc name Predef.builtin_idents in
         f ~namespace:Constructor env (Pident id) lid
-    | { Types.cstr_res; cstr_name; _ } ->
+    | { Data_types.cstr_res; cstr_name; _ } ->
         let path = path_in_type cstr_res cstr_name in
         Option.iter (fun path -> f ~namespace:Constructor env path lid) path
   in
-  let add_label env lid { Types.lbl_name; lbl_res; _ } =
+  let add_label env lid { Data_types.lbl_name; lbl_res; _ } =
     let path = path_in_type lbl_res lbl_name in
     Option.iter (fun path -> f ~namespace:Label env path lid) path
   in
@@ -186,7 +186,8 @@ let iter_on_occurrences
       | Texp_construct (lid, constr_desc, _) ->
           add_constructor_description exp_env lid constr_desc
       | Texp_field (_, lid, label_desc)
-      | Texp_setfield (_, lid, label_desc, _) ->
+      | Texp_setfield (_, lid, label_desc, _)
+      | Texp_atomic_loc (_, lid, label_desc) ->
           add_label exp_env lid label_desc
       | Texp_new (path, lid, _) ->
           f ~namespace:Class exp_env path lid
@@ -235,8 +236,8 @@ let iter_on_occurrences
       (match ctyp_desc with
       | Ttyp_constr (path, lid, _ctyps) ->
           f ~namespace:Type ctyp_env path lid
-      | Ttyp_package {pack_path; pack_txt} ->
-          f ~namespace:Module_type ctyp_env pack_path pack_txt
+      | Ttyp_package {tpt_path; tpt_txt} ->
+          f ~namespace:Module_type ctyp_env tpt_path tpt_txt
       | Ttyp_class (path, lid, _typs) ->
           (* Deprecated syntax to extend a polymorphic variant *)
           f ~namespace:Type ctyp_env path lid
@@ -367,13 +368,31 @@ let index_occurrences binary_annots =
   in
   let f ~namespace env path lid =
     let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
-    if not_ghost lid then
+    let reduce_and_store ~namespace lid path = if not_ghost lid then
       match Env.shape_of_path ~namespace env path with
       | exception Not_found -> ()
       | { uid = Some (Predef _); _ } -> ()
       | path_shape ->
         let result = Shape_reduce.local_reduce_for_uid env path_shape in
         index := (lid, result) :: !index
+    in
+    (* Shape reduction can be expensive, but the persistent memoization tables
+       should make these successive reductions fast. *)
+    let rec index_components namespace lid path  =
+      let module_ = Shape.Sig_component_kind.Module in
+      let scraped_path = Path.scrape_extra_ty path in
+      match lid.Location.txt, scraped_path with
+      | Longident.Ldot (lid', _), Path.Pdot (path', _) ->
+        reduce_and_store ~namespace lid path;
+        index_components module_ lid' path'
+      | Longident.Lapply (lid', lid''), Path.Papply (path', path'') ->
+        index_components module_ lid'' path'';
+        index_components module_ lid' path'
+      | Longident.Lident _, _ ->
+        reduce_and_store ~namespace lid path;
+      | _, _ -> ()
+    in
+    index_components namespace lid path
   in
   iter_on_annots (iter_on_occurrences ~f) binary_annots;
   !index
@@ -460,12 +479,16 @@ let save_cmt target binary_annots initial_env cmi shape =
          let cmt_annots = clear_env binary_annots in
          let cmt_uid_to_decl = index_declarations cmt_annots in
          let source_digest = Option.map Digest.file sourcefile in
+         let cmt_args =
+           let cmt_args = Array.copy Sys.argv in
+           cmt_args.(0) <- Location.rewrite_absolute_path Sys.argv.(0);
+           cmt_args in
          let cmt = {
            cmt_modname = Unit_info.Artifact.modname target;
            cmt_annots;
            cmt_declaration_dependencies = !uids_deps;
            cmt_comments = Lexer.comments ();
-           cmt_args = Sys.argv;
+           cmt_args;
            cmt_sourcefile = sourcefile;
            cmt_builddir = Location.rewrite_absolute_path (Sys.getcwd ());
            cmt_loadpath = Load_path.get_paths ();
 
@@ -57,6 +57,8 @@ type cmt_infos = {
   cmt_declaration_dependencies : (dependency_kind * Uid.t * Uid.t) list;
   cmt_comments : (string * Location.t) list;
   cmt_args : string array;
+    (** {!Sys.argv} from the compiler invocation which created the file.
+        [Sys.argv.(0)] is rewritten using [BUILD_PATH_PREFIX_MAP]. *)
   cmt_sourcefile : string option;
   cmt_builddir : string;
   cmt_loadpath : Load_path.paths;
 
@@ -50,21 +50,20 @@ type tag_info =
       ; attributes: Parsetree.attributes
       }
   | Blk_record_ext of { fields: string array; exn: bool }
-  | Blk_lazy_general
   | Blk_class (* Ocaml style class*)
 
 let default_tag_info : tag_info = Blk_na ""
 let blk_record = ref (fun fields ->
-  let all_labels_info = fields |> Array.map (fun (x,_) -> x.Types.lbl_name) in
+  let all_labels_info = fields |> Array.map (fun (x,_) -> x.Data_types.lbl_name) in
   Blk_record all_labels_info
   )
 
 let blk_record_ext =  ref (fun ~is_exn fields ->
-    let all_labels_info = fields |> Array.map (fun (x,_) -> x.Types.lbl_name) in
+    let all_labels_info = fields |> Array.map (fun (x,_) -> x.Data_types.lbl_name) in
     Blk_record_ext { fields = all_labels_info; exn = is_exn })
 
 let blk_record_inlined = ref (fun fields name num_nonconst attributes ->
-  let fields = fields |> Array.map (fun (x,_) -> x.Types.lbl_name) in
+  let fields = fields |> Array.map (fun (x,_) -> x.Data_types.lbl_name) in
   Blk_record_inlined {fields; name; num_nonconst; attributes }
 )
 
@@ -84,13 +83,13 @@ type field_dbg_info =
   | Fld_cons
   | Fld_array
 
-let fld_record = ref (fun (lbl : Types.label_description) ->
+let fld_record = ref (fun (lbl : Data_types.label_description) ->
   Fld_record {name = lbl.lbl_name; mutable_flag = Mutable})
 
-let fld_record_inline = ref (fun (lbl : Types.label_description) ->
+let fld_record_inline = ref (fun (lbl : Data_types.label_description) ->
   Fld_record_inline {name = lbl.lbl_name})
 
-let fld_record_extension = ref (fun (lbl : Types.label_description) ->
+let fld_record_extension = ref (fun (lbl : Data_types.label_description) ->
   Fld_record_extension {name = lbl.lbl_name})
 
 let ref_field_info : field_dbg_info =
@@ -105,11 +104,11 @@ type set_field_dbg_info =
     | Fld_record_extension_set of string
 
 let ref_field_set_info : set_field_dbg_info = Fld_record_set "contents"
-let fld_record_set = ref ( fun (lbl : Types.label_description) ->
+let fld_record_set = ref ( fun (lbl : Data_types.label_description) ->
   Fld_record_set lbl.lbl_name  )
-let fld_record_inline_set = ref ( fun (lbl : Types.label_description) ->
+let fld_record_inline_set = ref ( fun (lbl : Data_types.label_description) ->
   Fld_record_inline_set lbl.lbl_name  )
-let fld_record_extension_set = ref ( fun (lbl : Types.label_description) ->
+let fld_record_extension_set = ref ( fun (lbl : Data_types.label_description) ->
   Fld_record_extension_set lbl.lbl_name  )
 
 type immediate_or_pointer =
@@ -125,6 +124,14 @@ type is_safe =
   | Safe
   | Unsafe
 
+type lazy_block_tag =
+  | Lazy_tag
+  | Forward_tag
+
+let tag_of_lazy_tag = function
+  | Lazy_tag -> Config.lazy_tag
+  | Forward_tag -> Obj.forward_tag
+
 type primitive =
   | Pbytes_to_string
   | Pbytes_of_string
@@ -134,6 +141,7 @@ type primitive =
   | Psetglobal of Ident.t
   (* Operations on heap blocks *)
   | Pmakeblock of int * tag_info * mutable_flag * block_shape
+  | Pmakelazyblock of lazy_block_tag
   | Pfield of int * immediate_or_pointer * mutable_flag * field_dbg_info
   | Pfield_computed
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment * set_field_dbg_info
@@ -229,10 +237,7 @@ type primitive =
   (* Integer to external pointer *)
   | Pint_as_pointer
   (* Atomic operations *)
-  | Patomic_load of {immediate_or_pointer : immediate_or_pointer}
-  | Patomic_exchange
-  | Patomic_cas
-  | Patomic_fetch_add
+  | Patomic_load
   (* Inhibition of optimisation *)
   | Popaque
   (* Fetching domain-local state *)
@@ -878,14 +883,18 @@ let transl_extension_path loc env path =
 let transl_class_path loc env path =
   transl_path Env.find_class_address loc env path
 
-let transl_prim mod_name name =
-  let pers = Ident.create_persistent mod_name in
-  let env = Env.add_persistent_structure pers Env.empty in
-  let lid = Longident.Ldot (Longident.Lident mod_name, name) in
-  match Env.find_value_by_name lid env with
-  | path, _ -> transl_value_path Loc_unknown env path
-  | exception Not_found ->
-      fatal_error ("Primitive " ^ name ^ " not found.")
+let transl_prim modname field =
+  let mod_ident = Ident.create_persistent modname in
+  let env = Env.add_persistent_structure mod_ident Env.initial in
+  match Env.open_pers_signature modname env with
+  | Error `Not_found ->
+      fatal_errorf "Module %s unavailable." modname
+  | Ok env -> (
+      match Env.find_value_by_name (Longident.Lident field) env with
+      | exception Not_found ->
+          fatal_errorf "Primitive %s.%s not found." modname field
+      | path, _ -> transl_value_path Loc_unknown env path
+    )
 
 (* Compile a sequence of expressions *)
 
 
@@ -61,25 +61,24 @@ type tag_info =
       ; attributes: Parsetree.attributes
       }
   | Blk_record_ext of { fields: string array; exn: bool }
-  | Blk_lazy_general
   | Blk_class (* ocaml style class *)
 
 val blk_record :
   (
-    (Types.label_description * Typedtree.record_label_definition) array ->
+    (Data_types.label_description * Typedtree.record_label_definition) array ->
     tag_info
   ) ref
 
 val blk_record_ext :
   (
     is_exn:bool ->
-    (Types.label_description * Typedtree.record_label_definition) array ->
+    (Data_types.label_description * Typedtree.record_label_definition) array ->
     tag_info
   ) ref
 
 val blk_record_inlined :
   (
-    (Types.label_description* Typedtree.record_label_definition) array ->
+    (Data_types.label_description* Typedtree.record_label_definition) array ->
     string ->
     int ->
     Parsetree.attributes ->
@@ -105,15 +104,15 @@ type field_dbg_info =
   | Fld_array
 
 val fld_record :
-  (Types.label_description ->
+  (Data_types.label_description ->
   field_dbg_info) ref
 
 val fld_record_inline :
-  (Types.label_description ->
+  (Data_types.label_description ->
   field_dbg_info) ref
 
 val fld_record_extension :
-  (Types.label_description ->
+  (Data_types.label_description ->
   field_dbg_info) ref
 
 val ref_field_info : field_dbg_info
@@ -129,20 +128,22 @@ type set_field_dbg_info =
 val ref_field_set_info : set_field_dbg_info
 
 val fld_record_set :
-  (Types.label_description ->
+  (Data_types.label_description ->
   set_field_dbg_info) ref
 
 val fld_record_inline_set :
-  (Types.label_description ->
+  (Data_types.label_description ->
   set_field_dbg_info) ref
 
 val fld_record_extension_set :
-  (Types.label_description ->
+  (Data_types.label_description ->
   set_field_dbg_info) ref
 
 type immediate_or_pointer =
   | Immediate
+  (* The value must be immediate. *)
   | Pointer
+  (* The value may be a pointer or an immediate. *)
 
 type initialization_or_assignment =
   | Assignment
@@ -175,6 +176,10 @@ type pointer_info =
   | Pt_assertfalse
   | Pt_na
 
+type lazy_block_tag =
+  | Lazy_tag
+  | Forward_tag
+
 type primitive =
   | Pbytes_to_string
   | Pbytes_of_string
@@ -184,6 +189,7 @@ type primitive =
   | Psetglobal of Ident.t
   (* Operations on heap blocks *)
   | Pmakeblock of int * tag_info * mutable_flag * block_shape
+  | Pmakelazyblock of lazy_block_tag
   | Pfield of int * immediate_or_pointer * mutable_flag * field_dbg_info
   | Pfield_computed
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment * set_field_dbg_info
@@ -283,10 +289,7 @@ type primitive =
   (* Integer to external pointer *)
   | Pint_as_pointer
   (* Atomic operations *)
-  | Patomic_load of {immediate_or_pointer : immediate_or_pointer}
-  | Patomic_exchange
-  | Patomic_cas
-  | Patomic_fetch_add
+  | Patomic_load
   (* Inhibition of optimisation *)
   | Popaque
   (* Fetching domain-local state *)
@@ -583,7 +586,7 @@ val transl_prim: string -> string -> lambda
 (** Translate a value from a persistent module. For instance:
 
     {[
-      transl_internal_value "CamlinternalLazy" "force"
+      transl_prim "CamlinternalLazy" "force"
     ]}
 *)
 
@@ -657,6 +660,8 @@ val max_arity : unit -> int
       This is unlimited ([max_int]) for bytecode, but limited
       (currently to 126) for native code. *)
 
+val tag_of_lazy_tag : lazy_block_tag -> int
+
 (***********************)
 (* For static failures *)
 (***********************)