Skip to content

Commit

Permalink
[fix] libnet: Quick temporary fix for genproto dependency analysis. R…
Browse files Browse the repository at this point in the history 
…aft of unused value fixes.
  • Loading branch information
@nrs135
nrs135 committed Nov 21, 2012
1 parent cc4975a commit d2218c4
Show file tree
Hide file tree
Showing 20 changed files with 70 additions and 59 deletions.
2 changes: 1 addition & 1 deletion compiler/protocols/genproto.ml
View file
Expand Up @@ -286,7 +286,7 @@ let gen_functor ~protocol parserprefix parsername arg lst types startfun =
@ [O.Verbatim launch] @ [O.Verbatim launch]
in in
O.Open [Ident.source "Base"] O.Open [Ident.source "Base"]
:: O.Open [Ident.source "Scheduler"] (*:: O.Open [Ident.source "Scheduler"]*)
:: O.Open [Ident.source (String.capitalize parsername)] :: O.Open [Ident.source (String.capitalize parsername)]
(*:: List.map (function MOpen s -> O.Open [Ident.source s] | _ -> assert false) opens*) (*:: List.map (function MOpen s -> O.Open [Ident.source s] | _ -> assert false) opens*)
:: List.map (function G.Debugvar s -> O.Verbatim ("#<Debugvar:"^s^">") | _ -> assert false) dbgvars :: List.map (function G.Debugvar s -> O.Verbatim ("#<Debugvar:"^s^">") | _ -> assert false) dbgvars
Expand Down
2 changes: 1 addition & 1 deletion compiler/protocols/reorder_functions.ml
View file
Expand Up @@ -118,7 +118,7 @@ let do_it lst =
let funs = B.Hashtbl.create <| L.length lst in let funs = B.Hashtbl.create <| L.length lst in
let () = init_table funs lst in let () = init_table funs lst in
let deps_list = get_dep_list funs lst in let deps_list = get_dep_list funs lst in
let ccl = reorder deps_list in let ccl = [List.flatten(reorder deps_list)] in
(* Tag functions as normal or [mutually-]recursive *) (* Tag functions as normal or [mutually-]recursive *)
try try
L.map (flag_as_rec funs) ccl L.map (flag_as_rec funs) ccl
Expand Down
4 changes: 2 additions & 2 deletions compiler/protocols/rewrite_funs.ml
View file
Expand Up @@ -114,13 +114,13 @@ and receive rfn success errors timeout =
let clauses = match timeout with let clauses = match timeout with
| None -> clauses | None -> clauses
| Some (G.Timeout ( _, what_to_do)) -> | Some (G.Timeout ( _, what_to_do)) ->
let clause = G.Case ((G.Constr ("Timeout", []), None), what_to_do) in let clause = G.Case ((G.Constr ("Scheduler.Timeout", []), None), what_to_do) in
clause :: clauses clause :: clauses
| _ -> assert false in | _ -> assert false in
let clauses = let clauses =
match L.map rewrite_clause clauses with match L.map rewrite_clause clauses with
| [] -> [O.PatAny, None, O.Const O.Unit] | [] -> [O.PatAny, None, O.Const O.Unit]
| [((O.PatConstructor ([timeout], _) as patconst), g, re)] when Ident.stident timeout = "Timeout" -> | [((O.PatConstructor ([timeout], _) as patconst), g, re)] when Ident.stident timeout = "Scheduler.Timeout" ->
(patconst, g, re) :: [O.PatAny, None, O.Const O.Unit] (patconst, g, re) :: [O.PatAny, None, O.Const O.Unit]
| otherwise -> otherwise | otherwise -> otherwise
in O.Var ( in O.Var (
Expand Down
6 changes: 3 additions & 3 deletions ocamllib/libnet/cluster.ml
View file
Expand Up @@ -74,7 +74,7 @@ let get_id dc addr =
| -1 -> failwith (Printf.sprintf "[Cluster] Unknown clunser ode... %s" (sockaddr_to_string addr)) | -1 -> failwith (Printf.sprintf "[Cluster] Unknown clunser ode... %s" (sockaddr_to_string addr))
| i -> i | i -> i


let node_id_to_debug_string = string_of_int (*let node_id_to_debug_string = string_of_int*)


let node_id_to_string dc node_id = let node_id_to_string dc node_id =
let addr = get_addr dc node_id in let addr = get_addr dc node_id in
Expand Down Expand Up @@ -131,9 +131,9 @@ let random_server_id ?including_myself dc =
let servers_no ?including_myself dc = let servers_no ?including_myself dc =
List.length (all_server_ids ?including_myself dc) List.length (all_server_ids ?including_myself dc)


let all_server_endpoints ?including_myself dc = (*let all_server_endpoints ?including_myself dc =
let ss = all_server_ids ?including_myself dc in let ss = all_server_ids ?including_myself dc in
List.map (get_addr dc) ss List.map (get_addr dc) ss*)


let node_id_to_int node_id = node_id let node_id_to_int node_id = node_id


Expand Down
4 changes: 2 additions & 2 deletions ocamllib/libnet/directory.ml
View file
Expand Up @@ -23,7 +23,7 @@ module Hashtbl = Base.Hashtbl


(* ********************************************************) (* ********************************************************)
(* DEFINE TYPE FOR HLNET PROTOCOL *************************) (* DEFINE TYPE FOR HLNET PROTOCOL *************************)
type kind = Dir | Loc (*type kind = Dir | Loc*)


type who = Me | Other of Unix.inet_addr type who = Me | Other of Unix.inet_addr


Expand Down Expand Up @@ -124,7 +124,7 @@ module ExtendHash = struct
| x -> x | x -> x
end end


let rec make ?(err_cont=fun _ -> let make ?(err_cont=fun _ ->
#<If> Logger.warning "[DIRECTORY] Make : Uncaught exn" #<If> Logger.warning "[DIRECTORY] Make : Uncaught exn"
#<Else> () #<Else> ()
#<End>) #<End>)
Expand Down
1 change: 1 addition & 0 deletions ocamllib/libnet/ftpClientCore.proto
View file
Expand Up @@ -70,6 +70,7 @@
-include "ftpMessages.proto" -include "ftpMessages.proto"


{{ {{
let _ = (compare_msg,get_msg_name,ec2ecsa)
let dlog sep code _msg = Logger.debug "<<< %d%s%s" code sep _msg let dlog sep code _msg = Logger.debug "<<< %d%s%s" code sep _msg
let eilog = dlog "-" let eilog = dlog "-"
let ilog = dlog " " let ilog = dlog " "
Expand Down
4 changes: 4 additions & 0 deletions ocamllib/libnet/ftpServerCore.proto
View file
Expand Up @@ -89,6 +89,10 @@
rt_proto : rt_proto; rt_proto : rt_proto;
} }


{{
let _ = ec2ecsa
}}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% General states %% %% General states %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Expand Down
76 changes: 38 additions & 38 deletions ocamllib/libnet/hlnet.ml
View file
Expand Up @@ -38,10 +38,10 @@ let protocol_version = 1


let gc_finalise _sched = Scheduler.finalise _sched let gc_finalise _sched = Scheduler.finalise _sched


let apply_fun_option opt = (*let apply_fun_option opt =
match opt with match opt with
| Some f -> f | Some f -> f
| None -> fun _ -> () | None -> fun _ -> ()*)




(* ------------------------------------------------------------ *) (* ------------------------------------------------------------ *)
Expand Down Expand Up @@ -268,15 +268,15 @@ let hexprint ?(chars_per_line=32) s =
String.blit sfx 0 buf (String.length buf - sfxlen) sfxlen; String.blit sfx 0 buf (String.length buf - sfxlen) sfxlen;
buf buf


let int64_to_debug_string ld = (*let int64_to_debug_string ld =
let color = 31 + Int64.to_int (Int64.rem ld (Int64.of_int 6)) in let color = 31 + Int64.to_int (Int64.rem ld (Int64.of_int 6)) in
Printf.sprintf "[%dm%016Lx[39m" color ld Printf.sprintf "[%dm%016Lx[39m" color ld*)


let int_to_debug_string i = let int_to_debug_string i =
let color = 31 + i mod 6 in let color = 31 + i mod 6 in
Printf.sprintf "[%dm%016x" color i Printf.sprintf "[%dm%016x" color i


let print_marshalled str beg = (*let print_marshalled str beg =
let s = ref "" in let s = ref "" in
for i = beg to String.length str -1 do for i = beg to String.length str -1 do
let topr = let topr =
Expand All @@ -286,13 +286,13 @@ let print_marshalled str beg =
else Char.escaped str.[i] in else Char.escaped str.[i] in
s := !s ^ "-" ^ topr s := !s ^ "-" ^ topr
done; done;
!s^"[0m" !s^"[0m"*)


let string_of_htable keystr valstr ht = (*let string_of_htable keystr valstr ht =
Format.fprintf Format.str_formatter "(%d) - %a" Format.fprintf Format.str_formatter "(%d) - %a"
(H.length ht) (H.length ht)
(fun f -> H.iter (fun k v -> Format.fprintf f "{ %s+%s }|" (keystr k) (valstr v))) ht; (fun f -> H.iter (fun k v -> Format.fprintf f "{ %s+%s }|" (keystr k) (valstr v))) ht;
Format.flush_str_formatter () Format.flush_str_formatter ()*)


(* -- Type specific -- *) (* -- Type specific -- *)


Expand Down Expand Up @@ -421,19 +421,19 @@ let is_channel_listening ch =
(* Serialisation / deserialisation *) (* Serialisation / deserialisation *)
(* ------------------------------------------------------------ *) (* ------------------------------------------------------------ *)


let write_int64 buf offset i = (*let write_int64 buf offset i =
let (>>) = Int64.shift_right_logical in let (>>) = Int64.shift_right_logical in
for byte = 0 to 7 do for byte = 0 to 7 do
buf.[offset + byte] <- Char.chr (Int64.to_int (i >> (8* (7 - byte))) land 0xFF) buf.[offset + byte] <- Char.chr (Int64.to_int (i >> (8* (7 - byte))) land 0xFF)
done done*)


let read_int64 buf offset = (*let read_int64 buf offset =
let (<<) = Int64.shift_left in let (<<) = Int64.shift_left in
let rec aux offset value byte = let rec aux offset value byte =
if byte >= 8 then value else if byte >= 8 then value else
aux offset (Int64.logor value (Int64.of_int (Char.code buf.[offset+byte]) << (8 * (7 - byte)))) (byte+1) aux offset (Int64.logor value (Int64.of_int (Char.code buf.[offset+byte]) << (8 * (7 - byte)))) (byte+1)
in in
aux offset Int64.zero 0 aux offset Int64.zero 0*)


let write_int buf offset i = let write_int buf offset i =
for byte = 0 to 7 do for byte = 0 to 7 do
Expand Down Expand Up @@ -595,7 +595,7 @@ struct
- a string using the serialisation functions provided by the user in the channel_spec - a string using the serialisation functions provided by the user in the channel_spec
*) *)


let message_shebang = 'M' (*let message_shebang = 'M'*)
let shebang_length = 1 let shebang_length = 1
let message_header_length = shebang_length + 8 + 8 let message_header_length = shebang_length + 8 + 8


Expand Down Expand Up @@ -731,7 +731,7 @@ module Connection : sig


(** Same as [get], but does not attempt to connect, just return the connection (** Same as [get], but does not attempt to connect, just return the connection
if existing *) if existing *)
val find: endpoint -> connection option (*val find: endpoint -> connection option*)


(** Registers an already open low-level connection (e.g. returned by (** Registers an already open low-level connection (e.g. returned by
[accept]). Warning, the connection will be closed if you let the returned [accept]). Warning, the connection will be closed if you let the returned
Expand Down Expand Up @@ -766,7 +766,7 @@ module Connection : sig


val dump: unit -> string val dump: unit -> string


val live_channels: unit -> int (*val live_channels: unit -> int*)
end = struct end = struct


let table = Wconnections.create 11 let table = Wconnections.create 11
Expand Down Expand Up @@ -895,7 +895,7 @@ end = struct
gc_finalise sched disconnect connection; gc_finalise sched disconnect connection;
connection connection


let find = Wconnections.get_opt table (*let find = Wconnections.get_opt table*)


let register_channel channel = let register_channel channel =
let channel = channel_to_black channel in let channel = channel_to_black channel in
Expand Down Expand Up @@ -931,10 +931,10 @@ end = struct
(fun c acc -> Printf.sprintf "%s%s\n" acc (connection_to_string c)) (fun c acc -> Printf.sprintf "%s%s\n" acc (connection_to_string c))
table "" table ""


let live_channels () = (*let live_channels () =
Wconnections.fold Wconnections.fold
(fun c acc -> acc + Wchannels.count c.channels) (fun c acc -> acc + Wchannels.count c.channels)
table 0 table 0*)
end end




Expand Down Expand Up @@ -973,7 +973,7 @@ module PolyHash (V :
sig sig
type key type key
type ('out', 'in') value type ('out', 'in') value
val key2str: key -> string (*val key2str: key -> string*)
end) : end) :
sig sig
(* This module provides semi-heterogeneous hashtables, needed to handle channels (* This module provides semi-heterogeneous hashtables, needed to handle channels
Expand All @@ -989,9 +989,9 @@ sig
val find : t -> V.key -> ('out','in') V.value option val find : t -> V.key -> ('out','in') V.value option
val mem : t -> V.key -> bool val mem : t -> V.key -> bool
val remove : t -> V.key -> unit val remove : t -> V.key -> unit
val update : t -> V.key -> (('out','in') V.value -> ('out','in') V.value) -> unit (*val update : t -> V.key -> (('out','in') V.value -> ('out','in') V.value) -> unit*)
val fold : t -> (V.key -> ('out','in') V.value -> 'acc -> 'acc) -> 'acc -> 'acc (*val fold : t -> (V.key -> ('out','in') V.value -> 'acc -> 'acc) -> 'acc -> 'acc*)
val to_string : t -> string (*val to_string : t -> string*)
end = struct end = struct
type t = (V.key, Obj.t) H.t type t = (V.key, Obj.t) H.t


Expand All @@ -1006,21 +1006,21 @@ end = struct


let mem = H.mem let mem = H.mem


let to_string tbl = (*let to_string tbl =
BaseList.print V.key2str (H.fold (fun k _v acc -> k::acc) tbl []) BaseList.print V.key2str (H.fold (fun k _v acc -> k::acc) tbl [])*)


let remove tbl k = let remove tbl k =
H.remove tbl k H.remove tbl k


let update tbl k f = (*let update tbl k f =
try try
let v = H.find tbl k in let v = H.find tbl k in
let new_v = Obj.repr (f ((Obj.obj v) : ('out','in') V.value)) in let new_v = Obj.repr (f ((Obj.obj v) : ('out','in') V.value)) in
H.replace tbl k new_v H.replace tbl k new_v
with Not_found -> () with Not_found -> ()*)


let fold (tbl : t) f acc = (*let fold (tbl : t) f acc =
H.fold (fun k v acc -> f (k:V.key) ((Obj.obj v) : ('out','in') V.value) acc) tbl acc H.fold (fun k v acc -> f (k:V.key) ((Obj.obj v) : ('out','in') V.value) acc) tbl acc*)
end end




Expand All @@ -1029,15 +1029,15 @@ end
module EP : sig module EP : sig
val add: endpoint -> ('out', 'in') connection_handler -> unit val add: endpoint -> ('out', 'in') connection_handler -> unit
val find: endpoint -> ('out', 'in') connection_handler option val find: endpoint -> ('out', 'in') connection_handler option
val update: endpoint -> (('out', 'in') connection_handler -> ('out', 'in') connection_handler) -> unit (*val update: endpoint -> (('out', 'in') connection_handler -> ('out', 'in') connection_handler) -> unit*)
val remove: endpoint -> unit val remove: endpoint -> unit
val to_string: unit -> string (*val to_string: unit -> string*)
end = struct end = struct


module E = struct module E = struct
type key = endpoint type key = endpoint
type ('out','in') value = ('out', 'in') connection_handler type ('out','in') value = ('out', 'in') connection_handler
let key2str = endpoint_to_string (*let key2str = endpoint_to_string*)
end end


module EPH = PolyHash(E) (** Hash from (local) endpoints to their connection handler *) module EPH = PolyHash(E) (** Hash from (local) endpoints to their connection handler *)
Expand All @@ -1056,10 +1056,10 @@ end = struct
let remove ep = let remove ep =
EPH.remove table ep EPH.remove table ep


let update ep f = (*let update ep f =
EPH.update table ep f EPH.update table ep f*)


let to_string () = EPH.to_string table (*let to_string () = EPH.to_string table*)
end end




Expand All @@ -1068,13 +1068,13 @@ end
module ChanH : sig module ChanH : sig
val add : ('out','in') channel -> unit val add : ('out','in') channel -> unit
val find: channel_id -> black_channel option val find: channel_id -> black_channel option
val mem: channel_id -> bool (*val mem: channel_id -> bool*)


val remove: channel_id -> unit val remove: channel_id -> unit
(** If [propagate] (the default), inform the other end of the deletion *) (** If [propagate] (the default), inform the other end of the deletion *)


val to_string: unit -> string val to_string: unit -> string
val count: unit -> int (*val count: unit -> int*)
end = struct end = struct


let table = H.create 89 let table = H.create 89
Expand All @@ -1084,7 +1084,7 @@ end = struct
H.replace table chan.id (channel_to_black chan) H.replace table chan.id (channel_to_black chan)
(* Strong ref, CH is for channels with pending operations, we hold it in memory *) (* Strong ref, CH is for channels with pending operations, we hold it in memory *)


let mem id = H.mem table id (*let mem id = H.mem table id*)


let find id = Base.Hashtbl.find_opt table id let find id = Base.Hashtbl.find_opt table id


Expand All @@ -1101,7 +1101,7 @@ end = struct
(fun id _chan acc -> Printf.sprintf "%s, %s" acc (channel_id_to_debug_string id)) (fun id _chan acc -> Printf.sprintf "%s, %s" acc (channel_id_to_debug_string id))
table "" table ""


let count () = H.length table (*let count () = H.length table*)
end end


(* Channels have two special closing treatments: (* Channels have two special closing treatments:
Expand Down
2 changes: 1 addition & 1 deletion ocamllib/libnet/http/accept.ml
View file
Expand Up @@ -18,7 +18,7 @@
(* Accept: see the interface file for docs. *) (* Accept: see the interface file for docs. *)
open Printf open Printf
open HttpTools open HttpTools
open HttpServerTypes (*open HttpServerTypes*)


(* depends *) (* depends *)
module List = BaseList module List = BaseList
Expand Down
2 changes: 1 addition & 1 deletion ocamllib/libnet/http/requestLex.mll
View file
Expand Up @@ -18,7 +18,7 @@
(* The lexer definition *) (* The lexer definition *)
{ {
open RequestParse open RequestParse
open Printf (*open Printf*)


type lexical_error = Illegal_character type lexical_error = Illegal_character


Expand Down
2 changes: 1 addition & 1 deletion ocamllib/libnet/http/requestParse.mly
View file
Expand Up @@ -20,7 +20,7 @@
%{ %{
open Requestdef open Requestdef
open RequestType open RequestType
open Printf (*open Printf*)
%} %}


/*(* Tokens *)*/ /*(* Tokens *)*/
Expand Down
4 changes: 2 additions & 2 deletions ocamllib/libnet/http/requestRaw.ml
View file
Expand Up @@ -15,8 +15,8 @@
You should have received a copy of the GNU Affero General Public License You should have received a copy of the GNU Affero General Public License
along with Opa. If not, see <http://www.gnu.org/licenses/>. along with Opa. If not, see <http://www.gnu.org/licenses/>.
*) *)
open Printf (*open Printf*)
open Option (*open Option*)
open Rp_typ open Rp_typ
open Rp_hdr open Rp_hdr
open Requestdef open Requestdef
Expand Down
2 changes: 1 addition & 1 deletion ocamllib/libnet/http/requestUlex.ml
View file
Expand Up @@ -17,7 +17,7 @@
*) *)
(* The lexer definition *) (* The lexer definition *)
open RequestParse open RequestParse
open Printf (*open Printf*)


type lexical_error = Illegal_character type lexical_error = Illegal_character


Expand Down
4 changes: 2 additions & 2 deletions ocamllib/libnet/http/userCompat.ml
View file
Expand Up @@ -20,9 +20,9 @@
module String = BaseString module String = BaseString
module List = BaseList module List = BaseList


open Printf (*open Printf*)
open UserCompatType open UserCompatType
open Rp_brow (*open Rp_brow*)


module UCT = UserCompatType module UCT = UserCompatType
module HSCp = HttpServerCore_parse module HSCp = HttpServerCore_parse
Expand Down

0 comments on commit d2218c4

Please sign in to comment.