Compiler Explorer

Source code

module type MT_policy =
  sig
    val lock   : unit -> unit
    val unlock : unit -> unit
  end

module Foo (Policy : MT_policy) = struct

let do_something () =
    Policy.lock () ;
    print_endline "Doing something..." ;
    Policy.unlock ()

end

(* -------- EXT LIB -------- *)

module CRITICAL_SECTION :
  sig
    type t
    val value      : unit -> t
    val initialize : t -> unit
    val enter      : t -> unit
    val leave      : t -> unit
    val delete     : t -> unit
  end =
struct
  
  type t = int ref
  
  let value () = ref 0
  
  let initialize sec =
    let sid = Random.int 100 in
    Printf.printf "---- INIT SEC %d\n" sid ;
    sec := sid
  
  let enter sec =
    Printf.printf "ENTER SEC %d\n" !sec
  
  let leave sec =
    Printf.printf "LEAVE SEC %d\n" !sec
  
  let delete sec =
    Printf.printf "---- DEL SEC %d\n" !sec ;
    sec := 0

end

module Mutex :
  sig
    type t
    val construct : unit -> t
    val acquire   : t -> unit
    val release   : t -> unit
    val destruct  : t -> unit
  end =
struct

type t = int ref
  
  let construct () =
    let mid = 100 + Random.int 100 in
    Printf.printf "---- CONSTR MUX %d\n" mid ;
    ref mid
  
  let acquire mux =
    Printf.printf "ACQ MUX %d\n" !mux
  
  let release mux =
    Printf.printf "REL MUX %d\n" !mux
  
  let destruct mux =
    Printf.printf "---- DESTR MUX %d\n" !mux ;
    mux := 0

end

(* -------------------------------- *)

module No_sync : MT_policy = struct

let lock     () = ()
  let unlock   () = ()

end

module type REGION =
  sig
    val finalize : ('a -> unit) -> 'a -> unit
  end

module CT_sync (R : REGION) : MT_policy = struct

let ct = CRITICAL_SECTION.value ()

let _ = CRITICAL_SECTION.initialize ct
  let _ = R.finalize CRITICAL_SECTION.delete ct
  
  let lock   () = CRITICAL_SECTION.enter ct
  let unlock () = CRITICAL_SECTION.leave ct

end

module MX_sync (R : REGION) : MT_policy = struct

let mx = Mutex.construct ()
  let _  = R.finalize Mutex.destruct mx
  
  let lock   () = Mutex.acquire mx
  let unlock () = Mutex.release mx

end

(* -------------------------------- *)

module Region () :
  sig
    val finalize : ('a -> unit) -> 'a -> unit
    val exit     : unit -> unit
  end =
struct

let finalizers = ref []
  
  let finalize f v =
    finalizers := (fun () -> f v) :: !finalizers
  
  let rec exit () =
    match !finalizers with
    | []    -> ()
    | f::fs ->
      begin
        f () ;
        finalizers := fs ;
        exit ()
      end

end

let _ =
  Random.self_init () ;
  let module REGION = Region () in
  
  let module F1 = Foo (CT_sync (REGION)) in
  let module F2 = Foo (MX_sync (REGION)) in
  let module F3 = Foo (No_sync) in
  let module F4 = Foo (CT_sync (REGION)) in
  let module F5 = Foo (MX_sync (REGION)) in
  
  F1.do_something () ;
  F2.do_something () ;
  F3.do_something () ;
  F4.do_something () ;
  F5.do_something () ;
  
  REGION.exit ()