From de80f0150ba24a3b8079c1602d4cd758c57ad709 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Tue, 30 Jan 2018 16:30:22 +0100 Subject: [PATCH] Compiler: allow bytecode compilation --- Makefile | 6 +- src/bin_node/main.ml | 3 +- src/lib_protocol_compiler/byte.ml | 46 ++++ src/lib_protocol_compiler/byte.mli | 10 + src/lib_protocol_compiler/compiler.ml | 235 ++++++++++++++++++ src/lib_protocol_compiler/embedded_cmis.mli | 2 +- src/lib_protocol_compiler/jbuild | 60 ++++- .../jbuild_protocol_template | 30 ++- src/lib_protocol_compiler/main_byte.ml | 17 ++ .../{main.ml => main_native.ml} | 3 +- src/lib_protocol_compiler/native.ml | 225 +---------------- src/lib_protocol_compiler/native.mli | 4 +- src/lib_protocol_updater/jbuild | 4 +- .../tezos-protocol-updater.opam | 3 +- src/lib_protocol_updater/updater.ml | 4 +- src/lib_shell/state.ml | 4 +- 16 files changed, 409 insertions(+), 247 deletions(-) create mode 100644 src/lib_protocol_compiler/byte.ml create mode 100644 src/lib_protocol_compiler/byte.mli create mode 100644 src/lib_protocol_compiler/compiler.ml create mode 100644 src/lib_protocol_compiler/main_byte.ml rename src/lib_protocol_compiler/{main.ml => main_native.ml} (88%) diff --git a/Makefile b/Makefile index e85f95ae0..5bb6467b7 100644 --- a/Makefile +++ b/Makefile @@ -6,13 +6,13 @@ all: src/bin_node/main.exe \ src/bin_client/main.exe \ src/bin_client/admin_main.exe \ - src/lib_protocol_compiler/main.exe + src/lib_protocol_compiler/main_native.exe @cp _build/default/src/bin_node/main.exe tezos-node @cp _build/default/src/bin_client/main.exe tezos-client @cp _build/default/src/bin_client/admin_main.exe tezos-admin-client - @cp _build/default/src/lib_protocol_compiler/main.exe tezos-protocol-compiler + @cp _build/default/src/lib_protocol_compiler/main_native.exe tezos-protocol-compiler -%.pkg: +tezos-%.pkg: @jbuilder build --dev $(patsubst %.opam,%.install, \ $(shell find -name tezos-$*.opam)) diff --git a/src/bin_node/main.ml b/src/bin_node/main.ml index 23deed85c..62fa73a72 100644 --- a/src/bin_node/main.ml +++ b/src/bin_node/main.ml @@ -10,7 +10,8 @@ let () = if Filename.basename Sys.argv.(0) = Updater.compiler_name then begin try - Tezos_protocol_compiler.Native.main (); + Tezos_protocol_compiler.Compiler.main + Tezos_protocol_compiler_native.Native.driver ; Pervasives.exit 0 with exn -> Format.eprintf "%a\n%!" Opterrors.report_error exn; diff --git a/src/lib_protocol_compiler/byte.ml b/src/lib_protocol_compiler/byte.ml new file mode 100644 index 000000000..a8c5ab519 --- /dev/null +++ b/src/lib_protocol_compiler/byte.ml @@ -0,0 +1,46 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +(** The OCaml compiler not being implemented with Lwt, the compilation + take place in a separated process (by using [Lwt_process.exec]). + + The [main] function is the entry point for the forked process. + While [Updater.compile] is the 'forking' function to be called by + the [tezos-node] process. + +*) + +(** Semi-generic compilation functions *) + +let pack_objects output objects = + let output = output ^ ".cmo" in + Compmisc.init_path true; + Bytepackager.package_files + Format.err_formatter Env.initial_safe_string objects output ; + Warnings.check_fatal () ; + output + +let link_shared output objects = + Compenv.(readenv Format.err_formatter Before_link) ; + Compmisc.init_path true; + Bytelink.link Format.err_formatter objects output ; + Warnings.check_fatal () + +let compile_ml ?for_pack ml = + let target = Filename.chop_extension ml in + Clflags.for_package := for_pack ; + Compenv.(readenv Format.err_formatter (Before_compile ml)); + Compile.implementation Format.err_formatter ml target ; + Clflags.for_package := None ; + target ^ ".cmo" + +let () = + Clflags.native_code := false + +let driver = Compiler.{ compile_ml ; link_shared ; pack_objects } diff --git a/src/lib_protocol_compiler/byte.mli b/src/lib_protocol_compiler/byte.mli new file mode 100644 index 000000000..c6520b41c --- /dev/null +++ b/src/lib_protocol_compiler/byte.mli @@ -0,0 +1,10 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +val driver: Compiler.driver diff --git a/src/lib_protocol_compiler/compiler.ml b/src/lib_protocol_compiler/compiler.ml new file mode 100644 index 000000000..508d23f80 --- /dev/null +++ b/src/lib_protocol_compiler/compiler.ml @@ -0,0 +1,235 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let warnings = "+a-4-6-7-9-29-40..42-44-45-48" +let warn_error = "-a+8" + +let () = + Clflags.unsafe_string := false + +(** Override the default 'Env.Persistent_signature.load' + with a lookup in locally defined hashtable. +*) + +let preloaded_cmis : (string, Env.Persistent_signature.t) Hashtbl.t = + Hashtbl.create ~random:true 42 + +(* Set hook *) +let () = + Env.Persistent_signature.load := + (fun ~unit_name -> + try Some (Hashtbl.find preloaded_cmis (String.capitalize_ascii unit_name)) + with Not_found -> None) + +let load_cmi_from_file file = + Hashtbl.add preloaded_cmis + (String.capitalize_ascii Filename.(basename (chop_extension file))) + { filename = file ; + cmi = Cmi_format.read_cmi file ; + } + +let load_embeded_cmi (unit_name, content) = + let content = Bytes.of_string content in + (* Read cmi magic *) + let magic_len = String.length Config.cmi_magic_number in + let magic = Bytes.sub content 0 magic_len in + assert (magic = Bytes.of_string Config.cmi_magic_number) ; + (* Read cmi_name and cmi_sign *) + let pos = magic_len in + let (cmi_name, cmi_sign) = Marshal.from_bytes content pos in + let pos = pos + Marshal.total_size content pos in + (* Read cmi_crcs *) + let cmi_crcs = Marshal.from_bytes content pos in + let pos = pos + Marshal.total_size content pos in + (* Read cmi_flags *) + let cmi_flags = Marshal.from_bytes content pos in + (* TODO check crcrs... *) + Hashtbl.add + preloaded_cmis + (String.capitalize_ascii unit_name) + { filename = unit_name ^ ".cmi" ; + cmi = { cmi_name; cmi_sign; cmi_crcs; cmi_flags } ; + } + +let load_embeded_cmis cmis = List.iter load_embeded_cmi cmis + +(** Compilation environment. + + [tezos_protocol_env] defines the list of [cmi] available while compiling + the protocol version. The [cmi] are packed into the [tezos-node] + binary by using [ocp-ocamlres], see the Makefile. + + [register_env] defines a complementary list of [cmi] available + while compiling the generated [register.ml] file (that register + the protocol first-class module into the [Updater.versions] + hashtable). + +*) + + +let tezos_protocol_env = + let open Embedded_cmis in + [ + "CamlinternalFormatBasics", camlinternalFormatBasics_cmi ; + "Tezos_protocol_environment_sigs", tezos_protocol_environment_sigs_cmi ; + "Tezos_protocol_environment_sigs__V1", tezos_protocol_environment_sigs__V1_cmi ; + ] + +let register_env = + let open Embedded_cmis in + [ + "tezos_protocol_registerer__Registerer", tezos_protocol_registerer__Registerer_cmi ; + ] + + +(** Helpers *) + +let (//) = Filename.concat + +let create_file ?(perm = 0o644) name content = + let open Unix in + let fd = openfile name [O_TRUNC; O_CREAT; O_WRONLY] perm in + ignore(write_substring fd content 0 (String.length content)); + close fd + +let safe_unlink file = + try Unix.unlink file + with Unix.Unix_error(Unix.ENOENT, _, _) -> () + +let unlink_cmi dir (file, _) = + safe_unlink (dir // file ^ ".cmi") + +let unlink_object obj = + safe_unlink obj; + safe_unlink (Filename.chop_suffix obj ".cmx" ^ ".cmi"); + safe_unlink (Filename.chop_suffix obj ".cmx" ^ ".o") + +let debug_flag = ref false + +let debug fmt = + if !debug_flag then Format.eprintf fmt + else Format.ifprintf Format.err_formatter fmt + +let hash_file file = + let open Sodium.Generichash in + let buflen = 8092 in + let buf = BytesLabels.create buflen in + let fd = Unix.openfile file [Unix.O_RDONLY] 0o600 in + let state = init ~size:32 () in + let loop () = + match Unix.read fd buf 0 buflen with + | 0 -> () + | nb_read -> + Bytes.update state @@ + if nb_read = buflen then buf else BytesLabels.sub buf ~pos:0 ~len:nb_read + in + loop () ; + Unix.close fd ; + BytesLabels.unsafe_to_string (Bytes.of_hash (final state)) + +let mktemp_dir () = + Filename.get_temp_dir_name () // + Printf.sprintf "tezos-protocol-build-%06X" (Random.int 0xFFFFFF) + +(** Main *) + +type driver = { + compile_ml: ?for_pack:string -> string -> string ; + pack_objects: string -> string list -> string ; + link_shared: string -> string list -> unit ; +} + +let main { compile_ml ; pack_objects ; link_shared } = + Random.self_init () ; + let anonymous = ref [] + and static = ref false + and register = ref false + and build_dir = ref None in + let args_spec = [ + "-static", Arg.Set static, " Only build the static library (no .cmxs)"; + "-register", Arg.Set register, " Generete the `Registerer` module"; + "-bin-annot", Arg.Set Clflags.binary_annotations, " (see ocamlopt)" ; + "-g", Arg.Set Clflags.debug, " (see ocamlopt)" ; + "-build-dir", Arg.String (fun s -> build_dir := Some s), + "use custom build directory and preserve build artifacts" + ] in + let usage_msg = + Printf.sprintf + "Usage: %s [options] \nOptions are:" + Sys.argv.(0) in + Arg.parse args_spec (fun s -> anonymous := s :: !anonymous) usage_msg ; + let (output, source_dir) = + match List.rev !anonymous with + | [ output ; protocol_dir ] -> output, protocol_dir + | _ -> Arg.usage args_spec usage_msg ; Pervasives.exit 1 in + let build_dir = + match !build_dir with + | None -> + let dir = mktemp_dir () in + at_exit (fun () -> Lwt_main.run (Lwt_utils.remove_dir dir)) ; + dir + | Some dir -> dir in + Lwt_main.run (Lwt_utils.create_dir ~perm:0o755 build_dir) ; + Lwt_main.run (Lwt_utils.create_dir ~perm:0o755 (Filename.dirname output)) ; + let hash, protocol = Protocol.read_dir source_dir in + (* Generate the 'functor' *) + let functor_file = build_dir // "functor.ml" in + let oc = open_out functor_file in + Packer.dump oc + (Array.map + begin fun { Protocol.name } -> + let name_lowercase = String.uncapitalize_ascii name in + source_dir // name_lowercase ^ ".ml" + end + (Array.of_list protocol.components)) ; + close_out oc ; + (* Compile the protocol *) + let proto_cmi = Filename.chop_extension functor_file ^ ".cmi" in + let functor_unit = + String.capitalize_ascii + Filename.(basename (chop_extension functor_file)) in + let for_pack = String.capitalize_ascii (Filename.basename output) in + (* Initialize the compilers *) + Compenv.(readenv Format.err_formatter Before_args); + Clflags.nopervasives := true; + Clflags.no_std_include := true ; + Clflags.include_dirs := [Filename.dirname functor_file] ; + Warnings.parse_options false warnings ; + Warnings.parse_options true warn_error ; + + load_embeded_cmis tezos_protocol_env ; + let packed_protocol_object = compile_ml ~for_pack functor_file in + + let register_objects = + if not !register then + [] + else begin + load_embeded_cmis register_env ; + load_cmi_from_file proto_cmi ; + (* Compiler the 'registering module' *) + let register_file = Filename.dirname functor_file // "register.ml" in + create_file register_file + (Printf.sprintf + "module Name = struct let name = %S end\n\ + \ let () = Tezos_protocol_compiler_native__Registerer.register Name.name (module %s.Make)" + (Protocol_hash.to_b58check hash) + functor_unit) ; + let register_object = compile_ml ~for_pack register_file in + [ register_object ] + end + in + + let resulting_object = + pack_objects output (packed_protocol_object :: register_objects) in + + (* Create the final [cmxs] *) + if not !static then begin + Clflags.link_everything := true ; + link_shared (output ^ ".cmxs") [resulting_object] ; + end diff --git a/src/lib_protocol_compiler/embedded_cmis.mli b/src/lib_protocol_compiler/embedded_cmis.mli index eaa2f8f2d..70c28cf6c 100644 --- a/src/lib_protocol_compiler/embedded_cmis.mli +++ b/src/lib_protocol_compiler/embedded_cmis.mli @@ -10,4 +10,4 @@ val camlinternalFormatBasics_cmi: string val tezos_protocol_environment_sigs_cmi: string val tezos_protocol_environment_sigs__V1_cmi: string -val tezos_protocol_compiler__Registerer_cmi: string +val tezos_protocol_registerer__Registerer_cmi: string diff --git a/src/lib_protocol_compiler/jbuild b/src/lib_protocol_compiler/jbuild index 90628dd36..2eb4dbbc4 100644 --- a/src/lib_protocol_compiler/jbuild +++ b/src/lib_protocol_compiler/jbuild @@ -5,34 +5,75 @@ (action (run ${bin:ocp-ocamlres} -format ocaml -o ${@} ${lib:stdlib:camlinternalFormatBasics.cmi} - ${path:tezos_protocol_compiler__Registerer.cmi} + ${path:tezos_protocol_registerer__Registerer.cmi} ${lib:tezos-protocol-environment-sigs:tezos_protocol_environment_sigs.cmi} ${lib:tezos-protocol-environment-sigs:tezos_protocol_environment_sigs__V1.cmi})))) +(library + ((name tezos_protocol_registerer) + (public_name tezos-protocol-compiler.registerer) + (libraries (tezos-base + tezos-protocol-environment-sigs)) + (flags (:standard -w -9+27-30-32-40@8 + -safe-string + -opaque + -open Tezos_base__TzPervasives)) + (modules (Registerer)))) + (library ((name tezos_protocol_compiler) (public_name tezos-protocol-compiler) (libraries (tezos-base tezos-protocol-environment-sigs compiler-libs - compiler-libs.optcomp lwt.unix ocplib-endian ocplib-ocamlres unix)) (flags (:standard -w -9+27-30-32-40@8 -safe-string - -opaque -open Tezos_base__TzPervasives)) - (modules (:standard \ Main Main_embedded_packer)))) + (modules (Embedded_cmis Packer Compiler)))) + +(library + ((name tezos_protocol_compiler_byte) + (public_name tezos-protocol-compiler.byte) + (libraries (tezos-base + tezos-protocol-compiler + compiler-libs.bytecomp)) + (flags (:standard -w -9+27-30-32-40@8 + -safe-string + -open Tezos_base__TzPervasives + -open Tezos_protocol_compiler)) + (modules (Byte)))) + +(library + ((name tezos_protocol_compiler_native) + (public_name tezos-protocol-compiler.native) + (libraries (tezos-base + tezos-protocol-compiler + compiler-libs.optcomp)) + (flags (:standard -w -9+27-30-32-40@8 + -safe-string + -open Tezos_base__TzPervasives + -open Tezos_protocol_compiler)) + (modules (Native)))) (executable - ((name main) + ((name main_byte) + (public_name tezos-protocol-compiler-byte) + (modes (native)) + (libraries (tezos_protocol_compiler_byte)) + (flags (:standard -linkall)) + (modules (Main_byte)))) + +(executable + ((name main_native) (public_name tezos-protocol-compiler) (modes (native)) - (libraries (tezos_protocol_compiler)) + (libraries (tezos_protocol_compiler_native)) (flags (:standard -linkall)) - (modules (Main)))) + (modules (Main_native)))) (executable ((name main_embedded_packer) @@ -55,9 +96,12 @@ (deps ("embedded_cmis.mli" "main_embedded_packer.ml" "main_embedded_packer.mli" - "main.ml" + "main_byte.ml" + "main_native.ml" "native.ml" "native.mli" + "byte.ml" + "byte.mli" "packer.ml" "packer.mli" "registerer.ml" diff --git a/src/lib_protocol_compiler/jbuild_protocol_template b/src/lib_protocol_compiler/jbuild_protocol_template index be5dbff3e..c287a4ae9 100644 --- a/src/lib_protocol_compiler/jbuild_protocol_template +++ b/src/lib_protocol_compiler/jbuild_protocol_template @@ -55,6 +55,16 @@ let () = Format.kasprintf Jbuild_plugin.V1.send {| (jbuild_version 1) +(rule + ((targets (tezos_protocol_%s.cmo + tezos_protocol_%s_dummy_byte.ml)) + (deps ((glob_files src/*.ml) + (glob_files src/*.mli) + src/TEZOS_PROTOCOL)) + (action (with-stdout-to ${path-no-dep:tezos_protocol_%s_dummy_byte.ml} + (chdir ${ROOT} + (run ${bin:tezos-protocol-compiler-byte} -static ${path-no-dep:tezos_protocol_%s} ${path-no-dep:src})))))) + (rule ((targets (tezos_protocol_%s.o tezos_protocol_%s.cmx @@ -76,6 +86,15 @@ let () = Format.kasprintf Jbuild_plugin.V1.send {| (modes (native)) (modules (Tezos_protocol_%s_dummy)))) +(library + ((name tezos_protocol_%s_byte) + (public_name tezos-protocol-%s.byte) + (library_flags (:standard -linkall %s/tezos_protocol_%s.cmo)) + (flags (:standard -safe-string)) + (wrapped false) + (modes (byte)) + (modules (Tezos_protocol_%s_dummy_byte)))) + (install ((section lib) (files ("tezos_protocol_%s.cmx" "tezos_protocol_%s.cmi")) @@ -91,8 +110,13 @@ let () = Format.kasprintf Jbuild_plugin.V1.send {| (action (run bash ${libexec:tezos-stdlib:test-ocp-indent.sh} ${^})))) |} - version version version version version version version version - path - version version version version version version + version version version version + version version version version + version version version version + path version + version version version + path version + version version version + version version Format.(pp_print_list (fun ppf -> Format.fprintf ppf "%S")) sources diff --git a/src/lib_protocol_compiler/main_byte.ml b/src/lib_protocol_compiler/main_byte.ml new file mode 100644 index 000000000..37159f69b --- /dev/null +++ b/src/lib_protocol_compiler/main_byte.ml @@ -0,0 +1,17 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +let () = + try + Tezos_protocol_compiler.Compiler.main + Tezos_protocol_compiler_byte.Byte.driver ; + Pervasives.exit 0 + with exn -> + Format.eprintf "%a\n%!" Errors.report_error exn; + Pervasives.exit 1 diff --git a/src/lib_protocol_compiler/main.ml b/src/lib_protocol_compiler/main_native.ml similarity index 88% rename from src/lib_protocol_compiler/main.ml rename to src/lib_protocol_compiler/main_native.ml index 058de0aa5..2cd70088d 100644 --- a/src/lib_protocol_compiler/main.ml +++ b/src/lib_protocol_compiler/main_native.ml @@ -9,7 +9,8 @@ let () = try - Tezos_protocol_compiler.Native.main (); + Tezos_protocol_compiler.Compiler.main + Tezos_protocol_compiler_native.Native.driver ; Pervasives.exit 0 with exn -> Format.eprintf "%a\n%!" Opterrors.report_error exn; diff --git a/src/lib_protocol_compiler/native.ml b/src/lib_protocol_compiler/native.ml index 1ec917e9c..9e6216ee4 100644 --- a/src/lib_protocol_compiler/native.ml +++ b/src/lib_protocol_compiler/native.ml @@ -16,6 +16,8 @@ *) +open Compiler + (* TODO: fail in the presence of "external" *) module Backend = struct @@ -37,133 +39,6 @@ end let backend = (module Backend : Backend_intf.S) -let warnings = "+a-4-6-7-9-29-40..42-44-45-48" -let warn_error = "-a+8" - -let () = - Clflags.unsafe_string := false ; - Clflags.native_code := true - -(** Override the default 'Env.Persistent_signature.load' - with a lookup in locally defined hashtable. -*) - -let preloaded_cmis : (string, Env.Persistent_signature.t) Hashtbl.t = - Hashtbl.create ~random:true 42 - -(* Set hook *) -let () = - Env.Persistent_signature.load := - (fun ~unit_name -> - try Some (Hashtbl.find preloaded_cmis (String.capitalize_ascii unit_name)) - with Not_found -> None) - -let load_cmi_from_file file = - Hashtbl.add preloaded_cmis - (String.capitalize_ascii Filename.(basename (chop_extension file))) - { filename = file ; - cmi = Cmi_format.read_cmi file ; - } - -let load_embeded_cmi (unit_name, content) = - let content = Bytes.of_string content in - (* Read cmi magic *) - let magic_len = String.length Config.cmi_magic_number in - let magic = Bytes.sub content 0 magic_len in - assert (magic = Bytes.of_string Config.cmi_magic_number) ; - (* Read cmi_name and cmi_sign *) - let pos = magic_len in - let (cmi_name, cmi_sign) = Marshal.from_bytes content pos in - let pos = pos + Marshal.total_size content pos in - (* Read cmi_crcs *) - let cmi_crcs = Marshal.from_bytes content pos in - let pos = pos + Marshal.total_size content pos in - (* Read cmi_flags *) - let cmi_flags = Marshal.from_bytes content pos in - (* TODO check crcrs... *) - Hashtbl.add - preloaded_cmis - (String.capitalize_ascii unit_name) - { filename = unit_name ^ ".cmi" ; - cmi = { cmi_name; cmi_sign; cmi_crcs; cmi_flags } ; - } - -let load_embeded_cmis cmis = List.iter load_embeded_cmi cmis - -(** Compilation environment. - - [tezos_protocol_env] defines the list of [cmi] available while compiling - the protocol version. The [cmi] are packed into the [tezos-node] - binary by using [ocp-ocamlres], see the Makefile. - - [register_env] defines a complementary list of [cmi] available - while compiling the generated [register.ml] file (that register - the protocol first-class module into the [Updater.versions] - hashtable). - -*) - - -let tezos_protocol_env = - let open Embedded_cmis in - [ - "CamlinternalFormatBasics", camlinternalFormatBasics_cmi ; - "Tezos_protocol_environment_sigs", tezos_protocol_environment_sigs_cmi ; - "Tezos_protocol_environment_sigs__V1", tezos_protocol_environment_sigs__V1_cmi ; - ] - -let register_env = - let open Embedded_cmis in - [ - "tezos_protocol_compiler__Registerer", tezos_protocol_compiler__Registerer_cmi ; - ] - - -(** Helpers *) - -let (//) = Filename.concat - -let create_file ?(perm = 0o644) name content = - let open Unix in - let fd = openfile name [O_TRUNC; O_CREAT; O_WRONLY] perm in - ignore(write_substring fd content 0 (String.length content)); - close fd - -let safe_unlink file = - try Unix.unlink file - with Unix.Unix_error(Unix.ENOENT, _, _) -> () - -let unlink_cmi dir (file, _) = - safe_unlink (dir // file ^ ".cmi") - -let unlink_object obj = - safe_unlink obj; - safe_unlink (Filename.chop_suffix obj ".cmx" ^ ".cmi"); - safe_unlink (Filename.chop_suffix obj ".cmx" ^ ".o") - -let debug_flag = ref false - -let debug fmt = - if !debug_flag then Format.eprintf fmt - else Format.ifprintf Format.err_formatter fmt - -let hash_file file = - let open Sodium.Generichash in - let buflen = 8092 in - let buf = BytesLabels.create buflen in - let fd = Unix.openfile file [Unix.O_RDONLY] 0o600 in - let state = init ~size:32 () in - let loop () = - match Unix.read fd buf 0 buflen with - | 0 -> () - | nb_read -> - Bytes.update state @@ - if nb_read = buflen then buf else BytesLabels.sub buf ~pos:0 ~len:nb_read - in - loop () ; - Unix.close fd ; - BytesLabels.unsafe_to_string (Bytes.of_hash (final state)) - (** Semi-generic compilation functions *) let pack_objects output objects = @@ -188,97 +63,7 @@ let compile_ml ?for_pack ml = Clflags.for_package := None ; target ^ ".cmx" -(** Main *) +let () = + Clflags.native_code := true -let mktemp_dir () = - Filename.get_temp_dir_name () // - Printf.sprintf "tezos-protocol-build-%06X" (Random.int 0xFFFFFF) - -let main () = - Random.self_init () ; - let anonymous = ref [] - and static = ref false - and register = ref false - and build_dir = ref None in - let args_spec = [ - "-static", Arg.Set static, " Only build the static library (no .cmxs)"; - "-register", Arg.Set register, " Generete the `Registerer` module"; - "-bin-annot", Arg.Set Clflags.binary_annotations, " (see ocamlopt)" ; - "-g", Arg.Set Clflags.debug, " (see ocamlopt)" ; - "-build-dir", Arg.String (fun s -> build_dir := Some s), - "use custom build directory and preserve build artifacts" - ] in - let usage_msg = - Printf.sprintf - "Usage: %s [options] \nOptions are:" - Sys.argv.(0) in - Arg.parse args_spec (fun s -> anonymous := s :: !anonymous) usage_msg ; - let (output, source_dir) = - match List.rev !anonymous with - | [ output ; protocol_dir ] -> output, protocol_dir - | _ -> Arg.usage args_spec usage_msg ; Pervasives.exit 1 in - let build_dir = - match !build_dir with - | None -> - let dir = mktemp_dir () in - at_exit (fun () -> Lwt_main.run (Lwt_utils.remove_dir dir)) ; - dir - | Some dir -> dir in - Lwt_main.run (Lwt_utils.create_dir ~perm:0o755 build_dir) ; - Lwt_main.run (Lwt_utils.create_dir ~perm:0o755 (Filename.dirname output)) ; - let hash, protocol = Protocol.read_dir source_dir in - (* Generate the 'functor' *) - let functor_file = build_dir // "functor.ml" in - let oc = open_out functor_file in - Packer.dump oc - (Array.map - begin fun { Protocol.name } -> - let name_lowercase = String.uncapitalize_ascii name in - source_dir // name_lowercase ^ ".ml" - end - (Array.of_list protocol.components)) ; - close_out oc ; - (* Compile the protocol *) - let proto_cmi = Filename.chop_extension functor_file ^ ".cmi" in - let functor_unit = - String.capitalize_ascii - Filename.(basename (chop_extension functor_file)) in - let for_pack = String.capitalize_ascii (Filename.basename output) in - (* Initialize the compilers *) - Compenv.(readenv Format.err_formatter Before_args); - Clflags.nopervasives := true; - Clflags.no_std_include := true ; - Clflags.include_dirs := [Filename.dirname functor_file] ; - Warnings.parse_options false warnings ; - Warnings.parse_options true warn_error ; - - load_embeded_cmis tezos_protocol_env ; - let packed_protocol_object = compile_ml ~for_pack functor_file in - - let register_objects = - if not !register then - [] - else begin - load_embeded_cmis register_env ; - load_cmi_from_file proto_cmi ; - (* Compiler the 'registering module' *) - let register_file = Filename.dirname functor_file // "register.ml" in - create_file register_file - (Printf.sprintf - "module Name = struct let name = %S end\n\ - \ let () = Tezos_protocol_compiler__Registerer.register Name.name (module %s.Make)" - (Protocol_hash.to_b58check hash) - functor_unit) ; - let register_object = compile_ml ~for_pack register_file in - [ register_object ] - end - in - - let resulting_object = - pack_objects output (packed_protocol_object :: register_objects) in - - (* Create the final [cmxs] *) - if not !static then begin - Clflags.link_everything := true ; - link_shared (output ^ ".cmxs") [resulting_object] ; - end +let driver = { compile_ml ; link_shared ; pack_objects } diff --git a/src/lib_protocol_compiler/native.mli b/src/lib_protocol_compiler/native.mli index c25825a07..c6520b41c 100644 --- a/src/lib_protocol_compiler/native.mli +++ b/src/lib_protocol_compiler/native.mli @@ -7,6 +7,4 @@ (* *) (**************************************************************************) -(** Low-level part of the [Updater]. *) - -val main: unit -> unit +val driver: Compiler.driver diff --git a/src/lib_protocol_updater/jbuild b/src/lib_protocol_updater/jbuild index 785dc51a9..30ad55660 100644 --- a/src/lib_protocol_updater/jbuild +++ b/src/lib_protocol_updater/jbuild @@ -5,14 +5,14 @@ (public_name tezos-protocol-updater) (libraries (tezos-base tezos-micheline - tezos-protocol-compiler + tezos-protocol-compiler.registerer + tezos-protocol-compiler.native tezos-storage dynlink)) (flags (:standard -w -9+27-30-32-40@8 -safe-string -open Tezos_base__TzPervasives -open Tezos_micheline - -open Tezos_protocol_compiler -open Tezos_storage)))) (alias diff --git a/src/lib_protocol_updater/tezos-protocol-updater.opam b/src/lib_protocol_updater/tezos-protocol-updater.opam index 9a4a54471..9aadcd7e4 100644 --- a/src/lib_protocol_updater/tezos-protocol-updater.opam +++ b/src/lib_protocol_updater/tezos-protocol-updater.opam @@ -11,7 +11,8 @@ depends: [ "jbuilder" { build & >= "1.0+beta15" } "tezos-base" "tezos-micheline" - "tezos-protocol-compiler" + "tezos-protocol-compiler.registerer" + "tezos-protocol-compiler-native" "tezos-storage" ] build: [ diff --git a/src/lib_protocol_updater/updater.ml b/src/lib_protocol_updater/updater.ml index c1b8a1f40..aa3fb9ff3 100644 --- a/src/lib_protocol_updater/updater.ml +++ b/src/lib_protocol_updater/updater.ml @@ -78,11 +78,11 @@ let do_compile hash p = Lwt.return false let compile hash p = - if Tezos_protocol_compiler.Registerer.mem hash then + if Tezos_protocol_registerer.Registerer.mem hash then Lwt.return true else begin do_compile hash p >>= fun success -> - let loaded = Tezos_protocol_compiler.Registerer.mem hash in + let loaded = Tezos_protocol_registerer.Registerer.mem hash in if success && not loaded then log_error "Internal error while compiling %a" Protocol_hash.pp hash; Lwt.return loaded diff --git a/src/lib_shell/state.ml b/src/lib_shell/state.ml index 00ab5ceb5..2f7ca6506 100644 --- a/src/lib_shell/state.ml +++ b/src/lib_shell/state.ml @@ -706,7 +706,7 @@ module Registred_protocol = struct type t = (module T) let build_v1 hash = - let (module F) = Tezos_protocol_compiler.Registerer.get_exn hash in + let (module F) = Tezos_protocol_registerer.Registerer.get_exn hash in let module Name = struct let name = Protocol_hash.to_b58check hash end in @@ -726,7 +726,7 @@ module Registred_protocol = struct let mem hash = VersionTable.mem versions hash || - Tezos_protocol_compiler.Registerer.mem hash + Tezos_protocol_registerer.Registerer.mem hash let get_exn hash = try VersionTable.find versions hash