One-place cache per connection speeds up name lookup

server/node.ml

@@ -49,6 +49,17 @@ let name_of_string str =
   let template = {label = str; binding = None} in
   NameTable.merge name_table template
 
+let caching_name_of_string () =
+  let cache = ref None in
+  fun str ->
+    match !cache with
+      | Some ({label = k} as n) when k = str ->
+	n
+      | _ ->
+	let n = name_of_string str in
+	cache := Some n;
+	n
+
 let local_container_name () = "server"
 
 let make class_name handler = {

server/relay.ml

@@ -28,10 +28,11 @@ let send_error ch message details =
 let send_sexp_syntax_error ch explanation =
   send_error ch explanation (Str "http://people.csail.mit.edu/rivest/Sexp.txt")
 
-let dispatch_message n ch m =
-  match m with
+let dispatch_message n ch =
+  let lookup = Node.caching_name_of_string () in
+  function
     | Message.Post (Str name, body, token) ->
-      Node.send_ignore' name body
+      Node.send_ignore (lookup name) body
     | Message.Subscribe (Str filter, sink, name, Str reply_sink, Str reply_name) ->
       (match_lwt Node.bind (Node.name_of_string filter, n) with
 	| true ->
@@ -46,7 +47,7 @@ let dispatch_message n ch m =
       (match_lwt Node.unbind (Node.name_of_string token) with
 	| true -> return ()
 	| false -> Log.warn "Unbind failed" [Str token])
-    | _ ->
+    | m ->
       send_error ch "Message not understood" (Message.sexp_of_message m)
 
 let issue_banner cin cout =
@@ -66,9 +67,10 @@ let relay_handler (_, mtx, _, cout) _ m =
 let relay_mainloop (peername, mtx, cin, cout) n =
   let write_sexp sexp = Lwt_mutex.with_lock mtx (fun () -> output_sexp cout sexp) in
   (try_lwt
+     let dispatcher = dispatch_message n write_sexp in
      while_lwt true do
        lwt message_sexp = Sexp.input_sexp cin in
-       dispatch_message n write_sexp (Message.message_of_sexp message_sexp)
+       dispatcher (Message.message_of_sexp message_sexp)
      done
    with
      | Sexp.Syntax_error explanation ->