Commits

Matthew Hammer  committed ded5600 Merge

merged

  • Participants
  • Parent commits 093d504, 470d750

Comments (0)

Files changed (8)

 Results
+.DS_Store
+_build
+_product
+.swp

File Source/Adapton/EagerSATotalOrder.ml

 
 
 (** Functor to make constructors and updaters for eager self-adjusting values of a specific type. *)
-module Make (R : Signatures.EqualsType)
+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
 
     (** 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 =

File Source/Adapton/LazySABidi.ml

 
 
 (** Functor to make constructors for lazy self-adjusting values of a specific type. *)
-module Make (R : Signatures.EqualsType)
+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
 
     (** 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 }
     (**/**)

File Source/Adapton/NonSAEager.ml

 
 
 (** Functor to make constructors for eager non-self-adjusting values of a specific type. *)
-module Make (R : Signatures.EqualsType)
+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
 
     (** 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 }
 

File Source/Adapton/NonSALazy.ml

 
 
 (** Functor to make constructors for lazy non-self-adjusting values of a specific type. *)
-module Make (R : Signatures.EqualsType)
+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
 
     (** 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 }
 

File Source/Adapton/PolySA.ml

 
     let default_equal = (==)
 
-    let const (type a) ?(equal=default_equal) : a -> a thunk =
-        let module S = M.Make (struct type t = a let equal = equal end) in
+    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) ?(equal=default_equal) : (unit -> a) -> a thunk =
-        let module S = M.Make (struct type t = a let equal = equal end) in
+    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 =
 
     let memo (type inp) (type a)
                 ?(inp_hash=default_hash) ?(inp_equal=default_equal)
-                ?(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 equal = equal end) in
+        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
     let memo2 (type inp1) (type inp2) (type a)
                 ?(inp1_hash=default_hash) ?(inp1_equal=default_equal)
                 ?(inp2_hash=default_hash) ?(inp2_equal=default_equal)
-                ?(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 equal = equal end) in
+        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
                 ?(inp1_hash=default_hash) ?(inp1_equal=default_equal)
                 ?(inp2_hash=default_hash) ?(inp2_equal=default_equal)
                 ?(inp3_hash=default_hash) ?(inp3_equal=default_equal)
-                ?(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 equal = equal end) in
+        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
                 ?(inp2_hash=default_hash) ?(inp2_equal=default_equal)
                 ?(inp3_hash=default_hash) ?(inp3_equal=default_equal)
                 ?(inp4_hash=default_hash) ?(inp4_equal=default_equal)
-                ?(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 equal = equal end) in
+        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

File Source/Adapton/Signatures.ml

 (** Module types for {i Adapton}. *)
 
-(** {2 Equals-comparable values *)
-
-module type EqualsType = sig
-    type t
-    val equal : t -> t -> bool
-end
-
 (** {2 Self-adjusting values} *)
 
 (** Output module types of modules for self-adjusting values. *)
         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 equal : 'a thunk -> 'a thunk -> bool
     val refresh : unit -> unit
     val force : 'a thunk -> 'a
-    module Make (R : EqualsType) : 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) : 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
 

File Source/Frtime/behavior.ml

 	*)
 	val merge : 'a behavior -> 'a behavior -> 'a behavior
 	val ifb : bool behavior -> 'a behavior -> 'a behavior -> 'a behavior
-	(* TODO: val memo_ifb : bool behavior -> 'a behavior -> 'a behavior -> 'a behavior*)
 
 	(* Derived combinators. *)
 	val lift : ('a -> 'b) -> (module Hashtbl.SeededHashedType with type t = 'b ) -> 'a behavior -> 'b behavior
 	val lift3 : ('a -> 'b -> 'c -> 'd) -> (module Hashtbl.SeededHashedType with type t = 'd ) -> 'a behavior -> 'b behavior-> 'c behavior -> 'd behavior
 	val lift4 : ('a -> 'b -> 'c -> 'd -> 'e) -> (module Hashtbl.SeededHashedType with type t = 'e ) -> 'a behavior -> 'b behavior-> 'c behavior -> 'd behavior -> 'e behavior
 
+	val memo_lift : ('a -> 'b) -> (module Hashtbl.SeededHashedType with type t = 'b ) -> 'a behavior -> 'b behavior
+	(*
+	val memo_lift2 : ('a -> 'b -> 'c) -> (module Hashtbl.SeededHashedType with type t = 'c ) -> 'a behavior -> 'b behavior-> 'c behavior
+	val memo_lift3 : ('a -> 'b -> 'c -> 'd) -> (module Hashtbl.SeededHashedType with type t = 'd ) -> 'a behavior -> 'b behavior-> 'c behavior -> 'd behavior
+	val memo_lift4 : ('a -> 'b -> 'c -> 'd -> 'e) -> (module Hashtbl.SeededHashedType with type t = 'e ) -> 'a behavior -> 'b behavior-> 'c behavior -> 'd behavior -> 'e behavior
+	*)
+	
 	(* Alarm. *)
 	val seconds : unit -> time behavior
 
 
 	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
+	(* Requirement: Always force 'a thunk before time thunk. *)
 
 	let const (type t) (module H : Hashtbl.SeededHashedType with type t = t) (c : t) : t behavior = 
 		let module R = M.Make( H) in
 	
 	let memo_app (type a) (type b) (((module F), f, tf) : (a -> b) behavior) (module B : Hashtbl.SeededHashedType with type t = b) (((module A), a, ta) : a behavior) : b behavior = 
 		let module R = M.Make( B) in
-		let r = R.memo2 (module F) (module A) (fun memo f' a' ->
-			(*R.force (memo f' a')*)
-			(F.force f') (A.force a')
-		) f a
-		in
+		let memo = R.memo2 (module F.Data) (module A.Data) (fun _ f' a' -> f' a') in
+		let r = R.thunk (fun () -> R.force (memo (F.force f) (A.force a))) in
 		let t = Tm.thunk (fun () -> max_time [ Tm.force tf; Tm.force ta]) in
 		(module R), r, t
 
 		let f' = lift3 f mF a b c in
 		app f' (module E) d
 
+	let memo_lift (type a) (type b) (f : a -> b) (module B : Hashtbl.SeededHashedType with type t = b) ((module A), a, ta : a behavior) : b behavior =
+		let module R = M.Make( B) in
+		let memo = R.memo (module A.Data) (fun _ -> f) in
+		let r = R.thunk (fun () -> R.force (memo (A.force a))) in
+		let t' = Tm.const (get_time ()) in
+		let t = Tm.thunk (fun () -> max_time [ Tm.force t'; Tm.force ta]) in
+		(module R), r, t
+		
+	(* Can't be compositional here because memoizing on closures does not work. *)
+	let memo_lift2 (type a) (type b) (type c) (f : a -> b -> c) (module C : Hashtbl.SeededHashedType with type t = c) ((module A), a, ta : a behavior) ((module B), b, tb : b behavior) : c behavior =
+		let module R = M.Make( C) in
+		let memo = R.memo2 (module A.Data) (module B.Data) (fun _ -> f) in
+		let r = R.thunk (fun () -> R.force (memo (A.force a) (B.force b))) in
+		let t' = Tm.const (get_time ()) in
+		let t = Tm.thunk (fun () -> max_time [ Tm.force t'; Tm.force ta; Tm.force tb]) in
+		(module R), r, t
+		(*
+		let mF = T.makeFunction () in
+		let f' = memo_lift f mF a in
+		memo_app f' (module C) b
+		*)
+
+	let memo_lift3 (type a) (type b) (type c) (type d) (f : a -> b -> c -> d) (module D : Hashtbl.SeededHashedType with type t = d) ((module A), a, ta : a behavior) ((module B), b, tb : b behavior) ((module C), c, tc : c behavior) : d behavior =
+		let module R = M.Make( D) in
+		let memo = R.memo3 (module A.Data) (module B.Data) (module C.Data) (fun _ -> f) in
+		let r = R.thunk (fun () -> R.force (memo (A.force a) (B.force b) (C.force c))) in
+		let t' = Tm.const (get_time ()) in
+		let t = Tm.thunk (fun () -> max_time [ Tm.force t'; Tm.force ta; Tm.force tb; Tm.force tc]) in
+		(module R), r, t
+
+	let memo_lift4 (type a) (type b) (type c) (type d) (type e) (f : a -> b -> c -> d -> e) (module E : Hashtbl.SeededHashedType with type t = e) ((module A), a, ta : a behavior) ((module B), b, tb : b behavior) ((module C), c, tc : c behavior) ((module D), d, td : d behavior) : e behavior =
+		let module R = M.Make( E) in
+		let memo = R.memo4 (module A.Data) (module B.Data) (module C.Data) (module D.Data) (fun _ -> f) in
+		let r = R.thunk (fun () -> R.force (memo (A.force a) (B.force b) (C.force c) (D.force d))) in
+		let t' = Tm.const (get_time ()) in
+		let t = Tm.thunk (fun () -> max_time [ Tm.force t'; Tm.force ta; Tm.force tb; Tm.force tc; Tm.force td]) in
+		(module R), r, t
+
 	(* Take on the value of the most recently updated behavior. *)
 	let merge (type a) (((module A), a, ta) : a behavior) (( _, b, tb) : a behavior) : a behavior =
+		(* Precompute force to satisfy requirement and maintain consistency. *)
+		ignore (A.force a);
+		ignore (A.force b);
+		let t = Tm.const (max_time [ Tm.force ta; Tm.force tb]) in
 		let r = A.thunk (fun () ->
 			let ta' = Tm.force ta in
 			let tb' = Tm.force tb in
 			A.force begin
 				(* ta < tb -> !(ta >= tb) *)
-				if cmp_time ta' tb' then
+				if cmp_time ta' tb' then (
+					Tm.update_const t tb';
 					b
-				else
+				) else (
+					Tm.update_const t ta';
 					a
+				)
 			end
 		)
 		in
-		let t = Tm.thunk (fun () -> max_time [ Tm.force ta; Tm.force tb]) in (* TODO: switch to a tmStore? *)
+		(*let t = Tm.thunk (fun () -> max_time [ Tm.force ta; Tm.force tb]) in (* TODO: switch to a tmStore? *)*)
 		(module A), r, t
 
 	(*
 		let t = Tm.thunk (fun () -> max_time [ Tm.force tg; Tm.force ta; Tm.force tb]) in
 		(module A), r, t
 
-	(*
-	let memo_ifb (type a) (((module G), g, tg) : bool behavior) (((module A), a, ta) : a behavior) ((_, b, tb) : a behavior) : a behavior = 
-		let memo_a = A.memo (module A) (fun a' -> a') in
-		let memo_b = A.memo (module A) (fun a' -> a') in
-		let r = A.thunk (fun () ->
-			if G.force g then
-				memo_a (A.force a)
-			else
-				memo_b (A.force b)
-		)
-		in
-		let t = Tm.thunk (fun () -> max_time [ Tm.force tg; Tm.force ta; Tm.force tb]) in
-		(module A), r, t
-	*)
-
-	
 	let seconds_store = ref None
 	let seconds () : time behavior = 
 		let c = !seconds_store in
 			in
 			S.set_signal S.sigalrm handle;
 			ignore (U.alarm 1);
-			(*let beh = (module Tm : (time sa_mod)), r, r in*)
 			let beh = (module Tm : SAType.S with type sa = M.sa and type data = time and type t = time M.thunk), r, r in
 			seconds_store := Some beh;
 			beh
 		A.force a
 end
 
-(*
-module type Test = sig
-	type t
-	val eq : t -> t -> bool
-end
-
-module TestA = struct type t = int  let eq x y = x = y end
-module TestB = struct type t = float let eq x y = x = y end
-
-
-(*
-type 'b behavior = (module SA with type sa = ? and type 'a thunk = ?) * ?
-*)
-
-(*let const (type t) (module M : Test with type t = t) (v:t) = v*)
-(*let const (type t) (module M : Test with type t = t) (v:t) = (module M)*)
-let const (type t) (module H : SeededHashedType with type t = t) (v:t) : t behavior = (module M : Test with type t = t), v
-
-let i = const (module TestA) 4
-let f = const (module TestB) 4.4
-
-let b_eq (type a) (x:a behavior) (y:a behavior) = 
-	let (module A) = (fst x) in
-	A.eq (snd x) (snd y) 
-module type HSHT = Hashtbl.SeededHashedType
-
-class ['a] behavior = object
-	val m : (module SAType.S with type t = 'a)
-	val v : m.t thunk
-end
-
-let const (module C : HSHT) c = (*(module C : HSHT) * c*)
-	let (module M : )
-	
-*)