1. Yit Phang Khoo
  2. Adapton.ocaml

Commits

Yit Phang Khoo  committed fa9c8d4

Renaming "self-adjusting" -> "incremental", etc.

  • Participants
  • Parent commits fd8102a
  • Branches default

Comments (0)

Files changed (40)

File Applications/Adaptime/Adaptime/behavior.ml

View file
  • Ignore whitespace
 	val id : 'a behavior -> int
 end
 
-(* Make a behavior, given a SAType. *)
-module Make (M : SAType) : Behavior = struct
+(* Make a behavior, given an AType. *)
+module Make (M : AType) : Behavior = struct
 	module Tm = TimeType(M)
 	module S = Sys
 	module U = Unix
 
-	type 'a sa_mod = (module SAType.S with type sa = M.sa and type data = 'a and type t = 'a M.thunk)
-	type 'a behavior = 'a sa_mod * 'a M.thunk * time M.thunk
+	type 'a a_mod = (module AType.S with type atype = M.atype and type data = 'a and type t = 'a M.thunk)
+	type 'a behavior = 'a a_mod * 'a M.thunk * time M.thunk
 	(* Requirement: Always force 'a thunk before time thunk. *)
 
 	let const (type t) (module H : Hashtbl.SeededHashedType with type t = t) (c : t) : t behavior =
 			helper !memo_const_store
 		in	
 		let memo =
-			let mod_r = (module R : SAType.S with type sa = M.sa and type data = t and type t = t M.thunk) in
+			let mod_r = (module R : AType.S with type atype = M.atype and type data = t and type t = t M.thunk) in
 			try
 				Hashtbl.find memo_const_store mod_r
 			with
 			in
 			S.set_signal S.sigalrm handle;
 			ignore (U.alarm 1);
-			let beh = (module Tm : SAType.S with type sa = M.sa and type data = time and type t = time M.thunk), r, t in
+			let beh = (module Tm : AType.S with type atype = M.atype and type data = time and type t = time M.thunk), r, t in
 			seconds_store := Some beh;
 			beh
 		| Some c' ->
 				t'
 			)
 			in
-			let beh = (module Tm : SAType.S with type sa = M.sa and type data = time and type t = time M.thunk), r, t in
+			let beh = (module Tm : AType.S with type atype = M.atype and type data = time and type t = time M.thunk), r, t in
 			time_store := Some beh;
 			beh
 		| Some c ->

File Applications/Adaptime/Adaptime/time.ml

View file
  • Ignore whitespace
 let max_time (l : time list) : time =
 	List.fold_left max min_float l
 
-module TimeType (M : AdaptonUtil.Signatures.SAType) = M.Make( AdaptonUtil.Types.Float)
+module TimeType (M : AdaptonUtil.Signatures.AType) = M.Make( AdaptonUtil.Types.Float)
 

File Applications/As2/As2/Ast.ml

View file
  • Ignore whitespace
 
 module type S = sig
-  module A : AdaptonUtil.PolySA.S
+  module A : AdaptonUtil.PolyAPI.S
 
   type col = int
   type row = int
   end
 end
 
-module Make (SA : AdaptonUtil.Signatures.SAType) : S with module A = AdaptonUtil.PolySA.Make (SA) = struct
-  module A = AdaptonUtil.PolySA.Make (SA)
+module Make (AA : AdaptonUtil.Signatures.AType) : S with module A = AdaptonUtil.PolyAPI.Make (AA) = struct
+  module A = AdaptonUtil.PolyAPI.Make (AA)
 
   type col = int
   type row = int

File Applications/As2/As2/Interp.ml

View file
  • Ignore whitespace
   let read cur = get_val cur
 
   let update_cell_frm cur cell frm =
-    if A.is_self_adjusting then (
+    if A.is_incremental then (
       A.update_const cell.cell_frm frm ;
       A.update_thunk cell.cell_val begin fun _ ->
         if (! Global.stateless_eval ) then

File Applications/As2/As2/Main.ml

View file
  • Ignore whitespace
-module Make (SA : AdaptonUtil.Signatures.SAType) = struct
-  module Ast = Ast.Make (SA)
+module Make (AA : AdaptonUtil.Signatures.AType) = struct
+  module Ast = Ast.Make (AA)
   module Parser = Parser.Make (Ast)
   module Interp = Interp.Make (Ast)
   module Lexer = Lexer.Make (Ast) (Parser)
         (* Important: refresh signals to TotalOrder implementation that
            we want to start re-evaluation now; return to "at the
            beginning of time".  This is a no-op otherwise. *)
-        if Ast.A.is_self_adjusting then
+        if Ast.A.is_incremental then
           Ast.A.refresh ()
         else () ;
         let (sht,_) = Interp.get_pos cur in
   val run : unit -> unit
 end
 
-let as2_list = List.map begin fun ( name, sa ) ->
-    ( name, (module Make ((val sa : AdaptonUtil.Signatures.SAType)) : S) )
-end AdaptonZoo.All.sa_list
+let as2_list = List.map begin fun ( name, atype ) ->
+    ( name, (module Make ((val atype : AdaptonUtil.Signatures.AType)) : S) )
+end AdaptonZoo.All.a_list
 
 let run () =
   let as2 = ref (snd (List.hd as2_list)) in

File Benchmarks/BenchmarkAdapton/runbenchmarkadapton.ml

View file
  • Ignore whitespace
 
 open AdaptonUtil.Statistics
 
-let list_filter_task (type a) (module L : AdaptonUtil.Signatures.SAListType.S with type t = a and type data = float) =
+let list_filter_task (type a) (module L : AdaptonUtil.Signatures.AListType.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 : AdaptonUtil.Signatures.SAListType.S with type t = a and type data = float) =
+let list_map_task (type a) (module L : AdaptonUtil.Signatures.AListType.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 : AdaptonUtil.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.AListType.S with type t = a and type AData.t = b and type data = float) =
     L.memo_tfold min
 
-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) =
+let list_tfold_sum_task (type a) (type b) (module L : AdaptonUtil.Signatures.AListType.S with type t = a and type AData.t = b and type data = float) =
     L.memo_tfold (+.)
 
-let list_quicksort_task (type a) (module L : AdaptonUtil.Signatures.SAListType.S with type t = a and type data = float) =
+let list_quicksort_task (type a) (module L : AdaptonUtil.Signatures.AListType.S with type t = a and type data = float) =
     L.memo_quicksort Pervasives.compare
 
-let list_mergesort_task (type a) (module L : AdaptonUtil.Signatures.SAListType.S with type t = a and type data = float) =
+let list_mergesort_task (type a) (module L : AdaptonUtil.Signatures.AListType.S with type t = a and type data = float) =
     L.memo_mergesort Pervasives.compare
 
 let list_updown1_task
-        (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)
+        (type a) (module L : AdaptonUtil.Signatures.AListType.S with type t = a and type data = float)
+        (type b) (module B : AdaptonUtil.Signatures.AType.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 : 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)
+        (type a) (module L : AdaptonUtil.Signatures.AListType.S with type t = a and type data = float)
+        (type b) (module B : AdaptonUtil.Signatures.AType.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 AdaptonZoo.All.sa_list))
+let opt_a = ref (fst (List.hd AdaptonZoo.All.a_list))
 let opt_task = ref "filter"
 let opt_input_size = ref 1
 let opt_repeat_count = ref 1
 let opt_random_seed = ref 1
 let opt_monotonic = ref false
 
-let header ff = Printf.fprintf ff "%24s %24s %8d %8d %20d" !opt_sa !opt_task !opt_take_count !opt_input_size !opt_random_seed
+let header ff = Printf.fprintf ff "%24s %24s %8d %8d %20d" !opt_a !opt_task !opt_take_count !opt_input_size !opt_random_seed
 let stats ff s =
     Printf.fprintf ff "\"time\": %.17g, \"heap\": %.17g, \"stack\": %.17g, \"update\": %.17g, \"evaluate\": %.17g, \"dirty\": %.17g, \"clean\": %.17g"
         s.time s.heap s.stack s.update s.evaluate s.dirty s.clean
             (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 AdaptonZoo.All.sa_list))
+        (list_printer (fun ff -> Printf.fprintf ff "%S")) (fst (List.split AdaptonZoo.All.a_list))
         (list_printer task_printer) tasks;
     exit 0
 
-let exptree (module SA : AdaptonUtil.Signatures.SAType) rng =
+let exptree (module A : AdaptonUtil.Signatures.AType) 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 (AdaptonUtil.Types.Float) in
+    let module F = A.Make (AdaptonUtil.Types.Float) in
     let module E = struct
-        type e = e' SA.thunk
+        type e = e' A.thunk
         and e' = Num of float | Op of op * e * e
         and op = Plus | Mul | Minus | Div
-        module E = SA.Make (struct
+        module E = A.Make (struct
             type t = e'
             let hash seed = function
                 | Num f -> Hashtbl.seeded_hash seed f
-                | Op  ( op, x, y ) -> SA.hash (SA.hash (Hashtbl.seeded_hash seed op) x) y
+                | Op  ( op, x, y ) -> A.hash (A.hash (Hashtbl.seeded_hash seed op) x) y
             let equal x y = x == y || match x, y with
                 | Num x, Num y -> x == y
-                | Op ( op1, x1, y1 ), Op ( op2, x2, y2 ) -> op1 == op2 && SA.equal x1 x2 && SA.equal y1 y2
+                | Op ( op1, x1, y1 ), Op ( op2, x2, y2 ) -> op1 == op2 && A.equal x1 x2 && A.equal y1 y2
                 | _ -> false
         end)
         include E
             | Op ( Div, x, y ) -> let y = F.force (eval y) in F.force (eval x) /. (if y == 0. then 1. else y)
         end
     end in
-    SA.tweak_gc ();
+    A.tweak_gc ();
     Gc.compact ();
     let start_time = get_time () in
 
         let setup_stats = finish setup_stats 1 in
         let setup_top_heap_stack = get_top_heap_stack () in
 
-        if SA.is_self_adjusting then begin
+        if A.is_incremental then begin
             let half = int_of_float (floor (log (float_of_int !opt_input_size) /. log 2. /. 2.)) in
             let rec do_edits past n update_stats take_stats edit_count =
                 if n == 0 then
                         in
 
                         let (), update_stats = measure (fun () -> change false x) in
-                        let (), take_stats = measure (fun () -> SA.refresh (); take ()) in
+                        let (), take_stats = measure (fun () -> A.refresh (); take ()) in
                         let (), update_stats' = measure (fun () -> change true x) in
-                        let (), take_stats' = measure (fun () -> SA.refresh (); take ()) in
+                        let (), take_stats' = measure (fun () -> A.refresh (); take ()) in
 
                         ( add update_stats update_stats', add take_stats take_stats', 2 )
                     else
                                 failwith "swap"
                         end in
 
-                        let (), take_stats = measure (fun () -> SA.refresh (); take ()) in
+                        let (), take_stats = measure (fun () -> A.refresh (); take ()) in
 
                         ( update_stats, take_stats, 1 )
                     in
 let _ =
     Arg.parse (Arg.align [
         ( "-c", Arg.Unit show_config, " output available configuration" );
-        ( "-m", Arg.Symbol ( (fst (List.split AdaptonZoo.All.sa_list)), (fun s -> opt_sa := s) ), "list module" );
+        ( "-m", Arg.Symbol ( (fst (List.split AdaptonZoo.All.a_list)), (fun s -> opt_a := 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 AdaptonZoo.All.sa_list)) in
+    let module A = (val (List.assoc !opt_a AdaptonZoo.All.a_list)) in
     begin match List.assoc !opt_task tasks with
-        | `ExpTree -> exptree (module SA) rng
+        | `ExpTree -> exptree (module A) rng
         | _ -> ()
     end;
-    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 ();
+    let module ABool = A.Make (AdaptonUtil.Types.Bool) in
+    let module AList = AdaptonUtil.AList.Make (A) in
+    let module AFloatList = AList.Make (AdaptonUtil.Types.Float) in
+    A.tweak_gc ();
     Gc.compact ();
     let task = match List.assoc !opt_task tasks with
         | `One task ->
                 Printf.eprintf "Task %s only supports -T 1\n%!" !opt_task;
                 exit 1
             end;
-            `One (task (module SAFloatList))
+            `One (task (module AFloatList))
         | `List task ->
-            `List (task (module SAFloatList))
+            `List (task (module AFloatList))
         | `Flip task ->
             if !opt_monotonic then begin
                 Printf.eprintf "Task %s does not support -M\n%!" !opt_task;
                 exit 1
             end;
-            `Flip (task (module SAFloatList) (module SABool))
+            `Flip (task (module AFloatList) (module ABool))
         | `ExpTree ->
             failwith "exptree"
     in
 
     let start_time = get_time () in
 
-    let xs = ref (SAFloatList.const `Nil) in
+    let xs = ref (AFloatList.const `Nil) in
     let xss = Array.init !opt_input_size begin fun _ ->
-        xs := SAFloatList.const (`Cons (Random.State.float rng 1.0, !xs));
+        xs := AFloatList.const (`Cons (Random.State.float rng 1.0, !xs));
         !xs
     end in
     let xs = !xs in
     let last = ref 0 in
 
-    let b = SABool.const false in
+    let b = ABool.const false in
 
     Printf.eprintf "%t\n%!" header;
     try
             let take = match task with
                 | `List task ->
                     let yss = Array.init !opt_repeat_count (fun _ -> task xs) in
-                    (fun () -> Array.iter (fun ys -> ignore (SAFloatList.take ys !opt_take_count)) yss)
+                    (fun () -> Array.iter (fun ys -> ignore (AFloatList.take ys !opt_take_count)) yss)
                 | `One task ->
                     let ys = Array.init !opt_repeat_count (fun _ -> task xs) in
-                    (fun () -> Array.iter (fun y -> ignore (SAFloatList.SAData.force y)) ys)
+                    (fun () -> Array.iter (fun y -> ignore (AFloatList.AData.force y)) ys)
                 | `Flip task ->
                     let yss = Array.init !opt_repeat_count (fun _ -> task xs b) in
-                    (fun () -> Array.iter (fun ys -> ignore (SAFloatList.take ys !opt_take_count)) yss)
+                    (fun () -> Array.iter (fun ys -> ignore (AFloatList.take ys !opt_take_count)) yss)
                 | `ExpTree ->
                     failwith "exptree"
             in
         let setup_stats = finish setup_stats 1 in
         let setup_top_heap_stack = get_top_heap_stack () in
 
-        if SA.is_self_adjusting then begin
+        if A.is_incremental then begin
             let rec do_edits past n update_stats take_stats edit_count =
                 if n == 0 then
                     ( update_stats, take_stats, edit_count )
                             let zs = xss.(edit) in
 
                             let ( z', zs' ), delete_update_stats = measure begin fun () ->
-                                match SAFloatList.force zs with
+                                match AFloatList.force zs with
                                     | `Cons ( z', zs' ) ->
-                                        SAFloatList.update_const zs (SAFloatList.force zs');
+                                        AFloatList.update_const zs (AFloatList.force zs');
                                         ( z', zs' )
                                     | `Nil ->
                                         failwith "delete"
                             end in
 
                             let (), delete_take_stats = measure begin fun () ->
-                                SA.refresh ();
+                                A.refresh ();
                                 take ()
                             end in
 
                             let (), insert_update_stats = measure begin fun () ->
-                                SAFloatList.update_const zs (`Cons ( z', zs' ))
+                                AFloatList.update_const zs (`Cons ( z', zs' ))
                             end in
 
                             let (), insert_take_stats = measure begin fun () ->
-                                SA.refresh ();
+                                A.refresh ();
                                 take ()
                             end in
 
                             let zs = xss.(edit) in
 
                             let (), update_stats = measure begin fun () ->
-                                match SAFloatList.force xs with
+                                match AFloatList.force xs with
                                     | `Cons _ as xs' ->
-                                        begin match SAFloatList.force xss.(!last) with
+                                        begin match AFloatList.force xss.(!last) with
                                             | `Cons _ as last' ->
-                                                begin match SAFloatList.force zs with
+                                                begin match AFloatList.force zs with
                                                     | `Cons _ as zs' ->
-                                                        SAFloatList.update_const xs zs';
-                                                        SAFloatList.update_const xss.(!last) xs';
-                                                        SAFloatList.update_const zs last';
+                                                        AFloatList.update_const xs zs';
+                                                        AFloatList.update_const xss.(!last) xs';
+                                                        AFloatList.update_const zs last';
                                                         last := edit;
                                                     | `Nil ->
                                                         failwith "swap"
                             end in
 
                             let (), take_stats = measure begin fun () ->
-                                SA.refresh ();
+                                A.refresh ();
                                 take ()
                             end in
 
                             let zs = xss.(edit) in
 
                             let (), update_stats = measure begin fun () ->
-                                SABool.update_const b (not (SABool.force b));
-                                match SAFloatList.force zs with
+                                ABool.update_const b (not (ABool.force b));
+                                match AFloatList.force zs with
                                     | `Cons ( _, zs' ) ->
-                                        SAFloatList.update_const zs (`Cons ( value, zs' ))
+                                        AFloatList.update_const zs (`Cons ( value, zs' ))
                                     | `Nil ->
                                         failwith "flip"
                             end in
 
-                            let (), take_stats = measure (fun () -> SA.refresh (); take ()) in
-                            let (), update_stats' = measure (fun () -> SABool.update_const b (not (SABool.force b))) in
-                            let (), take_stats' = measure (fun () -> SA.refresh (); take ()) in
+                            let (), take_stats = measure (fun () -> A.refresh (); take ()) in
+                            let (), update_stats' = measure (fun () -> ABool.update_const b (not (ABool.force b))) in
+                            let (), take_stats' = measure (fun () -> A.refresh (); take ()) in
 
                             ( add update_stats update_stats', add take_stats take_stats', 2 )
 

File Benchmarks/BenchmarkAdapton/runbenchmarkadapton.py

View file
  • Ignore whitespace
         default=1, type=int)
     benchmark.add_argument("-T", "--take-counts", metavar="TAKE", help="take only the first %(metavar)s elements of each output (default: 1)",
         nargs="+", default=( 1, ), type=int)
-    benchmark.add_argument("-E", "--edit-count", metavar="COUNT", help="average self-adjusting benchmarks over %(metavar)s edits ",
+    benchmark.add_argument("-E", "--edit-count", metavar="COUNT", help="average Adapton benchmarks over %(metavar)s edits ",
         default=250, type=int)
     benchmark.add_argument("-M", "--monotonic", help="make monotonic edits ", action="store_true")
     benchmark.add_argument("-S", "--random-seeds", metavar="SEED", help="run benchmark for seeds (default: 5 random seeds)",

File LICENSE.txt

View file
  • Ignore whitespace
-Adapton.ocaml: Self-adjusting computation library for OCaml.
+Adapton.ocaml: Incremental computation library for OCaml.
 
 Copyright (c) 2013, Khoo Yit Phang <khooyp@cs.umd.edu>
 

File README.md

View file
  • Ignore whitespace
 Introduction
 ============
 
-Adapton.ocaml is an OCaml library for self-adjusting computation.
+Adapton.ocaml is an OCaml library for incremental computation.
 
 
 Quick-start
         % make repl
                 OCaml version 4.00.1
 
-        # module IntList = Adapton.SAList.Make (AdaptonUtil.Types.Int);;
+        # module IntList = Adapton.AList.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

View file
  • Ignore whitespace
-(** Adapton self-adjusting values, alternative APIs, and applications. *)
+(** Adapton thunks, alternative APIs, and applications. *)
 
-(** Adapton with a functor-based API. *)
+(** Adapton with a default functor-based API. *)
 include AdaptonZoo.Adapton
 
-(** Adapton with a polymorphic API. *)
-module PolySA = AdaptonUtil.PolySA.Make (AdaptonZoo.Adapton)
+(** Adapton with a alternative polymorphic API. *)
+module PolyAPI = AdaptonUtil.PolyAPI.Make (AdaptonZoo.Adapton)
 
-(** Adapton with a basic polymorphic API. *)
-module BasicSA = AdaptonUtil.BasicSA.Make (AdaptonZoo.Adapton)
+(** Adapton with a alternative basic polymorphic API. *)
+module BasicAPI = AdaptonUtil.BasicAPI.Make (AdaptonZoo.Adapton)
 
-(** Adapton self-adjusting lists. *)
-module SAList = AdaptonUtil.SAList.Make (AdaptonZoo.Adapton)
+(** Adapton incremental lists. *)
+module AList = AdaptonUtil.AList.Make (AdaptonZoo.Adapton)

File Source/AdaptonInternal/MemoN.ml

View file
  • Ignore whitespace
-(** Memoization helper module to create modules for self-adjusting values. *)
+(** Memoization helper module to memoize incremental thunks. *)
 
 (** Input module type of memoization functor {!MemoN.Make}. *)
 module type MemoNType = sig

File Source/AdaptonUtil.mlpack

View file
  • Ignore whitespace
-AdaptonUtil/BasicSA
-AdaptonUtil/PolySA
-AdaptonUtil/SAArrayMappedTrie
-AdaptonUtil/SAList
+AdaptonUtil/AArrayMappedTrie
+AdaptonUtil/AList
+AdaptonUtil/BasicAPI
+AdaptonUtil/PolyAPI
 AdaptonUtil/Signatures
 AdaptonUtil/Statistics
 AdaptonUtil/Types

File Source/AdaptonUtil/AArrayMappedTrie.ml

View file
  • Ignore whitespace
+(** Adapton array mapped tries. *)
+
+open AdaptonInternal
+
+(**/**) (* 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 Adapton array mapped tries. *)
+let key_bits = bits * depth
+
+(** Size of Adapton array mapped tries. *)
+let size = 1 lsl key_bits
+
+(** Functor to make Adapton array mapped tries, given a particular module for Adapton thunks. *)
+module Make (M : Signatures.AType)
+        : Signatures.AArrayMappedTrieType with
+            type atype = M.atype
+            and type 'a thunk = 'a M.thunk
+        = struct
+
+    (** Adapton array mapped tries containing ['a]. *)
+    type 'a aamt = 'a aamt' M.thunk
+
+    (** Constructor tags for Adapton array mapped tries containing ['a]. *)
+    and 'a aamt' =
+        | Branches of 'a aamt' LazySparseArray.t
+        | Leaves of 'a LazySparseArray.t
+        | Empty
+
+    (** Types and operations common to Adapton array mapped tries containing any type. *)
+    module T = struct
+        (** Abstract type identifying the given module for Adapton thunks used to create this module for Adapton array mapped tries. *)
+        type atype = M.atype
+
+        (** Adapton thunks from the given module used to create this module for Adapton array mapped tries. *)
+        type 'a thunk = 'a M.thunk
+
+        (** True if this module implements Adapton array mapped tries. *)
+        let is_incremental = M.is_incremental
+
+        (** True if this module implements lazy array mapped tries. *)
+        let is_lazy = M.is_lazy
+
+        (** Compute the hash value of an Adapton array mapped trie. *)
+        let hash = M.hash
+
+        (** Compute whether two Adapton array mapped tries are equal. *)
+        let equal = M.equal
+
+        (** Recompute Adapton array mapped tries if necessary. *)
+        let refresh = M.refresh
+
+        (** Return the value at index [k] of an Adapton 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 {!AArrayMappedTrie.Make}. *)
+    module type S = Signatures.AArrayMappedTrieType.S
+
+    (** Helper functor to make a constructor for Adapton array mapped tries of a specific type. *)
+    module Make (R : Hashtbl.SeededHashedType)
+            : S with type atype = atype and type 'a thunk = 'a thunk and type data = R.t and type t = R.t aamt = struct
+        module A = M.Make (struct
+            type t = R.t aamt'
+            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 Adapton array mapped tries for a specific type. *)
+        type data = R.t
+
+        (** Adapton array mapped tries for a specific type. *)
+        type t = A.t
+
+        include T
+
+        (** An empty Adapton array mapped trie. *)
+        let empty = A.const Empty
+
+        (** Create memoizing constructor that adds a binding to an Adapton 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/AdaptonUtil/AList.ml

View file
  • Ignore whitespace
+(** Adapton lists. *)
+
+open AdaptonInternal
+
+(** Functor to make Adapton lists, given a particular module for Adapton thunks. *)
+module Make (M : Signatures.AType)
+        : Signatures.AListType with type atype = M.atype and type 'a thunk = 'a M.thunk and type 'a alist = [ `Cons of 'a * 'b | `Nil ] M.thunk as 'b = struct
+
+    (** Adapton lists containing ['a]. *)
+    type 'a alist = 'a alist' M.thunk
+
+    (** Constructor tags for Adapton lists containing ['a]. *)
+    and 'a alist' = [ `Cons of 'a * 'a alist | `Nil ]
+
+    (** Types and operations common to Adapton lists containing any type. *)
+    module T = struct
+        (** Abstract type identifying the given module for Adapton thunks used to create this module for Adapton lists. *)
+        type atype = M.atype
+
+        (** Adapton thunks from the given module used to create this module for Adapton lists. *)
+        type 'a thunk = 'a M.thunk
+
+        (** True if this module implements Adapton lists. *)
+        let is_incremental = M.is_incremental
+
+        (** True if this module implements lazy lists. *)
+        let is_lazy = M.is_lazy
+
+        (** Return the id of an Adapton list. *)
+        let id = M.id
+
+        (** Compute the hash value of an Adapton list. *)
+        let hash = M.hash
+
+        (** Compute whether two Adapton lists are equal. *)
+        let equal = M.equal
+
+        (** Return the tag of an Adapton list, (re-)computing it if necessary. *)
+        let force = M.force
+
+        (** Recompute Adapton lists if necessary. *)
+        let refresh = M.refresh
+
+        (** Create a regular list from an Adapton 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 an Adapton 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 an Adapton 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 an Adapton list. *)
+        let hd xs = match force xs with
+            | `Cons ( x, _ ) -> x
+            | `Nil -> failwith "hd"
+
+        (** Return the tail of an Adapton list. *)
+        let tl xs = match force xs with
+            | `Cons ( _, xs ) -> xs
+            | `Nil -> failwith "tl"
+    end
+    include T
+
+    (** Output module types of {!AList.MakeBasic}. *)
+    module type BasicS = Signatures.AListType.BasicS
+
+    (** Output module types of {!AList.Make}. *)
+    module type S = Signatures.AListType.S
+
+    (** Helper functor to make basic list constructors and combinators for Adapton lists of a specific type. *)
+    module MakeBasic (R : Hashtbl.SeededHashedType)
+            : BasicS with type atype = atype and type 'a thunk = 'a thunk and type data = R.t and type t = R.t alist and type t' = R.t alist' = struct
+        module L = M.Make (struct
+            type t = R.t alist'
+            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)
+
+        (** Adapton thunks for a specific type, return by certain list operations. *)
+        module AData = M.Make (R)
+
+        (** Value contained by Adapton lists for a specific type. *)
+        type data = R.t
+
+        (** Adapton lists for a specific type. *)
+        type t = L.t
+
+        (** Tags for Adapton lists for a specific type. *)
+        type t' = L.data
+
+        include T
+
+        (** Create an Adapton list from a constant list constructor that does not depend on other Adapton thunks. *)
+        let const = L.const
+
+        (** Update an Adapton list with a constant list constructor that does not depend on other Adapton thunks. *)
+        let update_const = L.update_const
+
+        (** Create an Adapton list from a thunk returning a list constructor that may depend on other Adapton thunks. *)
+        let thunk = L.thunk
+
+        (** Update an Adapton list with a thunk returning a list constructor that may depend on other Adapton thunks. *)
+        let update_thunk = L.update_thunk
+
+        include MemoN.Make (struct
+            type data = L.data
+            type t = L.t
+
+            (** Create memoizing constructor of an Adapton list. *)
+            let memo = L.memo
+        end)
+
+        (** Create an Adapton 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 an Adapton 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 an Adapton 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 an Adapton 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 an Adapton 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 Adapton 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 an Adapton 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 an Adapton 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 an Adapton list with a predicate/mapping function. *)
+        let memo_filter_map (type a) (type b) (module L : Signatures.AListType.BasicS with type atype = atype 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 an Adapton list with a mapping function. *)
+        let memo_map (type a) (type b) (module L : Signatures.AListType.BasicS with type atype = atype 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 an Adapton 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.AListType.BasicS with type atype = atype 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) an Adapton list with an scanning function. *)
+        let memo_scan (type a) (type b) (module L : Signatures.AListType.BasicS with type atype = atype 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 an Adapton 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 = AData.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 Adapton lists of a specific type. *)
+    module Make (R : Hashtbl.SeededHashedType)
+            : S with type atype = atype and type 'a thunk = 'a thunk and type data = R.t and type t = R.t alist and type t' = R.t alist' = struct
+        module L = MakeBasic (R)
+        include L
+
+        (** Create memoizing constructor to quicksort an Adapton 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 an Adapton 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.AData.force (mergesort (lift xs)))
+                | `Nil -> `Nil
+            end
+    end
+end

File Source/AdaptonUtil/BasicAPI.ml

View file
  • Ignore whitespace
+(** Functor that provides a basic polymorphic API for an Adapton 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.
+*)
+
+open AdaptonInternal
+
+module Make (M : Signatures.AType) : 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 = PolyAPI.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/AdaptonUtil/BasicSA.ml

  • Ignore whitespace
-(** 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.
-*)
-
-open AdaptonInternal
-
-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/AdaptonUtil/PolyAPI.ml

View file
  • Ignore whitespace
+(** Functor that provides a polymorphic API for an Adapton 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.
+*)
+
+open AdaptonInternal
+
+module type S = sig
+    type 'a thunk
+    val is_incremental : 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.AType) = struct
+    type 'a thunk = 'a M.thunk * (module Signatures.AType.S with type atype = M.atype and type data = 'a and type t = 'a M.thunk)
+
+    let is_incremental = M.is_incremental
+
+    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/AdaptonUtil/PolySA.ml

  • Ignore whitespace
-(** 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.
-*)
-
-open AdaptonInternal
-
-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/AdaptonUtil/SAArrayMappedTrie.ml

  • Ignore whitespace
-(** Self-adjusting array mapped tries. *)
-
-open AdaptonInternal
-
-(**/**) (* 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/AdaptonUtil/SAList.ml

  • Ignore whitespace
-(** Self-adjusting lists. *)
-
-open AdaptonInternal
-
-(** 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/AdaptonUtil/Signatures.ml

View file
  • Ignore whitespace
 
 open AdaptonInternal
 
-(** {2 Self-adjusting values} *)
+(** {2 Adapton thunks} *)
 
-(** Output module types of modules for self-adjusting values. *)
-module rec SAType : sig
-    (** Module type for self-adjusting values for a specific type. *)
+(** Output module types of modules for Adapton thunks. *)
+module rec AType : sig
+    (** Module type for Adapton thunks for a specific type. *)
     module type S = sig
-        type sa
+        type atype
         type 'a thunk
         type data
         type t
         module Data : Hashtbl.SeededHashedType with type t = data
-        val is_self_adjusting : bool
+        val is_incremental : bool
         val is_lazy : bool
         val id : t -> int
         val hash : int -> t -> int
         val update_thunk : t -> (unit -> data) -> unit
         include MemoN.S with type data := data and type t := t
     end
-end = SAType
+end = AType
 
-(** Module type for self-adjusting values. *)
-module type SAType = sig
-    type sa
+(** Module type for Adapton thunks. *)
+module type AType = sig
+    type atype
     type 'a thunk
-    val is_self_adjusting : bool
+    val is_incremental : 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
+    module Make (R : Hashtbl.SeededHashedType) : AType.S with type atype = atype and type 'a thunk = 'a thunk and type data = R.t and type t = R.t thunk
     val tweak_gc : unit -> unit