cothreads/0000750000175000017500000000000010673744171012015 5ustar erikderikdcothreads/Changes0000640000175000017500000000046010671617234013306 0ustar erikderikdCoThreads 0.10 --------------- * STMlib now retarget as coThreads, a full-fledged concurrent/parallel programming library for OCaml * (vm)threads/process engines done, with components (co)thread, mutex, condition, event, stm STM library for OCaml 0.01 -------------------------- * Initial version cothreads/INSTALL0000640000175000017500000000302610671617234013045 0ustar erikderikd=== Prerequisite === The current release has been tested with * OCaml (>= 3.10.0) * GNU Make (>= 3.81) * Linux It may work, or adapted to work under other environment though not being tested yet. === Compile and installation === You may change some path arguments at the beginning of Makefile.template, though we would suggest you not, as the default setting can save you a lot of future efforts in specifying path parameter in common cases. The command is simply make all make install The target installation directories by default are $STDLIB/vmthreads, $STDLIB/threads and $STDLIB/process corresponding to the three engines. To make use of these libraries, you can * either compile and link against the libraries (threads.cma/cothreads.cma) in each of the directories by prefixing including paths e.g. "-I +process" * or compile against the common interfaces located in $STDLIB directory and choose which engine to link with sometime later (by feeding different include paths to linking command) Check other documents from the distribution and website for more details === Cleanup and uninstall === Due to the complex code organisation, we not only provide cleanup but also uninstall directives, as: make clean make uninstall === Examples and documents === The building of examples and documents is optional. If you want, simply enter the corresponding directories and make all/clean. cd example make all make clean cd doc make all make clean cothreads/LICENSE0000640000175000017500000004310310615201452013006 0ustar erikderikd GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Lesser General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. cothreads/Makefile0000640000175000017500000000042410657037006013450 0ustar erikderikdinclude ./Makefile.template all: $(MAKE) -C $(SOURCEDIR) $@ install: $(MAKE) -C $(SOURCEDIR) $@ uninstall: $(MAKE) -C $(SOURCEDIR) $@ doc: $(MAKE) -C $(DOCDIR) $@ clean: ocamlclean $(MAKE) -C $(SOURCEDIR) $@ $(MAKE) -C $(DOCDIR) $@ $(MAKE) -C $(EXAMPLEDIR) $@ cothreads/Makefile.template0000640000175000017500000000212010671575550015264 0ustar erikderikd# Installation setting: Usually the only parameter needs customization INSTALLLIBDIR = $(OCAMLSTDLIBPATH) # Layout of current project SOURCEDIR = src DOCDIR = doc EXAMPLEDIR = example # OCaml related setting OCAMLC = ocamlc $(OCAMLCFLAGS) OCAMLOPT = ocamlopt $(OCAMLOPTFLAGS) OCAMLDEP = ocamldep OCAMLDOC = ocamldoc OCAMLSTDLIBPATH = $(shell $(OCAMLC) -where) INCLUDES= # all relevant -I options here OCAMLCFLAGS=$(INCLUDES) # add other options for ocamlc here OCAMLOPTFLAGS=$(INCLUDES) # add other options for ocamlopt here .SUFFIXES: .cmo .cmi .cmx .ml .mli .mli.cmi: $(OCAMLC) -c $< .ml.cmo: $(OCAMLC) -c $< .ml.cmx: $(OCAMLOPT) -c $< .PHONY: depend all install doc uninstall clean ocamlclean depend .depend: $(OCAMLDEP) $(INCLUDES) *.ml *.mli > .depend ocamlclean: rm -f *.cmi *.cmo *.cmx *.cma *.cmxa *.a *.o *.annot *.out .depend *~ ## Common Routines MKDIR = mkdir -p RM = rm -rf CP = cp -pfr MV = mv -f LN = ln -sf TOUCH = touch CHMOD = chmod -R CHGRP = chgrp -R CHOWN = chown -R TAR = tar TARC = $(TAR) czvf TARX = $(TAR) xzvf AR = ar -include .depend cothreads/README0000640000175000017500000000475710671617234012710 0ustar erikderikd============================================================================= OCaml coThreads (C) 2007 by Zheng Li (li@pps.jussieu.fr) ============================================================================= == Description == coThreads is a [[doc/concurrency.and.parallelism|concurrent/parallel]] programming library for OCaml. It enhances the Threads library of the standard OCaml distribution in the two dimensions: * coThreads implements the same API of the standard Threads library as different execution engines (process, netwoker(TODO)), so that a single copy of source code can be compiled and deployed to different environments without modification * coThreads is also a super set of the standard Threads library, with extra components (STM etc.), functions (spawn etc.), and features (object-level compatibility etc.) === Features ==== The design of coThreads brings several advantages: ==== Powerfulness ==== * The process engine can give you real speedup on a multi-processor machine, the networker engine (TODO) will give you both speedup and scalability. * Combining the original components from the Threads library and the new added ones, coThreads is a full-fledged toolbox covering two main concurrent programming [[doc/paradigm|paradigms]], namely shared-memory and message passing, with both high-level and low-level constructors. * All constructors (e.g. threads, mutex, condition, event, channel, tvar etc.) can be manipulated as first class values, they can even be communicated and shared between independent threads through channels etc.. ==== Compatibility ==== * Fully [[doc/compatibility|compatibility]] with the original Threads library (systhreads and vmthreads), so that you can now deploy your legacy code to new environment for free --- without modifying source code, without learning anything new. * Both source-level and object-level compatibility among different execution engines, so that you can keep a single copy of source code and a single copy of objects files. ==== Convenience ==== * The full library is implemented in user-space, no modification to the OCaml compiler and runtime, so that you can [[doc/usage|use]] it as a set of plain modules. * Switching engines is as easy as changing the include paths of compilation, and it's quite easy to automate the building process over a set of engines (e.g. with lines of pattern rules in your Makefile) == More == Everything at http://cothreads.sf.net cothreads/TODO0000640000175000017500000000016610671617234012506 0ustar erikderikdTODO: * the networker engine * enhanced event module * future module * more examples * tutorial cothreads/VERSION0000640000175000017500000000000510671617234013056 0ustar erikderikd0.10 cothreads/doc/0000750000175000017500000000000010673744143012561 5ustar erikderikdcothreads/doc/Makefile0000640000175000017500000000053310671575550014225 0ustar erikderikdTOPDIR = .. include $(TOPDIR)/Makefile.template all: doc doc: $(MKDIR) html $(MKDIR) man $(OCAMLDOC) -html -d html -colorize-code $(TOPDIR)/$(SOURCEDIR)/*.mli $(TOPDIR)/$(SOURCEDIR)/process/thread.mli $(OCAMLDOC) -man -d man -man-mini $(TOPDIR)/$(SOURCEDIR)/*.mli $(TOPDIR)/$(SOURCEDIR)/process/thread.mli clean: $(RM) html man *~ .dependcothreads/example/0000750000175000017500000000000010673744145013451 5ustar erikderikdcothreads/example/Makefile0000640000175000017500000000210610671575550015111 0ustar erikderikdinclude ../Makefile.template IFRAY = $(if $(findstring ray,$@), $(if $(findstring opt,$@),ray.cmx,ray.cmo)) VMPARAM = -I +vmthreads $(IFRAY) cothreads.cma NATHPARAM = -I +threads $(IFRAY) unix.cma cothreads.cma NATHOPTPARAM = $(NATHPARAM:%.cma=%.cmxa) PROCPARAM = -I +process $(IFRAY) unix.cma cothreads.cma PROCOPTPARAM = $(PROCPARAM:%.cma=%.cmxa) %.vmth: %.cmo $(OCAMLC) -o $@ $(VMPARAM) $< %.nath: %.cmo $(OCAMLC) -o $@ $(NATHPARAM) $< %.nath.opt: %.cmx $(OCAMLOPT) -o $@ $(NATHOPTPARAM) $< %.proc: %.cmo $(OCAMLC) -o $@ $(PROCPARAM) $< %.proc.opt: %.cmx $(OCAMLOPT) -o $@ $(PROCOPTPARAM) $< ALLTEST = coth evt lock ray_col ray_nocol test mvar merge mcast phil santa all: $(ALLTEST:%=%.vmth) $(ALLTEST:%=%.nath) $(ALLTEST:%=%.nath.opt) $(ALLTEST:%=%.proc) $(ALLTEST:%=%.proc.opt) clean: ocamlclean $(RM) *.vmth *.nath *.proc *.netw *.opt *.pgm # TODO: # NETWPARAM = -I +networker $(IFRAY) unix.cma cothreads.cma # NETWOPTPARAM = $(NETWOPTPARAM:%.cma=%.cmxa) # %.netw: %.cmo # $(OCAMLC) -o $@ $(NETWPARAM) $< # %.netw.opt: %.cmx # $(OCAMLOPT) -o $@ $(NETWOPTPARAM) $< cothreads/example/README0000640000175000017500000000556610673743342014344 0ustar erikderikd= README = == BUILD == Just ''make all'' after you've got coThreads installed on your system. Type ''make clean'' to remove all imtermediate and final building results. == LIST == * coth (use: Thread (or Cothread), Mutex) Simple test of mutex. A set of threads tries to grab a single mutex and release it for random times * evt (use: Thread (or Cothread), Event) Simple test of event. Most examples are directly from the OCaml OReilly book. The execution won't exist, this is intentional. * lock (use: Thread (or Cothread), Mutex) Simple test of mutex. A set of threads try to grab two mutex. Each thread first must grab the first mutex before the second mutex, then release the second mutex and the first one. * mcast (use: Thread (or Cothread), Stm) STM example from [1], contributed by Yoriyuki Yamagata * merge (use: Thread (or Cothread), Stm) STM example from [1], contributed by Yoriyuki Yamagata * mvar (use: Thread (or Cothread), Stm) STM example from [1], contributed by Yoriyuki Yamagata * phil (use: Thread (or Cothread), Stm) Classical philosophers dinning problem written in STM. Launch it with [./phil n], where n is the number of philosophers and chopsticks. * ray_col, ray_nocol (use: Cothread, Event) Replanted versions of Jon Harrop's ray tracer [3]. ray.ml is the module containing common computation functions, ray_xxx.ml are parallel engines. In ray_nocol.ml, the workers don't send the results back to master, instead they write them directly to the output file; in ray_col.ml, the workers send results back to the master, and the master write them to the output file. Launch it with [./ray_xxx level size degree outputfile], where [level] and [size] are about the quality of output image, and [degree] is the parallel degree which should equal or greater than the cores or cpus of your machine if you'd like to get the most speedup. Or you may just lanch it with [./ray_xxx] which takes the default setting [./ray_xxx 9 512 2 ray_xxx.pgm] * santa (use: Thread (or Cothread), Stm) The Santa Clause problem documented in [2]. The haskell version is attached as comment at the end of the file. * sing (use: Thread (or Cothread), Stm) Simple test of Stm. Two threads constantly update a single tvar. * test (use: Thread (or Cothread), Stm) Simple test of Stm to calculate the sum of [0..n-1] with n threads. The i_th thread is responsible for adding i to the sum. Its action is not allowed to take place until the current sum exceed sum (i/10). * The Makefile itself is an example. It shows that how you can build your applications against a set of execution engines with just a few lines of pattern rules. [1] http://research.microsoft.com/users/simonpj/papers/stm/index.htm#composble [2] https://research.microsoft.com/users/simonpj/papers/stm/index.htm#beautiful [3] http://www.ffconsultancy.com/languages/ray_tracer/index.html cothreads/example/coth.ml0000640000175000017500000000100110673743342014727 0ustar erikderikd(* Or open Thread *) open Cothread let lk = Mutex.create () let test_f () = let myid = id (self ()) in let r = Random.int 1000 in for i = 0 to r do (* test (Printf.sprintf "%dth test from %d\n" i myid); *) while (not (Mutex.try_lock lk)) do Printf.printf "%d fail to get the mutex\n" myid; done; Printf.printf "%d finally get the mutex\n" myid; Mutex.unlock lk done let ith_array = Array.init 7 (fun _ -> create test_f ()) let _ = Array.iter (fun t -> join t) ith_array cothreads/example/evt.ml0000640000175000017500000000316110673743342014601 0ustar erikderikd(* Or just use Thread *) module Thread=Cothread (* Test 1 *) let ch1 = Event.new_channel () let r = Event.choose (Array.to_list (Array.init 10 Event.always));; let ntimes n = for i = 0 to (n-1) do match Event.poll r with Some i -> print_int i | _ -> assert false done;; (* Test 2 *) let e1 = Event.guard (fun () -> print_endline "Guard"; Event.always 999) let e2 = Event.wrap_abort (Event.receive ch1) (fun _ -> print_endline "Fail") let e = Event.wrap (Event.choose [e1; e2]) (Printf.printf "Result: %d\n") let kinds () = Event.sync e; print_endline "End!" (* Test 3 *) let ch2 = Event.new_channel () let f1 () = Event.sync (Event.send ch2 8888) let f2 () = Event.sync (Event.wrap (Event.receive ch2) print_int) let f3 () = ignore (Thread.create f1 ()); ignore (Thread.create f2 ()) (* Test 4 *) let c = Event.new_channel ();; let f () = let ids = string_of_int (Thread.id (Thread.self ())) in print_string ("-------- before -------" ^ ids) ; print_newline() ; let e = Event.receive c in print_string ("-------- during -------" ^ ids) ; print_newline() ; let v = Event.sync e in print_string (v ^ " " ^ ids ^ " ") ; print_string ("-------- after -------" ^ ids) ; print_newline() ;; let g () = let ids = string_of_int (Thread.id (Thread.self ())) in print_string ("Start of " ^ ids ^ "\n"); let e2 = Event.send c "hello" in Event.sync e2 ; print_string ("End of " ^ ids) ; print_newline () ;; let _ = ntimes 100; kinds (); f3 (); let t1 = Thread.create f () in let t2 = Thread.create f () in let t3 = Thread.create g () in Thread.join t1; Thread.join t2; Thread.join t3 cothreads/example/lock.ml0000640000175000017500000000107610673743342014736 0ustar erikderikdmodule Thread=Cothread (* Or just use Thread, no difference *) open Thread let lk1 = Mutex.create () let lk2 = Mutex.create () let rec run x = Mutex.lock lk1; Printf.printf "%d takes lock 1\n" x; flush stdout; Mutex.lock lk2; Printf.printf "%d takes lock 2\n" x; flush stdout; Mutex.unlock lk2; Printf.printf "%d release lock 2\n" x; flush stdout; Mutex.unlock lk1; Printf.printf "%d release lock 1\n" x; flush stdout; Thread.delay (Random.float 0.2); run x let _ = ignore (Array.init 10 (Thread.create run)); while true do Thread.delay 5.0 done cothreads/example/mcast.ml0000640000175000017500000000230310671575550015111 0ustar erikderikdmodule Thread=Cothread open Stm type 'a chain = 'a item tvar and 'a item = Empty | Full of 'a * 'a chain type 'a mchan = 'a chain tvar type 'a port = 'a chain tvar let new_mchan = new_tvar Empty >>= fun c -> new_tvar c let new_port mc = read_tvar mc >>= fun c -> new_tvar c let read_port p = read_tvar p >>= fun c -> read_tvar c >>= function Empty -> retry | Full (v, c') -> write_tvar p c' >> return v let write_mchan mc v = read_tvar mc >>= fun c -> new_tvar Empty >>= fun c' -> write_tvar c (Full (v, c')) >> write_tvar mc c' let producer mc = let c = ref 0 in while true do Thread.delay (Random.float 0.2); atom (write_mchan mc !c); Printf.printf "produced %d\n" !c; incr c done let consumer n mc = let p = atom (new_port mc) in while true do Thread.delay (Random.float 0.1); Printf.printf "%d receives %d\n" n (atom (read_port p)); flush_all (); done let main () = let mc = atom (new_mchan) in let prod = Thread.create producer mc in let consum1 = Thread.create (consumer 1) mc in let consum2 = Thread.create (consumer 2) mc in Thread.join prod; Thread.join consum1; Thread.join consum2; () let () = main () cothreads/example/merge.ml0000640000175000017500000000164310671575550015107 0ustar erikderikdmodule Thread=Cothread open Stm type 'a mvar = 'a option tvar let new_empty_mvar = new_tvar None let take_mvar mv = read_tvar mv >>= (function None -> retry | Some v -> write_tvar mv None >>= (function _ -> return v)) let put_mvar mv v = read_tvar mv >>= (function None -> write_tvar mv (Some v) | Some v -> retry) let producer n mv = while true do Thread.delay (Random.float 0.2); atom (put_mvar mv n); done let merge mv1 mv2 = while true do Printf.printf "Receive signal from %d\n" (atom (or_else (take_mvar mv1) (take_mvar mv2))); flush_all () done let main () = let mv1 = atom new_empty_mvar in let mv2 = atom new_empty_mvar in let prod1 = Thread.create (producer 1) mv1 in let prod2 = Thread.create (producer 2) mv2 in let consum = Thread.create (merge mv1) mv2 in Thread.join prod1; Thread.join prod2; Thread.join consum; () let () = main () cothreads/example/mvar.ml0000640000175000017500000000143210661673351014746 0ustar erikderikdmodule Thread=Cothread open Stm type 'a mvar = 'a option tvar let new_empty_mvar () = tvar None let take_mvar mv = read_tvar mv >>= (function None -> retry | Some v -> write_tvar mv None >>= (function _ -> return v)) let put_mvar mv v = read_tvar mv >>= (function None -> write_tvar mv (Some v) | Some v -> retry) let producer mv = let c = ref 0 in while true do Thread.delay (Random.float 0.05); atom (put_mvar mv !c); incr c done let consumer mv = while true do Printf.printf "Receive %d\n" (atom (take_mvar mv)); flush_all (); done let main () = let mv = new_empty_mvar () in let prod = Thread.create producer mv in let consum = Thread.create consumer mv in Thread.join prod; Thread.join consum; () let () = main () cothreads/example/phil.ml0000640000175000017500000000277110673743342014745 0ustar erikderikd(* Classical philosopher dinning problem written in STM. Launch it with [./phil n], where n is the number of philosophers and chopsticks. *) module Thread=Cothread (* Or use Thread directly *) open Stm (* Number of philosophers and chopsticks, the degree *) let n = try int_of_string Sys.argv.(1) with Invalid_argument _ -> prerr_endline "Launch the program with a single int, e.g. ./phil 5"; exit 1 let chopstick = Array.init n (fun _ -> tvar true) let left x = x and right x = (x + 1) mod n let check b = if b then return () else retry (* Actions: think, eat, takeup, putdown*) let think x = Printf.printf "Phil %d begins his THINKING ...\n" x; flush stdout; Thread.delay (Random.float 0.1) let eat x = Printf.printf "Phil %d begins to EAT -----> \n" x; Thread.delay (Random.float 0.02); Printf.printf "Phil %d now finish EAT <----- \n" x; flush stdout let chop_act x s l r = Printf.printf "Phil %d %s chopstick %d and %d\n" x s l r let takeup id = read_tvar chopstick.(id) >>= check >> write_tvar chopstick.(id) false let putdown id = write_tvar chopstick.(id) true (* Philosopher thread function *) let phil x = let l,r = (left x, right x) in let rec run () = think x; atom (takeup l >> takeup r); chop_act x "take up" l r; eat x; atom (putdown l >> putdown r); chop_act x "put down" l r; run () in Random.self_init (); run () let main () = let phils = Array.init n (Thread.create phil) in Array.iter Thread.join phils let _ = main () cothreads/example/prod_consum.ml0000640000175000017500000000375510671575550016346 0ustar erikderikd(* Example taken from the OReilly book *) open Libextunix open Coordinator let create () = let name = fresh_name "_pipe" in let () = Unix.mkfifo name file_perm in let read_fd = Unix.openfile name [Unix.O_RDONLY; Unix.O_NONBLOCK] file_perm in let write_fd = Unix.openfile name [Unix.O_WRONLY] file_perm in let _ = Unix.unlink name in (read_fd, write_fd) ;; let c = Condition.create () ;; let m = Mutex.create ();; let r,w = create ();; let produce i p d = incr p ; Cothread.delay d ; Printf.printf "Producer (%d) has produced %d\n" i !p; Mutex.lock m ; Printf.printf "Producer (%d) take the lock\n" i; marshal_write (i,!p) w; Printf.printf "Producer (%d) has added its %dth product\n" i !p; Condition.signal c; Printf.printf "Producer (%d) has signal others\n" i; Mutex.unlock m; Printf.printf "Producer (%d) has unlock it\n" i let producer2 i = let p = ref 0 in let d = Random.float 0.2 in try while true do produce i p d; Cothread.delay (Random.float 0.2); done with Unix.Unix_error (e,_,_) -> Printf.printf "Producer (%d) exit because of %s" i (Unix.error_message e) let wait2 i = Mutex.lock m ; Printf.printf "Consumer (%d) take the lock\n" i; while (let rr,_,_ = Cothread.select [r] [] [] 0.0 in rr = []) do Printf.printf "Consumer (%d) is waiting (and relase the lock)\n" i; Condition.wait c m; Printf.printf "Consumer (%d) wakes up\n" i; done ;; let take2 i = let ip, p = marshal_read r in Printf.printf "Consumer (%d) takes product (%d, %d)\n" i ip p; Mutex.unlock m ; Printf.printf "Consumer (%d) release the lock\n" i let consumer2 i = try while true do wait2 i; take2 i; Cothread.delay (Random.float 0.2); done with Unix.Unix_error (e,_,_) -> Printf.printf "Consumer (%d) exit because of %s" i (Unix.error_message e) ;; for i = 0 to 3 do ignore (Cothread.create producer2 i); done ; for i = 0 to 9 do ignore (Cothread.create consumer2 i) done; while true do Cothread.delay 5. done ;; cothreads/example/ray.ml0000640000175000017500000000744510660137370014601 0ustar erikderikdlet delta = sqrt epsilon_float type vec = {x:float; y:float; z:float} let ( *| ) s r = {x = s *. r.x; y = s *. r.y; z = s *. r.z} let ( +| ) a b = {x = a.x +. b.x; y = a.y +. b.y; z = a.z +. b.z} let ( -| ) a b = {x = a.x -. b.x; y = a.y -. b.y; z = a.z -. b.z} let dot a b = a.x *. b.x +. a.y *. b.y +. a.z *. b.z let length r = sqrt(dot r r) let unitise r = 1. /. length r *| r type scene = Sphere of vec * float | Group of vec * float * scene * scene * scene * scene * scene let ray_sphere {x=dx; y=dy; z=dz} {x=vx; y=vy; z=vz} r = let disc = vx *. vx +. vy *. vy +. vz *. vz -. r *. r in if disc < 0. then infinity else let b = vx *. dx +. vy *. dy +. vz *. dz in let b2 = b *. b in if b2 < disc then infinity else let disc = sqrt(b2 -. disc) in let t1 = b -. disc in if t1 > 0. then t1 else b +. disc let ray_sphere' {x=ox; y=oy; z=oz} {x=dx; y=dy; z=dz} {x=cx; y=cy; z=cz} r = let vx = cx -. ox and vy = cy -. oy and vz = cz -. oz in let vv = vx *. vx +. vy *. vy +. vz *. vz in let b = vx *. dx +. vy *. dy +. vz *. dz in let disc = b *. b -. vv +. r *. r in disc >= 0. && b +. sqrt disc >= 0. type hit = {l: float; nx: float; ny: float; nz: float} let rec intersect ({x=dx; y=dy; z=dz} as dir) hit = function Sphere ({x=cx; y=cy; z=cz} as center, radius) -> let l' = ray_sphere dir center radius in if l' >= hit.l then hit else let x = l' *. dx -. cx in let y = l' *. dy -. cy in let z = l' *. dz -. cz in let il = 1. /. sqrt(x *. x +. y *. y +. z *. z) in {l = l'; nx = il *. x; ny = il *. y; nz = il *. z} | Group (center, radius, a, b, c, d, e) -> let l' = ray_sphere dir center radius in if l' >= hit.l then hit else let f h s = intersect dir h s in f (f (f (f (f hit a) b) c) d) e let rec intersect' orig dir = function Sphere (center, radius) -> ray_sphere' orig dir center radius | Group (center, radius, a, b, c, d, e) -> let f s = intersect' orig dir s in ray_sphere' orig dir center radius && (f a || f b || f c || f d || f e) let neg_light = unitise { x = 1.; y = 3.; z = -2. } let rec ray_trace dir scene = let hit = intersect dir {l=infinity; nx=0.; ny=0.; nz=0.} scene in if hit.l = infinity then 0. else let n = {x = hit.nx; y = hit.ny; z = hit.nz} in let g = dot n neg_light in if g < 0. then 0. else if intersect' (hit.l *| dir +| delta *| n) neg_light scene then 0. else g let fold5 f x a b c d e = f (f (f (f (f x a) b) c) d) e let rec create level c r = let obj = Sphere (c, r) in if level = 1 then obj else let a = 3. *. r /. sqrt 12. in let rec bound (c, r) = function Sphere (c', r') -> c, max r (length (c -| c') +. r') | Group (_, _, v, w, x, y, z) -> fold5 bound (c, r) v w x y z in let aux x' z' = create (level - 1) (c +| {x=x'; y=a; z=z'}) (0.5 *. r) in let w = aux (-.a) (-.a) and x = aux a (-.a) in let y = aux (-.a) a and z = aux a a in let c, r = fold5 bound (c +| {x=0.; y=r; z=0.}, 0.) obj w x y z in Group (c, r, obj, w, x, y, z) let string_init n f = if n = 0 then "" else let s = String.create n in for i = 0 to n-1 do s.[i] <- f i done; s let offset size degree i = i * (size/degree) + (min (size mod degree) i) let raster scene ss l s d y = string_init s (fun x -> let g = ref 0. in for dx = 0 to ss - 1 do for dy = 0 to ss - 1 do let aux x d = float x -. float s /. 2. +. float d /. float ss in let dir = unitise {x = aux x dx; y = aux y dy; z = float s } in g := !g +. ray_trace dir scene done done; let g = 0.5 +. 255. *. !g /. float (ss*ss) in char_of_int (int_of_float g)) let rasters l s d i = let scene = create l { x = 0.; y = -1.; z = 4. } 1. and ss = 4 in let off = offset s d i in (off, Array.init ((s-i-1)/d + 1) (fun j -> raster scene ss l s d (s-off-j))) cothreads/example/ray_col.ml0000640000175000017500000000232210660137370015423 0ustar erikderikdmodule Thread = Cothread open Ray (* This kind of function should really be integrated into the Event module *) let event_map ea' = let ea = Array.mapi (fun i e -> `Left (Event.wrap e (fun v -> (i, v)))) ea' in let rec run () = let el = Array.fold_left (fun l -> function `Left e -> e::l | `Done _ -> l) [] ea in match el with | [] -> Array.map (function `Done v -> v | `Left _ -> assert false) ea | _ -> let (i,v) = Event.select el in ea.(i) <- `Done v; run () in run () let (l,s,d,o) = try (int_of_string Sys.argv.(1), int_of_string Sys.argv.(2), int_of_string Sys.argv.(3), Sys.argv.(4)) with _ -> let name = Filename.basename (Sys.argv.(0)) in Printf.fprintf stderr "Command: \"%s level size degree output\"\n" name; Printf.fprintf stderr "Launch: \"./%s 9 512 2 %s.pgm\"\n" name name; flush stderr; (9, 512, 2, name^".pgm") let () = let oc = open_out o in Printf.fprintf oc "P5\n%d %d\n255\n" s s; let pos = pos_out oc in let worker i = rasters l s d i in let output (off,ra) = seek_out oc (pos+s*off); Array.iter (output_string oc) ra in let ea = Array.init d (fun i -> Event.wrap (Thread.spawn worker i) output) in ignore (event_map ea); close_out oc cothreads/example/ray_nocol.ml0000640000175000017500000000147010660137370015763 0ustar erikderikdmodule Thread=Cothread open Ray let (l,s,d,o) = try (int_of_string Sys.argv.(1), int_of_string Sys.argv.(2), int_of_string Sys.argv.(3), Sys.argv.(4)) with _ -> let name = Filename.basename (Sys.argv.(0)) in Printf.fprintf stderr "Command: \"%s level size degree output\"\n" name; Printf.fprintf stderr "Launch defaults: \"./%s 9 512 2 %s.pgm\"\n" name name; (9, 512, 2, name^".pgm") let () = let oc = open_out o in Printf.fprintf oc "P5\n%d %d\n255\n" s s; let pos = pos_out oc in close_out oc; let output (off,ra) = let oc = open_out_gen [Open_wronly] 0o644 o in seek_out oc (pos+s*off); Array.iter (output_string oc) ra; close_out oc in let worker i = output (rasters l s d i) in let ta = Array.init d (Thread.create worker) in Array.iter (fun t -> Thread.join t) ta cothreads/example/santa.ml0000640000175000017500000001344010671575550015114 0ustar erikderikd(* OCaml version of the Santa Claus problem documented in Simon Peython Jones's "Beautiful concurrency" paper. This is a _literal_ translation of the Haskell version (attached as comment a the end of this file) *) module Thread=Cothread open Stm type gate = {gt_num:int; gt_left: int tvar} let new_gate n = new_tvar 0 >>= fun left -> return {gt_num = n; gt_left = left} let use_gate {gt_left = left} = atom (read_tvar left >>= fun v -> if v > 0 then write_tvar left (v - 1) else retry) let operate_gate {gt_num = num; gt_left = left} = atom (write_tvar left num); atom (read_tvar left >>= fun v -> if v > 0 then retry else return ()) type group = {gp_num: int; gp_left: (int * gate * gate) tvar} let new_group n = atom (new_gate n >>= fun g1 -> new_gate n >>= fun g2 -> new_tvar (n, g1, g2) >>= fun tv -> return {gp_num = n; gp_left = tv}) let join_group {gp_left = left} = atom (read_tvar left >>= fun (n_left, g1, g2) -> if n_left > 0 then write_tvar left (n_left - 1, g1, g2) >> return (g1, g2) else retry) let await_group {gp_num = num; gp_left = left} = read_tvar left >>= fun (n_left, g1, g2) -> if n_left = 0 then new_gate num >>= fun new_g1 -> new_gate num >>= fun new_g2 -> write_tvar left (num, new_g1, new_g2) >> return (g1, g2) else retry let rec helper gp id task = let in_gate, out_gate = join_group gp in use_gate in_gate; task id; flush stdout; use_gate out_gate; Thread.delay (Random.float 0.5); helper gp id task let run task (in_gt, out_gt) = Printf.printf "Ho! Ho! Ho! let's %s\n" task; flush stdout; operate_gate in_gt; operate_gate out_gt (* Note that IO () in haskell corresponds here to () -> () *) let choose choices = let actions = List.map (fun (stm,act) -> stm >>= fun x -> return (fun () -> act x)) choices in let action = match actions with | [] -> return (fun () -> ()) | h::t -> List.fold_left or_else h t in atom action let rec santa elf_gp rein_gp = print_endline "----------------------"; choose [ (await_group rein_gp, run "deliver toys"); (await_group elf_gp, run "meet in study"); ] (); santa elf_gp rein_gp let main () = let elf_gp = new_group 3 in let _ = Array.init 10 (Thread.create (fun i -> helper elf_gp (i + 1) (Printf.printf "Elf %d meeting in the study\n"))) in let rein_gp = new_group 9 in let _ = Array.init 9 (Thread.create (fun i -> helper rein_gp (i + 1) (Printf.printf "Reindeer %d delivering toys\n"))) in santa elf_gp rein_gp let _ = main () (* We attach the original Haskell solution below *) (* {-# OPTIONS -package stm #-} module Main where import Control.Concurrent.STM import Control.Concurrent import System.Random main = do { elf_gp <- newGroup 3 ; sequence [ elf elf_gp n | n <- [1..10]] ; rein_gp <- newGroup 9 ; sequence [ reindeer rein_gp n | n <- [1..9]] ; forever (santa elf_gp rein_gp) } where elf gp id = forkIO (forever (do { elf1 gp id; randomDelay })) reindeer gp id = forkIO (forever (do { reindeer1 gp id; randomDelay })) santa :: Group -> Group -> IO () santa elf_group rein_group = do { putStr "----------\n" ; choose [(awaitGroup rein_group, run "deliver toys"), (awaitGroup elf_group, run "meet in my study")] } where run :: String -> (Gate,Gate) -> IO () run what (in_gate,out_gate) = do { putStr ("Ho! Ho! Ho! let's " ++ what ++ "\n") ; operateGate in_gate ; operateGate out_gate } helper1 :: Group -> IO () -> IO () helper1 group do_task = do { (in_gate, out_gate) <- joinGroup group ; useGate in_gate ; do_task ; useGate out_gate } elf1, reindeer1 :: Group -> Int -> IO () elf1 group id = helper1 group (meetInStudy id) reindeer1 group id = helper1 group (deliverToys id) deliverToys id = putStr ("Reindeer " ++ show id ++ " delivering toys\n") meetInStudy id = putStr ("Elf " ++ show id ++ " meeting in the study\n") --------------- data Group = MkGroup Int (TVar (Int, Gate, Gate)) newGroup :: Int -> IO Group newGroup n = atomically (do { g1 <- newGate n ; g2 <- newGate n ; tv <- newTVar (n, g1, g2) ; return (MkGroup n tv) }) joinGroup :: Group -> IO (Gate,Gate) joinGroup (MkGroup n tv) = atomically (do { (n_left, g1, g2) <- readTVar tv ; check (n_left > 0) ; writeTVar tv (n_left-1, g1, g2) ; return (g1,g2) }) awaitGroup :: Group -> STM (Gate,Gate) awaitGroup (MkGroup n tv) = do { (n_left, g1, g2) <- readTVar tv ; check (n_left == 0) ; new_g1 <- newGate n ; new_g2 <- newGate n ; writeTVar tv (n,new_g1,new_g2) ; return (g1,g2) } --------------- data Gate = MkGate Int (TVar Int) newGate :: Int -> STM Gate newGate n = do { tv <- newTVar 0; return (MkGate n tv) } useGate :: Gate -> IO () useGate (MkGate n tv) = atomically (do { n_left <- readTVar tv ; check (n_left > 0) ; writeTVar tv (n_left-1) }) operateGate :: Gate -> IO () operateGate (MkGate n tv) = do { atomically (writeTVar tv n) ; atomically (do { n_left <- readTVar tv ; check (n_left == 0) }) } ---------------- forever :: IO () -> IO () -- Repeatedly perform the action forever act = do { act; forever act } randomDelay :: IO () -- Delay for a random time between 1 and 1000,000 microseconds randomDelay = do { waitTime <- getStdRandom (randomR (1, 1000000)) ; threadDelay waitTime } choose :: [(STM a, a -> IO ())] -> IO () choose choices = do { to_do <- atomically (foldr1 orElse stm_actions) ; to_do } where stm_actions :: [STM (IO ())] stm_actions = [ do { val <- guard; return (rhs val) } | (guard, rhs) <- choices ] *) cothreads/example/sing.ml0000640000175000017500000000060110661673351014736 0ustar erikderikdmodule Thread=Cothread open Stm let tv = tvar 10 let rec run op t = Thread.delay (Random.float t); atom (read_tvar tv >>= fun x -> Printf.printf "I read %d\n" x; flush_all (); write_tvar tv (op x)); run op t let th1 = Thread.create (run (fun x -> x * 2 + 1)) 0.5 let th2 = Thread.create (run (fun x -> x / 2)) 1.0 let _ = Thread.join th1; Thread.join th2 cothreads/example/test.ml0000640000175000017500000000137410671575550014770 0ustar erikderikd(* Simple example without much meanings, for test purpose *) module Thread=Cothread open Stm;; let rec accu x = if x = 0 then 0 else x + (accu (pred x)) let simple () = let tv = tvar 0 in let trans x = read_tvar tv >>= fun v -> Thread.delay (Random.float 0.001); if v >= accu (x/10) then return (atom (write_tvar tv (x + v))) else retry in let rec thread_fun x = match atom_once (trans x) with | None -> Printf.printf "%d fail\n" x; flush stdout; thread_fun x | Some _ -> Printf.printf "%d succ\n" x; flush stdout in let thr_array = Array.init 300 (fun x -> Thread.create thread_fun (x+1)) in Array.iter Thread.join thr_array; Printf.printf "Final result: %d\n" (atom (read_tvar tv)); flush_all () let _ = simple () cothreads/src/0000750000175000017500000000000010673744144012604 5ustar erikderikdcothreads/src/Makefile0000640000175000017500000000167210671575550014254 0ustar erikderikdinclude ../Makefile.template BACKENDS = threads vmthreads process AUXMOD = libext libextunix AUXMODBYT = $(AUXMOD:%=%.cmo) AUXMODNAT = $(AUXMOD:%=%.cmx) COMMONMOD = mutex condition event COMMONMODINTFSRC = $(COMMONMOD:%=%.mli) COMMONMODINTFCOM = $(COMMONMOD:%=%.cmi) EXTRAMOD = cothread stm EXTRAMODINTFSRC = $(EXTRAMOD:%=%.mli) EXTRAMODINTFCOM = $(EXTRAMOD:%=%.cmi) INSTALLFILES = $(COMMONMODINTFCOM) $(EXTRAMODINTFSRC) $(EXTRAMODINTFCOM) $(COMMONMODINTFSRC): %: $(OCAMLSTDLIBPATH)/% @if [ ! -L $@ ]; then ln -s $< .; fi .PHONY: all install clean uninstall sub% all: $(AUXMODBYT) $(AUXMODNAT) $(COMMONMODINTFCOM) $(EXTRAMODINTFCOM) suball install: all subinstall $(MKDIR) $(INSTALLLIBDIR) $(CP) $(INSTALLFILES) $(INSTALLLIBDIR) uninstall: subuninstall for i in $(INSTALLFILES); do $(RM) $(INSTALLLIBDIR)/$$i; done clean: ocamlclean subclean find . -type l -exec $(RM) '{}' \; sub%: @for i in $(BACKENDS); do $(MAKE) -C $$i $*; done cothreads/src/cothread.mli0000640000175000017500000000344410671575550015107 0ustar erikderikd(** Super set of standard Thread module. It serves two purpose: 1) a unified threads maniputation interface among different engines, so that we can achieve object-level compatability 2) extended functions of threads maniputation *) (** {6 The part compatible with standard Thread module} *) type t val create : ('a -> 'b) -> 'a -> t val self : unit -> t val id : t -> int val exit : unit -> unit val kill : t -> unit val delay: float -> unit val join : t -> unit val wait_read : Unix.file_descr -> unit val wait_write : Unix.file_descr -> unit val wait_timed_read : Unix.file_descr -> float -> bool val wait_timed_write : Unix.file_descr -> float -> bool val select : Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list * Unix.file_descr list val wait_pid : int -> int * Unix.process_status val yield : unit -> unit val wait_signal : int list -> int (** {6 Extended functions} *) (** The interface of [spawn] and [spawnl] may change in the future. We have find a more elegent and comprehensive way to abstract the whole family of this kind of computation. Just need more time to implement. *) (** [spawn f x] launch up the computation of [(f x)] in a separate thread right away, the result is return as a event which you can [sync] with. Re-sync with the same event will bring you the same result, the computation won't repeat. *) val spawn: ('a -> 'b) -> 'a -> 'b Event.event (** [spawnl f x] returns a event represents the computation of [(f x)] as a separate thread, just like [spwan]. However the computation will be defered until it's been [sync] with. Whenever you [sync] the event, a new thread is relaunched to do the same computation *) val spawnl: ('a -> 'b) -> 'a -> 'b Event.event cothreads/src/libext.ml0000640000175000017500000001004210671575550014424 0ustar erikderikdexception Break exception NoImplementationYet let noimplementation x = raise NoImplementationYet let list_find_split = let rec find_rec test acc = function | [] -> raise Not_found | h :: t -> if test h then (acc, h, t) else find_rec test (h::acc) t in fun test l -> find_rec test [] l let rec list_find_app f = function | [] -> None | h::t -> match f h with Some _ as v -> v | None -> list_find_app f t let bit_chop_to_n n x = let capability = 1 lsl n - 1 in x land capability module Map_Make (Ord:Map.OrderedType) : sig include Map.S type 'a patch = (key * ('a option * 'a option)) list val diff: ('a -> 'a -> bool) -> 'a t -> 'a t -> 'a patch val patch_left: ('a -> 'a -> bool) -> 'a t -> 'a patch -> 'a t val patch_right: ('a -> 'a -> bool) -> 'a patch -> 'a t -> 'a t val merge: (key -> 'a -> 'a -> 'a t -> 'a t) -> 'a t -> 'a t -> 'a t end with type key = Ord.t = struct include Map.Make (Ord) type 'a patch = (key * ('a option * 'a option)) list let to_list t = fold (fun k v l -> (k,v)::l) t [] (* decrease order *) let diff eq t1 t2 = let lt1 = to_list t1 and lt2 = to_list t2 in let rec diff_aux eq accu = function | [], l -> List.fold_left (fun a (k, v) -> (k, (None, Some v))::a) accu l | l, [] -> List.fold_left (fun a (k, v) -> (k, (Some v, None))::a) accu l | (((k1,v1) :: t1) as l1), (((k2,v2) :: t2) as l2) -> let (accu', l1', l2') = let sign = Ord.compare k1 k2 in if sign > 0 then (k1, (Some v1, None)) :: accu, t1, l2 else if sign < 0 then (k2, (None, Some v2)) :: accu, l1, t2 else (if eq v1 v2 then accu else ((k1, (Some v1, Some v2))::accu)), t1, t2 in diff_aux eq accu' (l1', l2') in diff_aux eq [] (lt1, lt2) let patch_gen eq pick diff t = let patch_fun t (k,d) = match pick d with | Some v1, v2 -> if eq (find k t) v1 then let t' = remove k t in match v2 with Some v -> add k v t' | _ -> t' else raise Not_found | _, Some v2 -> add k v2 t | _, _ -> failwith "Not a valid patch" in List.fold_left patch_fun t diff let patch_left eq t diff = patch_gen eq (fun d -> d) diff t let patch_right eq diff t = patch_gen eq (fun (a,b) -> (b,a)) diff t let merge f t1 t2 = let add_item k v tbl = try f k v (find k tbl) tbl with Not_found -> add k v tbl in fold add_item t1 t2 end open Obj let obj_fields_from pos obj = let rec walk acc = function | n when n >= pos -> walk (field obj n :: acc) (n - 1) | _ -> acc in walk [] (size obj - 1) (* all prefix, depth first visit *) let obj_find prop v = let obj = repr v in let already_seen = ref [] in let rec find_aux o = if List.memq o !already_seen then None else if prop o then Some o else (already_seen := o :: !already_seen; if tag o < no_scan_tag then list_find_app find_aux (obj_fields_from 0 o) else None ) in find_aux obj let obj_iter f v = let obj = repr v in let already_seen = ref [] in let rec iter_aux o = if not (List.memq o !already_seen) then (f o; already_seen := o :: !already_seen; if tag o < no_scan_tag then List.iter iter_aux (obj_fields_from 0 o)) in iter_aux obj let obj_refed_by eq a b = match obj_find (eq (repr a)) b with None -> false | Some _ -> true (* Distructive substitution, note that rb is reference type because otherwise we have no way to substitute the whole expression, if it satify the condition *) let obj_subst eq ((a: 'a), (a': 'a)) rb = let oa = repr a and ob = repr (!rb) and oa' = repr a' in let already_seen = ref [] in let rec subst_aux o = if not (List.memq o !already_seen) then (already_seen := o :: !already_seen; if tag o < no_scan_tag then for i = 0 to size o do let oi = field o i in let equal = try eq oi oa with Invalid_argument _ -> oi == oa in if equal then set_field o i oa' else subst_aux oi done) in if eq ob oa then rb := obj oa' else subst_aux ob cothreads/src/libextunix.ml0000640000175000017500000000302010671575550015326 0ustar erikderikdopen Unix (* Atomically write OCaml value to file_descr for both block/nonblock mode *) let marshal_write = let rec write_rec fd s ofs len = let len' = try write fd s ofs len with Unix_error ((EAGAIN|EWOULDBLOCK),_,_) when ofs > 0 -> 0 in match len' with | 0 -> ignore (select [] [fd] [] (-1.)); write_rec fd s ofs len | _ when len' < len -> write_rec fd s (ofs + len') (len - len') | _ -> () in fun v fd -> let str = Marshal.to_string v [Marshal.Closures] in write_rec fd str 0 (String.length str) (* Atomically read OCaml value from file_descr for both block/nonblock mode *) let marshal_read fd = let bsize = Marshal.header_size + 128 in let buf = String.create bsize in let rec read_rec fd buf ofs len = let len' = try Some (read fd buf ofs len) with | Unix_error (EAGAIN,_,_) | Unix_error (EWOULDBLOCK,_,_) when ofs > 0 -> None | e -> raise e in match len' with | Some 0 -> raise End_of_file | Some l when l = len -> () | Some l -> read_rec fd buf (ofs + l) (len -l) | None -> ignore (select [fd] [] [] (-1.)); read_rec fd buf ofs len in read_rec fd buf 0 Marshal.header_size; let data_size = Marshal.data_size buf 0 in let total_size = Marshal.header_size + data_size in let buf = if total_size <= String.length buf then buf else let ext_buf = String.create total_size in String.blit buf 0 ext_buf 0 Marshal.header_size; ext_buf in read_rec fd buf Marshal.header_size data_size; Marshal.from_string buf 0 cothreads/src/networker/0000750000175000017500000000000010673744143014623 5ustar erikderikdcothreads/src/process/0000750000175000017500000000000010673744144014262 5ustar erikderikdcothreads/src/process/Makefile0000640000175000017500000000240210671575550015722 0ustar erikderikdinclude ../../Makefile.template INCLUDES = -I .. BACKEND = process AUXMOD = libext libextunix AUXMODBYT = $(AUXMOD:%=%.cmo) AUXMODNAT = $(AUXMOD:%=%.cmx) LOCALMOD = coordinator COMMONMOD = mutex condition event cothread stm COMMONMODNAT = $(COMMONMOD:%=%.cmx) COMMONMODINTFSRC = $(COMMONMOD:%=%.mli) COMMONMODINTFCOM = $(COMMONMOD:%=%.cmi) COMMONMODINTF = $(COMMONMODINTFSRC) $(COMMONMODINTFCOM) EXTRAMOD = thread EXTRAMODNAT =$(EXTRAMOD:%=%.cmx) EXTRAMODINTFCOM = $(EXTRAMOD:%=%.cmi) ALLMOD = $(LOCALMOD) $(COMMONMOD) $(EXTRAMOD) ALLMODBYT = $(ALLMOD:%=%.cmo) ALLMODNAT = $(ALLMOD:%=%.cmx) LIB = threads cothreads LIBBYT = $(LIB:%=%.cma) LIBNAT = $(LIB:%=%.cmxa) LIBNATA = $(LIB:%=%.a) INSTALLDIR = $(INSTALLLIBDIR)/$(BACKEND) INSTALLFILES = $(COMMONMODINTFCOM) $(EXTRAMODINTFCOM) $(COMMONMODNAT) $(EXTRAMODNAT) $(LIBBYT) $(LIBNAT) $(LIBNATA) $(LIBBYT): %: $(ALLMODBYT) $(OCAMLC) -a -o $@ $(AUXMODBYT) $(ALLMODBYT) $(LIBNAT): %: $(ALLMODNAT) $(OCAMLOPT) -a -o $@ $(AUXMODNAT) $(ALLMODNAT) $(COMMONMODINTF): %: ../% @if [ ! -e $@ -a -e $< ]; then ln -s $< .; fi .PHONY: all install clean uninstall all: $(COMMONMODINTF) $(LIBBYT) $(LIBNAT) install: all $(MKDIR) $(INSTALLDIR) $(CP) $(INSTALLFILES) $(INSTALLDIR) clean: ocamlclean uninstall: $(RM) $(INSTALLDIR) cothreads/src/process/condition.ml0000640000175000017500000000146110671575550016606 0ustar erikderikdopen Coordinator (* TODO: to reimplement with portal, tunnel is not persistent *) type t = bool portal tunnel * Mutex.t let create () = new_tunnel (), Mutex.create () let wait (t,_) mut = let portal = create_portal () in write_tunnel portal t; Mutex.unlock mut; if read_portal portal then (Mutex.lock mut; remove_portal portal) else assert false let rec signal (t, m) = Mutex.lock m; let result = read_tunnel t in Mutex.unlock m; match result with Some portal -> write_portal true portal | None -> () let broadcast (t, m) = let rec keep_read accu = match read_tunnel t with | Some portal -> keep_read (portal :: accu) | None -> accu in Mutex.lock m; let wait_lst = keep_read [] in Mutex.unlock m; List.iter (fun portal -> write_portal true portal) (List.rev wait_lst) cothreads/src/process/coordinator.ml0000640000175000017500000001710410673743342017142 0ustar erikderikdopen Unix open Libext open Libextunix type thread = { pid: int } let self () = {pid = Unix.getpid ()} let parent () = {pid = Unix.getppid ()} let id t = t.pid let thread id = { pid = id } let signal s t = Unix.kill s (id t) let file_perm = 0o600 let dir_perm = 0o700 let work_dir_name = "cothread" let work_dir = let name = Filename.concat Filename.temp_dir_name work_dir_name in (try mkdir name dir_perm with Unix_error (EEXIST,_,_) -> ()); name (* word_size is used to generate file offset, fresh id number and fresh name. For now, it's restricted to at most 32 bit on any platform, which should be sufficient for its purpose *) let word_size = min Sys.word_size 32 (* fresh_number fresh_name ensure that there won't exist number/name confliction between running processes. *) let fresh_number = let usable_size = word_size -2 in let bits_of_id = 16 in (* Should be sufficient in most OS *) let bits_of_num = usable_size - bits_of_id in let counter = ref 0 in fun () -> let self_id = id (self ()) in let id_part = bit_chop_to_n bits_of_id self_id in let num_part = counter := bit_chop_to_n bits_of_num (!counter + 1); !counter in (id_part lsl bits_of_num) + num_part let fresh_name prefix = let num = fresh_number () in let file_name = Printf.sprintf "%s%0*X" prefix (word_size/4) num in Filename.concat work_dir file_name let remove_exists name = try unlink name with Unix_error (ENOENT,_,_) -> () type 'a portal = string let create_portal () = let portal = fresh_name "_portal" in remove_exists portal; mkfifo portal file_perm; portal let remove_portal portal = remove_exists portal let read_portal (p: 'a portal) : 'a = let fd = openfile p [O_RDONLY] file_perm in let v = marshal_read fd in close fd; v let poll_read_portal p = let fd = openfile p [O_RDONLY; O_NONBLOCK] file_perm in let data = try Some (marshal_read fd) with End_of_file | Unix_error ((EAGAIN|EWOULDBLOCK),_,_) -> None in close fd; data let write_portal (x: 'a) (p: 'a portal) = let fd = openfile p [O_WRONLY] file_perm in marshal_write x fd; close fd let poll_write_portal (x : 'a) (p: 'a portal) = let fd = openfile p [O_RDWR; O_NONBLOCK] file_perm in try marshal_write x fd; Some (fun () -> close fd) with Unix_error ((EAGAIN|EWOULDBLOCK),_,_) -> None let demand_portal f p = let tp = create_portal () in let pkg = f tp in write_portal pkg p; let ack = read_portal tp in remove_portal tp; ack type 'a tunnel = file_descr * file_descr let new_tunnel = let close_tunnel (r,w) = close r; close w in fun () -> let tunnel_file = fresh_name "_tunnel" in remove_exists tunnel_file; mkfifo tunnel_file file_perm; let read_fd = openfile tunnel_file [O_RDONLY; O_NONBLOCK] file_perm in let write_fd = openfile tunnel_file [O_WRONLY] file_perm in remove_exists tunnel_file; let tunnel = read_fd, write_fd in Gc.finalise close_tunnel tunnel; tunnel let read_tunnel (r, _) = try Some (marshal_read r) with Unix_error ((EAGAIN|EWOULDBLOCK),_,_) -> None let write_tunnel v (_, w) = marshal_write v w let services : (string * Obj.t list) list ref = ref [] let new_serv p f = let f = Obj.repr f in let services' = try let pre, (_, l), suc = list_find_split (fun (p', _) -> p == p') !services in List.rev_append pre ((p, (f :: l)) :: suc) with Not_found -> (p, [f]) :: !services in services := services' let del_serv p f = let f = Obj.repr f in let services' = let pre,(_, l),suc = list_find_split (fun (p', _) -> p == p') !services in let l_pre, _ ,l_suc = list_find_split ((==) f) l in match (List.rev_append l_pre l_suc) with | [] -> List.rev_append pre suc | nl -> List.rev_append pre ((p, nl) :: suc) in services := services' let sub_serv p f1 f2 = let f1 = Obj.repr f1 in let f2 = Obj.repr f2 in let services' = let pre,(_,l),suc = list_find_split (fun (p', _) -> p == p') !services in let l_pre, _, l_suc = list_find_split ((==) f1) l in List.rev_append pre ((p, List.rev_append l_pre (f2 :: l_suc)) :: suc) in services := services' let exn_handlers: (exn -> (float -> 'a) -> 'a) list ref = ref [] let new_handler f = exn_handlers := f :: !exn_handlers let rec handle_all e cont handlers = match handlers with | [] -> raise e | h :: t -> try h e cont with _ -> handle_all e cont t module ThreadMap = Map_Make (struct type t = thread let compare = compare end) module ThreadSet = Set.Make (struct type t = thread let compare = compare end) type thread_info = {parent: thread; wait_lst: bool portal list} let root_db = ref (ThreadMap.empty: thread_info ThreadMap.t) let inited = ref false let run_services () = let serv_conf = List.map (fun (p, fl) -> let fd = openfile p [O_RDWR] file_perm in (fd, List.rev_map Obj.obj fl) ) (List.rev !services) in let fds , _ = List.split serv_conf in let exn_handlers = List.rev !exn_handlers in let exns = ref [] in let rec run timeout = let ready,_,_ = select fds [] [] timeout in match ready with | [] -> () | h :: _ -> let excep = try let v = marshal_read h in List.iter (fun f -> f v) (List.assoc h serv_conf); None with e -> Some e in match excep with | None -> let timeout = if ThreadMap.is_empty !root_db then 0. else (-1.) in run timeout | Some e -> handle_all e run exn_handlers in (try run (-1.) with e -> exns := e :: !exns; if ThreadMap.is_empty !root_db then () else (ThreadMap.iter (fun thr _ -> signal Sys.sigterm thr) !root_db; run (-1.))); List.iter close fds; List.iter (fun (p, _) -> remove_portal p) !services; List.iter raise !exns (* Root service begins *) type root_msg = [`Create of thread * thread * bool portal |`Delete of thread * bool portal |`Wait of thread * bool portal |`Test of string * string portal ] let root_portal: root_msg portal = create_portal () exception Quit let exit_handler e cont = match e with Quit -> () | e -> raise e let root_func = function | `Create (t', t, p) -> root_db := ThreadMap.add t {parent = t'; wait_lst = []} !root_db; write_portal true p | `Delete (t, p) -> let {wait_lst = wl} = ThreadMap.find t !root_db in List.iter (write_portal true) wl; write_portal true p; root_db := ThreadMap.remove t !root_db; if ThreadMap.is_empty !root_db then raise Quit | `Wait (t, p) -> (try let th_info = ThreadMap.find t !root_db in let new_info = {th_info with wait_lst = p :: th_info.wait_lst} in root_db := ThreadMap.add t new_info !root_db with Not_found -> write_portal true p) | `Test (str, p) -> write_portal ("Root got your msg "^str) p let rec unreg t = let flag = demand_portal (fun p -> `Delete (t, p)) root_portal in if not flag then unreg t let rec reg t' t = let flag = demand_portal (fun p -> `Create (t', t, p)) root_portal in if not flag then reg t' t let prefix_sig_handle s f = let old_handle = Sys.signal s Sys.Signal_default in let new_handle = Sys.Signal_handle (fun _ -> f (); Sys.set_signal s old_handle; signal s (self ())) in Sys.set_signal s new_handle let rec init () = assert (not !inited); (inited := true; match fork () with | 0 -> reg (parent ()) (self ()); at_exit (fun () -> unreg (self ())); prefix_sig_handle Sys.sigterm (fun _ -> unreg (self ())); Sys.set_signal Sys.sigchld Sys.Signal_ignore | pid -> run_services (); exit 0 ) let _ = new_serv root_portal root_func let _ = new_handler exit_handler cothreads/src/process/coordinator.mli0000640000175000017500000000622710661673351017316 0ustar erikderikdtype thread val self : unit -> thread val parent : unit -> thread val id : thread -> int val thread : int -> thread val signal : int -> thread -> unit val file_perm : int val dir_perm : int val work_dir_name : string val work_dir : string val fresh_number : unit -> int val fresh_name : string -> string val remove_exists : string -> unit type 'a portal val create_portal : unit -> 'a portal val remove_portal : 'a portal -> unit val read_portal : 'a portal -> 'a val poll_read_portal : 'a portal -> 'a option val write_portal : 'a -> 'a portal -> unit val poll_write_portal : 'a -> 'a portal -> (unit -> unit) option val demand_portal : ('a portal -> 'b) -> 'b portal -> 'a type 'a tunnel val new_tunnel : unit -> 'a tunnel val read_tunnel : 'a tunnel -> 'a option val write_tunnel : 'a -> 'a tunnel -> unit val new_serv : 'a portal -> ('a -> unit) -> unit val del_serv : 'a portal -> ('a -> unit) -> unit val sub_serv : 'a portal -> ('a -> unit) -> ('a -> unit) -> unit val new_handler : (exn -> (float -> unit) -> unit) -> unit val run_services : unit -> unit type root_msg = [ `Create of thread * thread * bool portal | `Delete of thread * bool portal | `Test of string * string portal | `Wait of thread * bool portal ] val root_portal : root_msg portal module ThreadMap : sig type key = thread type +'a t val empty : 'a t val is_empty : 'a t -> bool val add : key -> 'a -> 'a t -> 'a t val find : key -> 'a t -> 'a val remove : key -> 'a t -> 'a t val mem : key -> 'a t -> bool val iter : (key -> 'a -> unit) -> 'a t -> unit val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool type 'a patch = (key * ('a option * 'a option)) list val diff : ('a -> 'a -> bool) -> 'a t -> 'a t -> 'a patch val patch_left : ('a -> 'a -> bool) -> 'a t -> 'a patch -> 'a t val patch_right : ('a -> 'a -> bool) -> 'a patch -> 'a t -> 'a t val merge : (key -> 'a -> 'a -> 'a t -> 'a t) -> 'a t -> 'a t -> 'a t end module ThreadSet : sig type elt = thread type t val empty : t val is_empty : t -> bool val mem : elt -> t -> bool val add : elt -> t -> t val singleton : elt -> t val remove : elt -> t -> t val union : t -> t -> t val inter : t -> t -> t val diff : t -> t -> t val compare : t -> t -> int val equal : t -> t -> bool val subset : t -> t -> bool val iter : (elt -> unit) -> t -> unit val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a val for_all : (elt -> bool) -> t -> bool val exists : (elt -> bool) -> t -> bool val filter : (elt -> bool) -> t -> t val partition : (elt -> bool) -> t -> t * t val cardinal : t -> int val elements : t -> elt list val min_elt : t -> elt val max_elt : t -> elt val choose : t -> elt val split : elt -> t -> t * bool * t end val exit_handler : exn -> 'a -> unit val root_func : root_msg -> unit val inited : bool ref val init : unit -> unit val reg: thread -> thread -> unit val unreg: thread -> unit cothreads/src/process/cothread.ml0000640000175000017500000000437110661673351016411 0ustar erikderikdopen Unix open Libext open Coordinator type t = thread let self = self let id = id let exit () = Pervasives.exit 0 let kill = signal Sys.sigterm let create f x = flush_all (); if not !inited then init (); let m = Mutex.create () in Mutex.lock m; match fork () with | 0 -> Mutex.lock m; Mutex.unlock m; ignore (f x); exit () (* let error = try ignore (f x); None with e -> Some e in (match error with None -> exit () | Some e -> (* unreg self; *) raise e) *) | pid -> let son = thread pid in reg (self ()) son; Mutex.unlock m; son let join t = let success = demand_portal (fun p -> `Wait (t, p)) root_portal in if not success then assert false let select = Unix.select let delay d = ignore (select [] [] [] d) let wait_read fd = ignore (select [fd] [] [] (-1.)) let wait_write fd = ignore (select [fd] [] [] (-1.)) let wait_timed_read fd time = match select [fd] [] [] time with [],_,_ -> false | _ -> true let wait_timed_write fd time = match select [fd] [] [] time with [],_,_ -> false | _ -> true let wait_pid pid = Unix.waitpid [] pid let yield () = () let sigmask = Unix.sigprocmask let wait_signal sigs = let gotsig = ref 0 in let sighandler s = gotsig := s in let oldhdlrs = List.map (fun s -> Sys.signal s (Sys.Signal_handle sighandler)) sigs in if !gotsig = 0 then Unix.sigsuspend sigs; List.iter2 Sys.set_signal sigs oldhdlrs; !gotsig let spawn f x = let ch = Event.new_channel () in let result = ref `Unknown in let thread_fun () = let res = try `Result (f x) with e -> `Exn e in Event.sync (Event.send ch res) in ignore (create thread_fun ()); let rec launch () = match !result with | `Result v -> Event.always v | `Exn e -> raise e | `Unknown -> Event.wrap (Event.receive ch) (fun res -> result:= res; Event.sync (launch ())) in Event.guard launch let spawnl f x = let ch = Event.new_channel () in let thread_fun () = Event.sync (Event.send ch (f x)) in let launch () = let worker = create thread_fun () in Event.wrap_abort (Event.receive ch) (fun () -> kill worker) in Event.guard launch (* let test s = let ns = demand_portal s (fun s p -> `Test (s, p)) root_portal in print_endline ns *) cothreads/src/process/event.ml0000640000175000017500000001545510656544312015744 0ustar erikderikdopen Unix open Coordinator type id = int type 'a behavior = {poll: unit -> bool; suspend: unit -> (unit -> unit) option; result: unit -> 'a; handler: Obj.t portal -> unit; abort: (unit -> unit) list; } type 'a channel = {chn_lock: Mutex.t; send_pendings: communicator portal; recv_pendings: communicator portal; } and communicator = { com_lock: Mutex.t; com_portal: (id * Obj.t portal) portal; evn_number: id; } type 'a event = | Communication of (communicator -> 'a behavior) | Choose of 'a event list | Guard of (unit -> 'a event) let new_channel () = let lk = Mutex.create () in let sp = create_portal () in let rp = create_portal () in {chn_lock = lk; send_pendings = sp; recv_pendings = rp} let protect_do mut f x = Mutex.lock mut; let res = f x in Mutex.unlock mut; res let rec poll_recv_pending portal data = match poll_read_portal portal with | None -> None | Some comm -> let action () = let answer_portal = create_portal () in let res = try write_portal (comm.evn_number, answer_portal) comm.com_portal; write_portal (Obj.repr data) answer_portal; Some () with Unix_error (ENOENT,_,_) -> None in remove_portal answer_portal; res in match protect_do comm.com_lock action () with | None -> poll_recv_pending portal data | x -> x let rec poll_send_pending portal = match poll_read_portal portal with | None -> None | Some comm -> let action () = let answer_portal = create_portal () in let res = try write_portal (comm.evn_number, answer_portal) comm.com_portal; Some (Obj.obj (read_portal answer_portal)) with Unix_error (ENOENT,_,_) -> None in remove_portal answer_portal; res in match protect_do comm.com_lock action () with | None -> poll_send_pending portal | x -> x let send channel data : _ event = Communication (fun comm -> let result = ref None in { poll = (fun () -> result := protect_do channel.chn_lock (poll_recv_pending channel.recv_pendings) data; match !result with None -> false | _ -> true ); suspend = (fun () -> protect_do channel.chn_lock (poll_write_portal comm) channel.send_pendings ); handler = (fun portal -> write_portal (Obj.repr data) portal; result := Some ()); result = (fun () -> match !result with None -> assert false | Some () -> ()); abort = []; } ) let receive channel : _ event = Communication (fun comm -> let result = ref None in {poll = (fun () -> result := protect_do channel.chn_lock poll_send_pending channel.send_pendings; match !result with None -> false | _ -> true); suspend = (fun () -> protect_do channel.chn_lock (poll_write_portal comm) channel.recv_pendings ); handler = (fun portal -> result := Some (Obj.obj (read_portal portal))); result = (fun () -> match !result with None -> assert false | Some x -> x); abort = []; } ) let always data : _ event = Communication (fun comm -> { poll = (fun () -> true); suspend = (fun () -> Some (fun () -> ())); result = (fun () -> data); handler = (fun _ -> assert false); abort = []; } ) let choose evl = Choose evl let rec wrap_abort ev fn = match ev with | Communication genev -> Communication (fun comm -> let bev = genev comm in { bev with abort = fn :: bev.abort } ) | Choose evl -> Choose (List.map (fun ev -> wrap_abort ev fn) evl) | Guard gu -> Guard (fun () -> wrap_abort (gu ()) fn) let guard fn = Guard fn let rec wrap ev fn = match ev with | Communication genev -> Communication (fun comm -> let bev = genev comm in { bev with result = fun () -> fn (bev.result ()) } ) | Choose evl -> Choose (List.map (fun ev -> wrap ev fn) evl) | Guard gu -> Guard (fun () -> wrap (gu ()) fn) let rec flatten_event = function | Communication ev -> [ev] | Choose evl -> List.flatten (List.map flatten_event evl) | Guard fn -> flatten_event (fn ()) let scramble_array a = let len = Array.length a in if len = 0 then invalid_arg "Event.choose"; for i = len - 1 downto 1 do let j = Random.int (i + 1) in let temp = a.(i) in a.(i) <- a.(j); a.(j) <- temp done; a let do_aborts bev = function | None -> Array.iter (fun ev -> List.iter (fun f -> f ()) ev.abort) bev | Some n -> Array.iteri (fun i ev -> if i <> n then List.iter (fun f -> if not (List.exists ((==) f) bev.(n).abort) then f ()) ev.abort ) bev let poll ev = let dummy_lock = Mutex.create () in let dummy_portal = create_portal () in let _ = remove_portal dummy_portal in let eva = scramble_array (Array.of_list (flatten_event ev)) in let bev = Array.init (Array.length eva) (fun i -> eva.(i) { com_lock = dummy_lock; com_portal = dummy_portal; evn_number = i } ) in let rec poll_events i = if i >= Array.length bev then None else if (bev.(i).poll) () then Some i else poll_events (i+1) in let evn_num = poll_events 0 in do_aborts bev evn_num; match evn_num with Some n -> Some (bev.(n).result ()) | None -> None let sync ev = let com_lock = Mutex.create () in let com_portal = create_portal () in let clean_up = ref [] in let eva = scramble_array (Array.of_list (flatten_event ev)) in let bev = Array.init (Array.length eva) (fun i -> eva.(i) { com_lock = com_lock; com_portal = com_portal; evn_number = i } ) in let get_final i = List.iter (fun f -> f ()) !clean_up; do_aborts bev (Some i); bev.(i).result () in let rec sync_events i = if i >= Array.length bev || not (Mutex.try_lock com_lock) then let i, portal = read_portal com_portal in remove_portal com_portal; bev.(i).handler portal; get_final i else if bev.(i).poll () then (remove_portal com_portal; Mutex.unlock com_lock; get_final i) else match bev.(i).suspend () with | Some f -> clean_up := f :: !clean_up; Mutex.unlock com_lock; sync_events (i+1) | None -> let j = i + Random.int (Array.length bev - i) in let temp = bev.(i) in bev.(i) <- bev.(i); bev.(j) <- temp; Mutex.unlock com_lock; sync_events i in sync_events 0 let select evl = sync (choose evl) cothreads/src/process/mutex.ml0000640000175000017500000000122710671575550015762 0ustar erikderikdopen Unix open Coordinator let lock_fd = let lock_name = fresh_name "_mutex" in remove_exists lock_name; let fd = openfile lock_name [O_WRONLY; O_CREAT] file_perm in remove_exists lock_name; fd type t = int (* The offset *) let create = fresh_number let rec lock lk = if lk <> lseek lock_fd lk SEEK_SET then assert false; lockf lock_fd F_LOCK 1 let try_lock lk = if lk <> lseek lock_fd lk SEEK_SET then assert false; try lockf lock_fd F_TLOCK 1; true with Unix_error (EACCES,_,_) | Unix_error (EAGAIN,_,_) -> false | e -> raise e let unlock lk = if lk <> lseek lock_fd lk SEEK_SET then assert false; lockf lock_fd F_ULOCK 1 cothreads/src/process/stm.ml0000640000175000017500000003302310671575550015422 0ustar erikderikdopen Coordinator open Libext let stm_magic = "STM2007MTS" type tvid = string * int * int and version = int and value = Obj.t module TvMap = Map_Make (struct type t = tvid let compare = Pervasives.compare end) module TvSet = Set.Make (struct type t = tvid let compare = Pervasives.compare end) type tv_repr = {version: version; value: value; ref_to: TvSet.t} (* New: pre_version(value) = None First Read: pre_version(value) = Some _ First Write: pre_version = Some _, pre_value = None *) type tv_log = {pre_version: version option; pre_value: value option; mutable cur_value: value option} type commit_log = { read_log: version TvMap.t; write_log: tv_repr TvMap.t; dirty_log: TvSet.t } type stm_msg = [ `Tvar of tvid * tv_repr * thread * bool portal | `Wait of version TvMap.t * thread * bool portal | `Atom of thread * tv_repr TvMap.patch portal | `Commit of commit_log * thread * bool portal ] let stm_portal : stm_msg portal = create_portal () let repr_eq {version=v1} {version=v2} = v1 = v2 let var_of_val v = Obj.obj v and val_of_var v = Obj.repr v type 'a tvar = tvid type thr_state = { mutable env: tv_repr TvMap.t; mutable log: tv_log TvMap.t; mutable tvid_count: int; mutable layer: int; mutable dirty: TvSet.t; } let state = { env = TvMap.empty; log = TvMap.empty; tvid_count = 0; layer = 0; dirty = TvSet.empty } let state_reset diff = assert (state.layer = 0); state.env <- TvMap.patch_left repr_eq state.env diff; state.log <- TvMap.empty (* Shallow copy, only work for data structure like tvid *) let copy (x:tvid) : tvid = Obj.obj (Obj.dup (Obj.repr x)) let tvmap_add k = TvMap.add (copy k) let tvset_add k = TvSet.add (copy k) let finaliser vl = state.dirty <- TvSet.remove (var_of_val vl) state.dirty let suspicious () = TvMap.fold (fun tv log set -> match log with | {pre_version = Some _; pre_value = Some _} -> TvSet.union (TvMap.find tv state.env).ref_to set | {pre_version = None} -> TvSet.add tv set | _ -> set ) state.log state.dirty type 'a stm = unit -> 'a let return v = fun () -> v let bind t f = fun () -> f (t ()) () let ( >>= ) = bind let ( >> ) s1 s2 = s1 >>= fun _ -> s2 let reference v = TvSet.filter (fun x -> obj_refed_by (=) x v) let tvar v = if (not !inited) then init (); let self_t = self () in let self_id = id self_t in state.tvid_count <- succ state.tvid_count; let new_tvid = (stm_magic, self_id, state.tvid_count) in let ref_to = reference v (suspicious ()) in let new_repr = {version=0; value=val_of_var v; ref_to = ref_to} in let b = demand_portal (fun p -> `Tvar (new_tvid, new_repr, self_t, p)) stm_portal in assert b; state.env <- tvmap_add new_tvid new_repr state.env; state.dirty <- tvset_add new_tvid state.dirty; Gc.finalise finaliser (val_of_var new_tvid); new_tvid let new_tvar v = fun () -> let self_id = id (self ()) in state.tvid_count <- succ state.tvid_count; let new_tvid = (stm_magic, self_id, state.tvid_count) in let new_log = { pre_version = None; pre_value = None; cur_value = Some (val_of_var v) } in state.log <- tvmap_add new_tvid new_log state.log; new_tvid let read_tvar tv = fun () -> let value = try let log = TvMap.find tv state.log in match log.cur_value, log.pre_value with | Some v, _ | _, Some v -> v | _ -> assert false with Not_found -> let repr = TvMap.find tv state.env in state.log <- tvmap_add tv { pre_version = Some repr.version; pre_value = Some repr.value; cur_value = None } state.log; repr.value in var_of_val value let write_tvar tv v = fun () -> try let log = TvMap.find tv state.log in log.cur_value <- Some (val_of_var v) with Not_found -> let repr = TvMap.find tv state.env in state.log <- TvMap.add tv { pre_version = Some repr.version; pre_value = None; cur_value = Some (val_of_var v) } state.log let wait = fun () -> let wait_tv = TvMap.fold (fun tv log map -> match log with | {pre_version = Some v; pre_value = Some _} -> TvMap.add tv v map | _ -> map) state.log TvMap.empty in assert (demand_portal (fun p -> `Wait (wait_tv, self (), p)) stm_portal) exception Abort exception Retry of bool (* whether wait or not *) let abort = fun () -> raise Abort let retry = fun () -> raise (Retry true) let retry_now = fun () -> raise (Retry false) let save_state st = {st with layer = st.layer} (* actually copy everything *) let restore_state st st_bak = st.log <- st_bak.log; st.layer <- st_bak.layer let catch t f = fun () -> let state_bak = save_state state in try t () with | Retry _ | Abort as e -> raise e | e -> restore_state state state_bak; f e () let or_else t1 t2 = fun () -> let state_bak = save_state state in try t1 () with (Abort | Retry _) as e1 -> let state_bak_1 = save_state state in restore_state state state_bak; try t2 () with (Abort | Retry _) as e2 -> match e1, e2 with | Abort, Abort -> restore_state state state_bak; raise Abort | Retry b, Abort -> restore_state state state_bak_1; raise (Retry b) | Abort, Retry b -> raise (Retry b) | Retry b1, Retry b2 -> let comb_log = TvMap.merge (fun k v1 v2 tbl -> match v1.pre_value,v2.pre_value with | None, Some _ -> TvMap.add k v2 tbl | _,_ -> tbl) state.log state_bak_1.log in restore_state state state_bak; state.log <- comb_log; raise (Retry (b1 && b2)) | _, _ -> assert false let dirtirise v susp = let mark tv = let val_tv = val_of_var tv in obj_iter (fun o -> if o = val_tv then (state.dirty <- TvSet.add tv state.dirty; Gc.finalise finaliser o) ) v in TvSet.iter mark susp (* Compute locally to save the effort of coordinator *) let commit_log susp = let read,write = TvMap.fold (fun tv {pre_version=pver; pre_value=pval; cur_value=cval} (r,w) -> let w = match cval with | Some v -> let repr = { version= 0; (* tmp_value, to be changed when commit *) value=v; ref_to=reference v susp } in TvMap.add tv repr w | None -> w in let r = match pval, pver with | Some _, Some ver -> TvMap.add tv ver r | _ -> r in (r, w) ) state.log (TvMap.empty, TvMap.empty) in {read_log = read; write_log = write; dirty_log = state.dirty} let commit v : bool = let susp = suspicious () in let _ = dirtirise v susp in let clog = commit_log susp in demand_portal (fun p -> `Commit (clog, self (), p)) stm_portal let rec atom_once t = if (not !inited) then init (); (if state.layer = 0 then let diff = demand_portal (fun p -> `Atom (self (), p)) stm_portal in state_reset diff); state.layer <- succ state.layer; try let v = t () in state.layer <- pred state.layer; if state.layer > 0 || commit v then Some v else None with e -> state.layer <- pred state.layer; match state.layer, e with | 0, Retry b -> if b then wait (); atom_once t | 0, Abort -> None | _,_ -> raise e let rec atom t = match atom_once t with None -> atom t | Some v -> v (* Root Service *) type tv_rec = { mutable ref_by_tv: TvSet.t; mutable ref_by_thr: ThreadSet.t; mutable tv_wait: bool portal option ref list } type thr_rec = { mutable thr_env: tv_repr TvMap.t; mutable tv_dirty: TvSet.t } type stm_root = { mutable root_env: tv_repr TvMap.t; mutable root_rec: tv_rec TvMap.t; mutable root_thr: thr_rec ThreadMap.t; } let root = {root_env = TvMap.empty; root_rec = TvMap.empty; root_thr = ThreadMap.empty} let empty_tv_rec () = { ref_by_tv = TvSet.empty; ref_by_thr = ThreadSet.empty; tv_wait = []} let empty_thr_rec () = { thr_env = root.root_env; tv_dirty = TvSet.empty } (* Primitive Tvar service *) let tvar_handle tv repr thr p = let tv_rec = empty_tv_rec () in tv_rec.ref_by_thr <- ThreadSet.add thr tv_rec.ref_by_thr; root.root_env <- TvMap.add tv repr root.root_env; root.root_rec <- TvMap.add tv tv_rec root.root_rec; let thr_rec = ThreadMap.find thr root.root_thr in thr_rec.thr_env <- TvMap.add tv repr thr_rec.thr_env; thr_rec.tv_dirty <- TvSet.add tv thr_rec.tv_dirty; write_portal true p (* Primitive Wait service *) let wait_handle wait_tv thr p = let answer_port = ref None in let mark tv version = let tv_repr = TvMap.find tv root.root_env in if tv_repr.version > version then raise Break else let reco = TvMap.find tv root.root_rec in reco.tv_wait <- answer_port :: reco.tv_wait in try TvMap.iter mark wait_tv; answer_port := Some p with Break -> write_portal true p (* Primitve Atom service *) let atom_handle thr p = let thr_rec = ThreadMap.find thr root.root_thr in let diff = TvMap.diff repr_eq thr_rec.thr_env root.root_env in thr_rec.thr_env <- root.root_env; write_portal diff p let opr_ref_by_thr op tv = let tv_rec = TvMap.find tv root.root_rec in tv_rec.ref_by_thr <- op tv_rec.ref_by_thr let opr_ref_by_tv op tv = let tv_rec = TvMap.find tv root.root_rec in tv_rec.ref_by_tv <- op tv_rec.ref_by_tv (* Primitve Commit service *) let commit_handle {read_log=rl; write_log=wl; dirty_log=dl} thr p = let conflict = try TvMap.iter (fun tv ver -> if (TvMap.find tv root.root_env).version <> ver then raise Break) rl; false with Break | Not_found -> true in if conflict then write_portal false p else begin (* References decreasing set *) let ref_dec_set = ref TvSet.empty in (* we must first update the whole root_env to its final state before we begin to test dirty sets relation, otherwise there will be inconsistence *) let _ = TvMap.iter (fun tv repr -> try let old_repr = TvMap.find tv root.root_env in let new_repr = {repr with version = old_repr.version + 1} in TvSet.iter (opr_ref_by_tv (TvSet.remove tv)) old_repr.ref_to; ref_dec_set := TvSet.union !ref_dec_set old_repr.ref_to; (* we can not handle new references to other tv at this moment, because not all tv has been commited in *) root.root_env <- TvMap.add tv new_repr root.root_env; (* reactive waiting thread because of the value change *) let tv_rec = TvMap.find tv root.root_rec in List.iter (fun w -> match !w with | Some p -> (write_portal true p; w := None) | None -> () ) tv_rec.tv_wait; tv_rec.tv_wait <- [] with Not_found -> (* only reason: new tvar; collected: impossible *) root.root_env <- TvMap.add tv repr root.root_env; (* create record for new tvar now, in case of dangling points when updating reference *) root.root_rec <- TvMap.add tv (empty_tv_rec ()) root.root_rec; ) wl in (* handle new reference now *) let _ = TvMap.iter (fun tv repr -> TvSet.iter (opr_ref_by_tv (TvSet.add tv)) repr.ref_to; ref_dec_set := TvSet.diff !ref_dec_set repr.ref_to ) wl in (* We update thr_rec in the next step *) let _ = let thr_rec = ThreadMap.find thr root.root_thr in let to_remove = TvSet.diff thr_rec.tv_dirty dl in let to_add = TvSet.diff dl thr_rec.tv_dirty in TvSet.iter (opr_ref_by_thr (ThreadSet.remove thr)) to_remove; ref_dec_set := TvSet.union !ref_dec_set to_remove; TvSet.iter (opr_ref_by_thr (ThreadSet.add thr)) to_add; ref_dec_set := TvSet.diff !ref_dec_set to_add; thr_rec.tv_dirty <- dl in (* Finally doing house mantinance: GC *) let _ = let rec gc tv_set = let tv = TvSet.max_elt tv_set in let tv_rest = TvSet.remove tv tv_set in let tv_rec = TvMap.find tv root.root_rec in if TvSet.is_empty tv_rec.ref_by_tv && ThreadSet.is_empty tv_rec.ref_by_thr then let ref_to = (TvMap.find tv root.root_env).ref_to in root.root_rec <- TvMap.remove tv root.root_rec; root.root_env <- TvMap.remove tv root.root_env; TvSet.iter (opr_ref_by_tv (TvSet.remove tv)) ref_to; gc (TvSet.union ref_to tv_rest) else gc tv_rest in try gc !ref_dec_set with Not_found -> () in (* For now, we don't update the env record of thread, to make it agree with old_env of client; only when next atom requirement, we diff the current root_env with this version, update this version, and send out patchs *) write_portal true p end let stm_extend_handle : root_msg -> unit = function | `Create (t', t, _) -> (try let fat_thr = ThreadMap.find t' root.root_thr in let son_thr = {fat_thr with tv_dirty = fat_thr.tv_dirty} in root.root_thr <- ThreadMap.add t son_thr root.root_thr; TvSet.iter (opr_ref_by_thr (ThreadSet.add t)) son_thr.tv_dirty; with Not_found -> (* The first one *) root.root_thr <- ThreadMap.add t (empty_thr_rec ()) root.root_thr) | `Delete (t, _) -> let thr_rec = ThreadMap.find t root.root_thr in TvSet.iter (opr_ref_by_thr (ThreadSet.remove t)) thr_rec.tv_dirty; root.root_thr <- ThreadMap.remove t root.root_thr | _ -> () let stm_handle : stm_msg -> unit = function | `Tvar (new_tvid, new_repr, self_t, p) -> tvar_handle new_tvid new_repr self_t p | `Wait (touch, thr, p) -> wait_handle touch thr p | `Atom (thr, p) -> atom_handle thr p | `Commit (clog, thr, p) -> commit_handle clog thr p let _ = new_serv root_portal stm_extend_handle let _ = new_serv stm_portal stm_handle cothreads/src/process/thread.ml0000640000175000017500000000006110657035537016062 0ustar erikderikdinclude Cothread let sigmask = Unix.sigprocmask cothreads/src/process/thread.mli0000640000175000017500000001320210671575550016234 0ustar erikderikd(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1995 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../../LICENSE. *) (* *) (***********************************************************************) (** Thread inferface, the version compatible with Thread module of standard threads library from OCaml distribution *) type t (** The type of thread handles. *) (** {6 Thread creation and termination} *) val create : ('a -> 'b) -> 'a -> t (** [Thread.create funct arg] creates a new thread of control, in which the function application [funct arg] is executed concurrently with the other threads of the program. The application of [Thread.create] returns the handle of the newly created thread. The new thread terminates when the application [funct arg] returns, either normally or by raising an uncaught exception. In the latter case, the exception is printed on standard error, but not propagated back to the parent thread. Similarly, the result of the application [funct arg] is discarded and not directly accessible to the parent thread. *) val self : unit -> t (** Return the thread currently executing. *) val id : t -> int (** Return the identifier of the given thread. A thread identifier is an integer that identifies uniquely the thread. It can be used to build data structures indexed by threads. *) val exit : unit -> unit (** Terminate prematurely the currently executing thread. *) val kill : t -> unit (** Terminate prematurely the thread whose handle is given. *) (** {6 Suspending threads} *) val delay: float -> unit (** [delay d] suspends the execution of the calling thread for [d] seconds. The other program threads continue to run during this time. *) val join : t -> unit (** [join th] suspends the execution of the calling thread until the thread [th] has terminated. *) val wait_read : Unix.file_descr -> unit (** See {!Thread.wait_write}.*) val wait_write : Unix.file_descr -> unit (** This function does nothing in this implementation. *) val wait_timed_read : Unix.file_descr -> float -> bool (** See {!Thread.wait_timed_read}.*) val wait_timed_write : Unix.file_descr -> float -> bool (** Suspend the execution of the calling thread until at least one character is available for reading ([wait_read]) or one character can be written without blocking ([wait_write]) on the given Unix file descriptor. Wait for at most the amount of time given as second argument (in seconds). Return [true] if the file descriptor is ready for input/output and [false] if the timeout expired. These functions return immediately [true] in the Win32 implementation. *) val select : Unix.file_descr list -> Unix.file_descr list -> Unix.file_descr list -> float -> Unix.file_descr list * Unix.file_descr list * Unix.file_descr list (** Suspend the execution of the calling thead until input/output becomes possible on the given Unix file descriptors. The arguments and results have the same meaning as for [Unix.select]. This function is not implemented yet under Win32. *) val wait_pid : int -> int * Unix.process_status (** [wait_pid p] suspends the execution of the calling thread until the process specified by the process identifier [p] terminates. Returns the pid of the child caught and its termination status, as per [Unix.wait]. This function is not implemented under MacOS. *) val yield : unit -> unit (** Re-schedule the calling thread without suspending it. This function can be used to give scheduling hints, telling the scheduler that now is a good time to switch to other threads. *) (** {6 Management of signals} *) (** Signal handling follows the POSIX thread model: signals generated by a thread are delivered to that thread; signals generated externally are delivered to one of the threads that does not block it. Each thread possesses a set of blocked signals, which can be modified using {!Thread.sigmask}. This set is inherited at thread creation time. Per-thread signal masks are supported only by the system thread library under Unix, but not under Win32, nor by the VM thread library. *) val sigmask : Unix.sigprocmask_command -> int list -> int list (** [sigmask cmd sigs] changes the set of blocked signals for the calling thread. If [cmd] is [SIG_SETMASK], blocked signals are set to those in the list [sigs]. If [cmd] is [SIG_BLOCK], the signals in [sigs] are added to the set of blocked signals. If [cmd] is [SIG_UNBLOCK], the signals in [sigs] are removed from the set of blocked signals. [sigmask] returns the set of previously blocked signals for the thread. *) val wait_signal : int list -> int (** [wait_signal sigs] suspends the execution of the calling thread until the process receives one of the signals specified in the list [sigs]. It then returns the number of the signal received. Signal handlers attached to the signals in [sigs] will not be invoked. The signals [sigs] are expected to be blocked before calling [wait_signal]. *) cothreads/src/stm.mli0000640000175000017500000002266710671575550014131 0ustar erikderikd(***********************************************************************) (* *) (* STM library for OCaml *) (* *) (* (C) 2007 by Zheng Li (li@pps.jussieu.fr) *) (* *) (* This program is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Library General Public *) (* License as published by the Free Software Foundation; either *) (* version 2 of the License, or (at your option) any later version. *) (* *) (* This program is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Library General Public License for more details. *) (* *) (***********************************************************************) (** A user-space STM library for vmthreads, system threads, process and network programs(TODO). *) (** {6 STM model} *) type 'a stm (** The type of a transaction, when executed will produce a result of type ['a]. *) val return: 'a -> 'a stm (** Primitive to wrap a plain of type ['a] value to a ['a stm], which when being executed, will produces the orignal value. *) val bind: 'a stm -> ('a -> 'b stm) -> 'b stm (** [bind t f] is a transaction, when executed, first behavior as transaction [t], then feed the reture value to [f] to get the consecutive transaction to execute next. *) val ( >>= ): 'a stm -> ('a -> 'b stm) -> 'b stm (** [t >>= f] is an alternative notation of [bind t f] *) val ( >> ): 'a stm -> 'b stm -> 'b stm (** [t1 >> t2] is equal to [t1 >>= fun _ -> t2] which first execute [t1] and wait for its result but ignore it, and then behaviors like [t2] *) val abort: 'a stm (** [abort] is a single transaction, when executed, abort the whole execution from current point. The result of abort an execution is detailed in the documentation of execution primitive [atom_once] below. *) val retry: 'a stm (** [retry] is a transaction, when executed, first wait for the changing of any transactional variables being read in the history of current execution, then relaunch the whole execution. *) val retry_now: 'a stm (** [retry_now] is a transaction in the same spirit with [retry], the only difference is that it does not wait for any changes and relaunch the execution immediately. This can be useful in a language with side-effect, see also the documentation on [atom_once] *) val wait: unit stm (** [wait] is a transaction, when executed, simply wait for the changing of any transactional variables being read in the history of current execution, but without relaunch it. Semantically, you can consider [retry] as [wait >> retry_now] *) val or_else: 'a stm -> 'a stm -> 'a stm (** [or_else t1 t2] is a transaction, when executed, first try to execute [t1]. If not encountering any [retry] ([retry_now]) or [abort], it behaviors just as [t1], otherwise it try [t2] in the same way. If both [t1] and [t2] [abort], the whole execution will abort; if either of them [retry_now], the whole execution will relaunch immediately; if either of them [retry], the execution will wait on its waiting condition and then relaunch; if both of them retry, the execution will wait on both their waiting conditions and then relaunch. *) val catch: 'a stm -> (exn -> 'a stm) -> 'a stm (** [catch t f] is a transaction, when executed, behaviors as [t] if no exception arise, otherwise [f] is used to catch this exception and produce the replacing transaction to execute. Note that [catch] is transaction-level [try ... with]. E.g., [let t3 = t1 >>= fun x -> let y = possible_exn x in t2], here [t3] is a transaction with potential exception inside, [try t3 with ...] won't catch it because t3 is not executed yet, and [try atom_once t3 with ...] can catch it but then [t3] lost its composability. The solution is [catch t3 (function _ -> t4)] which catches exceptions {i inside} [t3] and results a valid transaction being able to furtherly composed; another possibility is to catch the exception normally {i outside} transactions like [t1 >>= fun x -> let y = try possible_exn x with _ -> some_value in t2]. *) val atom_once: 'a stm -> 'a option (** [atom_once] execute a transaction and result in [Some v] if the transaction success and [None] if the transaction fail (due to conflicting in committing or abort). One difference between OCaml and Haskell is that OCaml is not pure and can hide side-effect anywhere while Haskell is pure and can seperate values with/without side-effect by types. On STM, any transaction may fail and relaunch for some times before its success, so any side-effects inside the transaction may be launched several times. Haskell forbid side effect inside transaction through types, whereas we won't be able to do that with OCaml. Instead of asking, but have no means to detect or forbid, the programmers to program without side-effect inside transaction, or modifying heavily the underlying run-time of a language with a imperative nature to be able to catch/revert side-effect, we simply tell it from type that "A transaction {i may} fail" and let the programmer decide what to do. This kind of things already exist in OCaml such as exception. E.g. [try incr i; danger_v1 with _ -> decr i; v2], it's the programmers' responsibility to revert [i] or choose not to do the side-effect modification inside a dangerous envrionment, if that's what they mean. On the other hand, the good thing is that now the programmers have more flexibility in controlling the execution of transactions, e.g. they may choose in purpose not to repeatedly execute the transaction after the committing fails [x] times. *) val atom: 'a stm -> 'a (** This is an analog of [atomically] in Haskell, which repeatedly execute a transaction until the committing succeed. As being said in [atom_once], the control is given to the programmer, the [atom] can defined by themselves as [let rec atom t = match atom_once t with Some v -> v | _ -> atom t]. Providing it is just for convenience. In the same way, you can define various helper functions such as [check]. As already warned (see [atom_once], transactions may fail, relauching transactions also means relaunching side-effects inside a transaction if any. So usually you should avoid side-effect, unless it's something you don't care or even something you want: as an example, you may want to add a harmless print routine inside the transaction to be able to debug that how may times the transaction fails before its success :) Unlike in haskell, we allow nested [atom_once] or [atom]. *) (** {6 Transactional variable} *) type 'a tvar (** the type of transactional variable, which has inside a value of type ['a] *) val tvar: 'a -> 'a tvar (** Toplevel tvar declaration, produce a transaction variable from a value. See [new_tvar] *) val new_tvar: 'a -> 'a tvar stm (** We provide two functions to create a transactional variable from common value: [tvar] is traditional toplevel declaration as those new* and create* functions seen in most other library, it is ensured to succeed; while [new_tvar] is a transactional declaration (as in Haskell) which may fail if the execution of the whole transaction it's bound in fails. We do not follow the idea on the relation between tvar allocation and exception from the original STM paper (last paragraph of section 3.5), as we explicitly provide this two different declaration method: toplevel declaration [tvar] is ensured to be succeed; [new_tvar] is itself transactional, hence by no means should it be specially ensured to succeed always, if it's value is exposed after a fail transaction by exception etc, visiting it later will result in a Not_found exception, which exactly indicates what has happened: the [new_tvar] does not succeed. *) val read_tvar: 'a tvar -> 'a stm (** Read value from a transactional variable, results in a transaction which can be further composed with other transactions through [bind] etc., or executed right away with [atom] etc. to get the final result *) val write_tvar: 'a tvar -> 'a -> unit stm (** [write_tvar tv v] write value [v] to transactional variable [tv], results in a transaction whose type is [unit]. As [read_tvar], the result transaction is for composing or executing. Warning: do not operate the value of a transactional variable though other way exception write_tvar: such as producing the tvar from a mutable value or reference and secretly changing it in traditional way. First, it breaks the transactional semantics; second, in all possibility you won't be able to do that, as the value of tvar is isolated. *) cothreads/src/threads/0000750000175000017500000000000010673744144014236 5ustar erikderikdcothreads/src/threads/Makefile0000640000175000017500000000263410671575550015705 0ustar erikderikdinclude ../../Makefile.template INCLUDES= -I +threads -I .. BACKEND = threads AUXMOD = libext AUXMODBYT = $(AUXMOD:%=%.cmo) AUXMODNAT = $(AUXMOD:%=%.cmx) COMMONMOD = thread mutex condition event COMMONMODNAT = $(COMMONMOD:%=%.cmx) COMMONMODNATA = $(COMMONMOD:%=%.o) EXTRAMOD = cothread stm EXTRAMODBYT = $(EXTRAMOD:%=%.cmo) EXTRAMODNAT = $(EXTRAMOD:%=%.cmx) EXTRAMODINTFSRC = $(EXTRAMOD:%=%.mli) EXTRAMODINTFCOM = $(EXTRAMOD:%=%.cmi) EXTRAMODINTF = $(EXTRAMODINTFSRC) $(EXTRAMODINTFCOM) LIB = cothreads LIBBYT = $(LIB:%=%.cma) LIBNAT = $(LIB:%=%.cmxa) LIBNATA = $(LIB:%=%.a) INSTALLDIR = $(INSTALLLIBDIR)/$(BACKEND) INSTALLFILES = $(EXTRAMODINTFCOM) $(EXTRAMODNAT) $(LIBBYT) $(LIBNAT) $(LIBNATA) $(EXTRAMODINTF):%:../% @if [ ! -e $@ -a -e $< ]; then ln -s $< .; fi $(COMMONMODNAT): %: $(OCAMLSTDLIBPATH)/threads/% @if [ ! -e $@ -a -e $< ]; then ln -s $< .; fi $(COMMONMODNATA):$(OCAMLSTDLIBPATH)/threads/threads.a $(AR) -x $< $(LIBBYT): $(EXTRAMODBYT) $(OCAMLC) -a -o $@ threads.cma $(AUXMODBYT) $+ $(LIBNAT): $(COMMONMODNAT) $(COMMONMODNATA) $(EXTRAMODNAT) $(OCAMLOPT) -a -o $@ $(COMMONMODNAT) $(AUXMODNAT) $(EXTRAMODNAT) -cclib -lthreadsnat -cclib -lunix -cclib -lpthread .PHONY: all install clean uninstall all: $(EXTRAMODINTF) $(LIBBYT) $(LIBNAT) install: all $(MKDIR) $(INSTALLDIR) $(CP) $(INSTALLFILES) $(INSTALLDIR) clean: ocamlclean uninstall: for i in $(INSTALLFILES); do $(RM) $(INSTALLDIR)/$$i; donecothreads/src/threads/cothread.ml0000640000175000017500000000137610660137370016362 0ustar erikderikdinclude Thread let spawn f x = let ch = Event.new_channel () in let result = ref `Unknown in let thread_fun () = let res = try `Result (f x) with e -> `Exn e in Event.sync (Event.send ch res) in ignore (Thread.create thread_fun ()); let rec launch () = match !result with | `Result v -> Event.always v | `Exn e -> raise e | `Unknown -> Event.wrap (Event.receive ch) (fun res -> result:= res; Event.sync (launch ())) in Event.guard launch let spawnl f x = let ch = Event.new_channel () in let thread_fun () = Event.sync (Event.send ch (f x)) in let launch () = let worker = Thread.create thread_fun () in Event.wrap_abort (Event.receive ch) (fun () -> Thread.kill worker) in Event.guard launch cothreads/src/threads/stm.ml0000640000175000017500000004265410671575550015410 0ustar erikderikd(***********************************************************************) (* *) (* STM library for OCaml *) (* *) (* (C) 2007 by Zheng Li (li@pps.jussieu.fr) *) (* *) (* This program is free software; you can redistribute it and/or *) (* modify it under the terms of the GNU Library General Public *) (* License as published by the Free Software Foundation; either *) (* version 2 of the License, or (at your option) any later version. *) (* *) (* This program is distributed in the hope that it will be useful, *) (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) (* GNU Library General Public License for more details. *) (* *) (***********************************************************************) (** A user-space STM library. This is the threads implementation. *) (** Lock mechanics *) (* The commit and read is a classical reader-writer problem. We make our choice for the writer's preference, because the readings before writings are possibly turn out to be invalid in the future and cause unnecessary computation. Here we use single lock, a more elegant-in-theory solution would give each tvar a lock, however there are very few chances it can speedup (esp. in the presense of OCaml'a master lock) and brings much more dangerous on deadlock and the complexity of solving them. *) let lock = Mutex.create () let writing = ref None and readers = ref 0 (* the working readers *) and writers = ref 0 (* the waiting writers *) (* The conditions of exchange *) let ok_to_read = Condition.create () and ok_to_write = Condition.create () (* Reader and Writer routines *) let start_write () = let my_id = Thread.id (Thread.self ()) in Mutex.lock lock; (match !writing with | Some (id, num) when id = my_id -> writing := Some (id, num + 1) | None when !readers = 0 && !writers = 0 -> writing := Some (my_id, 1) | _ -> incr writers; Condition.wait ok_to_write lock; decr writers ; writing := Some (my_id, 1)); Mutex.unlock lock and end_write () = Mutex.lock lock; match !writing with | None -> assert false | Some (id, n) -> if n = 1 then (writing := None; if !writers > 0 then Condition.signal ok_to_write else Condition.broadcast ok_to_read) else writing := Some (id, pred n); Mutex.unlock lock and start_read () = Mutex.lock lock; while !writing <> None || !writers > 0 do Condition.wait ok_to_read lock done; incr readers; Mutex.unlock lock and end_read () = Mutex.lock lock; decr readers; if !readers = 0 then Condition.signal ok_to_write; Mutex.unlock lock let reader f x = start_read (); try let res = f x in end_read (); res with e -> end_read (); raise e and writer f x = start_write (); try let res = f x in end_write (); res with e -> end_write (); raise e (** Internal representation of tvar, log, env (bindings) and thread info *) (* Magic number *) let stm_magic = 20072007 (* tid = stm_magic * thread_id * local_id, used as pure identification; tvid not only has tid inside, but also keep refrence (for GC) between each other. In such sense, tvid must carefully preserve physical linking/equivelence property, while tid doesn't. *) type tid = int * int * int and tvid = {tid: tid; mutable dirty: tvid list} (* We need both Obj and Marshal. Marshal is used to isolate side-effect so that tvar won't change through other means except tvar operation, however it breaks the referencing relation between values, so the former is used to preseve the referencing relation between values (esp. tvars) which is then used by Weaktidtbl module for GC. Just consider a tvar which has other tvars as its value, with Marshal back/forth, the reference realtion won't exist. *) type version = int and value = Obj.t and record = string let rec_of_var v = Marshal.to_string v [Marshal.Closures] let var_of_rec s = Marshal.from_string s 0 let rec_of_val o = Marshal.to_string (Obj.obj o) [Marshal.Closures] let val_of_rec s = Obj.repr (Marshal.from_string s 0) let val_of_var v = Obj.repr v let var_of_val o = Obj.obj o let tvid_eq {tid = tid1} {tid = tid2} = tid1 = tid2 let tvid_comp {tid = tid1} {tid = tid2} = compare tid1 tid2 let tvid_hash {tid = tid} = Hashtbl.hash tid let is_tvid o = Obj.tag o = 0 && let o' = Obj.field o 0 in Obj.tag o' = 0 && Obj.field o' 0 = Obj.repr stm_magic let tvid_obj_eq o1 o2 = is_tvid o1 && is_tvid o2 && Obj.field o1 0 = Obj.field o2 0 let filter_dirty v fold comb l base = fold (fun tvid ll -> if Libext.obj_refed_by tvid_obj_eq tvid v then comb tvid ll else ll ) l base let filter_subst v iter tbl = let r = ref v in iter (fun tvid -> Libext.obj_subst tvid_obj_eq (tvid,tvid) r) tbl; !r (* Tidtbl is used to define the environment (tid * value/version bindings) and log (tid * cur_value/rw_state etc. bindings). We must snapshot the whole environment (value bindings) before any atomic transactions, because tvars read on different points of a time series are actually inconsistent even if every updating is thread safe, besides we won't be able to know which tvars will be visited before the actual performing of each atomic transaction unit. Immutable data structure is used to save storage, otherwise we need a deep-persistent-copy. We use Map to get a immutable env. *) module Tidtbl = Map.Make (struct type t = tid let compare = compare end) module Tvidtbl = Map.Make (struct type t = tvid let compare = tvid_comp end) module Weaktidtbl = Weak.Make (struct type t = tvid let equal = tvid_eq let hash = tvid_hash end) module Thrtbl = Map.Make (struct type t = int let compare = compare end) (* env = tid -> tvar_repr bindings *) type env = tvar_repr Tidtbl.t and tvar_repr = { version: version; record: record } (* In a transaction log, we only care whether a tvar's first operation is read or write (useful for wait operation), and its current written value if being overwritten (useful for consequent read and commit). log = tvid -> log_item bindings *) type log = log_item Tvidtbl.t and log_item = { pre_version: version option; (* None = first op is write *) new_value: value option (* None = no write step, only read *) } (* Thr_info is global, immutable and locks-depending, whereas different threads can work on its own thr_state independently and sequentially. We are safe to make these thread-local variables mutable and lock-free. thr = thread_id -> thread_info bindings *) type thr = thr_info Thrtbl.t and thr_info = { channel: unit Event.channel; wait_tid : tid list ; state: thr_state } and thr_state = { mutable env: env; mutable log: log; (* When log is empty, env is free to get new env *) mutable tid_count : int; mutable layer: int (* For nested atom *) } (* Global variables information, should always be protected *) let global_env = ref Tidtbl.empty (* Global thread information *) let global_thr = ref Thrtbl.empty (* Global weak tid information, should always be proteced *) let global_weaktid = Weaktidtbl.create 29 (* Global to_remove list for env *) let global_remove = ref [] (* Some helper functions follows *) (* Thread safe: !global_thr is atomic, and no other thread will create thread record instead current thread itself *) let cur_thr_id () = Thread.id (Thread.self ()) let cur_thr () = Thrtbl.find (cur_thr_id ()) !global_thr (* Some of the following operations should be defined inside reader/writer context. To be more flexible and imposable, they are not defined themselves with reader/writer locking mechanics inside. The rule of thumb is that only STM primitives that related to global state should be defined with locks, helper functions are not. *) let new_thr () = let thr_id = cur_thr_id () in let thr_info = { channel = Event.new_channel (); wait_tid = []; state = { env = !global_env; log = Tvidtbl.empty; tid_count = 0; layer = 0 } } in global_thr := Thrtbl.add thr_id thr_info !global_thr; thr_info (* Hopefully atomic *) let clean_tid tvid = global_remove := tvid.tid :: !global_remove let clean_env () = let to_remove = !global_remove in global_remove := []; global_env := List.fold_right Tidtbl.remove to_remove !global_env (* valid_write take a log and env, produce (tvid list * log_item) list option: None means there are some contradictions between the version on which the log is based and the version of env; Some (r,w) means no contradictions and r a list of tvid been read and w is a list of tvid * value been written. *) let valid_write log env = Tvidtbl.fold (fun tvid item res -> match res, item.pre_version, item.new_value with | None, _, _ -> None | Some (r,w), None, Some value -> Some (r, (tvid, value)::w) | Some _, None, None -> assert false | Some (r,w), Some v, value -> if v <> (Tidtbl.find tvid.tid env).version then None else Some (tvid :: r, match value with None -> w | Some value -> (tvid, value) :: w) ) log (Some ([],[])) (* valid_read take a log and env, produce tvid list option: None means there are contradictions between log-based version and the version of env; Some l means no contradictions and l is a list of tvid been read *) let valid_read log env = Tvidtbl.fold (fun tvid item res -> match res, item.pre_version with | None, _ | _, None -> res | _, Some v when v <> (Tidtbl.find tvid.tid env).version -> None | Some l, Some v -> Some (tvid :: l) ) log (Some []) (* When saving/restoring state, Only log and layer needs saving, env does not change during atom performing, tid_count should keep increasing with every attempting no matter success or fail. *) let save_state st = {st with log = st.log; layer = st.layer} let restore_state st st_bak = st.log <- st_bak.log; st.layer <- st_bak.layer (* Be sure to reset as soon as possible, otherwise there could be memory leak due to unnecessary residu tvar, such as the mcast example *) let reset_state state = state.env <- !global_env; state.log <- Tvidtbl.empty let clean_state state = state.env <- Tidtbl.empty; state.log <- Tvidtbl.empty (** Transaction semantics *) (* Phantom type *) type 'a tvar = tvid type 'a stm = thr_state -> 'a let return v = fun state -> v let bind t f = fun state -> f (t state) state let ( >>= ) = bind let ( >> ) s1 s2 = s1 >>= (fun _ -> s2) (* Non-transactional declaration of new tvar, ensure to success *) let tvar v = let thr_state = try (reader cur_thr ()).state (* we are safe to separate test-read and write operations here, as no other threads will create the record for the current thread except itself *) with Not_found -> (writer new_thr ()).state in thr_state.tid_count <- succ thr_state.tid_count; let new_tid = (stm_magic, cur_thr_id (), thr_state.tid_count) in let new_repr = {version = 0; record = rec_of_var v} in writer (fun () -> let dirty = filter_dirty v Weaktidtbl.fold (fun x l -> x::l) global_weaktid [] in let new_tvid = {tid = new_tid; dirty = dirty} in let _ = Gc.finalise clean_tid new_tvid in thr_state.env <- Tidtbl.add new_tid new_repr thr_state.env; global_env := Tidtbl.add new_tid new_repr !global_env; Weaktidtbl.add global_weaktid new_tvid; new_tvid ) () (* Transactional declaration of new tvar *) let new_tvar v = fun state -> state.tid_count <- succ state.tid_count; let new_tid = (stm_magic, cur_thr_id (), state.tid_count) in let new_tvid = {tid =new_tid; dirty = []} in let new_log_item = { pre_version = None; new_value = Some (val_of_var v) } in state.log <- Tvidtbl.add new_tvid new_log_item state.log; new_tvid let read_tvar tv = fun state -> try match (Tvidtbl.find tv state.log).new_value with | None -> var_of_rec (Tidtbl.find tv.tid state.env).record | Some v -> var_of_val v with Not_found -> let tv_repr = Tidtbl.find tv.tid state.env in let new_item = {pre_version = Some tv_repr.version; new_value = None} in state.log <- Tvidtbl.add tv new_item state.log; var_of_rec tv_repr.record let write_tvar tv v = fun state -> let new_value = Some (val_of_var v) in let log_item = try {(Tvidtbl.find tv state.log) with new_value = new_value} with Not_found -> {pre_version = None; new_value = new_value} in state.log <- Tvidtbl.add tv log_item state.log (* We use synchronized event here in order to be able to leave critical section by beginning a continuous waiting. Asynchronized event (Event.poll) won't be able to ensure the seamless connection of the leaving and beginning. Condition.wait seems natural, but won't be able to allow us to customize the locking mechanics as we do with the reader/writer solution. Global operation, lock required. *) let wait state = let e = writer (fun () -> match valid_read state.log !global_env with | None | Some [] -> Event.always () | Some l -> let new_thr_info = {(cur_thr ()) with wait_tid = List.map (fun x -> x.tid) l} in global_thr := Thrtbl.add (cur_thr_id ()) new_thr_info !global_thr; Event.receive new_thr_info.channel) () in Event.sync e let commit log v = writer (fun (log, v) -> match valid_write log !global_env with | None -> None | Some (r, w) -> let suspecious_r = List.fold_left (fun l tvid -> (Weaktidtbl.find global_weaktid tvid).dirty @ l) r r in let suspecious_w, old_dirty = List.fold_left (fun (sw,od) (tvid,_) -> try sw, ((Weaktidtbl.find global_weaktid tvid).dirty @ od) with Not_found -> Gc.finalise clean_tid tvid; Weaktidtbl.add global_weaktid tvid; (tvid::sw, od)) ([], []) w in let suspecious = suspecious_w @ suspecious_r in List.iter (fun (tvid, value) -> let dirty = filter_dirty value List.fold_right (fun x l -> x::l) suspecious [] in (Weaktidtbl.find global_weaktid tvid).dirty <- dirty; (global_env := let repr = { record = rec_of_val value; version = try (Tidtbl.find tvid.tid !global_env).version + 1 with Not_found -> 0 } in Tidtbl.add tvid.tid repr !global_env); (global_thr := Thrtbl.fold (fun id item thr -> if List.mem tvid.tid item.wait_tid then (Event.sync (Event.send item.channel ()); Thrtbl.add id {item with wait_tid = []} thr) else thr) !global_thr !global_thr) ) w; clean_env (); Some (filter_subst v Weaktidtbl.iter global_weaktid) ) (log, v) exception Abort exception Retry of bool (* whether wait or not *) let abort = fun _ -> raise Abort let retry = fun _ -> raise (Retry true) let retry_now = fun _ -> raise (Retry false) let catch t f = fun state -> let st_bak = save_state state in try t state with | Retry _ | Abort as e -> raise e | e -> restore_state state st_bak; f e state let or_else t1 t2 = fun state -> let state_bak = save_state state in try t1 state with Abort | Retry _ as r1 -> let state_bak_1 = save_state state in restore_state state state_bak; try t2 state with Abort | Retry _ as r2 -> match r1, r2 with | Abort, Abort -> restore_state state state_bak; raise Abort | Retry b, Abort -> restore_state state state_bak_1; raise (Retry b) | Abort, Retry b -> raise (Retry b) | Retry b1, Retry b2 -> (* Mix two logs are unavoidably dirty, fortunately we only cares about the reading records *) state.log <- Tvidtbl.fold (fun tvid log_item log -> match log_item.pre_version with | None -> log | Some v -> try (match (Tvidtbl.find tvid log).pre_version with | Some _ -> log | None -> raise Not_found) with Not_found -> Tvidtbl.add tvid log_item log) state_bak_1.log state.log; raise (Retry (b1 && b2)) | _, _ -> assert false let rec atom_once t = let state = try let st = (cur_thr ()).state in if st.layer = 0 then reset_state st; st with Not_found -> (writer new_thr ()).state in (* Really enter by succ layer *) state.layer <- succ state.layer; try let v = t state in (* Quit to upper layer *) state.layer <- pred state.layer; if state.layer > 0 then Some v else let log = state.log in let _ = clean_state state in commit log v with e -> state.layer <- pred state.layer; match state.layer, e with | 0, Retry b -> if b then wait state; atom_once t | 0, Abort -> clean_state state; None | _, _ -> raise e let rec atom t = match atom_once t with None -> atom t | Some v -> v cothreads/src/vmthreads/0000750000175000017500000000000010673744144014601 5ustar erikderikdcothreads/src/vmthreads/Makefile0000640000175000017500000000171610671575550016250 0ustar erikderikdinclude ../../Makefile.template INCLUDES=-I +vmthreads -I .. BACKEND = vmthreads AUXMOD = libext AUXMODBYT = $(AUXMOD:%=%.cmo) COMMONMOD = cothread stm COMMONMODSRC = $(COMMONMOD:%=%.ml) COMMONMODBYT = $(COMMONMOD:%=%.cmo) COMMONMODINTFSRC = $(COMMONMOD:%=%.mli) COMMONMODINTFCOM = $(COMMONMOD:%=%.cmi) COMMONMODINTF = $(COMMONMODINTFSRC) $(COMMONMODINTFCOM) LIB = cothreads LIBBYT = $(LIB:%=%.cma) INSTALLDIR = $(INSTALLLIBDIR)/$(BACKEND) INSTALLFILES = $(COMMONMODINTFCOM) $(LIBBYT) $(LIBBYT): $(COMMONMODBYT) $(OCAMLC) -a -o $@ threads.cma $(AUXMODBYT) $+ $(COMMONMODINTF):%:../% @if [ ! -e $@ -a -e ../$@ ]; then ln -s $< .; fi $(COMMONMODSRC):%:../threads/% @if [ ! -e $@ -a -e $< ]; then ln -s $< .; fi .PHONY: all install clean uninstall all: $(COMMONMODSRC) $(COMMONMODINTF) $(LIBBYT) install: all $(MKDIR) $(INSTALLDIR) $(CP) $(INSTALLFILES) $(INSTALLDIR) clean: ocamlclean uninstall: for i in $(INSTALLFILES); do $(RM) $(INSTALLDIR)/$$i; done