Commits

Yit Phang Khoo  committed fd8102a

Major re-organization: rename LazySABidi to Adapton, and divide the remaining modules into Adapton{Internal,Util,Zoo}.

  • Participants
  • Parent commits 14640d0

Comments (0)

Files changed (62)

File Applications/Adaptime/Adaptime/behavior.ml

 
-open Adapton.Signatures
+open AdaptonUtil.Signatures
 open Time
-module T = Adapton.Types
+module T = AdaptonUtil.Types
 
 module type Behavior = sig
 	type 'a behavior

File Applications/Adaptime/Adaptime/time.ml

 let max_time (l : time list) : time =
 	List.fold_left max min_float l
 
-module TimeType (M : Adapton.Signatures.SAType) = M.Make( Adapton.Types.Float)
+module TimeType (M : AdaptonUtil.Signatures.SAType) = M.Make( AdaptonUtil.Types.Float)
 

File Applications/As2/As2/Ast.ml

 
 module type S = sig
-  module A : Adapton.PolySA.S
+  module A : AdaptonUtil.PolySA.S
 
   type col = int
   type row = int
   end
 end
 
-module Make (SA : Adapton.Signatures.SAType) : S with module A = Adapton.PolySA.Make (SA) = struct
-  module A = Adapton.PolySA.Make (SA)
+module Make (SA : AdaptonUtil.Signatures.SAType) : S with module A = AdaptonUtil.PolySA.Make (SA) = struct
+  module A = AdaptonUtil.PolySA.Make (SA)
 
   type col = int
   type row = int

File Applications/As2/As2/Main.ml

-module Make (SA : Adapton.Signatures.SAType) = struct
+module Make (SA : AdaptonUtil.Signatures.SAType) = struct
   module Ast = Ast.Make (SA)
   module Parser = Parser.Make (Ast)
   module Interp = Interp.Make (Ast)
       ast
 
   let measure f =
-    let module S = Adapton.Statistics in
+    let module S = AdaptonUtil.Statistics in
     let x, m = S.measure f
     in
     begin Printf.printf "time=%f, heap=%d, stack=%d, upd=%d, eval=%d, dirty=%d, clean=%d\n"
   let test test_flags n cur =
     let sht_to_demand = n in
     let num_changes = ! Global.num_changes in
-    let module S = Adapton.Statistics in
+    let module S = AdaptonUtil.Statistics in
     let cmd =
       match test_flags with
         | `No_switch ->
 end
 
 let as2_list = List.map begin fun ( name, sa ) ->
-    ( name, (module Make ((val sa : Adapton.Signatures.SAType)) : S) )
-end Adapton.All.sa_list
+    ( name, (module Make ((val sa : AdaptonUtil.Signatures.SAType)) : S) )
+end AdaptonZoo.All.sa_list
 
 let run () =
   let as2 = ref (snd (List.hd as2_list)) in

File Benchmarks/BenchmarkAdapton/runbenchmarkadapton.ml

-open Adapton.Statistics
 
-let list_filter_task (type a) (module L : Adapton.Signatures.SAListType.S with type t = a and type data = float) =
+open AdaptonUtil.Statistics
+
+let list_filter_task (type a) (module L : AdaptonUtil.Signatures.SAListType.S with type t = a and type data = float) =
     L.memo_filter (fun x -> log (1. +. x) < log 1.5)
 
-let list_map_task (type a) (module L : Adapton.Signatures.SAListType.S with type t = a and type data = float) =
+let list_map_task (type a) (module L : AdaptonUtil.Signatures.SAListType.S with type t = a and type data = float) =
     L.memo_map (module L) (fun x -> log (1. +. x) +. log 1.5)
 
-let list_tfold_min_task (type a) (type b) (module L : Adapton.Signatures.SAListType.S with type t = a and type SAData.t = b and type data = float) =
+let list_tfold_min_task (type a) (type b) (module L : AdaptonUtil.Signatures.SAListType.S with type t = a and type SAData.t = b and type data = float) =
     L.memo_tfold min
 
-let list_tfold_sum_task (type a) (type b) (module L : Adapton.Signatures.SAListType.S with type t = a and type SAData.t = b and type data = float) =
+let list_tfold_sum_task (type a) (type b) (module L : AdaptonUtil.Signatures.SAListType.S with type t = a and type SAData.t = b and type data = float) =
     L.memo_tfold (+.)
 
-let list_quicksort_task (type a) (module L : Adapton.Signatures.SAListType.S with type t = a and type data = float) =
+let list_quicksort_task (type a) (module L : AdaptonUtil.Signatures.SAListType.S with type t = a and type data = float) =
     L.memo_quicksort Pervasives.compare
 
-let list_mergesort_task (type a) (module L : Adapton.Signatures.SAListType.S with type t = a and type data = float) =
+let list_mergesort_task (type a) (module L : AdaptonUtil.Signatures.SAListType.S with type t = a and type data = float) =
     L.memo_mergesort Pervasives.compare
 
 let list_updown1_task
-        (type a) (module L : Adapton.Signatures.SAListType.S with type t = a and type data = float)
-        (type b) (module B : Adapton.Signatures.SAType.S with type t = b and type data = bool)
+        (type a) (module L : AdaptonUtil.Signatures.SAListType.S with type t = a and type data = float)
+        (type b) (module B : AdaptonUtil.Signatures.SAType.S with type t = b and type data = bool)
         xs b =
     let up = L.memo_quicksort Pervasives.compare in
     let down = L.memo_quicksort (fun x y -> -(Pervasives.compare x y)) in
     L.thunk (fun () -> L.force (if B.force b then up xs else down xs))
 
 let list_updown2_task
-        (type a) (module L : Adapton.Signatures.SAListType.S with type t = a and type data = float)
-        (type b) (module B : Adapton.Signatures.SAType.S with type t = b and type data = bool)
+        (type a) (module L : AdaptonUtil.Signatures.SAListType.S with type t = a and type data = float)
+        (type b) (module B : AdaptonUtil.Signatures.SAType.S with type t = b and type data = bool)
         xs b =
     let up = L.memo_quicksort Pervasives.compare xs in
     let down = L.memo_quicksort (fun x y -> -(Pervasives.compare x y)) xs in
     ( "exptree", `ExpTree );
 ]
 
-let opt_sa = ref (fst (List.hd Adapton.All.sa_list))
+let opt_sa = ref (fst (List.hd AdaptonZoo.All.sa_list))
 let opt_task = ref "filter"
 let opt_input_size = ref 1
 let opt_repeat_count = ref 1
             (fst task) (match snd task with `One _ -> "one" | `List _ -> "list" | `Flip _ -> "flip" | `ExpTree -> "exptree")
     in
     Printf.printf "{ \"modules\": [ %a ], \"tasks\": [ %a ] }\n%!"
-        (list_printer (fun ff -> Printf.fprintf ff "%S")) (fst (List.split Adapton.All.sa_list))
+        (list_printer (fun ff -> Printf.fprintf ff "%S")) (fst (List.split AdaptonZoo.All.sa_list))
         (list_printer task_printer) tasks;
     exit 0
 
-let exptree (module SA : Adapton.Signatures.SAType) rng =
+let exptree (module SA : AdaptonUtil.Signatures.SAType) rng =
     if !opt_input_size < 4 then begin
         Printf.eprintf "Task %s only supports -I n where n >= 4\n%!" !opt_task;
         exit 1
         Printf.eprintf "Task %s only supports -T 1\n%!" !opt_task;
         exit 1
     end;
-    let module F = SA.Make (Adapton.Types.Float) in
+    let module F = SA.Make (AdaptonUtil.Types.Float) in
     let module E = struct
         type e = e' SA.thunk
         and e' = Num of float | Op of op * e * e
 let _ =
     Arg.parse (Arg.align [
         ( "-c", Arg.Unit show_config, " output available configuration" );
-        ( "-m", Arg.Symbol ( (fst (List.split Adapton.All.sa_list)), (fun s -> opt_sa := s) ), "list module" );
+        ( "-m", Arg.Symbol ( (fst (List.split AdaptonZoo.All.sa_list)), (fun s -> opt_sa := s) ), "list module" );
         ( "-t", Arg.Symbol ( (fst (List.split tasks)), (fun s -> opt_task := s) ), "list task" );
         ( "-I", Arg.Set_int opt_input_size, "size input size" );
         ( "-R", Arg.Set_int opt_repeat_count, "count repeat count" );
 
     let rng = Random.State.make [| !opt_random_seed |] in
     Random.init (Random.State.bits rng);
-    let module SA = (val (List.assoc !opt_sa Adapton.All.sa_list)) in
+    let module SA = (val (List.assoc !opt_sa AdaptonZoo.All.sa_list)) in
     begin match List.assoc !opt_task tasks with
         | `ExpTree -> exptree (module SA) rng
         | _ -> ()
     end;
-    let module SABool = SA.Make (Adapton.Types.Bool) in
-    let module SAList = Adapton.SAList.Make (SA) in
-    let module SAFloatList = SAList.Make (Adapton.Types.Float) in
+    let module SABool = SA.Make (AdaptonUtil.Types.Bool) in
+    let module SAList = AdaptonUtil.SAList.Make (SA) in
+    let module SAFloatList = SAList.Make (AdaptonUtil.Types.Float) in
     SA.tweak_gc ();
     Gc.compact ();
     let task = match List.assoc !opt_task tasks with
 	hg id -nibtB 2>/dev/null || true
 	hg qselect 2>/dev/null || true
 
+exhaustive : all $(addprefix ocamlbuild//,runadapton.top runtestadapton.d.byte runbenchmarkadapton.native adaptimetest.native)
+
 include Makefile.rules
         % make repl
                 OCaml version 4.00.1
 
-        # module IntList = Adapton.Default.SAList.Make (Adapton.Types.Int);;
+        # module IntList = Adapton.SAList.Make (AdaptonUtil.Types.Int);;
         # let xs = IntList.of_list [1;2;3];;
         # let filter_gt_1 = IntList.memo_filter (fun x -> x > 1);;
         # let map_succ = IntList.memo_map (module IntList) succ;;

File Source/Adapton.ml

+(** Adapton self-adjusting values, alternative APIs, and applications. *)
+
+(** Adapton with a functor-based API. *)
+include AdaptonZoo.Adapton
+
+(** Adapton with a polymorphic API. *)
+module PolySA = AdaptonUtil.PolySA.Make (AdaptonZoo.Adapton)
+
+(** Adapton with a basic polymorphic API. *)
+module BasicSA = AdaptonUtil.BasicSA.Make (AdaptonZoo.Adapton)
+
+(** Adapton self-adjusting lists. *)
+module SAList = AdaptonUtil.SAList.Make (AdaptonZoo.Adapton)

File Source/Adapton.mllib

 Adapton
+AdaptonInternal
+AdaptonUtil
+AdaptonZoo

File Source/Adapton.mlpack

-Adapton/All
-Adapton/BasicSA
-Adapton/Default
-Adapton/EagerSATotalOrder
-Adapton/Exceptions
-Adapton/LazySABidi
-Adapton/LazySparseArray
-Adapton/MemoN
-Adapton/NonSAEager
-Adapton/NonSALazy
-Adapton/PolySA
-Adapton/PrioritySet
-Adapton/SAArrayMappedTrie
-Adapton/SAList
-Adapton/Signatures
-Adapton/Statistics
-Adapton/TotalOrder
-Adapton/Types
-Adapton/WeakDyn
-Adapton/WeakSet

File Source/Adapton/All.ml

-(** Lists of all modules for self-adjusting values and applications. *)
-
-(** List of all names and modules for self-adjusting values. *)
-let sa_list = [
-    ( "LazySABidi", (module LazySABidi : Signatures.SAType) );
-    ( "EagerSATotalOrder", (module EagerSATotalOrder : Signatures.SAType) );
-    ( "NonSAEager", (module NonSAEager : Signatures.SAType) );
-    ( "NonSALazy", (module NonSALazy : Signatures.SAType) );
-]
-
-(** List of all names and modules for self-adjusting lists. *)
-let salist_list = List.map begin fun ( name, sa ) ->
-    ( "SAList (" ^ name ^ ")", (module SAList.Make ((val sa : Signatures.SAType)) : Signatures.SAListType)  )
-end sa_list
-
-(** List of all names and modules for self-adjusting array mapped trie. *)
-let saamt_list = List.map begin fun ( name, sa ) ->
-    ( "SAArrayMappedTrie (" ^ name ^ ")", (module SAArrayMappedTrie.Make ((val sa : Signatures.SAType)) : Signatures.SAArrayMappedTrieType)  )
-end sa_list

File Source/Adapton/BasicSA.ml

-(** Functor that provides a basic polymorphic API for a self-adjusting module.
-
-    Instead of providing ['a thunk], this provides two types: ['a aref], which are input thunks that can only hold
-    values but is updateable by the outer program, and ['a athunk], which can hold computations, but cannot be updated
-    by the outer program.
-
-    These should only be used with [int], ['a aref] or ['a athunk], due to the use of conservative hash as well as
-    equality functions internally.
-*)
-
-module Make (M : Signatures.SAType) : sig
-    type 'a aref
-    val aref : 'a -> 'a aref
-    val get : 'a aref -> 'a
-    val set : 'a aref -> 'a -> unit
-
-    type 'a athunk
-    val force : 'a athunk -> 'a
-    val thunk : (unit -> 'a) -> 'a athunk
-    val memo : ('fn -> 'arg -> 'a) -> ('arg -> 'a athunk as 'fn)
-end = struct
-    module P = PolySA.Make (M)
-
-    type 'a aref = 'a P.thunk
-    let aref x = P.const x
-    let get m = P.force m
-    let set m x = P.update_const m x
-
-    type 'a athunk = 'a P.thunk
-    let force m = P.force m
-    let thunk f = P.thunk f
-    let memo f = P.memo f
-end

File Source/Adapton/Default.ml

-(** Default modules for self-adjusting values and applications. *)
-
-(** Default module for self-adjusting values providing a functorized API. *)
-module SA = LazySABidi
-
-(** Default module for self-adjusting lists. *)
-module SAList = SAList.Make (SA)
-
-(** Default module for self-adjusting values providing a polymorphic API. *)
-module PolySA = PolySA.Make (SA)
-
-(** Default module for self-adjusting values providing a basic polymorphic API. *)
-module BasicSA = BasicSA.Make (SA)

File Source/Adapton/EagerSATotalOrder.ml

-(** Eager variant of self-adjusting values based on a total-order maintenance data structure.
-
-    Implementation based on:
-        Umut Acar, Guy Blelloch, Matthias Blume, Robert Harper, and Kanat Tangwongsan. "A Library for Self-Adjusting
-        Computation". Electron. Notes Theor. Comput. Sci. 148, 2 (March 2006), 127-154.
-        http://dx.doi.org/10.1016/j.entcs.2005.11.043
-    supporting memoization and change propagation, but not adaptive memoization.
- *)
-
-(** Types and operations common to eager self-adjusting values containing any type. *)
-module T = struct
-    (** Abstract type identifying this module for self-adjusting values. *)
-    type sa
-
-    (** Eager self-adjusting values containing ['a]. *)
-    type 'a thunk = { (* 3 + 16 = 19 words *)
-        id : int;
-        mutable value : 'a;
-        meta : meta;
-    }
-    (**/**) (* auxiliary types *)
-    and meta = { (* 5 + 5 + 5 = 15 words (not including closures of evaluate and unmemo as well as WeakDyn.t) *)
-        mutable evaluate : unit -> unit;
-        mutable unmemo : unit -> unit;
-        mutable start_timestamp : TotalOrder.t; (* for const thunks, {start,end}_timestamp == TotalOrder.null and evaluate == nop *)
-        mutable end_timestamp : TotalOrder.t; (* while evaluating non-const thunk, end_timestamp == TotalOrder.null *)
-        dependents : meta WeakDyn.t;
-        (* dependents doesn't have to be a set since it is cleared and dependents are immediately re-evaluated and re-added if updated;
-            also, start_timestamp invalidators should provide strong references to dependencies to prevent the GC from breaking the dependents graph *)
-    }
-    (**/**)
-
-
-    (** This module implements self-adjusting values. *)
-    let is_self_adjusting = true
-
-    (** This module implements eager values. *)
-    let is_lazy = false
-
-
-    (**/**) (* internal state and helper functions *)
-
-    (* use a priority set because, although the size is usually quite small, duplicate insertions occur frequently *)
-    module PriorityQueue = PrioritySet.Make (struct
-        type t = meta
-        let compare meta meta' = TotalOrder.compare meta.start_timestamp meta'.start_timestamp
-    end)
-
-    let eager_id_counter = Types.Counter.make 0
-    let eager_stack = ref []
-    let eager_queue = PriorityQueue.create ()
-    let eager_start = TotalOrder.create ()
-    let eager_now = ref eager_start
-    let eager_finger = ref eager_start
-
-    let add_timestamp () =
-        let timestamp = TotalOrder.add_next !eager_now in
-        eager_now := timestamp;
-        timestamp
-
-    let unqueue meta =
-        if PriorityQueue.remove eager_queue meta then
-            incr Statistics.Counts.clean
-
-    let dequeue () = PriorityQueue.pop eager_queue
-
-    let enqueue_dependents dependents =
-        ignore begin WeakDyn.fold begin fun d () ->
-            if TotalOrder.is_valid d.start_timestamp then
-                if PriorityQueue.add eager_queue d then
-                    incr Statistics.Counts.dirty
-        end dependents () end;
-        WeakDyn.clear dependents
-    (**/**)
-
-
-    (** Return the id of a self-adjusting value. *)
-    let id m = m.id
-
-    (** Compute the hash value of a self-adjusting value. *)
-    let hash seed m = Hashtbl.seeded_hash seed m.id
-
-    (** Compute whether two self-adjusting values are equal. *)
-    let equal = (==)
-
-    (** Recompute self-adjusting values if necessary. *)
-    let refresh () =
-        let last_now = !eager_now in
-        try
-            let rec refresh () =
-                let meta = dequeue () in
-                eager_now := meta.start_timestamp;
-                eager_finger := meta.end_timestamp;
-                meta.evaluate ();
-                TotalOrder.splice !eager_now meta.end_timestamp;
-                refresh ()
-            in
-            refresh ()
-        with PriorityQueue.Empty ->
-            eager_now := last_now;
-            eager_finger := eager_start
-
-    (** Return the value contained by a self-adjusting value, computing it if necessary. *)
-    let force m =
-        (* add dependency to caller *)
-        begin match !eager_stack with
-            | dependent::_ -> WeakDyn.add m.meta.dependents dependent
-            | [] -> ()
-        end;
-        m.value
-end
-include T
-
-
-(** Functor to make constructors and updaters for eager self-adjusting values of a specific type. *)
-module Make (R : Hashtbl.SeededHashedType)
-        : Signatures.SAType.S with type sa = sa and type 'a thunk = 'a thunk and type data = R.t and type t = R.t thunk = struct
-    include T
-
-    (** Value contained by eager self-adjusting values for a specific type. *)
-    type data = R.t
-
-    (** Eager self-adjusting values for a specific type. *)
-    type t = R.t thunk
-
-    (** Module representing type [data]. *)
-    module Data = R
-
-    (**/**) (* helper functions *)
-    let nop () = ()
-    let invalidator meta ts =
-        (* help GC mark phase by cutting the object graph *)
-        (* no need to call unmemo since the memo entry will be replaced when it sees start_timestamp is invalid;
-            also, no need to replace {start,end}_timestamp with null since they are already cut by TotalOrder during invalidation *)
-        meta.unmemo <- nop;
-        meta.evaluate <- nop;
-        unqueue meta;
-        WeakDyn.clear meta.dependents
-    let update m x = if not (R.equal m.value x) then begin
-        m.value <- x;
-        enqueue_dependents m.meta.dependents
-    end
-    (**/**)
-
-    (** Create an eager self-adjusting value from a constant value. *)
-    let const x =
-        let m = {
-            id=Types.Counter.next eager_id_counter;
-            value=x;
-            meta={
-                evaluate=nop;
-                unmemo=nop;
-                start_timestamp=TotalOrder.null;
-                end_timestamp=TotalOrder.null;
-                dependents=WeakDyn.create 0;
-            };
-        } in
-        m
-
-    (** Update an eager self-adjusting value with a constant value. *)
-    let update_const m x =
-        incr Statistics.Counts.update;
-        if m.meta.start_timestamp != TotalOrder.null then begin
-            (* no need to call unmemo since the memo entry will be replaced when it sees start_timestamp is invalid *)
-            m.meta.unmemo <- nop;
-            m.meta.evaluate <- nop;
-            unqueue m.meta;
-            TotalOrder.reset_invalidator m.meta.start_timestamp;
-            TotalOrder.splice ~inclusive:true m.meta.start_timestamp m.meta.end_timestamp;
-            m.meta.start_timestamp <- TotalOrder.null;
-            m.meta.end_timestamp <- TotalOrder.null
-        end;
-        update m x
-
-    (**/**) (* helper function to evaluate a thunk *)
-    let evaluate_meta meta f =
-        incr Statistics.Counts.evaluate;
-        eager_stack := meta::!eager_stack;
-        let value = try
-            f ()
-        with exn ->
-            eager_stack := List.tl !eager_stack;
-            raise exn
-        in
-        eager_stack := List.tl !eager_stack;
-        value
-
-    let make_evaluate m f = fun () -> update m (evaluate_meta m.meta f)
-    (**/**)
-
-    (** Create an eager self-adjusting value from a thunk. *)
-    let thunk f =
-        let meta = {
-            evaluate=nop;
-            unmemo=nop;
-            start_timestamp=add_timestamp ();
-            end_timestamp=TotalOrder.null;
-            dependents=WeakDyn.create 0;
-        } in
-        let m = { id=Types.Counter.next eager_id_counter; value=evaluate_meta meta f; meta } in
-        meta.end_timestamp <- add_timestamp ();
-        TotalOrder.set_invalidator meta.start_timestamp (invalidator meta);
-        meta.evaluate <- make_evaluate m f;
-        m
-
-    (** Update an eager self-adjusting value with a thunk. *)
-    let update_thunk m f =
-        incr Statistics.Counts.update;
-        if m.meta.start_timestamp != TotalOrder.null then begin
-            m.meta.unmemo ();
-            m.meta.unmemo <- nop;
-            m.meta.evaluate <- nop;
-            unqueue m.meta;
-            TotalOrder.reset_invalidator m.meta.start_timestamp;
-            TotalOrder.splice ~inclusive:true m.meta.start_timestamp m.meta.end_timestamp;
-            m.meta.end_timestamp <- TotalOrder.null
-        end;
-        m.meta.start_timestamp <- add_timestamp ();
-        let evaluate = make_evaluate m f in
-        evaluate ();
-        m.meta.end_timestamp <- add_timestamp ();
-        TotalOrder.set_invalidator m.meta.start_timestamp (invalidator m.meta);
-        m.meta.evaluate <- evaluate
-
-    (* create memoizing constructors *)
-    include MemoN.Make (struct
-        type data = R.t
-        type t = R.t thunk
-
-        (** Create memoizing constructor for an eager self-adjusting value. *)
-        let memo (type a) (module A : Hashtbl.SeededHashedType with type t = a) f =
-            let module Binding = struct
-                type t = { key : A.t; mutable value : R.t thunk option }
-                let seed = Random.bits ()
-                let hash a = A.hash seed a.key
-                let equal a a' = A.equal a.key a'.key
-            end in
-            let module Memotable = Weak.Make (Binding) in
-            let memotable = Memotable.create 0 in
-
-            (* memoizing constructor *)
-            let rec memo x =
-                let binding = Memotable.merge memotable Binding.({ key=x; value=None }) in
-                match binding.Binding.value with
-                    | Some m when TotalOrder.is_valid m.meta.start_timestamp
-                            && TotalOrder.compare m.meta.start_timestamp !eager_now > 0
-                            && TotalOrder.compare m.meta.end_timestamp !eager_finger < 0 ->
-                        TotalOrder.splice !eager_now m.meta.start_timestamp;
-                        eager_now := m.meta.end_timestamp;
-                        m
-                    | _ ->
-                        (* note that m.meta.unmemo indirectly holds a reference to binding (via unmemo's closure);
-                            this prevents the GC from collecting binding from memotable until m itself is collected *)
-                        let m = thunk (fun () -> f memo x) in
-                        m.meta.unmemo <- (fun () -> Memotable.remove memotable binding);
-                        binding.Binding.value <- Some m;
-                        m
-            in
-
-            memo
-    end)
-end
-
-(** Tweak GC for this module. *)
-let tweak_gc () =
-    let open Gc in
-    let control = get () in
-    set { control with
-        minor_heap_size = max control.minor_heap_size (2 * 1024 * 1024);
-        major_heap_increment = max control.minor_heap_size (4 * 1024 * 1024);
-    }

File Source/Adapton/Exceptions.ml

-(** Exceptions raised by {i Adapton}. *)
-
-(** Operation unsupported on non-self-adjusting values. *)
-exception NonSelfAdjustingValue

File Source/Adapton/LazySABidi.ml

-(** Lazy variant of self-adjusting values based on a push-pull dependency graph. *)
-
-(** Types and operations common to lazy self-adjusting values containing any type. *)
-module T = struct
-    (** Abstract type identifying this module for self-adjusting values. *)
-    type sa
-
-    module rec TT : sig
-        (** Lazy self-adjusting values containing ['a]. *)
-        type 'a thunk = { (* 2 + 2 + 7 = 11 words (not including closures of receipt, repair, evaluate, and unmemo) *)
-            meta : meta;
-            mutable thunk : 'a thunk';
-        }
-        (**/**) (* auxiliary types *)
-        and meta = { (* 2 words (not including Dependents.t) *)
-            id : int;
-            dependents : Dependents.t;
-        }
-        and 'a thunk' =
-            | MemoValue of 'a repair * 'a * receipt * dependency list * 'a evaluate * unmemo (* 7 words *)
-            | Value of 'a repair * 'a * receipt * dependency list * 'a evaluate (* 6 words *)
-            | MemoThunk of 'a evaluate * unmemo (* 3  words *)
-            | Thunk of 'a evaluate (* 2 words *)
-            | Const of 'a * receipt (* 3 words *)
-        and unmemo = unit -> unit
-        and 'a evaluate = unit -> 'a * receipt
-        and receipt = { check : 'a . (bool -> 'a) -> 'a }
-        and 'a repair = { repair : 'b . ('a * receipt -> 'b) -> 'b }
-        and dependency = { (* 3 words (meta shared with 'a thunk) *)
-            mutable dirty : bool;
-            mutable receipt : receipt;
-            dependent : meta;
-        }
-        (**/**)
-    end = TT
-    (**/**) (* more auxiliary types *)
-    and Dependents : WeakSet.S with type data = TT.dependency = WeakSet.Make (struct
-        type t = TT.dependency
-        let hash d = Hashtbl.hash d.TT.dependent.TT.id
-        let equal d d' = d.TT.dependent == d'.TT.dependent
-    end)
-    include TT
-    (**/**)
-
-
-    (** This module implements self-adjusting values. *)
-    let is_self_adjusting = true
-
-    (** This module implements lazy values. *)
-    let is_lazy = true
-
-
-    (**/**) (* change-propagation state *)
-    let lazy_id_counter = Types.Counter.make 0
-    let lazy_stack = ref []
-    (**/**)
-
-
-    (** Return the id of a self-adjusting value. *)
-    let id m = m.meta.id
-
-    (** Compute the hash value of a self-adjusting value. *)
-    let hash seed m = Hashtbl.seeded_hash seed m.meta.id
-
-    (** Compute whether two self-adjusting values are equal. *)
-    let equal = (==)
-
-    (** Recompute self-adjusting values if necessary (unused by this module; a no-op). *)
-    let refresh () = ()
-
-    (** Return the value contained by a self-adjusting value, (re-)computing it if necessary. *)
-    let force m =
-        let value, receipt = match m.thunk with
-            | MemoValue ( repair, _, _, _, _, _ ) | Value ( repair, _, _, _, _ ) ->
-                repair.repair (fun result -> result)
-            | MemoThunk ( evaluate, _ ) | Thunk evaluate ->
-                evaluate ()
-            | Const ( value, receipt ) ->
-                ( value, receipt )
-        in
-        (* add dependency to caller *)
-        begin match !lazy_stack with
-            | ( dependent, dependencies )::_ ->
-                let dependency = Dependents.merge m.meta.dependents { dirty=false; receipt; dependent } in
-                (* an existing dependency may be reused *)
-                dependency.dirty <- false;
-                dependency.receipt <- receipt;
-                dependencies := dependency::!dependencies
-            | _ ->
-                ()
-        end;
-        value
-end
-include T
-
-
-(** Functor to make constructors for lazy self-adjusting values of a specific type. *)
-module Make (R : Hashtbl.SeededHashedType)
-        : Signatures.SAType.S with type sa = sa and type 'a thunk = 'a thunk and type data = R.t and type t = R.t thunk = struct
-    include T
-
-    (** Value contained by lazy self-adjusting values for a specific type. *)
-    type data = R.t
-
-    (** Lazy self-adjusting values for a specific type. *)
-    type t = R.t thunk
-
-    (** Module representing type [data]. *)
-    module Data = R
-
-    (**/**) (* helper function to make a new thunk meta *)
-    let make_meta () = { id=Types.Counter.next lazy_id_counter; dependents=Dependents.create 0 }
-    (**/**)
-
-    (**/**) (* helper function to unmemo a thunk *)
-    let unmemo m = match m.thunk with
-        | MemoValue ( _, _, _, _, _, unmemo ) | MemoThunk ( _, unmemo ) -> unmemo ()
-        | Value _  | Thunk _ | Const _ -> ()
-    (**/**)
-
-    (**/**) (* helper function to dirty a thunk *)
-    let dirty m =
-        unmemo m;
-        let rec dirty = function
-            | d::ds ->
-                dirty begin Dependents.fold begin fun d ds ->
-                    if d.dirty then
-                        ds
-                    else begin
-                        incr Statistics.Counts.dirty;
-                        d.dirty <- true;
-                        d.dependent.dependents::ds
-                    end
-                end d ds end
-            | [] ->
-                ()
-        in
-        dirty [ m.meta.dependents ]
-    (**/**)
-
-    (**/**) (* helper function to make a receipt check *)
-    let make_check m x k = match m.thunk with
-        | MemoValue ( repair, _, _, _, _, _ ) | Value ( repair, _, _, _, _ ) -> repair.repair (fun ( value, _ ) -> k (R.equal value x))
-        | MemoThunk _ | Thunk _ -> k false
-        | Const ( value, _ ) -> k (R.equal value x)
-    (**/**)
-
-    (** Create a lazy self-adjusting value from a constant value that does not depend on other lazy self-adjusting values. *)
-    let const x =
-        let rec check : 'a . (bool -> 'a) -> 'a = fun k -> make_check m x k
-        and m = { meta=make_meta (); thunk=Const ( x, { check } ) } in
-        m
-
-    (** Update a lazy self-adjusting value with a constant value that does not depend on other lazy self-adjusting values. *)
-    let update_const m x =
-        incr Statistics.Counts.update;
-        begin match m.thunk with
-            | MemoValue ( _, value, _, _, _, _ ) | Value ( _, value, _, _, _ ) | Const ( value, _ ) when not (R.equal value x) -> dirty m
-            | MemoValue _ | MemoThunk _ | Value _ | Thunk _ | Const _ -> unmemo m
-        end;
-        let check k = make_check m x k in
-        m.thunk <- Const ( x, { check } )
-
-    (**/**) (* helper function to evaluate a thunk *)
-    let evaluate_actual m f =
-        (* add self to call stack and evaluate *)
-        incr Statistics.Counts.evaluate;
-        let dependencies = ref [] in
-        lazy_stack := ( m.meta, dependencies )::!lazy_stack;
-        let value = try
-            f ()
-        with exn ->
-            lazy_stack := List.tl !lazy_stack;
-            raise exn
-        in
-        lazy_stack := List.tl !lazy_stack;
-        let dependencies = List.rev !dependencies in
-
-        (* repair/receipt performs a truncated inorder traversal of the dependency graph *)
-        let repair k = match m.thunk with
-            | MemoValue ( _, value, receipt, dependencies, evaluate, _ ) | Value ( _, value, receipt, dependencies, evaluate ) ->
-                let rec repair = function
-                    | d::ds ->
-                        if d.dirty then begin
-                            d.dirty <- false;
-                            d.receipt.check (fun c -> if c then (incr Statistics.Counts.clean; repair ds) else k (evaluate ()))
-                        end else
-                            repair ds
-                    | [] ->
-                        k ( value, receipt )
-                in
-                repair dependencies
-            | MemoThunk ( evaluate, _ ) | Thunk evaluate ->
-                k (evaluate ())
-            | Const ( value, receipt ) ->
-                k ( value, receipt )
-        in
-
-        let check k = make_check m value k in
-
-        ( { repair }, value, { check }, dependencies )
-    (**/**)
-
-    (**/**) (** helper function to make a function to evaluate a thunk *)
-    let make_evaluate m f =
-        let rec evaluate () =
-            let repair, value, receipt, dependencies = evaluate_actual m f in
-            m.thunk <- Value ( repair, value, receipt, dependencies, evaluate );
-            ( value, receipt )
-        in
-        evaluate
-    (**/**)
-
-    (** Create a lazy self-adjusting value from a thunk that may depend on other lazy self-adjusting values. *)
-    let thunk f =
-        let rec evaluate () = make_evaluate m f ()
-        and m = { meta=make_meta (); thunk=Thunk evaluate } in
-        m
-
-    (** Update a lazy self-adjusting value with a thunk that may depend on other lazy self-adjusting values. *)
-    let update_thunk m f =
-        incr Statistics.Counts.update;
-        dirty m;
-        let evaluate () = make_evaluate m f () in
-        m.thunk <- Thunk evaluate
-
-    (* create memoizing constructors *)
-    include MemoN.Make (struct
-        type data = R.t
-        type t = R.t thunk
-
-        (** Create memoizing constructor for a lazy self-adjusting value. *)
-        let memo (type a) (module A : Hashtbl.SeededHashedType with type t = a) f =
-            let module Memotable = Weak.Make (struct
-                type t = A.t * R.t thunk
-                let seed = Random.bits ()
-                let hash ( a, _ ) = A.hash seed a
-                let equal ( a, _ ) ( a', _ ) = A.equal a a'
-            end) in
-            let memotable = Memotable.create 0 in
-
-            (* memoizing constructor *)
-            let rec memo x =
-                (* note that m contains unmemo that indirectly holds a reference to binding (via unmemo's closure);
-                    this prevents the GC from collecting binding from memotable until m itself is collected (or unmemo is removed from m) *)
-                let rec binding = ( x, m )
-                and unmemo () = Memotable.remove memotable binding
-                and evaluate () =
-                    let repair, value, receipt, dependencies = evaluate_actual m (fun () -> f memo x) in
-                    m.thunk <- MemoValue ( repair, value, receipt, dependencies, evaluate, unmemo );
-                    ( value, receipt )
-                and m = { meta=make_meta (); thunk=MemoThunk ( evaluate, unmemo ) } in
-                snd (Memotable.merge memotable binding)
-            in
-            memo
-    end)
-end
-
-(** Tweak GC for this module. *)
-let tweak_gc () = ()

File Source/Adapton/LazySparseArray.ml

-(** Fixed-size lazy sparse arrays. *)
-
-module T : sig
-    type 'a t = private {
-        hash : int;
-        mutable thunk : int -> 'a option;
-        mutable initialized : int;
-        mutable nonnull : int;
-        mutable array : 'a array;
-    }
-    val size : int
-    val key_bits : int
-    val hash : int ->'a t -> int
-    val equal : 'a t -> 'a t -> bool
-    val make : (int -> 'a option) -> 'a t
-    val get : 'a t -> int -> 'a option
-end = struct
-    (** Type of lazy sparse arrays containing ['a]. *)
-    type 'a t = {
-        hash : int;
-        mutable thunk : int -> 'a option;
-        mutable initialized : int;
-        mutable nonnull : int;
-        mutable array : 'a array;
-    }
-
-    (** Size of lazy sparse arrays. *)
-    let size = if Sys.word_size == 32 then 16 else 32
-
-    (** Key-width in bits of lazy sparse arrays. *)
-    let key_bits = if size == 16 then 4 else 5
-
-    (**/**) (* helper functions/values *)
-    let popcount16 =
-        let map16 =
-            let map4 = [| 0; 1; 1; 2; 1; 2; 2; 3; 1; 2; 2; 3; 2; 3; 3; 4 |] in
-            Array.init 0x10000 begin fun x ->
-                map4.(x land 0xF) + map4.(x lsr 4 land 0xF) + map4.(x lsr 8 land 0xF) + map4.(x lsr 12 land 0xF)
-            end
-        in
-        fun x -> map16.(x)
-    let popcount32 x = popcount16 (x land 0xFFFF) + popcount16 (x lsr 16)
-    let popcount = if Sys.word_size == 32 then popcount16 else popcount32
-    let full_bitmask = 1 lsl size - 1
-    let null_thunk _ : 'a option = failwith "null thunk"
-    (**/**)
-
-    (** Create a new lazy sparse array. *)
-    let make thunk = {
-        hash = Hashtbl.hash thunk;
-        thunk;
-        initialized = 0;
-        nonnull = 0;
-        array = [||];
-    }
-
-    (** Compute the hash value of a lazy sparse array. *)
-    let hash seed xs = Hashtbl.seeded_hash seed xs.hash
-
-    (** Compute whether two lazy sparse arrays are equal. *)
-    let equal = (==)
-
-    (** Return the element [i] of a lazy sparse array. *)
-    let get xs k =
-        if k < 0 || k >= size then invalid_arg "index out of bounds";
-        let mask = 1 lsl k in
-        let slot = popcount (xs.nonnull land (mask - 1)) in
-        if xs.initialized land mask == 0 then begin
-            let value = match xs.thunk k with
-                | None ->
-                    None
-                | Some value as opt_value ->
-                    xs.nonnull <- xs.nonnull lor mask;
-                    xs.array <- Array.init (Array.length xs.array + 1) begin fun k ->
-                        if k < slot then
-                            xs.array.(k)
-                        else if k == slot then
-                            value
-                        else
-                            xs.array.(k - 1)
-                    end;
-                    opt_value
-            in
-            xs.initialized <- xs.initialized lor mask;
-            if xs.initialized == full_bitmask then
-                xs.thunk <- null_thunk;
-            value
-        end else if xs.nonnull land mask == 0 then
-            None
-        else
-            Some xs.array.(slot)
-end
-include T

File Source/Adapton/MemoN.ml

-(** Memoization helper module to create modules for self-adjusting values. *)
-
-(** Input module type of memoization functor {!MemoN.Make}. *)
-module type MemoNType = sig
-    type data
-    type t
-    val memo : (module Hashtbl.SeededHashedType with type t = 'a) -> (('a -> t as 'f) -> 'a -> data) -> 'f
-end
-
-(** Output module type of memoization functor {!MemoN.Make}. *)
-module type S = sig
-    type data
-    type t
-    val memo :
-        (module Hashtbl.SeededHashedType with type t = 'a)
-        -> (('a -> t as 'f) -> 'a -> data) -> 'f
-    val memo2 :
-        (module Hashtbl.SeededHashedType with type t = 'a)
-        -> (module Hashtbl.SeededHashedType with type t = 'b)
-        -> (('a -> 'b -> t as 'f) -> 'a -> 'b -> data) -> 'f
-    val memo3 :
-        (module Hashtbl.SeededHashedType with type t = 'a)
-        -> (module Hashtbl.SeededHashedType with type t = 'b)
-        -> (module Hashtbl.SeededHashedType with type t = 'c)
-        -> (('a -> 'b -> 'c -> t as 'f) -> 'a -> 'b -> 'c -> data) -> 'f
-    val memo4 :
-        (module Hashtbl.SeededHashedType with type t = 'a)
-        -> (module Hashtbl.SeededHashedType with type t = 'b)
-        -> (module Hashtbl.SeededHashedType with type t = 'c)
-        -> (module Hashtbl.SeededHashedType with type t = 'd)
-        -> (('a -> 'b -> 'c -> 'd -> t as 'f) -> 'a -> 'b -> 'c -> 'd -> data) -> 'f
-end
-
-(** Functor to make memoizing constructor of arity of 2 or greater from a memoizing constructor of arity 1. *)
-module Make (M : MemoNType) = struct
-    (** Create memoizing constructor of arity 1. *)
-    let memo = M.memo
-
-    (** Create memoizing constructor of arity 2. *)
-    let memo2
-            (type a) (module A : Hashtbl.SeededHashedType with type t = a)
-            (type b) (module B : Hashtbl.SeededHashedType with type t = b)
-            f =
-        let memo = M.memo (module Types.Tuple2 (A) (B)) (fun memo ( a, b ) -> f (fun a b -> memo ( a, b )) a b) in
-        fun a b -> memo ( a, b )
-
-    (** Create memoizing constructor of arity 3. *)
-    let memo3
-            (type a) (module A : Hashtbl.SeededHashedType with type t = a)
-            (type b) (module B : Hashtbl.SeededHashedType with type t = b)
-            (type c) (module C : Hashtbl.SeededHashedType with type t = c)
-            f =
-        let memo = M.memo (module Types.Tuple3 (A) (B) (C)) (fun memo ( a, b, c ) -> f (fun a b c -> memo ( a, b, c )) a b c) in
-        fun a b c -> memo ( a, b, c )
-
-    (** Create memoizing constructor of arity 4. *)
-    let memo4
-            (type a) (module A : Hashtbl.SeededHashedType with type t = a)
-            (type b) (module B : Hashtbl.SeededHashedType with type t = b)
-            (type c) (module C : Hashtbl.SeededHashedType with type t = c)
-            (type d) (module D : Hashtbl.SeededHashedType with type t = d)
-            f =
-        let memo = M.memo (module Types.Tuple4 (A) (B) (C) (D)) (fun memo ( a, b, c, d ) -> f (fun a b c d -> memo ( a, b, c, d )) a b c d) in
-        fun a b c d -> memo ( a, b, c, d )
-end

File Source/Adapton/NonSAEager.ml

-(** Eager variant of non-self-adjusting values. *)
-
-(** Types and operations common to eager non-self-adjusting values containing any type. *)
-module T = struct
-    (** Abstract type identifying this module for non-self-adjusting values. *)
-    type sa
-
-    (** Eager non-self-adjusting values containing ['a]. *)
-    type 'a thunk = {
-        id : int;
-        value : 'a;
-    }
-
-    (** This module implements non-self-adjusting values. *)
-    let is_self_adjusting = false
-
-    (** This module implements eager values. *)
-    let is_lazy = false
-
-    (**/**) (* internal state *)
-    let eager_id_counter = Types.Counter.make 0
-    (**/**)
-
-    (** Return the id of a non-self-adjusting value. *)
-    let id m = m.id
-
-    (** Compute the hash value of a non-self-adjusting value. *)
-    let hash seed m = Hashtbl.seeded_hash seed m.id
-
-    (** Compute whether two non-self-adjusting values are equal. *)
-    let equal = (==)
-
-    (** Recompute non-self-adjusting values if necessary (not supported by this module; raises {!NonSelfAdjustingValue}). *)
-    let refresh () = raise Exceptions.NonSelfAdjustingValue
-
-    (** Return the value contained by a non-self-adjusting value, computing it if necessary. *)
-    let force { value; _ } = value
-end
-include T
-
-
-(** Functor to make constructors for eager non-self-adjusting values of a specific type. *)
-module Make (R : Hashtbl.SeededHashedType)
-        : Signatures.SAType.S with type sa = sa and type 'a thunk = 'a thunk and type data = R.t and type t = R.t thunk = struct
-    include T
-
-    (** Value contained by eager non-self-adjusting values for a specific type. *)
-    type data = R.t
-
-    (** Eager non-self-adjusting values for a specific type. *)
-    type t = R.t thunk
-
-    (** Module representing type [data]. *)
-    module Data = R
-
-    (** Create an eager non-self-adjusting value from a constant value. *)
-    let const x = { id=Types.Counter.next eager_id_counter; value=x }
-
-    (** Update an eager non-self-adjusting value with a constant value (not supported by this module; raises {!NonSelfAdjustingValue}). *)
-    let update_const _ _ = raise Exceptions.NonSelfAdjustingValue
-
-    (** Create an eager non-self-adjusting value from a thunk. *)
-    let thunk f = incr Statistics.Counts.evaluate; { id=Types.Counter.next eager_id_counter; value=f () }
-
-    (** Update an eager non-self-adjusting value with a thunk (not supported by this module; raises {!NonSelfAdjustingValue}). *)
-    let update_thunk _ _ = raise Exceptions.NonSelfAdjustingValue
-
-    (* create memoizing constructors *)
-    include MemoN.Make (struct
-        type data = R.t
-        type t = R.t thunk
-
-        (** Create non-memoizing constructor for an eager non-self-adjusting value. *)
-        let memo (type a) (module A : Hashtbl.SeededHashedType with type t = a) f =
-            (* non-memoizing constructor *)
-            let rec memo x = incr Statistics.Counts.evaluate; { id=Types.Counter.next eager_id_counter; value=f memo x } in
-            memo
-    end)
-end
-
-(** Tweak GC for this module. *)
-let tweak_gc () = ()

File Source/Adapton/NonSALazy.ml

-(** Lazy variant of non-self-adjusting values. *)
-
-(** Types and operations common to lazy non-self-adjusting values containing any type. *)
-module T = struct
-    (** Abstract type identifying this module for non-self-adjusting values. *)
-    type sa
-
-    (** Lazy non-self-adjusting values containing ['a]. *)
-    type 'a thunk = {
-        id : int;
-        thunk : 'a Lazy.t;
-    }
-
-    (** This module implements non-self-adjusting values. *)
-    let is_self_adjusting = false
-
-    (** This module implements lazy values. *)
-    let is_lazy = true
-
-    (**/**) (* internal state *)
-    let lazy_id_counter = Types.Counter.make 0
-    (**/**)
-
-    (** Return the id of a non-self-adjusting value. *)
-    let id m = m.id
-
-    (** Compute the hash value of a non-self-adjusting value. *)
-    let hash seed m = Hashtbl.seeded_hash seed m.id
-
-    (** Compute whether two non-self-adjusting values are equal. *)
-    let equal = (==)
-
-    (** Recompute non-self-adjusting values if necessary (not supported by this module; raises {!NonSelfAdjustingValue}). *)
-    let refresh () = raise Exceptions.NonSelfAdjustingValue
-
-    (** Return the value contained by a non-self-adjusting value, computing it if necessary. *)
-    let force { thunk=lazy value; _ } = value
-end
-include T
-
-
-(** Functor to make constructors for lazy non-self-adjusting values of a specific type. *)
-module Make (R : Hashtbl.SeededHashedType)
-        : Signatures.SAType.S with type sa = sa and type 'a thunk = 'a thunk and type data = R.t and type t = R.t thunk = struct
-    include T
-
-    (** Value contained by lazy non-self-adjusting values for a specific type. *)
-    type data = R.t
-
-    (** Lazy non-self-adjusting values for a specific type. *)
-    type t = R.t thunk
-
-    (** Module representing type [data]. *)
-    module Data = R
-
-    (** Create a lazy non-self-adjusting value from a constant value. *)
-    let const x = { id=Types.Counter.next lazy_id_counter; thunk=lazy x }
-
-    (** Update a lazy non-self-adjusting value with a constant value (not supported by this module; raises {!NonSelfAdjustingValue}). *)
-    let update_const _ _ = raise Exceptions.NonSelfAdjustingValue
-
-    (** Create a lazy non-self-adjusting value from a thunk. *)
-    let thunk f = { id=Types.Counter.next lazy_id_counter; thunk=lazy (incr Statistics.Counts.evaluate; f ()) }
-
-    (** Update a lazy non-self-adjusting value with a thunk (not supported by this module; raises {!NonSelfAdjustingValue}). *)
-    let update_thunk _ _ = raise Exceptions.NonSelfAdjustingValue
-
-    (* create memoizing constructors *)
-    include MemoN.Make (struct
-        type data = R.t
-        type t = R.t thunk
-
-        (** Create non-memoizing constructor for a lazy non-self-adjusting value. *)
-        let memo (type a) (module A : Hashtbl.SeededHashedType with type t = a) f =
-            (* non-memoizing constructor *)
-            let rec memo x = { id=Types.Counter.next lazy_id_counter; thunk=lazy (incr Statistics.Counts.evaluate; f memo x) } in
-            memo
-    end)
-end
-
-(** Tweak GC for this module. *)
-let tweak_gc () = ()

File Source/Adapton/PolySA.ml

-(** Functor that provides a polymorphic API for a self-adjusting module.
-
-    Note that thunk constructors will provide conservative hash as well as equality functions by default (to compare
-    thunk values as well as memoization keys). These functions are too conservative for types other than [int] and
-    ['a thunk], so custom hash and equality functions should be provided for most types.
-*)
-
-module type S = sig
-    type 'a thunk
-    val is_self_adjusting : bool
-    val is_lazy : bool
-    val id : 'a thunk -> int
-    val hash : 'a thunk -> int
-    val equal : 'a thunk -> 'a thunk -> bool
-    val refresh : unit -> unit
-    val force : 'a thunk -> 'a
-    val const : ?hash:(int -> 'a -> int) -> ?equal:('a -> 'a -> bool) -> 'a -> 'a thunk
-    val update_const : 'a thunk -> 'a -> unit
-    val thunk : ?hash:(int -> 'a -> int) -> ?equal:('a -> 'a -> bool) -> (unit -> 'a) -> 'a thunk
-    val update_thunk : 'a thunk -> (unit -> 'a) -> unit
-    val memo :
-        ?inp_hash:(int -> 'inp -> int) -> ?inp_equal:('inp -> 'inp -> bool)
-        -> ?hash:(int -> 'a -> int) -> ?equal:('a -> 'a -> bool)
-        -> ('memo -> 'inp -> 'a) -> ('inp -> 'a thunk as 'memo)
-    val memo2 :
-        ?inp1_hash:(int -> 'inp1 -> int) -> ?inp1_equal:('inp1 -> 'inp1 -> bool)
-        -> ?inp2_hash:(int -> 'inp2 -> int) -> ?inp2_equal:('inp2 -> 'inp2 -> bool)
-        -> ?hash:(int -> 'a -> int) -> ?equal:('a -> 'a -> bool)
-        -> ('memo -> 'inp1 -> 'inp2 -> 'a) -> ('inp1 -> 'inp2 -> 'a thunk as 'memo)
-    val memo3 :
-        ?inp1_hash:(int -> 'inp1 -> int) -> ?inp1_equal:('inp1 -> 'inp1 -> bool)
-        -> ?inp2_hash:(int -> 'inp2 -> int) -> ?inp2_equal:('inp2 -> 'inp2 -> bool)
-        -> ?inp3_hash:(int -> 'inp3 -> int) -> ?inp3_equal:('inp3 -> 'inp3 -> bool)
-        -> ?hash:(int -> 'a -> int) -> ?equal:('a -> 'a -> bool)
-        -> ('memo -> 'inp1 -> 'inp2 -> 'inp3 -> 'a) -> ('inp1 -> 'inp2 -> 'inp3 -> 'a thunk as 'memo)
-    val memo4 :
-        ?inp1_hash:(int -> 'inp1 -> int) -> ?inp1_equal:('inp1 -> 'inp1 -> bool)
-        -> ?inp2_hash:(int -> 'inp2 -> int) -> ?inp2_equal:('inp2 -> 'inp2 -> bool)
-        -> ?inp3_hash:(int -> 'inp3 -> int) -> ?inp3_equal:('inp3 -> 'inp3 -> bool)
-        -> ?inp4_hash:(int -> 'inp4 -> int) -> ?inp4_equal:('inp4 -> 'inp4 -> bool)
-        -> ?hash:(int -> 'a -> int) -> ?equal:('a -> 'a -> bool)
-        -> ('memo -> 'inp1 -> 'inp2 -> 'inp3 -> 'inp4 -> 'a) -> ('inp1 -> 'inp2 -> 'inp3 -> 'inp4 -> 'a thunk as 'memo)
-    val tweak_gc : unit -> unit
-end
-
-module Make (M : Signatures.SAType) = struct
-    type 'a thunk = 'a M.thunk * (module Signatures.SAType.S with type sa = M.sa and type data = 'a and type t = 'a M.thunk)
-
-    let is_self_adjusting = M.is_self_adjusting
-
-    let is_lazy = M.is_lazy
-
-    let id (type a) (m, (module S) : a thunk) = S.id m
-
-    let hash m = Hashtbl.hash (id m)
-
-    let equal (type a) (m : a thunk) (m' : a thunk) = id m = id m'
-
-    let refresh = M.refresh
-
-    let force (type a) (m, (module S) : a thunk) = S.force m
-
-    let default_hash seed x =
-        (* the various thunk types are carefully laid out such that the following will hash the thunk ID only *)
-        Hashtbl.seeded_hash_param 1 100 seed x
-
-    let default_equal = (==)
-
-    let const (type a) ?(hash=default_hash) ?(equal=default_equal) : a -> a thunk =
-        let module S = M.Make (struct type t = a let hash = hash let equal = equal end) in
-        fun x -> (S.const x, (module S))
-
-    let update_const (type a) (m, (module S) : a thunk) x =
-        S.update_const m x
-
-    let thunk (type a) ?(hash=default_hash) ?(equal=default_equal) : (unit -> a) -> a thunk =
-        let module S = M.Make (struct type t = a let hash = hash let equal = equal end) in
-        fun f -> (S.thunk f, (module S))
-
-    let update_thunk (type a) (m, (module S) : a thunk) f =
-        S.update_thunk m f
-
-    let memo (type inp) (type a)
-                ?(inp_hash=default_hash) ?(inp_equal=default_equal)
-                ?(hash=default_hash) ?(equal=default_equal)
-            : ('memo -> inp -> a) -> (inp -> a thunk as 'memo) =
-        let module S = M.Make (struct type t = a let hash = hash let equal = equal end) in
-        fun f ->
-            let f memo = f (fun a -> (memo a, (module S) : a thunk)) in
-            let memo = S.memo (module struct type t = inp let hash = inp_hash let equal = inp_equal end) f in
-            fun a -> (memo a, (module S))
-
-    let memo2 (type inp1) (type inp2) (type a)
-                ?(inp1_hash=default_hash) ?(inp1_equal=default_equal)
-                ?(inp2_hash=default_hash) ?(inp2_equal=default_equal)
-                ?(hash=default_hash) ?(equal=default_equal)
-            : ('memo2 -> inp1 -> inp2 -> a) -> (inp1 -> inp2 -> a thunk as 'memo2) =
-        let module S = M.Make (struct type t = a let hash = hash let equal = equal end) in
-        fun f ->
-            let f memo2 = f (fun a b -> (memo2 a b, (module S) : a thunk)) in
-            let memo2 = S.memo2
-                (module struct type t = inp1 let hash = inp1_hash let equal = inp1_equal end)
-                (module struct type t = inp2 let hash = inp2_hash let equal = inp2_equal end)
-                f
-            in
-            fun a b -> (memo2 a b, (module S))
-
-    let memo3 (type inp1) (type inp2) (type inp3) (type a)
-                ?(inp1_hash=default_hash) ?(inp1_equal=default_equal)
-                ?(inp2_hash=default_hash) ?(inp2_equal=default_equal)
-                ?(inp3_hash=default_hash) ?(inp3_equal=default_equal)
-                ?(hash=default_hash) ?(equal=default_equal)
-            : ('memo3 -> inp1 -> inp2 -> inp3 -> a) -> (inp1 -> inp2 -> inp3 -> a thunk as 'memo3) =
-        let module S = M.Make (struct type t = a let hash = hash let equal = equal end) in
-        fun f ->
-            let f memo3 = f (fun a b c -> (memo3 a b c, (module S) : a thunk)) in
-            let memo3 = S.memo3
-                (module struct type t = inp1 let hash = inp1_hash let equal = inp1_equal end)
-                (module struct type t = inp2 let hash = inp2_hash let equal = inp2_equal end)
-                (module struct type t = inp3 let hash = inp3_hash let equal = inp3_equal end)
-                f
-            in
-            fun a b c -> (memo3 a b c, (module S))
-
-    let memo4 (type inp1) (type inp2) (type inp3) (type inp4) (type a)
-                ?(inp1_hash=default_hash) ?(inp1_equal=default_equal)
-                ?(inp2_hash=default_hash) ?(inp2_equal=default_equal)
-                ?(inp3_hash=default_hash) ?(inp3_equal=default_equal)
-                ?(inp4_hash=default_hash) ?(inp4_equal=default_equal)
-                ?(hash=default_hash) ?(equal=default_equal)
-            : ('memo4 -> inp1 -> inp2 -> inp3 -> inp4 -> a) -> (inp1 -> inp2 -> inp3 -> inp4 -> a thunk as 'memo4) =
-        let module S = M.Make (struct type t = a let hash = hash let equal = equal end) in
-        fun f ->
-            let f memo4 = f (fun a b c d -> (memo4 a b c d, (module S) : a thunk)) in
-            let memo4 = S.memo4
-                (module struct type t = inp1 let hash = inp1_hash let equal = inp1_equal end)
-                (module struct type t = inp2 let hash = inp2_hash let equal = inp2_equal end)
-                (module struct type t = inp3 let hash = inp3_hash let equal = inp3_equal end)
-                (module struct type t = inp4 let hash = inp4_hash let equal = inp4_equal end)
-                f
-            in
-            fun a b c d -> (memo4 a b c d, (module S))
-
-    let tweak_gc = M.tweak_gc
-end

File Source/Adapton/PrioritySet.ml

-(** Mutable priority set based on simple binary tree. *)
-
-module type S = sig
-    type data
-    type t
-    exception Empty
-    val create : unit -> t
-    val add : t -> data -> bool
-    val pop : t -> data
-    val remove : t -> data -> bool
-end
-
-module Make (O : Set.OrderedType) = struct
-    type data = O.t
-
-    type t = t' ref
-    and t' = Null | Node of data * t * t
-
-    exception Empty
-
-    let create () = ref Null
-
-    let rec add queue x = match !queue with
-        | Node ( value, left, right ) ->
-            let dir = O.compare x value in
-            if dir == 0 then
-                false
-            else if dir < 0 then
-                add left x
-            else
-                add right x
-        | Null ->
-            queue := Node ( x, ref Null, ref Null );
-            true
-
-    let rec pop queue = match !queue with
-        | Node ( value, ({ contents=Node _ } as left), _ ) ->
-            pop left
-        | Node ( value, { contents=Null }, right ) ->
-            queue := !right;
-            value
-        | Null ->
-            raise Empty
-
-    let rec remove queue x = match !queue with
-        | Node ( value, left, right ) ->
-            let dir = O.compare x value in
-            if dir == 0 then begin
-                queue := (try Node ( pop right, left, right ) with Empty -> !left);
-                true
-            end else if dir < 0 then
-                remove left x
-            else
-                remove right x
-        | Null ->
-            false
-end

File Source/Adapton/SAArrayMappedTrie.ml

-(** Self-adjusting array mapped tries. *)
-
-(**/**) (* helper parameters *)
-let depth = 7
-let bits = LazySparseArray.key_bits
-let width = 1 lsl bits
-let mask = width - 1
-let mask' = lnot mask
-let key_bits' = bits * (depth - 1)
-let _ = assert (key_bits' < Sys.word_size - 3)
-(**/**)
-
-(** Key-width of self-adjusting array mapped tries. *)
-let key_bits = bits * depth
-
-(** Size of self-adjusting array mapped tries. *)
-let size = 1 lsl key_bits
-
-(** Functor to make self-adjusting array mapped tries, given a particular module for self-adjusting values. *)
-module Make (M : Signatures.SAType)
-        : Signatures.SAArrayMappedTrieType with
-            type sa = M.sa
-            and type 'a thunk = 'a M.thunk
-        = struct
-
-    (** Self-adjusting array mapped tries containing ['a]. *)
-    type 'a saamt = 'a saamt' M.thunk
-
-    (** Constructor tags for self-adjusting array mapped tries containing ['a]. *)
-    and 'a saamt' =
-        | Branches of 'a saamt' LazySparseArray.t
-        | Leaves of 'a LazySparseArray.t
-        | Empty
-
-    (** Types and operations common to self-adjusting array mapped tries containing any type. *)
-    module T = struct
-        (** Abstract type identifying the given module for self-adjusting values used to create this module for self-adjusting array mapped tries. *)
-        type sa = M.sa
-
-        (** Self-adjusting values from the given module used to create this module for self-adjusting array mapped tries. *)
-        type 'a thunk = 'a M.thunk
-
-        (** True if this module implements self-adjusting array mapped tries. *)
-        let is_self_adjusting = M.is_self_adjusting
-
-        (** True if this module implements lazy array mapped tries. *)
-        let is_lazy = M.is_lazy
-
-        (** Compute the hash value of a self-adjusting array mapped trie. *)
-        let hash = M.hash
-
-        (** Compute whether two self-adjusting array mapped tries are equal. *)
-        let equal = M.equal
-
-        (** Recompute self-adjusting array mapped tries if necessary. *)
-        let refresh = M.refresh
-
-        (** Return the value at index [k] of a self-adjusting array mapped trie. *)
-        let get xs k =
-            if k < 0 || k >= size then invalid_arg "index out of bounds";
-            let rec get xs s =
-                let k = k lsr s land mask in
-                match xs with
-                    | Branches xs ->
-                        begin match LazySparseArray.get xs k with
-                            | Some xs -> get xs (s - bits)
-                            | None -> None
-                        end
-                    | Leaves xs ->
-                        LazySparseArray.get xs k
-                    | Empty ->
-                        None
-            in
-            get (M.force xs) key_bits'
-    end
-    include T
-
-    (** Output module types of {!SAArrayMappedTrie.Make}. *)
-    module type S = Signatures.SAArrayMappedTrieType.S
-
-    (** Helper functor to make a constructor for self-adjusting array mapped tries of a specific type. *)
-    module Make (R : Hashtbl.SeededHashedType)
-            : S with type sa = sa and type 'a thunk = 'a thunk and type data = R.t and type t = R.t saamt = struct
-        module A = M.Make (struct
-            type t = R.t saamt'
-            let hash seed = function
-                | Branches xs -> LazySparseArray.hash (Hashtbl.seeded_hash seed `Branches) xs
-                | Leaves xs -> LazySparseArray.hash (Hashtbl.seeded_hash seed `Leaves) xs
-                | Empty -> Hashtbl.seeded_hash seed `Empty
-            let equal xs xs' = xs == xs' || match xs, xs' with
-                | Branches xs, Branches xs' -> LazySparseArray.equal xs xs'
-                | Leaves xs, Leaves xs' -> LazySparseArray.equal xs xs'
-                | _ -> false
-        end)
-
-        (** Value contained by self-adjusting array mapped tries for a specific type. *)
-        type data = R.t
-
-        (** Self-adjusting array mapped tries for a specific type. *)
-        type t = A.t
-
-        include T
-
-        (** An empty self-adjusting array mapped trie. *)
-        let empty = A.const Empty
-
-        (** Create memoizing constructor that adds a binding to an self-adjusting array mapped trie. *)
-        let memo_add =
-            let add = A.memo3 (module A) (module Types.Int) (module R) begin fun _ xs k v ->
-                let rec add xs s =
-                    (* if along k, initialize the next branch/leaf node, else lookup the subtrie under the prior AMT *)
-                    if s > 0 then
-                        Branches begin LazySparseArray.make begin fun d ->
-                            if k lsr s land mask == d then
-                                Some (add xs (s - bits))
-                            else
-                                (* perform a partial key lookup for the corresponding subtrie under the prior AMT *)
-                                let rec subtrie xs s' = match xs with
-                                    | Branches xs ->
-                                        if s' == s then
-                                            LazySparseArray.get xs d
-                                        else
-                                            let k = k lsr s' land mask in
-                                            begin match LazySparseArray.get xs k with
-                                                | Some xs ->
-                                                    subtrie xs (s' - bits)
-                                                | None ->
-                                                    None
-                                            end
-                                    | Empty ->
-                                        None
-                                    | Leaves _ ->
-                                        assert false
-                                in
-                                subtrie (M.force xs) key_bits'
-                        end end
-                    else
-                        Leaves begin LazySparseArray.make begin fun d ->
-                            if k land mask == d then
-                                Some v
-                            else
-                                get xs (k land mask' lor d)
-                        end end
-                in
-                add xs key_bits'
-            end in
-            fun xs k v ->
-                if k < 0 || k >= size then invalid_arg "index out of bounds";
-                add xs k v
-    end
-end

File Source/Adapton/SAList.ml

-(** Self-adjusting lists. *)
-
-(** Functor to make self-adjusting lists, given a particular module for self-adjusting values. *)
-module Make (M : Signatures.SAType)
-        : Signatures.SAListType with type sa = M.sa and type 'a thunk = 'a M.thunk and type 'a salist = [ `Cons of 'a * 'b | `Nil ] M.thunk as 'b = struct
-
-    (** Self-adjusting lists containing ['a]. *)
-    type 'a salist = 'a salist' M.thunk
-
-    (** Constructor tags for self-adjusting lists containing ['a]. *)
-    and 'a salist' = [ `Cons of 'a * 'a salist | `Nil ]
-
-    (** Types and operations common to self-adjusting lists containing any type. *)
-    module T = struct
-        (** Abstract type identifying the given module for self-adjusting values used to create this module for self-adjusting lists. *)
-        type sa = M.sa
-
-        (** Self-adjusting values from the given module used to create this module for self-adjusting lists. *)
-        type 'a thunk = 'a M.thunk
-
-        (** True if this module implements self-adjusting lists. *)
-        let is_self_adjusting = M.is_self_adjusting
-
-        (** True if this module implements lazy lists. *)
-        let is_lazy = M.is_lazy
-
-        (** Return the id of a self-adjusting list. *)
-        let id = M.id
-
-        (** Compute the hash value of a self-adjusting list. *)
-        let hash = M.hash
-
-        (** Compute whether two self-adjusting lists are equal. *)
-        let equal = M.equal
-
-        (** Return the tag of a self-adjusting list, (re-)computing it if necessary. *)
-        let force = M.force
-
-        (** Recompute self-adjusting lists if necessary. *)
-        let refresh = M.refresh
-
-        (** Create a regular list from a self-adjusting list. *)
-        let to_list xs =
-            let rec to_list acc xs = match force xs with
-                | `Cons ( x, xs ) -> to_list (x::acc) xs
-                | `Nil -> List.rev acc
-            in
-            to_list [] xs
-
-        (** Create a regular list of ids of elements from a self-adjusting list. *)
-        let to_ids xs =
-            let rec to_ids acc xs = match force xs with
-                | `Cons ( _, xs ) -> to_ids (id xs::acc) xs
-                | `Nil -> List.rev (id xs::acc)
-            in
-            to_ids [] xs
-
-        (** Create a regular list from the first [k] elements of a self-adjusting list. *)
-        let take xs k =
-            let rec take acc xs k = if k = 0 then List.rev acc else match force xs with
-                | `Cons ( x, xs ) -> take (x::acc) xs (pred k)
-                | `Nil -> List.rev acc
-            in
-            take [] xs k
-
-        (** Return the head of a self-adjusting list. *)
-        let hd xs = match force xs with
-            | `Cons ( x, _ ) -> x
-            | `Nil -> failwith "hd"
-
-        (** Return the tail of a self-adjusting list. *)
-        let tl xs = match force xs with
-            | `Cons ( _, xs ) -> xs
-            | `Nil -> failwith "tl"
-    end
-    include T
-
-    (** Output module types of {!SAList.MakeBasic}. *)
-    module type BasicS = Signatures.SAListType.BasicS
-
-    (** Output module types of {!SAList.Make}. *)
-    module type S = Signatures.SAListType.S
-
-    (** Helper functor to make basic list constructors and combinators for self-adjusting lists of a specific type. *)
-    module MakeBasic (R : Hashtbl.SeededHashedType)
-            : BasicS with type sa = sa and type 'a thunk = 'a thunk and type data = R.t and type t = R.t salist and type t' = R.t salist' = struct
-        module L = M.Make (struct
-            type t = R.t salist'
-            let hash seed = function
-                | `Cons ( x, xs ) -> hash (R.hash (Hashtbl.seeded_hash seed `Cons) x) xs
-                | `Nil -> Hashtbl.seeded_hash seed `Nil
-            let equal xs xs' = xs == xs' || match xs, xs' with
-                | `Cons ( h, t ), `Cons ( h', t' ) -> R.equal h h' && equal t t'
-                | _ -> false
-        end)
-
-        (** Self-adjusting values for a specific type, return by certain list operations. *)
-        module SAData = M.Make (R)
-
-        (** Value contained by self-adjusting lists for a specific type. *)
-        type data = R.t
-
-        (** Self-adjusting lists for a specific type. *)
-        type t = L.t
-
-        (** Tags for self-adjusting lists for a specific type. *)
-        type t' = L.data
-
-        include T
-
-        (** Create a self-adjusting list from a constant list constructor that does not depend on other self-adjusting values. *)
-        let const = L.const
-
-        (** Update a self-adjusting list with a constant list constructor that does not depend on other self-adjusting values. *)
-        let update_const = L.update_const
-
-        (** Create a self-adjusting list from a thunk returning a list constructor that may depend on other self-adjusting values. *)
-        let thunk = L.thunk
-
-        (** Update a self-adjusting list with a thunk returning a list constructor that may depend on other self-adjusting values. *)
-        let update_thunk = L.update_thunk
-
-        include MemoN.Make (struct
-            type data = L.data
-            type t = L.t
-
-            (** Create memoizing constructor of a self-adjusting list. *)
-            let memo = L.memo
-        end)
-
-        (** Create a self-adjusting list from a regular list. *)
-        let of_list xs =
-            let rec of_list acc = function
-                | x::xs -> of_list (const (`Cons ( x, acc ))) xs
-                | [] -> acc
-            in
-            of_list (const `Nil) (List.rev xs)
-
-        (** Update the head of a self-adjusting list to push a value in front. *)
-        let push x xs = match force xs with
-            | `Cons ( x', xs' ) -> update_const xs (`Cons ( x, const (`Cons ( x', xs' )) ))
-            | `Nil -> update_const xs (`Cons ( x, const `Nil ))
-
-        (** Update the head of a self-adjusting list to pop a value from the front. *)
-        let pop xs = match force xs with
-            | `Cons ( x', xs' ) -> update_const xs (force xs'); x'
-            | `Nil -> failwith "pop"
-
-        (** Update the [k]th element of a self-adjusting list to insert a value [x]. *)
-        let insert k x xs =
-            if k < 0 then invalid_arg "insert";
-            let rec insert k xs = match force xs with
-                | `Cons ( _, xs ) when k > 0 -> insert (k - 1) xs
-                | `Nil when k > 0 -> failwith "insert"
-                | `Cons _ | `Nil -> push x xs
-            in
-            insert k xs
-
-        (** Update the [k]th element of a self-adjusting list to remove a value and return it. *)
-        let remove k xs =
-            if k < 0 then invalid_arg "remove";
-            let rec remove k xs = match force xs with
-                | `Cons ( _, xs ) when k > 0 -> remove (k - 1) xs
-                | `Cons _ -> pop xs
-                | `Nil -> failwith "remove"
-            in
-            remove k xs
-
-        (** Create memoizing constructor to concatenate two self-adjusting lists. *)
-        let memo_append =
-            memo2 (module L) (module L) begin fun append xs ys -> match force xs with
-                | `Cons ( x, xs ) -> `Cons ( x, append xs ys )
-                | `Nil -> force ys
-            end
-
-        (** Create memoizing constructor to filter a self-adjusting list with a predicate. *)
-        let memo_filter f =
-            memo (module L) begin fun filter xs -> match force xs with
-                | `Cons ( x, xs ) -> if f x then `Cons ( x, filter xs ) else force (filter xs)
-                | `Nil -> `Nil
-            end
-
-        (** Create memoizing constructor to filter a self-adjusting list with a predicate and key. *)
-        let memo_filter_with_key (type a) (module K : Hashtbl.SeededHashedType with type t = a) f =
-            memo2 (module K) (module L) begin fun filter k xs -> match force xs with
-                | `Cons ( x, xs ) -> if f k x then `Cons ( x, filter k xs ) else force (filter k xs)
-                | `Nil -> `Nil
-            end
-
-        (** Create memoizing constructor to simultaneously filter and map a self-adjusting list with a predicate/mapping function. *)
-        let memo_filter_map (type a) (type b) (module L : Signatures.SAListType.BasicS with type sa = sa and type data = a and type t = b) f =
-            memo (module L) begin fun filter xs -> match L.force xs with
-                | `Cons ( x, xs ) -> (match f x with Some y -> `Cons ( y, filter xs ) | None -> force (filter xs))
-                | `Nil -> `Nil
-            end
-
-        (** Create memoizing constructor to map a self-adjusting list with a mapping function. *)
-        let memo_map (type a) (type b) (module L : Signatures.SAListType.BasicS with type sa = sa and type data = a and type t = b) f =
-            memo (module L) begin fun map xs -> match L.force xs with
-                | `Cons ( x, xs ) -> `Cons ( f x, map xs )
-                | `Nil -> `Nil
-            end
-
-        (** Create memoizing constructor to map a self-adjusting list with a mapping function and key. *)
-        let memo_map_with_key
-                (type a) (module K : Hashtbl.SeededHashedType with type t = a)
-                (type b) (type c) (module L : Signatures.SAListType.BasicS with type sa = sa and type data = b and type t = c)
-                f =
-            memo2 (module K) (module L) begin fun map k xs -> match L.force xs with
-                | `Cons ( x, xs ) -> `Cons ( f k x, map k xs )
-                | `Nil -> `Nil
-            end
-
-        (** Create memoizing constructor to scan (fold over prefixes of) a self-adjusting list with an scanning function. *)
-        let memo_scan (type a) (type b) (module L : Signatures.SAListType.BasicS with type sa = sa and type data = a and type t = b) f =
-            memo2 (module L) (module R) begin fun scan xs acc -> match L.force xs with
-                | `Cons ( x, xs ) -> let acc = f x acc in `Cons ( acc, scan xs acc )
-                | `Nil -> `Nil
-            end
-
-        (** Create memoizing constructor to tree-fold a self-adjusting list with an associative fold function. *)
-        let memo_tfold f =
-            let fold_pairs = L.memo2 (module Types.Int) (module L) begin fun fold_pairs seed xs -> match L.force xs with
-                | `Cons ( x', xs' ) as xs'' ->
-                    if L.hash seed xs mod 2 == 0 then
-                        `Cons ( x', fold_pairs seed xs' )
-                    else begin match L.force xs' with
-                        | `Cons ( y', ys' ) ->
-                            `Cons ( f x' y', fold_pairs seed ys' )
-                        | `Nil ->
-                            xs''
-                    end
-                | `Nil ->
-                    `Nil
-            end in
-            let tfold = SAData.memo2 (module Types.Seeds) (module L) begin fun tfold seeds xs -> match L.force xs with
-                | `Cons ( x', xs' ) ->
-                    begin match L.force xs' with
-                        | `Cons _ ->
-                            let seed, seeds = Types.Seeds.pop seeds in
-                            force (tfold seeds (fold_pairs seed xs))
-                        | `Nil ->
-                            x'
-                    end
-                | `Nil ->
-                    failwith "tfold"
-            end in
-            let seeds = Types.Seeds.make () in
-            fun xs -> tfold seeds xs
-    end
-
-
-    (** Functor to make various list constructors and combinators for self-adjusting lists of a specific type. *)
-    module Make (R : Hashtbl.SeededHashedType)
-            : S with type sa = sa and type 'a thunk = 'a thunk and type data = R.t and type t = R.t salist and type t' = R.t salist' = struct
-        module L = MakeBasic (R)
-        include L
-
-        (** Create memoizing constructor to quicksort a self-adjusting list with a comparator. *)
-        let memo_quicksort cmp =
-            let filter_left = memo_filter_with_key (module R) (fun k x -> cmp x k < 0) in
-            let filter_right = memo_filter_with_key (module R) (fun k x -> cmp x k >= 0) in
-            let quicksort = memo2 (module L) (module L) begin fun quicksort xs rest -> match L.force xs with
-                | `Cons ( x, xs ) ->
-                    let left = filter_left x xs in
-                    let right = filter_right x xs in
-                    L.force (quicksort left (const (`Cons ( x, quicksort right rest ))))
-                | `Nil ->
-                    L.force rest
-            end in
-            fun xs -> quicksort xs (const `Nil)
-
-        (**/**) (* internal type of mergesort *)
-        module RunType = MakeBasic (L)
-        (**/**)
-
-        (** Create memoizing constructor to mergesort a self-adjusting list with a comparator. *)
-        let memo_mergesort cmp =
-            let nil = const `Nil in
-            let single = memo (module R) (fun single x -> `Cons ( x, nil )) in
-            let lift = RunType.memo_map (module L) single in
-            let merge = memo2 (module L) (module L) begin fun merge xs ys -> match force xs, force ys with
-                | `Cons ( x', xs' ), `Cons ( y', ys' ) ->
-                    if cmp x' y' < 0 then
-                        `Cons ( x', merge xs' ys )
-                    else
-                        `Cons ( y', merge xs ys' )
-                | xs'', `Nil ->
-                    xs''
-                | `Nil, ys'' ->
-                    ys''
-            end in
-            let mergesort = RunType.memo_tfold merge in
-            memo (module L) begin fun _ xs -> match force xs with
-                | `Cons _ -> force (RunType.SAData.force (mergesort (lift xs)))
-                | `Nil -> `Nil
-            end
-    end
-end

File Source/Adapton/Signatures.ml

-(** Module types for {i Adapton}. *)
-
-(** {2 Self-adjusting values} *)
-
-(** Output module types of modules for self-adjusting values. *)
-module rec SAType : sig
-    (** Module type for self-adjusting values for a specific type. *)
-    module type S = sig
-        type sa
-        type 'a thunk
-        type data
-        type t
-        module Data : Hashtbl.SeededHashedType with type t = data
-        val is_self_adjusting : bool
-        val is_lazy : bool
-        val id : t -> int
-        val hash : int -> t -> int
-        val equal : t -> t -> bool
-        val refresh : unit -> unit
-        val force : t -> data
-        val const : data -> t
-        val update_const : t -> data -> unit
-        val thunk : (unit -> data) -> t
-        val update_thunk : t -> (unit -> data) -> unit
-        include MemoN.S with type data := data and type t := t
-    end
-end = SAType
-
-(** Module type for self-adjusting values. *)
-module type SAType = sig
-    type sa
-    type 'a thunk
-    val is_self_adjusting : bool
-    val is_lazy : bool
-    val id : 'a thunk -> int
-    val hash : int -> 'a thunk -> int
-    val equal : 'a thunk -> 'a thunk -> bool
-    val refresh : unit -> unit
-    val force : 'a thunk -> 'a
-    module Make (R : Hashtbl.SeededHashedType) : SAType.S with type sa = sa and type 'a thunk = 'a thunk and type data = R.t and type t = R.t thunk
-    val tweak_gc : unit -> unit
-end
-
-(** {2 Self-adjusting lists} *)
-
-(** Output module types of modules for self-adjusting lists. *)
-module rec SAListType : sig
-    (** Module type for self-adjusting lists for a specific type containing basic types and operations. *)
-    module type BasicS = sig
-        type sa
-        type 'a thunk
-        type data
-        module SAData : SAType.S with type sa = sa and type 'a thunk = 'a thunk and type data = data
-        type t
-        type t' = [ `Cons of data * t | `Nil ]
-        val is_self_adjusting : bool
-        val is_lazy : bool
-        val id : t -> int
-        val hash : int -> t -> int
-        val equal : t -> t -> bool
-        val refresh : unit -> unit
-        val force : t -> t'
-        val to_list : t -> data list
-        val to_ids : t -> int list
-        val take : t -> int -> data list
-        val hd : t -> data
-        val tl : t -> t
-        val const : t' -> t
-        val update_const : t -> t' -> unit
-        val thunk : (unit -> t') -> t
-        val update_thunk : t -> (unit -> t') -> unit
-        include MemoN.S with type data := t' and type t := t
-        val of_list : data list -> t
-        val push : data -> t -> unit
-        val pop : t -> data
-        val insert : int -> data -> t -> unit
-        val remove : int -> t -> data
-        val memo_append : t -> t -> t
-        val memo_filter : (data -> bool) -> (t -> t)
-        val memo_filter_with_key
-            : (module Hashtbl.SeededHashedType with type t = 'a)
-                -> ('a -> data -> bool) -> ('a -> t -> t)
-        val memo_filter_map
-            : (module SAListType.BasicS with type sa = sa and type data = 'a and type t = 'b)
-                -> ('a -> data option) -> ('b -> t)
-        val memo_map
-            : (module SAListType.BasicS with type sa = sa and type data = 'a and type t = 'b)