fix(compiler): Stabilize CRC checks (#2101)

compiler/grainc/grainc.re

@@ -36,9 +36,6 @@ let compile_file = (name, outfile_arg) => {
  ~default=Compile.default_output_filename(name),
  outfile_arg,
  );
- if (Grain_utils.Config.debug^) {
- Compile.save_mashed(name, Compile.default_mashtree_filename(outfile));
- };
  let hook =
  if (Grain_utils.Config.statically_link^) {
  Compile.stop_after_assembled;

compiler/src/compile.re

@@ -49,6 +49,20 @@ let default_mashtree_filename = name =>
 let compile_prog = p =>
  Compcore.module_to_bytes @@ Compcore.compile_wasm_module(p);
 
+let save_mashed = (mashed, outfile) => {
+ switch (outfile) {
+ | Some(outfile) =>
+ let outfile = default_mashtree_filename(outfile);
+ Grain_utils.Fs_access.ensure_parent_directory_exists(outfile);
+ let mash_string =
+ Sexplib.Sexp.to_string_hum @@ Mashtree.sexp_of_mash_program(mashed);
+ let oc = open_out(outfile);
+ output_string(oc, mash_string);
+ close_out(oc);
+ | None => ()
+ };
+};
+
 let log_state = state =>
  if (Grain_utils.Config.verbose^) {
  let prerr_sexp = (conv, x) =>
@@ -135,9 +149,7 @@ let next_state = (~is_root_file=false, {cstate_desc, cstate_filename} as cs) =>
  ~no_pervasives=has_attr("noPervasives"),
  ~runtime_mode=has_attr("runtimeMode"),
  );
- if (is_root_file) {
- Grain_utils.Config.set_root_config();
- };
+
  Well_formedness.check_well_formedness(p);
  WellFormed(p);
  | WellFormed(p) =>
@@ -157,7 +169,11 @@ let next_state = (~is_root_file=false, {cstate_desc, cstate_filename} as cs) =>
  Linearized(Linearize.transl_anf_module(typed_mod))
  | Linearized(anfed) => Optimized(Optimize.optimize_program(anfed))
  | Optimized(optimized) =>
- Mashed(Transl_anf.transl_anf_program(optimized))
+ let mashed = Transl_anf.transl_anf_program(optimized);
+ if (Config.debug^) {
+ save_mashed(mashed, cs.cstate_outfile);
+ };
+ Mashed(mashed);
  | Mashed(mashed) =>
  Compiled(Compmod.compile_wasm_module(~name=?cstate_filename, mashed))
  | Compiled(compiled) =>
@@ -289,6 +305,9 @@ let compile_string =
  reset_compiler_state();
  compile_wasi_polyfill();
  };
+ if (is_root_file) {
+ Grain_utils.Config.set_root_config();
+ };
  let cstate = {
  cstate_desc: Initial(InputString(str)),
  cstate_filename: name,
@@ -305,6 +324,9 @@ let compile_file =
  reset_compiler_state();
  compile_wasi_polyfill();
  };
+ if (is_root_file) {
+ Grain_utils.Config.set_root_config();
+ };
  let cstate = {
  cstate_desc: Initial(InputFile(filename)),
  cstate_filename: Some(filename),
@@ -317,18 +339,6 @@ let compile_file =
 
 let anf = Linearize.transl_anf_module;
 
-let save_mashed = (f, outfile) =>
- switch (compile_file(~is_root_file=false, ~hook=stop_after_mashed, f)) {
- | {cstate_desc: Mashed(mashed)} =>
- Grain_utils.Fs_access.ensure_parent_directory_exists(outfile);
- let mash_string =
- Sexplib.Sexp.to_string_hum @@ Mashtree.sexp_of_mash_program(mashed);
- let oc = open_out(outfile);
- output_string(oc, mash_string);
- close_out(oc);
- | _ => failwith("Should be impossible")
- };
-
 let report_error = loc =>
  Location.(
  Printf.(

compiler/src/compile.rei

@@ -41,8 +41,6 @@ exception InlineFlagsError(Location.t, error);
 
 let default_output_filename: string => string;
 
-let default_mashtree_filename: string => string;
-
 let stop_after_parse: compilation_state => compilation_action;
 
 let stop_after_well_formed: compilation_state => compilation_action;
@@ -85,5 +83,3 @@ let compile_file:
  string
  ) =>
  compilation_state;
-
-let save_mashed: (string, string) => unit;

compiler/src/typed/cmi_format.re

@@ -46,12 +46,25 @@ let cmi_digest_of_yojson =
  "cmi_digest_of_yojson: Invalid Digest: " ++ Yojson.Safe.to_string(d),
  );
 
+let sexp_of_cmi_digest = d => Sexplib.Conv.sexp_of_string(Digest.to_hex(d));
+let cmi_digest_of_sexp =
+ fun
+ | Sexplib.Sexp.Atom(s) as d =>
+ try(Digest.from_hex(s)) {
+ | Invalid_argument(_) =>
+ of_sexp_error("cmi_digest_of_sexp: invalid digest", d)
+ }
+ | d => of_sexp_error("cmi_digest_of_sexp: invalid digest", d);
+
+[@deriving sexp]
+type cmi_crcs = list((string, cmi_digest));
+let rec cmi_crcs_of_yojson = [%of_yojson: list((string, cmi_digest))]
+and cmi_crcs_to_yojson = [%to_yojson: list((string, cmi_digest))];
+
 [@deriving sexp]
-type cmi_crcs = [@sexp.opaque] list((string, option(Digest.t)));
-let rec cmi_crcs_of_yojson = [%of_yojson:
- list((string, option(cmi_digest)))
-]
-and cmi_crcs_to_yojson = [%to_yojson: list((string, option(cmi_digest)))];
+type cmi_crc = cmi_digest;
+let rec cmi_crc_of_yojson = [%of_yojson: cmi_digest]
+and cmi_crc_to_yojson = [%to_yojson: cmi_digest];
 
 [@deriving (sexp, yojson)]
 type cmi_type_metadata = {
@@ -65,6 +78,7 @@ type cmi_infos = {
  cmi_name: string,
  cmi_sign: Types.signature,
  cmi_crcs,
+ cmi_crc,
  cmi_flags: list(pers_flags),
  cmi_type_metadata,
  cmi_config_sum: string,
@@ -75,25 +89,18 @@ type config_opt =
 
 let config_sum = Config.get_root_config_digest;
 
-let build_full_cmi = (~name, ~sign, ~crcs, ~flags, ~type_metadata) => {
- let ns_sign = Marshal.to_bytes((name, sign, config_sum()), []);
- let crc = Digest.bytes(ns_sign);
- let crcs = [(name, Some(crc)), ...crcs];
- let cmi_config_sum = config_sum();
- {
- cmi_name: name,
- cmi_sign: sign,
- cmi_crcs: crcs,
- cmi_flags: flags,
- cmi_type_metadata: type_metadata,
- cmi_config_sum,
- };
-};
+let build_crc = (~name: string, sign: Types.signature) => {
+ let subst_sign =
+ Subst.with_reset_state(() =>
+ Subst.signature(Subst.for_crc(Subst.identity), sign)
+ );
 
-let cmi_to_crc = ({cmi_name, cmi_sign, cmi_config_sum}) => {
- let ns_sign = Marshal.to_bytes((cmi_name, cmi_sign, cmi_config_sum), []);
- let crc = Digest.bytes(ns_sign);
- crc;
+ let ns_sign =
+ Marshal.to_bytes(
+ (name, subst_sign, Config.get_root_config_digest()),
+ [],
+ );
+ Digest.bytes(ns_sign);
 };
 
 let input_cmi = ic =>

compiler/src/typed/cmi_format.rei

@@ -28,23 +28,16 @@ type cmi_type_metadata = {
 type cmi_infos = {
  cmi_name: string,
  cmi_sign: list(Types.signature_item),
- cmi_crcs: list((string, option(Digest.t))),
+ cmi_crcs: list((string, Digest.t)),
+ cmi_crc: Digest.t,
  cmi_flags: list(pers_flags),
  cmi_type_metadata,
  cmi_config_sum: string,
 };
 
 let config_sum: unit => string;
 
-let build_full_cmi:
- (
- ~name: string,
- ~sign: list(Types.signature_item),
- ~crcs: list((string, option(Digest.t))),
- ~flags: list(pers_flags),
- ~type_metadata: cmi_type_metadata
- ) =>
- cmi_infos;
+let build_crc: (~name: string, Types.signature) => Digest.t;
 
 /* write the magic + the cmi information */
 let serialize_cmi: cmi_infos => bytes;
@@ -55,8 +48,6 @@ let input_cmi: in_channel => cmi_infos;
 /* read a cmi from a filename, checking the magic */
 let read_cmi: string => cmi_infos;
 
-let cmi_to_crc: cmi_infos => Digest.t;
-
 /* Error report */
 
 type error =