├── .gitignore ├── CHANGES.md ├── CONTRIBUTING.md ├── LICENSE.md ├── Makefile ├── README.md ├── bin ├── ROLL_NEW_VERSION ├── dune ├── ocaml_embed_compiler.ml └── ocaml_embed_compiler.mli ├── dune-project ├── hello_world ├── bin │ ├── dune │ ├── plugin_001.ml │ ├── plugin_001.mli │ ├── plugin_002.ml │ ├── plugin_003.ml │ ├── plugin_004.ml │ ├── plugin_005.ml │ ├── plugin_006.ml │ ├── plugin_007.ml │ └── run.ml └── src │ ├── dune │ └── plugin_intf.ml ├── ocaml_plugin.opam ├── sample ├── bin │ ├── config.ml │ ├── config.mli │ ├── dune │ ├── run.ml │ └── what_to_test.txt ├── config │ ├── config_01.ml │ ├── config_02.ml │ ├── config_util.ml │ ├── config_v1_error.ml │ └── syntax_error.ml └── src │ ├── dsl.ml │ ├── dsl.mli │ └── dune ├── src ├── compiler.ml ├── compiler.mli ├── dune ├── dynloader.ml ├── dynloader.mli ├── import.ml ├── ml_bundle.ml ├── ml_bundle.mli ├── ocaml_fake_archive.c ├── ocaml_plugin.ml ├── ocamldep.ml ├── ocamldep.mli ├── params.ml ├── params.mli ├── plugin_cache.ml ├── plugin_cache.mli ├── plugin_uuid.ml ├── plugin_uuid.mli ├── shell.ml ├── shell.mli ├── tar.ml └── tar.mli └── test ├── dune ├── jbuild-ignore ├── plugin_loader.ml ├── setup-script ├── test-basic.t ├── test-cache.t ├── test-inferred-interface.t ├── test-language-features.t ├── test-ocamldep.t ├── test-persistent-archive.t ├── test-positions.t ├── test-run-plugin-toplevel.t ├── test-trickier.t ├── test-warnings.t ├── test_lib ├── dune ├── sync_default_warnings.ml ├── sync_default_warnings.mli └── test.ml ├── test_with_sexp.ml ├── test_with_sexp.mli ├── test_with_sexp_dep.ml └── test_with_sexp_dep.mli /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | _opam 5 | 6 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## v0.11 2 | 3 | - Rework the API of Ocaml_plugin to use the new stdless idiom. (Keep the old one 4 | as deprecated) 5 | Also, the following modules were renamed: 6 | + `Ocaml_plugin.Std.Ocaml_dynloader` is now accessible at `Ocaml_plugin.Dynloader` 7 | + `Ocaml_plugin.Std.Ocaml_compiler` is now accessible at `Ocaml_plugin.Compiler` 8 | 9 | ## 113.43.00 10 | 11 | - In Ocaml_plugin, drop `t_of_sexp` on an unstable type not meant to expose this. 12 | This was most probably added either temporarily or maybe by mistake. 13 | 14 | - Allow the specification of the permissions with which to create 15 | `in_dir` (the directory where ocaml_plugin does its compilation). 16 | 17 | - If a persistent compiler archive is modified, ocaml\_plugin will probably fail at 18 | compiling. Make it more robust by considering the archive invalid instead. 19 | This can easily happen when deleting a bunch of cmi/cmx/exe recursively and inadvertently 20 | messing up the ocaml_plugin archive. 21 | 22 | On the way, I simplify things by passing more information from ocaml\_embed\_compiler (at 23 | compile time) to ocaml_plugin (at runtime) without having to look in the archive. 24 | 25 | ## 113.33.00 26 | 27 | - Improve the check plugin command that comes with ocaml-plugin: 28 | 29 | 1) Improve documentation, add `readme` to include more info about what is being 30 | checked exactly. 31 | 32 | 2) Avoid the switch `-code-style _` for application that have made a choice of 33 | code style statically. Having the swtich available at runtime is just 34 | confusing, since only 1 style is going to work anyway. 35 | 36 | ## 113.24.02 37 | 38 | - Added an ocamlbuild plugin to ease the creation of embed programs 39 | 40 | ## 113.24.00 41 | 42 | - Switch to ppx. 43 | 44 | - Allow ppx-style code to be loaded by plugin-applications build using ocaml\_plugin. 45 | 46 | - Follow Core & Async evolution. 47 | 48 | ## 113.00.00 49 | 50 | - Made `Ocaml_plugin.Plugin_cache.Config.t` stable. 51 | 52 | ## 112.35.00 53 | 54 | - In `copy_source_files_to_working_dir`, exclude files that start with 55 | a dot. 56 | 57 | emacs creates temporary files that cannot be read with names like 58 | `.#foo.ml`, and attempting to copy those causes this function to 59 | fail. 60 | 61 | ## 112.24.00 62 | 63 | Minor update: follow Async evolution. 64 | 65 | ## 112.17.00 66 | 67 | - Fixed spurious `interface mismatch` error when a plugin cache is 68 | shared by incompatible compilers. 69 | 70 | When a plugin cache directory is used by several executables with 71 | incompatible cmis/compilers, and the cache config option 72 | `try_old_cache_with_new_exec` is set to true, this could lead to the 73 | following error: 74 | 75 | ```ocaml 76 | Plugin failed: (ocaml_dynloader.ml.Dynlink_error "interface mismatch") 77 | ``` 78 | 79 | This feature fixes this. 80 | 81 | Since it modifies some record, for later changes it seems easier and 82 | more conservative to allow field additions without breaking older 83 | version. Thus we allow extra fields in persisted records. 84 | 85 | ```ocaml 86 | let t_of_sexp = Sexp.of_sexp_allow_extra_fields t_of_sexp 87 | ``` 88 | 89 | New executables can read both old and new caches, but old 90 | executables will either blow away new caches, or if the config says 91 | the cache is read-only, fail. 92 | 93 | Take the chance to modernize part of the code. 94 | - Switched tests to unified tests. 95 | - Fixed bugs dealing with paths with spaces in them. 96 | - Check that plugins have the expected type before running them rather 97 | than after, which is what one would expect. 98 | 99 | Also check that runtime and compile types match in 100 | `check_ocaml_src_files` and 101 | `compile_ocaml_src_files_into_cmxs_file`. 102 | 103 | ## 112.06.00 104 | 105 | - Stopped using the `~exclusive` with `Reader`, because it doesn't work 106 | on read-only file systems. 107 | 108 | It's not even needed because these files are written atomically. 109 | 110 | - Used a generative functor in the generated code, so the user code can 111 | apply generative functors at toplevel, or unpack first class modules 112 | that contain type components. 113 | - Fixed bug when mli file references something defined only in 114 | another ml. 115 | - Made it possible to compile a plugin in one process, and dynload the 116 | compiled `cmxs` file without starting async in another process. 117 | 118 | This was done with two new APIs in `Ocaml_dynloader.S`: 119 | 120 | val compile_ocaml_src_files_into_cmxs_file 121 | : dynloader 122 | -> string list 123 | -> output_file:string 124 | -> unit Deferred.Or_error.t 125 | 126 | val blocking_load_cmxs_file : string -> t Or_error.t 127 | 128 | - Allowed plugins to optionally have a shebang line. 129 | - Made `Ocaml_dynloader.find_dependencies` also support files with 130 | shebang lines. 131 | 132 | ## 112.01.00 133 | 134 | - Changed to not use `rm -r` when it is expected to remove one file. 135 | 136 | ## 111.28.00 137 | 138 | - Fixed a bug in tests that could leave the repository in a state where 139 | running the tests would fail. 140 | 141 | The bug happened if the tests were interrupted after creating 142 | read-only directories but before cleaning then up. 143 | 144 | ## 111.25.00 145 | 146 | - ignore more warnings by default 147 | 148 | ## 111.21.00 149 | 150 | - Fixed a bug in `ocaml_embed_compiler` on 32-bit machines. 151 | 152 | `ocaml_embed_compiler` tries to read the full contents of the file as 153 | a string, but the string might be too big on 32bits: 154 | 155 | https://github.com/ocaml/opam-repository/pull/2062#issuecomment-43045491 156 | 157 | ## 111.11.00 158 | 159 | - Added a tag to exceptions coming from the toplevel execution of 160 | plugins so that we do not confuse them with exceptions coming from 161 | the library. 162 | 163 | Also, added a function to check a plugin without executing it. And 164 | captured the common pattern of checking the compilation of a plugin 165 | in a `Command.t` offered in the library. 166 | 167 | ## 111.08.00 168 | 169 | - Use `ocamldep` to generate the dependencies of an `.ml` file, if 170 | requested. 171 | 172 | Added a function to find the dependencies of a module, but did not 173 | change the existing behavior and interface of the library if one 174 | does not choose to use this functionality. 175 | 176 | ## 110.01.00 177 | 178 | - Added `cmi`'s so that plugins can use `lazy`, recursive modules, and 179 | objects. 180 | 181 | ## 109.53.00 182 | 183 | Bump version number 184 | 185 | ## 109.45.00 186 | 187 | - Made executables link without error even if no archive is embedded 188 | in them. 189 | 190 | This is often the desired behavior (for inline tests of libraries 191 | using transitively ocaml-plugin for instance). 192 | 193 | ## 109.41.00 194 | 195 | - Added option `-strict-sequence`, which is set to `true` by default. 196 | 197 | ## 109.35.00 198 | 199 | - Changed the execution of plugin's toplevel to run in async instead 200 | of `In_thread.run`, unless a config parameter says otherwise. 201 | 202 | ## 109.32.00 203 | 204 | - Fixed the slow and memory-consuming compilation of > 100MB `.c` files generated by `ocaml_embed_compiler`. 205 | 206 | This was done by having them contain one big string instead of one big 207 | array. 208 | 209 | - Added more unused-value warnings in plugins. 210 | 211 | If { `Ui` , `M` } are the modules that constitute a given plugin of 212 | expected module type `S`, then previously we generated a file like: 213 | 214 | ```ocaml 215 | module Ui : sig 216 | ... 217 | end = struct 218 | ... 219 | end 220 | 221 | module M : sig 222 | ... 223 | end = struct 224 | ... 225 | end 226 | 227 | let () = ##register (M : S) 228 | ``` 229 | 230 | Doing that, we did not get unused variables: 231 | 232 | 1. for the toplevel of `Ui` if `Ui` does not have a `mli`. 233 | 2. for unused values of `Ui` and `M` if they have an `mli` exporting them. 234 | 235 | OCaml plugin now allows one to get these warnings. Since (2) is 236 | rather annoying for utils kind of file, this comes only if a config 237 | flag is enabled. 238 | 239 | ## 109.31.00 240 | 241 | - Fixed OCaml Plugin on CentOS 5 -- it had problems because the generated c files did not end with a newline. 242 | - Finished the transition from `Command_deprecated` to `Command`. 243 | 244 | ## 109.30.00 245 | 246 | - Support for Mac OSX 247 | 248 | Removed the dependency of `ocaml-plugin` on `objcopy` and `/proc`. 249 | 250 | ## 109.20.00 251 | 252 | - Removed a test that (rarely) failed nondeterministically. 253 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This repository contains open source software that is developed and 2 | maintained by [Jane Street][js]. 3 | 4 | Contributions to this project are welcome and should be submitted via 5 | GitHub pull requests. 6 | 7 | Signing contributions 8 | --------------------- 9 | 10 | We require that you sign your contributions. Your signature certifies 11 | that you wrote the patch or otherwise have the right to pass it on as 12 | an open-source patch. The rules are pretty simple: if you can certify 13 | the below (from [developercertificate.org][dco]): 14 | 15 | ``` 16 | Developer Certificate of Origin 17 | Version 1.1 18 | 19 | Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 20 | 1 Letterman Drive 21 | Suite D4700 22 | San Francisco, CA, 94129 23 | 24 | Everyone is permitted to copy and distribute verbatim copies of this 25 | license document, but changing it is not allowed. 26 | 27 | 28 | Developer's Certificate of Origin 1.1 29 | 30 | By making a contribution to this project, I certify that: 31 | 32 | (a) The contribution was created in whole or in part by me and I 33 | have the right to submit it under the open source license 34 | indicated in the file; or 35 | 36 | (b) The contribution is based upon previous work that, to the best 37 | of my knowledge, is covered under an appropriate open source 38 | license and I have the right under that license to submit that 39 | work with modifications, whether created in whole or in part 40 | by me, under the same open source license (unless I am 41 | permitted to submit under a different license), as indicated 42 | in the file; or 43 | 44 | (c) The contribution was provided directly to me by some other 45 | person who certified (a), (b) or (c) and I have not modified 46 | it. 47 | 48 | (d) I understand and agree that this project and the contribution 49 | are public and that a record of the contribution (including all 50 | personal information I submit with it, including my sign-off) is 51 | maintained indefinitely and may be redistributed consistent with 52 | this project or the open source license(s) involved. 53 | ``` 54 | 55 | Then you just add a line to every git commit message: 56 | 57 | ``` 58 | Signed-off-by: Joe Smith 59 | ``` 60 | 61 | Use your real name (sorry, no pseudonyms or anonymous contributions.) 62 | 63 | If you set your `user.name` and `user.email` git configs, you can sign 64 | your commit automatically with git commit -s. 65 | 66 | [dco]: http://developercertificate.org/ 67 | [js]: https://opensource.janestreet.com/ 68 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2013--2023 Jane Street Group, LLC 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | default: 4 | dune build 5 | 6 | install: 7 | dune install $(INSTALL_ARGS) 8 | 9 | uninstall: 10 | dune uninstall $(INSTALL_ARGS) 11 | 12 | reinstall: uninstall install 13 | 14 | clean: 15 | dune clean 16 | 17 | .PHONY: default install uninstall reinstall clean 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ocaml_plugin (archived) - a wrapper around dynlink for OCaml 2 | ================================================= 3 | 4 | ocaml_plugin is a library meant to make dynlink more easier. It offers 5 | a high-level kind of api where you can get a first class module out of 6 | a few ml source files, while handling the compilation of the files 7 | automatically. 8 | 9 | Installation via opam 10 | --------------------- 11 | 12 | ocaml_plugin can be installed via [opam](http://opam.ocamlpro.com/): 13 | 14 | $ opam install ocaml_plugin 15 | 16 | Usage 17 | ----- 18 | 19 | A simple example is provided under the `hello_world` directory. A 20 | recommended set-up usually involves 2 steps in the code 21 | - defining the interface of the plugin, as well as an univ value 22 | - applying a functor to get a customized plugin loader plugin_intf.ml: 23 | 24 | ```ocaml 25 | module type S = sig 26 | val message : string 27 | end 28 | let univ_constr = 29 | (Univ_constr.create "Plugin_intf.S" sexp_of_opaque : (module S) Univ_constr.t) 30 | ``` 31 | 32 | run.ml: 33 | 34 | ```ocaml 35 | module Plugin = Compiler.Make(struct 36 | type t = (module Plugin_intf.S) 37 | let t_repr = "Plugin_intf.S" 38 | let univ_constr = Plugin_intf.univ_constr 39 | let univ_constr_repr = "Plugin_intf.univ_constr" 40 | end) 41 | ``` 42 | 43 | ```ocaml 44 | Plugin.load_ocaml_src_files (files:string list) >>= function 45 | | Error err -> 46 | Printf.eprintf "loading failed:\n%s%!" (Error.to_string_hum err) 47 | | Ok plugin -> 48 | let module M = (val plugin : Plugin_intf.S) in 49 | Printf.printf "loaded plugin's message : %S\n%!" M.message 50 | ``` 51 | 52 | Standalone executable 53 | --------------------- 54 | 55 | It is possible to embed the compiler in an executable such that a full 56 | ocaml environment is not mandatory to actually load plugins. The way 57 | it is done in this version of the library is by embedding 58 | `ocamlopt.opt` and some `cmi files` inside a tgz archive that is 59 | getting amended at the end of the exec. At runtime, this archive is 60 | extracted into a temporary directory where the compilation will 61 | happen. To create this standalone version of an exec 62 | (exec+ocamlopt+cmi), you would typically run something like: 63 | 64 | $ ../bin/ocaml_embed_compiler.exe -exe ./run.exe -cc $(which ocamlopt) \ 65 | dsl.cmi ../lib/ocaml_plugin.cmi $(ocamlopt -where)/pervasives.cmi \ 66 | -o ./run-standalone.exe 67 | 68 | `opam` will install this executable as `ocaml-embed-compiler`. 69 | -------------------------------------------------------------------------------- /bin/ROLL_NEW_VERSION: -------------------------------------------------------------------------------- 1 | jadmin install to-merge ocaml_embed_compiler.exe /mnt/global/base/bin/ocaml-embed-compiler.exe 2 | jadmin install to-merge ocaml_embed_compiler.exe /mnt/global/base/bin/ocaml-embed-compiler-beta.exe 3 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executables (names ocaml_embed_compiler) 2 | (libraries async core_unix.command_unix core core_unix.filename_unix 3 | ocaml_plugin sexplib) 4 | (preprocess (pps ppx_jane))) 5 | 6 | (install (section bin) 7 | (files (ocaml_embed_compiler.exe as ocaml-embed-compiler))) -------------------------------------------------------------------------------- /bin/ocaml_embed_compiler.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | let readme () = 5 | {|This tool archives ocamlopt, cmis and preprocessors in a c file containing a big static 6 | string. The resulting .o file should be linked with any executable that uses 7 | Ocaml_plugin.Compiler module. Or you can link your executable with a .o file 8 | containing a dummy definition of the function ocaml_plugin_archive if you know you will 9 | not need it.|} 10 | ;; 11 | 12 | let check_files_in_tar ~files_in_tar ~expected = 13 | let files_in_tar = List.sort ~compare:String.compare files_in_tar in 14 | let files_in_tar_set = String.Set.of_list files_in_tar in 15 | if (not (Set.equal files_in_tar_set expected)) 16 | || List.length files_in_tar <> Set.length files_in_tar_set 17 | then 18 | raise_s 19 | [%sexp 20 | "Error checking files in tar" 21 | , { expected : String.Set.t 22 | ; files_in_tar : string list 23 | ; unknown_files = (Set.diff files_in_tar_set expected : String.Set.t) 24 | ; missing_files = (Set.diff expected files_in_tar_set : String.Set.t) 25 | } 26 | , [%here]] 27 | ;; 28 | 29 | let escape = 30 | let a = Array.init ~f:(Printf.sprintf "\\x%02x") 256 in 31 | fun c -> a.(Char.to_int c) 32 | ;; 33 | 34 | let transfer_escaped ~file ~writer = 35 | Reader.with_file file ~f:(fun reader -> 36 | let transfered = ref 0 in 37 | match%map 38 | Reader.read_one_chunk_at_a_time reader ~handle_chunk:(fun buf ~pos ~len -> 39 | for i = 0 to len - 1 do 40 | let c = buf.{pos + i} in 41 | if (!transfered + i) mod 20 = 0 then Writer.write writer "\"\n \""; 42 | Writer.write writer (escape c) 43 | done; 44 | transfered := !transfered + len; 45 | Deferred.return `Continue) 46 | with 47 | | `Eof -> !transfered 48 | | `Stopped _ | `Eof_with_unconsumed_data _ -> assert false) 49 | ;; 50 | 51 | let ocaml_plugin_archive_template : (_, _, _, _) format4 = 52 | {|CAMLprim value ocaml_plugin_archive (value unit __attribute__ ((unused))) 53 | { 54 | intnat dim = %d; 55 | int flags = CAML_BA_UINT8 | CAML_BA_C_LAYOUT | CAML_BA_EXTERNAL; 56 | return caml_ba_alloc(flags, 1, s, &dim); 57 | } 58 | |} 59 | ;; 60 | 61 | let ocaml_plugin_archive_metadata_template : (_, _, _, _) format4 = 62 | {|CAMLprim value ocaml_plugin_archive_metadata (value unit __attribute__ ((unused))) 63 | { 64 | return caml_copy_string(%S); 65 | } 66 | |} 67 | ;; 68 | 69 | let generate_c_file target ~tar ~metadata = 70 | Monitor.try_with (fun () -> 71 | Writer.with_file target ~f:(fun writer -> 72 | Writer.write 73 | writer 74 | (String.concat 75 | ~sep:"\n" 76 | [ (* avoid making emacs die trying to highlight the huge string *) 77 | "/* -*- mode: fundamental; -*- */" 78 | ; "#include " 79 | ; "#include " 80 | ; "#include " 81 | ; "#include " 82 | ; "#include " 83 | ; "" 84 | ]); 85 | Writer.write writer "static char s[] = \""; 86 | let%map file_length = transfer_escaped ~file:tar ~writer in 87 | Writer.write writer "\";\n\n"; 88 | Printf.ksprintf (Writer.write writer) ocaml_plugin_archive_template file_length; 89 | Writer.write writer "\n"; 90 | Printf.ksprintf 91 | (Writer.write writer) 92 | ocaml_plugin_archive_metadata_template 93 | (Sexp.to_string_mach (Ocaml_plugin.Compiler.Archive_metadata.sexp_of_t metadata)))) 94 | ;; 95 | 96 | let command = 97 | Command.async 98 | ~readme 99 | ~summary:"tool to embed ocamlopt and cmi files into a c file" 100 | (let%map_open.Command ocamlopt_opt = 101 | flag 102 | "-cc" 103 | (required Filename_unix.arg_type) 104 | ~doc:" set the ocaml native compiler" 105 | and ppx_exe = 106 | flag 107 | "-ppx" 108 | (optional Filename_unix.arg_type) 109 | ~doc:" set the executable for ppx preprocessing" 110 | and ocamldep_opt = 111 | flag 112 | "-ocamldep" 113 | (optional Filename_unix.arg_type) 114 | ~doc:" set the ocamldep native dependency generator" 115 | and target = 116 | flag 117 | "-o" 118 | (required Filename_unix.arg_type) 119 | ~doc:" set the name of the c file to be created" 120 | and verbose = flag "-verbose" no_arg ~doc:" be more verbose" 121 | and extra_files = anon (sequence ("" %: Filename_unix.arg_type)) in 122 | fun () -> 123 | let _set_defaults_scope = 124 | Ocaml_plugin.Private.Shell.set_defaults ~verbose ~echo:verbose () 125 | in 126 | let%bind tmpdir = 127 | Ocaml_plugin.Private.Shell.temp_dir ~in_dir:Filename.temp_dir_name () >>| ok_exn 128 | in 129 | let embedded_files = String.Table.create () in 130 | let embed_file ~filename ~basename = 131 | match Hashtbl.add embedded_files ~key:basename ~data:filename with 132 | | `Ok -> () 133 | | `Duplicate -> 134 | raise_s 135 | [%sexp 136 | "cannot embed multiple files with the same basename", (basename : string)] 137 | in 138 | let cp ~filename ~basename = 139 | embed_file ~filename ~basename; 140 | Ocaml_plugin.Private.Shell.cp ~source:filename ~dest:(tmpdir ^/ basename) 141 | >>| ok_exn 142 | in 143 | let copy_file filename = 144 | let basename = Filename.basename filename in 145 | let%map () = cp ~filename ~basename in 146 | basename 147 | in 148 | let how = `Max_concurrent_jobs 10 in 149 | let%bind (_ : string list) = Deferred.List.map ~how extra_files ~f:copy_file in 150 | let%bind () = 151 | cp ~filename:ocamlopt_opt ~basename:Ocaml_plugin.Compiler.ocamlopt_opt 152 | in 153 | let%bind () = 154 | match ocamldep_opt with 155 | | Some ocamldep_opt -> 156 | cp ~filename:ocamldep_opt ~basename:Ocaml_plugin.Compiler.ocamldep_opt 157 | | None -> return () 158 | in 159 | let%bind () = 160 | match ppx_exe with 161 | | Some ppx_exe -> cp ~filename:ppx_exe ~basename:Ocaml_plugin.Compiler.ppx_exe 162 | | None -> return () 163 | in 164 | let tar = "a.tgz" in 165 | let%bind () = 166 | Ocaml_plugin.Private.Tar.create 167 | ~working_dir:tmpdir 168 | ~files:(Hashtbl.keys embedded_files) 169 | tar 170 | >>| ok_exn 171 | in 172 | let%bind digests_by_basename = 173 | Deferred.List.map 174 | ~how 175 | (Hashtbl.to_alist embedded_files) 176 | ~f:(fun (basename, filename) -> 177 | Ocaml_plugin.Plugin_cache.Digest.file filename 178 | >>|? fun digest -> basename, digest) 179 | >>| Or_error.combine_errors 180 | >>| ok_exn 181 | in 182 | let tar = tmpdir ^/ tar in 183 | match%bind 184 | generate_c_file 185 | target 186 | ~tar 187 | ~metadata: 188 | { ppx_is_embedded = Option.is_some ppx_exe 189 | ; archive_digests = String.Map.of_alist_exn digests_by_basename 190 | } 191 | with 192 | | Error exn -> 193 | let%map () = Ocaml_plugin.Private.Shell.rm ~r:() ~f:() [ tmpdir ] >>| ok_exn in 194 | raise exn 195 | | Ok () -> 196 | let%bind files_in_tar = Ocaml_plugin.Private.Tar.list tar >>| ok_exn in 197 | check_files_in_tar 198 | ~files_in_tar 199 | ~expected:(String.Set.of_hashtbl_keys embedded_files); 200 | Ocaml_plugin.Private.Shell.rm ~r:() ~f:() [ tmpdir ] >>| ok_exn) 201 | ~behave_nicely_in_pipeline:false 202 | ;; 203 | 204 | 205 | let () = Command_unix.run command 206 | -------------------------------------------------------------------------------- /bin/ocaml_embed_compiler.mli: -------------------------------------------------------------------------------- 1 | (*_ Deliberately empty *) 2 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.10) -------------------------------------------------------------------------------- /hello_world/bin/dune: -------------------------------------------------------------------------------- 1 | (executables (names run) 2 | (libraries async core dynlink ocaml_plugin ocaml_plugin_hello_world sexplib) 3 | (modules run) (preprocess (pps ppx_jane))) -------------------------------------------------------------------------------- /hello_world/bin/plugin_001.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | (* example of plugin of type Plugin_intf.S *) 4 | 5 | let side_effect = print_endline "plugin_001.ml is being executed !" 6 | let message = "This is plugin_001's message" 7 | -------------------------------------------------------------------------------- /hello_world/bin/plugin_001.mli: -------------------------------------------------------------------------------- 1 | val side_effect : unit 2 | val message : string 3 | -------------------------------------------------------------------------------- /hello_world/bin/plugin_002.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | let message = 42 4 | -------------------------------------------------------------------------------- /hello_world/bin/plugin_003.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | let f s = s ^ s ^ s 4 | let message = f "plugin_003 is a stammer " 5 | -------------------------------------------------------------------------------- /hello_world/bin/plugin_004.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | type t = { x : int list } [@@deriving sexp, fields] 4 | 5 | let () = assert ({ x = [ 1 ] } = [%of_sexp: t] (Sexp.of_string "((x (1)))")) 6 | let () = assert (x { x = [ 1 ] } = [ 1 ]) 7 | let message = "Hey, turns out you don't need to write sexpifiers by hand. Awesome!!" 8 | -------------------------------------------------------------------------------- /hello_world/bin/plugin_005.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | let message = Int.to_string Plugin_002.message 4 | -------------------------------------------------------------------------------- /hello_world/bin/plugin_006.ml: -------------------------------------------------------------------------------- 1 | let message = Plugin_007.message 2 | -------------------------------------------------------------------------------- /hello_world/bin/plugin_007.ml: -------------------------------------------------------------------------------- 1 | let message = Plugin_006.message 2 | -------------------------------------------------------------------------------- /hello_world/bin/run.ml: -------------------------------------------------------------------------------- 1 | (* simplest example for using ocaml_plugin *) 2 | (* 3 | This is an interactive loop. It is meant to be used for small demo, testing the cache, 4 | looking at the build dir while the application is still running, experimenting various 5 | failure scenarios, etc. 6 | run with: 7 | rlwrap ./run.exe 8 | enter ml filename(s) to load: plugin_001.ml 9 | *) 10 | 11 | open! Core 12 | open! Async 13 | 14 | module Plugin = Ocaml_plugin.Dynloader.Make (struct 15 | type t = (module Ocaml_plugin_hello_world.Plugin_intf.S) 16 | 17 | let t_repr = "Ocaml_plugin_hello_world.Plugin_intf.S" 18 | let univ_constr = Ocaml_plugin_hello_world.Plugin_intf.univ_constr 19 | let univ_constr_repr = "Ocaml_plugin_hello_world.Plugin_intf.univ_constr" 20 | end) 21 | 22 | let () = 23 | don't_wait_for 24 | (Ocaml_plugin.Private.Shell.set_defaults ~verbose:true ~echo:true (); 25 | let argv = Sys.get_argv () in 26 | let use_cache = 27 | if Array.length argv > 1 28 | then Some (Ocaml_plugin.Plugin_cache.Config.t_of_sexp (Sexp.of_string argv.(1))) 29 | else None 30 | in 31 | let persistent_archive_dirpath = 32 | if Array.length argv > 2 then Some argv.(2) else None 33 | in 34 | match%bind 35 | Ocaml_plugin.Compiler.create ?use_cache ?persistent_archive_dirpath () 36 | with 37 | | Error e -> 38 | Core.Printf.eprintf "Cannot build embed loader: %s" (Error.to_string_hum e); 39 | Core.Printf.eprintf "use run_standalone.exe (cf build.sh) instead\n%!"; 40 | exit 1 41 | | Ok (`this_needs_manual_cleaning_after compiler) -> 42 | let loader = Ocaml_plugin.Compiler.loader compiler in 43 | let stdin = Lazy.force Reader.stdin in 44 | let rec loop () = 45 | Core.Printf.printf "enter ml filename(s) to load: %!"; 46 | match%bind Reader.read_line stdin with 47 | | `Eof -> 48 | let%bind result = Ocaml_plugin.Compiler.clean compiler in 49 | let () = Or_error.ok_exn result in 50 | print_newline (); 51 | return (shutdown 0) 52 | | `Ok input -> 53 | let files = String.split ~on:' ' input in 54 | let files = 55 | List.filter_map files ~f:(fun s -> 56 | let s = String.strip s in 57 | if String.is_empty s then None else Some s) 58 | in 59 | let with_files files = 60 | match%bind Plugin.load_ocaml_src_files loader files with 61 | | Error err -> 62 | Core.Printf.eprintf "loading failed:\n%s\n%!" (Error.to_string_hum err); 63 | loop () 64 | | Ok plugin -> 65 | let module M = (val plugin : Ocaml_plugin_hello_world.Plugin_intf.S) in 66 | Core.Printf.printf "loaded plugin's message : %S\n%!" M.message; 67 | loop () 68 | in 69 | (match files with 70 | | [] -> loop () 71 | | [ cmxs ] when String.is_suffix ~suffix:"cmxs" cmxs -> 72 | (* hack to play a bit with ocaml dynlink *) 73 | (try Dynlink.loadfile_private cmxs with 74 | | e -> 75 | let str = 76 | match e with 77 | | Dynlink.Error e -> Dynlink.error_message e 78 | | e -> Exn.to_string e 79 | in 80 | Core.Printf.eprintf "dynlink failed:\n%s\n%!" str); 81 | loop () 82 | | [ "dep"; file ] -> 83 | (* hack to play a bit with ocamldep *) 84 | (match%bind Ocaml_plugin.Dynloader.find_dependencies loader file with 85 | | Error err -> 86 | Core.Printf.eprintf "ocamldep failed:\n%s\n%!" (Error.to_string_hum err); 87 | loop () 88 | | Ok files -> with_files files) 89 | | _ -> with_files files) 90 | in 91 | loop ()) 92 | ;; 93 | 94 | let () = never_returns (Scheduler.go ()) 95 | -------------------------------------------------------------------------------- /hello_world/src/dune: -------------------------------------------------------------------------------- 1 | (library (name ocaml_plugin_hello_world) (libraries ocaml_plugin) 2 | (preprocess (pps ppx_jane))) -------------------------------------------------------------------------------- /hello_world/src/plugin_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | val message : string 3 | end 4 | 5 | let univ_constr : (module S) Ocaml_plugin.Dynloader.Univ_constr.t = 6 | Ocaml_plugin.Dynloader.Univ_constr.create () 7 | ;; 8 | -------------------------------------------------------------------------------- /ocaml_plugin.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Jane Street developers" 3 | authors: ["Jane Street Group, LLC"] 4 | homepage: "https://github.com/janestreet/ocaml_plugin" 5 | bug-reports: "https://github.com/janestreet/ocaml_plugin/issues" 6 | dev-repo: "git+https://github.com/janestreet/ocaml_plugin.git" 7 | doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ocaml_plugin/index.html" 8 | license: "MIT" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ] 12 | depends: [ 13 | "ocaml" {>= "4.08.0"} 14 | "async" 15 | "core" 16 | "core_kernel" 17 | "core_unix" 18 | "ppx_jane" 19 | "sexplib" 20 | "dune" {>= "2.0.0"} 21 | ] 22 | available: arch != "arm32" & arch != "x86_32" 23 | synopsis: "Automatically build and dynlink OCaml source files" 24 | description: " 25 | " 26 | -------------------------------------------------------------------------------- /sample/bin/config.ml: -------------------------------------------------------------------------------- 1 | type v1 = (module Ocaml_plugin_sample.Dsl.Config_intf_v1) 2 | type v2 = (module Ocaml_plugin_sample.Dsl.Config_intf_v2) 3 | 4 | module V1 = Ocaml_plugin.Compiler.Make (struct 5 | type t = v1 6 | 7 | let t_repr = "Ocaml_plugin_sample.Dsl.Config_intf_v1" 8 | let univ_constr = Ocaml_plugin_sample.Dsl.univ_constr_v1 9 | let univ_constr_repr = "Ocaml_plugin_sample.Dsl.univ_constr_v1" 10 | end) 11 | 12 | module V2 = Ocaml_plugin.Compiler.Make (struct 13 | type t = v2 14 | 15 | let t_repr = "Ocaml_plugin_sample.Dsl.Config_intf_v2" 16 | let univ_constr = Ocaml_plugin_sample.Dsl.univ_constr_v2 17 | let univ_constr_repr = "Ocaml_plugin_sample.Dsl.univ_constr_v2" 18 | end) 19 | -------------------------------------------------------------------------------- /sample/bin/config.mli: -------------------------------------------------------------------------------- 1 | type v1 = (module Ocaml_plugin_sample.Dsl.Config_intf_v1) 2 | type v2 = (module Ocaml_plugin_sample.Dsl.Config_intf_v2) 3 | 4 | module V1 : Ocaml_plugin.Compiler.S with type t := v1 5 | module V2 : Ocaml_plugin.Compiler.S with type t := v2 6 | -------------------------------------------------------------------------------- /sample/bin/dune: -------------------------------------------------------------------------------- 1 | (executables (names run) 2 | (libraries async core_unix.command_unix core ocaml_plugin 3 | ocaml_plugin_sample sexplib core_unix.sys_unix) 4 | (preprocess (pps ppx_jane))) -------------------------------------------------------------------------------- /sample/bin/run.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | (* 5 | For that sample, we will assume that the command ocamlopt.opt 6 | refer to the same executable used to compile run.exe 7 | This sample does not use the binutils packaging, it only 8 | tests the Loader module. 9 | *) 10 | let ocamlopt_opt = "ocamlopt.opt" 11 | 12 | (* 13 | We use a local build dir not in tmp so that we can have a look 14 | there and see what is generated and compiled (debugging) 15 | In production, this directory would be somewhere hidden in /tmp 16 | and cleaned right after the end of the dynloading. 17 | *) 18 | let builddir = Filename.concat (Sys_unix.getcwd ()) "_build" 19 | 20 | (* 21 | For building this example, we use 3 config files 22 | -config_01.ml is a version 1 of the Dsl's config 23 | -config_02.ml is a version 2 of the Dsl's config 24 | -config_util.ml is a utility file used by config_02 25 | it is used to show how to integrate library-like config scripts (cf ~export:true) 26 | since config_02.ml uses features from config_util, it should be loaded before. 27 | *) 28 | let conf_01 = "config/config_01.ml" 29 | let conf_util = "config/config_util.ml" 30 | let conf_02 = "config/config_02.ml" 31 | 32 | (** 33 | The location where the cmi files needed by the plugin can be found. 34 | Any config loading need to access ocaml_plugin.cmi. 35 | *) 36 | let def_include = [ "."; "../lib" ] 37 | 38 | let include_directories = ref [] 39 | let cmx_flags = ref [] 40 | let cmxs_flags = ref [] 41 | 42 | (* 43 | use rather a temp_dir instead of the builddir 44 | *) 45 | let temp_dir = ref false 46 | 47 | (* 48 | We use a flag to tell if we want to load the default files 49 | *) 50 | let default = ref true 51 | 52 | (* 53 | We use a flag to use the auto embed build mode 54 | *) 55 | let embed_mode = ref false 56 | 57 | (* 58 | we use a flag to test the clean function 59 | *) 60 | let clean = ref false 61 | 62 | (* 63 | this file is used to show what happens in case of error, e.g. typing error 64 | *) 65 | let conf_v1_error = "config/config_v1_error.ml" 66 | let load_error = ref false 67 | 68 | (* 69 | taking file to load from command line 70 | *) 71 | type file = 72 | [ `v1 of string 73 | | `v2 of string 74 | | `util of string 75 | ] 76 | 77 | let files = (Queue.create () : file Queue.t) 78 | 79 | module Flag = struct 80 | let string tag ~doc fct () = 81 | Command.Spec.( 82 | step (fun main strings -> 83 | List.iter ~f:fct strings; 84 | main) 85 | +> flag tag (listed string) ~doc) 86 | ;; 87 | 88 | let set tag ~doc ref_ () = 89 | Command.Spec.( 90 | step (fun main bool -> 91 | if bool then ref_ := true; 92 | main) 93 | +> flag tag no_arg ~doc) 94 | ;; 95 | 96 | let clear tag ~doc ref_ () = 97 | Command.Spec.( 98 | step (fun main bool -> 99 | if bool then ref_ := false; 100 | main) 101 | +> flag tag no_arg ~doc) 102 | ;; 103 | 104 | let noarg tag ~doc fct () = 105 | Command.Spec.( 106 | step (fun main bool -> 107 | if bool then fct (); 108 | main) 109 | +> flag tag no_arg ~doc) 110 | ;; 111 | end 112 | 113 | module Flags = struct 114 | let split_files string = 115 | let files = String.split ~on:' ' string in 116 | List.map files ~f:String.strip 117 | ;; 118 | 119 | let add_file tag version = 120 | let add sources = 121 | let sources = 122 | match version with 123 | | `v1 -> `v1 sources 124 | | `v2 -> `v2 sources 125 | | `util -> `util sources 126 | in 127 | Queue.enqueue files sources 128 | in 129 | Flag.string 130 | tag 131 | ~doc:" add one or several ocaml config files to be loaded (sep by ' ')" 132 | add 133 | ;; 134 | 135 | let rev_append_flags rev_acc flags = 136 | let flags = String.split ~on:' ' flags in 137 | let fold acc flag = if String.is_empty flag then acc else flag :: acc in 138 | rev_acc := List.fold ~f:fold ~init:!rev_acc flags 139 | ;; 140 | 141 | let v1 = add_file "-v1" `v1 142 | let v2 = add_file "-v2" `v2 143 | let util = add_file "-f" `util 144 | 145 | let embed = 146 | Flag.set 147 | "-embed" 148 | ~doc:" use the embedded mode of ocaml_plugin (needs standalone exe though)" 149 | embed_mode 150 | ;; 151 | 152 | let error = 153 | Flag.set 154 | "-error" 155 | ~doc: 156 | (Printf.sprintf " load an ill-typed config to see what happens %s" conf_v1_error) 157 | load_error 158 | ;; 159 | 160 | let clean = Flag.set "-clean" ~doc:" clean the builddir after dynamic loading" clean 161 | 162 | let no_default = 163 | Flag.clear 164 | "-n" 165 | ~doc:" do not load the default conf files, use custom files only" 166 | default 167 | ;; 168 | 169 | let temp_dir = 170 | Flag.set 171 | "-tmp" 172 | ~doc:(Printf.sprintf " use a temp dir instead of %s" builddir) 173 | temp_dir 174 | ;; 175 | 176 | let include_dir = 177 | Flag.string 178 | "-I" 179 | ~doc:" Add to the list of include directories" 180 | (fun dir -> include_directories := dir :: !include_directories) 181 | ;; 182 | 183 | let cmx_flag = 184 | Flag.string 185 | "-cmx-f" 186 | ~doc:" Add flag to the ocamlopt compilation of the cmx" 187 | (rev_append_flags cmx_flags) 188 | ;; 189 | 190 | let cmxs_flag = 191 | Flag.string 192 | "-cmxs-f" 193 | ~doc:" Add flag to the ocamlopt -shared compilation of the cmxs" 194 | (rev_append_flags cmxs_flags) 195 | ;; 196 | 197 | let all () = 198 | Command.Spec.( 199 | step (fun main -> main ()) 200 | ++ v1 () 201 | ++ v2 () 202 | ++ util () 203 | ++ embed () 204 | ++ error () 205 | ++ clean () 206 | ++ no_default () 207 | ++ include_dir () 208 | ++ temp_dir () 209 | ++ cmx_flag () 210 | ++ cmxs_flag () 211 | ++ Command.Spec.step (fun k () -> k) 212 | +> Ocaml_plugin.Private.Shell.flags) 213 | ;; 214 | end 215 | 216 | let readme () = 217 | "This toy exe is intended to:\n\ 218 | \ * test the ocaml_plugin library\n\ 219 | \ * show a code sample for potential users of the library\n\n\ 220 | You can try to load some custom ocaml source files,\n\ 221 | play a bit with the options to test and see what happens\n\ 222 | in case of type errors, etc.\n" 223 | ;; 224 | 225 | let summary = "simple example to test the ocaml_plugin library" 226 | 227 | let handle_error load = function 228 | | Result.Ok m -> load m 229 | | Result.Error e -> Core.Printf.eprintf "Error:\n%s\n%!" (Error.to_string_hum e) 230 | ;; 231 | 232 | let load_file loader = function 233 | | `v1 files -> 234 | let v1 = Config.V1.Load.load_ocaml_src_files loader (Flags.split_files files) in 235 | v1 >>| handle_error Ocaml_plugin_sample.Dsl.register_v1 236 | | `v2 files -> 237 | let v2 = Config.V2.Load.load_ocaml_src_files loader (Flags.split_files files) in 238 | v2 >>| handle_error Ocaml_plugin_sample.Dsl.register_v2 239 | | `util files -> 240 | let res = 241 | Ocaml_plugin.Dynloader.Side_effect.load_ocaml_src_files 242 | loader 243 | (Flags.split_files files) 244 | in 245 | res >>| handle_error ignore 246 | ;; 247 | 248 | let load_default loader = 249 | let%bind () = load_file loader (`v1 conf_01) in 250 | let v2 = Config.V2.Load.load_ocaml_src_files loader [ conf_util; conf_02 ] in 251 | v2 >>| handle_error Ocaml_plugin_sample.Dsl.register_v2 252 | ;; 253 | 254 | let main () () = 255 | let k_clean_loader = 256 | let compilation_directory = if !temp_dir then None else Some builddir in 257 | let include_directories = 258 | let directories = List.rev !include_directories in 259 | if !default && not !embed_mode then def_include @ directories else directories 260 | in 261 | let cmx_flags = List.rev !cmx_flags in 262 | let cmxs_flags = List.rev !cmxs_flags in 263 | if !embed_mode 264 | then ( 265 | let build = 266 | Ocaml_plugin.Compiler.create ~include_directories ~cmx_flags ~cmxs_flags () 267 | in 268 | match%bind build with 269 | | Error e -> 270 | Core.Printf.eprintf "Cannot build embed loader: %s" (Error.to_string_hum e); 271 | exit 1 272 | | Ok (`this_needs_manual_cleaning_after compiler) -> 273 | return 274 | ( (fun () -> Ocaml_plugin.Compiler.clean compiler) 275 | , Ocaml_plugin.Compiler.loader compiler )) 276 | else ( 277 | match%map 278 | Ocaml_plugin.Dynloader.create 279 | ?in_dir:compilation_directory 280 | ~cmx_flags 281 | ~cmxs_flags 282 | ~include_directories 283 | ~ocamlopt_opt 284 | () 285 | with 286 | | Error e -> Error.raise e 287 | | Ok loader -> (fun () -> Ocaml_plugin.Dynloader.clean loader), loader) 288 | in 289 | let dt = 290 | let%bind k_clean, loader = k_clean_loader in 291 | let%bind () = if !default then load_default loader else Deferred.return () in 292 | let%bind () = 293 | if !load_error then load_file loader (`v1 conf_v1_error) else Deferred.return () 294 | in 295 | let%bind () = 296 | Deferred.Queue.iter ~how:`Sequential ~f:(load_file loader) files 297 | >>| Ocaml_plugin_sample.Dsl.exec 298 | in 299 | match%map if !clean then k_clean () else Deferred.return (Ok ()) with 300 | | Error e -> Error.raise e 301 | | Ok () -> () 302 | in 303 | (dt >>> fun () -> shutdown 0); 304 | Deferred.never () 305 | ;; 306 | 307 | let run_command = 308 | Command.async_spec ~summary ~readme (Flags.all ()) main ~behave_nicely_in_pipeline:false 309 | ;; 310 | 311 | 312 | let command = 313 | Command.group 314 | ~summary:"Toy sample program for ocaml_plugin" 315 | [ "run", run_command 316 | ; "check-plugin-v1", Config.V1.check_plugin_cmd () 317 | ; "check-plugin-v2", Config.V2.check_plugin_cmd () 318 | ] 319 | ;; 320 | 321 | let () = Exn.handle_uncaught ~exit:true (fun () -> Command_unix.run command) 322 | -------------------------------------------------------------------------------- /sample/bin/what_to_test.txt: -------------------------------------------------------------------------------- 1 | This toy application is meant to demo various uses of the plugin library. 2 | Here is a small list of what to test with the run executable: 3 | In any case, you might want to use -shell-verbose or -shell-echo 4 | to have a better idea of what is happening. 5 | 6 | UNEMBEDDED MODE 7 | --------------- 8 | 9 | this mode uses a shared OCaml compiler found in the path, 10 | and need -I option to find its needed cmi files 11 | 12 | ./run.exe 13 | default command, it loads 3 config files without errors 14 | 15 | ./run.exe -error 16 | try to load config_v1_error.ml which is not well typed 17 | fail with a proper type error message 18 | 19 | ./run.exe -n -v1 config/config_01.ml 20 | try to load without adding the -I flags to the cmi 21 | this fail with an Unbound module Ocaml_plugin 22 | 23 | ./run.exe -n -I . -I ../lib -v1 config/config_01.ml 24 | works well 25 | 26 | ./run.exe -n -I . -I ../lib -v2 config/config_02.ml 27 | should not work because config_v2 uses some utility functions 28 | defined in config/config_util.ml 29 | this fail with an Unbound module Config_util 30 | 31 | ./run.exe -n -I . -I ../lib -v2 'config/config_util.ml config/config_02.ml' 32 | works well 33 | 34 | You can use -tmp as well as -clean if you are not interested in seeing 35 | the copied files and the compilation directory. 36 | 37 | EMBEDDED MODE (STANDALONE EXECUTABLES) 38 | -------------------------------------- 39 | 40 | This mode is more tricky, it uses an ocamlopt embedded in the executable 41 | as well as cmi files so that the resulting executable do not need 42 | any of them. The embedded files are batches together in tgz file that gets 43 | appended after the binary code. The new binary is called -standalone by convention. 44 | 45 | There is a util provided in the bin/ directory to create standalone executables: 46 | 47 | ../bin/ocaml_embed_compiler.exe -exe ./run.exe -cc $(which ocamlopt) dsl.cmi ../lib/ocaml_plugin.cmi $(ocamlopt -where)/pervasives.cmi -o ./run-standalone.exe 48 | 49 | you can extract back the archive embedded in the executable using: 50 | ../bin/ocaml_embed_compiler.exe -x ./run-standalone.exe 51 | 52 | Then, you can try: 53 | 54 | ./run-standalone.exe -embed 55 | work well 56 | 57 | ./run.exe -embed 58 | fail during the extraction of embedded section since the executable is not 59 | standalone 60 | 61 | You can try also to forget an cmi file and see what happen 62 | 63 | ../bin/ocaml_embed_compiler.exe -exe run.exe -cc $(which ocamlopt) ../lib/ocaml_plugin.cmi -o run-standalone.exe 64 | ./run-standalone.exe -embed 65 | fail with an unbound module (dsl.cmi is missing) 66 | 67 | BUILD RULES 68 | ----------- 69 | 70 | Depending on your build-system, you probably want to add a special rul to build 71 | the standalone version of the executable (calling ocaml_embed_compiler). 72 | At JS we have a special rule in OMakeroot where the set of cmi files to embed is 73 | configurable via a variable. 74 | In the release, there is a rule to include a bunch of cmi by default. 75 | 76 | ------------- 77 | You can also try with some more config files. 78 | -------------------------------------------------------------------------------- /sample/config/config_01.ml: -------------------------------------------------------------------------------- 1 | (** 2 | This is a standalone config for main 3 | *) 4 | 5 | module Fancy = struct 6 | let x = "I can use fancy OCaml features in my config files" 7 | end 8 | 9 | (* 10 | We open the main Api to simulate DSL keywords 11 | make, register, etc... 12 | *) 13 | open Ocaml_plugin_sample.Dsl 14 | 15 | (** in a sexp DSL, this would be: 16 | (job something) 17 | *) 18 | 19 | (* in OCaml, this gets written : *) 20 | let job = make_v1 Fancy.x 21 | -------------------------------------------------------------------------------- /sample/config/config_02.ml: -------------------------------------------------------------------------------- 1 | let x = "from config_02" 2 | let job = Ocaml_plugin_sample.Dsl.make_v2 (Config_util.f x) 3 | -------------------------------------------------------------------------------- /sample/config/config_util.ml: -------------------------------------------------------------------------------- 1 | (** 2 | This config is different, it is a library config file. 3 | Grass uses such jobs file to overwrite e.g. some builtins 4 | *) 5 | let f x = x ^ " using some config_util utility functions" 6 | -------------------------------------------------------------------------------- /sample/config/config_v1_error.ml: -------------------------------------------------------------------------------- 1 | (* this is a wrong config file containing type errors in it *) 2 | let job = 42 3 | -------------------------------------------------------------------------------- /sample/config/syntax_error.ml: -------------------------------------------------------------------------------- 1 | (* 2 | we want the error report to tell us the correct file, with the correct line 3 | *) 4 | 5 | let f x = 4513^&#$%1645!#^$$ 6 | -------------------------------------------------------------------------------- /sample/src/dsl.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | type t1 = string 4 | 5 | let make_v1 s = s 6 | 7 | module type Config_intf_v1 = sig 8 | val job : t1 9 | end 10 | 11 | let univ_constr_v1 : (module Config_intf_v1) Ocaml_plugin.Dynloader.Univ_constr.t = 12 | Ocaml_plugin.Dynloader.Univ_constr.create () 13 | ;; 14 | 15 | type t2 = string 16 | 17 | let make_v2 s = s 18 | 19 | module type Config_intf_v2 = sig 20 | val job : t2 21 | end 22 | 23 | let univ_constr_v2 : (module Config_intf_v2) Ocaml_plugin.Dynloader.Univ_constr.t = 24 | Ocaml_plugin.Dynloader.Univ_constr.create () 25 | ;; 26 | 27 | let table_v1 = ref ([] : (module Config_intf_v1) list) 28 | let register_v1 m = table_v1 := m :: !table_v1 29 | let table_v2 = ref ([] : (module Config_intf_v2) list) 30 | let register_v2 m = table_v2 := m :: !table_v2 31 | 32 | let print_m1 m = 33 | let module M = (val m : Config_intf_v1) in 34 | print_endline M.job 35 | ;; 36 | 37 | let print_m2 m = 38 | let module M = (val m : Config_intf_v2) in 39 | print_endline M.job 40 | ;; 41 | 42 | let exec () = 43 | Printf.printf "Starting the configured runtime\n%!"; 44 | List.iter ~f:print_m1 !table_v1; 45 | List.iter ~f:print_m2 !table_v2; 46 | Printf.printf "ending the runtime\n%!" 47 | ;; 48 | -------------------------------------------------------------------------------- /sample/src/dsl.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | type t1 4 | 5 | val make_v1 : string -> t1 6 | 7 | module type Config_intf_v1 = sig 8 | val job : t1 9 | end 10 | 11 | val univ_constr_v1 : (module Config_intf_v1) Ocaml_plugin.Dynloader.Univ_constr.t 12 | 13 | type t2 14 | 15 | val make_v2 : string -> t2 16 | 17 | module type Config_intf_v2 = sig 18 | val job : t2 19 | end 20 | 21 | val univ_constr_v2 : (module Config_intf_v2) Ocaml_plugin.Dynloader.Univ_constr.t 22 | val register_v1 : (module Config_intf_v1) -> unit 23 | val register_v2 : (module Config_intf_v2) -> unit 24 | 25 | (** Do something with the registered jobs. *) 26 | val exec : unit -> unit 27 | -------------------------------------------------------------------------------- /sample/src/dune: -------------------------------------------------------------------------------- 1 | (library (name ocaml_plugin_sample) (libraries core ocaml_plugin) 2 | (preprocess (pps ppx_jane))) -------------------------------------------------------------------------------- /src/compiler.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | open! Import 4 | module E = Deferred.Or_error 5 | 6 | let tar_id = "dynlink.tgz" 7 | let ocamlopt_opt = "ocamlopt.opt" 8 | let ocamldep_opt = "ocamldep.opt" 9 | let ppx_exe = "ppx.exe" 10 | let persistent_archive_subdir = "compiler" 11 | 12 | module Archive_metadata = struct 13 | (* Not trying to be stable here: it's simpler and it's not clear why stability would be 14 | useful: if this type changes, there is no hope that Info.is_up_to_date could return 15 | [true] (because at least ocaml_plugin.cmi changes since the type is exposed, causing 16 | archive_digests to differ), so whether or not we can read old versions of the type, 17 | we'll re-extract the archive. *) 18 | type t = 19 | { ppx_is_embedded : bool 20 | ; archive_digests : Plugin_cache.Digest.t String.Map.t 21 | } 22 | [@@deriving sexp] 23 | end 24 | 25 | (* Map of the directories contents: 26 | - build_dir: /tmp/ocaml_plugin_XXXXX/{m_dyn_1_.ml,m_dyn_1_.o,m_dyn_1_.cmx,m_dyn_1_.cmxs,...} 27 | Deleted on clean up. 28 | 29 | - compiler_dir: 30 | Either /tmp/ocaml_plugin_XXXXX/{ocamlopt.opt,pervasives.cmi,pa_sexp_conv.cmo,...} 31 | or $user_specified_dir/compiler/{archive-info.sexp,the other files}. 32 | Locked if it is shared using $user_specified_dir/compiler.lock. Deleted on clean up 33 | if they are the same directory otherwise deleted when the digest of the archive 34 | doesn't match the info anymore. 35 | 36 | - cache dir: 37 | $user_specified_dir/cmxs-cache/{cache-info.sexp, abcd-efgh-ijkl-mnop.cmxs} 38 | copied there from build_dir 39 | Locked because it can be shared using $user_specified_dir/cmxs-cache.lock. 40 | 41 | Both locks are released on clean up. *) 42 | 43 | module Archive_lock = struct 44 | type t = 45 | | Cleaned 46 | | Cleaning of unit Deferred.Or_error.t 47 | | Locked of string 48 | end 49 | 50 | type t = 51 | { loader : Dynloader.t 52 | ; archive_lock : Archive_lock.t ref 53 | } 54 | [@@deriving fields] 55 | 56 | let clean t = 57 | let%bind r1 = Dynloader.clean t.loader in 58 | let%map r2 = 59 | match t.archive_lock.contents with 60 | | Archive_lock.Cleaned -> Deferred.Or_error.ok_unit 61 | | Archive_lock.Cleaning def -> def 62 | | Archive_lock.Locked lock_filename -> 63 | let clean = Lock_file_async.Nfs.unlock lock_filename in 64 | t.archive_lock.contents <- Archive_lock.Cleaning clean; 65 | let%map res = clean in 66 | t.archive_lock.contents <- Archive_lock.Cleaned; 67 | res 68 | in 69 | Or_error.combine_errors_unit [ r1; r2 ] 70 | ;; 71 | 72 | (* This external declaration should be implemented by the c files generated by 73 | ocaml_embed_compiler.exe, which is normally called when using an "embed" entry 74 | in the jbuild. There is a default implementation in ocaml_fake_archive.c too. *) 75 | external archive : unit -> Bigstring.t = "ocaml_plugin_archive" 76 | 77 | let archive () = 78 | let bstr = archive () in 79 | let dummy = "dummy" in 80 | if Bigstring.length bstr = String.length dummy 81 | && String.equal (Bigstring.to_string bstr) dummy 82 | then None 83 | else Some bstr 84 | ;; 85 | 86 | external archive_metadata_binding : unit -> string = "ocaml_plugin_archive_metadata" 87 | 88 | let archive_metadata = 89 | lazy 90 | (let str = archive_metadata_binding () in 91 | let dummy = "dummy" in 92 | if String.equal str dummy 93 | then 94 | Or_error.error_string 95 | "This executable does not have an embedded archive, although this is required \ 96 | when using [Ocaml_plugin]. A likely cause is that the build of the binary is \ 97 | missing the step involving [ocaml_embed_compiler]." 98 | else Ok (Sexp.of_string_conv_exn str [%of_sexp: Archive_metadata.t])) 99 | ;; 100 | 101 | let embedded_files () = 102 | Or_error.map (force archive_metadata) ~f:(fun m -> m.archive_digests) 103 | ;; 104 | 105 | let () = 106 | match Core.Sys.getenv "OCAML_PLUGIN_DUMP_ARCHIVE" with 107 | | None -> () 108 | | Some _ -> 109 | (* This is a way of extracting the archive from the executable. It can be used like 110 | this: OCAML_PLUGIN_DUMP_ARCHIVE= ./run.exe | tar -xz 111 | We exit to avoid running any side effects that could be done later at toplevel. *) 112 | (match force archive_metadata with 113 | | Error _ -> Core.Printf.eprintf "No archive metadata\n%!" 114 | | Ok archive_metadata -> 115 | Core.Printf.eprintf 116 | !"archive metadata: %{sexp:Archive_metadata.t}\n%!" 117 | archive_metadata); 118 | (match archive () with 119 | | None -> Core.Printf.printf "No archive\n%!" 120 | | Some bstr -> 121 | Bigstring_unix.really_output stdout bstr; 122 | Out_channel.flush stdout); 123 | Stdlib.exit 0 124 | ;; 125 | 126 | let save_archive_to destination = 127 | Deferred.Or_error.try_with ~rest:`Log (fun () -> 128 | match archive () with 129 | | None -> failwith "There is no embedded compiler in the current executable" 130 | | Some contents -> 131 | Writer.with_file_atomic destination ~f:(fun w -> 132 | Writer.schedule_bigstring w contents; 133 | Deferred.unit)) 134 | ;; 135 | 136 | type 'a create_arguments = 137 | (?persistent_archive_dirpath:string -> 'a) Dynloader.create_arguments 138 | 139 | module Plugin_archive : sig 140 | val extract 141 | : archive_lock:Archive_lock.t ref 142 | -> persistent:bool 143 | -> string 144 | -> unit Deferred.Or_error.t 145 | end = struct 146 | module Info = struct 147 | type t = 148 | { infos : (string * Sexp.t) list 149 | ; build_info : Sexp.t 150 | ; archive_metadata : Archive_metadata.t 151 | } 152 | [@@deriving sexp] 153 | 154 | let t_of_sexp = Sexp.of_sexp_allow_extra_fields_recursively t_of_sexp 155 | let info_file_name = "archive-info.sexp" 156 | let info_file dir = dir ^/ info_file_name 157 | 158 | let create () = 159 | let%bind.E archive_metadata = return (force archive_metadata) in 160 | let%map.E infos = 161 | Deferred.Or_error.try_with ~rest:`Log ~extract_exn:true (fun () -> 162 | let%map login = Unix.getlogin () in 163 | [ "version", sexp_of_string Params.version 164 | ; "login", sexp_of_string login 165 | ; "hostname", sexp_of_string (Unix.gethostname ()) 166 | ; "sys_argv", [%sexp_of: string array] (Sys.get_argv ()) 167 | ]) 168 | in 169 | let build_info = Params.build_info_as_sexp in 170 | { infos; build_info; archive_metadata } 171 | ;; 172 | 173 | let info_file_perm = 0o644 174 | 175 | let save dir = 176 | let%bind.E t = create () in 177 | Deferred.Or_error.try_with ~rest:`Log ~extract_exn:true (fun () -> 178 | Writer.save_sexp ~perm:info_file_perm (info_file dir) (sexp_of_t t)) 179 | ;; 180 | 181 | let load dir = 182 | Deferred.Or_error.try_with ~rest:`Log ~extract_exn:true (fun () -> 183 | Reader.load_sexp_exn (info_file dir) t_of_sexp) 184 | ;; 185 | 186 | let is_up_to_date t ~dir = 187 | match force archive_metadata with 188 | | Error _ as error -> return error 189 | | Ok archive_metadata -> 190 | let digests = archive_metadata.archive_digests in 191 | if [%compare.equal: Plugin_cache.Digest.t String.Map.t] 192 | digests 193 | t.archive_metadata.archive_digests 194 | then ( 195 | (* Here we assume people won't change the contents of our files, but we could 196 | not make such an assumption and check the digests instead. Or make the files 197 | read-only. We expect neither missing files (obviously), neither additional 198 | files (like extra cmis because they can impact the build). *) 199 | let%map.E files = 200 | Deferred.Or_error.try_with ~rest:`Log (fun () -> Sys.readdir dir) 201 | in 202 | let files_extracted = 203 | Set.diff 204 | (String.Set.of_list (Array.to_list files)) 205 | (String.Set.of_list [ info_file_name; tar_id ]) 206 | in 207 | let files_we_would_extract = Map.key_set digests in 208 | String.Set.equal files_extracted files_we_would_extract) 209 | else return (Ok false) 210 | ;; 211 | end 212 | 213 | let extract_throttle = Throttle.Sequencer.create ~continue_on_error:true () 214 | 215 | let extract ~archive_lock ~persistent compiler_dir = 216 | let extract () = 217 | let%bind.E () = 218 | if_ persistent (fun () -> 219 | let lock_filename = compiler_dir ^ ".lock" in 220 | let%bind.E () = 221 | Monitor.try_with_or_error ~rest:`Log (fun () -> 222 | Unix.mkdir ~p:() ~perm:0o755 (Filename.dirname lock_filename)) 223 | in 224 | let%bind.E () = Lock_file_async.Nfs.create lock_filename in 225 | archive_lock := Archive_lock.Locked lock_filename; 226 | let%bind.E () = Shell.rm ~r:() ~f:() [ compiler_dir ] in 227 | Monitor.try_with_or_error ~rest:`Log (fun () -> 228 | Unix.mkdir ~p:() ~perm:0o755 compiler_dir)) 229 | in 230 | let destination = compiler_dir ^/ tar_id in 231 | let%bind.E () = save_archive_to destination in 232 | let%bind.E () = Tar.extract ~working_dir:compiler_dir destination in 233 | if_ persistent (fun () -> Info.save compiler_dir) 234 | in 235 | if persistent 236 | then 237 | Throttle.enqueue extract_throttle (fun () -> 238 | match%bind Info.load compiler_dir with 239 | | Error _ -> extract () 240 | | Ok info -> 241 | (match%bind Info.is_up_to_date info ~dir:compiler_dir with 242 | | Ok true -> Deferred.Or_error.ok_unit 243 | | Error _ | Ok false -> extract ())) 244 | else extract () 245 | ;; 246 | end 247 | 248 | let create 249 | ?in_dir 250 | ?in_dir_perm 251 | ?include_directories 252 | ?custom_warnings_spec 253 | ?strict_sequence 254 | ?cmx_flags 255 | ?cmxs_flags 256 | ?trigger_unused_value_warnings_despite_mli 257 | ?use_cache 258 | ?persistent_archive_dirpath 259 | () 260 | = 261 | let archive_lock = ref Archive_lock.Cleaned in 262 | let%bind.E persistent_archive_dirpath = 263 | match persistent_archive_dirpath with 264 | | None -> Deferred.return (Ok None) 265 | | Some path -> 266 | let%map.E path = Shell.absolute_pathname path in 267 | Some (path ^/ persistent_archive_subdir) 268 | in 269 | let in_compiler_dir exec = 270 | Option.value persistent_archive_dirpath ~default:"." ^/ exec 271 | in 272 | let include_directories = 273 | match persistent_archive_dirpath with 274 | | None -> include_directories 275 | | Some dir -> Some (dir :: Option.value include_directories ~default:[]) 276 | in 277 | let ocamlopt_opt = in_compiler_dir ocamlopt_opt in 278 | let ocamldep_opt = in_compiler_dir ocamldep_opt in 279 | let nostdlib flags = "-nostdlib" :: Option.value ~default:[] flags in 280 | let cmx_flags = nostdlib cmx_flags in 281 | let cmxs_flags = nostdlib cmxs_flags in 282 | let preprocessor = 283 | match force archive_metadata with 284 | | Error _ as error -> error 285 | | Ok { ppx_is_embedded; archive_digests = _ } -> 286 | if ppx_is_embedded 287 | then Ok (Dynloader.Preprocessor.Ppx { ppx_exe = in_compiler_dir ppx_exe }) 288 | else Ok Dynloader.Preprocessor.No_preprocessing 289 | in 290 | let%bind.E preprocessor = return preprocessor in 291 | let compilation_config = { Dynloader.Compilation_config.preprocessor } in 292 | let initialize ~directory:build_dir = 293 | let persistent, compiler_dir = 294 | match persistent_archive_dirpath with 295 | | None -> false, build_dir 296 | | Some archive_dirpath -> true, archive_dirpath 297 | in 298 | Plugin_archive.extract ~archive_lock ~persistent compiler_dir 299 | in 300 | let%bind.E loader = 301 | Dynloader.create 302 | ?in_dir 303 | ?in_dir_perm 304 | ?include_directories 305 | ?custom_warnings_spec 306 | ?strict_sequence 307 | ~cmx_flags 308 | ~cmxs_flags 309 | ?trigger_unused_value_warnings_despite_mli 310 | ?use_cache 311 | ~initialize 312 | ~compilation_config 313 | ~ocamlopt_opt 314 | ~ocamldep_opt 315 | () 316 | in 317 | let compiler = { loader; archive_lock } in 318 | Deferred.return (Ok (`this_needs_manual_cleaning_after compiler)) 319 | ;; 320 | 321 | let created_but_not_cleaned = Bag.create () 322 | 323 | let () = 324 | (* I think we can rely on the at_shutdown handlers only firing in the current process 325 | and not in the forks. In that case, worse things could happen than deleting the 326 | compiler under our feet. *) 327 | Shutdown.at_shutdown (fun () -> 328 | Deferred.List.iter 329 | ~how:`Sequential 330 | (Bag.to_list created_but_not_cleaned) 331 | ~f:(fun compiler -> 332 | match%map clean compiler with 333 | | Ok () -> () 334 | | Error _ -> ())) 335 | ;; 336 | 337 | let is_shutting_down () = 338 | match Shutdown.shutting_down () with 339 | | No -> false 340 | | Yes _ -> true 341 | ;; 342 | 343 | let with_compiler 344 | ?in_dir 345 | ?in_dir_perm 346 | ?include_directories 347 | ?custom_warnings_spec 348 | ?strict_sequence 349 | ?cmx_flags 350 | ?cmxs_flags 351 | ?trigger_unused_value_warnings_despite_mli 352 | ?use_cache 353 | ?persistent_archive_dirpath 354 | ~f 355 | () 356 | = 357 | if is_shutting_down () 358 | then return (Or_error.error_s [%sexp "Shutting_down", [%here]]) 359 | else ( 360 | let%bind.E (`this_needs_manual_cleaning_after compiler) = 361 | create 362 | ?in_dir 363 | ?in_dir_perm 364 | ?include_directories 365 | ?custom_warnings_spec 366 | ?strict_sequence 367 | ?cmx_flags 368 | ?cmxs_flags 369 | ?trigger_unused_value_warnings_despite_mli 370 | ?use_cache 371 | ?persistent_archive_dirpath 372 | () 373 | in 374 | if is_shutting_down () 375 | then ( 376 | let%bind.E () = clean compiler in 377 | return (Or_error.error_s [%sexp "Shutting_down", [%here]])) 378 | else ( 379 | let bag_elem = Bag.add created_but_not_cleaned compiler in 380 | let%bind result = 381 | Deferred.Or_error.try_with_join ~rest:`Log ~extract_exn:true (fun () -> 382 | f compiler) 383 | in 384 | Bag.remove created_but_not_cleaned bag_elem; 385 | let%map r2 = clean compiler in 386 | match result, r2 with 387 | | Ok result, Ok () -> Ok result 388 | | Ok _, (Error _ as error) -> error 389 | | Error e1, Error e2 -> Error (Error.of_list [ e1; e2 ]) 390 | | (Error _ as error), Ok () -> error)) 391 | ;; 392 | 393 | let make_load_ocaml_src_files load_ocaml_src_files = 394 | let aux 395 | ?in_dir 396 | ?in_dir_perm 397 | ?include_directories 398 | ?custom_warnings_spec 399 | ?strict_sequence 400 | ?cmx_flags 401 | ?cmxs_flags 402 | ?trigger_unused_value_warnings_despite_mli 403 | ?use_cache 404 | ?persistent_archive_dirpath 405 | files 406 | = 407 | let f compiler = 408 | let loader = loader compiler in 409 | load_ocaml_src_files loader files 410 | in 411 | with_compiler 412 | ?in_dir 413 | ?in_dir_perm 414 | ?include_directories 415 | ?custom_warnings_spec 416 | ?strict_sequence 417 | ?cmx_flags 418 | ?cmxs_flags 419 | ?trigger_unused_value_warnings_despite_mli 420 | ?use_cache 421 | ?persistent_archive_dirpath 422 | ~f 423 | () 424 | in 425 | aux 426 | ;; 427 | 428 | let make_check_plugin_cmd ~check_ocaml_src_files ~load_ocaml_src_files () = 429 | let execute_plugin_toplevel_switch = "-execute-plugin-toplevel" in 430 | Command.async 431 | ~summary:"Check a plugin for compilation errors" 432 | ~readme:(fun () -> 433 | String.concat 434 | [ "This command checks that a plugin compiles. It either succeeds quietly, or \ 435 | outputs\n\ 436 | compilation errors and fails.\n\n\ 437 | When it is deemed safe to execute the toplevel of a plugin, one can supply \ 438 | the switch\n\ 439 | [" 440 | ; execute_plugin_toplevel_switch 441 | ; "] to check for runtime exceptions at toplevel." 442 | ]) 443 | (let open Command.Let_syntax in 444 | let%map_open plugin_filenames = 445 | anon (sequence ("path/to/plugin.ml" %: Filename_unix.arg_type)) 446 | and execute_plugin_toplevel = 447 | flag 448 | execute_plugin_toplevel_switch 449 | no_arg 450 | ~doc:" Run the plugin's toplevel to check for runtime errors" 451 | and use_ocamldep = 452 | flag 453 | "-ocamldep" 454 | no_arg 455 | ~doc:" Use ocamldep. Expect only the main file in the remaining arguments" 456 | and is_verbose = flag "-verbose" no_arg ~doc:" Be more verbose" in 457 | fun () -> 458 | let open! Deferred.Let_syntax in 459 | let f compiler = 460 | let loader = loader compiler in 461 | let%bind.E plugin_filenames = 462 | if use_ocamldep 463 | then ( 464 | match plugin_filenames with 465 | | [ main ] -> Dynloader.find_dependencies loader main 466 | | [] | _ :: _ :: _ -> 467 | return 468 | (Or_error.error 469 | "Give only the main file when using option -ocamldep" 470 | plugin_filenames 471 | [%sexp_of: string list])) 472 | else return (Ok plugin_filenames) 473 | in 474 | if is_verbose 475 | then Print.printf "checking: %s\n%!" (String.concat ~sep:" " plugin_filenames); 476 | if execute_plugin_toplevel 477 | then load_ocaml_src_files loader plugin_filenames >>| Or_error.map ~f:ignore 478 | else check_ocaml_src_files loader plugin_filenames 479 | in 480 | match%map with_compiler ~f () with 481 | | Ok () -> 482 | if is_verbose then Print.printf "ok\n%!"; 483 | Shutdown.shutdown 0 484 | | Error err -> 485 | Print.eprintf "%s\n%!" (Error.to_string_hum err); 486 | Shutdown.shutdown 1) 487 | ~behave_nicely_in_pipeline:false 488 | ;; 489 | 490 | 491 | module type S = sig 492 | type t 493 | 494 | val load_ocaml_src_files : (string list -> t Deferred.Or_error.t) create_arguments 495 | 496 | val load_ocaml_src_files_without_running_them 497 | : (string list -> (unit -> t) Deferred.Or_error.t) create_arguments 498 | 499 | val check_ocaml_src_files : (string list -> unit Deferred.Or_error.t) create_arguments 500 | val check_plugin_cmd : unit -> Command.t 501 | 502 | module Load : Dynloader.S with type t := t 503 | end 504 | 505 | module Make (X : Dynloader.Module_type) = struct 506 | module Load = Dynloader.Make (X) 507 | 508 | let load_ocaml_src_files = make_load_ocaml_src_files Load.load_ocaml_src_files 509 | 510 | let load_ocaml_src_files_without_running_them = 511 | make_load_ocaml_src_files Load.load_ocaml_src_files_without_running_them 512 | ;; 513 | 514 | let check_ocaml_src_files = make_load_ocaml_src_files Load.check_ocaml_src_files 515 | 516 | let check_plugin_cmd = 517 | make_check_plugin_cmd 518 | ~check_ocaml_src_files:Load.check_ocaml_src_files 519 | ~load_ocaml_src_files:Load.load_ocaml_src_files 520 | ;; 521 | end 522 | 523 | module Side_effect = struct 524 | module Load = Dynloader.Side_effect 525 | 526 | let load_ocaml_src_files = make_load_ocaml_src_files Load.load_ocaml_src_files 527 | 528 | let load_ocaml_src_files_without_running_them = 529 | make_load_ocaml_src_files Load.load_ocaml_src_files_without_running_them 530 | ;; 531 | 532 | let check_ocaml_src_files = make_load_ocaml_src_files Load.check_ocaml_src_files 533 | 534 | let check_plugin_cmd = 535 | make_check_plugin_cmd 536 | ~check_ocaml_src_files:Load.check_ocaml_src_files 537 | ~load_ocaml_src_files:Load.load_ocaml_src_files 538 | ;; 539 | end 540 | -------------------------------------------------------------------------------- /src/compiler.mli: -------------------------------------------------------------------------------- 1 | (** This module offers an higher level api over Dynloader. This retrieves the 2 | compiler and a bunch of cmi files embedded in the current executable, and use them to 3 | do the compilation of ocaml source files, before loading them using Dynlink. The 4 | compilation steps happen in Async. 5 | 6 | This is meant to be used in unix only, in particular because it uses /proc to 7 | determine the location of the exec code being run. *) 8 | open! Core 9 | 10 | open! Async 11 | 12 | (** 13 | The convention over the name of the executables inside the archive. 14 | All are native executables (.opt) 15 | *) 16 | val ocamlopt_opt : string 17 | 18 | val ocamldep_opt : string 19 | val ppx_exe : string 20 | 21 | (** Mutable type to get the compiler and the cmi which must have been embedded in the 22 | executable. *) 23 | type t 24 | 25 | module Archive_metadata : sig 26 | type t = 27 | { ppx_is_embedded : bool 28 | ; archive_digests : Plugin_cache.Digest.t String.Map.t 29 | } 30 | [@@deriving sexp_of] 31 | end 32 | 33 | (** List of files in the archive embedded into the current executable. *) 34 | val embedded_files : unit -> Plugin_cache.Digest.t String.Map.t Or_error.t 35 | 36 | type 'a create_arguments = 37 | (?persistent_archive_dirpath:string 38 | (** Keep the extracted archive in some persistent location to avoid paying the cost of 39 | extraction each time a file needs to be compiled. The location passed will not be 40 | cleaned at the end of the execution of the program. The only guarantee given there 41 | is that it is never going to grow more than the size of the embedded archive. If 42 | the persistent location contains a extracted version that is older than the current 43 | executable, the directory is cleaned up and the archive is extracted again. *) 44 | -> 'a) 45 | Dynloader.create_arguments 46 | 47 | (** This is a special utilisation of the Generic Loader. It relies on a few assumptions, 48 | such as a file called ocamlopt.opt is present in the archive, as well as some cmi 49 | files, and uses a tmp compilation_directory. A call to this function will retrieve 50 | the embedded part of the code, and extract it in the current corresponding directory. 51 | The most common use and the default value for [code_file] is [`my_code]. Currently 52 | this library works with native code only. Called in bytecode, this function will 53 | raise. See the documentation of dynloader for other flags, they are passed 54 | internally to that module to create the internal dynloader (in _dir, 55 | custom_warnings_spec, etc.). 56 | 57 | /!\ By using this manual create, you take the responsibility to call [clean t] when 58 | you're done with all the compilation that you want to do with this compiler. Consider 59 | using [with_compiler], [Make] or [load_ocaml_src_files] if this makes your life 60 | simpler. *) 61 | val create 62 | : (unit -> [ `this_needs_manual_cleaning_after of t ] Deferred.Or_error.t) 63 | create_arguments 64 | 65 | (** Call create, do something with the compiler, and then take care of calling clean. In 66 | case an exception or a shutdown happen and f never returns, an attempt to clean the 67 | compiler is still done via an at_shutdown execution. *) 68 | val with_compiler 69 | : (f:(t -> 'a Deferred.Or_error.t) -> unit -> 'a Deferred.Or_error.t) create_arguments 70 | 71 | (** Get the loader using this compiler and these cmi. *) 72 | val loader : t -> Dynloader.t 73 | 74 | (** This will delete the temporary directory created, and remove all the files, included 75 | the files generated by the loader. This function should be used when the compiler has 76 | been created using [create] for advanced use of this module. For a simpler usage, look 77 | at [with_compiler] or the functor below. *) 78 | val clean : t -> unit Deferred.Or_error.t 79 | 80 | module type S = sig 81 | type t 82 | 83 | val load_ocaml_src_files : (string list -> t Deferred.Or_error.t) create_arguments 84 | 85 | val load_ocaml_src_files_without_running_them 86 | : (string list -> (unit -> t) Deferred.Or_error.t) create_arguments 87 | 88 | val check_ocaml_src_files : (string list -> unit Deferred.Or_error.t) create_arguments 89 | 90 | (** Command that checks that the anon files given compile and match the interface [X] 91 | given. Also provides a [-ocamldep] mode allowing only the main file to be passed on 92 | the command line. *) 93 | val check_plugin_cmd : unit -> Command.t 94 | 95 | (** [Load] contains functions similar to the ones above, and can be used if you want to 96 | separate extraction of the compiler from building/loading files. It can be useful if 97 | you want to extract the compiler upfront (to improve latency a bit) or if you want 98 | to share the cost of extracting the compiler for the current executable over 99 | multiple compilations. Probably not needed by the casual user. *) 100 | module Load : Dynloader.S with type t := t 101 | end 102 | 103 | (** This is a wrapper for the similar module in Dynloader that takes care of 104 | cleaning the compiler afterwards. *) 105 | module Make : functor (X : Dynloader.Module_type) -> S with type t := X.t 106 | 107 | (** In some cases, we are not interested by the module, but rather because it uses a side 108 | effect registering mechanism. *) 109 | module Side_effect : S with type t := unit 110 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library (name ocaml_plugin) (public_name ocaml_plugin) 2 | (libraries async core_unix.bigstring_unix core dynlink 3 | core_unix.filename_unix async.lock_file_async core_kernel.uuid 4 | core_unix.uuid core_kernel.version_util) 5 | (c_names ocaml_fake_archive) (preprocess (pps ppx_jane))) -------------------------------------------------------------------------------- /src/dynloader.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | module E = Deferred.Or_error 4 | 5 | let default_disabled_warnings = [ 4; 29; 40; 41; 42; 44; 45; 48; 58; 66; 69; 70 ] 6 | 7 | (* The default policy about warnings *) 8 | let warnings_spec ~disabled_warnings = 9 | let ignores = 10 | List.map disabled_warnings ~f:(fun i -> "-" ^ Int.to_string i) |> String.concat 11 | in 12 | "+a" ^ ignores 13 | ;; 14 | 15 | let default_warnings_spec = warnings_spec ~disabled_warnings:default_disabled_warnings 16 | let index = ref 0 17 | 18 | module Ppx = struct 19 | type t = { ppx_exe : string } 20 | end 21 | 22 | module Preprocessor = struct 23 | type t = 24 | | No_preprocessing 25 | | Ppx of Ppx.t 26 | end 27 | 28 | module Compilation_config = struct 29 | type t = { preprocessor : Preprocessor.t } 30 | 31 | let default = { preprocessor = No_preprocessing } 32 | end 33 | 34 | (* Default values to use for those binaries if their path is not specified. *) 35 | module Default_binaries = struct 36 | let ocamlopt_opt = "ocamlopt.opt" 37 | let ocamldep_opt = "ocamldep.opt" 38 | end 39 | 40 | module Compilation_directory : sig 41 | type t = private { directory : string } 42 | 43 | val create 44 | : initialize:(directory:string -> unit Or_error.t Deferred.t) 45 | -> in_dir:string 46 | -> in_dir_perm:Unix.file_perm option 47 | -> t Or_error.t Deferred.t 48 | end = struct 49 | type t = { directory : string } 50 | 51 | let info_file_name = "info" 52 | let info_file dir = dir ^/ info_file_name 53 | 54 | module Info : sig 55 | val save : info_file:string -> unit Or_error.t Deferred.t 56 | end = struct 57 | (* 58 | save some debug info in the builddir in case this doesn't get cleaned 59 | *) 60 | 61 | type t = 62 | { login : string 63 | ; hostname : string 64 | ; pid : Pid.t 65 | ; sys_argv : string array 66 | ; version : string 67 | ; build_info : Sexp.t 68 | } 69 | [@@deriving sexp_of] 70 | 71 | let create () = 72 | Deferred.Or_error.try_with ~rest:`Log ~extract_exn:true (fun () -> 73 | let hostname = Unix.gethostname () in 74 | let pid = Unix.getpid () in 75 | let build_info = Params.build_info_as_sexp in 76 | let version = Params.version in 77 | let sys_argv = Sys.get_argv () in 78 | let%map login = Unix.getlogin () in 79 | let t = { login; hostname; pid; build_info; version; sys_argv } in 80 | sexp_of_t t) 81 | ;; 82 | 83 | let get = Lazy_deferred.create create 84 | 85 | let save ~info_file = 86 | let%bind.E info = Lazy_deferred.force_exn get in 87 | Deferred.Or_error.try_with ~rest:`Log ~extract_exn:true (fun () -> 88 | Writer.save_sexp ~hum:true info_file info) 89 | ;; 90 | end 91 | 92 | let create ~initialize ~in_dir ~in_dir_perm = 93 | let%bind.E directory = Shell.temp_dir ~in_dir ?perm:in_dir_perm () in 94 | match%bind 95 | let%bind.E () = initialize ~directory in 96 | let%bind.E () = Info.save ~info_file:(info_file directory) in 97 | return (Ok { directory }) 98 | with 99 | | Ok _ as ok -> return ok 100 | | Error e -> 101 | (* if something failed, the rest of the code of ocaml dynloader will never know 102 | about the directory so we should delete it since no one else can. *) 103 | (match%map Shell.rm ~r:() ~f:() [ directory ] with 104 | | Ok () -> Error e 105 | | Error e2 -> Error (Error.of_list [ e; e2 ])) 106 | ;; 107 | end 108 | 109 | (* every t has a different compilation directory *) 110 | type t = 111 | { mutable cleaned : bool 112 | ; cmx_flags : string list 113 | ; cmxs_flags : string list 114 | ; trigger_unused_value_warnings_despite_mli : bool 115 | ; compilation_directory : Compilation_directory.t Or_error.t Lazy_deferred.t 116 | ; compilation_config : Compilation_config.t 117 | ; include_directories : string list 118 | ; ocamlopt_opt : string 119 | ; ocamldep_opt : string 120 | ; cache : Plugin_cache.t Or_error.t Lazy_deferred.t option 121 | } 122 | [@@deriving fields] 123 | 124 | type dynloader = t 125 | 126 | let next_filename () = 127 | let s = Printf.sprintf "m_dyn_%d_.ml" !index in 128 | incr index; 129 | s 130 | ;; 131 | 132 | type 'a create_arguments = 133 | ?in_dir:string 134 | -> ?in_dir_perm:Unix.file_perm 135 | -> ?include_directories:string list 136 | -> ?custom_warnings_spec:string 137 | -> ?strict_sequence:bool 138 | -> ?cmx_flags:string list 139 | -> ?cmxs_flags:string list 140 | -> ?trigger_unused_value_warnings_despite_mli:bool 141 | -> ?use_cache:Plugin_cache.Config.t 142 | -> 'a 143 | 144 | let create 145 | ?(in_dir = Filename.temp_dir_name) 146 | ?in_dir_perm 147 | ?(include_directories = []) 148 | ?(custom_warnings_spec = default_warnings_spec) 149 | ?(strict_sequence = true) 150 | ?(cmx_flags = []) 151 | ?(cmxs_flags = []) 152 | ?(trigger_unused_value_warnings_despite_mli = false) 153 | ?use_cache 154 | ?(initialize = fun ~directory:_ -> return (Ok ())) 155 | ?(compilation_config = Compilation_config.default) 156 | ?(ocamlopt_opt = Default_binaries.ocamlopt_opt) 157 | ?(ocamldep_opt = Default_binaries.ocamldep_opt) 158 | () 159 | = 160 | let cmx_flags = 161 | [ "-no-alias-deps"; "-w"; custom_warnings_spec; "-warn-error"; "+a" ] @ cmx_flags 162 | in 163 | let cmx_flags = 164 | if strict_sequence then "-strict-sequence" :: cmx_flags else cmx_flags 165 | in 166 | if not Dynlink.is_native 167 | then return (Or_error.error_s [%sexp "Ocaml_plugin only works in native code"]) 168 | else ( 169 | let%bind.E include_directories = Shell.absolute_pathnames include_directories in 170 | let cache = 171 | Option.map use_cache ~f:(fun cache_config -> 172 | Lazy_deferred.create (fun () -> Plugin_cache.create cache_config)) 173 | in 174 | let compilation_directory = 175 | Lazy_deferred.create (fun () -> 176 | Compilation_directory.create ~initialize ~in_dir ~in_dir_perm) 177 | in 178 | let cleaned = false in 179 | let t = 180 | { cleaned 181 | ; cmx_flags 182 | ; cmxs_flags 183 | ; trigger_unused_value_warnings_despite_mli 184 | ; compilation_directory 185 | ; compilation_config 186 | ; include_directories 187 | ; ocamlopt_opt 188 | ; ocamldep_opt 189 | ; cache 190 | } 191 | in 192 | Deferred.return (Ok t)) 193 | ;; 194 | 195 | let clean_compilation_directory t = 196 | if not (Lazy_deferred.is_forced t.compilation_directory) 197 | then return (Ok ()) 198 | else ( 199 | match%bind Lazy_deferred.force_exn t.compilation_directory with 200 | | Error _ -> 201 | (* if t.compilation_config failed, then either we couldn't create the temporary 202 | directory, in which case there is nothing to clean, or we failed after in 203 | which case the temporary directory was cleaned there. Either way, things are 204 | fine. *) 205 | return (Ok ()) 206 | | Ok { directory; _ } -> Shell.rm ~r:() ~f:() [ directory ]) 207 | ;; 208 | 209 | let clean_plugin_cache t = 210 | match t.cache with 211 | | None -> return (Ok ()) 212 | | Some cache -> 213 | if not (Lazy_deferred.is_forced cache) 214 | then return (Ok ()) 215 | else ( 216 | match%bind Lazy_deferred.force_exn cache with 217 | | Error _ -> return (Ok ()) 218 | | Ok cache -> Plugin_cache.clean cache) 219 | ;; 220 | 221 | let clean t = 222 | if t.cleaned 223 | then return (Ok ()) 224 | else ( 225 | t.cleaned <- true; 226 | let%bind r1 = clean_compilation_directory t in 227 | let%map r2 = clean_plugin_cache t in 228 | Or_error.combine_errors_unit [ r1; r2 ]) 229 | ;; 230 | 231 | module Univ_constr = struct 232 | type 'a t = 'a Type_equal.Id.t 233 | 234 | let name = "Ocaml_plugin.Dynloader.Univ_constr.t" 235 | let create () = Type_equal.Id.create ~name sexp_of_opaque 236 | end 237 | 238 | module type Module_type = sig 239 | type t 240 | 241 | val t_repr : string 242 | val univ_constr : t Univ_constr.t 243 | val univ_constr_repr : string 244 | end 245 | 246 | type packed_plugin = E : 'a Univ_constr.t * (unit -> 'a) -> packed_plugin 247 | 248 | exception Return_plugin of packed_plugin 249 | 250 | let return_plugin (type a) (constr : a Univ_constr.t) (fct : unit -> a) = 251 | raise (Return_plugin (E (constr, fct))) 252 | ;; 253 | 254 | let preprocess_shebang ~first_line = 255 | if String.is_prefix first_line ~prefix:"#!" 256 | then sprintf "(* %S *)" first_line 257 | else first_line 258 | ;; 259 | 260 | let include_directories dirs = List.concat_map dirs ~f:(fun dir -> [ "-I"; dir ]) 261 | 262 | let make_pp_args ?(map_exe = Fn.id) preprocessor = 263 | let call prog args = 264 | String.concat ~sep:" " (List.map ~f:Filename.quote (map_exe prog :: args)) 265 | in 266 | match (preprocessor : Preprocessor.t) with 267 | | No_preprocessing -> [] 268 | | Ppx { ppx_exe } -> [ "-pp"; call ppx_exe [ "-dump-ast" ] ] 269 | ;; 270 | 271 | module Compile : sig 272 | val copy_files 273 | : trigger_unused_value_warnings_despite_mli:bool 274 | -> compilation_directory:Compilation_directory.t 275 | -> Plugin_uuid.t 276 | -> string Deferred.Or_error.t 277 | 278 | val blocking_dynlink : string -> packed_plugin Or_error.t 279 | val dynlink : string -> packed_plugin Deferred.Or_error.t 280 | 281 | val compile_and_load_file 282 | : t 283 | -> compilation_directory:Compilation_directory.t 284 | -> basename:Core.String.Hash_set.elt 285 | -> (string * packed_plugin) Async.Deferred.Or_error.t 286 | end = struct 287 | let output_line out_channel line = 288 | Out_channel.output_string out_channel line; 289 | Out_channel.output_char out_channel '\n' 290 | ;; 291 | 292 | let output_in_channel out_channel in_channel = 293 | (* This is to support scripts that have a shebang line *) 294 | match In_channel.input_line in_channel with 295 | | None -> () 296 | | Some first_line -> 297 | output_line out_channel (preprocess_shebang ~first_line); 298 | In_channel.iter_lines in_channel ~f:(output_line out_channel) 299 | ;; 300 | 301 | let permission = 0o600 302 | 303 | (* Normally adding a signature on an implementation adds warnings, but 304 | here because no signature means that it defaults to [sig end], adding a 305 | signature removes warnings. *) 306 | 307 | let ocaml_plugin_gen_sig_prefix = "OCAML_PLUGIN__sig_" 308 | 309 | let copy_files 310 | ~trigger_unused_value_warnings_despite_mli 311 | ~(compilation_directory : Compilation_directory.t) 312 | plugin_uuid 313 | = 314 | let fct () = 315 | let repr = Plugin_uuid.repr plugin_uuid in 316 | let with_bundle out_channel bundle = 317 | let `ml filename, `mli intf_filename_opt, `module_name module_name = 318 | Ml_bundle.to_pathnames bundle 319 | in 320 | let output_struct ~sig_name_opt = 321 | (match sig_name_opt with 322 | | None -> Core.Printf.fprintf out_channel "module %s = struct\n" module_name 323 | | Some sig_name -> 324 | Core.Printf.fprintf 325 | out_channel 326 | "module %s : %s = struct\n" 327 | module_name 328 | sig_name); 329 | Core.Printf.fprintf out_channel "#1 %S\n" filename; 330 | In_channel.with_file filename ~binary:false ~f:(output_in_channel out_channel); 331 | Core.Printf.fprintf out_channel "\nend\n" 332 | in 333 | match intf_filename_opt with 334 | | None -> output_struct ~sig_name_opt:None 335 | | Some intf_filename -> 336 | let sig_name = ocaml_plugin_gen_sig_prefix ^ module_name in 337 | Core.Printf.fprintf out_channel "module type %s = sig\n" sig_name; 338 | Core.Printf.fprintf out_channel "#1 %S\n" intf_filename; 339 | In_channel.with_file 340 | ~binary:false 341 | intf_filename 342 | ~f:(output_in_channel out_channel); 343 | Core.Printf.fprintf out_channel "\nend\n"; 344 | output_struct ~sig_name_opt:(Some sig_name); 345 | if not trigger_unused_value_warnings_despite_mli 346 | then 347 | Core.Printf.fprintf 348 | out_channel 349 | "let _avoid_warnings = (module %s : %s)\n" 350 | module_name 351 | sig_name 352 | in 353 | let target = next_filename () in 354 | let full_target = compilation_directory.directory ^/ target in 355 | let with_out_channel out_channel = 356 | let bundles = Plugin_uuid.ml_bundles plugin_uuid in 357 | let last_bundle = 358 | match List.last bundles with 359 | | None -> raise_s [%sexp "Ocaml_plugin: No_file_to_compile"] 360 | | Some last -> last 361 | in 362 | let main_module_name = Ml_bundle.module_name last_bundle in 363 | Core.Printf.fprintf 364 | out_channel 365 | ("module F () : sig\n" ^^ " module %s : %s\n" ^^ "end\n = struct\n") 366 | main_module_name 367 | (Plugin_uuid.Repr.t repr); 368 | List.iter bundles ~f:(with_bundle out_channel); 369 | Core.Printf.fprintf out_channel "end\n"; 370 | Core.Printf.fprintf 371 | out_channel 372 | ("let () =\n" 373 | ^^ " let module R = Ocaml_plugin.Dynloader in\n" 374 | ^^ " R.return_plugin %s (fun () ->\n" 375 | ^^ " let module M = F() in\n" 376 | ^^ " (module M.%s : %s))\n") 377 | (Plugin_uuid.Repr.univ_constr repr) 378 | main_module_name 379 | (Plugin_uuid.Repr.t repr) 380 | in 381 | Out_channel.with_file full_target ~binary:false ~perm:permission ~f:with_out_channel; 382 | target 383 | in 384 | Deferred.Or_error.try_with ~rest:`Log ~extract_exn:true (fun () -> In_thread.run fct) 385 | ;; 386 | 387 | 388 | (* Dynlink has the following not really wanted property: dynlinking a file with a given 389 | filename only works properly the first time. Further dynlinks with the same filename 390 | (even a different file) will not load the new module but instead execute the initial 391 | module. Since ocaml_plugin need to be able to load cmxs coming from ml files with the 392 | same name (several variations of config.ml for instance), what we do is give unique 393 | name to each cmxs that we produce: files in the cache have their uuid in the name, 394 | and files not in the cache are called $tmp_dir/something_$fresh.cmxs. 395 | We can't have several Ocaml_plugin.Dynloader.t use the same directory, because 396 | ocaml_plugin always create a fresh directory in which to put its files. 397 | 398 | The other related problem is that if we dynlink the same filename multiple times, 399 | even if that filename has the same contents every time, we risk memory corruption. 400 | The problem is that dlopen the second time returns the same pointers as the first 401 | time (even with loadfile_private, which does a dlopen(..., RTLD_LOCAL) 402 | underneath. [man dlopen] says "If the same library is loaded again with dlopen(), the 403 | same file handle is returned"), which means that the second load initializes the 404 | previously loaded module instead of a new one. This can lead to the gc roots 405 | corruption, which leads to memory corruption. This situation can happen when loading 406 | modules from the plugin-cache, where loads of the same plugin use the same path. To 407 | avoid this, we keep track of every module we've already loaded (which is a memory 408 | leak, but it's just an amplification of the one in dlopen, not a new one), so we can 409 | only load them once per process (while still repeating the side effects in the users' 410 | source files). *) 411 | let blocking_dynlink_exn = 412 | let plugins_loaded_privately : (string, packed_plugin) Hashtbl.t = 413 | Hashtbl.create (module String) 414 | in 415 | fun file -> 416 | match Hashtbl.find plugins_loaded_privately file with 417 | | Some packed_plugin -> packed_plugin 418 | | None -> 419 | (match Dynlink.loadfile_private file with 420 | | () -> raise_s [%sexp "Ocaml_plugin: Plugin_did_not_return"] 421 | | exception 422 | ( Dynlink.Error 423 | (Library's_module_initializers_failed (Return_plugin packed_plugin)) 424 | | Return_plugin packed_plugin ) -> 425 | Hashtbl.set plugins_loaded_privately ~key:file ~data:packed_plugin; 426 | packed_plugin 427 | | exception Dynlink.Error e -> 428 | raise_s 429 | [%sexp "Ocaml_plugin: Dynlink_error", (Dynlink.error_message e : string)]) 430 | ;; 431 | 432 | let dynlink = 433 | let dynlink_sequencer = Sequencer.create ~continue_on_error:true () in 434 | fun cmxs_filename -> 435 | (* Ensure we can't dynlink multiple modules concurrently, as Dynlink doesn't support 436 | such things, as in it leads to segfaults. *) 437 | Throttle.enqueue dynlink_sequencer (fun () -> 438 | Deferred.Or_error.try_with ~rest:`Log ~extract_exn:true (fun () -> 439 | In_thread.run (fun () -> blocking_dynlink_exn cmxs_filename))) 440 | ;; 441 | 442 | let blocking_dynlink cmxs_filename = 443 | Or_error.try_with (fun () -> blocking_dynlink_exn cmxs_filename) 444 | ;; 445 | 446 | let compile_and_load_file 447 | t 448 | ~compilation_directory:{ Compilation_directory.directory = working_dir } 449 | ~basename 450 | = 451 | let basename_without_ext = 452 | try Filename.chop_extension basename with 453 | | Invalid_argument _ -> basename 454 | in 455 | let ext = Printf.sprintf "%s.%s" basename_without_ext in 456 | let ml = ext "ml" in 457 | let cmx = ext "cmx" in 458 | let cmxs = ext "cmxs" in 459 | let pp_args = make_pp_args t.compilation_config.preprocessor in 460 | let create_cmx_args = 461 | pp_args 462 | @ include_directories t.include_directories 463 | @ t.cmx_flags 464 | @ [ "-c"; "-o"; cmx; ml ] 465 | in 466 | let create_cmxs_args = t.cmxs_flags @ [ "-shared"; cmx; "-o"; cmxs ] in 467 | let%bind.E () = 468 | Shell.run ~quiet_or_error:true ~working_dir t.ocamlopt_opt create_cmx_args 469 | in 470 | let%bind.E () = 471 | Shell.run ~quiet_or_error:true ~working_dir t.ocamlopt_opt create_cmxs_args 472 | in 473 | let cmxs = working_dir ^/ cmxs in 474 | let%map.E packed_plugin = dynlink cmxs in 475 | cmxs, packed_plugin 476 | ;; 477 | end 478 | 479 | let copy_source_files_to_working_dir ~source_dir ~working_dir = 480 | Deferred.Or_error.try_with ~rest:`Log (fun () -> 481 | let%bind all_ocaml_files = 482 | Sys.ls_dir source_dir 483 | >>| List.filter ~f:(fun file -> 484 | (* We filter out some files created by emacs with names like ".#fool.ml" that we 485 | would fail to read because they are dead symlinks. *) 486 | (not (String.is_prefix file ~prefix:".")) 487 | && (String.is_suffix file ~suffix:".ml" 488 | || String.is_suffix file ~suffix:".mli")) 489 | in 490 | Deferred.List.iter ~how:`Sequential all_ocaml_files ~f:(fun file -> 491 | let source_file_name = source_dir ^/ file in 492 | Reader.with_file source_file_name ~f:(fun source_file -> 493 | Writer.with_file (working_dir ^/ file) ~f:(fun dest_file -> 494 | Writer.writef dest_file "#1 %S\n" source_file_name; 495 | match%bind Reader.read_line source_file with 496 | | `Eof -> Deferred.unit 497 | | `Ok first_line -> 498 | Writer.write_line dest_file (preprocess_shebang ~first_line); 499 | Pipe.iter_without_pushback 500 | (Reader.lines source_file) 501 | ~f:(Writer.write_line dest_file))))) 502 | ;; 503 | 504 | let find_dependencies t filename = 505 | if t.cleaned 506 | then return (Or_error.error_s [%sexp "Usage_of_cleaned_dynloader", [%here]]) 507 | else ( 508 | let%bind.E () = 509 | if Filename.check_suffix filename ".ml" 510 | then return (Ok ()) 511 | else 512 | return 513 | (Or_error.errorf 514 | "Ocaml_plugin.Dynloader.find_dependencies: argument %S is not an ml file" 515 | filename) 516 | in 517 | let%bind.E { directory = base_dir } = 518 | Lazy_deferred.force_exn t.compilation_directory 519 | in 520 | let%bind.E filename = Shell.absolute_pathname filename in 521 | let source_dir = Filename.dirname filename in 522 | let target = Filename.chop_extension (Filename.basename filename) in 523 | let in_base_dir file = 524 | (* our [working_dir] is not [base_dir], and [file] is relative to [base_dir] if it 525 | is not an absolute path and not an invocation to something in $PATH *) 526 | if (not (Filename.is_absolute file)) && String.mem file '/' 527 | then base_dir ^/ file 528 | else file 529 | in 530 | let pp_args = make_pp_args ~map_exe:in_base_dir t.compilation_config.preprocessor in 531 | (* we create a new directory under [base_dir] as ocamldep's working directory, when 532 | we copy files, we strip the shebang line. *) 533 | let%bind.E working_dir = 534 | Shell.temp_dir ~in_dir:base_dir ~prefix:"ocamldep" ~suffix:"" () 535 | in 536 | let%bind.E () = copy_source_files_to_working_dir ~source_dir ~working_dir in 537 | let%bind.E compilation_units = 538 | Ocamldep.find_dependencies 539 | ~prog:(in_base_dir t.ocamldep_opt) 540 | ~args:pp_args 541 | ~working_dir 542 | ~target 543 | in 544 | (* convert the topological order of compilation units into a list of files *) 545 | Deferred.List.map ~how:`Sequential compilation_units ~f:(fun compilation_unit -> 546 | (* return files from [source_dir] *) 547 | let ml = source_dir ^/ compilation_unit ^ ".ml" in 548 | let mli = ml ^ "i" in 549 | match%map Sys.file_exists mli with 550 | | `Yes -> Ok [ mli; ml ] 551 | | `No -> Ok [ ml ] 552 | | `Unknown -> Or_error.errorf "File in unknown state: %s" mli) 553 | >>| Or_error.all 554 | >>|? List.concat) 555 | ;; 556 | 557 | let load_ocaml_src_files_plugin_uuid ~repr t filenames = 558 | if t.cleaned 559 | then return (Or_error.error_s [%sexp "Usage_of_cleaned_dynloader", [%here]]) 560 | else ( 561 | let compile_without_cache ml_bundles = 562 | let%bind.E compilation_directory = 563 | Lazy_deferred.force_exn t.compilation_directory 564 | in 565 | let plugin_uuid = Plugin_uuid.create ~repr ~ml_bundles () in 566 | let trigger_unused_value_warnings_despite_mli = 567 | t.trigger_unused_value_warnings_despite_mli 568 | in 569 | let%bind.E basename = 570 | Compile.copy_files 571 | ~compilation_directory 572 | ~trigger_unused_value_warnings_despite_mli 573 | plugin_uuid 574 | in 575 | let%map.E res = Compile.compile_and_load_file t ~compilation_directory ~basename in 576 | plugin_uuid, res 577 | in 578 | let%bind.E filenames = Shell.absolute_pathnames filenames in 579 | let%bind.E ml_bundles = Ml_bundle.from_filenames filenames in 580 | match t.cache with 581 | | None -> 582 | let%map.E _, (cmxs_filename, packed_plugin) = compile_without_cache ml_bundles in 583 | `cmxs_filename cmxs_filename, packed_plugin 584 | | Some cache -> 585 | let%bind.E cache = Lazy_deferred.force_exn cache in 586 | let%bind.E sources = Plugin_cache.digest ml_bundles in 587 | let refresh_cache () = 588 | let%bind.E plugin_uuid, (cmxs_filename, packed_plugin) = 589 | compile_without_cache ml_bundles 590 | in 591 | let%map.E () = Plugin_cache.add cache sources plugin_uuid cmxs_filename in 592 | `cmxs_filename cmxs_filename, packed_plugin 593 | in 594 | (match Plugin_cache.find cache sources with 595 | | Some plugin -> 596 | let cmxs_filename = Plugin_cache.Plugin.cmxs_filename plugin in 597 | (match%bind Compile.dynlink cmxs_filename with 598 | | Ok packed_plugin -> 599 | Deferred.Or_error.return (`cmxs_filename cmxs_filename, packed_plugin) 600 | | Error _ as error -> 601 | if Plugin_cache.Plugin.was_compiled_by_current_exec plugin 602 | then 603 | (* Rebuilding the cmxs from scratch would lead to the exact same file since 604 | we have the same exec that the one that was used to build the same 605 | sources. Thus, the result of the dynlink would the same anyway, something 606 | else should be wrong. *) 607 | Deferred.return error 608 | else 609 | (* In that case, since the exec has changed since the last time it was used 610 | to build this cache, we might have a chance that dynlinking a freshly 611 | rebuilt cmxs file would actually succeed. In the case where the plugin 612 | dynlinked normally but raises an exception at toplevel, we will go 613 | through this branch and recompile it a second time. It is probably fine 614 | though. *) 615 | refresh_cache ()) 616 | | None -> refresh_cache ())) 617 | ;; 618 | 619 | module type S = sig 620 | type t 621 | 622 | val load_ocaml_src_files : dynloader -> string list -> t Deferred.Or_error.t 623 | 624 | val load_ocaml_src_files_without_running_them 625 | : dynloader 626 | -> string list 627 | -> (unit -> t) Deferred.Or_error.t 628 | 629 | val check_ocaml_src_files : dynloader -> string list -> unit Deferred.Or_error.t 630 | 631 | module Expert : sig 632 | val compile_ocaml_src_files_into_cmxs_file 633 | : dynloader 634 | -> string list 635 | -> output_file:string 636 | -> unit Deferred.Or_error.t 637 | 638 | val load_cmxs_file : string -> t Or_error.t Deferred.t 639 | val blocking_load_cmxs_file : string -> t Or_error.t 640 | end 641 | end 642 | 643 | module Make (X : Module_type) = struct 644 | let type_check plugin_type = 645 | (* There is an hidden invariant there: if the OCaml compilation succeed, that means 646 | that the loaded module has the type represented in [X.repr], so the [Univ.match_] 647 | will succeed. Of course this is only true is the user gave a valid [Module_type] 648 | in the first place. *) 649 | match Type_equal.Id.same_witness plugin_type X.univ_constr with 650 | | Some witness -> Ok witness 651 | | None -> 652 | Or_error.error_s 653 | [%sexp "Type_mismatch", (X.t_repr : string), (X.univ_constr_repr : string)] 654 | ;; 655 | 656 | let load_and_type_ocaml_src_files_without_running_them t filenames = 657 | let repr = Plugin_uuid.Repr.create ~t:X.t_repr ~univ_constr:X.univ_constr_repr in 658 | let%bind.E cmxs_filename, E (plugin_type, make_plugin) = 659 | load_ocaml_src_files_plugin_uuid ~repr t filenames 660 | in 661 | return 662 | (match type_check plugin_type with 663 | | Error _ as e -> e 664 | | Ok Type_equal.T -> Ok (cmxs_filename, (make_plugin : unit -> X.t))) 665 | ;; 666 | 667 | let load_ocaml_src_files_without_running_them t filenames = 668 | let%map.E `cmxs_filename _, make_plugin = 669 | load_and_type_ocaml_src_files_without_running_them t filenames 670 | in 671 | make_plugin 672 | ;; 673 | 674 | let run make_plugin = 675 | try Ok (make_plugin ()) with 676 | | exn -> 677 | Or_error.tag 678 | (Or_error.of_exn exn) 679 | ~tag:"Exception while executing the plugin's toplevel" 680 | ;; 681 | 682 | let load_ocaml_src_files t filenames = 683 | let%bind.E `cmxs_filename _, make_plugin = 684 | load_and_type_ocaml_src_files_without_running_them t filenames 685 | in 686 | Deferred.return (run make_plugin) 687 | ;; 688 | 689 | let check_ocaml_src_files t filenames = 690 | let%map.E (_ : unit -> X.t) = load_ocaml_src_files_without_running_them t filenames in 691 | () 692 | ;; 693 | 694 | module Expert = struct 695 | let compile_ocaml_src_files_into_cmxs_file t filenames ~output_file = 696 | let%bind.E `cmxs_filename cmxs_filename, (_ : unit -> X.t) = 697 | load_and_type_ocaml_src_files_without_running_them t filenames 698 | in 699 | Shell.cp ~source:cmxs_filename ~dest:output_file 700 | ;; 701 | 702 | let blocking_load_cmxs_file cmxs_filename : X.t Or_error.t = 703 | if not (Scheduler.is_ready_to_initialize ()) 704 | then 705 | Or_error.error_string 706 | "blocking_load_cmxs_file can only be called when Async scheduler isn't \ 707 | initialized" 708 | else ( 709 | match Compile.blocking_dynlink cmxs_filename with 710 | | Error _ as e -> e 711 | | Ok (E (plugin_type, make_plugin)) -> 712 | (match type_check plugin_type with 713 | | Error _ as e -> e 714 | | Ok Type_equal.T -> run make_plugin)) 715 | ;; 716 | 717 | let load_cmxs_file cmxs_filename = 718 | let%bind.E (E (plugin_type, make_plugin)) = Compile.dynlink cmxs_filename in 719 | match type_check plugin_type with 720 | | Error _ as e -> return e 721 | | Ok Type_equal.T -> 722 | let make_plugin : unit -> X.t = make_plugin in 723 | Deferred.return (run make_plugin) 724 | ;; 725 | end 726 | end 727 | 728 | module type Side_effect = sig end 729 | 730 | let side_effect_univ_constr = Univ_constr.create () 731 | 732 | module Side_effect_loader = Make (struct 733 | type t = (module Side_effect) 734 | 735 | let t_repr = "Ocaml_plugin.Dynloader.Side_effect" 736 | let univ_constr = side_effect_univ_constr 737 | let univ_constr_repr = "Ocaml_plugin.Dynloader.side_effect_univ_constr" 738 | end) 739 | 740 | module Side_effect = struct 741 | open Side_effect_loader 742 | 743 | let check_ocaml_src_files = check_ocaml_src_files 744 | 745 | let load_ocaml_src_files t filenames = 746 | let%map.E (_ : (module Side_effect)) = load_ocaml_src_files t filenames in 747 | () 748 | ;; 749 | 750 | let load_ocaml_src_files_without_running_them t filenames = 751 | let%map.E f = load_ocaml_src_files_without_running_them t filenames in 752 | (); 753 | fun () -> ignore (f () : (module Side_effect)) 754 | ;; 755 | 756 | module Expert = struct 757 | let compile_ocaml_src_files_into_cmxs_file = 758 | Expert.compile_ocaml_src_files_into_cmxs_file 759 | ;; 760 | 761 | let blocking_load_cmxs_file filename = 762 | Expert.blocking_load_cmxs_file filename 763 | |> (Or_error.ignore_m : (module Side_effect) Or_error.t -> unit Or_error.t) 764 | ;; 765 | 766 | let load_cmxs_file filename = 767 | let%map.E (_ : (module Side_effect)) = Expert.load_cmxs_file filename in 768 | () 769 | ;; 770 | end 771 | end 772 | -------------------------------------------------------------------------------- /src/dynloader.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | (** Ocaml plugin loader, from ocaml source file. Wrapper around Dynlink module, including 5 | on the fly async ocaml compilation. 6 | 7 | This is a low level module, casual user should rather use [Compiler] apart from 8 | Make to create a dedicated Plugin loader. *) 9 | 10 | (** See the labelled argument [custom_warnings_spec] for what these are for. *) 11 | val default_disabled_warnings : int list 12 | 13 | val warnings_spec : disabled_warnings:int list -> string 14 | val default_warnings_spec : string 15 | 16 | (** Mutable type for loading ocaml modules. *) 17 | type t 18 | 19 | type dynloader = t 20 | 21 | type 'a create_arguments = 22 | ?in_dir:string 23 | (** The pathname has to be absolute. If not, the behavior is unspecified. 24 | 25 | This is the location where the ocaml compilation will take place. A fresh directory 26 | will be created inside that directory. The default value is 27 | [Filename.temp_dir_name], so the default behavior is to create a fresh directory in 28 | the temp_dir_name, like /tmp/ocaml_plugin.1464h45 . 29 | 30 | Plugins are copied into that directory, and compiled there. Cf function [clean]. 31 | 32 | This should preferably be a local disk location not using NFS networking 33 | (compilation will be faster). *) 34 | -> ?in_dir_perm:Unix.file_perm 35 | (** The permissions with which [in_dir] will be created. Defaults to [0o700]. *) 36 | -> ?include_directories:string list 37 | (** If you do not use the Auto_embed mode, you want to use some cmi files installed in 38 | some shared places. You need then to add these directories to the ocamlopt 39 | compilation, using -I option. Each directory of this list will be added in the 40 | command, this module will add the -I flag. 41 | 42 | These should rather be absolute directories. If not, they would be concatenated with 43 | the cwd at the time the function [create] is executed. *) 44 | -> ?custom_warnings_spec:string 45 | (** Defaults to [default_warnings_spec]. 46 | 47 | When one uses this library, warnings are always triggered as errors. This flag 48 | allows one to change the warnings enabled and is passed to the compiler this way: 49 | [-w $(custom_warnings_spec) -warn-error +a] 50 | 51 | Custom warnings specifications can be built with [default_ignored_warnings] and 52 | [warnings_spec]. *) 53 | -> ?strict_sequence:bool 54 | (** Use or don't use -strict-sequence during compilation. Set to [true] by default, so 55 | that it is consistent with the policy used in core, async, etc. *) 56 | -> ?cmx_flags:string list 57 | (** Add some flags to the compilation producing the cmx file. No check are done, the 58 | option are passed 'as they are' to ocamlopt *) 59 | -> ?cmxs_flags:string list (** Same thing for cmxs compilation. *) 60 | -> ?trigger_unused_value_warnings_despite_mli:bool 61 | (** When the files of a plugin export values in some mli but no one is using them, 62 | unused value warnings are not triggered. However, by explicitly setting this 63 | parameter to [true] they will be triggered. This might come in handy to detect dead 64 | code in a large plugin that uses multiple files. *) 65 | -> ?use_cache:Plugin_cache.Config.t 66 | (** By default, there is no cache. If a config is given, cmxs files may be used from an 67 | execution to an other. *) 68 | -> 'a 69 | 70 | module Ppx : sig 71 | (** [ppx_exe] is a custom ppx binary built to include all the syntax extensions required 72 | to compile the plugins. *) 73 | type t = { ppx_exe : string } 74 | end 75 | 76 | module Preprocessor : sig 77 | type t = 78 | | No_preprocessing 79 | | Ppx of Ppx.t 80 | end 81 | 82 | module Compilation_config : sig 83 | type t = { preprocessor : Preprocessor.t } 84 | 85 | (** The specified preprocessor will be used to build the source files. By default no 86 | preprocessing is applied. *) 87 | val default : t 88 | end 89 | 90 | (** Currently this library works with native code only. The function [create] will 91 | raise if called in bytecode. *) 92 | val create 93 | : (?initialize:(directory:string -> unit Deferred.Or_error.t) 94 | (** In case we do not use the cache of cmxs, and the compilation will actually takes 95 | place, we offer a way via this call back to perform some computation before the 96 | first compilation. This is typically when [Compiler] will extract its tar 97 | file. *) 98 | -> ?compilation_config:Compilation_config.t 99 | (** This defaults to using [Compilation_config.default]. Typically, this flag is 100 | provided by Compiler from the metadata embedded in the executable. *) 101 | -> ?ocamlopt_opt:string 102 | -> ?ocamldep_opt:string 103 | (** ocamlopt, and ocamldep should be for the same version of ocaml as the current 104 | executable and the provided or embedded ocaml files (interfaces, preprocessors). If 105 | this is not specified, ocaml_plugin will assume that the correct ocamlopt.opt and 106 | ocamldep.opt are present in the path of the current executable, which is most likely 107 | a naive hope. *) 108 | -> unit 109 | -> t Deferred.Or_error.t) 110 | create_arguments 111 | 112 | (** Cleaning the files generated by this Dynloader.t from the begining of his life, 113 | and try to remove the directory if it is empty once the files have been removed. 114 | Doesn't fail if the directory contains other files, keep them and keep the directory 115 | in that case. Once cleaned, you cannot use a dynloader anymore, you should just leave 116 | it alone and let it be collected by the GC at some point. Using a cleaned dynloader 117 | will result in an error. *) 118 | val clean : t -> unit Deferred.Or_error.t 119 | 120 | module Univ_constr : sig 121 | type 'a t 122 | 123 | val create : unit -> 'a t 124 | end 125 | 126 | module type Module_type = sig 127 | (** The type [t] is the type of a first level module you want to load. This is 128 | typically the type of your expected config file, as a top level ocaml module. 129 | 130 | The field [t_repr] is the concrete OCaml syntax for this module type. 131 | 132 | The field [univ_constr] is used to constr and match_ values of type t, embedded 133 | in a value of type Univ.t. 134 | 135 | The field [univ_constr_repr] is the concrete OCaml syntax for the field 136 | [univ_constr]. 137 | 138 | Example : 139 | {module M : A.S} defined in the library "mylib.cmxa". 140 | 141 | {[ 142 | module My_config_loader = Ocaml_plugin.Dynloader.Make ( 143 | struct 144 | type t = (module A.S) 145 | let t_repr = "Mylib.A.S" 146 | let univ_constr = A.univ_constr 147 | let univ_constr_repr = "Mylib.A.univ_constr" 148 | end) 149 | ]} 150 | 151 | [t_repr] and [univ_constr_repr] should be complete paths, as it would be used by an 152 | ocaml file to link with the shared cmi files, in particular be aware that 153 | if you have some 'open' statements in your file, you might have different t and 154 | t_repr, which is a bad practice. 155 | 156 | If the module type [A.M_intf] is defined in a package, you would need to add it in 157 | the t_repr, as it is part of the complete path of the module type ("Mylib" in the 158 | example). *) 159 | type t 160 | 161 | val t_repr : string 162 | val univ_constr : t Univ_constr.t 163 | val univ_constr_repr : string 164 | 165 | (** This implementation is type safe. Some properties should be verified so that 166 | the library would work properly: 167 | 168 | -the type [t] and its representation '[t_repr]' should match, 169 | -the plugin implementation doesn't override the module type sig 170 | represented by the string [t_repr]: 171 | -the plugin implementation doesn't override the univ_constr scope name 172 | represented by the string [univ_constr_repr] 173 | -the value [univ_constr] and its representation [univ_constr_repr] should match. *) 174 | end 175 | 176 | (** [find_dependencies t file] uses ocamldep to compute the list of .ml and .mli files 177 | that [file] depends on transitively, which you can then pass to 178 | [load_ocaml_src_files]. [file] must be an .ml file, and all the files it depend on 179 | must be in the same folder. *) 180 | val find_dependencies : t -> string -> string list Deferred.Or_error.t 181 | 182 | module type S = sig 183 | type t 184 | 185 | (** Load a bunch of ocaml files source files (.ml + .mli). The last module's signature 186 | should be compatible with the signature [X.repr]. If the type does not match, there 187 | will be an error during OCaml compilation. The files are copied into the compilation 188 | directory, and compiled versus a generated mli file including the relevant module 189 | signature. This generated file is then dynlinked with the current executable. 190 | 191 | The compilation happens using [Dynlink.loadfile_private], meaning that 192 | the toplevel definition defined in these files are hidden 193 | (cannot be referenced) from other modules dynamically loaded afterwards *) 194 | val load_ocaml_src_files : dynloader -> string list -> t Deferred.Or_error.t 195 | 196 | (** Loads the given source files, same as [load_ocaml_src_files], but instead of running 197 | their toplevel, you are given a closure that will run the toplevel. You can use this 198 | to run the toplevel multiple times, or lazily, or outside the async thread, or get 199 | precise control over the raised exceptions. *) 200 | val load_ocaml_src_files_without_running_them 201 | : dynloader 202 | -> string list 203 | -> (unit -> t) Deferred.Or_error.t 204 | 205 | (** Similar to [load_ocaml_src_files], but does not execute the plugin toplevel, just 206 | checks that compilation and dynamic linking work. *) 207 | val check_ocaml_src_files : dynloader -> string list -> unit Deferred.Or_error.t 208 | 209 | module Expert : sig 210 | (** The following functions are exposed for expert users only, not for the casual 211 | user, because they are much more error prone. Prefer [load_ocaml_src_files] if 212 | possible. 213 | 214 | The complexity is due to the following unexpected or unpredictable behavior of 215 | [Dynlink]: dynlinking a file with a given filename only works properly the first 216 | time. Further dynlinks with the same filename (even if the contents of the file 217 | has changed in the meantime) will not load the new module but instead execute the 218 | initial module. Some even says that the behavior upon reload depends on the 219 | platform. Long story short: don't do that. Dynlink files at most once. 220 | 221 | To work around this, you may automatically copy the given file to a temporary and 222 | unique name before dynlinking it. 223 | 224 | It is worth noting too that the [*load_cmxs_file] functions below only work with 225 | cmxs files produced by ocaml_plugin's [compile_ocaml_src_files_into_cmxs_file]. 226 | They expect the code to perform some internal library calls, thus it cannot be 227 | used with any arbitrary cmxs compiled in some other way. Furthermore those 228 | functions would return an error even though the cmxs was built with ocaml_plugin 229 | when built under a different context (compiler version used, cmi dependencies 230 | version, etc.) The intended usage is to have the compilation and loading done 231 | using the same executable. *) 232 | 233 | (** This compiles the source files into cmxs file, but does not execute the plugin 234 | toplevel. The resulting cmxs file can be loaded by the [*load_cmxs_file] function 235 | below either from within the same process or other processes which share the same 236 | executable. If compile succeeds, it returns [Ok] and write the compiled cmxs file 237 | into [output_file] (may override existing file), otherwise it returns [Error] and 238 | won't write to [output_file] at all. *) 239 | val compile_ocaml_src_files_into_cmxs_file 240 | : dynloader 241 | -> string list 242 | -> output_file:string (** like -o option of gcc *) 243 | -> unit Deferred.Or_error.t 244 | 245 | val load_cmxs_file : string -> t Or_error.t Deferred.t 246 | 247 | (** [blocking_load_cmxs_file] will return an error if called after the async scheduler 248 | has been started. *) 249 | val blocking_load_cmxs_file : string -> t Or_error.t 250 | end 251 | end 252 | 253 | module Make : functor (X : Module_type) -> S with type t := X.t 254 | 255 | (** In some cases, we are only interested by the toplevel side effects of dynlinked 256 | modules. *) 257 | module Side_effect : S with type t := unit 258 | 259 | (* =============================================================== *) 260 | (* The following section is for internal use only*) 261 | module type Side_effect = sig end 262 | 263 | val side_effect_univ_constr : (module Side_effect) Univ_constr.t 264 | val return_plugin : 'a Univ_constr.t -> (unit -> 'a) -> unit 265 | (* =============================================================== *) 266 | 267 | -------------------------------------------------------------------------------- /src/import.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | (* some shared internal util for ocaml_plugin *) 5 | 6 | let if_ cond fct = if cond then fct () else Deferred.Or_error.ok_unit 7 | -------------------------------------------------------------------------------- /src/ml_bundle.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | type t = 5 | { ml : string 6 | ; mli : string option 7 | ; module_name : string 8 | } 9 | [@@deriving sexp, compare] [@@sexp.allow_extra_fields] 10 | 11 | type tmp_t = 12 | { mutable tmp_ml : string option 13 | ; mutable tmp_mli : string option 14 | ; tmp_module_name : string 15 | } 16 | 17 | let valid_module_name s = 18 | (not (String.is_empty s)) 19 | && 20 | match s.[0] with 21 | | 'A' .. 'Z' -> 22 | String.for_all s ~f:(function 23 | | 'a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9' | '\'' -> true 24 | | _ -> false) 25 | | _ -> false 26 | ;; 27 | 28 | let module_name ~full_path ~path_no_ext = 29 | let basename = Filename.basename path_no_ext in 30 | let unchecked_module_name = String.capitalize basename in 31 | if valid_module_name unchecked_module_name 32 | then unchecked_module_name 33 | else invalid_argf "%s is not a valid ocaml filename" full_path () 34 | ;; 35 | 36 | let enrich_bundle ({ ml; mli; module_name = _ } as bundle) = 37 | match mli with 38 | | Some _ -> return bundle 39 | | None -> 40 | let mli = Filename.chop_extension ml ^ ".mli" in 41 | (match%map Sys.file_exists mli with 42 | | `Yes -> { bundle with mli = Some mli } 43 | | `No -> bundle 44 | | `Unknown -> raise_s [%sexp "File_in_unknown_state", (mli : string), [%here]]) 45 | ;; 46 | 47 | let ml_with_mli_reorder filenames = 48 | let tbl = String.Table.create () in 49 | let init_bundle acc str = 50 | let path_no_ext, ext_opt = Filename.split_extension str in 51 | let ext = 52 | match ext_opt with 53 | | None -> `none 54 | | Some "ml" -> `ml 55 | | Some "mli" -> `mli 56 | | Some ext -> invalid_argf "Expected .ml or .mli files, got : %s" ext () 57 | in 58 | (* giving this error after the one about extensions *) 59 | let module_name = module_name ~full_path:str ~path_no_ext in 60 | let acc, data = 61 | match Hashtbl.find tbl module_name with 62 | | None -> 63 | let data = { tmp_ml = None; tmp_mli = None; tmp_module_name = module_name } in 64 | Hashtbl.add_exn tbl ~key:module_name ~data; 65 | data :: acc, data 66 | | Some data -> acc, data 67 | in 68 | (match ext, data with 69 | | (`ml | `none), { tmp_ml = Some old_ml; _ } -> 70 | invalid_argf 71 | "Several implementations provided for %s: %s and %s" 72 | module_name 73 | str 74 | old_ml 75 | () 76 | | `mli, { tmp_mli = Some old_mli; _ } -> 77 | invalid_argf 78 | "Several interfaces provided for %s: %s and %s" 79 | module_name 80 | str 81 | old_mli 82 | () 83 | | `none, { tmp_ml = None; _ } -> data.tmp_ml <- Some (str ^ ".ml") 84 | | `ml, { tmp_ml = None; _ } -> data.tmp_ml <- Some str 85 | | `mli, { tmp_mli = None; _ } -> data.tmp_mli <- Some str); 86 | acc 87 | in 88 | let rev_paths = List.fold_left filenames ~init:[] ~f:init_bundle in 89 | List.rev_map 90 | rev_paths 91 | ~f:(fun { tmp_ml; tmp_mli = mli; tmp_module_name = module_name } -> 92 | let ml = 93 | match tmp_ml with 94 | | None -> 95 | (* same behaviour as before *) 96 | Filename.chop_extension (Option.value_exn mli) ^ ".ml" 97 | | Some ml -> ml 98 | in 99 | { ml; mli; module_name }) 100 | ;; 101 | 102 | let from_filenames filenames = 103 | Deferred.Or_error.try_with ~rest:`Log ~extract_exn:true (fun () -> 104 | let pairs = ml_with_mli_reorder filenames in 105 | Deferred.List.map ~how:`Sequential pairs ~f:enrich_bundle) 106 | ;; 107 | 108 | let to_pathnames { ml; mli; module_name } = `ml ml, `mli mli, `module_name module_name 109 | let module_name t = t.module_name 110 | -------------------------------------------------------------------------------- /src/ml_bundle.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | type t [@@deriving sexp, compare] 5 | 6 | (** The argument is a list of absolute paths (with or without extensions) to ml and mli 7 | files. The order is such that it is stable regarding the first file found in the input 8 | list regardless if it is an ml or mli, or without extension. *) 9 | val from_filenames : string list -> t list Deferred.Or_error.t 10 | 11 | (* The string parameters in the result are absolute paths. *) 12 | val to_pathnames 13 | : t 14 | -> [ `ml of string ] * [ `mli of string option ] * [ `module_name of string ] 15 | 16 | val module_name : t -> string 17 | -------------------------------------------------------------------------------- /src/ocaml_fake_archive.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | static char s[] = "dummy"; 7 | 8 | /* Here and in the generated .c files, we must put CAML_BA_EXTERNAL instead of 9 | CAML_BA_MANAGED because the C string cannot be freed. */ 10 | CAMLprim CAMLweakdef value ocaml_plugin_archive(value unit 11 | __attribute__((unused))) { 12 | intnat dim = 5; 13 | int flags = CAML_BA_UINT8 | CAML_BA_C_LAYOUT | CAML_BA_EXTERNAL; 14 | return caml_ba_alloc(flags, 1, s, &dim); 15 | } 16 | 17 | CAMLprim CAMLweakdef value 18 | ocaml_plugin_archive_metadata(value unit __attribute__((unused))) { 19 | return (caml_copy_string(s)); 20 | } 21 | -------------------------------------------------------------------------------- /src/ocaml_plugin.ml: -------------------------------------------------------------------------------- 1 | module Dynloader = Dynloader 2 | module Compiler = Compiler 3 | module Plugin_cache = Plugin_cache 4 | 5 | module Private = struct 6 | module Shell = Shell 7 | module Tar = Tar 8 | end 9 | 10 | module Std = struct 11 | module Ocaml_dynloader = Dynloader 12 | module Ocaml_compiler = Compiler 13 | module Plugin_cache = Plugin_cache 14 | end 15 | [@@deprecated 16 | "[since 2018-01] Use [Ocaml_plugin]. The [Ocaml_plugin.Std] sub-module is no longer \ 17 | needed."] 18 | -------------------------------------------------------------------------------- /src/ocamldep.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | module E = Deferred.Or_error 4 | 5 | let fold_result ~f ~init:acc = 6 | let rec aux acc = function 7 | | [] -> Or_error.return acc 8 | | hd :: tl -> Or_error.bind (f acc hd) ~f:(fun acc -> aux acc tl) 9 | in 10 | aux acc 11 | ;; 12 | 13 | (* extract all dependencies from ocamldep output for one compilation unit *) 14 | let post_process ~target lines : String.Set.t Or_error.t = 15 | let chop_extension = Fn.compose fst Filename.split_extension in 16 | fold_result lines ~init:String.Set.empty ~f:(fun set line -> 17 | match String.split ~on:' ' line with 18 | | target_file :: ":" :: deps -> 19 | Or_error.try_with_join (fun () -> 20 | if String.equal target (chop_extension target_file) 21 | then 22 | List.fold deps ~init:set ~f:(fun set dep -> Set.add set (chop_extension dep)) 23 | |> Or_error.return 24 | else 25 | Or_error.error 26 | "Unexpected target file in ocamldep output" 27 | (target, line) 28 | [%sexp_of: string * string]) 29 | | _ -> Or_error.error "Fail to parse ocamldep output" lines [%sexp_of: string list]) 30 | ;; 31 | 32 | let%test_module _ = 33 | (module struct 34 | let lines = 35 | [ "a.cmx : a.cmi c.cmx d.cmx e.cmx"; "a.cmo : a.cmi b.cmo c.cmo"; "a.cmi : f.cmi" ] 36 | ;; 37 | 38 | let expect = String.Set.of_list [ "a"; "b"; "c"; "d"; "e"; "f" ] 39 | 40 | let%test_unit _ = 41 | [%test_eq: String.Set.t] (post_process ~target:"a" lines |> ok_exn) expect 42 | ;; 43 | end) 44 | ;; 45 | 46 | let topological_sort ~visit_trace ~target ~find_direct_deps = 47 | (* this uses a Depth-First Search to find a topological order of compilation units and 48 | report circular dependencies. 49 | 50 | [visiting] is everything currently in call stack and is used to detect circles 51 | [visit_finish_order] is the order we finish visiting a node and all its descendants, 52 | and is a topological order 53 | 54 | each time we visit a node, we 55 | 1) push it to [visiting] stack 56 | 2) visit all its descendants which are not visited (i.e. not in [visiting] nor 57 | [visit_finish_order]) 58 | 3) pop it from [visiting] stack and add it to [visit_finish_order] 59 | *) 60 | let visiting = Stack.create () in 61 | let visit_finish_order = Queue.create () in 62 | let rec visit target = 63 | (* low number of elements, O(n) lookup is ok there *) 64 | if Stack.mem ~equal:String.equal visiting target 65 | then ( 66 | let circle = 67 | target 68 | :: List.rev (List.take_while (Stack.to_list visiting) ~f:(String.( <> ) target)) 69 | in 70 | return 71 | (Or_error.error "Circular dependency detected" circle [%sexp_of: string list])) 72 | else if Queue.mem ~equal:String.equal visit_finish_order target 73 | then return (Ok ()) 74 | else ( 75 | visit_trace target; 76 | Stack.push visiting target; 77 | let%bind.E deps = find_direct_deps ~target in 78 | let%map.E () = 79 | Deferred.List.fold (Set.to_list deps) ~init:(Ok ()) ~f:(fun acc dep -> 80 | let%bind.E () = return acc in 81 | visit dep) 82 | in 83 | let popped = Stack.pop_exn visiting in 84 | assert (String.( = ) target popped); 85 | Queue.enqueue visit_finish_order target) 86 | in 87 | let%map.E () = visit target in 88 | Queue.to_list visit_finish_order 89 | ;; 90 | 91 | let%test_module _ = 92 | (module struct 93 | let test graph ~target = 94 | let graph = 95 | String.Map.of_alist_exn 96 | (List.rev_map graph ~f:(fun (a, deps) -> a, String.Set.of_list deps)) 97 | in 98 | let visited = String.Hash_set.create () in 99 | let visit_trace s = 100 | if Hash_set.mem visited s 101 | then 102 | raise_s 103 | [%sexp 104 | "complexity violation in toposort, node visited more that once" 105 | , (s : string) 106 | , (graph : String.Set.t String.Map.t)] 107 | else Hash_set.add visited s 108 | in 109 | Thread_safe.block_on_async_exn (fun () -> 110 | topological_sort ~visit_trace ~target ~find_direct_deps:(fun ~target -> 111 | return (Ok (Map.find_exn graph target)))) 112 | ;; 113 | 114 | let%test_unit _ = 115 | let graph = 116 | [ "a", [ "b"; "c"; "d" ]; "b", [ "c" ]; "c", [ "d" ]; "d", [ "e" ]; "e", [] ] 117 | in 118 | [%test_eq: string list] 119 | (test graph ~target:"a" |> ok_exn) 120 | [ "e"; "d"; "c"; "b"; "a" ] 121 | ;; 122 | 123 | let%test_unit _ = 124 | let all = 125 | List.init 26 ~f:(fun i -> String.make 1 (Char.of_int_exn (Char.to_int 'a' + i))) 126 | in 127 | let graph = 128 | let deps a = List.rev_filter all ~f:(String.( < ) a) in 129 | List.map all ~f:(fun a -> a, deps a) 130 | in 131 | [%test_eq: string list] (test graph ~target:"a" |> ok_exn) (List.rev all) 132 | ;; 133 | 134 | let%test_unit _ = 135 | let graph = [ "a", [ "b" ]; "b", [ "c" ]; "c", [ "a" ] ] in 136 | [%test_eq: Sexp.t] 137 | (test graph ~target:"a" |> [%sexp_of: _ Or_error.t]) 138 | (Sexp.of_string "(Error (\"Circular dependency detected\" (a b c)))") 139 | ;; 140 | end) 141 | ;; 142 | 143 | let find_dependencies ~prog ~args ~working_dir ~target = 144 | let args = "-one-line" :: args in 145 | (* call ocamldep for one target compilation unit to return a list of compilation units *) 146 | let find_direct_deps ~target = 147 | (* ocamldep works fine if the ml or mli file doesn't exist *) 148 | let%bind.E lines = 149 | Shell.run_lines ~working_dir prog (args @ [ target ^ ".mli"; target ^ ".ml" ]) 150 | in 151 | match post_process ~target lines with 152 | | Error _ as err -> return err 153 | | Ok deps -> 154 | (* remove self-dependency *) 155 | return (Ok (Set.remove deps target)) 156 | in 157 | topological_sort ~visit_trace:ignore ~target ~find_direct_deps 158 | ;; 159 | -------------------------------------------------------------------------------- /src/ocamldep.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | (** Call [ocamldep] to recursively find dependencies for the [target] compilation unit, 5 | return a list of compilation units the [target] depends on in topological order. 6 | 7 | Failure cases includes: 8 | - cannot run ocamldep.opt 9 | - invalid working_dir, target not found 10 | - ocamldep errors (the program crashes, syntax errors, etc.) 11 | - cyclic dependency detected 12 | 13 | A compilation unit is a string representing an ml/mli module. It does not contain the 14 | extension. Example: 15 | 16 | {v 17 | file compilation unit 18 | a.mli? "a" 19 | Stack.mli? "Stack" 20 | /path/to/file.ml "file" 21 | /other/file.ml "file" 22 | v} 23 | 24 | This function assumes that the target and all its dependencies are located under the 25 | same directory, that is [working_dir], and that an .ml and an .mli for the same module 26 | have the same case. *) 27 | val find_dependencies 28 | : prog:string (* path to ocamldep.opt *) 29 | -> args:string list (* extra arguments for ocamldep.opt *) 30 | -> working_dir:string (* the dir target is in *) 31 | -> target:string (* name of target compilation unit *) 32 | -> string list Deferred.Or_error.t 33 | 34 | -------------------------------------------------------------------------------- /src/params.ml: -------------------------------------------------------------------------------- 1 | (* In the public release, this module is replaced by: 2 | 3 | {[ 4 | let build_info_as_sexp = 5 | Sexplib.Sexp.Atom (Md5.to_hex (Md5.digest_file_blocking Sys.executable_name)) 6 | 7 | let version = "NO_VERSION_UTIL" 8 | ]} 9 | *) 10 | include Version_util 11 | -------------------------------------------------------------------------------- /src/params.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | (*_ This file is replaced by an alternative file in the release version, since 4 | [Version_util] is not released and therefore not available. *) 5 | 6 | (** What we actually use from [Version_util]. *) 7 | val build_info_as_sexp : Sexp.t 8 | 9 | val version : string 10 | -------------------------------------------------------------------------------- /src/plugin_cache.ml: -------------------------------------------------------------------------------- 1 | module Stable = struct 2 | open! Core.Core_stable 3 | 4 | module Config = struct 5 | let try_old_cache_with_new_exec_default = false 6 | 7 | module V1 = struct 8 | type t = 9 | { dir : string 10 | ; max_files : int option [@sexp.option] 11 | ; readonly : bool 12 | } 13 | [@@deriving fields, sexp, bin_io, compare] 14 | end 15 | 16 | module V2 = struct 17 | type t = 18 | { dir : string 19 | ; max_files : int [@default 10] 20 | ; readonly : bool [@default false] 21 | ; try_old_cache_with_new_exec : bool 22 | [@default try_old_cache_with_new_exec_default] 23 | } 24 | [@@deriving fields, sexp, bin_io, compare] [@@sexp.allow_extra_fields] 25 | 26 | let of_prev (v1 : V1.t) = 27 | { dir = v1.dir 28 | ; max_files = Core.Option.value v1.max_files ~default:10 29 | ; readonly = v1.readonly 30 | ; try_old_cache_with_new_exec = try_old_cache_with_new_exec_default 31 | } 32 | ;; 33 | end 34 | end 35 | end 36 | 37 | open! Core 38 | open! Async 39 | open! Import 40 | module E = Deferred.Or_error 41 | 42 | module Build_info : sig 43 | type t [@@deriving sexp] 44 | 45 | val is_current : t -> bool 46 | val current : t 47 | val not_available : t 48 | end = struct 49 | type t = Sexp.t [@@deriving sexp] 50 | 51 | let not_available = [%sexp_of: string] "(not available)" 52 | let current = Params.build_info_as_sexp 53 | let is_current a = Sexp.equal current a 54 | end 55 | 56 | type filename = string [@@deriving sexp, compare] 57 | type basename = string [@@deriving sexp, compare, hash] 58 | 59 | let parallel list ~f = Deferred.Or_error.List.iter ~how:`Parallel list ~f 60 | 61 | module Digest : sig 62 | type t [@@deriving compare, hash, sexp] 63 | 64 | include Stringable with type t := t 65 | 66 | val file : filename -> t Deferred.Or_error.t 67 | val string : string -> t 68 | end = struct 69 | include String 70 | 71 | let to_hex fct arg = Md5.to_hex (fct arg) 72 | 73 | let file arg = 74 | let fct () = to_hex Md5.digest_file_blocking arg in 75 | Deferred.Or_error.try_with ~rest:`Log ~extract_exn:true (fun () -> In_thread.run fct) 76 | ;; 77 | 78 | let string arg = to_hex Md5.digest_string arg 79 | end 80 | 81 | module Key = struct 82 | module T = struct 83 | type t = (basename * Digest.t) list [@@deriving sexp, compare, hash] 84 | end 85 | 86 | include T 87 | include Hashable.Make (T) 88 | 89 | let of_sources sources = 90 | List.map sources ~f:(fun (filename, digest) -> Filename.basename filename, digest) 91 | ;; 92 | end 93 | 94 | module Sources = struct 95 | type t = (filename * Digest.t) list [@@deriving sexp] 96 | end 97 | 98 | module Plugin = struct 99 | type t = 100 | { cmxs_filename : filename (* invariant: absolute *) 101 | ; sources : Sources.t 102 | ; plugin_uuid : Plugin_uuid.t 103 | ; build_info : Build_info.t [@default Build_info.not_available] 104 | } 105 | [@@deriving fields, sexp] 106 | 107 | let t_of_sexp = Sexp.of_sexp_allow_extra_fields_recursively t_of_sexp 108 | let clean t = Shell.rm ~f:() [ t.cmxs_filename ] 109 | let was_compiled_by_current_exec t = Build_info.is_current t.build_info 110 | end 111 | 112 | module Make_count_by (M : sig 113 | val of_sources : Sources.t -> string list 114 | end) : sig 115 | module Key : sig 116 | type t 117 | 118 | val of_sources : Sources.t -> t 119 | end 120 | 121 | type t 122 | 123 | val create : unit -> t 124 | val incr : t -> Key.t -> unit 125 | val decr : t -> Key.t -> unit 126 | val find : t -> Key.t -> int 127 | end = struct 128 | module Key = struct 129 | module T = struct 130 | type t = string list [@@deriving sexp, compare, hash] 131 | end 132 | 133 | include T 134 | include Hashable.Make (T) 135 | 136 | let of_sources = M.of_sources 137 | end 138 | 139 | type t = int Key.Table.t 140 | 141 | let create () = Key.Table.create () 142 | let incr table key = Hashtbl.incr table key ~by:1 143 | 144 | let decr table key = 145 | Hashtbl.change table key ~f:(function 146 | | None -> None 147 | | Some x when x <= 1 -> None 148 | | Some x -> Some (pred x)) 149 | ;; 150 | 151 | let find table key = Option.value (Hashtbl.find table key) ~default:0 152 | end 153 | 154 | module Count_by_basenames = Make_count_by (struct 155 | let of_sources sources = 156 | List.map sources ~f:(fun (filename, _digest) -> Filename.basename filename) 157 | ;; 158 | end) 159 | 160 | module Count_by_filenames = Make_count_by (struct 161 | let of_sources sources = List.map sources ~f:fst 162 | end) 163 | 164 | module Info : sig 165 | type t [@@deriving sexp_of] 166 | 167 | val create : plugins:Plugin.t list -> unit -> t 168 | val plugins : t -> Plugin.t list 169 | val empty : t 170 | val info_file_pathname : dir:string -> string 171 | val load : dir:string -> t Deferred.Or_error.t 172 | val save : dir:string -> t -> unit Deferred.Or_error.t 173 | val cache_dir : string 174 | val cache_dir_perm : int 175 | end = struct 176 | type t = 177 | { version : Sexp.t 178 | ; build_info : Sexp.t 179 | ; plugins : Plugin.t list 180 | } 181 | [@@deriving sexp, fields] 182 | 183 | let t_of_sexp = Sexp.of_sexp_allow_extra_fields_recursively t_of_sexp 184 | 185 | let create ~plugins () = 186 | { version = sexp_of_string Params.version 187 | ; build_info = Params.build_info_as_sexp 188 | ; plugins 189 | } 190 | ;; 191 | 192 | let empty = create ~plugins:[] () 193 | let cache_dir = "cmxs-cache" 194 | let info_file = "cache-info.sexp" 195 | let cache_dir_perm = 0o755 196 | let cache_files_perm = 0o644 197 | let info_file_pathname ~dir = dir ^/ cache_dir ^/ info_file 198 | 199 | let save ~dir t = 200 | Deferred.Or_error.try_with ~rest:`Log ~extract_exn:true (fun () -> 201 | Writer.save_sexp ~perm:cache_files_perm (info_file_pathname ~dir) (sexp_of_t t)) 202 | ;; 203 | 204 | let load ~dir = 205 | let pathname = info_file_pathname ~dir in 206 | (* do no check for `Read there, let the reader fail in that case *) 207 | match%bind Unix.access pathname [ `Exists ] with 208 | | Ok () -> 209 | Deferred.Or_error.try_with ~rest:`Log ~extract_exn:true (fun () -> 210 | Reader.load_sexp_exn pathname t_of_sexp) 211 | | Error _ -> Deferred.return (Ok empty) 212 | ;; 213 | end 214 | 215 | module Config = struct 216 | module Stable = Stable.Config 217 | 218 | module V = struct 219 | type t = 220 | | V1 of Stable.V1.t 221 | | V2 of Stable.V2.t 222 | [@@deriving sexp] 223 | 224 | let to_current = function 225 | | V1 v1 -> Stable.V2.of_prev v1 226 | | V2 v2 -> v2 227 | ;; 228 | end 229 | 230 | include Stable.V2 231 | 232 | let t_of_sexp sexp = 233 | let v = 234 | try V.t_of_sexp sexp with 235 | | _ -> V.V1 (Stable.V1.t_of_sexp sexp) 236 | in 237 | V.to_current v 238 | ;; 239 | 240 | let sexp_of_t t = V.sexp_of_t (V2 t) 241 | 242 | let create 243 | ~dir 244 | ?(max_files = 10) 245 | ?(readonly = false) 246 | ?(try_old_cache_with_new_exec = Stable.try_old_cache_with_new_exec_default) 247 | () 248 | = 249 | { dir; max_files; readonly; try_old_cache_with_new_exec } 250 | ;; 251 | end 252 | 253 | module State = struct 254 | module Plugin_in_table = struct 255 | type t = 256 | { creation_num : int 257 | ; plugin : Plugin.t 258 | ; basenames : Count_by_basenames.Key.t 259 | ; filenames : Count_by_filenames.Key.t 260 | ; key : Key.t 261 | } 262 | [@@deriving fields] 263 | 264 | let older_first t1 t2 = Int.compare t1.creation_num t2.creation_num 265 | end 266 | 267 | type t = 268 | { config : Config.t 269 | ; mutable has_write_lock : bool 270 | ; mutable next_creation_num : int 271 | ; mutable old_files_deleted : bool 272 | ; table : Plugin_in_table.t Key.Table.t 273 | ; num_plugins_by_basenames : Count_by_basenames.t 274 | ; num_plugins_by_filenames : Count_by_filenames.t 275 | } 276 | 277 | let there_is_more_plugins_with_same what t p1 p2 = 278 | let num_plugins_with_same what t (p : Plugin_in_table.t) = 279 | match what with 280 | | `Basenames -> Count_by_basenames.find t.num_plugins_by_basenames p.basenames 281 | | `Filenames -> Count_by_filenames.find t.num_plugins_by_filenames p.filenames 282 | in 283 | Int.compare (num_plugins_with_same what t p2) (num_plugins_with_same what t p1) 284 | ;; 285 | 286 | let priority_heuristic_to_clean_plugins t a b = 287 | Comparable.lexicographic 288 | [ there_is_more_plugins_with_same `Filenames t 289 | ; there_is_more_plugins_with_same `Basenames t 290 | ; Plugin_in_table.older_first 291 | ] 292 | a 293 | b 294 | ;; 295 | 296 | let remove_internal t key = 297 | match Hashtbl.find_and_remove t.table key with 298 | | None -> () 299 | | Some plugin -> 300 | Count_by_basenames.decr t.num_plugins_by_basenames plugin.basenames; 301 | Count_by_filenames.decr t.num_plugins_by_filenames plugin.filenames 302 | ;; 303 | 304 | let get_and_clear_plugins_to_remove t = 305 | (* In practice this function is called each time we add a new plugin, so as soon as we 306 | reach the max capacity, which means the loop runs only once, in O(n). In rare 307 | cases this might run several times in case a old plugin cache was loaded after 308 | decreasing the max values. We tried as well an approach where we maintain a heap 309 | on addition incrementally but the code was more complex. *) 310 | let get_one t = 311 | let fold_data table ~init ~f = 312 | Hashtbl.fold table ~init ~f:(fun ~key:_ ~data acc -> f acc data) [@nontail] 313 | in 314 | Container.min_elt 315 | ~fold:fold_data 316 | t.table 317 | ~compare:(priority_heuristic_to_clean_plugins t) 318 | in 319 | let max_plugins = max 0 t.config.max_files in 320 | let rec loop acc = 321 | if Hashtbl.length t.table <= max_plugins 322 | then acc 323 | else ( 324 | match get_one t with 325 | | None -> acc 326 | | Some plugin -> 327 | remove_internal t plugin.key; 328 | loop (plugin :: acc)) 329 | in 330 | loop [] 331 | ;; 332 | 333 | let add_plugin_internal t (plugin : Plugin.t) = 334 | let sources = plugin.sources in 335 | let key = Key.of_sources sources in 336 | let basenames = Count_by_basenames.Key.of_sources sources in 337 | let filenames = Count_by_filenames.Key.of_sources sources in 338 | let plugin_in_table : Plugin_in_table.t = 339 | let creation_num = t.next_creation_num in 340 | t.next_creation_num <- succ creation_num; 341 | { plugin; creation_num; basenames; filenames; key } 342 | in 343 | remove_internal t key; 344 | Hashtbl.set t.table ~key ~data:plugin_in_table; 345 | Count_by_basenames.incr t.num_plugins_by_basenames basenames; 346 | Count_by_filenames.incr t.num_plugins_by_filenames filenames 347 | ;; 348 | 349 | let del_cmxs path filename = 350 | if Filename.check_suffix filename "cmxs" 351 | then Shell.rm ~f:() [ path ^/ filename ] 352 | else Deferred.Or_error.return () 353 | ;; 354 | 355 | let info t = 356 | let plugins = 357 | (* When creating the info the list is ordered from old to new so that when we 358 | deserialize the info, [creation_num] fields are assigned in the same order then 359 | before serialization. *) 360 | Hashtbl.data t.table 361 | |> List.sort ~compare:Plugin_in_table.older_first 362 | |> List.map ~f:Plugin_in_table.plugin 363 | in 364 | Info.create ~plugins () 365 | ;; 366 | 367 | let save_info t = Info.save ~dir:(Config.dir t.config) (info t) 368 | 369 | let lock_filename t = 370 | let config_dir = Config.dir t.config in 371 | config_dir ^/ Info.cache_dir ^ ".lock" 372 | ;; 373 | 374 | (* this lock is taken only if we actually need to modify the info. it is cleaned by the 375 | Nfs lock library at exit *) 376 | let take_write_lock t = 377 | if t.has_write_lock 378 | then Deferred.Or_error.return () 379 | else ( 380 | let lock_filename = lock_filename t in 381 | let%map.E () = Lock_file_async.Nfs.create lock_filename in 382 | t.has_write_lock <- true) 383 | ;; 384 | 385 | let load_info t = 386 | let config_dir = Config.dir t.config in 387 | let reset_cache_if_writable info = 388 | if_ 389 | (not (Config.readonly t.config)) 390 | (fun () -> 391 | let dir = Config.dir t.config ^/ Info.cache_dir in 392 | let%bind.E () = 393 | Monitor.try_with_or_error ~rest:`Log (fun () -> 394 | Unix.mkdir ~p:() ~perm:Info.cache_dir_perm dir) 395 | in 396 | let%bind.E () = take_write_lock t in 397 | let%bind.E () = Info.save ~dir:config_dir Info.empty in 398 | let%bind.E () = parallel ~f:Plugin.clean (Info.plugins info) in 399 | let cache_dir = config_dir ^/ Info.cache_dir in 400 | let%bind.E files = Shell.readdir cache_dir in 401 | Deferred.Or_error.List.iter 402 | ~how:`Sequential 403 | (Array.to_list files) 404 | ~f:(del_cmxs cache_dir)) 405 | in 406 | match%bind Info.load ~dir:config_dir with 407 | | Error error -> 408 | (* The info file exists but could not be read or could not be parsed. *) 409 | if Config.readonly t.config 410 | then 411 | (* If the config is readonly, then we would rather make an error instead of 412 | working as if there was no cache, because applications could become slow all 413 | of a sudden, for reasons that could be hard to debug. *) 414 | Or_error.error_s 415 | [%sexp 416 | "Read_only_info_file_exists_but_cannot_be_read_or_parsed" 417 | , (Info.info_file_pathname ~dir:config_dir : string) 418 | , (error : Error.t)] 419 | |> return 420 | else 421 | (* If it is a permissions error, recreating the info file will fail and we will 422 | get a proper error. If it is a parsing error, we will just clean the possibly 423 | existing cmxs files and then proceed as if there was no cache. *) 424 | reset_cache_if_writable Info.empty 425 | | Ok info -> 426 | (* filtering the plugin if the file is available *) 427 | let iter plugin = 428 | match%map Unix.access (Plugin.cmxs_filename plugin) [ `Exists; `Read ] with 429 | | Ok () -> add_plugin_internal t plugin 430 | | Error _ -> () 431 | in 432 | let%map () = Deferred.List.iter ~how:`Sequential ~f:iter (Info.plugins info) in 433 | Ok () 434 | ;; 435 | 436 | let create (config : Config.t) = 437 | let%bind.E config_dir = Shell.absolute_pathname (Config.dir config) in 438 | let state = 439 | { config = { config with dir = config_dir } 440 | ; has_write_lock = false 441 | ; next_creation_num = 0 442 | ; old_files_deleted = false 443 | ; table = Key.Table.create () 444 | ; num_plugins_by_basenames = Count_by_basenames.create () 445 | ; num_plugins_by_filenames = Count_by_filenames.create () 446 | } 447 | in 448 | let%bind.E () = load_info state in 449 | Deferred.return (Ok state) 450 | ;; 451 | 452 | let clean_old t = 453 | assert (not (Config.readonly t.config)); 454 | let%bind.E () = 455 | parallel (get_and_clear_plugins_to_remove t) ~f:(fun plugin_in_table -> 456 | Plugin.clean plugin_in_table.plugin) 457 | in 458 | (* clean other old cmxs files that are no longer referenced by the info 459 | needs to be done only once *) 460 | if t.old_files_deleted 461 | then Deferred.Or_error.return () 462 | else ( 463 | let current_cmxs_basename = 464 | let basenames = 465 | List.rev_map (Hashtbl.data t.table) ~f:(fun plugin -> 466 | Filename.basename (Plugin.cmxs_filename (Plugin_in_table.plugin plugin))) 467 | in 468 | String.Hash_set.of_list basenames 469 | in 470 | let cache_dir = Config.dir t.config ^/ Info.cache_dir in 471 | let%bind.E files = Shell.readdir cache_dir in 472 | let%map.E r = 473 | Deferred.Or_error.List.iter ~how:`Sequential (Array.to_list files) ~f:(fun file -> 474 | if not (Hash_set.mem current_cmxs_basename file) 475 | then del_cmxs cache_dir file 476 | else Deferred.Or_error.return ()) 477 | in 478 | t.old_files_deleted <- true; 479 | r) 480 | ;; 481 | 482 | let find t sources = 483 | match Hashtbl.find t.table (Key.of_sources sources) with 484 | | None -> None 485 | | Some { plugin; _ } -> 486 | if Plugin.was_compiled_by_current_exec plugin 487 | || Config.try_old_cache_with_new_exec t.config 488 | then Some plugin 489 | else None 490 | ;; 491 | 492 | let add t sources plugin_uuid filename = 493 | if_ 494 | (not (Config.readonly t.config)) 495 | (fun () -> 496 | let dir = Config.dir t.config ^/ Info.cache_dir in 497 | let%bind.E () = 498 | Monitor.try_with_or_error ~rest:`Log (fun () -> 499 | Unix.mkdir ~p:() ~perm:Info.cache_dir_perm dir) 500 | in 501 | let%bind.E () = take_write_lock t in 502 | let uuid = Plugin_uuid.uuid plugin_uuid in 503 | let cmxs_filename = dir ^/ Uuid.to_string uuid ^ ".cmxs" in 504 | let%bind.E () = Shell.cp ~source:filename ~dest:cmxs_filename in 505 | let%bind.E () = Shell.chmod cmxs_filename ~perm:Info.cache_dir_perm in 506 | let plugin : Plugin.t = 507 | { sources; plugin_uuid; cmxs_filename; build_info = Build_info.current } 508 | in 509 | add_plugin_internal t plugin; 510 | let%bind.E () = clean_old t in 511 | save_info t) 512 | ;; 513 | 514 | let clean t = 515 | let had_lock = t.has_write_lock in 516 | t.has_write_lock <- false; 517 | if_ had_lock (fun () -> Lock_file_async.Nfs.unlock (lock_filename t)) 518 | ;; 519 | end 520 | 521 | include State 522 | 523 | let filenames_from_ml_bundles lst = 524 | let f x = 525 | let `ml ml, `mli opt_mli, `module_name _ = Ml_bundle.to_pathnames x in 526 | ml :: Option.to_list opt_mli 527 | in 528 | List.concat_map lst ~f 529 | ;; 530 | 531 | let digest files = 532 | let files = filenames_from_ml_bundles files in 533 | Deferred.Or_error.List.map ~how:`Parallel files ~f:(fun file -> 534 | let%map.E digest = Digest.file file in 535 | file, digest) 536 | ;; 537 | -------------------------------------------------------------------------------- /src/plugin_cache.mli: -------------------------------------------------------------------------------- 1 | (** This cache avoid recompilation of sources if there are no changes in the files. Since 2 | we want the side effects to be executed in case of a re-loading, this isn't a cache of 3 | dynloading. The purpose of this cache is to speed up the initialization of programs 4 | relying on an ml config set up. The cache is meant to be persistent between different 5 | executions of the program. Basically, cmxs files are stored in a specific location. 6 | This is not a ram cache. This module handles version upgrades. The info file 7 | contains the version of the executable using the cache. If the version doesn't match, 8 | the cache is deleted (or just skipped if no write access). *) 9 | 10 | open! Core 11 | open! Async 12 | 13 | (** Mutable type containing information about the cached files. *) 14 | type t 15 | 16 | type filename = string 17 | 18 | module Sources : sig 19 | type t 20 | end 21 | 22 | module Plugin : sig 23 | type t 24 | 25 | val cmxs_filename : t -> string 26 | val sources : t -> Sources.t 27 | val was_compiled_by_current_exec : t -> bool 28 | end 29 | 30 | module Config : sig 31 | type t [@@deriving sexp] 32 | 33 | val create 34 | : dir:string 35 | -> ?max_files:int (* default is 10 *) 36 | -> ?readonly:bool (* default is false *) 37 | -> ?try_old_cache_with_new_exec:bool (* default is false *) 38 | -> unit 39 | -> t 40 | 41 | val dir : t -> string 42 | val max_files : t -> int 43 | val readonly : t -> bool 44 | val try_old_cache_with_new_exec : t -> bool 45 | 46 | module Stable : sig 47 | module V1 : Stable_without_comparator 48 | 49 | module V2 : sig 50 | (** Note that the sexp representation for this [t] is different than for the main 51 | type, even though they are equal types: the main type's sexp converter includes 52 | a version tag to try to upgrade more seamlessly. *) 53 | type nonrec t = t 54 | 55 | include Stable_without_comparator with type t := t 56 | 57 | val of_prev : V1.t -> t 58 | end 59 | end 60 | end 61 | 62 | (** Loading info and cache initialization, including some clean-up if needed, etc. 63 | cleaning old version files if present. *) 64 | val create : Config.t -> t Deferred.Or_error.t 65 | 66 | val digest : Ml_bundle.t list -> Sources.t Deferred.Or_error.t 67 | val find : t -> Sources.t -> Plugin.t option 68 | 69 | (** Update the info in the file system, perform some clean-up if needed. *) 70 | val add : t -> Sources.t -> Plugin_uuid.t -> filename -> unit Deferred.Or_error.t 71 | 72 | (** Release this plugin cache lock. *) 73 | val clean : t -> unit Deferred.Or_error.t 74 | 75 | (** Exported to be used in some other part of ocaml_plugin. *) 76 | module Digest : sig 77 | type t [@@deriving compare, sexp] 78 | 79 | include Stringable with type t := t 80 | 81 | val file : filename -> t Deferred.Or_error.t 82 | val string : string -> t 83 | end 84 | -------------------------------------------------------------------------------- /src/plugin_uuid.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | module Repr = struct 4 | type t = 5 | { t : string 6 | ; univ_constr : string 7 | } 8 | [@@deriving sexp, fields] 9 | 10 | let create ~t ~univ_constr = { t; univ_constr } 11 | 12 | let side_effect = 13 | { t = "Ocaml_plugin.Dynloader.Side_effect" 14 | ; univ_constr = "Ocaml_plugin.Dynloader.side_effect_univ_constr" 15 | } 16 | ;; 17 | end 18 | 19 | module V1 = struct 20 | type t = 21 | { uuid : Uuid.Stable.V1.t 22 | ; ml_bundles : Ml_bundle.t list 23 | ; repr : Repr.t option 24 | } 25 | [@@deriving sexp, fields] 26 | end 27 | 28 | module V2 = struct 29 | module Prev = V1 30 | 31 | type t = 32 | { uuid : Uuid.Stable.V1.t 33 | ; ml_bundles : Ml_bundle.t list 34 | ; repr : Repr.t 35 | } 36 | [@@deriving sexp, fields] 37 | 38 | let t_of_sexp = Sexp.of_sexp_allow_extra_fields_recursively t_of_sexp 39 | 40 | let of_prev prev = 41 | let { Prev.uuid; ml_bundles; repr } = prev in 42 | let repr = 43 | match repr with 44 | | Some repr -> repr 45 | | None -> Repr.side_effect 46 | in 47 | { uuid; ml_bundles; repr } 48 | ;; 49 | end 50 | 51 | module Versioned = struct 52 | type t = 53 | | V1 of V1.t 54 | | V2 of V2.t 55 | [@@deriving sexp] 56 | 57 | let to_current = function 58 | | V1 v1 -> V2.of_prev v1 59 | | V2 v2 -> v2 60 | ;; 61 | 62 | let of_current v2 = V2 v2 63 | end 64 | 65 | include V2 66 | 67 | let of_v1 = V2.of_prev 68 | 69 | let t_of_sexp sexp = 70 | match Versioned.t_of_sexp sexp with 71 | | versioned -> Versioned.to_current versioned 72 | | exception _ -> 73 | (* initially this was not versioned *) 74 | of_v1 (V1.t_of_sexp sexp) 75 | ;; 76 | 77 | let sexp_of_t t = Versioned.sexp_of_t (Versioned.of_current t) 78 | let create ~repr ~ml_bundles () = { uuid = Uuid_unix.create (); ml_bundles; repr } 79 | -------------------------------------------------------------------------------- /src/plugin_uuid.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | module Repr : sig 4 | type t 5 | 6 | val create : t:string -> univ_constr:string -> t 7 | val t : t -> string 8 | val univ_constr : t -> string 9 | end 10 | 11 | (** [t] is a unique identifier for plugin, along with some information needed for code 12 | generation and that make debugging nicer because they end up in the cache info. *) 13 | type t [@@deriving sexp] 14 | 15 | val uuid : t -> Uuid.t 16 | val create : repr:Repr.t -> ml_bundles:Ml_bundle.t list -> unit -> t 17 | val ml_bundles : t -> Ml_bundle.t list 18 | val repr : t -> Repr.t 19 | -------------------------------------------------------------------------------- /src/shell.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | module E = Deferred.Or_error 4 | 5 | let permission_exe = 0o700 6 | let echo = ref false 7 | let verbose = ref false 8 | 9 | let set_defaults ?verbose:(v = !verbose) ?echo:(e = !echo) () = 10 | echo := e; 11 | verbose := v; 12 | () 13 | ;; 14 | 15 | module Process_flag = struct 16 | let echo = Command.Param.(flag "-shell-echo" no_arg ~doc:" show external shell calls") 17 | 18 | let verbose = 19 | Command.Param.( 20 | flag 21 | "-shell-verbose" 22 | no_arg 23 | ~doc:" let external shell call be more verbose (imply -shell-echo)") 24 | ;; 25 | 26 | let all = 27 | Command.Param.( 28 | map2 echo verbose ~f:(fun echo verbose -> set_defaults ~echo ~verbose ())) 29 | ;; 30 | end 31 | 32 | let flags = Process_flag.all 33 | let endline std = if String.is_empty std then std else std ^ "\n" 34 | 35 | let make_run from_output ?working_dir ?env ?(quiet_or_error = false) prog args = 36 | let command_text = lazy (prog :: args |> [%sexp_of: string list] |> Sexp.to_string) in 37 | if !echo then Core.Printf.printf "Shell: %s\n%!" (force command_text); 38 | let%bind.E process = Process.create ?working_dir ?env ~prog ~args () in 39 | let%map output = Process.collect_output_and_wait process in 40 | let { Process.Output.stdout; stderr; exit_status } = output in 41 | let error_and_status = 42 | match exit_status with 43 | | Error status -> Error (Some status) 44 | | Ok () -> 45 | if quiet_or_error && ((not (String.is_empty stdout)) || not (String.is_empty stderr)) 46 | then Error None 47 | else Ok () 48 | in 49 | if !verbose then Core.Printf.printf "%s%s%!" (endline stdout) (endline stderr); 50 | match error_and_status with 51 | | Ok () -> Ok (from_output output) 52 | | Error status -> 53 | let working_dir = 54 | match working_dir with 55 | | Some working_dir -> working_dir 56 | | None -> "none (cwd)" 57 | in 58 | let error = 59 | Error.of_lazy 60 | (lazy 61 | ((* not using an sexp_of_t because it makes the output unreadable by escaping 62 | newlines *) 63 | let status = 64 | match status with 65 | | Some status -> 66 | Sexp.to_string ([%sexp_of: Core_unix.Exit_or_signal.error] status) 67 | | None -> "error trace on stdout or stderr" 68 | in 69 | sprintf 70 | "working_dir: %s\n%sstatus: %s\ncommand: %s\n%s%s" 71 | working_dir 72 | (match env with 73 | | None -> "" 74 | | Some env -> sprintf !"environment: %{sexp#mach:Unix.env}" env) 75 | status 76 | (force command_text) 77 | stdout 78 | (if String.is_empty stdout then stderr else "\n" ^ stderr))) 79 | in 80 | Error error 81 | ;; 82 | 83 | let run = make_run ignore 84 | 85 | let run_lines = 86 | make_run ~quiet_or_error:false (function { Process.Output.stdout; _ } -> 87 | List.filter_map (String.split ~on:'\n' stdout) ~f:(fun s -> 88 | let s = String.rstrip s in 89 | if String.is_empty s then None else Some s)) 90 | ;; 91 | 92 | let getcwd () = 93 | Deferred.Or_error.try_with ~rest:`Log ~name:"Ocaml_plugin.Shell.getcwd" Sys.getcwd 94 | ;; 95 | 96 | let chmod pathname ~perm = 97 | Deferred.Or_error.try_with ~rest:`Log ~extract_exn:true (fun () -> 98 | Unix.chmod pathname ~perm) 99 | ;; 100 | 101 | let raw_temp_dir 102 | ~in_dir 103 | ?(prefix = "ocaml_plugin_") 104 | ?(suffix = ".build") 105 | ?(perm = permission_exe) 106 | () 107 | = 108 | let fct () = Filename_unix.temp_dir ~perm ~in_dir prefix suffix in 109 | Deferred.Or_error.try_with ~rest:`Log ~extract_exn:true (fun () -> 110 | let%bind () = Unix.mkdir ~p:() ~perm in_dir in 111 | In_thread.run fct) 112 | ;; 113 | 114 | let absolute_pathname filename = 115 | if Filename.is_relative filename 116 | then ( 117 | let%map.E prefix = getcwd () in 118 | prefix ^/ filename) 119 | else Deferred.return (Ok filename) 120 | ;; 121 | 122 | let absolute_pathnames filenames = 123 | let relative = ref false in 124 | let map filename = 125 | if Filename.is_relative filename 126 | then ( 127 | relative := true; 128 | `relative filename) 129 | else `absolute filename 130 | in 131 | let filenames = List.rev_map ~f:map filenames in 132 | if !relative 133 | then ( 134 | let%map.E cwd = getcwd () in 135 | let files = 136 | List.rev_map filenames ~f:(function 137 | | `absolute filename -> filename 138 | | `relative filename -> cwd ^/ filename) 139 | in 140 | files) 141 | else ( 142 | let files = 143 | List.rev_map filenames ~f:(function 144 | | `absolute filename -> filename 145 | | `relative _ -> assert false) 146 | in 147 | Deferred.return (Ok files)) 148 | ;; 149 | 150 | (* this should return an absolute pathname *) 151 | let temp_dir ~in_dir ?prefix ?suffix ?perm () = 152 | raw_temp_dir ~in_dir ?prefix ?suffix ?perm () >>=? absolute_pathname 153 | ;; 154 | 155 | let rm ?r ?f paths = 156 | let r = Option.map r ~f:(fun () -> "-r") in 157 | let f = Option.map f ~f:(fun () -> "-f") in 158 | run "/bin/rm" (List.filter_map ~f:Fn.id [ r; f ] @ ("--" :: paths)) 159 | ;; 160 | 161 | let rmdir dir = run "/bin/rmdir" [ dir ] 162 | let cp ~source ~dest = run "/bin/cp" [ source; dest ] 163 | let readdir dir = Deferred.Or_error.try_with ~rest:`Log (fun () -> Sys.readdir dir) 164 | -------------------------------------------------------------------------------- /src/shell.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | 5 | (** Global properties regarding bash sys calls. Echo would print the command before 6 | running them, and verbose would print the full output of the command. *) 7 | val set_defaults : ?verbose:bool -> ?echo:bool -> unit -> unit 8 | 9 | (** Offers a command line param to set verbose and echo directly. *) 10 | val flags : unit Command.Param.t 11 | 12 | val run 13 | : ?working_dir:string 14 | -> ?env:Unix.env 15 | -> ?quiet_or_error:bool 16 | -> string 17 | -> string list 18 | -> unit Deferred.Or_error.t 19 | 20 | val run_lines 21 | : ?working_dir:string 22 | -> ?env:Unix.env 23 | -> string 24 | -> string list 25 | -> string list Deferred.Or_error.t 26 | 27 | val getcwd : unit -> string Deferred.Or_error.t 28 | val chmod : string -> perm:Unix.file_perm -> unit Deferred.Or_error.t 29 | 30 | (** When this function succeed, it returns a absolute pathname. *) 31 | val temp_dir 32 | : in_dir:string 33 | -> ?prefix:string (* default: "ocaml_plugin_" *) 34 | -> ?suffix:string (* default: ".build" *) 35 | -> ?perm:Unix.file_perm (* default: 0o700 *) 36 | -> unit 37 | -> string Deferred.Or_error.t 38 | 39 | val absolute_pathname : string -> string Deferred.Or_error.t 40 | val absolute_pathnames : string list -> string list Deferred.Or_error.t 41 | val rm : ?r:unit -> ?f:unit -> string list -> unit Deferred.Or_error.t 42 | val rmdir : string -> unit Deferred.Or_error.t 43 | val cp : source:string -> dest:string -> unit Deferred.Or_error.t 44 | val readdir : string -> string array Deferred.Or_error.t 45 | -------------------------------------------------------------------------------- /src/tar.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | let extract ~working_dir tar = 5 | let args = [ "-xzf"; tar ] in 6 | Shell.run ~working_dir "tar" args 7 | ;; 8 | 9 | let list tar = 10 | (* curiously, tar doesn't need a z option *) 11 | let args = [ "-tf"; tar ] in 12 | Shell.run_lines "tar" args 13 | ;; 14 | 15 | let create ~working_dir ~files tar = 16 | (* The tar should be deterministic if possible, to avoid causing spurious rebuilds. 17 | This option isn't supported on mac os, it seems, so we use this conditionally. *) 18 | let deterministic_archive_flag = [ "--mtime"; "2017-01-01" ] in 19 | let%bind support_mtime = 20 | Process.run 21 | ~working_dir 22 | ~prog:"tar" 23 | ~args:(deterministic_archive_flag @ [ "--version" ]) 24 | () 25 | >>| Result.is_ok 26 | in 27 | let args = 28 | (if support_mtime then deterministic_archive_flag else []) 29 | @ [ "-I"; "gzip -n"; "-cf"; tar ] 30 | @ files 31 | in 32 | Shell.run ~working_dir "tar" args 33 | ;; 34 | -------------------------------------------------------------------------------- /src/tar.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | val create : working_dir:string -> files:string list -> string -> unit Deferred.Or_error.t 5 | val extract : working_dir:string -> string -> unit Deferred.Or_error.t 6 | val list : string -> string list Deferred.Or_error.t 7 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (executables (names plugin_loader) (modules plugin_loader) 2 | (libraries async core_unix.command_unix core core_unix.filename_unix 3 | ocaml_plugin) 4 | (preprocess (pps ppx_jane))) 5 | 6 | (alias (name runtest) 7 | (deps plugin_loader.exe test_with_sexp.ml test_with_sexp.mli) 8 | (action (bash "./plugin_loader.exe test_with_sexp.mli"))) 9 | 10 | (alias (name runtest) 11 | (deps plugin_loader.exe test_with_sexp.ml test_with_sexp.mli) 12 | (action (bash "./plugin_loader.exe test_with_sexp.ml"))) 13 | 14 | (alias (name runtest) 15 | (deps plugin_loader.exe test_with_sexp.ml test_with_sexp.mli 16 | test_with_sexp_dep.ml test_with_sexp_dep.mli) 17 | (action 18 | (bash "./plugin_loader.exe --find-dependencies test_with_sexp_dep.ml"))) -------------------------------------------------------------------------------- /test/jbuild-ignore: -------------------------------------------------------------------------------- 1 | tmp_dir 2 | -------------------------------------------------------------------------------- /test/plugin_loader.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Async 3 | 4 | let run 5 | ?use_cache 6 | ?persistent_archive_dirpath 7 | ~trigger_unused_value_warnings_despite_mli 8 | ~find_dependencies 9 | files 10 | = 11 | let%bind cwd = Sys.getcwd () in 12 | let in_dir = Filename.concat cwd "tmp_dir" in 13 | match%bind 14 | if find_dependencies 15 | then ( 16 | match files with 17 | | [ file ] -> 18 | Ocaml_plugin.Compiler.with_compiler 19 | ~in_dir 20 | ~trigger_unused_value_warnings_despite_mli 21 | ?use_cache 22 | ?persistent_archive_dirpath 23 | ~f:(fun compiler -> 24 | let loader = Ocaml_plugin.Compiler.loader compiler in 25 | Ocaml_plugin.Dynloader.find_dependencies loader file 26 | >>=? fun files -> 27 | (match Sys.getenv "VERBOSE" with 28 | | None -> () 29 | | Some _ -> 30 | Core.Printf.printf 31 | "Loaded %s\n" 32 | (String.concat (List.map files ~f:Filename.basename) ~sep:" ")); 33 | Ocaml_plugin.Dynloader.Side_effect.load_ocaml_src_files loader files) 34 | () 35 | | _ -> 36 | failwithf 37 | "When --find-dependencies is specified, only one file should be given" 38 | ()) 39 | else 40 | Ocaml_plugin.Compiler.Side_effect.load_ocaml_src_files 41 | ~in_dir 42 | ~trigger_unused_value_warnings_despite_mli 43 | ?use_cache 44 | ?persistent_archive_dirpath 45 | files 46 | with 47 | | Ok () -> Deferred.unit 48 | | Error e -> 49 | prerr_endline (Error.to_string_hum e); 50 | return (Shutdown.shutdown 1) 51 | ;; 52 | 53 | let groups l = 54 | List.map 55 | (String.split ~on:'|' (String.concat l ~sep:" ")) 56 | ~f:(fun s -> 57 | List.filter (String.split ~on:' ' s) ~f:(function 58 | | "" -> false 59 | | _ -> true)) 60 | ;; 61 | 62 | let max_files_default = 2 63 | 64 | let use_cache ~max_files = 65 | Ocaml_plugin.Plugin_cache.Config.create 66 | ~dir:"cache" 67 | ~max_files 68 | ~readonly:false 69 | ~try_old_cache_with_new_exec:true 70 | () 71 | ;; 72 | 73 | let command = 74 | Command.async 75 | ~summary:"unit test program for ocaml-plugin" 76 | (let open Command.Let_syntax in 77 | let%map_open use_cache = 78 | let%map cache = flag "--cache" no_arg ~doc:" use a plugin cache" 79 | and cache_size = 80 | flag 81 | "--cache-size" 82 | (optional_with_default max_files_default int) 83 | ~doc:(sprintf " specify size of plugin cache. default %d" max_files_default) 84 | in 85 | if cache then Some (use_cache ~max_files:cache_size) else None 86 | and persistent_archive_dirpath = 87 | map 88 | ~f:(fun b -> if b then Some "cache" else None) 89 | (flag 90 | "--persistent-archive" 91 | no_arg 92 | ~doc:" use a persistent location for the extracted compiler") 93 | and trigger_unused_value_warnings_despite_mli = 94 | flag 95 | "--warnings-in-utils" 96 | no_arg 97 | ~doc:" trigger unused warnings even in utils with an mli" 98 | and find_dependencies = 99 | flag "--find-dependencies" no_arg ~doc:" use ocamldep to generate dependencies" 100 | and files = anon (sequence ("" %: Filename_unix.arg_type)) in 101 | fun () -> 102 | let open! Deferred.Let_syntax in 103 | Deferred.List.iter 104 | ~how:`Sequential 105 | (groups files) 106 | ~f: 107 | (run 108 | ?use_cache 109 | ?persistent_archive_dirpath 110 | ~trigger_unused_value_warnings_despite_mli 111 | ~find_dependencies)) 112 | ~behave_nicely_in_pipeline:false 113 | ;; 114 | 115 | 116 | let () = Command_unix.run command 117 | -------------------------------------------------------------------------------- /test/setup-script: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | function matches { 4 | stdin="$(cat /dev/stdin)" 5 | if echo "$stdin" | tr '\n' ' ' | grep -q "$@"; then 6 | : 7 | else 8 | echo "$stdin" 9 | fi 10 | } 11 | export -f matches 12 | 13 | function setup { 14 | set -o pipefail 15 | } 16 | export -f setup 17 | 18 | export TEST_DIR="$(readlink -f $(dirname "$BASH_SOURCE"))" 19 | cd "$TEST_DIR" 20 | -------------------------------------------------------------------------------- /test/test-basic.t: -------------------------------------------------------------------------------- 1 | $ setup 2 | 3 | Loading non existing mli/ml 4 | 5 | $ rm -f *.ml* 6 | $ $TEST_DIR/plugin_loader.exe ./test.mli |& matches "test.mli: No such file or directory" 7 | [1] 8 | $ $TEST_DIR/plugin_loader.exe ./test.ml |& matches "test.ml: No such file or directory" 9 | [1] 10 | 11 | Loading mli without ml 12 | 13 | $ rm -f *.ml* 14 | $ touch test.mli 15 | $ $TEST_DIR/plugin_loader.exe ./test.mli |& matches "test.ml: No such file or directory" 16 | [1] 17 | 18 | Loading ml without mli 19 | 20 | $ rm -f *.ml* 21 | $ echo 'let () = print_endline "loaded"' > test.ml 22 | $ $TEST_DIR/plugin_loader.exe ./test.ml 23 | loaded 24 | 25 | Loading ml with mli by mentioning the ml/mli/ml without extension 26 | 27 | $ rm -f *.ml* 28 | $ touch test.mli 29 | $ echo 'let () = print_endline "loaded"' > test.ml 30 | $ $TEST_DIR/plugin_loader.exe ./test.mli 31 | loaded 32 | $ $TEST_DIR/plugin_loader.exe ./test.ml 33 | loaded 34 | $ $TEST_DIR/plugin_loader.exe ./test 35 | loaded 36 | 37 | Loading ml with mli by mentioning the wrong mli 38 | 39 | $ rm -f *.ml* 40 | $ touch test.ml 41 | $ echo 'val a : int' > test.mli 42 | $ $TEST_DIR/plugin_loader.exe ./test.mli |& matches "The .* \`a' is required" 43 | [1] 44 | 45 | Loading the same file several times 46 | 47 | $ rm -f *.ml* 48 | $ echo 'let () = print_endline "loaded"' > test.ml 49 | $ $TEST_DIR/plugin_loader.exe 'test.ml | test.ml | test.ml' 50 | loaded 51 | loaded 52 | loaded 53 | 54 | Loading a file that blows up at toplevel 55 | 56 | $ rm -f *.ml* 57 | $ echo 'let () = failwith "blowup"' > test.ml 58 | $ $TEST_DIR/plugin_loader.exe ./test.ml 59 | ("Exception while executing the plugin's toplevel" (Failure blowup)) 60 | [1] 61 | 62 | Loading several ml files 63 | 64 | $ rm -f *.ml* 65 | $ echo '#!/usr/bin/env ocaml' > test1.ml 66 | $ echo 'let x = Test2.x ^ "-middle"' >> test1.ml 67 | $ echo '#!/usr/bin/env ocaml' > test2.ml 68 | $ echo 'let x = "first"' >> test2.ml 69 | $ echo '#!/usr/bin/env ocaml' > test3.ml 70 | $ echo 'let x = Test1.x ^ "-last";; let () = print_endline x' >> test3.ml 71 | $ $TEST_DIR/plugin_loader.exe test2.ml test1.ml test3.ml 72 | first-middle-last 73 | -------------------------------------------------------------------------------- /test/test-cache.t: -------------------------------------------------------------------------------- 1 | $ setup 2 | 3 | Loading the same ml file several times with a cache. 4 | 5 | $ function cache_size { find cache -type f -name '*.cmxs' | wc -l; } 6 | 7 | $ echo 'let () = print_endline "loaded"' > test.ml 8 | $ $TEST_DIR/plugin_loader.exe --cache 'test.ml | test.ml' 9 | loaded 10 | loaded 11 | $ cache_size 12 | 1 13 | 14 | $ $TEST_DIR/plugin_loader.exe --cache 'test.ml | test.ml' 15 | loaded 16 | loaded 17 | $ cache_size 18 | 1 19 | 20 | Check that plugin are indexed by basenames. 21 | 22 | $ mkdir -p plugins 23 | $ cp test.ml plugins/. 24 | $ $TEST_DIR/plugin_loader.exe --cache 'plugins/test.ml | plugins/test.ml' 25 | loaded 26 | loaded 27 | $ cache_size 28 | 1 29 | 30 | Checking that we really are using the cache. 31 | 32 | $ cmxs_before="$(find cache -type f -name '*.cmxs')" 33 | 34 | $ echo 'let () = print_endline "loaded2"' > test2.ml 35 | $ $TEST_DIR/plugin_loader.exe --cache 'test2.ml' 36 | loaded2 37 | $ cache_size 38 | 2 39 | 40 | $ cmxs_after="$(find cache -type f -name '*.cmxs')" 41 | $ for i in $cmxs_after; do if [ "$i" != "$cmxs_before" ]; then cp "$i" "$cmxs_before"; fi; done 42 | $ $TEST_DIR/plugin_loader.exe --cache test.ml 43 | loaded2 44 | 45 | Check the heuristic to pick what old cache to clean. 46 | 47 | $ cache_info="cache/cmxs-cache/cache-info.sexp" 48 | $ cat $cache_info | grep -q "$TESTTMP/test.ml" 49 | 50 | $ echo 'let () = print_endline "plugins/loaded"' > plugins/test.ml 51 | $ $TEST_DIR/plugin_loader.exe --cache-size 2 --cache 'plugins/test.ml | plugins/test.ml' 52 | plugins/loaded 53 | plugins/loaded 54 | $ cache_size 55 | 2 56 | 57 | $ cache_info="cache/cmxs-cache/cache-info.sexp" 58 | $ cat $cache_info | grep -q "$TESTTMP/test.ml" 59 | [1] 60 | -------------------------------------------------------------------------------- /test/test-inferred-interface.t: -------------------------------------------------------------------------------- 1 | It used to be the case that in the default mode where we get warnings for every unused 2 | value in modules without interfaces, the inferred interfaces would not be in the scope 3 | of hand written interfaces. 4 | 5 | $ setup 6 | $ echo 'type t = string' > a.ml 7 | $ echo 'type t = A.t' > b.mli 8 | $ echo 'type t = A.t' > b.ml 9 | $ echo 'let () = print_endline "ok"' >> b.ml 10 | $ $TEST_DIR/plugin_loader.exe a.ml b.mli b.ml 11 | ok 12 | -------------------------------------------------------------------------------- /test/test-language-features.t: -------------------------------------------------------------------------------- 1 | Testing that various language feature do work in plugins. 2 | 3 | $ setup 4 | 5 | Lazy 6 | 7 | $ cat > test.ml < let lazy x = lazy (print_endline "using lazy is fine"; 1+41) 9 | > let () = assert (x = 42) 10 | > EOF 11 | $ $TEST_DIR/plugin_loader.exe ./test.ml 12 | using lazy is fine 13 | 14 | Recursive modules 15 | 16 | $ cat > test.ml < module rec _ : sig end = struct 18 | > let () = print_endline "rec modules" 19 | > end and _ : sig end = struct 20 | > end 21 | > EOF 22 | $ $TEST_DIR/plugin_loader.exe ./test.ml 23 | rec modules 24 | 25 | Objects 26 | 27 | $ cat > test.ml < let o = object 29 | > method print = print_endline "objects ftw" 30 | > end 31 | > let () = o#print 32 | > EOF 33 | $ $TEST_DIR/plugin_loader.exe ./test.ml 34 | objects ftw 35 | 36 | Generative functors 37 | 38 | $ cat > test.ml < module F() = struct type _t let () = print_endline "ok" end 40 | > include F() 41 | > EOF 42 | $ $TEST_DIR/plugin_loader.exe ./test.ml 43 | ok 44 | -------------------------------------------------------------------------------- /test/test-ocamldep.t: -------------------------------------------------------------------------------- 1 | $ setup 2 | 3 | Loading several ml files with ocamldep in a read-only folder 4 | 5 | $ rm -f *.ml* 6 | $ mkdir -p readonly 7 | $ echo 'let () = print_endline "this should not be loaded"' > readonly/test.ml 8 | $ echo 'let () "this syntax error shall not be a problem"' > readonly/test_with_typo.ml 9 | $ echo 'open Core;; let x = Test2.x ^ (sprintf !"%{sexp: string}" "-middle")' > readonly/test1.ml 10 | $ echo 'let x = "first"' > readonly/test2.ml 11 | $ echo '#!/usr/bin/env ocaml' > readonly/test3.ml 12 | $ echo 'let x = Test1.x ^ "-last";; let () = print_endline x' >> readonly/test3.ml 13 | $ chmod -R -w readonly 14 | $ VERBOSE= $TEST_DIR/plugin_loader.exe --find-dependencies readonly/test3.ml 15 | Loaded test2.ml test1.ml test3.ml 16 | first-middle-last 17 | $ chmod -R +w readonly 18 | 19 | Loading several ml files with different cases and using ocamldep 20 | 21 | $ rm -f *.ml* 22 | $ echo 'let y = "foo"' > Test.ml 23 | $ echo 'val y : string' > Test.mli 24 | $ echo '#!/usr/bin/env ocaml' > test1.ml 25 | $ echo 'let () = print_endline Test.y;; let x = Test.y' >> test1.ml 26 | $ echo 'val x : string' > test1.mli 27 | $ VERBOSE= $TEST_DIR/plugin_loader.exe --find-dependencies test1.ml 28 | Loaded Test.mli Test.ml test1.mli test1.ml 29 | foo 30 | -------------------------------------------------------------------------------- /test/test-persistent-archive.t: -------------------------------------------------------------------------------- 1 | $ setup 2 | 3 | Checking that archive is really persistent 4 | 5 | $ function ocamlopt_stat { 6 | > stat -c %z cache/compiler/ocamlopt.opt 7 | > } 8 | 9 | $ echo 'let () = print_endline "persistent"' > test1.ml 10 | $ $TEST_DIR/plugin_loader.exe --persistent-archive test1.ml 11 | persistent 12 | $ grep 'archive_digest fake-digest' cache/compiler/archive-info.sexp 13 | [1] 14 | $ compiler_stat=$(ocamlopt_stat) 15 | $ $TEST_DIR/plugin_loader.exe --persistent-archive test1.ml 16 | persistent 17 | $ compiler_stat2=$(ocamlopt_stat) 18 | $ [ "$compiler_stat" = "$compiler_stat2" ] 19 | $ sed -r -i -e 's/cmi [0-9a-f]{32}/cmi aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa/' cache/compiler/archive-info.sexp 20 | $ $TEST_DIR/plugin_loader.exe --persistent-archive test1.ml 21 | persistent 22 | $ compiler_stat3=$(ocamlopt_stat) 23 | $ [ "$compiler_stat2" != "$compiler_stat3" ] 24 | 25 | Check that if the extracted archived is corrupted (missing ppx.exe here), we recover: 26 | 27 | $ rm cache/compiler/*.exe 28 | $ $TEST_DIR/plugin_loader.exe --persistent-archive test1.ml 29 | persistent 30 | -------------------------------------------------------------------------------- /test/test-positions.t: -------------------------------------------------------------------------------- 1 | $ setup 2 | 3 | Checking positions are good in error messages: 4 | 5 | $ echo 'let () = 1' > a.ml 6 | $ $TEST_DIR/plugin_loader.exe ./a.ml 7 | working_dir: $TESTTMP/* (glob) 8 | status: (Exit_non_zero 2) 9 | command: * (glob) 10 | File "$TESTTMP/a.ml", line 1, characters 9-10: 11 | Error: This expression has type int but an expression was expected of type 12 | unit 13 | 14 | [1] 15 | -------------------------------------------------------------------------------- /test/test-run-plugin-toplevel.t: -------------------------------------------------------------------------------- 1 | $ setup 2 | 3 | $ cat > test.ml < let () = Core.Printf.printf "%b\n%!" 5 | > (Async.Thread_safe.am_holding_async_lock ()) 6 | > EOF 7 | $ $TEST_DIR/plugin_loader.exe test.ml 8 | true 9 | -------------------------------------------------------------------------------- /test/test-trickier.t: -------------------------------------------------------------------------------- 1 | $ setup 2 | 3 | Loading file with a wrong name 4 | 5 | $ rm -f *.ml* 6 | $ touch invalid-name.ml 7 | $ $TEST_DIR/plugin_loader.exe invalid-name.ml |& matches 'not a valid ocaml' 8 | [1] 9 | 10 | Loading mls that collide 11 | 12 | $ rm -f *.ml* 13 | $ touch Test.ml test.ml 14 | $ $TEST_DIR/plugin_loader.exe test.ml Test.ml |& matches 'Several implementations' 15 | [1] 16 | 17 | Loadings mlis that collide 18 | 19 | $ rm -f *.ml* 20 | $ touch Test.mli test.mli 21 | $ $TEST_DIR/plugin_loader.exe test.mli Test.mli |& matches 'Several interfaces' 22 | [1] 23 | 24 | Loading ml and mli with different basenames but same module name 25 | 26 | $ rm -f *.ml* 27 | $ echo 'let x = 2' > test.ml 28 | $ echo 'val x : string' > Test.mli 29 | $ $TEST_DIR/plugin_loader.exe test.ml Test.mli |& matches 'Signature mismatch' 30 | [1] 31 | 32 | Loading ml and mli from different dirs 33 | 34 | $ rm -f *.ml* 35 | $ mkdir -p tmp_dir 36 | $ echo 'let x = 2' > test.ml 37 | $ echo 'let () = print_endline "different dirs ok"' >> test.ml 38 | $ echo 'val x : int' > test.mli 39 | $ echo 'val x : string' > tmp_dir/Test.mli 40 | $ $TEST_DIR/plugin_loader.exe test.ml tmp_dir/Test.mli |& matches 'Signature mismatch' 41 | [1] 42 | $ echo 'val x : int' > tmp_dir/Test.mli 43 | $ $TEST_DIR/plugin_loader.exe test.ml tmp_dir/Test.mli 44 | different dirs ok 45 | -------------------------------------------------------------------------------- /test/test-warnings.t: -------------------------------------------------------------------------------- 1 | $ setup 2 | 3 | $ rm -f *.ml* 4 | $ echo 'let x = "Test1.x"' > test1.ml 5 | $ echo 'let y = "Test1.y"' >> test1.ml 6 | $ echo 'let x = Test1.x ' > test2.ml 7 | $ echo 'let y = Test1.y' >> test2.ml 8 | $ echo 'let () = print_endline (x^y)' >> test2.ml 9 | $ $TEST_DIR/plugin_loader.exe test1.ml test2.ml 10 | Test1.xTest1.y 11 | 12 | $ rm -f *.ml* 13 | $ echo 'let x = "Test1.x"' > test1.ml 14 | $ echo 'let y = "Test1.y"' >> test1.ml 15 | $ echo 'let x = Test1.x ' > test2.ml 16 | $ echo 'let () = print_endline x' >> test2.ml 17 | $ $TEST_DIR/plugin_loader.exe test1.ml test2.ml |& matches 'warning 32 \[unused-value-declaration\]): unused value y' 18 | [1] 19 | 20 | $ rm -f *.ml* 21 | $ echo 'let x = "Test1.x"' > test1.ml 22 | $ echo 'let y = "Test1.y"' >> test1.ml 23 | $ echo 'val x : string' > test1.mli 24 | $ echo 'val y : string' >> test1.mli 25 | $ echo 'let x = Test1.x ' > test2.ml 26 | $ echo 'let () = print_endline x' >> test2.ml 27 | $ $TEST_DIR/plugin_loader.exe test1.ml test2.ml 28 | Test1.x 29 | $ $TEST_DIR/plugin_loader.exe --warnings-in-utils test1.ml test2.ml |& matches 'warning 32 \[unused-value-declaration\]): unused value y' 30 | [1] 31 | 32 | $ rm -f *.ml* 33 | $ echo 'let x = "x"' > test1.ml 34 | $ echo 'let y = "y"' >> test1.ml 35 | $ echo 'let () = print_endline y' >> test1.ml 36 | $ $TEST_DIR/plugin_loader.exe test1.ml |& matches 'warning 32 \[unused-value-declaration\]): unused value x' 37 | [1] 38 | 39 | $ rm -f *.ml* 40 | $ echo 'let x = "x"' > test1.ml 41 | $ echo 'let y = "y"' >> test1.ml 42 | $ echo 'let () = print_endline y' >> test1.ml 43 | $ echo 'val x : string' > test1.mli 44 | $ echo 'val y : string' >> test1.mli 45 | $ $TEST_DIR/plugin_loader.exe test1.ml 46 | y 47 | $ $TEST_DIR/plugin_loader.exe --warnings-in-utils test1.ml |& matches 'warning 32 \[unused-value-declaration\]): unused value y' 48 | [1] 49 | 50 | -------------------------------------------------------------------------------- /test/test_lib/dune: -------------------------------------------------------------------------------- 1 | (library (name ocaml_plugin_user_with_unit_tests) (libraries core) 2 | (preprocess (pps ppx_jane))) -------------------------------------------------------------------------------- /test/test_lib/sync_default_warnings.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | (* 4 | {[ 5 | let%expect_test "monitor jenga and ocaml-plugin default warnings" = 6 | let print_list name set = 7 | print_endline "--"; 8 | print_endline name; 9 | Set.iter set ~f:(fun t -> print_endline (Int.to_string t)) 10 | in 11 | let jenga = Jenga_rules.Compiler_config.disabled_warnings |> Int.Set.of_list in 12 | let ocaml_plugin = Ocaml_plugin.Dynloader.disabled_warnings |> Int.Set.of_list in 13 | print_list "jenga" jenga; 14 | print_list "ocaml-plugin" ocaml_plugin; 15 | print_list "disabled-only-in-jenga" (Set.diff jenga ocaml_plugin); 16 | print_list "disabled-only-in-ocaml-plugin" (Set.diff ocaml_plugin jenga); 17 | [%expect {| |}] 18 | ;; 19 | ]} 20 | *) 21 | -------------------------------------------------------------------------------- /test/test_lib/sync_default_warnings.mli: -------------------------------------------------------------------------------- 1 | (*_ Deliberately empty. *) 2 | -------------------------------------------------------------------------------- /test/test_lib/test.ml: -------------------------------------------------------------------------------- 1 | let%test _ = true 2 | (* just testing that the linking works *) 3 | -------------------------------------------------------------------------------- /test/test_with_sexp.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | type t = 4 | { foo : int 5 | ; bar : string 6 | } 7 | [@@deriving sexp] 8 | 9 | let sexped = sexp_of_t { foo = 1; bar = "toto" } 10 | let first = t_of_sexp sexped 11 | -------------------------------------------------------------------------------- /test/test_with_sexp.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | type t [@@deriving sexp] 4 | 5 | val sexped : Sexp.t 6 | val first : t 7 | -------------------------------------------------------------------------------- /test/test_with_sexp_dep.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | type t = 4 | { foo : float option 5 | ; bar : Test_with_sexp.t 6 | } 7 | [@@deriving sexp] 8 | 9 | let sexped = sexp_of_t { foo = Some 3.; bar = Test_with_sexp.first } 10 | let first = t_of_sexp sexped 11 | -------------------------------------------------------------------------------- /test/test_with_sexp_dep.mli: -------------------------------------------------------------------------------- 1 | open! Core 2 | 3 | type t [@@deriving sexp] 4 | 5 | val sexped : Sexp.t 6 | val first : t 7 | --------------------------------------------------------------------------------