├── .gitignore ├── .header ├── .ocamlinit ├── .ocp-indent ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── doc └── maki_design.md ├── dune-project ├── maki.opam ├── src ├── core │ ├── dune │ ├── maki.ml │ ├── maki.mli │ ├── maki_bencode.ml │ ├── maki_log.ml │ ├── maki_lwt_err.ml │ ├── maki_storage.ml │ ├── maki_utils.ml │ └── maki_utils.mli ├── demo_build │ ├── dune │ └── maki_build.ml ├── dune ├── json │ ├── dune │ ├── maki_yojson.ml │ └── maki_yojson.mli └── tools │ ├── dune │ ├── maki_display.ml │ └── maki_gc.ml └── tests ├── dune └── test_fib.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | 3 | .merlin 4 | *.install 5 | -------------------------------------------------------------------------------- /.header: -------------------------------------------------------------------------------- 1 | (* This file is free software. See file "license" for more details. *) 2 | -------------------------------------------------------------------------------- /.ocamlinit: -------------------------------------------------------------------------------- 1 | #use "topfind";; 2 | #require "lwt.unix";; 3 | #require "lwt.preemptive";; 4 | #require "lwt.ppx";; 5 | #require "sha";; 6 | #require "bencode";; 7 | #require "result";; 8 | 9 | #directory "_build/src/core";; 10 | #load "maki.cma";; 11 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | with=0 2 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh 3 | script: bash -ex .travis-docker.sh 4 | services: 5 | - docker 6 | env: 7 | global: 8 | - PINS="maki:." 9 | - DISTRO="ubuntu-16.04" 10 | matrix: 11 | - PACKAGE="maki" OCAML_VERSION="4.03" EXTRA_DEPS="yojson" 12 | - PACKAGE="maki" OCAML_VERSION="4.04" EXTRA_DEPS="yojson" 13 | #- PACKAGE="maki" OCAML_VERSION="4.05" EXTRA_DEPS="yojson" 14 | - PACKAGE="maki" OCAML_VERSION="4.06" EXTRA_DEPS="yojson" 15 | - PACKAGE="maki" OCAML_VERSION="4.07" EXTRA_DEPS="yojson" 16 | - PACKAGE="maki" OCAML_VERSION="4.09" EXTRA_DEPS="yojson" 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Simon Cruanes 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 15 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 18 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 20 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 21 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 22 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 23 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | build: 3 | @dune build @install 4 | 5 | dev: test 6 | 7 | test: 8 | @dune runtest --no-buffer --force 9 | 10 | doc: 11 | @dune build @doc 12 | 13 | clean: 14 | @dune clean 15 | 16 | reindent: 17 | find -name '*.ml*' -exec ocp-indent -i {} \; 18 | 19 | .PHONY: all build test clean doc 20 | 21 | watch: 22 | @dune build -w 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # maki 2 | 3 | Persistent incremental computations, for repeatable tests and benchmarks. 4 | 5 | **Status**: beta 6 | 7 | [![build status](https://api.travis-ci.org/c-cube/maki.svg?branch=master)](https://travis-ci.org/c-cube/maki) 8 | 9 | For more details, see [the initial design document (obsolete)](doc/maki_design.md) 10 | and the [blog post](https://blag.cedeela.fr/maki/) 11 | 12 | ## Examples 13 | 14 | ### Simple memoizing of a recursive function 15 | 16 | ```ocaml 17 | let fib = 18 | let rec fib n = Maki.( 19 | mk1 ~name:"fib" Hash.int Codec.int ~lifetime:Lifetime.one_minute 20 | ~f:(fun x -> if x <= 1 21 | then return_ok 1 22 | else (fib (x-1) >>= fun x1 -> 23 | fib (x-2) >|= fun x2 -> x1+x2)) 24 | n 25 | ) in 26 | fib;; 27 | 28 | fib 42 ;; 29 | (* returns [Ok 42] *) 30 | ``` 31 | 32 | ### Concatenating file, but memoizing the result as long as they do not change 33 | 34 | ```ocaml 35 | 36 | open Lwt.Infix;; 37 | 38 | let concat = 39 | Maki.(mk2 ~name:"concat" Hash.file_ref Hash.file_ref Codec.string ~lifetime:Lifetime.one_hour 40 | ~f:(fun f1 f2 -> 41 | let open E in 42 | read_file f1 >>= fun content1 -> 43 | read_file f2 >>= fun content2 -> 44 | return_ok (content1 ^ content2))) 45 | ;; 46 | 47 | let x1 = Maki.(File_ref.make "foo1" >>= fun f1 -> File_ref.make "foo2" >>= concat f1);; 48 | 49 | (* cached *) 50 | let x2 = Maki.(File_ref.make "foo1" >>= fun f1 -> File_ref.make "foo2" >>= concat f1);; 51 | 52 | (* now change contnet of file "foo1", so this should change too *) 53 | let x3 = Maki.(File_ref.make "foo1" >>= fun f1 -> File_ref.make "foo2" >>= concat f1);; 54 | 55 | 56 | ``` 57 | 58 | ## Documentation 59 | 60 | See http://c-cube.github.io/maki/ 61 | -------------------------------------------------------------------------------- /doc/maki_design.md: -------------------------------------------------------------------------------- 1 | 2 | # Maki 3 | 4 | Persistent incremental computations for OCaml, to subsume `make`, run 5 | deterministic benchmarks, etc. 6 | 7 | The main idea is to make some **pure** OCaml functions memoized, by storing 8 | their result on disk for every tuple of inputs it is called on. The inputs 9 | are instances of a type the interpreter knows about, and in particular 10 | we have a notion of **pointer**, or **symbol** (a OCaml value that actually 11 | refers to something outside of the system, for instance a path to refer 12 | to a file's content, or an URL to refer to some remote content). This 13 | type would look like the `Maki.value_` type below. 14 | Such a memoized function can also **depend** on some other `value_`s that 15 | are fixed, but that Maki still needs to know about because they might have 16 | different versions (e.g. different versions of the same compiler, or tool, 17 | or different versions of a config file whose path is fixed). 18 | 19 | ```ocaml 20 | type value_ = 21 | | File of path (* equality is actually sha1(file) *) 22 | | Url of url (* equality is actually sha1(get url) *) 23 | | Program of program (* equality is actually sha1(which program) *) 24 | | Int of int 25 | | String of string (* raw content, typically after serialization *) 26 | | List of value_ list 27 | | Assoc of (string * value_) list 28 | ``` 29 | 30 | We should have a type `('a, 'ret) Maki.fun_`, that represents a memoized 31 | function of type `'a` (returning `'ret`). For instance a function to run 32 | "wc" on a file would have the type `(path -> int, int) Maki.fun_`, 33 | and it would also declare a dependency on `Program "wc"`. 34 | 35 | Maki's primary goal is to compute the result of functions applied to 36 | arguments, **or** retrieve the result if it was already computed (with the 37 | exact same set of inputs+dependencies). 38 | 39 | ## Storage 40 | 41 | Instances of `value_` can be stored on disk (in JSON: use `ppx_deriving_yojson` 42 | as much as possible). Memoized functions need to have unique names, because it 43 | allows Maki to describe values on disk by their AST. 44 | 45 | ## Computation 46 | 47 | To compute `f x_1...x_n`, where `f : (a_1 -> ... -> a_n -> ret, ret)` 48 | and `x_i : a_i` (corresponding to `value_` or special cases of 49 | values, such as `path`), assuming that the `x_i` are already computed (possibly 50 | by previous invocations of Maki), the steps are: 51 | 52 | 1. make a string representation `computation := f x_1 ... x_n` 53 | of the computation to do 54 | 2. hash this representation into `h := sha1(computation)` 55 | 3. make a string representation 56 | `computation_instance := h sha1(x_1) ... sha1(x_n)` of the 57 | particular instance to compute (note that this is not the same as 58 | `computation` because, if `x_1 = File "/foo/bar"`, `h` will depend 59 | on the _name_ "/foo/bar", but `computation_instance` will depend 60 | on `sha1(/foo/bar)`, the hash of the current string content. 61 | 4. hash this particular instance `h_instance := sha1(computation_instance)` 62 | 5. if a file `h_instance` exists on disk, it must contain the result 63 | of the computation, so we unserialized the result and return it 64 | 6. otherwise, we do the computation, obtaining value `res : ret`; 65 | we store it into a file `h_instance` and then return it, so 66 | the next computation will stop at step 5. 67 | 68 | Maki should provide a function `Maki.call : ('a, _) fun_ -> 'a Lwt.t` 69 | that takes parameters of a given function and runs through the previous 70 | steps. Several calls to `Maki.call` may be computed in parallel, hence 71 | the use of `Lwt`. 72 | 73 | Of course Maki should provide many helpers to read/write files, run 74 | subprocess and obtain their results, etc. but `call` is the main 75 | entry point. 76 | 77 | ## Design challenges 78 | 79 | - garbage collection: need a set of root computations, compute transitive 80 | closure of inner computations, remove the rest? 81 | - export to a "regular" result: shoud be quite easy, just compute a function 82 | that outputs a CSV or JSON file somewhere, it barely adds complexity to 83 | the whole computation 84 | - distributed computation: `-j 5` is easy, running on remote nodes is not. 85 | But since we know the entire set of dependencies of every computation, at 86 | least we know what to copy on the remote machine. 87 | - dynamic dependencies: when processing a TPTP file, say, we might discover 88 | it `include` some other file. This dependency should be expressible 89 | in the OCaml library (see above, need to add a dependency on the 90 | included file in some cases). 91 | - central resource management for `-j 5` (costly functions should 92 | access a pseudo "semaphore" structure and run inside it, to limit 93 | parallelism). 94 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.1) 2 | -------------------------------------------------------------------------------- /maki.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "maki" 3 | version: "dev" 4 | synopsis: "Persistent incremental computations, for repeatable tests and benchmarks" 5 | author: "Simon Cruanes" 6 | maintainer: "simon.cruanes.2007@m4x.org" 7 | build: [ 8 | ["dune" "build" "@install" "-p" name "-j" jobs] 9 | ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} 10 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 11 | ] 12 | depends: [ 13 | "dune" {build} 14 | "lwt" { >= "3.2" } 15 | "base-unix" 16 | "bencode" 17 | "sha" 18 | "base-threads" 19 | "odoc" {with-doc} 20 | "ocaml" { >= "4.03" } 21 | ] 22 | depopts: [ 23 | "yojson" 24 | ] 25 | tags: [ "incremental" "persistent" "memoization" ] 26 | homepage: "https://github.com/c-cube/maki/" 27 | doc: "http://c-cube.github.io/maki/" 28 | dev-repo: "git+https://github.com/c-cube/maki.git" 29 | bug-reports: "https://github.com/c-cube/maki/issues/" 30 | -------------------------------------------------------------------------------- /src/core/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name maki) 4 | (public_name maki) 5 | (libraries lwt.unix sha bencode)) 6 | 7 | -------------------------------------------------------------------------------- /src/core/maki.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Maki: Persistent Incremental Computations} *) 5 | 6 | open Lwt.Infix 7 | 8 | module Util = Maki_utils 9 | module Log = Maki_log 10 | 11 | module Sha = Sha1 12 | 13 | module B = Bencode 14 | module BM = Maki_bencode 15 | module Ca = Maki_utils.Cache 16 | module E = Maki_lwt_err 17 | 18 | let (>>>=) = E.(>>=) 19 | let (>>|=) = E.(>|=) 20 | 21 | type 'a or_error = ('a, string) result 22 | type 'a lwt_or_error = 'a or_error Lwt.t 23 | type 'a printer = Format.formatter -> 'a -> unit 24 | 25 | let error = Maki_utils.error 26 | let errorf msg = Maki_utils.errorf msg 27 | 28 | module Res_ = struct 29 | let return x = Ok x 30 | let fail e = Error e 31 | let (<*>) f x = match f, x with 32 | | Ok f, Ok x -> Ok (f x) 33 | | Error e, _ 34 | | _, Error e -> Error e 35 | let (>|=) r f = match r with 36 | | Ok x -> Ok (f x) 37 | | Error e -> Error e 38 | let map f x = x >|= f 39 | let (>>=) r f = match r with 40 | | Ok x -> f x 41 | | Error e -> Error e 42 | 43 | exception Exit_map of string 44 | 45 | let map_l f l = 46 | try 47 | let res = 48 | List.map 49 | (fun x -> match f x with Ok y -> y | Error e -> raise (Exit_map e)) 50 | l 51 | in 52 | Ok res 53 | with Exit_map msg -> Error msg 54 | end 55 | 56 | (** {2 Controlling Parallelism} *) 57 | 58 | module Limit = struct 59 | type t = unit Lwt_pool.t 60 | 61 | let create size = Lwt_pool.create size (fun () -> Lwt.return_unit) 62 | 63 | let acquire = Lwt_pool.use 64 | 65 | let j_init = ref 1 66 | 67 | (* pool used to limit concurrent access to cores, memory, etc. *) 68 | let j_ = lazy (create !j_init) 69 | 70 | let j () = Lazy.force j_ 71 | 72 | let set_j n = 73 | if Lazy.is_val j_ then failwith "Limit.set_j: too late to set limit"; 74 | j_init := n 75 | 76 | let map_l lim f l : _ list Lwt.t = 77 | Lwt_list.map_p 78 | (fun x -> acquire lim (fun () -> f x)) 79 | l 80 | end 81 | 82 | (** {2 Basic types} *) 83 | 84 | type path = string 85 | type program = string 86 | type time = float 87 | type hash = string 88 | type encoded_value = string 89 | 90 | (** {2 Utils} *) 91 | 92 | (* last time file [f] was modified *) 93 | let last_time_ f = 94 | let s = Unix.stat f in 95 | s.Unix.st_mtime 96 | 97 | (* number of threads to use in parallel for computing Sha *) 98 | let sha1_pool_ = Limit.create 20 99 | 100 | (* fast sha1 on a file *) 101 | let sha1_exn f = 102 | Limit.acquire sha1_pool_ 103 | (fun () -> 104 | Maki_log.logf 5 (fun k->k "compute sha1 of `%s`" f); 105 | Lwt_preemptive.detach (fun () -> Sha.file_fast f |> Sha.to_hex) ()) 106 | 107 | let sha1 f = 108 | Lwt.catch 109 | (fun () -> sha1_exn f >|= Res_.return) 110 | (fun e -> 111 | errorf "error when computing sha1 of `%s`: %s" 112 | f (Printexc.to_string e) 113 | |> Lwt.return) 114 | 115 | let abspath f = 116 | if Filename.is_relative f 117 | then Filename.concat (Sys.getcwd()) f 118 | else f 119 | 120 | let sha1_of_string s = Sha.string s |> Sha.to_hex 121 | 122 | let last_mtime f : time or_error = 123 | try Ok (last_time_ f) 124 | with e -> 125 | errorf "could not compute `last_mtime %s`: %s" f (Printexc.to_string e) 126 | 127 | let errcode_of_status_ = 128 | fun (Unix.WEXITED c | Unix.WSIGNALED c | Unix.WSTOPPED c) -> c 129 | 130 | let shell ?timeout ?(stdin="") cmd0 = 131 | let cmd = "sh", [|"sh"; "-c"; cmd0|] in 132 | Lwt.catch 133 | (fun () -> 134 | Lwt_process.with_process_full ?timeout cmd 135 | (fun p -> 136 | Lwt_io.write p#stdin stdin >>= fun () -> 137 | Lwt_io.flush p#stdin >>= fun () -> 138 | let stdout = Lwt_io.read p#stdout 139 | and stderr = Lwt_io.read p#stderr 140 | and errcode = p#status 141 | and close_in = Lwt_io.close p#stdin in 142 | stdout >>= fun o -> 143 | stderr >>= fun e -> 144 | errcode >|= errcode_of_status_ >>= fun c -> 145 | close_in >>= fun _ -> 146 | E.return (o, e, c))) 147 | (fun e -> 148 | errorf "error when calling `%s`: %s" cmd0 (Printexc.to_string e) 149 | |> Lwt.return) 150 | 151 | let shellf ?timeout ?stdin cmd = 152 | let buf = Buffer.create 64 in 153 | let fmt = Format.formatter_of_buffer buf in 154 | Format.kfprintf 155 | (fun _ -> 156 | Format.pp_print_flush fmt (); 157 | shell ?timeout ?stdin (Buffer.contents buf)) 158 | fmt cmd 159 | 160 | (** {2 Encoder/Decoder} *) 161 | 162 | module Codec = struct 163 | type hash = string 164 | type encoded_value = string 165 | 166 | type 'a t = { 167 | descr: string; 168 | encode: 'a -> encoded_value * hash list; 169 | (** [encode x] should return a string encoding of [x], to be stored 170 | for the computation of some function, as well as a list of 171 | hash of sub-values used by [x] (for garbage collection purposes) *) 172 | decode: encoded_value -> 'a or_error; 173 | (** Decode the main value from its serialized representation *) 174 | } 175 | 176 | let make ~encode ~decode descr = 177 | { descr; encode; decode; } 178 | 179 | let encode v x = v.encode x 180 | let decode v s = v.decode s 181 | 182 | let make_leaf ~encode ~decode descr = 183 | make ~encode:(fun x -> encode x, []) ~decode descr 184 | 185 | let make_bencode ~encode ~decode descr = 186 | make descr 187 | ~encode:(fun x -> 188 | let b, children = encode x in 189 | Bencode.encode_to_string b, children) 190 | ~decode:(fun s -> 191 | Res_.(BM.decode_bencode s >>= decode)) 192 | 193 | let make_leaf_bencode ~encode ~decode descr = 194 | make_bencode ~encode:(fun x -> encode x, []) ~decode descr 195 | 196 | let int = 197 | make_leaf "int" 198 | ~encode:string_of_int 199 | ~decode:(fun s -> 200 | begin 201 | try Ok (int_of_string s) 202 | with _ -> errorf "expected int, got `%s`" s 203 | end) 204 | 205 | let string = 206 | make_leaf "string" ~encode:(fun s->s) ~decode:(fun s->Ok s) 207 | 208 | let bool = 209 | make_leaf "bool" 210 | ~encode:string_of_bool 211 | ~decode:(fun s -> 212 | begin try Ok (bool_of_string s) 213 | with _ -> errorf "expected bool, got `%s`" s 214 | end) 215 | 216 | (* TODO: use the hexadecimal output of Printf when available ? *) 217 | let float = 218 | make_leaf "float" 219 | ~encode:(fun f -> Int64.((to_string @@ bits_of_float f))) 220 | ~decode:(fun s -> 221 | begin try Ok Int64.(float_of_bits @@ of_string s) 222 | with Failure _ -> errorf "expected float, got `%s`" s 223 | end) 224 | 225 | let marshal name = 226 | let flags = [Marshal.Closures; Marshal.No_sharing; Marshal.Compat_32] in 227 | make_leaf name 228 | ~encode:(fun x -> Marshal.to_string (name,x) flags) 229 | ~decode:(fun s -> 230 | let name', x = Marshal.from_string s 0 in 231 | if name=name' then x 232 | else failwith (Format.asprintf "codec.marshal: mismatch (value is %S, expected %S)" name' name) 233 | ) 234 | 235 | let or_error (c:'a t): 'a or_error t = 236 | let name = c.descr ^ " or_error" in 237 | make name 238 | ~encode:(function 239 | | Ok x -> let s, deps = encode c x in "1" ^ s, deps 240 | | Error y -> "0" ^ y, []) 241 | ~decode:(fun s -> 242 | let open Res_ in 243 | if s<>"" && s.[0] = '0' 244 | then decode c (String.sub s 1 (String.length s-1)) >|= Res_.return 245 | else if s<>"" && s.[0] = '1' 246 | then String.sub s 1 (String.length s-1) |> Res_.fail 247 | else errorf "expected %s, got `%s`" name s) 248 | end 249 | 250 | (** {2 References to Files} *) 251 | 252 | module File_ref : sig 253 | type t 254 | 255 | val path : t -> path 256 | val hash : t -> hash 257 | val to_string : t -> string 258 | 259 | val make : path -> t or_error Lwt.t 260 | val make_exn : path -> t Lwt.t 261 | val is_valid : t -> bool Lwt.t 262 | 263 | val of_bencode : Bencode.t -> t or_error 264 | val to_bencode : t -> Bencode.t 265 | val codec : t Codec.t 266 | end = struct 267 | type t = { 268 | f_path: path; 269 | f_hash: hash; 270 | } 271 | 272 | let path f = f.f_path 273 | let hash f = f.f_hash 274 | 275 | let to_string f: string = 276 | Printf.sprintf "{path=`%s`, hash=%s}" (path f) (hash f) 277 | 278 | let of_bencode = function 279 | | B.Dict l -> 280 | let open Res_ in 281 | BM.assoc "path" l >>= BM.as_str >>= fun f_path -> 282 | BM.assoc "hash" l >>= BM.as_str >>= fun f_hash -> 283 | Ok {f_path; f_hash;} 284 | | b -> BM.expected_b "file_state" b 285 | 286 | let to_bencode fs = 287 | B.Dict 288 | [ "path", B.String fs.f_path; 289 | "hash", B.String fs.f_hash; 290 | ] 291 | 292 | 293 | let codec = 294 | Codec.make_leaf_bencode ~encode:to_bencode ~decode:of_bencode "file_stat" 295 | 296 | (* cache for files: maps file name to hash + last modif *) 297 | type file_cache = (path, time * t or_error Lwt.t) Ca.t 298 | 299 | let file_cache_ : file_cache = Ca.replacing 512 300 | 301 | let make f : t or_error Lwt.t = 302 | if not (Sys.file_exists f) then ( 303 | errorf "file `%s` not found" f |> Lwt.return 304 | ) else ( 305 | let last = last_time_ f in 306 | match Ca.get file_cache_ f with 307 | | Some (time,fs) when time >= last -> fs (* cache hit *) 308 | | _ -> 309 | let fut = 310 | sha1 f >>|= fun f_hash -> 311 | { f_path=f; f_hash;} 312 | in 313 | Ca.set file_cache_ f (last,fut); 314 | fut 315 | ) 316 | 317 | let make_exn f : _ Lwt.t = 318 | make f >>= function 319 | | Ok x -> Lwt.return x 320 | | Error e -> Lwt.fail (Invalid_argument e) 321 | 322 | (* check if [f] is a [file_state] that doesn't correspond to the actual 323 | content of the disk *) 324 | let is_valid (f:t): bool Lwt.t = 325 | Maki_log.logf 5 (fun k->k "check if file %s is up-to-date..." (to_string f)); 326 | (* compare [fs] with actual current file state *) 327 | make (path f) >>= fun res -> 328 | begin match res with 329 | | Error _ -> Lwt.return_true (* file not present, etc. *) 330 | | Ok f' -> 331 | let res = 332 | path f = path f' && 333 | hash f = hash f' 334 | in 335 | Maki_log.logf 5 (fun k->k "file %s up-to-date? %B" (to_string f) res); 336 | Lwt.return res 337 | end 338 | end 339 | 340 | module Program_ref : sig 341 | type t 342 | val find : path -> path or_error Lwt.t 343 | val make : path -> t or_error Lwt.t 344 | val as_file : t -> File_ref.t 345 | val codec : t Codec.t 346 | val to_string : t -> string 347 | end = struct 348 | type t = File_ref.t 349 | 350 | let as_file (p:t): File_ref.t = p 351 | let codec = File_ref.codec 352 | 353 | (* program name -> path *) 354 | let path_tbl_ : (string, string or_error Lwt.t) Ca.t = Ca.replacing 64 355 | 356 | let path_pool_ = Lwt_pool.create 100 (fun _ -> Lwt.return_unit) 357 | 358 | (* turn [f], a potentially relative path to a program, into an absolute path *) 359 | let find (f:path) : path or_error Lwt.t = 360 | if Filename.is_relative f && Filename.is_implicit f 361 | then match Ca.get path_tbl_ f with 362 | | Some r -> r 363 | | None -> 364 | let fut = 365 | Lwt_pool.use path_pool_ 366 | (fun _ -> 367 | Maki_log.logf 5 (fun k->k "invoke `which` on `%s`" f); 368 | let p = Lwt_process.open_process_in ("", [|"which"; f|]) in 369 | Lwt_io.read p#stdout >>= fun out -> 370 | p#status >|= errcode_of_status_ >|= fun errcode -> 371 | if errcode=0 372 | then Ok (String.trim out) 373 | else errorf "program `%s` not found in path" f) 374 | in 375 | (* cache *) 376 | Ca.set path_tbl_ f fut; 377 | fut 378 | else Lwt.return (Ok f) 379 | 380 | let make (f:path) = find f >>>= File_ref.make 381 | 382 | let to_string = File_ref.to_string 383 | end 384 | 385 | (** {2 Time Utils} *) 386 | 387 | module Time = struct 388 | type t = time 389 | let seconds = float_of_int 390 | let hours n = float_of_int n *. 3600. 391 | let minutes n = float_of_int n *. 60. 392 | let days n = float_of_int n *. hours 24 393 | let weeks n = 7. *. days n 394 | let now () = Unix.gettimeofday() 395 | let (++) = (+.) 396 | let pp out t = Format.fprintf out "%.3fs" t 397 | end 398 | 399 | module Lifetime = struct 400 | type t = 401 | | Keep 402 | | KeepFor of time (** Time delta *) 403 | | KeepUntil of time (** Absolute deadline *) 404 | | CanDrop 405 | 406 | let keep = Keep 407 | let can_drop = CanDrop 408 | let keep_for t = KeepFor t 409 | let keep_until t = KeepUntil t 410 | 411 | let short = keep_for (Time.minutes 10) 412 | let one_minute = keep_for (Time.minutes 1) 413 | let one_hour = keep_for (Time.hours 1) 414 | let one_day = keep_for (Time.days 1) 415 | 416 | let pp out = function 417 | | Keep -> Format.pp_print_string out "keep" 418 | | CanDrop -> Format.pp_print_string out "can_drop" 419 | | KeepFor t -> Format.fprintf out "keep_for %a" Time.pp t 420 | | KeepUntil t -> Format.fprintf out "keep_until %a" Time.pp t 421 | 422 | let default : t = keep_for @@ Time.weeks 10 423 | end 424 | 425 | module GC_info : sig 426 | type t = 427 | | Keep 428 | | KeepUntil of time 429 | | CanDrop 430 | val lt : t -> t -> bool 431 | val to_bencode : t -> Bencode.t 432 | val of_bencode : Bencode.t -> t or_error 433 | val codec : t Codec.t 434 | val of_lifetime : Lifetime.t -> t 435 | end = struct 436 | type t = 437 | | Keep 438 | | KeepUntil of time 439 | | CanDrop 440 | 441 | (* a < b? *) 442 | let lt a b = match a, b with 443 | | Keep, Keep 444 | | _, CanDrop -> false 445 | | _, Keep 446 | | CanDrop, _ -> true 447 | | Keep, _ -> false 448 | | KeepUntil a, KeepUntil b -> a < b 449 | 450 | let to_bencode = function 451 | | Keep -> B.String "keep" 452 | | KeepUntil t -> B.List [B.String "keep_until"; B.String (string_of_float t)] 453 | | CanDrop -> B.String "drop" 454 | 455 | let of_bencode = function 456 | | B.String "keep" -> Ok Keep 457 | | B.List [B.String "keep_until"; B.String t] -> 458 | begin try Ok (KeepUntil (float_of_string t)) 459 | with _ -> Error "expected float" 460 | end 461 | | B.String "drop" -> Ok CanDrop 462 | | b -> errorf "expected lifetime, got `%s`" (Bencode.encode_to_string b) 463 | 464 | let codec = Codec.make_leaf_bencode ~encode:to_bencode ~decode:of_bencode "gc_info" 465 | 466 | let of_lifetime = function 467 | | Lifetime.CanDrop -> CanDrop 468 | | Lifetime.Keep -> Keep 469 | | Lifetime.KeepUntil t -> KeepUntil t 470 | | Lifetime.KeepFor t -> 471 | let now = Unix.gettimeofday () in 472 | KeepUntil (now +. t) 473 | end 474 | 475 | (** {2 On-Disk storage} *) 476 | 477 | module Storage = Maki_storage 478 | 479 | (** {2 Value Stored on Disk} *) 480 | 481 | module On_disk_record : sig 482 | type t = { 483 | gc_info: GC_info.t; (* how long should the GC keep this value *) 484 | key: hash; (* hash of the computation *) 485 | children: hash list; (* hash of children *) 486 | data: encoded_value; (* the actual data *) 487 | } 488 | 489 | val make : 490 | ?lifetime:Lifetime.t -> 491 | ?children:hash list -> 492 | hash -> 493 | encoded_value -> 494 | t 495 | 496 | val gc_info : t -> GC_info.t 497 | val key : t -> hash 498 | val children : t -> hash list 499 | val data : t -> encoded_value 500 | val lifetime : t -> Lifetime.t 501 | 502 | val codec : t Codec.t 503 | end = struct 504 | type t = { 505 | gc_info: GC_info.t; (* how long should the GC keep this value *) 506 | key: hash; (* hash of the computation *) 507 | children: hash list; (* hash of children *) 508 | data: encoded_value; (* the actual data *) 509 | } 510 | 511 | let key c = c.key 512 | let children c = c.children 513 | let data c = c.data 514 | let gc_info c = c.gc_info 515 | 516 | let make ?(lifetime=Lifetime.default) ?(children=[]) key data = 517 | let gc_info = GC_info.of_lifetime lifetime in 518 | { gc_info; children; key; data; } 519 | 520 | (* serialize [c] into Bencode *) 521 | let encode c = 522 | B.Dict 523 | [ "gc_info", GC_info.to_bencode c.gc_info; 524 | "data", BM.mk_str c.data; 525 | "children", BM.mk_list (List.map BM.mk_str c.children); 526 | "key", BM.mk_str c.key; 527 | ] 528 | 529 | (* [s] is a serialized cached value, turn it into a [cache_value] *) 530 | let decode (b:Bencode.t) : t or_error = 531 | let open Res_ in 532 | begin match b with 533 | | B.Dict l -> 534 | BM.assoc "gc_info" l >>= GC_info.of_bencode >>= fun gc_info -> 535 | BM.assoc "data" l >>= BM.as_str >>= fun data -> 536 | BM.assoc_or (B.List []) "children" l 537 | |> BM.as_list >>= map_l BM.as_str >>= fun children -> 538 | BM.assoc "key" l >>= BM.as_str >>= fun key -> 539 | return {data; gc_info; key; children; } 540 | | b -> 541 | errorf "expected on_disk_record, got `%s`" 542 | (Bencode.encode_to_string b) 543 | end 544 | 545 | let codec = Codec.make_leaf_bencode ~encode ~decode "on_disk_record" 546 | 547 | let lifetime c = match c.gc_info with 548 | | GC_info.Keep -> Lifetime.Keep 549 | | GC_info.KeepUntil t -> Lifetime.KeepUntil t 550 | | GC_info.CanDrop -> Lifetime.CanDrop 551 | end 552 | 553 | (** {2 Reference to On-Disk Value} *) 554 | 555 | module Ref = struct 556 | type 'a t = 'a Codec.t * hash 557 | 558 | let hash = snd 559 | let codec = fst 560 | 561 | let store 562 | ?(storage=Storage.get_default()) 563 | ?lifetime 564 | codec 565 | x = 566 | let data, children = Codec.encode codec x in 567 | let key = Sha.string data |> Sha.to_hex in 568 | let record = On_disk_record.make ?lifetime ~children key data in 569 | let record_s, _ = Codec.encode On_disk_record.codec record in 570 | Storage.set storage key record_s >>|= fun () -> 571 | codec, key 572 | 573 | let find ?(storage=Storage.get_default()) (codec,key) = 574 | Storage.get storage key >>>= fun s -> 575 | begin match s with 576 | | None -> errorf "could not find value `%s` on storage" key 577 | | Some s -> 578 | begin match Codec.decode On_disk_record.codec s with 579 | | Error _ as e -> e 580 | | Ok record -> 581 | assert (On_disk_record.key record = key); 582 | let data = On_disk_record.data record in 583 | Codec.decode codec data 584 | end 585 | end |> Lwt.return 586 | 587 | let get ?(storage=Storage.get_default()) (codec,k) = 588 | Storage.get storage k >>>= fun s -> 589 | begin match s with 590 | | None -> Ok None 591 | | Some s -> 592 | let open Res_ in 593 | Codec.decode codec s >|= fun x -> Some x 594 | end |> Lwt.return 595 | end 596 | 597 | module Hash = struct 598 | module Sha = Sha 599 | type 'a t = Sha.ctx -> 'a -> unit 600 | 601 | let hash (h:_ t) x = 602 | let buf = Sha.init() in 603 | h buf x; 604 | Sha.finalize buf 605 | 606 | let hash_to_string h x = hash h x |> Sha.to_hex 607 | 608 | let str_ ctx s = Sha.update_string ctx s 609 | 610 | let unit _ _ = () 611 | let int ctx x = str_ ctx (string_of_int x) 612 | let bool ctx x = str_ ctx (string_of_bool x) 613 | let float ctx x = str_ ctx (string_of_float x) 614 | let string ctx x = str_ ctx x 615 | 616 | let map f h ctx x = h ctx (f x) 617 | 618 | let list h ctx l = List.iter (h ctx) l 619 | let array h ctx a = list h ctx (Array.to_list a) 620 | 621 | let file_ref ctx (f:File_ref.t) = 622 | let h = File_ref.hash f in 623 | str_ ctx (File_ref.path f); 624 | str_ ctx h 625 | 626 | let program_ref ctx (p:Program_ref.t) = 627 | let h = Program_ref.as_file p in 628 | file_ref ctx h 629 | 630 | let pair h1 h2 ctx (x1,x2) = 631 | h1 ctx x1; 632 | h2 ctx x2 633 | 634 | let triple h1 h2 h3 ctx (x1,x2,x3) = 635 | h1 ctx x1; 636 | h2 ctx x2; 637 | h3 ctx x3 638 | 639 | let quad h1 h2 h3 h4 ctx (x1,x2,x3,x4) = 640 | h1 ctx x1; 641 | h2 ctx x2; 642 | h3 ctx x3; 643 | h4 ctx x4 644 | 645 | (* set: orderless. We compute all hashes, sort, then hash the resulting list *) 646 | let set h ctx l = 647 | begin 648 | List.map (fun x -> hash_to_string h x) l 649 | |> List.sort String.compare 650 | |> List.iter (str_ ctx) 651 | end 652 | 653 | let marshal: 'a t = fun ctx x -> 654 | str_ ctx (Marshal.to_string x [Marshal.Closures]) 655 | 656 | let of_codec (c:'a Codec.t): 'a t = 657 | fun ctx x -> 658 | let s, _ = Codec.encode c x in 659 | string ctx s 660 | end 661 | 662 | (** {2 Arguments} *) 663 | module Arg = struct 664 | 665 | type t = A : 'a Hash.t * 'a -> t 666 | 667 | let make h x = A(h,x) 668 | let of_codec c x = make (Hash.of_codec c) x 669 | 670 | module Infix = struct 671 | let (@::) h x = make h x 672 | end 673 | include Infix 674 | end 675 | 676 | (** {2 Memoized Functions} *) 677 | 678 | (** {2 Result of Memoized Computation} *) 679 | module Compute_res : sig 680 | type 'a t 681 | 682 | val computation_name : _ t -> hash 683 | val tags : _ t -> string list 684 | val result : 'a t -> 'a Ref.t 685 | val children : _ t -> hash list 686 | 687 | val make : ?tags:string list -> hash -> 'a Ref.t -> 'a t 688 | 689 | val save : ?storage:Storage.t -> ?lifetime:Lifetime.t -> 'a t -> unit or_error Lwt.t 690 | 691 | val get : ?storage:Storage.t -> ?lifetime:Lifetime.t -> hash -> 'a Codec.t -> 'a t option or_error Lwt.t 692 | 693 | val find : ?storage:Storage.t -> ?lifetime:Lifetime.t -> hash -> 'a Codec.t -> 'a t or_error Lwt.t 694 | 695 | val to_record : ?lifetime:Lifetime.t -> 'a t -> On_disk_record.t 696 | 697 | val codec : 'a Codec.t -> 'a t Codec.t 698 | end = struct 699 | type 'a t = { 700 | computation_name: hash; (** computed value (hash of) *) 701 | result: 'a Ref.t; (** reference to the result *) 702 | tags: string list; (** Some metadata *) 703 | } 704 | 705 | let tags c = c.tags 706 | let result c = c.result 707 | let computation_name c = c.computation_name 708 | let children c = [c.result |> Ref.hash] 709 | 710 | let make ?(tags=[]) name result = {tags; computation_name=name; result} 711 | 712 | (* serialize [c] into Bencode *) 713 | let encode c = 714 | let b = B.Dict 715 | [ "name", BM.mk_str (computation_name c); 716 | "ref", BM.mk_str (result c |> Ref.hash); 717 | "tags", BM.mk_list (List.map BM.mk_str (tags c)); 718 | ] in 719 | b, children c 720 | 721 | (* [s] is a serialized result, turn it into a result *) 722 | let decode (codec:'a Codec.t) (b:Bencode.t) : 'a t or_error = 723 | let open Res_ in 724 | begin match b with 725 | | B.Dict l -> 726 | BM.assoc "ref" l >>= BM.as_str >>= fun hash -> 727 | let result : _ Ref.t = codec, hash in 728 | BM.assoc "name" l >>= BM.as_str >>= fun name -> 729 | BM.assoc_or (B.List []) "tags" l 730 | |> BM.as_list >>= map_l BM.as_str >|= fun tags -> 731 | make ~tags name result 732 | | _ -> 733 | errorf "expected cache_value, got `%s`" (Bencode.encode_to_string b) 734 | end 735 | 736 | let codec (c:'a Codec.t): 'a t Codec.t = 737 | Codec.make_bencode 738 | ~encode 739 | ~decode:(decode c) 740 | "compute_res" 741 | 742 | let save_record_ ~storage key record = 743 | Maki_log.logf 3 744 | (fun k->k "save result `%s` into storage %s" key (Storage.name storage)); 745 | let record_s, _ = Codec.encode On_disk_record.codec record in 746 | Storage.set storage key record_s 747 | 748 | let to_record ?lifetime (c:_ t): On_disk_record.t = 749 | let key = computation_name c in 750 | let c_bencode, children = encode c in 751 | let c_string = Bencode.encode_to_string c_bencode in 752 | On_disk_record.make ?lifetime ~children key c_string 753 | 754 | (* specific storage, indexed by [computation_name] rather than by the 755 | record's sha1 itself *) 756 | let save ?(storage=Storage.get_default()) ?lifetime (c:_ t) = 757 | let key = computation_name c in 758 | let record = to_record ?lifetime c in 759 | save_record_ ~storage key record 760 | 761 | let get ?(storage=Storage.get_default ()) ?(lifetime=Lifetime.CanDrop) key c = 762 | Storage.get storage key >>>= 763 | function 764 | | None -> E.return None 765 | | Some s -> 766 | let new_gc_info = GC_info.of_lifetime lifetime in 767 | Codec.decode On_disk_record.codec s |> Lwt.return >>>= fun record -> 768 | (* check if we should refresh the on-disk's value expiration date *) 769 | begin 770 | if GC_info.lt (On_disk_record.gc_info record) new_gc_info then ( 771 | let record = {record with On_disk_record.gc_info=new_gc_info} in 772 | save_record_ ~storage key record 773 | ) else E.return_unit 774 | end >>>= fun () -> 775 | let s = On_disk_record.data record in 776 | Codec.decode (codec c) s |> Res_.map (fun x-> Some x) |> Lwt.return 777 | 778 | let find ?storage ?lifetime k c = 779 | get ?storage ?lifetime k c 780 | >|= function 781 | | Ok (Some x) -> Ok x 782 | | Ok None -> errorf "could not find key `%s`" k 783 | | Error _ as e -> e 784 | end 785 | 786 | (* compute the hash of the result of computing the application of 787 | the function named [fun_name] on dependencies [l] *) 788 | let compute_name (fun_name:string) (args:Arg.t list): hash = 789 | let ctx = Sha.init() in 790 | Sha.update_string ctx fun_name; 791 | List.iter (fun (Arg.A(h,x)) -> h ctx x) args; 792 | Sha.finalize ctx |> Sha.to_hex 793 | 794 | (* map computation_name -> future (serialized) result *) 795 | type memo_table = (string, encoded_value lazy_t or_error Lwt.t) Hashtbl.t 796 | 797 | let memo_table_ : memo_table = Hashtbl.create 64 798 | 799 | (* 800 | - compute a string [s] out of computation and dependencies [to_string] 801 | - compute the content's hash (canonical form) of dependencies, 802 | OR use the cache if timestamp didn't change 803 | - compute the hash [h] of [s [hash(dep1), ..., [hash depn]]] 804 | - check if file named [h] exists 805 | * if it does, read its content, deserialize result with [op] and return it 806 | * otherwise, compute result, write it in [h], and return it 807 | *) 808 | let call_ 809 | ?(storage=Storage.get_default()) 810 | ?lifetime 811 | ?limit 812 | ?tags 813 | ~name:fun_name 814 | ~args 815 | ~(returning:'a Codec.t) 816 | (f:unit -> 'a or_error Lwt.t) : 'a or_error Lwt.t 817 | = 818 | (* compute the "name" of the computation *) 819 | let name = compute_name fun_name args in 820 | (* compute the result of calling the function, or retrieve the result in 821 | cache. This returns a [('a * string) or_error Lwt.t] where 822 | the string is the serialization of the ['a] *) 823 | let compute_memoized (): ('a * 'a Compute_res.t) or_error Lwt.t = 824 | begin match limit with 825 | | None -> f () 826 | | Some l -> Limit.acquire l f 827 | end 828 | >>>= fun res -> 829 | (* store result *) 830 | Ref.store ~storage ?lifetime returning res 831 | >>>= fun res_ref -> 832 | let compute_res = Compute_res.make ?tags name res_ref in 833 | Compute_res.save ~storage ?lifetime compute_res >>|= fun () -> 834 | res, compute_res 835 | in 836 | (* check on-disk cache *) 837 | let check_cache_or_compute () : ('a * 'a Compute_res.t) or_error Lwt.t = 838 | Compute_res.get ~storage ?lifetime name returning >>>= 839 | function 840 | | None -> 841 | (* not in cache, perform computation (possibly acquiring 842 | the "limit" first) *) 843 | Maki_log.logf 3 844 | (fun k->k "could not find `%s` in storage %s" name (Storage.name storage)); 845 | compute_memoized () 846 | | Some compute_res -> 847 | Maki_log.logf 3 848 | (fun k->k "found result of `%s` in storage %s" name (Storage.name storage)); 849 | (* read result from the raw data *) 850 | let data_ref = Compute_res.result compute_res in 851 | Ref.find ~storage data_ref >>= fun data -> 852 | begin match data with 853 | | Error e -> 854 | Maki_log.logf 3 855 | (fun k->k "cached file for `%s` is invalid, delete it and recompute: %s" 856 | name e); 857 | Storage.remove storage name >>= fun () -> 858 | compute_memoized () 859 | | Ok res -> E.return (res, compute_res) 860 | end 861 | in 862 | (* check memo table *) 863 | try 864 | let future_res = Hashtbl.find memo_table_ name in 865 | (* ok, some other thread is performing the computation, just wait 866 | for it to complete and deserialize the result *) 867 | future_res >>>= fun (lazy encoded_value) -> 868 | (Codec.decode (Compute_res.codec returning) encoded_value |> Lwt.return) 869 | >>|= Compute_res.result 870 | >>>= Ref.find ~storage 871 | with Not_found -> 872 | let res_record, wait_record = Lwt.wait () in 873 | (* put future result in memo table in case another thread wants to 874 | compute the same value *) 875 | Hashtbl.add memo_table_ name res_record; 876 | (* compute result *) 877 | let res = check_cache_or_compute() in 878 | (* ensure that when [res] terminates, [res_serialized] is updated, 879 | and cleanup entry from hashtable to avoid clogging memory *) 880 | Lwt.on_any res 881 | (function 882 | | Ok (_, compute_res) -> 883 | Hashtbl.remove memo_table_ name; 884 | let data = lazy ( 885 | Compute_res.to_record ?lifetime compute_res 886 | |> On_disk_record.data 887 | ) in 888 | Lwt.wakeup wait_record (Ok data) 889 | | Error e -> 890 | Hashtbl.remove memo_table_ name; 891 | Lwt.wakeup wait_record (Error e)) 892 | (fun e -> 893 | Lwt.wakeup wait_record 894 | (errorf "error when computing %s: %s" name (Printexc.to_string e))); 895 | res >>|= fst 896 | 897 | let call 898 | ?(bypass=false) ?storage ?lifetime ?limit ?tags ~name ~args ~returning f 899 | = 900 | if bypass then ( 901 | Lwt.catch 902 | (fun () -> 903 | begin match limit with 904 | | None -> f () 905 | | Some l -> Limit.acquire l f 906 | end) 907 | (fun e -> Lwt.return (error (Printexc.to_string e))) 908 | ) else ( 909 | call_ ?storage ?lifetime ?limit ?tags ~name ~args ~returning f 910 | ) 911 | 912 | let call_pure ?bypass ?storage ?lifetime ?limit ?tags ~name ~args ~returning f = 913 | call ?bypass ?storage ?lifetime ?limit ?tags ~name ~args ~returning 914 | (fun () -> f () >|= Res_.return) 915 | 916 | module Fun = struct 917 | type (_, _, _) t = 918 | | Fun : 'a Hash.t * ('f, 'f2, 'ret) t -> ('a -> 'f, 'f2, 'ret) t 919 | | Ret : string * 'a Codec.t -> 920 | ('a or_error Lwt.t, 921 | ((unit -> 'a or_error Lwt.t) -> string -> Arg.t list -> 'a Codec.t -> 'a or_error Lwt.t), 922 | 'a) t 923 | 924 | let returning ~name c = Ret (name,c) 925 | let (@->) h f = Fun (h,f) 926 | 927 | type 'f call_wrap = 928 | ?bypass:bool -> 929 | ?storage:Storage.t -> 930 | ?lifetime:Lifetime.t -> 931 | ?limit:Limit.t -> 932 | ?tags:string list -> 933 | 'f 934 | 935 | let call : type f1 f2 ret. ((f1, f2, ret) t -> f1 -> f1) call_wrap = 936 | fun ?bypass ?storage ?lifetime ?limit ?tags def f -> 937 | let rec pass_args 938 | : type g1 g2 ret. Arg.t list -> (g1, g2, ret) t -> (unit -> g1) -> g1 939 | = fun args def f -> match def with 940 | | Ret (name,codec) -> 941 | let args = List.rev args in 942 | call ?bypass ?storage ?lifetime ?limit ?tags ~name ~args ~returning:codec f 943 | | Fun (h, sub_def) -> 944 | (fun x -> 945 | let f () = f () x in 946 | let a = Arg.make h x in 947 | pass_args (a::args) sub_def f) 948 | in 949 | pass_args [] def (fun () -> f) 950 | end 951 | 952 | let return_ok x = E.return x 953 | let return_fail s = E.fail s 954 | 955 | let mk1 ?bypass ?storage ?lifetime ?limit ?tags ~name h1 ret ~f = 956 | let open Fun in 957 | call ?bypass ?storage ?lifetime ?limit ?tags (h1 @-> returning ~name ret) f 958 | 959 | let mk2 ?bypass ?storage ?lifetime ?limit ?tags ~name h1 h2 ret ~f = 960 | let open Fun in 961 | call ?bypass ?storage ?lifetime ?limit ?tags (h1 @-> h2 @-> returning ~name ret) f 962 | 963 | let mk3 ?bypass ?storage ?lifetime ?limit ?tags ~name h1 h2 h3 ret ~f = 964 | let open Fun in 965 | call ?bypass ?storage ?lifetime ?limit ?tags (h1 @-> h2 @-> h3 @-> returning ~name ret) f 966 | 967 | let mk4 ?bypass ?storage ?lifetime ?limit ?tags ~name h1 h2 h3 h4 ret ~f = 968 | let open Fun in 969 | call ?bypass ?storage ?lifetime ?limit ?tags (h1 @-> h2 @-> h3 @-> h4 @-> returning ~name ret) f 970 | 971 | let mk5 ?bypass ?storage ?lifetime ?limit ?tags ~name h1 h2 h3 h4 h5 ret ~f = 972 | let open Fun in 973 | call ?bypass ?storage ?lifetime ?limit ?tags (h1 @-> h2 @-> h3 @-> h4 @-> h5 @-> returning ~name ret) f 974 | 975 | (** {2 GC} *) 976 | 977 | module GC = struct 978 | type stats = { 979 | roots: int; 980 | kept: int; 981 | removed: int; 982 | } 983 | 984 | let string_of_stats s = 985 | Printf.sprintf "kept %d entries (%d roots), removed %d entries" 986 | s.kept s.roots s.removed 987 | 988 | type gc_cell = { 989 | gc_children: hash list; 990 | mutable gc_status: [`Root | `Alive | `Dead]; 991 | } 992 | 993 | type state = (string, gc_cell) Hashtbl.t 994 | 995 | (* find the set of roots, collect the graph in RAM *) 996 | let collect_roots now s : state or_error Lwt.t = 997 | Maki_log.log 3 "gc: collecting roots..."; 998 | let state = Hashtbl.create 256 in 999 | Storage.fold s ~x:() 1000 | ~f:(fun () (key, value) -> 1001 | (* decide whether to add [key] to [set], so it remains alive, or now *) 1002 | (Codec.decode On_disk_record.codec value |> Lwt.return) 1003 | >>|= fun record -> 1004 | (* remember dependencies of [key] *) 1005 | let gc_status = match On_disk_record.gc_info record with 1006 | | GC_info.Keep -> `Root 1007 | | GC_info.KeepUntil t -> if t >= now then `Root else `Dead 1008 | | GC_info.CanDrop -> `Dead 1009 | in 1010 | Hashtbl.add state key 1011 | {gc_children=On_disk_record.children record; gc_status}; 1012 | ()) 1013 | >>|= fun () -> 1014 | Maki_log.logf 3 1015 | (fun k->k "root collection is done (%d entries)" (Hashtbl.length state)); 1016 | state 1017 | 1018 | let cleanup ?(force=false) s: stats or_error Lwt.t = 1019 | let now = Unix.gettimeofday () in 1020 | collect_roots now s >>>= fun st -> 1021 | (* actually collect dead cells *) 1022 | let n_roots = ref 0 in 1023 | let n_kept = ref 0 in 1024 | let n_removed = ref 0 in 1025 | let err = ref None in 1026 | Maki_log.log 3 "start collection of dead values"; 1027 | Hashtbl.iter 1028 | (fun k c -> 1029 | match c.gc_status with 1030 | | (`Alive | `Root) when not force -> 1031 | Maki_log.logf 5 (fun f->f "gc: keep value %s" k); 1032 | if c.gc_status = `Root then incr n_roots; 1033 | incr n_kept 1034 | | _ -> 1035 | Maki_log.logf 5 (fun f->f "gc: remove value %s" k); 1036 | Lwt.async 1037 | (fun () -> 1038 | Lwt.catch 1039 | (fun () -> 1040 | incr n_removed; 1041 | Storage.remove s k) 1042 | (fun e -> 1043 | err := 1044 | Some (errorf "error when removing `%s`: %s" 1045 | k (Printexc.to_string e)); 1046 | Lwt.return_unit))) 1047 | st; 1048 | begin match !err with 1049 | | Some e -> Lwt.return e 1050 | | None -> 1051 | let stats = { 1052 | roots= !n_roots; 1053 | kept= !n_kept; 1054 | removed= !n_removed 1055 | } in 1056 | Lwt.return (Ok stats) 1057 | end 1058 | end 1059 | 1060 | let read_file (f:File_ref.t) : string or_error Lwt.t = 1061 | let s = File_ref.path f in 1062 | Lwt.catch 1063 | (fun () -> 1064 | Lwt_io.with_file ~mode:Lwt_io.Input s 1065 | (fun ic -> Lwt_io.read ic |> E.lift_ok)) 1066 | (fun e -> 1067 | E.fail (Printexc.to_string e)) 1068 | 1069 | let walk 1070 | ?(filter=fun _ -> true) 1071 | ?(recursive=true) 1072 | ?(which=[`File;`Dir]) 1073 | dir = 1074 | let dir = abspath dir in 1075 | let rec walk ~rec_ acc file = 1076 | if not (Sys.file_exists file) then acc 1077 | else if not (filter file) then acc 1078 | else ( 1079 | (* yield this particular file? *) 1080 | let acc = 1081 | if filter file && 1082 | ((Sys.is_directory file && 1083 | List.mem `Dir which) || 1084 | (not (Sys.is_directory file) && 1085 | List.mem `File which)) 1086 | then file :: acc 1087 | else acc 1088 | in 1089 | if Sys.is_directory file then ( 1090 | (* try to list the directory *) 1091 | let arr = try Sys.readdir file with Sys_error _ -> [||] in 1092 | Array.fold_left 1093 | (fun acc sub -> 1094 | (* abspath *) 1095 | let sub = Filename.concat file sub in 1096 | walk ~rec_:(rec_ && recursive) acc sub) 1097 | acc arr 1098 | ) else acc 1099 | ) 1100 | in 1101 | try walk ~rec_:true [] dir |> E.return 1102 | with e -> E.fail (Printexc.to_string e) 1103 | 1104 | include E.Infix 1105 | -------------------------------------------------------------------------------- /src/core/maki.mli: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Maki: Persistent Incremental Computations} 5 | 6 | Maki is a system for memoizing costly OCaml functions using the disk. 7 | It requires the functions to be {b pure}, that is, to always return 8 | the same result given that the set of {b dependencies} declared by 9 | the function doesn't change. 10 | 11 | {b status: experimental} 12 | 13 | This module is not thread-safe. 14 | *) 15 | 16 | type 'a or_error = ('a, string) Result.result 17 | type 'a lwt_or_error = 'a or_error Lwt.t 18 | type 'a printer = Format.formatter -> 'a -> unit 19 | 20 | val error : string -> _ or_error 21 | val errorf : ('a, Format.formatter, unit, 'b or_error) format4 -> 'a 22 | 23 | (** {2 Basic types} *) 24 | 25 | type path = string 26 | type program = string 27 | type time = float 28 | type hash = string 29 | type encoded_value = string 30 | 31 | (** {2 Error Handling} *) 32 | module E : sig 33 | type 'a t = 'a or_error Lwt.t 34 | 35 | val return : 'a -> 'a t 36 | val return_unit : unit t 37 | val fail : string -> _ t 38 | val lift_ok : 'a Lwt.t -> 'a t 39 | val lift_err : string Lwt.t -> 'a t 40 | val unwrap_res : ('a, exn) Result.result -> 'a Lwt.t 41 | module Infix : sig 42 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 43 | val ( >|= ) : 'a t -> ('a -> 'b) -> 'b t 44 | val ( <*> ) : ('a -> 'b) t -> 'a t -> 'b t 45 | val ( <$> ) : ('a -> 'b) -> 'a t -> 'b t 46 | end 47 | include module type of Infix 48 | end 49 | 50 | include module type of E.Infix 51 | 52 | (** {2 Controlling Parallelism} *) 53 | 54 | module Limit : sig 55 | type t 56 | val create : int -> t 57 | val acquire : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t 58 | 59 | val map_l : t -> ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t 60 | (** [map_l limit f l] maps [f] in parallel on [l], but restricts 61 | parallelism using [j] *) 62 | 63 | val j : unit -> t 64 | (** Default limiter for concurrency, should be set by CLI options *) 65 | 66 | val set_j : int -> unit 67 | (** Should be called at the beginning to set the value of [j]. 68 | @raise Failure if [j] is already evaluated *) 69 | end 70 | 71 | (** {2 Codec} 72 | 73 | Maki deals with functions that return values of any 74 | type that provides a {!'a Codec.t} implementation; 75 | that is, values that we can serialize and unserialize. 76 | The reason is that values are stored on disk for memoization purposes. 77 | *) 78 | module Codec : sig 79 | type 'a t = { 80 | descr: string; 81 | encode: 'a -> encoded_value * hash list; 82 | (** [encode x] should return a string encoding of [x], to be stored 83 | for the computation of some function, as well as a list of 84 | hash of sub-values used by [x] (for garbage collection purposes) *) 85 | decode: encoded_value -> 'a or_error; 86 | (** Decode the main value from its serialized representation *) 87 | } 88 | 89 | val make : 90 | encode:('a -> encoded_value * hash list) -> 91 | decode:(encoded_value -> 'a or_error) -> 92 | string -> 93 | 'a t 94 | 95 | val make_leaf : 96 | encode:('a -> encoded_value) -> 97 | decode:(encoded_value -> 'a or_error) -> 98 | string -> 99 | 'a t 100 | (** Encode an atomic value, as a leaf of the dependency graph. 101 | The value cannot depend on any other value (see {!make} for that) *) 102 | 103 | val encode : 'a t -> 'a -> encoded_value * hash list 104 | (** [encode codec x] uses the [codec] to encode [x] into a string that 105 | can be persisted to some {!Storage}. 106 | It also returns the list of hashes of other values this one 107 | depends on *) 108 | 109 | val decode : 'a t -> encoded_value -> 'a or_error 110 | (** [decode codec s] tries to decode the string [s] using [codec] 111 | into a proper value *) 112 | 113 | val make_bencode: 114 | encode:('a -> Bencode.t * hash list) -> 115 | decode:(Bencode.t -> 'a or_error) -> 116 | string -> 117 | 'a t 118 | (** Encode via a conversion to Bencode *) 119 | 120 | val make_leaf_bencode: 121 | encode:('a -> Bencode.t) -> 122 | decode:(Bencode.t -> 'a or_error) -> 123 | string -> 124 | 'a t 125 | (** Encode a leaf via bencode *) 126 | 127 | val int : int t 128 | val string : string t 129 | val bool : bool t 130 | val float : float t 131 | val or_error : 'a t -> 'a or_error t 132 | 133 | val marshal : string -> 'a t 134 | (** [marshal descr] encodes and decodes using marshal. 135 | Unsafe, but useful for prototyping. 136 | @param descr the (unique) description of this type. It might be 137 | a good idea to version it to avoid segfaults at decoding time. *) 138 | end 139 | 140 | (** {2 Persistent storage} 141 | 142 | We use a generic interface for persistent storage, in the form of a 143 | dictionary [string -> string]. The default storage just uses 144 | one file per pair. *) 145 | 146 | module Storage : sig 147 | type t = { 148 | name: string; 149 | get: string -> string option or_error Lwt.t; 150 | set: string -> string -> unit or_error Lwt.t; 151 | remove: string -> unit Lwt.t; 152 | fold: 'a. f:('a -> string * string -> 'a or_error Lwt.t) -> x:'a -> 'a or_error Lwt.t; 153 | flush_cache: unit -> unit; 154 | } 155 | 156 | val name : t -> string 157 | (** Informal description of the storage *) 158 | 159 | val get : t -> string -> string option or_error Lwt.t 160 | (** [get t k] obtains the value for [k] in [t] *) 161 | 162 | val get_exn : t -> string -> string option Lwt.t 163 | 164 | val set : t -> string -> string -> unit or_error Lwt.t 165 | (** [set t k v] puts the pair [k -> v] in [t] *) 166 | 167 | val set_exn : t -> string -> string -> unit Lwt.t 168 | 169 | val remove : t -> string -> unit Lwt.t 170 | 171 | val fold : t -> f:('a -> string * string -> 'a or_error Lwt.t) -> x:'a -> 'a or_error Lwt.t 172 | (** [fold ~f ~x t] folds over all the pairs [key, value] in [t]. *) 173 | 174 | val to_list : t -> (string * string) list or_error Lwt.t 175 | (** Get all bindings in this storage *) 176 | 177 | val flush_cache : t -> unit 178 | (** Flush in-process cache, if any *) 179 | 180 | val none : t 181 | (** A dummy storage which does not store any result, thus forcing 182 | every computation to run. *) 183 | 184 | val default : ?dir:path -> unit -> t Lwt.t 185 | (** [default ?dir ()] creates a new default storage (one file per pair) 186 | @param dir if provided, set the directory used for storing files 187 | if [dir] is not set, then the current directory is used, unless the 188 | environment variable "MAKI_DIR" is set 189 | @raise Unix.Error in case of error, if it could not create [dir] properly *) 190 | 191 | val set_default : t -> unit 192 | (** Change the storage that is used to evaluate every Maki function *) 193 | 194 | val get_default : unit -> t 195 | end 196 | 197 | (** {2 Time Utils} *) 198 | 199 | module Time : sig 200 | type t = time 201 | val seconds : int -> t 202 | val hours : int -> t 203 | val minutes : int -> t 204 | val days : int -> t 205 | val weeks : int -> t 206 | val now : unit -> t 207 | val (++) : t -> t -> t 208 | val pp : t printer 209 | end 210 | 211 | (** {2 lifetime for a value on disk} *) 212 | module Lifetime : sig 213 | type t = 214 | | Keep 215 | | KeepFor of time (** Time delta *) 216 | | KeepUntil of time (** Absolute deadline *) 217 | | CanDrop 218 | 219 | val keep : t 220 | val can_drop : t 221 | val keep_for : time -> t 222 | val keep_until : time -> t 223 | 224 | val pp : t printer 225 | 226 | val default : t 227 | (** Default lifetime for values *) 228 | 229 | (** A few useful lifetimes *) 230 | val short : t 231 | val one_minute : t 232 | val one_hour : t 233 | val one_day : t 234 | end 235 | 236 | (** {2 Values Stored on Disk} *) 237 | 238 | module File_ref : sig 239 | type t 240 | (** An immutable reference to a file, as a path, with a hash of its 241 | content. 242 | If the file changes on the filesystem, the reference becomes 243 | invalid. *) 244 | 245 | val path : t -> path 246 | val hash : t -> hash 247 | 248 | val to_string : t -> string 249 | 250 | val make : path -> t or_error Lwt.t 251 | (** Make a file ref out of a simple path *) 252 | 253 | val make_exn : path -> t Lwt.t 254 | (** @raise Invalid_argument if the path is not valid *) 255 | 256 | val is_valid : t -> bool Lwt.t 257 | (** Check if the reference is up-to-date (i.e. the file content 258 | did not change) *) 259 | 260 | val codec : t Codec.t 261 | end 262 | 263 | module Program_ref : sig 264 | type t 265 | 266 | val find : path -> path or_error Lwt.t 267 | 268 | val make : path -> t or_error Lwt.t 269 | 270 | val as_file : t -> File_ref.t 271 | 272 | val codec : t Codec.t 273 | 274 | val to_string : t -> string 275 | end 276 | 277 | (** {6 Reference to On-Disk Value} *) 278 | module Ref : sig 279 | type 'a t = 'a Codec.t * hash 280 | (** A reference to some value of type ['a], referred to by the 281 | hash of the value. 282 | The codec is there to deserialize the value when it's dereferenced. *) 283 | 284 | val hash : _ t -> hash 285 | (** Recover the hash corresponding to the reference. *) 286 | 287 | val store : 288 | ?storage:Maki_storage.t -> 289 | ?lifetime:Lifetime.t -> 290 | 'a Codec.t -> 291 | 'a -> 292 | 'a t or_error Lwt.t 293 | (** [store v x] stores [x] on disk using [v] to encode it *) 294 | 295 | val find : 296 | ?storage:Maki_storage.t -> 297 | 'a t -> 298 | 'a or_error Lwt.t 299 | (** [find codec h] fetches the value whose hash is [h], assuming it 300 | is stored, and decodes it. Returns an error if the value is 301 | not present. *) 302 | 303 | val get : 304 | ?storage:Maki_storage.t -> 305 | 'a t -> 306 | 'a option or_error Lwt.t 307 | (** [get codec h] fetches the value whose hash is [h], if it is 308 | stored, and decodes it. *) 309 | end 310 | 311 | (** {2 Hash function} 312 | 313 | A cryptographic hash function used to map objects to (probably) unique keys *) 314 | 315 | module Hash : sig 316 | module Sha : module type of Sha1 317 | 318 | type 'a t = Sha.ctx -> 'a -> unit 319 | 320 | val unit : unit t 321 | val int : int t 322 | val bool: bool t 323 | val string : string t 324 | val float : float t 325 | val list : 'a t -> 'a list t 326 | val array : 'a t -> 'a array t 327 | 328 | val map : ('a -> 'b) -> 'b t -> 'a t 329 | (** [map f hash x] encodes [x] using [f], and then uses [hash] 330 | to hash [f x]. *) 331 | 332 | val file_ref : File_ref.t t 333 | (** How to hash a file ref *) 334 | 335 | val program_ref : Program_ref.t t 336 | (** How to hash a program ref *) 337 | 338 | val set : 'a t -> 'a list t 339 | (** [set op] is similar to {!list}, except the order of elements does 340 | not matter. *) 341 | 342 | val marshal : 'a t 343 | (** Encode the data into a string using marshal, then hash 344 | the string. 345 | Caution, this is somewhat unsafe, but useful for quick-and-dirty work. *) 346 | 347 | val pair : 'a t -> 'b t -> ('a * 'b) t 348 | val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t 349 | val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t 350 | 351 | val hash : 'a t -> 'a -> Sha.t 352 | (** Hash a value. *) 353 | 354 | val hash_to_string : 'a t -> 'a -> string 355 | (** Hash a value, then encode the hash into a string. *) 356 | 357 | val of_codec : 'a Codec.t -> 'a t 358 | (** Hashing by encoding, then hashing the encoded value *) 359 | end 360 | 361 | (** {2 Memoized Functions} 362 | 363 | This is the heart of the library: a wrapper around {b pure} functions 364 | from {!Arg} arguments to a {!Codec}-aware type. Such functions 365 | are supposed to always return the same value given the same arguments 366 | and dependencies (a typical dependency is an external program that 367 | might have several version). 368 | 369 | The {!call} function is used to actually evaluate a wrapped function, 370 | or return its memoized result if the computation was done already. 371 | 372 | We need to name functions because, from one execution to another, 373 | the results of a function call must be stored on disk. Names are used 374 | to map function calls to their result. If two different functions 375 | share the same name (even across programs), the results will be 376 | unpredictable. 377 | *) 378 | 379 | (** {3 High-Level API} *) 380 | 381 | module Fun : sig 382 | type ('f,'f2,'ret) t 383 | 384 | type 'f call_wrap = 385 | ?bypass:bool -> 386 | ?storage:Storage.t -> 387 | ?lifetime:Lifetime.t -> 388 | ?limit:Limit.t -> 389 | ?tags:string list -> 390 | 'f 391 | end 392 | 393 | val return_ok : 'a -> 'a or_error Lwt.t 394 | val return_fail : string -> 'a or_error Lwt.t 395 | 396 | val mk1 : 397 | ( name:string -> 398 | 'a Hash.t -> 'ret Codec.t -> 399 | f:(('a -> 'ret or_error Lwt.t) as 'f) -> 400 | 'f) Fun.call_wrap 401 | (** [mk1 ~name h codec ~f] behaves like the unary function [f : 'a -> 'ret] 402 | but uses the hash function [h] to hash arguments, and [codec] to 403 | save/restore values from the cache when [f] has already been evaluated 404 | on a given value. 405 | @param name is used to distinguish calls to [f] from calls to other 406 | functions that have the same signature. 407 | 408 | Example: memoizing a recursive function: 409 | {[ 410 | let fib = 411 | let rec fib n = Maki.( 412 | mk1 ~name:"fib" Hash.int Codec.int ~lifetime:Lifetime.one_minute 413 | ~f:(fun x -> if x <= 1 414 | then return_ok 1 415 | else (fib (x-1) >>= fun x1 -> 416 | fib (x-2) >|= fun x2 -> x1+x2)) 417 | n 418 | ) in 419 | fib;; 420 | 421 | fib 42 ;; 422 | (* returns [Ok 42] *) 423 | ]} 424 | 425 | *) 426 | 427 | val mk2 : 428 | ( name:string -> 429 | 'a Hash.t -> 'b Hash.t -> 'ret Codec.t -> 430 | f:(('a -> 'b -> 'ret or_error Lwt.t) as 'f) -> 431 | 'f) Fun.call_wrap 432 | (** Binary version of {!mk1} 433 | 434 | Example: memoized concatenation of two files : 435 | {[ 436 | open Lwt.Infix;; 437 | 438 | let concat = 439 | Maki.(mk2 ~name:"concat" Hash.file_ref Hash.file_ref Codec.string ~lifetime:Lifetime.one_hour 440 | ~f:(fun f1 f2 -> 441 | let open E in 442 | read_file f1 >>= fun content1 -> 443 | read_file f2 >>= fun content2 -> 444 | return_ok (content1 ^ content2))) 445 | ;; 446 | 447 | let x1 = Maki.(File_ref.make "foo1" >>= fun f1 -> File_ref.make "foo2" >>= concat f1);; 448 | 449 | (* cached *) 450 | let x2 = Maki.(File_ref.make "foo1" >>= fun f1 -> File_ref.make "foo2" >>= concat f1);; 451 | 452 | (* now change contnet of file "foo1", so this should change too *) 453 | let x3 = Maki.(File_ref.make "foo1" >>= fun f1 -> File_ref.make "foo2" >>= concat f1);; 454 | 455 | *) 456 | 457 | val mk3 : 458 | ( name:string -> 459 | 'a Hash.t -> 'b Hash.t -> 'c Hash.t -> 'ret Codec.t -> 460 | f:(('a -> 'b -> 'c -> 'ret or_error Lwt.t) as 'f) -> 461 | 'f) Fun.call_wrap 462 | 463 | val mk4 : 464 | ( name:string -> 465 | 'a Hash.t -> 'b Hash.t -> 'c Hash.t -> 'd Hash.t -> 'ret Codec.t -> 466 | f:(('a -> 'b -> 'c -> 'd -> 'ret or_error Lwt.t) as 'f) -> 467 | 'f) Fun.call_wrap 468 | 469 | val mk5 : 470 | ( name:string -> 471 | 'a Hash.t -> 'b Hash.t -> 'c Hash.t -> 'd Hash.t -> 'e Hash.t -> 'ret Codec.t -> 472 | f:(('a -> 'b -> 'c -> 'd -> 'e -> 'ret or_error Lwt.t) as 'f) -> 473 | 'f) Fun.call_wrap 474 | 475 | (** {3 Low-Level API} *) 476 | 477 | (** To memoize a function, Maki must be able to hash the function's input 478 | arguments. Arguments that hash to the same value are considered 479 | identical. We use a cryptographic hash to ensure that the probability 480 | of collisions is astronomically low. 481 | 482 | An argument is then the pair of the value and its hash function; 483 | if the result is stored (by the computation's hash), we return it, 484 | otherwise we compute the value. 485 | 486 | Example: to pass a [int list] as argument: 487 | {[ 488 | Arg.(Hash.(list int) @:: [41; 0; 1] ) 489 | ]} 490 | *) 491 | module Arg : sig 492 | type t = A : 'a Hash.t * 'a -> t 493 | (** A pair of a value (in case we need to compute) and a hash 494 | function (to check whether a result is computed already). 495 | 496 | Typically one would use {!@::}: 497 | 498 | - {[ int @:: 42 ]} 499 | - {[ list string @ ["a"; "b"] ]} *) 500 | 501 | val make : 'a Hash.t -> 'a -> t 502 | 503 | val of_codec : 'a Codec.t -> 'a -> t 504 | 505 | module Infix : sig 506 | val (@::) : 'a Hash.t -> 'a -> t (** Infix alias to {!make} *) 507 | end 508 | include module type of Infix 509 | end 510 | 511 | val call : 512 | ?bypass:bool -> 513 | ?storage:Storage.t -> 514 | ?lifetime:Lifetime.t -> 515 | ?limit:Limit.t -> 516 | ?tags:string list -> 517 | name:string -> 518 | args:Arg.t list -> 519 | returning:'a Codec.t -> 520 | (unit -> 'a or_error Lwt.t) -> 521 | 'a or_error Lwt.t 522 | (** Call the function iff its result has not been cached yet 523 | @param bypass if true, then cache is disabled 524 | @param storage the storage used for caching values 525 | (default [Storage.get_default ()]) 526 | @param lifetime how long to keep the cached value (default: [`CanDrop]) 527 | @param limit if given, [call] will acquire a handle from [limit] before 528 | calling the (potentially costly) function 529 | @param name the name of the function, should be unique! 530 | @param deps the dependencies (arguments) of the function 531 | @param returning how to encode/decode the result on disk 532 | *) 533 | 534 | val call_pure : 535 | ?bypass:bool -> 536 | ?storage:Storage.t -> 537 | ?lifetime:Lifetime.t -> 538 | ?limit:Limit.t -> 539 | ?tags:string list -> 540 | name:string -> 541 | args:Arg.t list -> 542 | returning:'a Codec.t -> 543 | (unit -> 'a Lwt.t) -> 544 | 'a or_error Lwt.t 545 | 546 | (** {2 GC} 547 | 548 | Garbage Collection for the stored values. It needs to be called 549 | explicitely *) 550 | 551 | module GC_info : sig 552 | type t = 553 | | Keep 554 | | KeepUntil of time 555 | | CanDrop 556 | val lt : t -> t -> bool 557 | val of_lifetime : Lifetime.t -> t 558 | val codec : t Codec.t 559 | end 560 | 561 | module On_disk_record : sig 562 | type t 563 | 564 | val gc_info : t -> GC_info.t 565 | val key : t -> hash 566 | val children : t -> hash list 567 | val data : t -> encoded_value 568 | val lifetime : t -> Lifetime.t 569 | 570 | val codec : t Codec.t 571 | end 572 | 573 | module GC : sig 574 | type stats = { 575 | roots: int; 576 | kept: int; (* ≥ roots *) 577 | removed: int; 578 | } 579 | 580 | val string_of_stats : stats -> string 581 | 582 | val cleanup : ?force:bool -> Storage.t -> stats or_error Lwt.t 583 | (** [cleanup s] removes uneeded values and uneeded dependencies, 584 | and returns some statistics. It might take a long time. 585 | @param force if true, ignore roots and remove every entry *) 586 | end 587 | 588 | (** {2 Utils} *) 589 | 590 | module Util = Maki_utils 591 | 592 | val last_mtime : path -> time or_error 593 | (** Last modification time of the file *) 594 | 595 | val sha1 : path -> string or_error Lwt.t 596 | (** [sha1 f] hashes the file [f] *) 597 | 598 | val sha1_of_string : string -> string 599 | (** hash the given string *) 600 | 601 | val abspath : path -> path 602 | (** Make the path absolute *) 603 | 604 | val shell : 605 | ?timeout:float -> ?stdin:string -> 606 | string -> 607 | (string * string * int) or_error Lwt.t 608 | (** [shell cmd] runs the command [cmd] and 609 | returns [stdout, sterr, errcode]. 610 | @param stdin optional input to the sub-process *) 611 | 612 | val shellf : 613 | ?timeout:float -> ?stdin:string -> 614 | ('a, Format.formatter, unit, (string * string * int) or_error Lwt.t) format4 615 | -> 'a 616 | (** Same as {!shell} but with a format string. Careful with escaping! *) 617 | 618 | val read_file : File_ref.t -> string or_error Lwt.t 619 | (** Read the content of the file *) 620 | 621 | val walk : 622 | ?filter:(path -> bool) -> 623 | ?recursive:bool -> 624 | ?which:[`File | `Dir] list -> 625 | path -> 626 | path list or_error Lwt.t 627 | (** [walk dir] traverses the directory and yields 628 | its content, by {b absolute} path. 629 | @param which filters on the type of the content 630 | @param recursive if true, walks into subdirectories too 631 | @param filter filters the absolute path of objects 632 | and yields only these which satisfy the predicate 633 | *) 634 | 635 | (* TODO: globbing, for depending on lists of files easily *) 636 | 637 | (** {2 Logging} *) 638 | 639 | module Log : sig 640 | type logger = { 641 | log: 'a. 642 | int -> 643 | ((('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a) -> unit) -> 644 | unit 645 | } 646 | 647 | val log : int -> string -> unit 648 | 649 | val logf : 650 | int -> 651 | ((('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a) -> unit) -> 652 | unit 653 | (** Log at the given level, using a {!Format}-ready message. This is 654 | designed to be cheap if the message won't be printed because its 655 | level is too high. 656 | Use like this: 657 | [logf 1 (fun k->k "hello %s, 42=%d" "world" (41+1))] *) 658 | 659 | val default_logger : logger 660 | 661 | val set_logger : logger -> unit 662 | 663 | val set_level : int -> unit 664 | end 665 | -------------------------------------------------------------------------------- /src/core/maki_bencode.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Helpers for Bencode} *) 5 | 6 | module B = Bencode 7 | open Result 8 | 9 | let expected_s what s = 10 | Error (Printf.sprintf "maki: bencode: expected %s, got %s" what s) 11 | 12 | let expected_b what b = expected_s what (B.encode_to_string b) 13 | 14 | let decode_bencode s = 15 | try Ok (B.decode (`String s)) 16 | with e -> 17 | Error (s ^ " is not valid Bencode: " ^ Printexc.to_string e) 18 | 19 | let assoc k l = 20 | try Ok (List.assoc k l) 21 | with Not_found -> Error ("could not find key " ^ k) 22 | 23 | let assoc_or default k l = 24 | try List.assoc k l 25 | with _ -> default 26 | 27 | let as_str = function 28 | | B.String s -> Ok s 29 | | b -> expected_b "string" b 30 | 31 | let as_float = function 32 | | B.String s as b -> 33 | begin try Ok (float_of_string s) 34 | with _ -> expected_b "float" b 35 | end 36 | | _ -> Error "expected string" 37 | 38 | let as_list = function 39 | | B.List l -> Ok l 40 | | b -> expected_b "list" b 41 | 42 | let mk_str s = B.String s 43 | let mk_list l = B.List l 44 | let mk_dict l = 45 | let l = List.sort (fun (n1,_)(n2,_) -> compare n1 n2) l in 46 | B.Dict l 47 | let mk_pair x y = B.List [x; y] 48 | let mk_triple x y z = B.List [x;y;z] 49 | let mk_quad x y z u = B.List [x;y;z;u] 50 | -------------------------------------------------------------------------------- /src/core/maki_log.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Logs} *) 5 | 6 | type logger = { 7 | log: 'a. 8 | int -> 9 | ((('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a) -> unit) -> 10 | unit 11 | } 12 | 13 | let level_ = ref 1 14 | let set_level i = level_ := i 15 | 16 | let debug_fmt_ = Format.err_formatter 17 | 18 | let start = Unix.gettimeofday() 19 | 20 | let default_logger = { 21 | log=( 22 | fun i f -> 23 | if i <= !level_ 24 | then ( 25 | f 26 | (fun fmt -> 27 | Format.kfprintf 28 | (fun _ -> ()) 29 | debug_fmt_ 30 | ("@[<2>maki[%.3f]:@ " ^^ fmt ^^ "@]@.") (Unix.gettimeofday()-.start)) 31 | ) 32 | ) 33 | } 34 | 35 | let log_ : logger ref = ref default_logger 36 | 37 | let log i s = (!log_).log i (fun k->k "%s" s) 38 | let logf i k = (!log_).log i k 39 | 40 | let set_logger l = log_ := l 41 | -------------------------------------------------------------------------------- /src/core/maki_lwt_err.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | open Result 5 | 6 | type 'a or_error = ('a, string) Result.result 7 | 8 | type 'a t = 'a or_error Lwt.t 9 | 10 | let return x = Lwt.return (Ok x) 11 | 12 | let return_unit = Lwt.return (Ok ()) 13 | 14 | let fail msg = Lwt.return (Error msg) 15 | 16 | let unwrap_res = function 17 | | Ok x -> Lwt.return x 18 | | Error e -> Lwt.fail e 19 | 20 | let lift_ok m = Lwt.(m >|= fun x -> Ok x) 21 | 22 | let lift_err m = Lwt.(m >|= fun x -> Error x) 23 | 24 | module Infix = struct 25 | let (<*>) f x = 26 | Lwt.bind f 27 | (function 28 | | Error msg -> fail msg 29 | | Ok f -> 30 | Lwt.map 31 | (function 32 | | Ok x -> Ok (f x) 33 | | Error msg -> Error msg) 34 | x) 35 | 36 | let (>>=) x f = 37 | Lwt.bind x 38 | (function 39 | | Error msg -> fail msg 40 | | Ok y -> f y) 41 | 42 | let (>|=) x f = 43 | Lwt.map 44 | (function 45 | | Error _ as e -> e 46 | | Ok x -> Ok (f x)) 47 | x 48 | 49 | let (<$>) f x = x >|= f 50 | end 51 | 52 | include Infix 53 | -------------------------------------------------------------------------------- /src/core/maki_storage.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Persistent Storage} *) 5 | 6 | (* TODO: 7 | - optional interface for Memcached 8 | - optional interface for LMDB 9 | - optional interface for Sqlite 10 | - optional interface to DHT 11 | - composition of storages: 12 | * like RAID1, duplicate writes, use first terminating read 13 | * use one storage as a fast cache for the second storage (slower but 14 | probably more comprehensive; e.g. memcached + DHT for distributed jobs) 15 | - a dynlink based system for loading other storage systems 16 | - some system for picking storage from CLI options 17 | *) 18 | 19 | 20 | open Result 21 | open Lwt.Infix 22 | 23 | type 'a or_error = ('a, string) Result.result 24 | type path = string 25 | 26 | let error = Maki_utils.error 27 | let errorf = Maki_utils.errorf 28 | 29 | module E = Maki_lwt_err 30 | 31 | type t = { 32 | name: string; 33 | get: string -> string option or_error Lwt.t; 34 | set: string -> string -> unit or_error Lwt.t; 35 | remove: string -> unit Lwt.t; 36 | fold: 'a. f:('a -> string * string -> 'a or_error Lwt.t) -> x:'a -> 'a or_error Lwt.t; 37 | flush_cache: unit -> unit; 38 | } 39 | 40 | let env_var_ = "MAKI_DIR" 41 | 42 | let name t = t.name 43 | let get t k = t.get k 44 | let set t k v = t.set k v 45 | let remove t k = t.remove k 46 | let fold t ~f ~x = t.fold ~f ~x 47 | let flush_cache t = t.flush_cache () 48 | 49 | let get_exn t k = 50 | t.get k >>= function 51 | | Ok x -> Lwt.return x 52 | | Error e -> Lwt.fail (Failure e) 53 | 54 | let set_exn t k v = 55 | t.set k v >>= function 56 | | Ok () -> Lwt.return_unit 57 | | Error e -> Lwt.fail (Failure e) 58 | 59 | module Default = struct 60 | type t = { 61 | pool: unit Lwt_pool.t; 62 | dir: path; 63 | cache: (string, string option or_error) Hashtbl.t; 64 | } 65 | 66 | let k_to_file t f = Filename.concat t.dir f 67 | 68 | let read_file_ f = 69 | Lwt_io.with_file ~mode:Lwt_io.input f (fun ic -> Lwt_io.read ic) 70 | 71 | let get_ t k = 72 | try Lwt.return (Hashtbl.find t.cache k) 73 | with Not_found -> 74 | Lwt.catch 75 | (fun () -> 76 | let f = k_to_file t k in 77 | if Sys.file_exists f 78 | then read_file_ f >|= fun x -> Ok (Some x) 79 | else Lwt.return (Ok None)) 80 | (fun e -> 81 | Lwt.return (Error (Printexc.to_string e))) 82 | >|= fun res -> 83 | Hashtbl.add t.cache k res; 84 | res 85 | 86 | let get t k = Lwt_pool.use t.pool (fun _ -> get_ t k) 87 | 88 | let set_ t k v = 89 | Lwt.catch 90 | (fun () -> 91 | let f = k_to_file t k in 92 | Lwt_io.with_file f 93 | ~mode:Lwt_io.output ~flags:[Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC] 94 | ~perm:0o644 95 | (fun oc -> 96 | (* invalidate cache *) 97 | Hashtbl.replace t.cache k (Ok(Some v)); 98 | Lwt_io.write oc v >>= fun () -> 99 | Lwt_io.flush oc) 100 | >|= fun () -> Ok () 101 | ) 102 | (fun e -> 103 | errorf "storage: error when writing `%s`: %s" k (Printexc.to_string e) 104 | |> Lwt.return) 105 | 106 | let set t k v = Lwt_pool.use t.pool (fun _ -> set_ t k v) 107 | 108 | let remove t k = 109 | let f = k_to_file t k in 110 | Sys.remove f; 111 | Lwt.return_unit 112 | 113 | let fold t ~f ~x:acc = 114 | let dir = Unix.opendir t.dir in 115 | let rec aux acc = 116 | match Unix.readdir dir with 117 | | k -> 118 | let file = k_to_file t k in 119 | if Sys.is_directory file 120 | then aux acc (* ignore directories *) 121 | else ( 122 | read_file_ file >>= fun value -> 123 | f acc (k,value) >>= 124 | function 125 | | Ok acc -> aux acc 126 | | Error e -> Lwt.return (Error e) 127 | ) 128 | | exception (Unix.Unix_error _ as e) -> 129 | Unix.closedir dir; 130 | Lwt.fail e 131 | | exception End_of_file -> 132 | Lwt.return (Ok acc) 133 | in 134 | aux acc 135 | 136 | let flush t () = Hashtbl.clear t.cache 137 | 138 | let split_dir_ = 139 | let rec aux acc s = 140 | let parent = Filename.dirname s in 141 | if parent = "." || parent="/" then s::acc 142 | else aux (s::acc) parent 143 | in 144 | aux [] 145 | 146 | let create dir = 147 | (* first, create dir (and parents, recursively) *) 148 | List.iter 149 | (fun s -> 150 | try Unix.mkdir s 0o755 151 | with Unix.Unix_error (Unix.EEXIST, _, _) -> ()) 152 | (split_dir_ dir); 153 | let t = 154 | {dir; 155 | pool=Lwt_pool.create 100 (fun _ -> Lwt.return_unit); 156 | cache=Hashtbl.create 256 157 | } 158 | in 159 | { 160 | name="shelf"; 161 | get=get t; 162 | set=set t; 163 | remove=remove t; 164 | fold=(fun ~f ~x -> fold t ~f ~x); 165 | flush_cache=flush t; 166 | } 167 | end 168 | 169 | let none = { 170 | name = "dummy storage"; 171 | get = (fun _ -> Lwt.return (Result.Ok None)); 172 | set = (fun _ _ -> Lwt.return (Result.Ok ())); 173 | remove = (fun _ -> Lwt.return_unit); 174 | fold = (fun ~f:_ ~x -> Lwt.return (Ok x)); 175 | flush_cache = (fun () -> ()); 176 | } 177 | 178 | let default_ ?dir () = 179 | let dir = match dir with 180 | | Some d -> d 181 | | None -> 182 | try Sys.getenv env_var_ 183 | with Not_found -> 184 | let dir = 185 | try Sys.getenv "XDG_CACHE_HOME" 186 | with Not_found -> 187 | Filename.concat 188 | (try Sys.getenv "HOME" with Not_found -> "/tmp/") 189 | ".cache" 190 | in 191 | Filename.concat dir "maki" 192 | in 193 | Default.create dir 194 | 195 | let default ?dir () = Lwt.return (default_ ?dir ()) 196 | 197 | let storage_ = ref (lazy (default_ ())) 198 | let set_default s = storage_ := Lazy.from_val s 199 | let get_default () = Lazy.force !storage_ 200 | 201 | let to_list st = fold ~x:[] ~f:(fun acc pair -> E.return @@ pair::acc) st 202 | -------------------------------------------------------------------------------- /src/core/maki_utils.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Various Utils} *) 5 | 6 | open Result 7 | open Lwt.Infix 8 | 9 | type 'a or_error = ('a, string) Result.result 10 | 11 | let error msg = Error msg 12 | let errorf msg = 13 | let buf = Buffer.create 64 in 14 | let out = Format.formatter_of_buffer buf in 15 | Format.kfprintf 16 | (fun out -> Format.pp_print_flush out (); error (Buffer.contents buf)) 17 | out msg 18 | 19 | (* thread that prints progress *) 20 | module ProgressBar = struct 21 | let nb_sec_minute = 60 22 | let nb_sec_hour = 60 * nb_sec_minute 23 | let nb_sec_day = 24 * nb_sec_hour 24 | 25 | (* how to print the time *) 26 | let time_string f = 27 | let n = int_of_float f in 28 | let aux n div = n / div, n mod div in 29 | let n_day, n = aux n nb_sec_day in 30 | let n_hour, n = aux n nb_sec_hour in 31 | let n_min, n = aux n nb_sec_minute in 32 | let print_aux s n = if n <> 0 then (string_of_int n) ^ s else "" in 33 | (print_aux "d" n_day) ^ 34 | (print_aux "h" n_hour) ^ 35 | (print_aux "m" n_min) ^ 36 | (string_of_int n) ^ "s" 37 | 38 | type t = { 39 | thread: unit Lwt.t lazy_t; 40 | start: float; (* timestamp *) 41 | n: int; (* max *) 42 | mutable cur: int; 43 | } 44 | 45 | let rec loop t = 46 | let time_elapsed = Unix.gettimeofday () -. t.start in 47 | let len_bar = 30 in 48 | let bar = 49 | String.init len_bar 50 | (fun i -> if i * t.n <= len_bar * t.cur then '#' else ' ') in 51 | let percent = if t.n=0 then 100 else (t.cur * 100) / t.n in 52 | Lwt_io.printf "\r... %5d/%d | %3d%% [%6s: %s]" 53 | t.cur t.n percent (time_string time_elapsed) bar 54 | >>= fun () -> 55 | Lwt_io.flush Lwt_io.stdout >>= fun () -> 56 | if t.cur = t.n 57 | then 58 | Lwt_io.printl "" >>= fun () -> 59 | Lwt_io.flush Lwt_io.stdout 60 | else 61 | Lwt_unix.sleep 0.2 >>= fun () -> loop t 62 | 63 | let make ~n = 64 | let start = Unix.gettimeofday () in 65 | let rec t = { thread=lazy (loop t); start; n; cur=0; } in 66 | ignore (Lazy.force t.thread); 67 | t 68 | 69 | let stop t = Lwt.cancel (Lazy.force t.thread) 70 | 71 | let incr t = t.cur <- t.cur + 1 72 | 73 | let set_count t m = 74 | assert (m >= 0 && m <= t.n); 75 | t.cur <- m 76 | end 77 | 78 | (** {2 Caches} *) 79 | module Cache = struct 80 | type 'a equal = 'a -> 'a -> bool 81 | type 'a hash = 'a -> int 82 | 83 | let default_eq_ = Pervasives.(=) 84 | let default_hash_ = Hashtbl.hash 85 | 86 | (** {2 Value interface} *) 87 | 88 | (** Invariants: 89 | - after [cache.set x y], [get cache x] must return [y] or raise [Not_found] 90 | - [cache.set x y] is only called if [get cache x] fails, never if [x] is already bound 91 | - [cache.size()] must be positive and correspond to the number of items in [cache.iter] 92 | - [cache.iter f] calls [f x y] with every [x] such that [cache.get x = y] 93 | - after [cache.clear()], [cache.get x] fails for every [x] 94 | *) 95 | type ('a,'b) t = { 96 | set : 'a -> 'b -> unit; 97 | get : 'a -> 'b; (* or raise Not_found *) 98 | size : unit -> int; 99 | iter : ('a -> 'b -> unit) -> unit; 100 | clear : unit -> unit; 101 | } 102 | 103 | let clear c = c.clear () 104 | 105 | let with_cache c f x = 106 | try 107 | c.get x 108 | with Not_found -> 109 | let y = f x in 110 | c.set x y; 111 | y 112 | 113 | let get c x = try Some (c.get x) with Not_found -> None 114 | let set c x y = c.set x y 115 | 116 | let size c = c.size () 117 | 118 | let iter c f = c.iter f 119 | 120 | module Replacing = struct 121 | type ('a,'b) bucket = 122 | | Empty 123 | | Pair of 'a * 'b 124 | 125 | type ('a,'b) t = { 126 | eq : 'a equal; 127 | hash : 'a hash; 128 | arr : ('a,'b) bucket array; 129 | mutable c_size : int; 130 | } 131 | 132 | let make eq hash size = 133 | assert (size>0); 134 | {arr=Array.make size Empty; eq; hash; c_size=0 } 135 | 136 | let clear c = 137 | c.c_size <- 0; 138 | Array.fill c.arr 0 (Array.length c.arr) Empty 139 | 140 | let get c x = 141 | let i = c.hash x mod Array.length c.arr in 142 | match c.arr.(i) with 143 | | Pair (x', y) when c.eq x x' -> y 144 | | Pair _ 145 | | Empty -> raise Not_found 146 | 147 | let set c x y = 148 | let i = c.hash x mod Array.length c.arr in 149 | if c.arr.(i) = Empty then c.c_size <- c.c_size + 1; 150 | c.arr.(i) <- Pair (x,y) 151 | 152 | let iter c f = 153 | Array.iter (function Empty -> () | Pair (x,y) -> f x y) c.arr 154 | 155 | let size c () = c.c_size 156 | end 157 | 158 | let replacing ?(eq=default_eq_) ?(hash=default_hash_) size = 159 | let c = Replacing.make eq hash size in 160 | { get=(fun x -> Replacing.get c x); 161 | set=(fun x y -> Replacing.set c x y); 162 | clear=(fun () -> Replacing.clear c); 163 | size=Replacing.size c; 164 | iter=Replacing.iter c; 165 | } 166 | end 167 | -------------------------------------------------------------------------------- /src/core/maki_utils.mli: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Various Utils} *) 5 | 6 | type 'a or_error = ('a, string) Result.result 7 | 8 | val error : string -> _ or_error 9 | val errorf : ('a, Format.formatter, unit, 'b or_error) format4 -> 'a 10 | 11 | 12 | module ProgressBar : sig 13 | type t 14 | 15 | val make : n:int -> t 16 | 17 | val stop : t -> unit 18 | 19 | val incr : t -> unit 20 | 21 | val set_count : t -> int -> unit 22 | end 23 | 24 | (** {2 Cache} *) 25 | module Cache : sig 26 | type 'a equal = 'a -> 'a -> bool 27 | type 'a hash = 'a -> int 28 | 29 | type ('a, 'b) t 30 | 31 | val get : ('a, 'b) t -> 'a -> 'b option 32 | 33 | val set : ('a, 'b) t -> 'a -> 'b -> unit 34 | 35 | val clear : (_,_) t -> unit 36 | (** Clear the content of the cache *) 37 | 38 | val with_cache : ('a, 'b) t -> ('a -> 'b) -> 'a -> 'b 39 | (** [with_cache c f] behaves like [f], but caches calls to [f] in the 40 | cache [c]. It always returns the same value as 41 | [f x], if [f x] returns, or raise the same exception. 42 | However, [f] may not be called if [x] is in the cache. *) 43 | 44 | val size : (_,_) t -> int 45 | (** Size of the cache (number of entries). At most linear in the number 46 | of entries. *) 47 | 48 | val iter : ('a,'b) t -> ('a -> 'b -> unit) -> unit 49 | (** Iterate on cached values. Should yield [size cache] pairs. *) 50 | 51 | val replacing : ?eq:'a equal -> ?hash:'a hash -> 52 | int -> ('a,'b) t 53 | (** Replacing cache of the given size. Equality and hash functions can be 54 | parametrized. It's a hash table that handles collisions by replacing 55 | the old value with the new (so a cache entry is evicted when another 56 | entry with the same hash (modulo size) is added). 57 | Never grows wider than the given size. *) 58 | end 59 | -------------------------------------------------------------------------------- /src/demo_build/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name maki_build) 3 | (libraries maki containers containers.data oasis-parser lwt lwt.ppx)) 4 | -------------------------------------------------------------------------------- /src/demo_build/maki_build.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Maki-Build} 5 | 6 | This tool is a {b TOY} build system for OCaml, intended only for 7 | demonstrating features of Maki. *) 8 | 9 | open Lwt.Infix 10 | 11 | module A = Oasis_ast 12 | module P = Oasis_parser 13 | module V = Maki.Value 14 | 15 | (** {2 Helpers} *) 16 | 17 | let fail = failwith 18 | let failf msg = CCFormat.ksprintf msg ~f:fail 19 | let failf_lwt msg = CCFormat.ksprintf msg ~f:(fun msg -> Lwt.fail (Failure msg)) 20 | 21 | let pp_string = CCFormat.string 22 | let pp_list ~sep pp = CCFormat.(hbox (list ~start:"" ~stop:"" ~sep pp)) 23 | let pp_strings = pp_list ~sep:"," pp_string 24 | let pp_strings_space = pp_list ~sep:" " pp_string 25 | 26 | (* replace file extension of [a] *) 27 | let set_ext a ~ext = 28 | try (Filename.chop_extension a) ^ ext 29 | with _ -> failf "could not chop extension of %s" a 30 | 31 | let shellf msg = 32 | CCFormat.ksprintf msg 33 | ~f:(fun cmd -> 34 | Maki_log.logf 5 (fun k->k "run command `%s`" cmd); 35 | Maki.shell cmd) 36 | 37 | let limit = Maki.Limit.create 20 38 | 39 | (** {2 Basic building blocks} *) 40 | 41 | (* path+module name --> filename *) 42 | let module_to_ml ~path m = 43 | let n1 = Printf.sprintf "%s/%s.ml" path (String.uncapitalize m) in 44 | let n2 = Printf.sprintf "%s/%s.ml" path (String.capitalize m) in 45 | if Sys.file_exists n1 then n1 46 | else if Sys.file_exists n2 then n2 47 | else failf "could not find .ml file for module %s/%s" path m 48 | 49 | (* can we find a .ml file for m? *) 50 | let has_ml_file ~path m = 51 | try ignore (module_to_ml ~path m); true 52 | with _ -> false 53 | 54 | let module_to_mli ~path m = 55 | let n1 = Printf.sprintf "%s/%s.mli" path (String.uncapitalize m) in 56 | let n2 = Printf.sprintf "%s/%s.mli" path (String.capitalize m) in 57 | if Sys.file_exists n1 then n1 58 | else if Sys.file_exists n2 then n2 59 | else module_to_ml ~path m (* fall back to .ml *) 60 | 61 | let module_to_cmi ~path m = 62 | module_to_mli ~path m |> set_ext ~ext:".cmi" 63 | 64 | let module_to_cmo ~path m = 65 | module_to_ml ~path m |> set_ext ~ext:".cmo" 66 | 67 | let deps_to_args deps = 68 | let l = CCList.flat_map (fun d -> ["-package"; d]) deps in 69 | if List.mem "threads" deps then "-thread" :: l else l 70 | 71 | (* other modules [m] depends on *) 72 | let find_deps ~deps ~path m : string list Lwt.t = 73 | let file = module_to_ml ~path m in 74 | let pdeps = CCList.flat_map (fun d -> ["-package"; d]) deps in 75 | (* call "ocamldep" *) 76 | Maki.call_exn ~name:"find_deps" ~limit 77 | ~deps:[V.pack_program "ocamldep"; V.pack_file file; V.pack_set V.string pdeps] 78 | ~op:V.(set string) 79 | (fun () -> 80 | shellf "@[ocamlfind ocamldep -modules %a %s@]" 81 | pp_strings_space pdeps file 82 | >|= fun (out,_,_) -> 83 | out 84 | |> CCString.Split.left_exn ~by:":" 85 | |> snd 86 | |> CCString.Split.list_cpy ~by:" " 87 | |> List.map String.trim 88 | |> List.filter (fun s -> s<>"") 89 | ) 90 | >|= fun l -> 91 | Maki_log.logf 5 (fun k->k "deps of %s/%s: %a" path m pp_strings l); 92 | l 93 | 94 | let find_local_deps ~deps ~path m : string list Lwt.t = 95 | Maki.call_exn 96 | ~name:"find_local_deps" 97 | ~lifetime:(`KeepFor Maki.Time.(minutes 30)) 98 | ~deps:[V.pack_string m; V.pack_string path; V.pack_set V.string deps] 99 | ~op:V.(set string) 100 | (fun () -> 101 | find_deps ~deps ~path m 102 | >|= List.filter (has_ml_file ~path)) 103 | 104 | (* find recursive deps (without duplicates) *) 105 | let rec find_local_deps_rec ~deps ~path m = 106 | let%lwt mdeps = find_local_deps ~deps ~path m in 107 | Maki.call_exn 108 | ~name:"find_local_deps_rec" 109 | ~deps:[V.pack_string m; V.pack_string path; V.pack_set V.string deps] 110 | ~op:V.(set string) 111 | (fun () -> 112 | Lwt_list.map_p (find_local_deps_rec ~deps ~path) mdeps 113 | >|= List.flatten 114 | >|= (fun l->List.rev_append mdeps l) 115 | >|= CCList.sort_uniq ~cmp:String.compare) 116 | 117 | (* find a topological ordering of given modules *) 118 | let topo_order ~path ~deps modules : string list Lwt.t = 119 | let%lwt deps = 120 | Lwt_list.map_p 121 | (fun m -> 122 | find_deps ~deps ~path m 123 | >|= fun l -> m, List.filter (fun m' -> List.mem m' modules) l) 124 | modules 125 | in 126 | (* build a graph to obtain a topological order *) 127 | let g = CCGraph.make_tuple (fun m -> List.assoc m deps |> CCList.to_seq) in 128 | let l = CCGraph.topo_sort ~rev:true ~graph:g (CCList.to_seq modules) in 129 | Lwt.return l 130 | 131 | (* build the .cmi for [m] *) 132 | let build_interface ~path ~deps m : Maki.path Lwt.t = 133 | let file_mli = module_to_mli ~path m in 134 | let file_cmi = module_to_cmi ~path m in 135 | Maki.call_exn 136 | ~name:"build_interface" ~limit 137 | ~lifetime:(`KeepFor Maki.Time.(minutes 30)) 138 | ~deps:[V.pack_file file_mli; V.pack_set V.string deps] 139 | ~op:V.file 140 | (fun () -> 141 | shellf "@[ocamlfind ocamlc -c -I %s %a %s -o %s@]" 142 | path pp_strings_space (deps_to_args deps) file_mli file_cmi 143 | >>= fun (o,e,_) -> 144 | if Sys.file_exists file_cmi 145 | then Lwt.return file_cmi 146 | else failf_lwt "failed to build interface %s of %s\n%s\n%s" file_cmi m o e) 147 | 148 | (* build module [m] (after building its dependencies). 149 | @param path path in which [m] lives 150 | @param deps library [m] depends upon *) 151 | let rec build_module ~path ~deps m : Maki.path Lwt.t = 152 | (* compute deps *) 153 | let%lwt m_deps = find_local_deps ~deps ~path m in 154 | (* build deps, obtain the resulting .cmo files *) 155 | let%lwt m_deps' = 156 | Lwt_list.map_p (fun m' -> build_module ~path ~deps m') m_deps 157 | in 158 | (* build interface *) 159 | let%lwt _ = build_interface ~path ~deps m in 160 | let file_ml = module_to_ml ~path m in 161 | let file_cmo = module_to_cmo ~path m in 162 | Maki.call_exn 163 | ~name:"build_module" ~limit 164 | ~lifetime:(`KeepFor Maki.Time.(hours 2)) 165 | ~deps:[V.pack_program "ocamlc"; V.pack_file file_ml; 166 | V.pack_set V.string deps; V.pack_set V.file m_deps'] 167 | ~op:V.file 168 | (fun () -> 169 | shellf "@[ocamlfind ocamlc -I %s -c %a %a %s -o %s@]" 170 | path 171 | pp_strings_space (deps_to_args deps) 172 | pp_strings_space m_deps' 173 | file_ml file_cmo 174 | >>= fun (o,e,_) -> 175 | if Sys.file_exists file_cmo 176 | then Lwt.return file_cmo 177 | else failf_lwt "failed to build %s for %s:\n%s\n%s" file_cmo m o e) 178 | 179 | let build_lib ~deps ~path ~name modules = 180 | (* build modules *) 181 | let%lwt () = 182 | Lwt_list.iter_p 183 | (fun m -> build_module ~deps ~path m >|= fun _ -> ()) 184 | modules 185 | in 186 | (* link in the proper order *) 187 | let%lwt l = 188 | topo_order ~path ~deps modules 189 | >|= List.map (module_to_cmo ~path) 190 | in 191 | let file_out = Filename.concat path (name ^ ".cma") in 192 | Maki.call_exn 193 | ~name:"build_lib" ~limit 194 | ~lifetime:(`KeepFor Maki.Time.(hours 2)) 195 | ~deps:[V.pack_program "ocamlc"; V.pack_list V.file l; V.pack_set V.string deps] 196 | ~op:V.file 197 | (fun () -> 198 | shellf "@[ocamlfind ocamlc -a %a -o %s" 199 | pp_strings_space l file_out 200 | >>= fun (o,e,_) -> 201 | if Sys.file_exists file_out then Lwt.return file_out 202 | else failf_lwt "error while building `%s` (out: %s, err:%s)" name o e 203 | ) 204 | >|= fun _ -> () 205 | 206 | let build_exec ~deps ~path ~name:_ main_is : unit Lwt.t = 207 | (* get back to module name (so as to reuse find_deps) *) 208 | let main_m = Filename.chop_extension main_is |> String.capitalize in 209 | Maki_log.logf 5 (fun k->k "main module: %s (main_is: %s)" main_m main_is); 210 | (* find recursive dependencies; only keep those in the same path *) 211 | let%lwt m_deps = find_local_deps_rec ~deps ~path main_m in 212 | Maki_log.logf 5 (fun k->k "main %s depends recursively on %a" main_m pp_strings m_deps); 213 | (* build deps *) 214 | let%lwt m_deps' = 215 | Lwt_list.map_p (build_module ~path ~deps) m_deps 216 | in 217 | (* build main module *) 218 | let%lwt main' = 219 | build_module ~path ~deps main_m 220 | in 221 | (* sort dependencies topologically *) 222 | let%lwt l = 223 | topo_order ~path ~deps m_deps 224 | >|= List.map (module_to_cmo ~path) 225 | in 226 | (* also depend on main module *) 227 | let l = l @ [main'] in 228 | let file_in = main' in 229 | let file_out = Filename.concat path (set_ext ~ext:".byte" main_is) in 230 | Maki.call_exn 231 | ~name:"build_exec" ~limit 232 | ~lifetime:(`KeepFor Maki.Time.(hours 2)) 233 | ~deps:[V.pack_program "ocamlc"; V.pack_file file_in; 234 | V.pack_set V.string m_deps'; V.pack_set V.file l] 235 | ~op:V.file 236 | (fun () -> 237 | shellf "@[ocamlfind ocamlc %a %a -linkpkg %s -o %s@]" 238 | pp_strings_space (deps_to_args deps) 239 | pp_strings_space l 240 | file_in file_out 241 | >>= fun (o,e,_) -> 242 | if Sys.file_exists file_out 243 | then Lwt.return file_out 244 | else failf_lwt "failed to build binary `%s` for `%s`\n%s\n%s" 245 | file_out main_is o e 246 | ) 247 | >|= fun _ -> () 248 | 249 | (** {2 Build following oasis} *) 250 | 251 | (* find field "f: something" in the list [l] *) 252 | let find_field ?or_ what f l = 253 | match 254 | CCList.find 255 | (function 256 | | A.S_field (f', A.F_set p) when f=f' -> Some p 257 | | _ -> None) l 258 | with 259 | | Some x -> x 260 | | None -> 261 | match or_ with 262 | | None -> failf "building `%s`: could not find \"%s\"" what f l 263 | | Some x -> x 264 | 265 | let build_oasis_lib name l = 266 | let path = find_field name "Path" l |> String.concat "" in 267 | let modules = find_field name "Modules" l |> P.split_list in 268 | let deps = find_field name ~or_:[] "BuildDepends" l |> P.split_list in 269 | Maki_log.logf 2 270 | (fun k->k "build lib `%s`: path %s,@ @[modules `@[%a@]`@],@ @[depends `@[%a@]`@]" 271 | name path pp_strings modules pp_strings deps); 272 | build_lib ~deps ~path ~name modules 273 | 274 | let build_oasis_exec name l = 275 | let path = find_field name "Path" l |> String.concat "" in 276 | let main_is = find_field name "MainIs" l |> String.concat "" in 277 | let deps = find_field name ~or_:[] "BuildDepends" l |> P.split_list in 278 | Maki_log.logf 2 279 | (fun k->k "build executable `%s`: path %s,@ main_is: `%s`,@ @[depends `@[%a@]`@]" 280 | name path main_is pp_strings deps); 281 | build_exec ~deps ~path ~name main_is 282 | 283 | let build_target stmts t = 284 | Maki_log.logf 1 (fun k->k "build target `%s`" t); 285 | let t' = 286 | CCList.find_map 287 | (function 288 | | A.TS_decl (A.Library, n, l) when n=t -> Some (`Lib l) 289 | | A.TS_decl (A.Executable, n, l) when n=t -> Some (`Exec l) 290 | | _ -> None) 291 | stmts 292 | in 293 | match t' with 294 | | Some (`Lib l) -> build_oasis_lib t l 295 | | Some (`Exec l) -> build_oasis_exec t l 296 | | None -> 297 | Maki_log.logf 0 (fun k->k "could not find target `%s`" t); 298 | exit 1 299 | 300 | let build targets = 301 | let stmts = Oasis_parser.parse_file "_oasis" in 302 | Lwt_list.iter_s (build_target stmts) targets 303 | 304 | (** {2 Main} *) 305 | 306 | let () = 307 | let options = 308 | Arg.align 309 | [ "-d", Arg.Int Maki_log.set_level, " set debug level" 310 | ; "-j", Arg.Int Maki.Limit.set_j, " set parallelism level" 311 | ] 312 | in 313 | let l = ref [] in 314 | Arg.parse options 315 | (fun s -> l := s :: !l) 316 | "usage: maki_build [options] target [,target]*"; 317 | Lwt_main.run (build (List.rev !l)) 318 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | 2 | (env 3 | (_ (flags :standard -warn-error -3 -w -32 -safe-string))) 4 | -------------------------------------------------------------------------------- /src/json/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name maki_yojson) 4 | (public_name maki.yojson) 5 | (optional) 6 | (flags :standard -safe-string) 7 | (libraries maki yojson)) 8 | -------------------------------------------------------------------------------- /src/json/maki_yojson.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Simple wrapper for Yojson} *) 5 | 6 | type 'a or_error = 'a Maki.or_error 7 | 8 | (** Yojson.Safe *) 9 | type json = Yojson.Safe.json 10 | 11 | let (>>=) r f = match r with 12 | | Result.Ok x -> f x 13 | | Result.Error e -> Result.Error e 14 | 15 | let decode_json s = 16 | try Result.Ok (Yojson.Safe.from_string s) 17 | with e -> 18 | Maki.errorf "expected json, got `%s`: %s" s (Printexc.to_string e) 19 | 20 | let hash ctx j = Maki.Hash.string ctx (Yojson.Safe.to_string j) 21 | 22 | let codec = 23 | Maki.Codec.make_leaf "json" 24 | ~encode:(fun j-> Yojson.Safe.to_string j) 25 | ~decode:decode_json 26 | 27 | let make ~to_yojson ~of_yojson name = 28 | Maki.Codec.make name 29 | ~encode:(fun x -> 30 | let j = to_yojson x in 31 | Yojson.Safe.to_string j, []) 32 | ~decode:(fun s -> decode_json s >>= of_yojson) 33 | 34 | let make_exn ~to_yojson ~of_yojson name = 35 | make name ~to_yojson 36 | ~of_yojson:( 37 | fun j -> match of_yojson j with 38 | | Result.Ok x -> Result.Ok x 39 | | Result.Error e -> Result.Error (Printexc.to_string e)) 40 | 41 | let make_err ~to_yojson ~of_yojson name = 42 | make name ~to_yojson 43 | ~of_yojson:( 44 | fun j -> match of_yojson j with 45 | | `Ok x -> Result.Ok x 46 | | `Error e -> Result.Error e) 47 | 48 | 49 | -------------------------------------------------------------------------------- /src/json/maki_yojson.mli: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Simple wrapper for Yojson} *) 5 | 6 | type 'a or_error = 'a Maki.or_error 7 | 8 | (** Yojson.Safe *) 9 | type json = Yojson.Safe.json 10 | 11 | val hash : json Maki.Hash.t 12 | (** Taking json as hash *) 13 | 14 | val codec : json Maki.Codec.t 15 | (** Encoding/Decoding json to strings *) 16 | 17 | val make : 18 | to_yojson:('a -> json) -> 19 | of_yojson:(json -> 'a or_error) -> 20 | string -> 21 | 'a Maki.Codec.t 22 | 23 | val make_exn : 24 | to_yojson:('a -> json) -> 25 | of_yojson:(json -> ('a, exn) Result.result) -> 26 | string -> 27 | 'a Maki.Codec.t 28 | 29 | val make_err : 30 | to_yojson:('a -> json) -> 31 | of_yojson:(json -> [`Ok of 'a | `Error of string]) -> 32 | string -> 33 | 'a Maki.Codec.t 34 | 35 | -------------------------------------------------------------------------------- /src/tools/dune: -------------------------------------------------------------------------------- 1 | 2 | (executables 3 | (names maki_gc maki_display) 4 | (public_names maki_gc maki_display) 5 | (package maki) 6 | (modes native) 7 | (libraries maki)) 8 | 9 | -------------------------------------------------------------------------------- /src/tools/maki_display.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Display Storage} *) 5 | 6 | open Lwt.Infix 7 | 8 | type 'a or_error = 'a Maki.or_error 9 | 10 | let collect_entries s : (string * Maki.On_disk_record.t) list or_error Lwt.t = 11 | Maki.Log.log 3 "display: collecting values..."; 12 | Maki.Storage.fold s ~x:[] 13 | ~f:(fun acc (key, value) -> 14 | let open Maki.E in 15 | (Maki.Codec.decode Maki.On_disk_record.codec value |> Lwt.return) 16 | >|= fun c -> (key,c) :: acc) 17 | 18 | let print_entries l = 19 | let module L = Maki.Lifetime in 20 | let pp_lifetime out = function 21 | | L.KeepFor _ -> assert false 22 | | L.KeepUntil t -> 23 | let now = Unix.gettimeofday () in 24 | Format.fprintf out "keep for %.1f s" (t -. now) 25 | | L.CanDrop -> Format.pp_print_string out "can drop" 26 | | L.Keep -> Format.pp_print_string out "keep" 27 | in 28 | let pp_pair out (k,c) = 29 | Format.fprintf out "@[`%s` ->@ `%s`@ [key: `%s`, %a]@]" 30 | k (Maki.On_disk_record.data c) (Maki.On_disk_record.key c) 31 | pp_lifetime (Maki.On_disk_record.lifetime c) 32 | in 33 | Format.printf "@[entries:@ %a@]@." 34 | (Format.pp_print_list pp_pair) l 35 | 36 | let () = 37 | let options = 38 | Arg.align 39 | [ "--debug", Arg.Int Maki.Log.set_level, " set debug level" 40 | ; "-d", Arg.Int Maki.Log.set_level, " short for --debug" 41 | ] 42 | in 43 | Arg.parse options (fun _ -> ()) "usage: maki_display [options]"; 44 | (* TODO: also parse which storage to GC *) 45 | let s = Maki.Storage.get_default () in 46 | Lwt_main.run ( 47 | let res = 48 | let open Maki.E in 49 | collect_entries s >|= print_entries 50 | in 51 | res >>= function 52 | | Result.Ok () -> Lwt.return_unit 53 | | Result.Error msg -> 54 | Lwt.fail (Failure msg) 55 | ) 56 | -------------------------------------------------------------------------------- /src/tools/maki_gc.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Maki GC implementation} *) 5 | 6 | module S = Maki.Storage 7 | 8 | open Result 9 | open Lwt.Infix 10 | 11 | let force = ref false 12 | 13 | let parse_argv () = 14 | let options = 15 | Arg.align 16 | [ "--debug", Arg.Int Maki.Log.set_level, " set debug level"; 17 | "-d", Arg.Int Maki.Log.set_level, " short for --debug"; 18 | "--force", Arg.Set force, " force collection of every object"; 19 | ] 20 | in 21 | Arg.parse options (fun _ -> ()) "usage: maki_gc [options]"; 22 | () 23 | 24 | let () = 25 | parse_argv (); 26 | (* TODO: also parse which storage to GC *) 27 | let s = S.get_default () in 28 | Lwt_main.run ( 29 | Maki.GC.cleanup ~force:!force s 30 | >>= function 31 | | Ok stats -> 32 | Printf.printf "GC done (%s)\n" (Maki.GC.string_of_stats stats); 33 | Lwt.return () 34 | | Error e -> 35 | Printf.printf "error: %s\n" e; 36 | exit 1 37 | ) 38 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test_fib) 3 | (libraries maki)) 4 | 5 | (alias 6 | (name runtest) 7 | (action (run ./test_fib.exe))) 8 | -------------------------------------------------------------------------------- /tests/test_fib.ml: -------------------------------------------------------------------------------- 1 | (* Naive fibonacci function *) 2 | 3 | open Maki.E 4 | 5 | let rec fib n = 6 | if n<= 1 then return 1 7 | else 8 | let n1 = fib_memo (n-1) in 9 | let n2 = fib_memo (n-2) in 10 | n1 >>= fun n1 -> n2 >|= fun n2 -> n1+n2 11 | 12 | and fib_memo n = 13 | Maki.call 14 | ~lifetime:(Maki.Lifetime.KeepFor (Maki.Time.minutes 20)) 15 | ~name:"fib" 16 | ~returning:Maki.Codec.int 17 | ~args:Maki.Arg.([Maki.Hash.int @:: n]) 18 | (fun () -> fib n) 19 | 20 | let main n = 21 | let open Lwt.Infix in 22 | fib n >|= function 23 | | Error msg -> Printf.printf "error: %s\n" msg 24 | | Ok n -> Printf.printf "result: %d\n" n 25 | 26 | let () = 27 | let n = ref 20 in 28 | Arg.parse 29 | [ "-n", Arg.Set_int n, " set number (default 20)" 30 | ; "--debug", Arg.Int Maki.Log.set_level, " set debug level" 31 | ] (fun _ -> failwith "no arguments") "usage: test_fib"; 32 | Lwt_main.run (main !n) 33 | --------------------------------------------------------------------------------