Explicit region support for reset primitives and CCalls

.gitignore

@@ -5,4 +5,5 @@ lib
 config.log
 config.status
 configure
-*~
+src/.ccls-cache
+*~

basis/REGION.sig

@@ -0,0 +1,56 @@
+(** Operations and information about regions. *)
+
+signature REGION =
+  sig
+	(* \/ r. r * unit -> unit *)
+	val resetRegion : unit -> unit
+
+
+	(* \/ r. r * unit -> bool *)
+    val isAtbot : unit -> bool
+
+	(* \/ r. r * unit -> int *)
+	val numPagesOfRegion : unit -> int
+
+	(* \/ r. r * unit -> int *)
+    val memoryUsageOfRegion : unit -> int
+
+
+	val getPageSizeBytes : unit -> int
+
+	val getNumAllocatedPages : unit -> int
+
+	val getFreeListSize: unit -> int
+
+
+	val getThreadFreeListSize : unit -> int
+
+	val giveThreadFreeListToGlobal : unit -> unit
+  end
+
+(**
+[resetRegion [r] ()] resets the explicit region parameter. Warnings will be
+generated if there are any live references into the region, but the region will
+still be reset. This operation it thus not guaranteed to be sound.
+
+
+[isAtbot [r] ()] returns true if the explicit region parameter is at bottom.
+
+[memoryUsage [r] ()] returns an integer describing the memory usage (in bytes)
+of the explicit region parameter.
+
+[numPages [r] ()] returns the number of pages allocated to the explicit region
+
+
+[getPageSizeBytes ()] returns the size of a memory page (in bytes).
+
+[getNumAllocatedPages ()] returns the total number of allocated pages, including
+free list.
+
+[getFreeListSize ()] returns the size of the global free list (in number of pages).
+
+
+[getThreadFreeListSize ()] returns the size of the thread-local free list (in number of pages). If the program is single-threaded, this is equivalent to getFreeListSize ().
+
+[giveThreadFreeListToGlobal] gives pages of thread local free list back to global free list.
+*)

basis/Region.sml

@@ -0,0 +1,25 @@
+(* Region.sml *)
+
+structure Region : REGION =
+  struct
+	fun resetRegion `[r] () = prim `[r] ("resetRegion", ())
+
+
+	fun isAtbot `[r] () = prim `[r] ("is_Atbot", ())
+
+	fun numPagesOfRegion `[r] () = prim `[r] ("num_Pages", ())
+
+	fun memoryUsageOfRegion `[r] () = prim `[r] ("get_Region_Memory_Usage_Bytes", ())
+
+
+	fun getPageSizeBytes () = prim ("get_Page_Size_Bytes", ())
+
+	fun getNumAllocatedPages () = prim ("get_Num_Allocated_Pages", ())
+
+	fun getFreeListSize () = prim ("get_Free_List_Size", ())
+
+
+	fun getThreadFreeListSize () = prim ("get_Thread_Free_List_Size", ())
+
+	fun giveThreadFreeListToGlobal () = prim ("give_Thread_Free_List_To_Global", ())
+  end

basis/basis-reml.mlb

@@ -0,0 +1,2 @@
+basis.mlb
+reml.mlb

basis/par-reml.mlb

@@ -1,6 +1,7 @@
 local
   basis.mlb
 in
+  reml.mlb
   THREAD.sig
   ThreadSeq.sml
   Thread-reml.sml

basis/reml.mlb

@@ -0,0 +1,6 @@
+local
+	basis.mlb
+in
+	REGION.sig
+	Region.sml
+end

examples/fragAssembling/driver.sml

@@ -0,0 +1,101 @@
+signature SERVICE =
+sig
+  type serviceState
+  type conn = int
+  val service : serviceState * conn * string -> conn option * serviceState
+  val emptySs : unit -> serviceState
+  val timeToGC : serviceState -> bool
+  val copySs : serviceState -> serviceState
+en
+
+signature DRIVER =
+sig
+  val run : string -> unit
+end
+
+functor Driver (structure TcpState: TCP_STATE
+				structure Service: SERVICE) :> DRIVER =
+struct
+  open TcpState
+  open SimpleIO
+
+  exception EOF
+
+  (* read line from file. (msgID, packetID, data) *)
+  fun read is =
+	  case inputLine is of
+	    NONE => NONE
+	  | SOME line => 
+		  case String.fields (fn c => c = #";") line of
+			(msgID::pkID::rest) => (
+			  case (Int.fromString msgID, Int.fromString pkID) of
+				(SOME msgID', SOME pkID') => SOME
+				(msgID', (pkID', String.concatWith ";" rest))
+			  | (_, _) => NONE
+			)
+		  | _ => NONE
+
+  fun loop is (arg as (state, ss)) =
+	  let val arg' = 
+		case read is of
+		  NONE => raise EOF
+		| SOME (msgID, packet) =>
+			  case insert (msgID, packet, state) of
+				 NONE => arg
+			   | SOME state1 =>
+				(case extract state1 of
+				   NONE => (print ("state size: " ^ Int.toString (stateSize state1) ^ " bytes\n");
+							(state1, ss))
+				  | SOME (msgID, msg, state2) =>
+					 let
+					   val msg' = msg ^ ""
+					   val (connOpt, ss') = Service.service (ss, msgID, msg')
+
+					   (* Double copy GC on the assemlber state *)
+					   (* val state' = if stateSize state2 > 10000 then *)
+					   (* 				  let val temp = copyState state2 *)
+					   (* 					  val _ = forceResetting state2 *)
+					   (* 					  val _ = forceResetting state *)
+					   (* 					val _ = print ("state size: " ^ Int.toString (stateSize state2) ^ " bytes\n") *)
+					   (* 				  in copyState temp *)
+					   (* 				  end *)
+                       (*              else state2 *)
+					   (* val _ = print ("state size: " ^ Int.toString (stateSize state') ^ " bytes\n") *)
+					   val temp = copyState state2
+					   val _ = forceResetting state
+					   val state' = copyState temp
+					   val state'' =
+						 case connOpt of
+						   NONE => state'
+						 | SOME conn => closeConn (conn, state')
+					   (* val _ = print ("state size: " ^ Int.toString (stateSize state'') ^ " bytes\n")  *)
+
+					   (* Double copy GC on the service state *)
+					   val ss'' = if Service.timeToGC ss' then
+									let val temp = Service.copySs ss'
+									  val _ = forceResetting ss'
+									in Service.copySs temp
+									end
+								  else ss'
+					 in
+					   (state'', ss'')
+					 end
+			  )
+	  in loop is arg'
+  	  end
+
+
+  fun run file =
+	  let
+		val is = openIn file
+		val state = emptyState ()
+		val serviceState = Service.emptySs ()
+	  in
+		(loop is (state, serviceState) handle EOF => (
+		  closeIn is;
+		  print ("Service loop exited\n")
+		)
+		)
+	  end
+end
+

examples/fragAssembling/service.mlb

@@ -0,0 +1,3 @@
+$(SML_LIB)/basis/reml.mlb
+size.sig	
+service.sml

examples/fragAssembling/service.sml

@@ -0,0 +1,90 @@
+(*
+ * service.sml
+ *
+ * Maintains per-connection partial prefixes until a message is complete.
+ * A message is considered complete when two newlines: "\n\n", are found.
+
+ * When a message completes, it is printed to stdout and removed from the
+ * service state.
+ *)
+
+structure Service : SERVICE =
+struct
+  type conn = int
+  type serviceState = (conn * string) list
+
+  fun emptySs () : serviceState = []
+
+  (* removeConn removes the entry for connection c from the state, if it exists *)
+  fun removeConn (_: conn, []: serviceState) = []
+    | removeConn (c, (c',buf)::rest) =
+        if c = c' then rest else (c',buf)::removeConn (c, rest)
+
+  (* lookupConn looks up the buffer for connection c in the state, returning
+	 SOME buf if found, or NONE if not found *)
+  fun lookupConn (_: conn, []: serviceState) = NONE
+    | lookupConn (c, (c',buf)::rest) =
+        if c = c' then SOME buf else lookupConn (c, rest)
+
+  (* addConn adds chunk to the buffer for connection c, or creates a new entry
+	 if c is not in the state *)
+  fun addConn (c, chunk, ss) =
+	  let
+		fun appendChunk (_: conn, _: string, []: serviceState) = []
+		  | appendChunk (c, chunk, (c',buf)::rest) =
+			if c = c' then (c, buf ^ chunk)::rest else (c',buf)::appendChunk (c, chunk, rest)
+	  in
+		case lookupConn (c, ss) of
+		  SOME _ => appendChunk (c, chunk, ss)
+		| NONE => (c, chunk) :: ss
+	  end
+
+  (* Check if string s contains "\n\n". Returns SOME s', where s' is the string
+	 up untill "\n\n", and NONE otherwise *)
+  fun findEnd (s:string) : string option =
+	let
+	  fun go (i:int) =
+		if i >= String.size s - 1 then NONE
+		else if String.substring (s, i, 2) = "\n\n" then
+			SOME (String.substring (s, 0, i + 2))
+		else go (i + 1)
+	in
+	  go 0
+	end
+
+  fun copySs [] = []
+	| copySs ((c, buf)::rest) = (c, buf ^ "") :: copySs rest
+
+  fun timeToGC`[r1 r2 r3] (ss : (conn * string`r1)`r3 list`r2) : bool =
+	  let val total = Region.memoryUsageOfRegion `[r1] ()
+					+ Region.memoryUsageOfRegion `[r2] ()
+					+ Region.memoryUsageOfRegion `[r3] ()
+		  val live = Size.size (Size.list (Size.tup2 Size.int Size.string))  ss
+	  in live * 10 < total
+	  end
+  (* fun timeToGC ss = false *)
+
+  (* fun timeToGC `[r1 r2 r3] (ss : (conn * string`r1)`r3 list`r2) : bool = *)
+  (* 	  let val total = Region.memoryUsageOfRegion `[r1] () *)
+  (* 					+ Region.memoryUsageOfRegion `[r2] () *)
+  (* 					+ Region.memoryUsageOfRegion `[r3] () *)
+  (* 	  in if total < 1000000 then false *)
+  (*        else *)
+  (* 		   let val live = Size.size (Size.list (Size.tup2 Size.int Size.string))  ss *)
+  (* 		   in live * 4 < total *)
+  (* 		   end *)
+  (* 	  end *)
+
+  fun service (ss, c, chunk) =
+	let val tempState = addConn (c, chunk, ss)
+	 in
+	  case lookupConn (c, tempState) of
+		SOME buf =>
+		  (case findEnd buf of
+			 SOME s =>
+				(print ("msg is: \n" ^ s);
+				(SOME c, removeConn (c, tempState)))
+		   | NONE => (NONE, tempState))
+	  | NONE => (NONE, tempState)
+	end
+end

examples/fragAssembling/service_driver.mlb

@@ -0,0 +1,10 @@
+local
+	$(SML_LIB)/basis/basis-reml.mlb
+	tcp_state.sig
+	simpleio.mlb
+	size.mlb
+in
+	tcp_state.sml
+	driver.sml
+	service.sml
+end

examples/fragAssembling/simpleio.mlb

@@ -0,0 +1,2 @@
+$(SML_LIB)/basis/basis.mlb
+simpleio.sml

examples/fragAssembling/simpleio.sml

@@ -0,0 +1,36 @@
+(* A simple I/O library *)
+
+structure SimpleIO = struct
+	type instream = {ic: int, name: string}
+
+	exception CannotOpen
+
+	fun getCtx () : foreignptr = prim("__get_ctx",())
+
+	fun chr_unsafe (i:int):char = prim ("id", i)
+
+	fun input1_ (ic:int) : int = prim ("input1Stream", ic)
+
+	fun input1 ({ic, name} : instream) : char option =
+		let val res = input1_ ic
+		in if res < 0 then NONE
+		   else SOME (chr_unsafe res)
+		end
+
+	fun openIn (f: string) : instream =
+		{ic=prim("openInStream",(getCtx(), f, CannotOpen)),
+		 name=f} handle exn => raise Fail "openIn"
+
+	fun closeIn ({ic,...} : instream) : unit = prim ("closeStream", ic)
+
+	fun inputLine is =
+		let fun loop(acc) =
+			case input1 is
+			  of SOME (c as #"\n") => SOME(implode(rev(c :: acc)))
+			| SOME c => loop(c::acc)
+			| NONE => case acc
+						of [] => NONE
+					  | _ => SOME(implode(rev(#"\n" :: acc)))
+		in loop([])
+		end
+end

examples/fragAssembling/size.mlb

@@ -0,0 +1,3 @@
+$(SML_LIB)/basis/basis.mlb
+	size.sig
+size.sml

examples/fragAssembling/size.sig

@@ -0,0 +1,21 @@
+signature SIZE =
+sig
+  type 'a sz
+
+  (* Primitives *)
+  val int    : int sz
+  val bool   : bool sz
+  val char   : char sz
+  val word   : word sz
+  val real   : real sz
+  val unit   : unit sz
+  val string : string sz
+
+  (* Combinators *)
+  val list   : 'a sz -> 'a list sz
+  val option : 'a sz -> 'a option sz
+  val tup2   : 'a sz -> 'b sz -> ('a * 'b) sz
+  val tup3   : 'a sz -> 'b sz -> 'c sz -> ('a * 'b * 'c) sz
+
+  val size   : 'a sz -> 'a -> int
+end