Skip to content

Commit

Permalink
use MCLOCK rather than CLOCK; kill lots of float math
Browse files Browse the repository at this point in the history
  • Loading branch information
@yomimono
yomimono committed Aug 18, 2016
1 parent 016c00f commit 80dbfcd
Show file tree
Hide file tree
Showing 21 changed files with 177 additions and 202 deletions.
33 changes: 19 additions & 14 deletions lib/arpv4/arpv4.ml
View file
Expand Up @@ -20,16 +20,17 @@ open Lwt.Infix
let src = Logs.Src.create "arpv4" ~doc:"Mirage ARP module"
module Log = (val Logs.src_log src : Logs.LOG)

module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = struct
module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.MCLOCK) (Time : V1_LWT.TIME) = struct

type result = [ `Ok of Macaddr.t | `Timeout ]

type entry =
| Pending of result Lwt.t * result Lwt.u
| Confirmed of float * Macaddr.t
| Confirmed of int64 * Macaddr.t

type t = {
ethif : Ethif.t;
clock : Clock.t;
cache: (Ipaddr.V4.t, entry) Hashtbl.t;
mutable bound_ips: Ipaddr.V4.t list;
}
Expand All @@ -48,23 +49,27 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = str
let probe_num = 3 (* how many probes to send before giving up *)

let rec tick t () =
let now = Clock.time () in
let expired = Hashtbl.fold (fun ip entry expired ->
let now = Clock.elapsed_ns t.clock in
let remove_expired ip entry =
match entry with
| Pending _ -> expired
| Confirmed (t, _) -> if t >= now then ip :: expired else expired) t.cache []
| Pending _ -> Some entry
| Confirmed (expiry, _) ->
if Int64.compare expiry now > -1
then Some entry
else begin
Log.info (fun f -> f "ARP: timeout %a" Ipaddr.V4.pp_hum ip);
None
end
in
List.iter (fun ip ->
Log.info (fun f -> f "ARP: timeout %a" Ipaddr.V4.pp_hum ip); Hashtbl.remove t.cache ip
) expired;
Hashtbl.filter_map_inplace remove_expired t.cache;
Time.sleep_ns arp_timeout >>= tick t

let to_repr t =
let print ip entry acc =
let key = Ipaddr.V4.to_string ip in
match entry with
| Pending _ -> acc ^ "\n" ^ key ^ " -> " ^ "Pending"
| Confirmed (time, mac) -> Printf.sprintf "%s\n%s -> Confirmed (%s) (expires %f)\n%!"
| Confirmed (time, mac) -> Printf.sprintf "%s\n%s -> Confirmed (%s) (expires %Lu)\n%!"
acc key (Macaddr.to_string mac) time
in
Lwt.return (Hashtbl.fold print t.cache "")
Expand All @@ -77,8 +82,8 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = str
match Ipaddr.V4.is_multicast ip || (Ipaddr.V4.compare ip Ipaddr.V4.any = 0) with
| true -> Log.debug (fun f -> f "Ignoring ARP notification request for IP %a" Ipaddr.V4.pp_hum ip)
| false ->
let now = Clock.time () in
let expire = now +. Duration.to_f arp_timeout in
let now = Clock.elapsed_ns t.clock in
let expire = Int64.add now arp_timeout in
try
match Hashtbl.find t.cache ip with
| Pending (_, w) ->
Expand Down Expand Up @@ -197,10 +202,10 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = str
Lwt.async (retry 0);
response

let connect ethif =
let connect ethif clock =
let cache = Hashtbl.create 7 in
let bound_ips = [] in
let t = { ethif; cache; bound_ips } in
let t = { clock; ethif; cache; bound_ips } in
Lwt.async (tick t);
Log.info (fun f -> f "Connected arpv4 device on %s" (Macaddr.to_string (
Ethif.mac t.ethif)));
Expand Down
4 changes: 2 additions & 2 deletions lib/arpv4/arpv4.mli
View file
Expand Up @@ -15,11 +15,11 @@
*
*)

module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) : sig
module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.MCLOCK) (Time : V1_LWT.TIME) : sig
include V1_LWT.ARP

type ethif = Ethif.t

(** [connect] creates a value of type [t]. *)
val connect : ethif -> [> `Ok of t | `Error of error ] Lwt.t
val connect : ethif -> Clock.t -> [> `Ok of t | `Error of error ] Lwt.t
end
21 changes: 11 additions & 10 deletions lib/ipv6/ipv6.ml
View file
Expand Up @@ -21,7 +21,7 @@ module I = Ipaddr

open Lwt.Infix

module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.CLOCK) = struct
module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.MCLOCK) = struct
type ethif = E.t
type 'a io = 'a Lwt.t
type buffer = Cstruct.t
Expand All @@ -31,6 +31,7 @@ module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.CLOCK) = struct

type t =
{ ethif : E.t;
clock : C.t;
mutable ctx : Ndpv6.context }

type error =
Expand All @@ -39,7 +40,7 @@ module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.CLOCK) = struct

let start_ticking t =
let rec loop () =
let now = C.time () in
let now = C.elapsed_ns t.clock in
let ctx, bufs = Ndpv6.tick ~now t.ctx in
t.ctx <- ctx;
Lwt_list.iter_s (E.writev t.ethif) bufs >>= fun () ->
Expand All @@ -51,7 +52,7 @@ module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.CLOCK) = struct
Ndpv6.allocate_frame t.ctx dst proto

let writev t frame bufs =
let now = C.time () in
let now = C.elapsed_ns t.clock in
let dst =
Ndpv6.ipaddr_of_cstruct
(Ipv6_wire.get_ipv6_dst (Cstruct.shift frame Ethif_wire.sizeof_ethernet))
Expand All @@ -64,7 +65,7 @@ module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.CLOCK) = struct
writev t frame [buf]

let input t ~tcp ~udp ~default buf =
let now = C.time () in
let now = C.elapsed_ns t.clock in
let _, bufs, actions = Ndpv6.handle ~now t.ctx buf in
Lwt_list.iter_s (function
| `Tcp (src, dst, buf) -> tcp ~src ~dst buf
Expand All @@ -81,7 +82,7 @@ module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.CLOCK) = struct
let src t ~dst = Ndpv6.select_source t.ctx dst

let set_ip t ip =
let now = C.time () in
let now = C.elapsed_ns t.clock in
let ctx, bufs = Ndpv6.add_ip ~now t.ctx ip in
t.ctx <- ctx;
Lwt_list.iter_s (E.writev t.ethif) bufs
Expand All @@ -90,7 +91,7 @@ module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.CLOCK) = struct
Ndpv6.get_ip t.ctx

let set_ip_gateways t ips =
let now = C.time () in
let now = C.elapsed_ns t.clock in
let ctx = Ndpv6.add_routers ~now t.ctx ips in
t.ctx <- ctx;
Lwt.return_unit
Expand All @@ -102,7 +103,7 @@ module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.CLOCK) = struct
Ndpv6.get_prefix t.ctx

let set_ip_netmask t pfx =
let now = C.time () in
let now = C.elapsed_ns t.clock in
let ctx = Ndpv6.add_prefix ~now t.ctx pfx in
t.ctx <- ctx;
Lwt.return_unit
Expand All @@ -127,11 +128,11 @@ module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.CLOCK) = struct
| Some x -> f x >>= g
| None -> g ()

let connect ?ip ?netmask ?gateways ethif =
let connect ?ip ?netmask ?gateways ethif clock =
Log.info (fun f -> f "IP6: Starting");
let now = C.time () in
let now = C.elapsed_ns clock in
let ctx, bufs = Ndpv6.local ~now (E.mac ethif) in
let t = {ctx; ethif} in
let t = {ctx; clock; ethif} in
Lwt_list.iter_s (E.writev t.ethif) bufs >>= fun () ->
(ip, set_ip t) >>=? fun () ->
(netmask, Lwt_list.iter_s (set_ip_netmask t)) >>=? fun () ->
Expand Down
4 changes: 2 additions & 2 deletions lib/ipv6/ipv6.mli
View file
Expand Up @@ -14,11 +14,11 @@
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)

module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (C : V1.CLOCK) : sig
module Make (E : V1_LWT.ETHIF) (T : V1_LWT.TIME) (Clock : V1.MCLOCK) : sig
include V1_LWT.IPV6 with type ethif = E.t
val connect :
?ip:Ipaddr.V6.t ->
?netmask:Ipaddr.V6.Prefix.t list ->
?gateways:Ipaddr.V6.t list ->
ethif -> [> `Ok of t | `Error of error ] Lwt.t
ethif -> Clock.t -> [> `Ok of t | `Error of error ] Lwt.t
end

0 comments on commit 80dbfcd

Please sign in to comment.