Stefan pushed to branch master at Stefan / Typer
Commits: d81d6755 by Stefan Monnier at 2016-12-05T12:00:55-05:00 * src/lexp.ml (hc): Reimplement using a *weak* set
* emacs/typer-mode.el: Move to its own subdirectory. * src/tweak.ml: New file, copied from OCaml's distribution.
- - - - -
4 changed files:
- .gitignore - typer-mode.el → emacs/typer-mode.el - src/lexp.ml - + src/tweak.ml
Changes:
===================================== .gitignore ===================================== --- a/.gitignore +++ b/.gitignore @@ -21,3 +21,5 @@ test__.typer *.orig _tags .merlin +gmon.out +ocamlprof.dump
===================================== typer-mode.el → emacs/typer-mode.el ===================================== --- a/typer-mode.el +++ b/emacs/typer-mode.el @@ -3,7 +3,8 @@ ;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
;; Author: Stefan Monnier monnier@iro.umontreal.ca -;; Keywords: +;; Keywords: +;; Version: 0
;; This file is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -20,7 +21,7 @@
;;; Commentary:
-;; +;;
;;; Code:
@@ -185,5 +186,4 @@ )
(provide 'typer-mode) -;; arch-tag: b5d7a461-b1bc-4f32-b3b7-cad11d95017d ;;; typer-mode.el ends here
===================================== src/lexp.ml ===================================== --- a/src/lexp.ml +++ b/src/lexp.ml @@ -131,13 +131,23 @@ let builtin_size = ref 0
(********************** Hash-consing **********************)
-(* FIXME: We'd want this hash-table to be weak in its values: as soon - * as one of its values can be GC'd, the entry should be removed. *) -let hc_table : (lexp, lexp) Hashtbl.t = Hashtbl.create 1000 -let hc (e : lexp) : lexp = - try Hashtbl.find hc_table e - with Not_found -> Hashtbl.add hc_table e e; - e +(* let hc_table : (lexp, lexp) Hashtbl.t = Hashtbl.create 1000 + * let hc (e : lexp) : lexp = + * try Hashtbl.find hc_table e + * with Not_found -> Hashtbl.add hc_table e e; e *) + +module WHC = Tweak.Make (struct type t = lexp + (* Using (=) instead of `compare` results + * in an *enormous* slowdown. Apparently + * `compare` checks == before recursing + * but (=) doesn't? *) + let equal x y = (compare x y = 0) + let hash = Hashtbl.hash + end) +let hc_table : WHC.t = WHC.create 1000 +let hc : lexp -> lexp = WHC.merge hc_table + + let mkImm s = hc (Imm s) let mkSortLevel l = hc (SortLevel l) let mkSort (l, s) = hc (Sort (l, s))
===================================== src/tweak.ml ===================================== --- /dev/null +++ b/src/tweak.ml @@ -0,0 +1,271 @@ +(* tweak.ml --- A tweaked version of OCaml's weak.ml + * + * Copyright (C) 2016 Free Software Foundation, Inc. + * + * The tweak consists in getting rid of `get_copy` and use `get` instead. *) + +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +type 'a t = 'a Weak.t + +let create = Weak.create +let length = Weak.length +let get = Weak.get +let set = Weak.set +let check = Weak.check +let blit = Weak.blit + +module type S = Weak.S + +module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct + + type 'a weak_t = 'a t + let weak_create = create + let emptybucket = weak_create 0 + + type data = H.t + + type t = { + mutable table : data weak_t array; + mutable hashes : int array array; + mutable limit : int; (* bucket size limit *) + mutable oversize : int; (* number of oversize buckets *) + mutable rover : int; (* for internal bookkeeping *) + } + + let get_index t h = (h land max_int) mod (Array.length t.table) + + let limit = 7 + let over_limit = 2 + + let create sz = + let sz = if sz < 7 then 7 else sz in + let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in + { + table = Array.create sz emptybucket; + hashes = Array.create sz [| |]; + limit = limit; + oversize = 0; + rover = 0; + } + + let clear t = + for i = 0 to Array.length t.table - 1 do + t.table.(i) <- emptybucket; + t.hashes.(i) <- [| |]; + done; + t.limit <- limit; + t.oversize <- 0 + + + let fold f t init = + let rec fold_bucket i b accu = + if i >= length b then accu else + match get b i with + | Some v -> fold_bucket (i+1) b (f v accu) + | None -> fold_bucket (i+1) b accu + in + Array.fold_right (fold_bucket 0) t.table init + + + let iter f t = + let rec iter_bucket i b = + if i >= length b then () else + match get b i with + | Some v -> f v; iter_bucket (i+1) b + | None -> iter_bucket (i+1) b + in + Array.iter (iter_bucket 0) t.table + + + let iter_weak f t = + let rec iter_bucket i j b = + if i >= length b then () else + match check b i with + | true -> f b t.hashes.(j) i; iter_bucket (i+1) j b + | false -> iter_bucket (i+1) j b + in + Array.iteri (iter_bucket 0) t.table + + + let rec count_bucket i b accu = + if i >= length b then accu else + count_bucket (i+1) b (accu + (if check b i then 1 else 0)) + + + let count t = + Array.fold_right (count_bucket 0) t.table 0 + + + let next_sz n = min (3 * n / 2 + 3) Sys.max_array_length + let prev_sz n = ((n - 3) * 2 + 2) / 3 + + let test_shrink_bucket t = + let bucket = t.table.(t.rover) in + let hbucket = t.hashes.(t.rover) in + let len = length bucket in + let prev_len = prev_sz len in + let live = count_bucket 0 bucket 0 in + if live <= prev_len then begin + let rec loop i j = + if j >= prev_len then begin + if check bucket i then loop (i + 1) j + else if check bucket j then begin + blit bucket j bucket i 1; + hbucket.(i) <- hbucket.(j); + loop (i + 1) (j - 1); + end else loop i (j - 1); + end; + in + loop 0 (length bucket - 1); + if prev_len = 0 then begin + t.table.(t.rover) <- emptybucket; + t.hashes.(t.rover) <- [| |]; + end else begin + Obj.truncate (Obj.repr bucket) (prev_len + 1); + Obj.truncate (Obj.repr hbucket) prev_len; + end; + if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1; + end; + t.rover <- (t.rover + 1) mod (Array.length t.table) + + + let rec resize t = + let oldlen = Array.length t.table in + let newlen = next_sz oldlen in + if newlen > oldlen then begin + let newt = create newlen in + let add_weak ob oh oi = + let setter nb ni _ = blit ob oi nb ni 1 in + let h = oh.(oi) in + add_aux newt setter None h (get_index newt h); + in + iter_weak add_weak t; + t.table <- newt.table; + t.hashes <- newt.hashes; + t.limit <- newt.limit; + t.oversize <- newt.oversize; + t.rover <- t.rover mod Array.length newt.table; + end else begin + t.limit <- max_int; (* maximum size already reached *) + t.oversize <- 0; + end + + and add_aux t setter d h index = + let bucket = t.table.(index) in + let hashes = t.hashes.(index) in + let sz = length bucket in + let rec loop i = + if i >= sz then begin + let newsz = min (3 * sz / 2 + 3) (Sys.max_array_length - 1) in + if newsz <= sz then failwith "Weak.Make: hash bucket cannot grow more"; + let newbucket = weak_create newsz in + let newhashes = Array.make newsz 0 in + blit bucket 0 newbucket 0 sz; + Array.blit hashes 0 newhashes 0 sz; + setter newbucket sz d; + newhashes.(sz) <- h; + t.table.(index) <- newbucket; + t.hashes.(index) <- newhashes; + if sz <= t.limit && newsz > t.limit then begin + t.oversize <- t.oversize + 1; + for _i = 0 to over_limit do test_shrink_bucket t done; + end; + if t.oversize > Array.length t.table / over_limit then resize t; + end else if check bucket i then begin + loop (i + 1) + end else begin + setter bucket i d; + hashes.(i) <- h; + end; + in + loop 0 + + + let add t d = + let h = H.hash d in + add_aux t set (Some d) h (get_index t h) + + + let find_or t d ifnotfound = + let h = H.hash d in + let index = get_index t h in + let bucket = t.table.(index) in + let hashes = t.hashes.(index) in + let sz = length bucket in + let rec loop i = + if i >= sz then ifnotfound h index + else if h = hashes.(i) then begin + match get bucket i with + | Some v when H.equal v d -> v + | _ -> loop (i + 1) + end else loop (i + 1) + in + loop 0 + + + let merge t d = + find_or t d (fun h index -> add_aux t set (Some d) h index; d) + + + let find t d = find_or t d (fun h index -> raise Not_found) + + let find_shadow t d iffound ifnotfound = + let h = H.hash d in + let index = get_index t h in + let bucket = t.table.(index) in + let hashes = t.hashes.(index) in + let sz = length bucket in + let rec loop i = + if i >= sz then ifnotfound + else if h = hashes.(i) then begin + match get bucket i with + | Some v when H.equal v d -> iffound bucket i + | _ -> loop (i + 1) + end else loop (i + 1) + in + loop 0 + + + let remove t d = find_shadow t d (fun w i -> set w i None) () + + let mem t d = find_shadow t d (fun w i -> true) false + + let find_all t d = + let h = H.hash d in + let index = get_index t h in + let bucket = t.table.(index) in + let hashes = t.hashes.(index) in + let sz = length bucket in + let rec loop i accu = + if i >= sz then accu + else if h = hashes.(i) then begin + match get bucket i with + | Some v when H.equal v d + -> loop (i + 1) (v :: accu) + | _ -> loop (i + 1) accu + end else loop (i + 1) accu + in + loop 0 [] + + + let stats t = + let len = Array.length t.table in + let lens = Array.map length t.table in + Array.sort compare lens; + let totlen = Array.fold_left ( + ) 0 lens in + (len, count t, totlen, lens.(0), lens.(len/2), lens.(len-1)) + + +end
View it on GitLab: https://gitlab.com/monnier/typer/commit/d81d6755b8b7d6bc42b4ecd5ce7da32898c1...
Afficher les réponses par date