Commits

Dmitry Grebeniuk  committed 6b4b15f Merge

merge

  • Participants
  • Parent commits 3836737, 15788d0
  • Branches net-base

Comments (0)

Files changed (20)

+CMT _build
+I +site-lib/cadastr
+(* OASIS_START *)
+(* DO NOT EDIT (digest: db6d1b5909b9a64d742b1369d82f8591) *)
+Authors of parvel
+Dmitry Grebeniuk <gdsfh1@gmail.com>
+(* OASIS_STOP *)
+(* OASIS_START *)
+(* DO NOT EDIT (digest: e318d64c36e2ed4d6c0f450d80206080) *)
+This is the INSTALL file for the parvel distribution.
+
+This package uses OASIS to generate its build system. See section OASIS for
+full information. 
+
+Dependencies
+============
+
+In order to compile this package, you will need:
+* ocaml
+* findlib
+* lwt
+* monad_io
+* substrings
+* cadastr
+
+Installing
+==========
+
+1. Uncompress the source archive and go to the root of the package
+2. Run 'ocaml setup.ml -configure'
+3. Run 'ocaml setup.ml -build'
+4. Run 'ocaml setup.ml -install'
+
+Uninstalling
+============
+
+1. Go to the root of the package 
+2. Run 'ocaml setup.ml -uninstall'
+
+OASIS
+=====
+
+OASIS is a program that generates a setup.ml file using a simple '_oasis'
+configuration file. The generated setup only depends on the standard OCaml
+installation: no additional library is required.
+
+(* OASIS_STOP *)
-LGPL with OCaml linking exception.
+License:     LGPL-2.1 with OCaml linking exception
-name="parvel"
-version=""
-description="Message-passing primitives in Actors-style"
-requires="unix, lwt, lwt.unix, monad_io, monad_io.lwt, substrings"
-archive(byte)="parvel.cma"
-archive(native)="parvel.cmxa"
+# OASIS_START
+# DO NOT EDIT (digest: 42d26cb357469109156c25804bc873aa)
+version = "0.1"
+description = "OCaml message passing library"
+requires = "unix lwt lwt.unix monad_io monad_io.lwt substrings cadastr"
+archive(byte) = "parvel.cma"
+archive(native) = "parvel.cmxa"
+exists_if = "parvel.cma"
+# OASIS_STOP
+
-PKG=parvel
-VERSION=0.1
+# OASIS_START
+# DO NOT EDIT (digest: bc1e05bfc8b39b664f29dae8dbd3ebbb)
 
-TESTBIN=tests.byte
+SETUP = ocaml setup.ml
 
-all :
-	ocamlbuild parvel.cmi parvel_types.cmi parvel_IO.cmi \
-	   parvel.cma parvel.cmxa tests.byte tests.native \
-	   typeinfo.cmi
+build: setup.data
+	$(SETUP) -build $(BUILDFLAGS)
 
-install : all
-	ocamlfind install \
-	  -patch-version $(VERSION) \
-	  $(PKG) META \
-	  _build/parvel.cma _build/parvel.cmxa _build/parvel.a \
-	  parvel.mli \
-	  _build/parvel.cmi _build/parvel_types.cmi _build/parvel_IO.cmi \
-	  _build/parvel_lwt.cmi _build/typeinfo.cmi
+doc: setup.data build
+	$(SETUP) -doc $(DOCFLAGS)
 
-deinstall :
-	ocamlfind remove $(PKG)
+test: setup.data build
+	$(SETUP) -test $(TESTFLAGS)
 
-uninstall :
-	$(MAKE) deinstall
+all: 
+	$(SETUP) -all $(ALLFLAGS)
 
-reinstall :
-	-$(MAKE) deinstall
-	$(MAKE) install
+install: setup.data
+	$(SETUP) -install $(INSTALLFLAGS)
+
+uninstall: setup.data
+	$(SETUP) -uninstall $(UNINSTALLFLAGS)
+
+reinstall: setup.data
+	$(SETUP) -reinstall $(REINSTALLFLAGS)
+
+clean: 
+	$(SETUP) -clean $(CLEANFLAGS)
+
+distclean: 
+	$(SETUP) -distclean $(DISTCLEANFLAGS)
+
+setup.data:
+	$(SETUP) -configure $(CONFIGUREFLAGS)
+
+.PHONY: build doc test all install uninstall reinstall clean distclean configure
+
+# OASIS_STOP
 
 tests : all
 	_build/$(TESTBIN)
 infer :
 	ocamlbuild parvel.inferred.mli && cat _build/parvel.inferred.mli
 
-clean :
-	ocamlbuild -clean
+uninstall_force :
+	ocamlfind remove parvel
+
+reinstall_force : uninstall_force install

File README

-    What is Parvel
-
-  Message passing primitives for OCaml in style between
-the actors and erlang.
-
-    Where is the documentation
-
-  There is not so much documentation for now.  See parvel.mli for
-actual API, see https://bitbucket.org/gds/parvel/wiki/Home for
-some documentation, plans, concepts' description, mostly russian
-language.
-
-    License
-
-  LGPL with OCaml linking exception.
-
-    Authors
-
-  Dmitry Grebeniuk  gdsfh1 at gmail dot com
-
-    Acknowledgements
-
-  Parvel developement is sponsored by Amatei.  Thanks for the money.
-
-  Parvel is inspired by actors-style message passing and erlang.  Thanks
-for the conception.
-
-  Parvel architecture and implementation include many ideas and
-design choices that were derived from discussions in ocaml jabber
-conference xmpp:ocaml@conference.jabber.ru (language: russian).
-Thanks for the help.
+(* OASIS_START *)
+(* DO NOT EDIT (digest: 12ae66d36f66ee9d8e3f30b66d9b978a) *)
+This is the README file for the parvel distribution.
+
+OCaml message passing library
+
+See the files INSTALL.txt for building and installation instructions. 
+
+
+(* OASIS_STOP *)
+
+
+    What is Parvel
+
+  Message passing primitives for OCaml in style between
+the actors and erlang.
+
+
+    Where is the documentation
+
+  There is not so much documentation for now.  See parvel.mli for
+actual API, see https://bitbucket.org/gds/parvel/wiki/Home for
+some documentation, plans, concepts' description, mostly russian
+language.
+
+
+    What is Parvel
+
+  Message passing primitives for OCaml in style between
+the actors and erlang.
+
+
+    Where is the documentation
+
+  There is not so much documentation for now.  See parvel.mli for
+actual API, see https://bitbucket.org/gds/parvel/wiki/Home for
+some documentation, plans, concepts' description, mostly russian
+language.
+
+
+    Acknowledgements
+
+  Parvel developement is sponsored by Amatei.  Thanks for the money.
+
+  Parvel is inspired by actors-style message passing and erlang.  Thanks
+for the conception.
+
+  Parvel architecture and implementation include many ideas and
+design choices that were derived from discussions in ocaml jabber
+conference xmpp:ocaml@conference.jabber.ru (language: russian).
+Thanks for the help.
+OASISFormat: 0.2
+Name:        parvel
+Version:     0.1
+Synopsis:    OCaml message passing library
+Authors:     Dmitry Grebeniuk <gdsfh1@gmail.com>
+License:     LGPL-2.1 with OCaml linking exception
+Plugins:     DevFiles (0.2), META (0.2), StdFiles (0.2)
+
+BuildDepends: unix, lwt, lwt.unix, monad_io, monad_io.lwt, substrings, cadastr
+
+Library parvel
+  Path:       .
+  BuildTools: ocamlbuild
+  Modules:    Parvel, Lwt_mq_parvel, Parvel_IO, Parvel_log,
+    Parvel_lwt, Parvel_types, Typeinfo, Parvel_ops
+  
+Executable tests
+  Path:       .
+  BuildTools: ocamlbuild
+  MainIs:     tests.ml
+  Install:    false
+  
+SourceRepository default
+  Type:     hg
+  Location: https://bitbucket.org/gds/parvel/
+  
-<*.ml> | <*.mli> | <*.byte> | <*.native> : camlp4r, pkg_lwt, pkg_monad_io.lwt, pkg_lwt.unix, pkg_substrings
+# OASIS_START
+# DO NOT EDIT (digest: f02666ee37a48fded1c4483839e15c8e)
+# Ignore VCS directories, you can use the same kind of rule outside 
+# OASIS_START/STOP if you want to exclude directories that contains 
+# useless stuff for the build process
+<**/.svn>: -traverse
+<**/.svn>: not_hygienic
+".bzr": -traverse
+".bzr": not_hygienic
+".hg": -traverse
+".hg": not_hygienic
+".git": -traverse
+".git": not_hygienic
+"_darcs": -traverse
+"_darcs": not_hygienic
+# Library parvel
+# Executable tests
+"tests.byte": pkg_unix
+"tests.byte": pkg_substrings
+"tests.byte": pkg_monad_io.lwt
+"tests.byte": pkg_monad_io
+"tests.byte": pkg_lwt.unix
+"tests.byte": pkg_lwt
+"tests.byte": pkg_cadastr
+<*.ml{,i}>: pkg_unix
+<*.ml{,i}>: pkg_substrings
+<*.ml{,i}>: pkg_monad_io.lwt
+<*.ml{,i}>: pkg_monad_io
+<*.ml{,i}>: pkg_lwt.unix
+<*.ml{,i}>: pkg_lwt
+<*.ml{,i}>: pkg_cadastr
+# OASIS_STOP
+
+
+<*.ml> | <*.mli> | <*.byte> | <*.native> : camlp4r, -camlp4o
 <*> : warn_A
 <parvel_ops.*> : -camlp4r, camlp4o
 <lwt_mvar_parvel.*> : -camlp4r, camlp4o
-
 <test_iteratees.*> : pkg_iteratees
-
 <typeinfo.*> : pkg_json-static, pkg_json-wheel
+#!/bin/sh
+
+# OASIS_START
+# DO NOT EDIT (digest: 425187ed8bfdbdd207fd76392dd243a7)
+set -e
+
+FST=true
+for i in "$@"; do 
+  if $FST; then
+    set --
+    FST=false
+  fi
+
+  case $i in
+    --*=*)
+      ARG=${i%%=*}
+      VAL=${i##*=}
+      set -- "$@" "$ARG" "$VAL"
+      ;;
+    *)
+      set -- "$@" "$i"
+      ;;
+  esac
+done
+
+ocaml setup.ml -configure "$@"
+# OASIS_STOP

File myocamlbuild.ml

-open Ocamlbuild_plugin;;
-
-
-
-(**********************)
-
-(* these functions are not really officially exported *)
-let run_and_read = Ocamlbuild_pack.My_unix.run_and_read
-let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings
-
-let split s ch =
-  let x = ref [] in
-  let rec go s =
-    let pos = String.index s ch in
-    x := (String.before s pos)::!x;
-    go (String.after s (pos + 1))
-  in
-  try
-    go s
-  with Not_found -> !x
-
-let split_nl s = split s '\n'
-
-let before_space s =
-  try
-    String.before s (String.index s ' ')
-  with Not_found -> s
-
-(* this lists all supported packages *)
-let find_packages () =
-  List.map before_space (split_nl & run_and_read "ocamlfind list")
-
-(* this is supposed to list available syntaxes,
-   but I don't know how to do it. *)
-let find_syntaxes () = ["camlp4o"; "camlp4r"]
-
-(* ocamlfind command *)
-let ocamlfind x = S[A"ocamlfind"; x]
-;;
-
-let disp_ocamlfind = begin function
-   | Before_options ->
-       (* by using Before_options one let command line options have an higher priority *)
-       (* on the contrary using After_options will guarantee to have the higher priority *)
-
-       (* override default commands by ocamlfind ones *)
-
-(*
-       Options.ocamlc     := ocamlfind & A"ocamlc";
-*)
-       Options.ocamlc     := ocamlfind & S[A"ocamlc"; A"-verbose"];
-
-       Options.ocamlopt   := ocamlfind & A"ocamlopt";
-       Options.ocamldep   := ocamlfind & A"ocamldep" (* S[A"ocamldep"; A"-verbose"] *) ;
-       Options.ocamldoc   := ocamlfind & A"ocamldoc";
-       Options.ocamlmktop := ocamlfind & A"ocamlmktop"
-
-   | After_rules ->
-
-       (* When one link an OCaml library/binary/package, one should use -linkpkg *)
-       flag ["ocaml"; "link"] & A"-linkpkg";
-
-       (* For each ocamlfind package one inject the -package option when
-       	* compiling, computing dependencies, generating documentation and
-       	* linking. *)
-       List.iter begin fun pkg ->
-         flag ["ocaml"; "compile";  "pkg_"^pkg] & S[A"-package"; A pkg];
-         flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg];
-         flag ["ocaml"; "doc";      "pkg_"^pkg] & S[A"-package"; A pkg];
-         flag ["ocaml"; "link";     "pkg_"^pkg] & S[A"-package"; A pkg];
-         flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg];
-       end (find_packages ());
-
-       (* Like -package but for extensions syntax. Morover -syntax is useless
-       	* when linking. *)
-       List.iter begin fun syntax ->
-         flag ["ocaml"; "compile";  "syntax_"^syntax] & S[A"-syntax"; A syntax];
-         flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
-         flag ["ocaml"; "doc";      "syntax_"^syntax] & S[A"-syntax"; A syntax];
-         flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
-       end (find_syntaxes ());
-       
-       (* The default "thread" tag is not compatible with ocamlfind.
-          Indeed, the default rules add the "threads.cma" or "threads.cmxa"
-          options when using this tag. When using the "-linkpkg" option with
-          ocamlfind, this module will then be added twice on the command line.
-       
-          To solve this, one approach is to add the "-thread" option when using
-          the "threads" package using the previous plugin.
-        *)
-       flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]);
-       flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]);
-       flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"])
-       
-   | _ -> ()
+(* OASIS_START *)
+(* DO NOT EDIT (digest: f58ee4488815b31b636135710f5c7e00) *)
+module OASISGettext = struct
+# 21 "/home/gds/dev/ovm/work1/src/oasis/work/src/oasis/OASISGettext.ml"
+  
+  let ns_ str =
+    str
+  
+  let s_ str =
+    str
+  
+  let f_ (str : ('a, 'b, 'c, 'd) format4) =
+    str
+  
+  let fn_ fmt1 fmt2 n =
+    if n = 1 then
+      fmt1^^""
+    else
+      fmt2^^""
+  
+  let init =
+    []
+  
 end
 
-(**********************)
+module OASISExpr = struct
+# 21 "/home/gds/dev/ovm/work1/src/oasis/work/src/oasis/OASISExpr.ml"
+  
+  
+  
+  open OASISGettext
+  
+  type test = string 
+  
+  type flag = string 
+  
+  type t =
+    | EBool of bool
+    | ENot of t
+    | EAnd of t * t
+    | EOr of t * t
+    | EFlag of flag
+    | ETest of test * string
+    
+  
+  type 'a choices = (t * 'a) list 
+  
+  let eval var_get t =
+    let rec eval' =
+      function
+        | EBool b ->
+            b
+  
+        | ENot e ->
+            not (eval' e)
+  
+        | EAnd (e1, e2) ->
+            (eval' e1) && (eval' e2)
+  
+        | EOr (e1, e2) ->
+            (eval' e1) || (eval' e2)
+  
+        | EFlag nm ->
+            let v =
+              var_get nm
+            in
+              assert(v = "true" || v = "false");
+              (v = "true")
+  
+        | ETest (nm, vl) ->
+            let v =
+              var_get nm
+            in
+              (v = vl)
+    in
+      eval' t
+  
+  let choose ?printer ?name var_get lst =
+    let rec choose_aux =
+      function
+        | (cond, vl) :: tl ->
+            if eval var_get cond then
+              vl
+            else
+              choose_aux tl
+        | [] ->
+            let str_lst =
+              if lst = [] then
+                s_ "<empty>"
+              else
+                String.concat
+                  (s_ ", ")
+                  (List.map
+                     (fun (cond, vl) ->
+                        match printer with
+                          | Some p -> p vl
+                          | None -> s_ "<no printer>")
+                     lst)
+            in
+              match name with
+                | Some nm ->
+                    failwith
+                      (Printf.sprintf
+                         (f_ "No result for the choice list '%s': %s")
+                         nm str_lst)
+                | None ->
+                    failwith
+                      (Printf.sprintf
+                         (f_ "No result for a choice list: %s")
+                         str_lst)
+    in
+      choose_aux (List.rev lst)
+  
+end
 
 
+module BaseEnvLight = struct
+# 21 "/home/gds/dev/ovm/work1/src/oasis/work/src/base/BaseEnvLight.ml"
+  
+  module MapString = Map.Make(String)
+  
+  type t = string MapString.t
+  
+  let default_filename =
+    Filename.concat
+      (Sys.getcwd ())
+      "setup.data"
+  
+  let load ?(allow_empty=false) ?(filename=default_filename) () =
+    if Sys.file_exists filename then
+      begin
+        let chn =
+          open_in_bin filename
+        in
+        let st =
+          Stream.of_channel chn
+        in
+        let line =
+          ref 1
+        in
+        let st_line =
+          Stream.from
+            (fun _ ->
+               try
+                 match Stream.next st with
+                   | '\n' -> incr line; Some '\n'
+                   | c -> Some c
+               with Stream.Failure -> None)
+        in
+        let lexer =
+          Genlex.make_lexer ["="] st_line
+        in
+        let rec read_file mp =
+          match Stream.npeek 3 lexer with
+            | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] ->
+                Stream.junk lexer;
+                Stream.junk lexer;
+                Stream.junk lexer;
+                read_file (MapString.add nm value mp)
+            | [] ->
+                mp
+            | _ ->
+                failwith
+                  (Printf.sprintf
+                     "Malformed data file '%s' line %d"
+                     filename !line)
+        in
+        let mp =
+          read_file MapString.empty
+        in
+          close_in chn;
+          mp
+      end
+    else if allow_empty then
+      begin
+        MapString.empty
+      end
+    else
+      begin
+        failwith
+          (Printf.sprintf
+             "Unable to load environment, the file '%s' doesn't exist."
+             filename)
+      end
+  
+  let var_get name env =
+    let rec var_expand str =
+      let buff =
+        Buffer.create ((String.length str) * 2)
+      in
+        Buffer.add_substitute
+          buff
+          (fun var ->
+             try
+               var_expand (MapString.find var env)
+             with Not_found ->
+               failwith
+                 (Printf.sprintf
+                    "No variable %s defined when trying to expand %S."
+                    var
+                    str))
+          str;
+        Buffer.contents buff
+    in
+      var_expand (MapString.find name env)
+  
+  let var_choose lst env =
+    OASISExpr.choose
+      (fun nm -> var_get nm env)
+      lst
+end
 
-(*
-List.iter begin fun class_name ->
-  flag ["ocaml"; "pp"; "classes"^class_name] (S[A"-classes"; A class_name])
-end ["Show"; "Typeable"]
-;;
-*)
 
-let libdir = !Ocamlbuild_pack.Ocamlbuild_where.libdir
-;;
+module MyOCamlbuildFindlib = struct
+# 21 "/home/gds/dev/ovm/work1/src/oasis/work/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml"
+  
+  (** OCamlbuild extension, copied from 
+    * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild
+    * by N. Pouillard and others
+    *
+    * Updated on 2009/02/28
+    *
+    * Modified by Sylvain Le Gall 
+    *)
+  open Ocamlbuild_plugin
+  
+  (* these functions are not really officially exported *)
+  let run_and_read = 
+    Ocamlbuild_pack.My_unix.run_and_read
+  
+  let blank_sep_strings = 
+    Ocamlbuild_pack.Lexers.blank_sep_strings
+  
+  let split s ch =
+    let x = 
+      ref [] 
+    in
+    let rec go s =
+      let pos = 
+        String.index s ch 
+      in
+        x := (String.before s pos)::!x;
+        go (String.after s (pos + 1))
+    in
+      try
+        go s
+      with Not_found -> !x
+  
+  let split_nl s = split s '\n'
+  
+  let before_space s =
+    try
+      String.before s (String.index s ' ')
+    with Not_found -> s
+  
+  (* this lists all supported packages *)
+  let find_packages () =
+    List.map before_space (split_nl & run_and_read "ocamlfind list")
+  
+  (* this is supposed to list available syntaxes, but I don't know how to do it. *)
+  let find_syntaxes () = ["camlp4o"; "camlp4r"]
+  
+  (* ocamlfind command *)
+  let ocamlfind x = S[A"ocamlfind"; x]
+  
+  let dispatch =
+    function
+      | Before_options ->
+          (* by using Before_options one let command line options have an higher priority *)
+          (* on the contrary using After_options will guarantee to have the higher priority *)
+          (* override default commands by ocamlfind ones *)
+          Options.ocamlc     := ocamlfind & A"ocamlc";
+          Options.ocamlopt   := ocamlfind & A"ocamlopt";
+          Options.ocamldep   := ocamlfind & A"ocamldep";
+          Options.ocamldoc   := ocamlfind & A"ocamldoc";
+          Options.ocamlmktop := ocamlfind & A"ocamlmktop"
+                                  
+      | After_rules ->
+          
+          (* When one link an OCaml library/binary/package, one should use -linkpkg *)
+          flag ["ocaml"; "link"; "program"] & A"-linkpkg";
+          
+          (* For each ocamlfind package one inject the -package option when
+           * compiling, computing dependencies, generating documentation and
+           * linking. *)
+          List.iter 
+            begin fun pkg ->
+              flag ["ocaml"; "compile";  "pkg_"^pkg] & S[A"-package"; A pkg];
+              flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg];
+              flag ["ocaml"; "doc";      "pkg_"^pkg] & S[A"-package"; A pkg];
+              flag ["ocaml"; "link";     "pkg_"^pkg] & S[A"-package"; A pkg];
+              flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg];
+            end 
+            (find_packages ());
+  
+          (* Like -package but for extensions syntax. Morover -syntax is useless
+           * when linking. *)
+          List.iter begin fun syntax ->
+          flag ["ocaml"; "compile";  "syntax_"^syntax] & S[A"-syntax"; A syntax];
+          flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
+          flag ["ocaml"; "doc";      "syntax_"^syntax] & S[A"-syntax"; A syntax];
+          flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
+          end (find_syntaxes ());
+  
+          (* The default "thread" tag is not compatible with ocamlfind.
+           * Indeed, the default rules add the "threads.cma" or "threads.cmxa"
+           * options when using this tag. When using the "-linkpkg" option with
+           * ocamlfind, this module will then be added twice on the command line.
+           *                        
+           * To solve this, one approach is to add the "-thread" option when using
+           * the "threads" package using the previous plugin.
+           *)
+          flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]);
+          flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]);
+          flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]);
+          flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"])
+  
+      | _ -> 
+          ()
+  
+end
 
-(*
-Printf.printf "%!\n\n\nlibdir: %S\n\n\n%!"
-   !Ocamlbuild_pack.Ocamlbuild_where.libdir
-   !libdir
-   !Ocamlbuild_where.libdir
-   !Myocamlbuild_config.libdir
-   !Ocamlbuild_Myocamlbuild_config.libdir
-*)
+module MyOCamlbuildBase = struct
+# 21 "/home/gds/dev/ovm/work1/src/oasis/work/src/plugins/ocamlbuild/MyOCamlbuildBase.ml"
+  
+  (** Base functions for writing myocamlbuild.ml
+      @author Sylvain Le Gall
+    *)
+  
+  
+  
+  open Ocamlbuild_plugin
+  
+  type dir = string 
+  type file = string 
+  type name = string 
+  type tag = string 
+  
+# 55 "/home/gds/dev/ovm/work1/src/oasis/work/src/plugins/ocamlbuild/MyOCamlbuildBase.ml"
+  
+  type t =
+      {
+        lib_ocaml: (name * dir list) list;
+        lib_c:     (name * dir * file list) list; 
+        flags:     (tag list * (spec OASISExpr.choices)) list;
+      } 
+  
+  let env_filename =
+    Pathname.basename 
+      BaseEnvLight.default_filename
+  
+  let dispatch_combine lst =
+    fun e ->
+      List.iter 
+        (fun dispatch -> dispatch e)
+        lst 
+  
+  let dispatch t e = 
+    let env = 
+      BaseEnvLight.load 
+        ~filename:env_filename 
+        ~allow_empty:true
+        ()
+    in
+      match e with 
+        | Before_options ->
+            let no_trailing_dot s =
+              if String.length s >= 1 && s.[0] = '.' then
+                String.sub s 1 ((String.length s) - 1)
+              else
+                s
+            in
+              List.iter
+                (fun (opt, var) ->
+                   try 
+                     opt := no_trailing_dot (BaseEnvLight.var_get var env)
+                   with Not_found ->
+                     Printf.eprintf "W: Cannot get variable %s" var)
+                [
+                  Options.ext_obj, "ext_obj";
+                  Options.ext_lib, "ext_lib";
+                  Options.ext_dll, "ext_dll";
+                ]
+  
+        | After_rules -> 
+            (* Declare OCaml libraries *)
+            List.iter 
+              (function
+                 | lib, [] ->
+                     ocaml_lib lib;
+                 | lib, dir :: tl ->
+                     ocaml_lib ~dir:dir lib;
+                     List.iter 
+                       (fun dir -> 
+                          flag 
+                            ["ocaml"; "use_"^lib; "compile"] 
+                            (S[A"-I"; P dir]))
+                       tl)
+              t.lib_ocaml;
+  
+            (* Declare C libraries *)
+            List.iter
+              (fun (lib, dir, headers) ->
+                   (* Handle C part of library *)
+                   flag ["link"; "library"; "ocaml"; "byte"; "use_lib"^lib]
+                     (S[A"-dllib"; A("-l"^lib); A"-cclib"; A("-l"^lib)]);
+  
+                   flag ["link"; "library"; "ocaml"; "native"; "use_lib"^lib]
+                     (S[A"-cclib"; A("-l"^lib)]);
+                        
+                   flag ["link"; "program"; "ocaml"; "byte"; "use_lib"^lib]
+                     (S[A"-dllib"; A("dll"^lib)]);
+  
+                   (* When ocaml link something that use the C library, then one
+                      need that file to be up to date.
+                    *)
+                   dep  ["link"; "ocaml"; "use_lib"^lib] 
+                     [dir/"lib"^lib^"."^(!Options.ext_lib)];
+  
+                   (* TODO: be more specific about what depends on headers *)
+                   (* Depends on .h files *)
+                   dep ["compile"; "c"] 
+                     headers;
+  
+                   (* Setup search path for lib *)
+                   flag ["link"; "ocaml"; "use_"^lib] 
+                     (S[A"-I"; P(dir)]);
+              )
+              t.lib_c;
+  
+              (* Add flags *)
+              List.iter
+              (fun (tags, cond_specs) ->
+                 let spec = 
+                   BaseEnvLight.var_choose cond_specs env
+                 in
+                   flag tags & spec)
+              t.flags
+        | _ -> 
+            ()
+  
+  let dispatch_default t =
+    dispatch_combine 
+      [
+        dispatch t;
+        MyOCamlbuildFindlib.dispatch;
+      ]
+  
+end
 
-let stdlib_dir = Ocamlbuild_pack.Ocaml_utils.stdlib_dir;;
 
+open Ocamlbuild_plugin;;
+let package_default =
+  {MyOCamlbuildBase.lib_ocaml = [("parvel", [])]; lib_c = []; flags = []; }
+  ;;
 
-let str_replace_char str cfrom cto =
-  let str = String.copy str in
-  let () =
-    for i = 0 to String.length str - 1 do
-      ( if str.[i] = cfrom
-        then str.[i] <- cto
-        else ()
-      )
-      done
-  in
-  str
-;;
+let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;;
 
-
-let disp_deriving = (function
-| After_rules ->
-    let stdlib_dir = Lazy.force stdlib_dir in
-    let syn_dir = stdlib_dir / "deriving" / "syntax" in
-(*
-    let syn_dir =
-      if Sys.os_type = "Win32"
-      then str_replace_char syn_dir '/' '\\'
-      else syn_dir
-    in
-*)
-    ( flag ["ocaml"; "pp"; "deriving"]
-        (S[A"-I"; P(syn_dir);
-          S(List.map
-              (fun m -> A(m^".cmo"))
-              ["utils"; "type"; "base"; "id"; "extend"; "show_class"]
-           )
-          ]
-        )
-    ; flag ["ocaml"; "compile"; "deriving"]
-        (S[A"-I"; P("+deriving" / "lib")])
-    ; flag ["ocaml"; "link"; "deriving"; "byte"]
-        (S[A"-I"; P("+deriving" / "lib"); A"deriving.cma"])
-    ; flag ["ocaml"; "link"; "deriving"; "native"]
-        (S[A"-I"; P("+deriving" / "lib"); A"deriving.cmxa"])
-    )
-|  _ -> ()
-);;
-
-
-dispatch
-(fun x -> (disp_ocamlfind x; disp_deriving x))
-;;
+(* OASIS_STOP *)
+Ocamlbuild_plugin.dispatch dispatch_default;;
+(*
+2. сделать так, чтобы процесс при падении куда-то писал в лог.
+3. продумать логи.
+*)
+
+module L = Parvel_log;
+
 module type COUNTER
  =
   sig
     exception Ty_ver of ty_ver_error;
 
     type call_resp_error =
-      [= `Exn_string of string
+      [= `Exn of exn
+      |  `Exn_string of string
       ]
     ;
 
 
     exception ECall of call_resp_error;
 
+    type dest_kind =
+      [ DLocal of (unit -> unit)  (* run after put *)
+      | DRemote
+          of int
+          and Cdt.type_name
+          and (string -> unit)
+          and (unit -> string)
+      ]
+    ;
+
     type dest 'o =
-      [ Local of (call_resp 'o -> IO.m unit)
-      ]
+      { dest_ref : ref (option (call_resp 'o))
+      ; dest_kind : dest_kind
+      }
     ;
 
     type call 'i 'o = ('i * dest 'o)
       ]
     ;
 
+    type optsync 'm =
+      [ Async of 'm
+      | Sync of 'm and IO.sink unit
+      ]
+    ;
+
     type process_status =
       [ PSAlive of list (pid -> process_exit_status -> IO.m unit)
       | PSExited of process_exit_status
      *)
     type process 'i =
       { p_pid : lpid
-      ; p_send_msg : process_message_req 'i -> IO.m unit
+      ; p_send_smsg : optsync (process_message_req 'i) -> IO.m unit
       ; p_status : mutable process_status
       }
     ;
 
     (*********************************************************)
 
+    (* runtime type infos: *)
+
+    module Ti
+     =
+      struct
+
+        open Cd_All; open Cdt;
+        open Printf;
+        open Cd_Ser;
+
+        (* in Cd_Ser:
+        value ti_int = (ti_int :> ti int);
+        value ti_string = (ti_string :> ti string);
+        value ti_unit = (ti_unit :> ti unit);
+        *)
+
+        value ti_call_resp_error
+         : ti call_resp_error
+         = ((
+           new ti_sum_type
+             ~type_name:"call_resp_error"
+             ~constr:
+               [| ti_ctr_variant1 "`Exn_string" ti_string &
+                  fun s -> `Exn_string s
+                ; ti_ctr_variant1 "`Exn" Exn.ti &
+                  fun e -> `Exn e
+                |]
+             & fun
+             [ `Exn_string s -> ti_variant "`Exn_string"
+                 [| ubox ti_string s |]
+             | `Exn e -> ti_variant "`Exn"
+                 [| ubox Exn.ti e |]
+             ]
+           ) :> ti _)
+        ;
+
+
+        value ti_call_resp
+         : ti 'o -> ti (call_resp 'o)
+         = fun ti_o ->
+             let t =
+             ((
+             new ti_sum_type
+               ~type_name:(sprintf "call_resp (%s)" ti_o#type_name)
+               ~constr:
+                 [| ti_ctr_variant1 "CR_Ok" ti_o &
+                    fun a -> CR_Ok a
+                  ; ti_ctr_variant1 "CR_Error" ti_call_resp_error &
+                    fun a -> CR_Error a
+                 |]
+               & fun
+               [ CR_Ok a -> ti_variant "CR_Ok"
+                   [| ubox ti_o a |]
+               | CR_Error a -> ti_variant "CR_Error"
+                   [| ubox ti_call_resp_error a |]
+               ]
+             ) :> ti _)
+             in
+             ( ti_add_ser_deser t
+             ; t
+             )
+        ;
+
+        value ti_dest_put = ti_abs ti_string ti_unit
+        ;
+
+        value ti_dest_get = ti_abs ti_unit ti_string
+        ;
+
+        value ti_dlocal_after_put = ti_abs ti_unit ti_unit
+        ;
+
+        value ti_dest_kind =
+           ((
+           new ti_sum_type
+             ~type_name:"dest_kind"
+             ~constr:
+               [| ti_ctr_variant4 "DRemote"
+                  ti_int ti_string ti_dest_put ti_dest_get
+                  & fun a b c d -> DRemote a b c d
+                |]
+             & fun
+               [ DRemote a b c d -> ti_variant "DRemote"
+                   [| ubox ti_int a ; ubox ti_string b
+                    ; ubox ti_dest_put c ; ubox ti_dest_get d
+                    |]
+               | DLocal a -> ti_variant "DLocal"
+                   [| ubox ti_dlocal_after_put a |]
+               ]
+           ) :> ti _)
+        ;
+
+
+        value dest_ubox_get
+         : ti (call_resp 'a) -> ref (option (call_resp 'a)) -> (unit -> string)
+         = fun ti_cr_a r ->
+               (fun () ->
+                  match r.val with
+                  [ None -> failwith "dest: not filled"
+                  | Some a -> ti_ser ti_cr_a a
+                  ]
+               )
+        ;
+
+
+        (* todo: вынести dest* в модуль? *)
+
+        class ti_dest ['dest_o]
+          (ti_o : #ti 'o)
+          ()
+         =
+          let tn_dest = "dest" in
+          let ti_cr_o = ((ti_call_resp ti_o) :> ti _) in
+          let ti_ref_opt_o = new Ref.ti (new Option.ti ti_cr_o ()) () in
+
+          object (self : #ti (dest 'o))
+             inherit ti_record ['dest_o]
+               ~type_name:(sprintf "dest (%s)" ti_o#type_name)
+               ~constr:
+                 ( [| (ti_ref_opt_o :> uti) ; (ti_dest_kind :> uti) |]
+                 , [| "val" |]
+                 , fun
+                   [ [| r ; k |] ->
+                       { dest_ref = uget_exn ti_ref_opt_o r
+                       ; dest_kind = uget_exn ti_dest_kind k
+                       }
+                   | _ -> assert False
+                   ]
+                 )
+               ( fun [ { dest_ref ; dest_kind } ->
+                         [| ti_field "dest_ref" ti_ref_opt_o dest_ref
+                          ; ti_field "dest_kind" ti_dest_kind dest_kind
+                          |]
+                 ]
+               )
+             ;
+
+             initializer
+             let self = (self :> ti _) in
+             ( uti_add_meth self "ser" &
+                 ubox
+                   (ti_abs self ti_string)
+                   (fun d ->
+                      match d.dest_kind with
+                      [ DRemote i tn_o _ _  ->
+                          marshal_ser tn_dest (i, tn_o)
+                      | DLocal _ap ->
+                          failwith "can't serialize DLocal %s" &
+                            self#type_name
+                      ]
+                   )
+             ; uti_add_meth self "deser" &
+                 ubox
+                   (ti_abs ti_string self)
+                   (fun s ->
+                      let (i, tn_o) = marshal_deser tn_dest s in
+                      if tn_o <> ti_o#type_name
+                      then failwith "dest deser: received type_name=%S, \
+                                     local type_name=%S"
+                                    tn_o ti_o#type_name
+                      else
+                      let r = ref None in
+                      { dest_ref = r
+                      ; dest_kind = DRemote
+                          i
+                          tn_o
+                          (fun _s -> failwith
+                             "can't put anything into deserialized 'dest'")
+                          (dest_ubox_get ti_cr_o r)
+                      }
+                   )
+             ; uti_add_meth self "is_dest" & ubox ti_unit ()
+             ; ()
+             );
+
+          end
+        ;
+
+
+
+      end
+    ;
+    include Ti;
+
+
+    (*********************************************************)
+
 
     value ty_ver_error ~tyname ~expected ~got =
       Ty_ver (
     ;
 
 
+    value process_pid p = p.p_pid
+    ;
 
     value () = Printexc.register_printer
       (fun
       ]
     ;
 
-    value (dest_put : dest 'o -> call_resp 'o -> IO.m unit)
+    value (dest_put : dest 'o -> call_resp 'o -> unit)
     d v =
-      match d with
-      [ Local f -> f v ]
+      match d.dest_ref.val with
+      [ Some _ -> failwith "dest_put: already put"
+      | None ->
+          ( d.dest_ref.val := Some v
+          ; L.debug "dest_put: put"
+          ; match d.dest_kind with
+            [ DLocal ap ->
+                try ap () with
+                [ e -> d.dest_ref.val := Some (CR_Error (`Exn_string
+                    (Printexc.to_string e)))
+                ]
+            | DRemote _ _ _ _ -> ()
+            ]
+          )
+      ]
     ;
 
+
+    value dest_put_val
+     : dest 'o -> 'o -> unit
+     = fun d v ->
+         dest_put d (CR_Ok v)
+    ;
+
+
+    value dest_put_error
+     : dest 'o -> string -> unit
+     = fun d s ->
+         dest_put d (CR_Error (`Exn_string s))
+    ;
+
+    value dest_put_exn
+     : dest 'o -> exn -> unit
+     = fun d e ->
+         dest_put_error d (Printexc.to_string e)
+    ;
+
+
     value (dest_pre_map : ('a -> 'b) -> dest 'b -> dest 'a) m d =
-      match d with
-      [ Local f ->
-          Local (fun [ CR_Ok x -> f (CR_Ok (m x))
-                     | ((CR_Error _) as e) -> f e
-                     ])
-      ]
+      let dest_ref = ref None in
+      { dest_ref
+      ; dest_kind =
+          match d.dest_kind with
+          [ DLocal old_ap ->
+              let new_ap () =
+                ( d.dest_ref.val :=
+                    match dest_ref.val with
+                    [ None -> None
+                    | Some (CR_Ok v) -> Some (CR_Ok (m v))
+                    | Some (CR_Error e) -> Some (CR_Error e)
+                    ]
+                ; old_ap ()
+                )
+              in
+              DLocal new_ap
+          | DRemote _ _ _ _ -> failwith
+              "dest_pre_map on DRemote: not implemented"
+          ]
+      }
     ;
 
     value _notimpl msg = failwith
     value send_ctx_cmd ctx cmd = ctx.c_send_cmd cmd
     ;
 
+    value send_optsync
+     : process 'i -> optsync (process_message_req 'i) -> IO.m unit
+     = fun proc smsg ->
+         proc.p_send_smsg smsg
+    ;
+
     value send
      : process 'i -> process_message_req 'i -> IO.m unit
      = fun proc msg ->
-         proc.p_send_msg msg
+         send_optsync proc (Async msg)
+    ;
+
+    value send_sync
+     : process 'i -> process_message_req 'i -> IO.sink unit -> IO.m unit
+     = fun proc msg sink ->
+         send_optsync proc (Sync msg sink)
     ;
 
     value addrt_of_proc proc =
-      { asend = proc.p_send_msg
+      { asend = fun msg -> proc.p_send_smsg (Async msg)
       }
     ;
 
       IO.run_and_ignore_result (f my_pid process_exit_status)
     ;
 
+    value process_pass_msg_sync
+     = fun disp msg ->
+         IO.catch
+           (fun () ->
+              (disp msg : IO.m (process_result _)) >>= fun res ->
+              IO.return res
+           )
+           (fun e ->
+              let () = L.debug "process raised exception: %s"
+                (Printexc.to_string e) in
+              IO.return (Exit (PE_Error (`Exn e)))
+           )
+    ;
+
+    value process_do_exit
+     = fun ~context ~me ~pe ->
+         let () =
+           let my_pid = me.p_pid in
+           match me.p_status with
+           [ PSAlive monitors ->
+               ( List.iter
+                   (fun fin -> try fin () with [ _ -> () ]
+                   )
+                   context.c_finalizers
+               ; List.iter
+                   (notify_monitor ~my_pid ~process_exit_status:pe)
+                   monitors
+               )
+           | PSExited _ ->
+               assert False
+           ]
+         in
+           IO.return ()
+    ;
+
+
     value rec (process_loop
       : context ->
         (process 'a) ->
-        (IO.Mq.t (process_message_req 'a)) ->
+        (IO.Mq.t (optsync (process_message_req 'a))) ->
         (_ -> IO.m (process_result 'a)) ->
         _
     )
     context me mq disp =
-      IO.catch
-        (fun () ->
-           ( (* IO.printf "s.c.: waiting\n%!" >>= fun () -> *)
-            IO.Mq.take mq >>= fun msg ->
-             (* IO.printf "s.c.: taken\n%!" >>= fun () -> *)
-            (disp msg : IO.m (process_result _)) >>= fun res ->
-            IO.return res
-           )
-        )
-        (fun e -> IO.return (Exit (PE_Error (`Exn e)))
-        )
+      ( (* IO.printf "s.c.: waiting\n%!" >>= fun () -> *)
+        IO.Mq.take mq >>= fun smsg ->
+        (* IO.printf "s.c.: taken\n%!" >>= fun () -> *)
+        match smsg with
+        [ Async msg -> process_pass_msg_sync disp msg
+        | Sync msg sink ->
+            let () = L.debug "process_loop: sync msg" in
+            process_pass_msg_sync disp msg >>= fun res ->
+            let () = L.debug "process_loop: passed to process" in
+            ( IO.put_sink sink ()
+            ; L.debug "process_loop: sink put"
+            ; IO.return res
+            )
+        ]
+      )
       >>= fun
-      [ Exit pe ->
-          let () =
-            let my_pid = me.p_pid in
-            match me.p_status with
-            [ PSAlive monitors ->
-                ( List.iter
-                    (fun fin -> try fin () with [ _ -> () ]
-                    )
-                    context.c_finalizers
-                ; List.iter
-                    (notify_monitor ~my_pid ~process_exit_status:pe)
-                    monitors
-                )
-            | PSExited _ ->
-                assert False
-            ]
-          in
-            IO.return ()
+      [ Exit pe -> process_do_exit ~context ~me ~pe
       | Continue k -> process_loop context me mq k
       ]
     ;
     value process_continue k = IO.return (Continue k)
     ;
 
+    value process_exit_by_status = fun ps -> IO.return (Exit ps)
+      (* fun
+      [ PE_Normal -> process_exit ()
+      | PE_Error err -> process_exit_error err
+      ] *)
+    ;
+
     value (create_process_inner :
       process_factory 'a ->
       ~mq:(IO.Mq.t _) ->
       in
 *)
       let process : process _ =
-        { p_send_msg = fun msg -> IO.Mq.put mq msg
+        { p_send_smsg = fun smsg -> IO.Mq.put mq smsg
         ; p_status = PSAlive []
         ; p_pid = Counter.next pid_local_counter
         }
       in
       let context =
-        { c_send_cmd = fun cmd -> IO.Mq.put mq (Cmd cmd)
+        { c_send_cmd = fun cmd -> IO.Mq.put mq (Async (Cmd cmd))
         ; c_mq_set_block_limit = fun n -> IO.Mq.set_block_limit mq n
         ; c_mq_set_fail_limit = fun n -> IO.Mq.set_fail_limit mq n
         ; c_finalizers = []
     ;
 
 
-    value monitor my_context some_process =
+    value monitor
+     : context -> process 'a -> unit
+     = fun my_context some_process ->
       let notify_me =
         fun pid pe ->
           send_ctx_cmd my_context (`Exited (pid, pe))
     ;
 
 
-    value (create_server_inner :
-      server_factory 'i 'o ->
-      ~mq:(IO.Mq.t _) ->
-      IO.m (server 'i 'o)
-      )
-    server_factory ~mq =
+    value process_of_server
+     : server_factory 'i 'o ->
+       process_factory (call 'i 'o)
+     = fun server_factory ->
       let (process_factory : process_factory _) ctx =
         server_factory ctx >>= fun server_disp ->
         IO.return server_loop
                   )
                 >>= fun call_resp ->
                 (* IO.printf "server_loop: got reply\n%!" >>= fun () -> *)
-                dest_put dest call_resp >>= fun () ->
+                let () = dest_put dest call_resp in
                 (* IO.printf "server_loop: put reply\n%!" >>= fun () -> *)
                 process_continue server_loop
             | Cmd `Shutdown ->
                 process_continue server_loop
             ]
       in
-        create_process_inner ~mq process_factory
+        process_factory
+    ;       
+
+
+    value (create_server_inner :
+      server_factory 'i 'o ->
+      ~mq:(IO.Mq.t _) ->
+      IO.m (server 'i 'o)
+      )
+    server_factory ~mq =
+      create_process_inner ~mq (process_of_server server_factory)
     ;
 
 
         ~mq:(IO.Mq.create ())
     ;
 
+    value dest_local_initial_after_put = fun () -> ()
+    ;
+
+    value dest_local
+     : unit -> dest 'o
+     = fun () ->
+         { dest_ref = ref None
+         ; dest_kind = DLocal dest_local_initial_after_put
+         }
+    ;
+
+
+    value dest_remote_counter = ref 0
+    ;
+
+    value dest_remote
+     : ! 'a . #Cdt.ti 'a -> dest 'a
+     =
+      fun ti_a ->
+        let ti_cr_a = ti_call_resp ti_a in
+        let r = ref None in
+        ( incr dest_remote_counter
+        ; { dest_ref = r
+          ; dest_kind =
+              DRemote
+                dest_remote_counter.val
+                ti_a#type_name
+                (fun s ->
+                   r.val := Some (Cd_Ser.ti_deser ti_cr_a s)
+                )
+                (dest_ubox_get ti_cr_a r)
+          }
+        )
+    ;
+
+
+    (* временное: *)
+    value dest
+     : #Cdt.ti 'o -> dest 'o
+     = fun _ti ->
+         dest_local ()
+    ;
+
+
+    value dest_get
+     : dest 'o -> IO.m (call_resp 'o)
+     = fun d ->
+         let () = L.debug "Parvel.dest_get" in
+         (
+         match d.dest_kind with
+         [ DLocal _ap -> IO.return "DLocal"
+         | DRemote _ _ _ _ -> IO.return "DRemote"
+         ]
+         ) >>= fun dk ->
+         match d.dest_ref.val with
+         [ None -> IO.error (
+               Failure (Printf.sprintf "dest_get: no data (%s)" dk)
+             )
+         | Some cr -> IO.return cr
+         ]
+    ;
+
+    value dest_get_val
+     : dest 'o -> IO.m 'o
+     = fun d ->
+         dest_get d >>= fun
+         [ CR_Ok v -> IO.return v
+         | CR_Error (`Exn_string s) -> IO.error (Failure
+               (Printf.sprintf "Parvel.dest_get_val: error: %s" s)
+             )
+         ]
+    ;
+
     (* синхронный вызов *)
     value (call : server 'i 'o -> 'i -> IO.m (call_resp 'o)) server arg =
-      let (source, sink) = IO.pipe1 () in
-      let dest = Local (fun o -> IO.return (IO.put_sink sink o)) in
+      let dest = dest_local () in
       send server (Msg (arg, dest)) >>= fun () ->
-      IO.wait_source source
+      dest_get dest
     ;
 
     value (call_io : server 'i 'o -> 'i -> IO.m 'o) server arg =
              [ Msg (`Add_worker (k, w), dest) ->
                  ( workers.val := Map.add k w workers.val
                  ; monitor ctx w
-                 ; dest_put dest (CR_Ok SR_Worker_added) >>= fun () ->
-                   process_continue loop
+                 ; dest_put dest (CR_Ok SR_Worker_added)
+                 ; process_continue loop
                  )
              | Msg (`Call (k, i), dest) ->
                  match Map.find_opt workers.val k with
                  [ None ->
-                     dest_put dest (CR_Ok SR_No_worker_for_key) >>= fun () ->
-                     process_continue loop
+                     ( dest_put dest (CR_Ok SR_No_worker_for_key)
+                     ; process_continue loop
+                     )
                  | Some w ->
                      let new_dest = dest_pre_map (fun r -> (SR_Res r)) dest in
                      send w (Msg (i, new_dest)) >>= fun () ->
                      process_continue loop
                  ]
              | Msg (`Get_keys, dest) ->
-                 dest_put dest (CR_Ok (SR_Keys (Map.keys workers.val)))
-                 >>= fun () ->
-                 process_continue loop
+                 ( dest_put dest (CR_Ok (SR_Keys (Map.keys workers.val)))
+                 ; process_continue loop
+                 )
              | Cmd `Shutdown ->
                  (* где-то тут надо как бы разослать привет детишкам.
                     однако подумать: если дети сами регистрируются,
              | Cmd (`Exited (the_pid, status)) ->
                  (match status with
                   [ PE_Normal ->
-                      IO.printf "Parvel.switch: normal worker's exit.  wtf?\n"
+                      let () = L.error
+                        "Parvel.switch: normal worker's exit.  wtf?" in
+                      IO.return ()
                   | PE_Error _ ->
                       IO.return ()
                   ]
     *)
 
 
-    value cmd_shutdown = Cmd `Shutdown;
+    value cmd_shutdown_msg = Cmd `Shutdown;
+    value cmd_shutdown = Async cmd_shutdown_msg;
 
     value (process_limit :
       ?nmax:int ->
             then
               let () = dbg "lim:   count < nmax" in
               let any_reader = IO.Mq.idle_reader_exists common_mq in
-              IO.Mq.put common_mq msg >>= fun () ->
+              IO.Mq.put common_mq (Async msg) >>= fun () ->
               (if not any_reader
                then
                  let () = dbg "lim:     no readers" in
               (* count >= nmax *)
               let () = dbg "lim:   count >= nmax" in
 
-              IO.Mq.put_blocking common_mq msg >>= fun () ->
+              IO.Mq.put_blocking common_mq (Async msg) >>= fun () ->
               process_continue (out_disp ~count)
 
         | Cmd (`Exited _) ->
 
         | Cmd `Shutdown ->
             let () = dbg "lim: `Shutdown" in
-            send monitor cmd_shutdown >>= fun () ->
+            send monitor cmd_shutdown_msg >>= fun () ->
             process_exit ()
         ]
     ;
 
       create_process (fun context ->
 
-        create_process (combine_pairs dest_put) >>= fun combiner ->
+        create_process
+          (combine_pairs (fun a b -> IO.return (dest_put a b)))
+        >>= fun combiner ->
 
         let combiner_addrt = addrt_of_proc combiner in
 
 
     (*************************************************************)
 
+    module Proto
+     =
+      struct
+
+        open Cd_All; open Cdt; open Cd_Ser;
+
+        value rec get_dests
+         : ubox -> list
+             (int * (string -> unit) * (unit -> string) * (unit -> bool))
+                       (* id, deserialize, serialize, get_is_filled *)
+         = fun u ->
+             let rec get_dests_td td u =
+               match td with
+               [ Simple _ -> []
+               | Dispatch_method disp -> get_dests_td (disp "ser") u
+               | Sum_type destr _constr ->
+                   let (_vname, disp) = destr u in
+                   let uarr = disp "ser" in
+                   get_dests_arr uarr
+               | Record_type destr _utis _fields _constr ->
+                   let uarrfn = destr u in
+                   let uarr = Array.map (fun (_field_name, u) -> u) uarrfn in
+                   get_dests_arr uarr
+               | Lambda _ _ _ -> []
+               | Tuple destr _utis _constr ->
+                   get_dests_arr (destr u)
+               ]
+
+             and get_dests_arr uarr =
+               List.concat & Array.map_to_list get_dests uarr
+
+             and get_from_dest u =
+               match u with
+               [ [| ("dest_ref", ur) ; ("dest_kind", uk) |] ->
+                   match uk.ub_uti#type_desc with
+                   [ Sum_type destr _constr ->
+                       match destr uk with
+                       [ ("DRemote", disp) ->
+                           let uarr = disp "get_dests" in
+                           match uarr with
+                           [ [| ui ; _u_tn ; uput_dest ; uget_dest |] ->
+                                [ ( uget_exn ti_int ui
+                                  , fun s ->
+                                      uget_exn ti_unit &
+                                        u_app
+                                          uput_dest
+                                          (ubox ti_string s)
+                                  , fun () ->
+                                      uget_exn ti_string &
+                                        u_app
+                                          uget_dest
+                                          (ubox ti_unit ())
+                                  , get_is_filled ur
+                                  )
+                                ]
+                           | _ -> assert False
+                           ]
+                       | ("DLocal", _disp) ->
+                           [ ( -1
+                             , fun _ -> failwith "shouldn't use uput_dest \
+                                                  on DLocal dests"
+                             , fun _ -> failwith "shouldn't use uget_dest \
+                                                  on DLocal dests"
+                             , get_is_filled ur
+                             )
+                           ]
+                       | _ -> assert False
+                       ]
+                   | Tuple _ _ _ | Simple _ | Lambda _ _ _
+                   | Dispatch_method _ | Record_type _ _ _ _
+                       -> assert False
+                   ]
+               | _ -> assert False
+               ]
+             and get_is_filled uref =
+               fun () ->
+               let (destr, _utis, _fields, _constr) =
+                 ti_expect_record_exn uref.ub_uti#type_desc
+               in
+                 match destr uref with
+                 [ [| ("val", uopt) |] ->
+                     let (destr, _constr) =
+                       ti_expect_sum_exn uopt.ub_uti#type_desc in
+                     match destr uopt with
+                     [ ("None", _) -> False
+                     | ("Some", _) -> True
+                     | _ -> assert False
+                     ]
+                 | _ -> assert False
+                 ]
+             in
+               let uti = u.ub_uti in
+               if has_meth "is_dest" uti
+               then
+                 let (destr, _utis, _fields, _constr) =
+                   ti_expect_record_exn uti#type_desc
+                 in
+                   get_from_dest & destr u
+               else
+                 get_dests_td u.ub_uti#type_desc u
+        ;
+
+
+        type proto_call_resp = list (int * string)
+        ;
+
+        value ti_resp_elem =
+          new Tuple2.ti
+                ti_int
+                ti_string
+                ()
+        ;
+        value () = ti_add_ser_deser (ti_resp_elem :> ti _)
+        ;
+
+        value ti_proto_call_resp : #ti proto_call_resp =
+          new List.ti ti_resp_elem
+            ()
+        ;
+        value ti_proto_call_resp = (ti_proto_call_resp :> ti _)
+        ;
+        value () = ti_add_ser_deser ti_proto_call_resp
+        ;
+
+
+
+        value sort_dests =
+          List.sort (fun (a, _, _) (b, _, _) -> compare a b)
+        ;
+
+
+        value proto_call
+         : ti 'p -> process 'p -> 'p -> unit
+         = fun ti_proto server p ->
+             (*
+             let dests : list (int * (string -> unit) * (unit -> string)) =
+               (* sort_dests & *)
+               get_dests &
+               ubox ti_proto p
+             in
+             let __ () =
+             ( List.iter
+                 (fun (i, _d, _s) ->
+                    L.debug "dest found: id = %i" i
+                 )
+                 dests
+             ; L.debug "dests total: %i" dests_count
+             )
+             in
+             let proto_call_resp = server & ti_ser ti_proto p in
+             let filled_dests = ti_deser ti_proto_call_resp proto_call_resp in
+             let () = List.iter2
+               (fun (sd_id, sd_put, _sd_get) (rc_id, rc_data) ->
+                  if sd_id <> rc_id
+                  then failwith "call_proto: dest id's mismatch (sd=%i rc=%i)"
+                         sd_id rc_id
+                  else
+                    sd_put rc_data
+               )
+               dests
+               filled_dests
+             in
+             *)
+           (* тут -- только локальный случай. *)
+           let () = ignore ti_proto in
+           let (source, sink) = IO.pipe1 () in
+           let res = IO.runIO
+             ( let () = L.debug "proto_call: before send_optsync" in
+               send_optsync server (Sync (Msg p) sink) >>= fun () ->
+               let () = L.debug "proto_call: send_optsync done" in
+               IO.wait_source source >>= fun () ->
+               let () = L.debug "proto_call: wait_source done" in
+               IO.return ()
+             ) in
+           match res with
+           [ `Ok () -> ()
+           | `Error e -> raise e
+           ]
+        ;
+
+
+        value proto_server
+         : ti 'p -> process_factory 'p -> process_factory 'p
+         = fun ti_proto inner_factory ->
+             (*
+             let p_deser = ti_deser ti_proto in
+             fun i_str ->
+               let i = p_deser i_str in
+               let () = server_func i in
+               let filled : proto_call_resp = List.map
+                 (fun (i, _sd_put, sd_get) -> (i, sd_get ())
+                 )
+                 dests
+               in
+               ti_ser ti_proto_call_resp filled
+             *)
+             (* тут -- только локальный случай. *)
+             let () = ignore ti_proto in
+
+             fun outer_ctx ->
+               inner_factory outer_ctx >>= fun inner_disp ->
+               let rec outer_disp ~inner_disp = fun
+                 [ Msg p as msg ->
+                     let () = L.debug "proto_server: Msg _" in
+                     let dests : list
+                       (int * (string -> unit) * (unit -> string)
+                         * (unit -> bool))
+                      =
+                      try
+                       (* sort_dests & *)
+                       get_dests &
+                       ubox ti_proto p
+                      with
+                      [ e -> ( L.error "proto_server: get_dests: %s"
+                         (Printexc.to_string e) ; raise e ) ]
+                     in
+                     (* пред/пост обработка -- тут. *)
+                     let () = L.debug
+                       "proto_server: passing msg to wrapped proc" in
+                     process_pass_msg_sync inner_disp msg >>= fun res ->
+                     let () = L.debug
+                       "proto_server: got result from wrapped proc" in
+                       if List.for_all
+                            (fun (_, _, _, get_is_filled) -> get_is_filled ())
+                            dests
+                       then
+                         cont res
+                       else
+                         process_exit_exn (Failure
+                           "proto_server function hadn't filled all 'dest's")
+                 | Cmd _ as msg ->
+                     process_pass_msg_sync inner_disp msg >>= cont
+                 ]
+               and cont = fun
+                 [ Exit pe -> process_exit_by_status pe
+                 | Continue k -> process_continue & outer_disp ~inner_disp:k
+                 ]
+               in
+                 IO.return & outer_disp ~inner_disp
+        ;
+
+
+      end
+    ;
+
+
+    value proto_server = Proto.proto_server
+    ;
+
+    value proto_call = Proto.proto_call
+    ;
+
+
+    (*************************************************************)
+
     module type IT_TYPE
      =
       sig
 ;
 
 type call_resp_error =
-  [= `Exn_string of string
+  [= `Exn of exn
+  |  `Exn_string of string
   ]
 ;
 
 type dest 'o
 ;
 
+class ti_dest ['a] : [ (Cdt.ti 'b) ] -> [ unit ] ->
+  object
+    constraint 'a = dest 'b;
+    inherit Cdt.tifull ['a];
+  end
+;
+
+
 (* вызов = аргументы + место для результата *)
 type call 'i 'o = ('i * dest 'o)
 ;
 
 (***************************************************************)
 
-(* переименовать в reply/replyto? *)
-value dest_put : dest 'o -> call_resp 'o -> IO.m unit
+(* пока так, чтобы долго не думать.  потом разберёмся. *)
+value dest_local : unit -> dest 'o
 ;
 
+value dest : #Cdt.ti 'o -> dest 'o
+;
+
+
+
+value dest_put : dest 'o -> call_resp 'o -> unit
+;
+
+value dest_put_val : dest 'o -> 'o -> unit
+;
+
+value dest_put_error : dest 'o -> string -> unit
+;
+
+value dest_put_exn : dest 'o -> exn -> unit
+;
+
+
+
+value dest_get : dest 'o -> IO.m (call_resp 'o)
+;
+
+value dest_get_val : dest 'o -> IO.m 'o
+;
+
+
+
 value create_process :
   process_factory 'i ->
   IO.m (process 'i);
 
+value process_of_server : server_factory 'i 'o -> process_factory (call 'i 'o)
+;
+
 value create_server :
   server_factory 'i 'o ->
   IO.m (server 'i 'o);
 value server_respawn
  : ?max_count:int -> server_factory 'i 'o -> server_factory 'i 'o
 ;
+
+
+(* wraps process_factory into new process_factory that allows to
+   use "protocols".  Protocol is the type ['p] that has values
+   of type [dest 'o] in it.  Protocol typeinfo [Cdt.ti 'p] should
+   allow deconstruction of every value of type ['p] to access
+   all [dest 'o] in runtime.  This is required in local protocol
+   communication to enforce the protocol (to make sure that all
+   [dest 'o] are filled (todo), this is required in remote protocol
+   communication to pass [dest]s from caller to server and to pass
+   [dest]s' values back from server to caller over network, using
+   some serialization (todo: processes should declare, based on
+   [Cdt.ti 'p], which serialization they accept/require/deny).
+   Note: it's bad idea to wrap [process_factory] with [proto_server]
+   more than once, but it's hard/clumsy to enforce this constraint
+   with types. (or.. any ideas?)
+ *)
+value proto_server : Cdt.ti 'p -> process_factory 'p -> process_factory 'p
+;
+
+(* call the process with "proto" semantics (see [proto_server]
+   for description). *)
+value proto_call : Cdt.ti 'p -> process 'p -> 'p -> unit
+;

File parvel.mllib

+# OASIS_START
+# DO NOT EDIT (digest: abebd5ca3a3b7dd387b54a3f12639fa9)
 Parvel
+Lwt_mq_parvel
 Parvel_IO
+Parvel_log
+Parvel_lwt
 Parvel_types
+Typeinfo
 Parvel_ops
-Parvel_lwt
-Lwt_mq_parvel
-Typeinfo
+# OASIS_STOP

File parvel_IO.ml

 include IO_Lwt;
 
+value ( >>= ) = bind_rev
+;
+
 value return_unit = return ()
 ;
 
  and source +'a = Lwt.t 'a
 ;
 
-value pipe1 = Lwt.wait
-  and put_sink = Lwt.wakeup
-  and wait_source s = s
+value pipe1 : unit -> (source 'a * sink 'a) = Lwt.wait
+  and put_sink : sink 'a -> 'a -> unit = Lwt.wakeup
+  and wait_source : source 'a -> m 'a = fun s -> s
 ;
+
+value sleep = Lwt_unix.sleep
+;
+
+
+open Cd_All; open Cdt;
+
+class ti ['z] (ti_a : Cdt.ti 'a) () =
+  ti_simple ['z] (Printf.sprintf "Lwt.t (%s)" ti_a#type_name)
+;

File parvel_log.ml

+open Printf
+;
+
+type log_dest =
+  [ Channel of out_channel
+  | File of string
+  | Function of (string -> unit)
+  ]
+;
+
+type log_level = int
+;
+
+value log_level_debug = 1
+  and log_level_info = 2
+  and log_level_error = 3
+  and log_level_no = 4
+;
+
+(* with additional spaces *)
+value string_of_log_level = fun
+  [ 1 -> " debug   "
+  | 2 -> " info    "
+  | 3 -> " error   "
+  | _ -> assert False
+  ]
+;
+
+
+
+type log_dest_state =
+  [ LS_channel of out_channel
+  | LS_file of string and out_channel
+  | LS_function of (string -> unit)
+  ]
+;
+
+type log_state = (log_dest_state * log_dest * log_level)
+;
+
+
+(* author of original code: ygrek *)
+value time_to_buf ?(gmt=False) ?(ms=False) f buf =
+  let t = (if gmt then Unix.gmtime else Unix.localtime) f in
+  let sec =
+    if ms
+    then sprintf "%07.4f" (mod_float f 60.)
+    else sprintf "%02u" t.Unix.tm_sec
+  in
+    bprintf buf "%04u-%02u-%02uT%02u:%02u:%s%s"
+      (1900 + t.Unix.tm_year)
+      (t.Unix.tm_mon+1)
+      t.Unix.tm_mday
+      t.Unix.tm_hour
+      t.Unix.tm_min
+      sec
+      (if gmt then "Z" else "")
+;
+
+
+value log_gmt = True
+  and log_ms = True
+;
+
+value write log_state level line =
+  match log_state with
+  [ (cur_state, _cur_dest, cur_level) ->
+      if level < cur_level
+      then ()
+      else
+        let buf = Buffer.create 100 in
+        ( time_to_buf ~gmt:log_gmt ~ms:log_ms
+           (Unix.gettimeofday ()) buf
+        ; Buffer.add_string buf (string_of_log_level level)
+        ; Buffer.add_string buf line
+        ; match cur_state with
+          [ LS_channel c | LS_file _ c ->
+              ( Buffer.add_char buf '\n'
+              ; Buffer.output_buffer c buf
+              ; flush c
+              )
+          | LS_function f -> f (Buffer.contents buf)
+          ]
+        )
+  ]
+;
+
+
+value default_log_dest = Channel stderr
+  and default_log_level = log_level_no
+;
+
+value state_of_dest log_dest log_level =
+  ( match log_dest with
+    [ Channel c -> LS_channel c
+    | File fn ->
+        let c = open_out_gen
+          [ Open_append ; Open_creat ; Open_binary ]
+          0o666
+          fn
+        in
+          LS_file fn c
+    | Function f -> LS_function f
+    ]
+  , log_dest
<