devices + first class modules

gistfile1.ml

open Printf

(* Generic device module type *)
module type DEVICE = sig
  type t
  val make: unit -> t
  val read: t -> string
  val write: t -> string -> unit
end

(* Concrete device with internal int state *)
module DEV1 : DEVICE = struct
  type t = int
  let ctr = ref 0
  let make () = incr ctr; !ctr
  let read t = printf "DEV1: read %d\n%!" t; "dev1"
  let write t s = printf "DEV1: write %d %s\n%!" t s
end

(* Concrete device with internal string state *)
module DEV2 : DEVICE = struct
  type t = string
  let ctr = ref 0
  let make () = incr ctr; string_of_int !ctr
  let read t = printf "DEV2: read %s\n%!" t; "dev1"
  let write t s = printf "DEV2: write %s %s\n%!" t s
end

(* Do something with a device *)
let with_device (type t) m dev =
  let module D = (val m : DEVICE with type t = t) in
  let _ = D.read dev in
  D.write dev "foo"

(* Construct dev1 and dev2 and pass it to with_device *)
let _ =
  let d1 = DEV1.make () in
  let d2 = DEV2.make () in
  with_device (module DEV1 : DEVICE with type t = DEV1.t) d1;
  with_device (module DEV2 : DEVICE with type t = DEV2.t) d2

So, I'm not sure if this is really any better, but you can write a
module that does the unwrapping for you, though it's definitely
boilerplate:

module Device : sig
  type 'a t = (module DEVICE with type t = 'a)
  val make : 'a t -> 'a
  val read : 'a t -> 'a -> string
  val write : 'a t -> 'a -> string -> unit
end = struct
  type 'a t = (module DEVICE with type t = 'a)

  let make (type a) m =
    let module M = (val m : DEVICE with type t= a) in
    M.make ()

  let read (type a) m t =
    let module M = (val m : DEVICE with type t = a) in
    M.read t

  let write (type a) m t s =
    let module M = (val m : DEVICE with type t = a) in
    M.write t s
end

And then you can create polymorphic values that front for your module:

let m1 = (module DEV1 : DEVICE with type t = DEV1.t)
let m2 = (module DEV2 : DEVICE with type t = DEV2.t)

At which point, you can write the code you want in a fairly natural
style. Note that this is typeclass-like dictionary-passing, since you
pass the module around with you to allow you to access the relevant
methods:

let with_device m dev =
  ignore (Device.read m dev : string);
  Device.write m dev "foo"

let main () =
  let d1 = Device.make m1 in
  let d2 = Device.make m2 in
  with_device m1 d1;
  with_device m2 d2

And to be clear, that's only if you want the polymorphic version,
which is not clearly necessary in this case. You can also pack the
value into the module directly, like in the following code:

module type DEVICE_INSTANCE = sig
  include DEVICE
  val this : t
end

module Device_m : sig
  type t
  val make : (module DEVICE) -> t
  val read : t -> string
  val write : t -> string -> unit
end = struct
  type t = (module DEVICE_INSTANCE)

  let make m =
    let module D = (val m : DEVICE) in
    let module D_instance = struct
      include D
      let this = D.make ()
    end in
    (module D_instance : DEVICE_INSTANCE)

  let read m =
    let module M = (val m : DEVICE_INSTANCE) in
    M.read M.this

  let write m s =
    let module M = (val m : DEVICE_INSTANCE) in
    M.write M.this s
end

let main_m () =
  let with_device dev =
    ignore (Device_m.read dev : string);
    Device_m.write dev "foo"
  in
  let d1 = Device_m.make (module DEV1 : DEVICE) in
  let d2 = Device_m.make (module DEV2 : DEVICE)  in
  with_device d1;
  with_device d2

Thanks! I like the approach of wrapping the module values to make them polymorphic --- boilerplate enough that it could be camlp4-generated if it ever became a problem too. I did a quick comparison of the three approaches (manual unpacking of first class modules, the polymorphic approach, and objects) to see if there is a significant performance difference, and they are all pretty close. Close enough that the actual work done by the devices will outweigh the method invocation used, at least.

firstclass manual unpack: 12.083006
firstclass poly unpack: 12.140164
object: 12.550903

And the full source to the test:

open Printf

let iters = 20000000
let timeit name fn =
  Gc.compact ();
  let t1 = Unix.gettimeofday () in
  for i = 0 to iters do
    fn ();
  done;
  let t2 = Unix.gettimeofday () in
  printf "%s: %f\n%!" name (t2 -. t1);
  Gc.compact ()

(* Generic device module type *)
module type DEVICE = sig
  type t
  val make: unit -> t
  val read: t -> string
  val write: t -> string -> unit
end

(* Concrete device with internal int state *)
module DEV1 : DEVICE = struct
  type t = int ref
  let make () = ref 1
  let read t = incr t; string_of_int !t
  let write t s = incr t
end

(* Concrete device with internal string state *)
module DEV2 : DEVICE = struct
  type t = string * int ref
  let make () = "dev2", (ref 1)
  let read (_,t) = incr t; string_of_int !t
  let write (_,t) s = incr t
end

(* Do something with a device *)
let with_device (type t) m dev =
  let module D = (val m : DEVICE with type t = t) in
  let _ = D.read dev in
  D.write dev "foo"

(* Construct dev1 and dev2 and pass it to with_device *)
let _ =
  let d1 = DEV1.make () in
  let d2 = DEV2.make () in
  timeit "firstclass manual unpack" (fun () ->
    with_device (module DEV1 : DEVICE with type t = DEV1.t) d1;
    with_device (module DEV2 : DEVICE with type t = DEV2.t) d2
  )

(* Boilerplate to wrap the module unpacking *)
module Device : sig
  type 'a t = (module DEVICE with type t = 'a)
  val make : 'a t -> 'a
  val read : 'a t -> 'a -> string
  val write : 'a t -> 'a -> string -> unit
end = struct
  type 'a t = (module DEVICE with type t = 'a)

  let make (type a) m =
    let module M = (val m : DEVICE with type t= a) in
    M.make ()

  let read (type a) m t =
    let module M = (val m : DEVICE with type t = a) in
    M.read t

  let write (type a) m t s =
  )

(* Boilerplate to wrap the module unpacking *)
module Device : sig
  type 'a t = (module DEVICE with type t = 'a)
  val make : 'a t -> 'a
  val read : 'a t -> 'a -> string
  val write : 'a t -> 'a -> string -> unit
end = struct
  type 'a t = (module DEVICE with type t = 'a)

  let make (type a) m =
    let module M = (val m : DEVICE with type t= a) in
    M.make ()

  let read (type a) m t =
    let module M = (val m : DEVICE with type t = a) in
    M.read t

  let write (type a) m t s =
    let module M = (val m : DEVICE with type t = a) in
    M.write t s
end

let dev1 = (module DEV1 : DEVICE with type t = DEV1.t)
let dev2 = (module DEV2 : DEVICE with type t = DEV2.t)

(* Do something with a device *)
let with_device m dev =
  let _ = Device.read m dev in
  Device.write m dev "foo"

(* Construct dev1 and dev2 and pass it to with_device *)
let _ =
  let d1 = Device.make dev1 in
  let d2 = Device.make dev2 in
  timeit "firstclass poly unpack" (fun () ->
    with_device dev1 d1;
    with_device dev2 d2;
  )

(* Do the same with objects *)
type dev = < read: string; write: string -> unit >
let make_dev1 () : dev =
  let t = ref 1 in
  object 
    method read = incr t; string_of_int !t
    method write x = incr t
  end
let make_dev2 () : dev =
  let t = "dev2", (ref 1) in
  object
    method read = incr (snd t); string_of_int !(snd t)
    method write x = incr (snd t)
  end

(* Do something with a device *)
let with_device dev =
  let _ = dev#read in
  dev#write "foo"

(* Construct dev1 and dev2 and pass it to with_device *)
let _ =
  let d1 = make_dev1 () in
  let d2 = make_dev2 () in
  timeit "object" (fun () ->
    with_device d1;
    with_device d2
  )