Menu
▾
▴
[Krobot-commits] [SCM] krobot branch, master, updated. 80af4a55967b9189f8263c73a7f173e532b0d367
|
From: Jérémie D. <Ba...@us...> - 2010-02-15 22:50:30
|
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "krobot".
The branch, master has been updated
via 80af4a55967b9189f8263c73a7f173e532b0d367 (commit)
from fdb6a0d68539867257a8498a43564647205aa20e (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 80af4a55967b9189f8263c73a7f173e532b0d367
Author: Jérémie Dimino <je...@di...>
Date: Mon Feb 15 23:49:50 2010 +0100
Rewrite the Card module
-----------------------------------------------------------------------
Changes:
diff --git a/PC_Mainboard/driver/card.ml b/PC_Mainboard/driver/card.ml
index 2bb819f..a82451f 100644
--- a/PC_Mainboard/driver/card.ml
+++ b/PC_Mainboard/driver/card.ml
@@ -9,10 +9,6 @@
open Lwt
-(* Log an error message and exit: *)
-let fatal fmt =
- Printf.ksprintf (fun txt -> Log#fatal "%s" txt; exit 2) fmt
-
(* +-----------------------------------------------------------------+
| Messages |
+-----------------------------------------------------------------+ *)
@@ -61,7 +57,7 @@ let forge_message msg =
buf.[Protocol.up_cmd] <- Char.chr msg.command;
buf.[Protocol.up_err] <- Char.chr msg.error;
if String.length msg.data > 52 then
- fatal "message trop grand pour être envoyé"
+ Printf.ksprintf invalid_arg "message body too big: %d > 52" (String.length msg.data)
else begin
String.blit msg.data 0 buf Protocol.up_data (String.length msg.data);
buf
@@ -72,10 +68,9 @@ let forge_message msg =
+-----------------------------------------------------------------+ *)
exception Card_closed
+exception Card_crashed of string
-module SerialMap = Map.Make(struct type t = serial let compare = compare end)
-
-type state = [ `Running | `Opening | `Closed ]
+module Int_map = Map.Make(struct type t = int let compare = compare end)
(* Type of a up and running card *)
type card = {
@@ -83,7 +78,7 @@ type card = {
(* Pool de serial disponibles, comme il n'y a que 256 serial
disponibles on évite de juste incrémenter un compteur au pif. *)
- mutable reply_waiters : string Lwt.u SerialMap.t;
+ mutable reply_waiters : string Lwt.u Int_map.t;
(* Threads en attente d'une réponse *)
handle : USB.handle;
@@ -96,191 +91,177 @@ type card = {
mutex : Lwt_mutex.t;
(* Mutex pour envoyer des commandes, les cartes n'aiment pas les
appels parallèles. *)
-}
-type wrapper_state =
- | Running of card
- | Opening of unit Lwt.t
- | Closed
+ mutable events : (string -> unit) Lwt_sequence.t Int_map.t;
+ (* Connected events *)
-type wrapper = {
- mutable state : wrapper_state;
+ abort_waiter : int Lwt.t;
+ abort_wakener : int Lwt.u;
+ (* Sleeping thread which is wakeup when the card is closed *)
- public_state : state React.signal;
- set_public_state : state -> unit;
- (* The state that is returning to the user *)
+ wrapper : wrapper;
+ (* The associated wrapper *)
+}
- vendor_id : int;
- product_id : int;
- (* Informations needed to reopen the card when it crashes *)
+and state =
+ | Opened of card
+ | Closed of exn
+and wrapper = {
+ mutable state : state;
name : string;
-
- events : (int * (string -> unit)) Lwt_sequence.t;
- (* Connected events *)
}
type t = wrapper
let name wrapper = wrapper.name
+let closed wrapper = match wrapper.state with
+ | Opened _ -> false
+ | Closed _ -> true
+
+(* Return a running card, if possible. *)
+let rec get_card wrapper = match wrapper.state with
+ | Opened card ->
+ return card
+ | Closed exn ->
+ fail exn
-(* Returns the public state of a wrapper *)
-let state wrapper = wrapper.public_state
+(* +-----------------------------------------------------------------+
+ | Aborting |
+ +-----------------------------------------------------------------+ *)
-(* Set the state of a wrapper *)
-let set_state wrapper state =
- wrapper.state <- state;
- wrapper.set_public_state
- (match state with
- | Running _ -> `Running
- | Opening _ -> `Opening
- | Closed -> `Closed)
+let abort wrapper exn =
+ match wrapper.state with
+ | Opened card ->
+ wrapper.state <- Closed exn;
+ wakeup_exn card.abort_wakener exn;
+ lwt () = USB.release_interface card.handle 0 in
+ if card.kernel_active then USB.attach_kernel_driver card.handle 0;
+ USB.close card.handle;
+ return exn
+ | Closed exn ->
+ return exn
(* +-----------------------------------------------------------------+
- | Opening, closing and dispatching |
+ | Dispatching |
+-----------------------------------------------------------------+ *)
-(* Return a running card, if possible. *)
-let rec get_card wrapper = match wrapper.state with
- | Running card ->
- return card
- | Opening waiter ->
- lwt () = waiter in
- get_card wrapper
- | Closed ->
- fail Card_closed
-
-let close_card card =
- lwt _ = USB.release_interface card.handle 0 in
- if card.kernel_active then USB.attach_kernel_driver card.handle 0;
- USB.close card.handle;
- return ()
+(* Dispatch incomming messages continously *)
+let rec dispatch card =
+ let buffer = String.create 64 in
+ begin
+ try_lwt
+ select [card.abort_waiter;
+ USB.interrupt_recv
+ ~handle:card.handle
+ ~endpoint:1
+ buffer 0 64] >|= fun len -> `OK len
+ with exn ->
+ return (`Error exn)
+ end >>= function
+ | `Error exn ->
+ Log#exn exn "stop dispatching on %s card: %s" card.wrapper.name (Printexc.to_string exn);
+ lwt _ = abort card.wrapper exn in
+ return ()
+ | `OK len ->
+ if len <> 64 then begin
+ let msg = Printf.sprintf "read on %s card returned %d instead of 64" card.wrapper.name len in
+ Log#error "%s" msg;
+ lwt _ = abort card.wrapper (Card_crashed msg) in
+ return ()
+ end else begin
+ let msg = parse_message buffer in
+ if msg.command = Protocol.cmd_respond then begin
+ match try Some(Int_map.find msg.host_serial card.reply_waiters) with Not_found -> None with
+ | Some wakener ->
+ card.reply_waiters <- Int_map.remove msg.host_serial card.reply_waiters;
+ card.serial_pool <- card.serial_pool @ [msg.host_serial];
+ Lwt.wakeup wakener msg.data
+ | None ->
+ Log#warning "response dropped"
+ end else begin
+ match try Some(Int_map.find msg.command card.events) with Not_found -> None with
+ | Some seq ->
+ Lwt_sequence.iter_l
+ (fun push ->
+ try
+ push msg.data
+ with exn ->
+ Log#exn exn "pushing event %d from %s card failed with" msg.command card.wrapper.name)
+ seq
+ | None ->
+ Log#warning "command dropped"
+ end;
+ dispatch card
+ end
+
+(* +-----------------------------------------------------------------+
+ | Opening and closing |
+ +-----------------------------------------------------------------+ *)
let close wrapper = match wrapper.state with
- | Running card ->
- set_state wrapper Closed;
- close_card card
- | Opening waiter ->
- set_state wrapper Closed;
- Lwt.cancel waiter;
- return ()
- | Closed ->
+ | Opened _ ->
+ lwt _ = abort wrapper Card_closed in
return ()
-
-(* Retry continuously to open a card until it succeed: *)
-let rec reopen_card wakener wrapper =
- let rec loop is_first =
- try_lwt
- (* USB stuff *)
- let handle = USB.open_device_with ~vendor_id:wrapper.vendor_id ~product_id:wrapper.product_id in
- lwt () = USB.reset_device handle in
- let kernel_active = USB.kernel_driver_active handle 0 in
- if kernel_active then USB.detach_kernel_driver handle 0;
- lwt () = USB.set_configuration handle 1 in
- lwt () = USB.claim_interface handle 0 in
-
- Log#info "%s card opened" wrapper.name;
-
- let card = {
- serial_pool = (let rec loop = function
- | 256 -> []
- | n -> n :: loop (n + 1)
- in
- loop 1);
- reply_waiters = SerialMap.empty;
- handle = handle;
- kernel_active = kernel_active;
- mutex = Lwt_mutex.create ();
- } in
- set_state wrapper (Running card);
- ignore (dispatch wrapper card);
- Lwt.wakeup wakener ();
+ | Closed _ ->
return ()
- with exn ->
- if is_first then Log#exn exn "failed to open %s card" wrapper.name;
- lwt () = Lwt_unix.sleep Config.reopen_delay in
- loop false
- in
- loop true
-(* Dispatch incomming messages *)
-and dispatch wrapper card =
- let buffer = String.create 64 in
- lwt len = USB.interrupt_recv ~handle:card.handle ~endpoint:1 buffer 0 64 in
- if len <> 64 then fatal "read <> 64!";
- let msg = parse_message buffer in
- if msg.command = Protocol.cmd_respond then begin
- (* Réponse à un message *)
- match try Some(SerialMap.find msg.host_serial card.reply_waiters) with Not_found -> None with
- | Some wakener ->
- card.reply_waiters <- SerialMap.remove msg.host_serial card.reply_waiters;
- card.serial_pool <- card.serial_pool @ [msg.host_serial];
- Lwt.wakeup wakener msg.data
- | None ->
- Log#warning "response dropped"
- end else begin
- Lwt_sequence.iter_l
- (fun (command, push) ->
- if command = msg.command then
- try
- push msg.data
- with exn ->
- Log#exn exn "pushing event %d failed with: " msg.command)
- wrapper.events
- end;
- dispatch wrapper card
-
-let open_card ~name ~vendor_id ~product_id =
- let waiter, wakener = Lwt.task () in
- let state, set_state = React.S.create `Opening in
- let wrapper = {
- state = Opening waiter;
- public_state = state;
- set_public_state = set_state;
- vendor_id = vendor_id;
- product_id = product_id;
+let rec make ~name ~handle =
+ lwt () = USB.reset_device handle in
+ let kernel_active = USB.kernel_driver_active handle 0 in
+ if kernel_active then USB.detach_kernel_driver handle 0;
+ lwt () = USB.set_configuration handle 1 in
+ lwt () = USB.claim_interface handle 0 in
+ let abort_waiter, abort_wakener = wait () in
+ let rec card = {
+ serial_pool = (let rec loop = function
+ | 256 -> []
+ | n -> n :: loop (n + 1)
+ in
+ loop 1);
+ reply_waiters = Int_map.empty;
+ events = Int_map.empty;
+ handle = handle;
+ kernel_active = kernel_active;
+ mutex = Lwt_mutex.create ();
+ abort_waiter = abort_waiter;
+ abort_wakener = abort_wakener;
+ wrapper = wrapper;
+ } and wrapper = {
+ state = Opened card;
name = name;
- events = Lwt_sequence.create ();
} in
- ignore (reopen_card wakener wrapper);
- wrapper
-
-(* Close and reopen a card: *)
-let restart wrapper =
- Log#info "restarting %s card" wrapper.name;
- match wrapper.state with
- | Opening _ | Closed ->
- return ()
- | Running card ->
- let waiter, wakener = Lwt.task () in
- set_state wrapper (Opening waiter);
- lwt () =
- (* Try to close the card before reopening it: *)
- try_lwt
- close_card card
- with exn ->
- Log#exn exn "cannot close %s card" wrapper.name;
- return ()
- in
- ignore (reopen_card wakener wrapper);
- return ()
+ ignore (dispatch card);
+ return wrapper
(* +-----------------------------------------------------------------+
| Sending/receiving messages |
+-----------------------------------------------------------------+ *)
+let send card buffer =
+ lwt len = USB.interrupt_send ~handle:card.handle ~endpoint:1 buffer 0 64 in
+ if len <> 64 then begin
+ let msg = Printf.sprintf "write on %s card returned %d instead of 64" card.wrapper.name len in
+ Log#error "%s" msg;
+ fail =<< abort card.wrapper (Card_crashed msg)
+ end else
+ return ()
+
(* Send a command and wait for the response: *)
let rec send_request wrapper command data =
lwt card = get_card wrapper in
let serial = match card.serial_pool with
| [] ->
- fatal "no more serial available!"
- | s :: l ->
- card.serial_pool <- l;
- s
+ failwith "Card.send_request: no more serial available!"
+ | serial :: rest ->
+ card.serial_pool <- rest;
+ serial
in
- let waiter, wakener = Lwt.wait () in
- card.reply_waiters <- SerialMap.add serial wakener card.reply_waiters;
+ let waiter, wakener = Lwt.task () in
+ card.reply_waiters <- Int_map.add serial wakener card.reply_waiters;
+ on_cancel waiter (fun () ->
+ card.reply_waiters <- Int_map.remove serial card.reply_waiters;
+ card.serial_pool <- card.serial_pool @ [serial]);
let buffer = forge_message { host_serial = serial;
device_serial = 0;
command = command;
@@ -289,16 +270,14 @@ let rec send_request wrapper command data =
try_lwt
Lwt_mutex.with_lock card.mutex
(fun () ->
- lwt len = USB.interrupt_send ~handle:card.handle ~endpoint:1 buffer 0 64 in
- if len <> 64 then fatal "write <> 64!";
+ lwt () = send card buffer in
waiter)
with
| Canceled ->
fail Canceled
- | exn ->
- Log#exn exn "write to %s card failed" wrapper.name;
- lwt () = restart wrapper in
- send_request wrapper command data
+ | exn ->
+ Log#exn exn "write to %s card failed with" wrapper.name;
+ fail =<< abort wrapper exn
(* Send a command without waiting for the reply: *)
let rec send_command wrapper command data =
@@ -309,21 +288,35 @@ let rec send_command wrapper command data =
error = 0;
data = data } in
try_lwt
- lwt len = USB.interrupt_send ~handle:card.handle ~endpoint:1 buffer 0 64 in
- if len <> 64 then fatal "write <> 64!";
- return ()
+ Lwt_mutex.with_lock card.mutex (fun () -> send card buffer)
with
| Canceled ->
fail Canceled
| exn ->
- Log#exn exn "write to %s card failed" wrapper.name;
- lwt () = restart wrapper in
- send_command wrapper command data
-
-let connect wrapper command =
- let event, push = React.E.create () in
- let node = Lwt_sequence.add_l (command, push) wrapper.events in
- (object
- method event = event
- method stop = Lwt_sequence.remove node; React.E.stop event
- end)
+ Log#exn exn "write to %s card failed with" wrapper.name;
+ fail =<< abort wrapper exn
+
+let connect wrapper command = match wrapper.state with
+ | Closed exn ->
+ raise exn
+ | Opened card ->
+ let event, push = React.E.create () in
+ let seq =
+ try
+ Int_map.find command card.events
+ with Not_found ->
+ let seq = Lwt_sequence.create () in
+ card.events <- Int_map.add command seq card.events;
+ seq
+ in
+ let node = Lwt_sequence.add_l push seq in
+ let stop = lazy(
+ Lwt_sequence.remove node;
+ if Lwt_sequence.is_empty seq then
+ card.events <- Int_map.remove command card.events;
+ React.E.stop event
+ ) in
+ (object
+ method event = event
+ method stop = Lazy.force stop
+ end)
diff --git a/PC_Mainboard/driver/card.mli b/PC_Mainboard/driver/card.mli
index 8ca9ef2..c0ad590 100644
--- a/PC_Mainboard/driver/card.mli
+++ b/PC_Mainboard/driver/card.mli
@@ -12,38 +12,28 @@
type t
(** Type of a card *)
-(** {6 Card state} *)
+val name : t -> string
+ (** Returns the name of a card. It can be applied on a closed
+ card. *)
-(** State of a card: *)
-type state =
- [ `Running
- (** The card is up and running *)
- | `Opening
- (** The card is being opened *)
- | `Closed
- (** The card has been closed *) ]
+val closed : t -> bool
+ (** Returns [true] iff the card has been closed *)
-val state : t -> state React.signal
- (** [state card] is the state of a card, as a reactive value *)
+exception Card_closed
+ (** Exception raised when trying to use a closed card *)
-val name : t -> string
- (** Returns the name of a card *)
+exception Card_crashed of string
+ (** Exception raised when a fatal error happen on the card *)
(** {6 Card opening/closing} *)
-val open_card : name : string -> vendor_id : int -> product_id : int -> t
- (** Opten the card with given product-id and vendor-id. [name] is
- used for debug messages. *)
+val make : name : string -> handle : USB.handle -> t Lwt.t
+ (** [make ~name ~handle] creates a card using the given USB
+ handle. [name] is used for debug messages. *)
val close : t -> unit Lwt.t
(** Close the given card *)
-exception Card_closed
- (** Exception raised when trying to use a closed card *)
-
-val restart : t -> unit Lwt.t
- (** Closes and reopens the given card *)
-
(** {6 Sending/receving messages} *)
val make_buffer : unit -> string
hooks/post-receive
--
krobot
|
