diff --git a/bootstrap/bin/hocc/workq.ml b/bootstrap/bin/hocc/workq.ml index cb2119940..146b7b097 100644 --- a/bootstrap/bin/hocc/workq.ml +++ b/bootstrap/bin/hocc/workq.ml @@ -2,23 +2,14 @@ open Basis open! Basis.Rudiments type ('a, 'cmp) t = { - cmper: ('a, 'cmp) Cmper.t; - deq: 'a Deq.t; + q: (i64, 'a, I64.cmper_witness) Ordmap.t; set: ('a, 'cmp) Set.t; } type ('a, 'cmp) cmper = (module Cmper.SMono with type t = 'a and type cmper_witness = 'cmp) -(* Extract cmper from first-class module compatible with Cmper.SMono. *) -let m_cmper (type k cmp) ((module M) : (k, cmp) cmper) = - M.cmper - -let pp {cmper; deq; _} = - Deq.pp cmper.pp deq - let empty m = { - cmper=m_cmper m; - deq=Deq.empty; + q=Ordmap.empty (module I64); set=Set.empty m; } @@ -28,29 +19,39 @@ let length {set; _} = let is_empty {set; _} = Set.is_empty set -let push elm {cmper; deq; set} = +let push elm {q; set} = assert (not (Set.mem elm set)); + let k = match Ordmap.length q with + | 0L -> I64.zero + | _ -> begin + let kmin, _elm = Ordmap.nth 0L q in + I64.pred kmin + end + in { - cmper; - deq=Deq.push elm deq; + q=Ordmap.insert_hlt ~k ~v:elm q; set=Set.insert elm set; } -let push_back elm {cmper; deq; set} = +let push_back elm {q; set} = assert (not (Set.mem elm set)); + let k = match Ordmap.length q with + | 0L -> I64.zero + | l -> begin + let kmax, _elm = Ordmap.nth (pred l) q in + I64.succ kmax + end + in { - cmper; - deq=Deq.push_back elm deq; + q=Ordmap.insert_hlt ~k ~v:elm q; set=Set.insert elm set; } -let pop {cmper; deq; set} = - let elm, deq' = Deq.pop deq in +let pop {q; set} = + let k, elm = Ordmap.nth 0L q in + let q' = Ordmap.remove_hlt k q in let set' = Set.remove elm set in - elm, {cmper; deq=deq'; set=set'} + elm, {q=q'; set=set'} let mem elm {set; _} = Set.mem elm set - -let set {set; _} = - set diff --git a/bootstrap/bin/hocc/workq.mli b/bootstrap/bin/hocc/workq.mli index 280c325b8..4f4620097 100644 --- a/bootstrap/bin/hocc/workq.mli +++ b/bootstrap/bin/hocc/workq.mli @@ -13,9 +13,6 @@ type ('a, 'cmp) t type ('a, 'cmp) cmper = (module Cmper.SMono with type t = 'a and type cmper_witness = 'cmp) -val pp: ('a, 'cmp) t -> (module Fmt.Formatter) -> (module Fmt.Formatter) -(** [pp t formatter] applies a formatted representation of [t] to the [formatter]. *) - val empty: ('a, 'cmp) cmper -> ('a, 'cmp) t (** [empty cmper] returns an empty work queue. *) @@ -29,7 +26,7 @@ val push: 'a -> ('a, 'cmp) t -> ('a, 'cmp) t (** [push a t] prepends [a]. [a] must not be present in [t] prior to [push]. *) val push_back: 'a -> ('a, 'cmp) t -> ('a, 'cmp) t -(** [push a t] appends [a]. [a] must not be present in [t] prior to [push_back]. *) +(** [push_back a t] appends [a]. [a] must not be present in [t] prior to [push_back]. *) val pop: ('a, 'cmp) t -> 'a * ('a, 'cmp) t (** [pop t] removes the front element from [t] and returns the element along with the depleted [t]. @@ -37,6 +34,3 @@ val pop: ('a, 'cmp) t -> 'a * ('a, 'cmp) t val mem: 'a -> ('a, 'cmp) t -> bool (** [mem a t] returns true iff [a] is present in [t]. *) - -val set: ('a, 'cmp) t -> ('a, 'cmp) Set.t -(** [set t] returns the set of elements in [t]. *)