svn-r7: satisfied with static performance, for now

darcs-hash:20070416220946-e5a07-58527017f4c0949edbe386974811c9288b59be2b.gz

Makefile

@@ -1,5 +1,6 @@
+include Makefile.rules
 subdirs=server metac scripts paper
-mlflags=-I server
+mlflags+=-I server
 
 default:
 	for d in $(subdirs); do $(MAKE) -C $$d default; done
@@ -22,9 +23,8 @@ reallyclean: clean
 
 method=camlcode
 static-bench:
-	for n in 01 02 04; do \
+	for n in $(sizes); do \
 	  bench/static-overhead $(method) $$n 2>&1 \
 	    | tee bench/static.$(method).$$n; \
 	done
 
-include Makefile.rules

Makefile.rules

@@ -23,3 +23,4 @@ mlflags+=-I +threads
 	$(ocamlc) -c $<
 
 junk=*.cm? *~
+sizes=01 02 04 08 16 32 64

bench/static-overhead

@@ -5,24 +5,35 @@
 #   camlfile
 #   camlcode
 
-set -m
-make run &
+case $1 in
+    caml*)
+        set -m
+        make -C.. run &
+        sleep 4
+        ;;
+esac
 
 echo '========================================' $1-$2
 
 case $1 in
     apache)
         url=http://localhost/static$2.meta
         ;;
+    php)
+        url=http://localhost/static$2.php
+        ;;
     camlfile)
         url=http://localhost:8000/scripts/static$2.meta
         ;;
     camlcode)
         url=http://localhost:8000/static$2
         ;;
 esac
-sleep 4
 
 ab -k -t 30 -c 8 $url 
 
-kill -INT %%
+case $1 in
+    caml*)
+        kill -INT %%
+        ;;
+esac

scripts/Makefile

@@ -1,14 +1,17 @@
-sizes=01 02 04 08 16 32 64
-scripts=dir power gc $(addprefix static, $(sizes))
+include ../Makefile.rules
+
+scripts= power gc $(addprefix static, $(sizes))
+#dir
+mlfiles=$(addsuffix .ml, $(scripts))
 
 default: run
 
 run: all run_
 	cat $^ >$@
 
-all: $(addsuffix .ml, $(scripts))
+all: $(mlfiles) Makefile
 	echo -n >$@
-	for x in $^; do \
+	for x in $(mlfiles); do \
 	  echo '#use "scripts/'$$x'";;' >>$@; \
 	done
 
@@ -21,9 +24,8 @@ static%.meta:
 	mimencode </dev/urandom | dd bs=1K count=$* >$@
 
 clean:
-	rm -f $(junk) all run $(addsuffix .ml, $(scripts))
+	rm -f $(junk) all run $(mlfiles)
 
 reallyclean: clean
 	rm -f static*.meta
 
-include ../Makefile.rules

scripts/run_

@@ -2,12 +2,14 @@ let code_map =
   List.fold_right 
     (fun(uri,scr) map->StringMap.add uri scr map) [
 
+(*
 "/browse",   .! Dir.page ".";
 "/server/",  .! Dir.page "server";
 "/scripts/", .! Dir.page "scripts";
 "/paper/",   .! Dir.page "paper";
 "/metac/",   .! Dir.page "metac";
 "/images/",  .! Dir.page "images";
+ *)
 
 "/power7",   .! Power.page (Num.Int 7);
 "/power17",  .! Power.page (Num.Int 17);
@@ -28,5 +30,6 @@ let code_map =
 #use "server/codeHandler.ml";;       
 Sys.set_signal Sys.sigpipe Sys.Signal_ignore;;
 Sys.catch_break true;;
-Server.start [CodeHandler.run; CodeHandler.redirect;
+Server.start [CodeHandler.run code_map; 
+              CodeHandler.redirect code_map;
               FileHandler.root "."];;

server/Makefile

@@ -1,5 +1,6 @@
 include ../Makefile.rules
-objects=chunked timeStamp stringMap status request logFile server fileHandler 
+objects=chunked timeStamp stringMap status request \
+	logFile server fileHandler codeHandler
 
 default: server.cma
 

server/Makefile.depend

@@ -19,3 +19,8 @@ fileHandler.cmo: logFile.cmi request.cmi server.cmi status.cmi timeStamp.cmi \
 fileHandler.cmx: logFile.cmx request.cmx server.cmx status.cmx timeStamp.cmx \
     fileHandler.cmi 
 fileHandler.cmi: server.cmi 
+codeHandler.cmo: chunked.cmi request.cmi server.cmi status.cmi stringMap.cmi \
+    timeStamp.cmi codeHandler.cmi 
+codeHandler.cmx: chunked.cmx request.cmx server.cmx status.cmx stringMap.cmx \
+    timeStamp.cmx codeHandler.cmi 
+codeHandler.cmi: request.cmi server.cmi stringMap.cmi 

server/chunked.ml

@@ -1,32 +1,56 @@
 
-type t = { chan: out_channel;
-           buf: Buffer.t;
-           size: int }
-
-let create chan size =
-  { chan = chan;
-    buf = Buffer.create size;
-    size = size }
-
-let flush out = 
-  match Buffer.length out.buf with
-    0 -> ()
-  | k ->
-      Printf.fprintf out.chan "%x\r\n" k;
-      Buffer.output_buffer out.chan out.buf;
-      output_string out.chan "\r\n";
-      Buffer.clear out.buf
-
-let puts out str =
-  Buffer.add_string out.buf str;
-  if Buffer.length out.buf >= out.size 
-  then flush out
-
-let putc out char = 
-  Buffer.add_char out.buf char;
-  if Buffer.length out.buf >= out.size
-  then flush out
-
-let finish out =
-  flush out;
-  output_string out.chan "0\r\n"
+type t = 
+    { fd: Unix.file_descr;
+      buf: string;
+      size: int;
+      mutable pos: int
+    }
+
+let descr fd size =
+  { fd  = fd;
+    buf = String.create size;
+    size = size - 2;  (* so there is always room for CR/LF *)
+    pos = 0 }
+
+let channel ch size =
+  flush ch;
+  descr (Unix.descr_of_out_channel ch) size
+
+let write fd s n = 
+  let k = Unix.write fd s 0 n in
+  if n <> k then failwith "Chunked.write: incomplete"
+
+let write_string fd s = 
+  write fd s (String.length s)
+
+let write_chunk_header fd n =
+  write_string fd (Printf.sprintf "%x\r\n" n)
+
+let add_crlf s k = 
+  String.set s k '\r';
+  String.set s (k+1) '\n'
+
+let flush stream =
+  let n = stream.pos in 
+  if n > 0 then
+    (write_chunk_header stream.fd n;
+     add_crlf stream.buf n;
+     write stream.fd stream.buf (n+2);
+     stream.pos <- 0)
+
+let puts stream text =
+  let n = String.length text in
+  if stream.pos + n > stream.size then
+    flush stream;
+  if n > stream.size then
+    (write_chunk_header stream.fd n;
+     write_string stream.fd text;
+     write_string stream.fd "\r\n")
+  else
+    (String.blit text 0 stream.buf stream.pos n;
+     stream.pos <- stream.pos + n)
+
+let finish stream =
+  flush stream;
+  write_string stream.fd "0\r\n"
+

server/chunked.mli

@@ -1,6 +1,6 @@
 type t
-val create : out_channel -> int -> t
+val channel : out_channel -> int -> t
+val descr : Unix.file_descr -> int -> t
+val puts : t -> string -> unit
 val flush : t -> unit
 val finish : t -> unit
-val puts : t -> string -> unit
-val putc : t -> char -> unit

server/codeHandler.ml

@@ -1,23 +1,16 @@
-
-module type CodeHandler =
-  sig
-    val run : Server.handler
-    val redirect : Server.handler
-  end
-
-module CodeHandler : CodeHandler = struct
+  type code = Request.req -> (string -> unit) -> unit
 
   let chunked_response f o =
     output_string o "Transfer-encoding: chunked\r\n\r\n";
     flush o;
-    let ch = Chunked.create o 512 in
+    let ch = Chunked.channel o Server.bufsize in
     f (Chunked.puts ch);
     Chunked.finish ch;
     (* footers go here *)
     output_string o "\r\n"
 
   let buffered_response f o =
-    let buf = Buffer.create 512 in
+    let buf = Buffer.create Server.bufsize in
     f (Buffer.add_string buf);
     Printf.fprintf o "Content-length: %d\r\n" (Buffer.length buf);
     (* headers go here *)
@@ -32,10 +25,10 @@ module CodeHandler : CodeHandler = struct
 
 (* NEED A WAY FOR script function to send additional headers *)
 (* would be nice to support HEAD *)
-  let run req o =
+  let run map req o =
    (match Request.meth req with
       Request.GET ->
-        let code = StringMap.find (Request.uri req) code_map in
+        let code = StringMap.find (Request.uri req) map in
         let fn puts = 
           try 
             (*Mutex.lock mutex;
@@ -63,11 +56,11 @@ module CodeHandler : CodeHandler = struct
    "/dir" --> "/dir/" 
  *)
 
-  let redirect req o =
+  let redirect map req o =
     (match Request.meth req with
       Request.GET ->
         let uri' = Request.uri req ^ "/" in
-        let _ = StringMap.find uri' code_map in
+        let _ = StringMap.find uri' map in
         let url = "http://" in
         let url = url^Unix.gethostname() in
         let url = 
@@ -92,4 +85,3 @@ module CodeHandler : CodeHandler = struct
         Status.Moved_permanently
      | _ -> raise Server.Not_implemented)
 
-end

server/codeHandler.mli

@@ -0,0 +1,3 @@
+type code = Request.req -> (string -> unit) -> unit
+val run : code StringMap.t -> Server.handler
+val redirect : code StringMap.t -> Server.handler

server/fileHandler.ml

@@ -54,7 +54,7 @@ let copy o' (path, st) =
   flush o';
   let o = descr_of_out_channel o' in
   let i = openfile path [O_RDONLY] 0 in
-  let size = min st.st_size 8192 in
+  let size = min st.st_size Server.bufsize in
   let buf = String.create size in
   while
     match read i buf 0 size with

server/server.ml

@@ -1,5 +1,7 @@
 open Unix
 
+let bufsize = 4096
+
 module TMap = Map.Make
     (struct 
       type t = Thread.t

server/server.mli

@@ -6,3 +6,4 @@ exception Forbidden
 
 val start: ?port:int -> ?logfile:string -> handler list -> server
 val stop: server -> unit
+val bufsize: int  (* recommended size for buffering *)