1. Yit Phang Khoo
  2. Adapton.ocaml

Commits

Matthew Hammer  committed b801752 Merge

merged

  • Participants
  • Parent commits ccf7777, ab7e13c
  • Branches default

Comments (0)

Files changed (5)

File Makefile

View file
 
 frtime : check $(addprefix ocamlbuild//Frtime.,cmxa a cma cmi)
 
+frtime-test : check ocamlbuild//frtimetest.native
+
 test : check ounit//runtestadapton.d.byte
 
 .PRECIOUS : $(OCAMLBUILD_PRODUCTDIR)/runbenchmark%.py

File Source/Adapton/Types.ml

View file
     let equal ( a, b, c, d as x ) ( a', b', c', d' as x' ) = x == x' || A.equal a a' && B.equal b b' && C.equal c c' && D.equal d d'
 end
 
+module Unit = struct
+    type t = unit
+    let hash seed () = seed
+    let equal = (==)
+end
+
 (** Counter. *)
 module Counter = struct
     type t = int ref

File Source/Frtime.mlpack

View file
 Frtime/Behavior
+Frtime/Time

File Source/Frtime/behavior.ml

View file
 
 	(* Core combinators. *)
 	val const : (module Hashtbl.SeededHashedType with type t = 'a ) -> 'a -> 'a behavior
+	val memo_const : (module Hashtbl.SeededHashedType with type t = 'a ) -> 'a -> 'a behavior
 	val app : ('a->'b) behavior -> (module Hashtbl.SeededHashedType with type t = 'b ) -> 'a behavior -> 'b behavior
 	val memo_app : ('a->'b) behavior -> (module Hashtbl.SeededHashedType with type t = 'b ) -> 'a behavior -> 'b behavior
 	(* TODO:val memo_app ... *)
 	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
 
 	(* Extractors. *)
 	val force : 'a behavior -> 'a
+	val id : 'a behavior -> int
 end
 
 (* Make a behavior, given a SAType. *)
 		let r = R.const c in
 		let t = Tm.const (get_time ()) in
 		(module R), r, t
+
+	(* Universal type hackery. 
+	https://ocaml.janestreet.com/?q=node/18
+	*)
+	module Univ : sig
+		type t
+		val embed: unit -> ('a -> t) * (t -> 'a option)
+	end = struct 
+		type t = exn
+
+		let embed (type s) () =
+			let module M = struct exception E of s end in
+			(fun x -> M.E x), (function M.E x -> Some x | _ -> None)
+	end
 	
+	let memo_const_store = ref [] (*Hashtbl.create 10*)
+	let memo_const (type t) (module H : Hashtbl.SeededHashedType with type t = t) : t -> t behavior = 
+		let module R = M.Make( H) in
+		let memo = 
+			let (of_memo_t, to_memo_t) = Univ.embed () in
+			let rec helper = function
+			| [] ->
+				let m = R.memo (module R.Data) (fun _ c' -> c') in
+				let m' = ref (of_memo_t m) in
+				memo_const_store := m'::!memo_const_store;
+				Printf.printf "memo_const: making new..\n%!";
+				m
+			| h::t ->
+				let m = to_memo_t !h in
+				match m with
+				| None ->
+					Printf.printf "memo_const: not this one\n%!";
+					helper t
+				| Some m' ->
+					Printf.printf "memo_const: found!\n%!";
+					m'
+			in
+			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
+			try
+				Hashtbl.find memo_const_store mod_r
+			with
+			| Not_found -> 
+				let m = R.memo (module R.Data) (fun _ c' -> c') in
+				Hashtbl.add memo_const_store mod_r m
+		in
+		*)
+		(*let r = memo c in*)
+		let t = Tm.const (get_time ()) in
+		fun (c : t) ->
+			(module R), memo c, t
+		
 	let 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.thunk (fun () -> (F.force f) (A.force a)) in
 
 	let force (type a) (((module A), a, _) : a behavior) : a =
 		A.force a
+	
+	(* Returns the id of the underlying thunk. *)
+	let id (type a) ((module A), a, _ : a behavior) : int = 
+		A.id a
 end
 

File Test/frtimetest.ml

View file
+
+open Frtime
+
+module T = Adapton.Types
+module B = Behavior.Make( Adapton.LazySABidi)
+module Tm = Time
+
+let t = B.seconds ()
+let t0 = Tm.to_seconds (B.force t)
+let ellapsed = B.lift (fun t -> int_of_float ((Tm.to_seconds t) -. t0)) (module T.Int) t
+let print_time () =
+	Printf.printf "seconds: %d\n%!" (B.force ellapsed)
+
+let oddGuard = B.lift (fun i -> i mod 2 == 1) (module T.Bool) ellapsed
+let oddCase = B.const (T.makeFunction ()) (fun i -> Printf.printf "seconds: %d\n%!" i)
+let evenCase = B.const (T.makeFunction ()) (fun i -> Printf.printf "even!\n%!")
+let ifb = B.ifb oddGuard oddCase evenCase
+let branched = B.app ifb (module T.Unit) ellapsed
+
+let rec loop i = 
+	(if false then
+		print_time ()
+	else
+		ignore (B.force branched)
+	);
+	(*Unix.sleep 1;*)
+	loop (i+1)
+
+let testUniv () = 
+	let id x = x in
+	(*let module F = T.makeFunction () in*)
+	assert (B.memo_const (module T.Bool) true == B.memo_const (module T.Bool) true);
+	assert (B.memo_const (T.makeFunction ()) id == B.memo_const (T.makeFunction ()) id);
+	assert (B.memo_const (T.makeFunction ()) id != B.memo_const (T.makeFunction ()) (fun x -> x));
+	()
+
+let _ = 
+	assert (oddCase != evenCase);
+	assert (evenCase == evenCase);
+	testUniv ();
+	loop 0
+