From c799968934c78f9196b7acef991c9dcf0d0a7c43 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Wed, 28 Jun 2023 16:25:02 +0200 Subject: [PATCH] Add a 'modules' plugin with helpers to compile modules This will be done by Clerk at some point, but the plugin is useful for the time being. --- compiler/driver.ml | 2 +- compiler/lcalc/to_ocaml.ml | 40 ++++++- compiler/lcalc/to_ocaml.mli | 12 +- compiler/plugins/api_web.ml | 2 +- compiler/plugins/dune | 7 ++ compiler/plugins/modules.ml | 215 ++++++++++++++++++++++++++++++++++++ 6 files changed, 271 insertions(+), 7 deletions(-) create mode 100644 compiler/plugins/modules.ml diff --git a/compiler/driver.ml b/compiler/driver.ml index 1b36a34b..472c532f 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -684,7 +684,7 @@ module Commands = struct | FileName n -> Some (modname_of_file n) | _ -> None in - Lcalc.To_ocaml.format_program fmt ?modname prg type_ordering + Lcalc.To_ocaml.format_program fmt ?register_module:modname prg type_ordering let ocaml_cmd = Cmd.v diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index 534f7afc..1e5d9f12 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -545,6 +545,32 @@ let format_code_items String.Map.add (Mark.remove (ScopeName.get_info name)) var bnd) ~init:String.Map.empty code_items +let format_scope_exec + (ctx : decl_ctx) + (fmt : Format.formatter) + (bnd : 'm Ast.expr Var.t String.Map.t) + scope_name + scope_body = + let scope_name_str = Mark.remove (ScopeName.get_info scope_name) in + let scope_var = String.Map.find scope_name_str bnd in + let scope_input = + StructName.Map.find scope_body.scope_body_input_struct ctx.ctx_structs + in + if not (StructField.Map.is_empty scope_input) then + Message.raise_error + "The scope @{%s@} defines input variables.@ This is not supported \ + for a main scope at the moment." + scope_name_str; + Format.pp_open_vbox fmt 2; + Format.pp_print_string fmt "let _ ="; + (* TODO: dump the output using yojson that should be already available from + the runtime *) + Format.pp_print_space fmt (); + format_var fmt scope_var; + Format.pp_print_space fmt (); + Format.pp_print_string fmt "()"; + Format.pp_close_box fmt () + let format_module_registration fmt (bnd : 'm Ast.expr Var.t String.Map.t) @@ -584,11 +610,21 @@ open Runtime_ocaml.Runtime let format_program (fmt : Format.formatter) - ?modname + ?register_module + ?exec_scope (p : 'm Ast.program) (type_ordering : Scopelang.Dependency.TVertex.t list) : unit = Format.pp_print_string fmt header; format_ctx type_ordering fmt p.decl_ctx; let bnd = format_code_items p.decl_ctx fmt p.code_items in Format.pp_print_newline fmt (); - Option.iter (format_module_registration fmt bnd) modname + match register_module, exec_scope with + | Some modname, None -> format_module_registration fmt bnd modname + | None, Some scope_name -> + let scope_body = Program.get_scope_body p scope_name in + format_scope_exec p.decl_ctx fmt bnd scope_name scope_body + | None, None -> () + | Some _, Some _ -> + Message.raise_error + "OCaml generation: both module registration and top-level scope \ + execution where required at the same time." diff --git a/compiler/lcalc/to_ocaml.mli b/compiler/lcalc/to_ocaml.mli index 8d6eedb7..f695a0f3 100644 --- a/compiler/lcalc/to_ocaml.mli +++ b/compiler/lcalc/to_ocaml.mli @@ -40,9 +40,15 @@ val format_var : Format.formatter -> 'm Var.t -> unit val format_program : Format.formatter -> - ?modname:string -> + ?register_module:string -> + ?exec_scope:ScopeName.t -> 'm Ast.program -> Scopelang.Dependency.TVertex.t list -> unit -(** Usage [format_program fmt p type_dependencies_ordering]. If [modname] is - set, registers the module for dynamic loading *) +(** Usage [format_program fmt p type_dependencies_ordering]. Either one of these + may be set: + + - [register_module] will register the module for dynamic loading under the + given name + - [exec_scope] will mark the named scope as "main" and execute it at the end + of the program. It must have no inputs. *) diff --git a/compiler/plugins/api_web.ml b/compiler/plugins/api_web.ml index da782e25..5ead8879 100644 --- a/compiler/plugins/api_web.ml +++ b/compiler/plugins/api_web.ml @@ -453,7 +453,7 @@ let run Message.emit_debug "Compiling program into OCaml..."; Message.emit_debug "Writing to %s..." (Option.value ~default:"stdout" output_file); - Lcalc.To_ocaml.format_program fmt ?modname prg type_ordering + Lcalc.To_ocaml.format_program fmt ?register_module:modname prg type_ordering in let jsoo_output_file, with_formatter = Driver.Commands.get_output_format options ~ext:"_api_web.ml" output diff --git a/compiler/plugins/dune b/compiler/plugins/dune index 0d768020..4f3f330f 100644 --- a/compiler/plugins/dune +++ b/compiler/plugins/dune @@ -28,6 +28,13 @@ (modules lazy_interp) (libraries shared_ast catala.driver)) +(library + (name modules) + (public_name catala.plugins.modules) + (synopsis "Catala plugin for experimental module handling tooling") + (modules modules) + (libraries shared_ast catala.driver)) + (documentation (package catala) (mld_files plugins)) diff --git a/compiler/plugins/modules.ml b/compiler/plugins/modules.ml new file mode 100644 index 00000000..80ebf39f --- /dev/null +++ b/compiler/plugins/modules.ml @@ -0,0 +1,215 @@ +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Louis Gesbert . + + Licensed under the Apache License, Version 2.0 (the "License"); you may not + use this file except in compliance with the License. You may obtain a copy of + the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, WITHOUT + WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the + License for the specific language governing permissions and limitations under + the License. *) + +open Catala_utils + +let action_flag = + let docs = "ACTIONS" in + let open Cmdliner.Arg in + required + & vflag None + [ + ( Some `Compile, + info ["compile"] ~docs + ~doc: + "Compiles a Catala file into a module: a $(b,.cmxs) file that \ + can be used by the Catala interpreter." + (* "and $(b,cmo) and $(b,cmx) files that can be linked into an OCaml + program" *) ); + ( Some `Link, + info ["link"] ~docs + ~doc: + "Compiles and links a catala program into a binary (using the \ + ocaml backend). Specify a main scope using the $(b,--scope) \ + flag to be run upon execution. This is still pretty useless at \ + the moment besides for testing purposes, as there is no way to \ + feed input to the generated program, and the output will be \ + silent. Assertions will be checked, though." ); + ] + +let gen_ocaml options link_modules optimize check_invariants modname main = + let prg, ctx, type_ordering = + Driver.Passes.lcalc options ~link_modules ~optimize ~check_invariants + ~avoid_exceptions:false ~closure_conversion:false + in + let exec_scope = Option.map (Driver.Commands.get_scope_uid ctx) main in + let filename, with_output = + Driver.Commands.get_output_format options ~ext:".ml" None + in + with_output + @@ fun ppf -> + Lcalc.To_ocaml.format_program ppf ?register_module:modname ?exec_scope prg + type_ordering; + Option.get filename + +let run_process cmd args = + Message.emit_debug "Running @[@{@{%s@} %a@}@}@]" cmd + (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_string) + args; + match + Unix.waitpid [] + (Unix.create_process cmd + (Array.of_list (cmd :: args)) + Unix.stdin Unix.stdout Unix.stderr) + with + | _, Unix.WEXITED 0 -> () + | _, _ -> Message.raise_error "Child process @{%s@} failed" cmd + +let with_flag flag args = + List.fold_right (fun p acc -> flag :: p :: acc) args [] + +let ocaml_libdir = + lazy + (try String.trim (File.process_out "opam" ["var"; "lib"]) + with Failure _ -> ( + try String.trim (File.process_out "ocamlc" ["-where"]) + with Failure _ -> ( + match File.(check_directory (Sys.executable_name / ".." / "lib")) with + | Some d -> d + | None -> + Message.raise_error + "Could not locate the OCaml library directory, make sure OCaml or \ + opam is installed"))) + +let runtime_dir = + lazy + (match + List.find_map File.check_directory + [ + "_build/install/default/lib/catala/runtime_ocaml"; + (* Relative dir when running from catala source *) + File.(Lazy.force ocaml_libdir / "catala" / "runtime"); + ] + with + | Some dir -> + Message.emit_debug "Catala runtime libraries found at @{%s@}." dir; + dir + | None -> + Message.raise_error + "Could not locate the Catala runtime library.@ Make sure that either \ + catala is correctly installed,@ or you are running from the root of a \ + compiled source tree.") + +let compile options link_modules optimize check_invariants = + let modname = + match options.Cli.input_file with + (* TODO: extract module name from directives *) + | FileName n -> Driver.modname_of_file n + | _ -> Message.raise_error "Input must be a file name for this command" + in + let basename = String.uncapitalize_ascii modname in + let ml_file = + gen_ocaml options link_modules optimize check_invariants (Some modname) None + in + let flags = ["-I"; Lazy.force runtime_dir] in + let shared_out = basename ^ ".cmxs" in + Message.emit_debug "Compiling OCaml shared object file @{%s@}..." + shared_out; + run_process "ocamlopt" ("-shared" :: ml_file :: "-o" :: shared_out :: flags); + (* let byte_out = basename ^ ".cmo" in + * Message.emit_debug "Compiling OCaml byte-code object file @{%s@}..." byte_out; + * run_process "ocamlc" ("-c" :: ml_file :: "-o" :: byte_out :: flags); + * let native_out = basename ^ ".cmx" in + * Message.emit_debug "Compiling OCaml native object file @{%s@}..." native_out; + * run_process "ocamlopt" ("-c" :: ml_file :: "-o" :: native_out ::flags); *) + Message.emit_debug "Done." + +let link options link_modules optimize check_invariants output ex_scope_opt = + let ml_file = + gen_ocaml options link_modules optimize check_invariants None ex_scope_opt + in + (* NOTE: assuming native target at the moment *) + let cmd = "ocamlopt" in + let ocaml_libdir = Lazy.force ocaml_libdir in + let runtime_dir = Lazy.force runtime_dir in + (* Recursive dependencies are expanded manually here. A shorter version would + use [ocamlfind ocalmopt -linkpkg -package] with just ppx_yojson_conv_lib, + zarith and dates_calc *) + let link_libs = + [ + "biniou"; + "easy-format"; + "yojson"; + "ppx_yojson_conv_lib"; + "zarith"; + "dates_calc"; + ] + in + let link_libdirs = + List.map + (fun lib -> + match File.(check_directory (ocaml_libdir / lib)) with + | None -> + Message.raise_error + "Required OCaml library not found at @{%s@}.@ Try `opam \ + install %s'" + File.(ocaml_libdir / lib) + lib + | Some l -> l) + link_libs + in + let runtime_lib = File.(runtime_dir / "runtime_ocaml.cmxa") in + let modules = + List.map (fun m -> Filename.remove_extension m ^ ".ml") link_modules + in + let output = + match output with + | Some o -> o + | None -> Filename.remove_extension ml_file ^ ".exe" + in + let args = + with_flag "-I" link_libdirs + @ List.map + (fun lib -> String.map (function '-' -> '_' | c -> c) lib ^ ".cmxa") + link_libs + @ ("-I" :: runtime_dir :: runtime_lib :: modules) + @ [ml_file; "-o"; output] + in + run_process cmd args; + Message.emit_result "Successfully generated @{%s@}" output +(* Compile from ml and link the modules cmx. => ocamlfind ocamlopt -linkpkg + -package ppx_yojson_conv_lib -package zarith -package dates_calc -I + _build/default/runtimes/ocaml/.runtime_ocaml.objs/byte + _build/default/runtimes/ocaml/runtime_ocaml.cmxa ext.cmx extuse.ml *) + +let run + action + link_modules + optimize + check_invariants + output + ex_scope_opt + options = + match action with + | `Compile -> compile options link_modules optimize check_invariants + | `Link -> + link options link_modules optimize check_invariants ex_scope_opt output + +let term = + let open Cmdliner.Term in + const run + $ action_flag + $ Cli.Flags.link_modules + $ Cli.Flags.optimize + $ Cli.Flags.check_invariants + $ Cli.Flags.ex_scope_opt + $ Cli.Flags.output + +let () = + Driver.Plugin.register "module" term + ~doc: + "This plugin provides a few experimental tools related to module \ + generation and compilation"