From c6a9dfdeaab14870e7665dfae7b7a0943d59788e Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 7 Nov 2023 13:52:58 +0000 Subject: [PATCH 01/10] Remove duplicate definition of exit in thread.ml --- ocaml/otherlibs/systhreads/thread.ml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/ocaml/otherlibs/systhreads/thread.ml b/ocaml/otherlibs/systhreads/thread.ml index a021d3223a4..44e3f962bba 100644 --- a/ocaml/otherlibs/systhreads/thread.ml +++ b/ocaml/otherlibs/systhreads/thread.ml @@ -76,10 +76,6 @@ let exit () = ignore (Sys.opaque_identity (check_memprof_cb ())); exit_stub () -let exit () = - ignore (Sys.opaque_identity (check_memprof_cb ())); - exit_stub () - (* Thread.kill is currently not implemented due to problems with cleanup handlers on several platforms *) From b14dd45769cd8eb0aaf9979912090497ebc8049a Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 7 Nov 2023 13:56:08 +0000 Subject: [PATCH 02/10] git mv systhreads systhreads4 --- ocaml/otherlibs/{systhreads => systhreads4}/.depend | 0 ocaml/otherlibs/{systhreads => systhreads4}/META.in | 0 ocaml/otherlibs/{systhreads => systhreads4}/Makefile | 0 ocaml/otherlibs/{systhreads => systhreads4}/byte/dune | 0 ocaml/otherlibs/{systhreads => systhreads4}/condition.ml | 0 ocaml/otherlibs/{systhreads => systhreads4}/condition.mli | 0 ocaml/otherlibs/{systhreads => systhreads4}/dune | 0 ocaml/otherlibs/{systhreads => systhreads4}/event.ml | 0 ocaml/otherlibs/{systhreads => systhreads4}/event.mli | 0 ocaml/otherlibs/{systhreads => systhreads4}/mutex.ml | 0 ocaml/otherlibs/{systhreads => systhreads4}/mutex.mli | 0 ocaml/otherlibs/{systhreads => systhreads4}/native/dune | 0 ocaml/otherlibs/{systhreads => systhreads4}/semaphore.ml | 0 ocaml/otherlibs/{systhreads => systhreads4}/semaphore.mli | 0 ocaml/otherlibs/{systhreads => systhreads4}/st_posix.h | 0 ocaml/otherlibs/{systhreads => systhreads4}/st_pthreads.h | 0 ocaml/otherlibs/{systhreads => systhreads4}/st_stubs.c | 0 ocaml/otherlibs/{systhreads => systhreads4}/st_win32.h | 0 ocaml/otherlibs/{systhreads => systhreads4}/thread.ml | 0 ocaml/otherlibs/{systhreads => systhreads4}/thread.mli | 0 ocaml/otherlibs/{systhreads => systhreads4}/threads.h | 0 21 files changed, 0 insertions(+), 0 deletions(-) rename ocaml/otherlibs/{systhreads => systhreads4}/.depend (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/META.in (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/Makefile (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/byte/dune (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/condition.ml (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/condition.mli (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/dune (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/event.ml (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/event.mli (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/mutex.ml (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/mutex.mli (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/native/dune (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/semaphore.ml (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/semaphore.mli (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/st_posix.h (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/st_pthreads.h (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/st_stubs.c (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/st_win32.h (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/thread.ml (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/thread.mli (100%) rename ocaml/otherlibs/{systhreads => systhreads4}/threads.h (100%) diff --git a/ocaml/otherlibs/systhreads/.depend b/ocaml/otherlibs/systhreads4/.depend similarity index 100% rename from ocaml/otherlibs/systhreads/.depend rename to ocaml/otherlibs/systhreads4/.depend diff --git a/ocaml/otherlibs/systhreads/META.in b/ocaml/otherlibs/systhreads4/META.in similarity index 100% rename from ocaml/otherlibs/systhreads/META.in rename to ocaml/otherlibs/systhreads4/META.in diff --git a/ocaml/otherlibs/systhreads/Makefile b/ocaml/otherlibs/systhreads4/Makefile similarity index 100% rename from ocaml/otherlibs/systhreads/Makefile rename to ocaml/otherlibs/systhreads4/Makefile diff --git a/ocaml/otherlibs/systhreads/byte/dune b/ocaml/otherlibs/systhreads4/byte/dune similarity index 100% rename from ocaml/otherlibs/systhreads/byte/dune rename to ocaml/otherlibs/systhreads4/byte/dune diff --git a/ocaml/otherlibs/systhreads/condition.ml b/ocaml/otherlibs/systhreads4/condition.ml similarity index 100% rename from ocaml/otherlibs/systhreads/condition.ml rename to ocaml/otherlibs/systhreads4/condition.ml diff --git a/ocaml/otherlibs/systhreads/condition.mli b/ocaml/otherlibs/systhreads4/condition.mli similarity index 100% rename from ocaml/otherlibs/systhreads/condition.mli rename to ocaml/otherlibs/systhreads4/condition.mli diff --git a/ocaml/otherlibs/systhreads/dune b/ocaml/otherlibs/systhreads4/dune similarity index 100% rename from ocaml/otherlibs/systhreads/dune rename to ocaml/otherlibs/systhreads4/dune diff --git a/ocaml/otherlibs/systhreads/event.ml b/ocaml/otherlibs/systhreads4/event.ml similarity index 100% rename from ocaml/otherlibs/systhreads/event.ml rename to ocaml/otherlibs/systhreads4/event.ml diff --git a/ocaml/otherlibs/systhreads/event.mli b/ocaml/otherlibs/systhreads4/event.mli similarity index 100% rename from ocaml/otherlibs/systhreads/event.mli rename to ocaml/otherlibs/systhreads4/event.mli diff --git a/ocaml/otherlibs/systhreads/mutex.ml b/ocaml/otherlibs/systhreads4/mutex.ml similarity index 100% rename from ocaml/otherlibs/systhreads/mutex.ml rename to ocaml/otherlibs/systhreads4/mutex.ml diff --git a/ocaml/otherlibs/systhreads/mutex.mli b/ocaml/otherlibs/systhreads4/mutex.mli similarity index 100% rename from ocaml/otherlibs/systhreads/mutex.mli rename to ocaml/otherlibs/systhreads4/mutex.mli diff --git a/ocaml/otherlibs/systhreads/native/dune b/ocaml/otherlibs/systhreads4/native/dune similarity index 100% rename from ocaml/otherlibs/systhreads/native/dune rename to ocaml/otherlibs/systhreads4/native/dune diff --git a/ocaml/otherlibs/systhreads/semaphore.ml b/ocaml/otherlibs/systhreads4/semaphore.ml similarity index 100% rename from ocaml/otherlibs/systhreads/semaphore.ml rename to ocaml/otherlibs/systhreads4/semaphore.ml diff --git a/ocaml/otherlibs/systhreads/semaphore.mli b/ocaml/otherlibs/systhreads4/semaphore.mli similarity index 100% rename from ocaml/otherlibs/systhreads/semaphore.mli rename to ocaml/otherlibs/systhreads4/semaphore.mli diff --git a/ocaml/otherlibs/systhreads/st_posix.h b/ocaml/otherlibs/systhreads4/st_posix.h similarity index 100% rename from ocaml/otherlibs/systhreads/st_posix.h rename to ocaml/otherlibs/systhreads4/st_posix.h diff --git a/ocaml/otherlibs/systhreads/st_pthreads.h b/ocaml/otherlibs/systhreads4/st_pthreads.h similarity index 100% rename from ocaml/otherlibs/systhreads/st_pthreads.h rename to ocaml/otherlibs/systhreads4/st_pthreads.h diff --git a/ocaml/otherlibs/systhreads/st_stubs.c b/ocaml/otherlibs/systhreads4/st_stubs.c similarity index 100% rename from ocaml/otherlibs/systhreads/st_stubs.c rename to ocaml/otherlibs/systhreads4/st_stubs.c diff --git a/ocaml/otherlibs/systhreads/st_win32.h b/ocaml/otherlibs/systhreads4/st_win32.h similarity index 100% rename from ocaml/otherlibs/systhreads/st_win32.h rename to ocaml/otherlibs/systhreads4/st_win32.h diff --git a/ocaml/otherlibs/systhreads/thread.ml b/ocaml/otherlibs/systhreads4/thread.ml similarity index 100% rename from ocaml/otherlibs/systhreads/thread.ml rename to ocaml/otherlibs/systhreads4/thread.ml diff --git a/ocaml/otherlibs/systhreads/thread.mli b/ocaml/otherlibs/systhreads4/thread.mli similarity index 100% rename from ocaml/otherlibs/systhreads/thread.mli rename to ocaml/otherlibs/systhreads4/thread.mli diff --git a/ocaml/otherlibs/systhreads/threads.h b/ocaml/otherlibs/systhreads4/threads.h similarity index 100% rename from ocaml/otherlibs/systhreads/threads.h rename to ocaml/otherlibs/systhreads4/threads.h From 08a94c32e56915161b501251dab3816494473117 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 7 Nov 2023 14:16:35 +0000 Subject: [PATCH 03/10] Import otherlibs/systhreads/ from upstream tree at rev a7840563fe9fe972d1f34f72f58d46d9dd67fa16 (tag tip-5 in ocaml-jst) as ocaml/otherlibs/systhreads5/ --- ocaml/otherlibs/systhreads5/.depend | 10 + ocaml/otherlibs/systhreads5/META.in | 13 + ocaml/otherlibs/systhreads5/Makefile | 170 +++++ ocaml/otherlibs/systhreads5/event.ml | 276 ++++++++ ocaml/otherlibs/systhreads5/event.mli | 81 +++ ocaml/otherlibs/systhreads5/st_posix.h | 96 +++ ocaml/otherlibs/systhreads5/st_pthreads.h | 305 ++++++++ ocaml/otherlibs/systhreads5/st_stubs.c | 819 ++++++++++++++++++++++ ocaml/otherlibs/systhreads5/st_win32.h | 41 ++ ocaml/otherlibs/systhreads5/thread.ml | 112 +++ ocaml/otherlibs/systhreads5/thread.mli | 174 +++++ ocaml/otherlibs/systhreads5/threads.h | 71 ++ 12 files changed, 2168 insertions(+) create mode 100644 ocaml/otherlibs/systhreads5/.depend create mode 100644 ocaml/otherlibs/systhreads5/META.in create mode 100644 ocaml/otherlibs/systhreads5/Makefile create mode 100644 ocaml/otherlibs/systhreads5/event.ml create mode 100644 ocaml/otherlibs/systhreads5/event.mli create mode 100644 ocaml/otherlibs/systhreads5/st_posix.h create mode 100644 ocaml/otherlibs/systhreads5/st_pthreads.h create mode 100644 ocaml/otherlibs/systhreads5/st_stubs.c create mode 100644 ocaml/otherlibs/systhreads5/st_win32.h create mode 100644 ocaml/otherlibs/systhreads5/thread.ml create mode 100644 ocaml/otherlibs/systhreads5/thread.mli create mode 100644 ocaml/otherlibs/systhreads5/threads.h diff --git a/ocaml/otherlibs/systhreads5/.depend b/ocaml/otherlibs/systhreads5/.depend new file mode 100644 index 00000000000..11b76f90bb7 --- /dev/null +++ b/ocaml/otherlibs/systhreads5/.depend @@ -0,0 +1,10 @@ +event.cmo : \ + event.cmi +event.cmx : \ + event.cmi +event.cmi : +thread.cmo : \ + thread.cmi +thread.cmx : \ + thread.cmi +thread.cmi : diff --git a/ocaml/otherlibs/systhreads5/META.in b/ocaml/otherlibs/systhreads5/META.in new file mode 100644 index 00000000000..07d301f116a --- /dev/null +++ b/ocaml/otherlibs/systhreads5/META.in @@ -0,0 +1,13 @@ +# @configure_input@ + +version = "@VERSION@" +description = "Multi-threading" +requires = "unix" +archive(byte) = "threads.cma" +archive(native) = "threads.cmxa" +type_of_threads = "posix" + +package "posix" ( + requires = "threads" + version = "[internal]" +) diff --git a/ocaml/otherlibs/systhreads5/Makefile b/ocaml/otherlibs/systhreads5/Makefile new file mode 100644 index 00000000000..a098f0bafdb --- /dev/null +++ b/ocaml/otherlibs/systhreads5/Makefile @@ -0,0 +1,170 @@ +#************************************************************************** +#* * +#* OCaml * +#* * +#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * +#* * +#* Copyright 1999 Institut National de Recherche en Informatique et * +#* en Automatique. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +ROOTDIR=../.. + +include $(ROOTDIR)/Makefile.common +include $(ROOTDIR)/Makefile.best_binaries + +ifneq "$(CCOMPTYPE)" "msvc" +OC_CFLAGS += -g +endif + +OC_CFLAGS += $(SHAREDLIB_CFLAGS) + +LIBS = $(STDLIBFLAGS) -I $(ROOTDIR)/otherlibs/unix + +CAMLC=$(BEST_OCAMLC) $(LIBS) +CAMLOPT=$(BEST_OCAMLOPT) $(LIBS) + +MKLIB=$(OCAMLRUN) $(ROOTDIR)/tools/ocamlmklib$(EXE) +COMPFLAGS=-w +33..39 -warn-error +A -g -bin-annot +ifeq "$(FLAMBDA)" "true" +OPTCOMPFLAGS += -O3 +endif + +LIBNAME=threads + +# Note: the header on which object files produced from st_stubs.c +# should actually depend is known for sure only at compile-time. +# That's why this dependency is handled in the Makefile directly +# and removed from the output of the C compiler during make depend + +BYTECODE_C_OBJS=st_stubs.b.$(O) +NATIVECODE_C_OBJS=st_stubs.n.$(O) + +THREADS_SOURCES = thread.ml event.ml + +THREADS_BCOBJS = $(THREADS_SOURCES:.ml=.cmo) +THREADS_NCOBJS = $(THREADS_SOURCES:.ml=.cmx) + +MLIFILES=thread.mli event.mli + +CMIFILES=$(MLIFILES:.mli=.cmi) + +all: lib$(LIBNAME).$(A) $(LIBNAME).cma $(CMIFILES) + +allopt: lib$(LIBNAME)nat.$(A) $(LIBNAME).cmxa $(CMIFILES) + +lib$(LIBNAME).$(A): $(BYTECODE_C_OBJS) + $(V_OCAMLMKLIB)$(MKLIB_CMD) -o $(LIBNAME) $(BYTECODE_C_OBJS) + +lib$(LIBNAME)nat.$(A): OC_CFLAGS += $(OC_NATIVE_CFLAGS) + +lib$(LIBNAME)nat.$(A): $(NATIVECODE_C_OBJS) + $(V_OCAMLMKLIB)$(MKLIB_CMD) -o $(LIBNAME)nat $^ + +$(LIBNAME).cma: $(THREADS_BCOBJS) +ifeq "$(UNIX_OR_WIN32)" "unix" + $(V_OCAMLMKLIB)$(MKLIB) -o $(LIBNAME) -ocamlc '$(CAMLC)' -cclib -lunixbyt -linkall $^ +# TODO: Figure out why -cclib -lunix is used here. +# It may be because of the threadsUnix module which is deprecated. +# It may hence be good to figure out whether this module shouldn't be +# removed, and then -cclib -lunix arguments. +else # Windows + $(V_OCAMLMKLIB)$(MKLIB) -o $(LIBNAME) -ocamlc "$(CAMLC)" -linkall $^ +endif + +# See remark above: force static linking of libthreadsnat.a +$(LIBNAME).cmxa: $(THREADS_NCOBJS) + $(V_LINKOPT)$(CAMLOPT) -linkall -a -cclib -lthreadsnat -o $@ $^ + +# Note: I removed "-cclib -lunix" from the line above. +# Indeed, if we link threads.cmxa, then we must also link unix.cmxa, +# which itself will pass -lunix to the C linker. It seems more +# modular to me this way. -- Alain + +# The following lines produce two object files st_stubs.b.$(O) and +# st_stubs.n.$(O) from the same source file st_stubs.c (it is compiled +# twice, each time with different options). + +ifeq "$(COMPUTE_DEPS)" "true" +st_stubs.%.$(O): st_stubs.c +else +st_stubs.%.$(O): st_stubs.c $(RUNTIME_HEADERS) $(wildcard *.h) +endif + $(V_CC)$(CC) -c $(OC_CFLAGS) $(CFLAGS) $(OC_CPPFLAGS) $(CPPFLAGS) \ + $(OUTPUTOBJ)$@ $< + +.PHONY: partialclean +partialclean: + rm -f *.cm* + +.PHONY: clean +clean: partialclean + rm -f dllthreads*.so dllthreads*.dll *.a *.lib *.o *.obj + rm -rf $(DEPDIR) + +.PHONY: distclean +distclean: clean + rm -f META + +INSTALL_THREADSLIBDIR=$(INSTALL_LIBDIR)/$(LIBNAME) + +install: + if test -f dllthreads$(EXT_DLL); then \ + $(INSTALL_PROG) dllthreads$(EXT_DLL) "$(INSTALL_STUBLIBDIR)"; \ + fi + $(INSTALL_DATA) libthreads.$(A) "$(INSTALL_LIBDIR)" + $(MKDIR) "$(INSTALL_THREADSLIBDIR)" + $(INSTALL_DATA) \ + $(CMIFILES) threads.cma META \ + "$(INSTALL_THREADSLIBDIR)" +ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true" + $(INSTALL_DATA) \ + $(CMIFILES:.cmi=.cmti) \ + "$(INSTALL_THREADSLIBDIR)" + $(INSTALL_DATA) $(MLIFILES) "$(INSTALL_THREADSLIBDIR)" +endif + $(INSTALL_DATA) threads.h "$(INSTALL_INCDIR)" + +installopt: + $(INSTALL_DATA) libthreadsnat.$(A) "$(INSTALL_LIBDIR)" + $(INSTALL_DATA) \ + $(THREADS_NCOBJS) threads.cmxa threads.$(A) \ + "$(INSTALL_THREADSLIBDIR)" + +%.cmi: %.mli + $(V_OCAMLC)$(CAMLC) -c $(COMPFLAGS) $< + +%.cmo: %.ml + $(V_OCAMLC)$(CAMLC) -c $(COMPFLAGS) $< + +%.cmx: %.ml + $(V_OCAMLOPT)$(CAMLOPT) -c $(COMPFLAGS) $(OPTCOMPFLAGS) $< + +DEP_FILES := st_stubs.b.$(D) +ifeq "$(NATIVE_COMPILER)" "true" +DEP_FILES += st_stubs.n.$(D) +endif + +ifeq "$(COMPUTE_DEPS)" "true" +include $(addprefix $(DEPDIR)/, $(DEP_FILES)) +endif + +%.n.$(D): OC_CPPFLAGS += $(OC_NATIVE_CPPFLAGS) + +define GEN_RULE +$(DEPDIR)/%.$(1).$(D): %.c | $(DEPDIR) + $$(V_CCDEPS)$$(DEP_CC) $$(OC_CPPFLAGS) $$(CPPFLAGS) $$< -MT '$$*.$(1).$(O)' -MF $$@ +endef + +$(foreach object_type, b n, $(eval $(call GEN_RULE,$(object_type)))) + +.PHONY: depend +depend: + $(V_GEN)$(OCAMLRUN) $(ROOTDIR)/boot/ocamlc -depend -slash *.mli *.ml > .depend + +include .depend diff --git a/ocaml/otherlibs/systhreads5/event.ml b/ocaml/otherlibs/systhreads5/event.ml new file mode 100644 index 00000000000..f5fc9785fcb --- /dev/null +++ b/ocaml/otherlibs/systhreads5/event.ml @@ -0,0 +1,276 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* David Nowak and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Events *) +type 'a basic_event = + { poll: unit -> bool; + (* If communication can take place immediately, return true. *) + suspend: unit -> unit; + (* Offer the communication on the channel and get ready + to suspend current process. *) + result: unit -> 'a } + (* Return the result of the communication *) + +type 'a behavior = int ref -> Condition.t -> int -> 'a basic_event + +type 'a event = + Communication of 'a behavior + | Choose of 'a event list + | WrapAbort of 'a event * (unit -> unit) + | Guard of (unit -> 'a event) + +(* Communication channels *) +type 'a channel = + { mutable writes_pending: 'a communication Queue.t; + (* All offers to write on it *) + mutable reads_pending: 'a communication Queue.t } + (* All offers to read from it *) + +(* Communication offered *) +and 'a communication = + { performed: int ref; (* -1 if not performed yet, set to the number *) + (* of the matching communication after rendez-vous. *) + condition: Condition.t; (* To restart the blocked thread. *) + mutable data: 'a option; (* The data sent or received. *) + event_number: int } (* Event number in select *) + +(* Create a channel *) + +let new_channel () = + { writes_pending = Queue.create(); + reads_pending = Queue.create() } + +(* Basic synchronization function *) + +let masterlock = Mutex.create() + +let do_aborts abort_env genev performed = + if abort_env <> [] then begin + if performed >= 0 then begin + let ids_done = snd genev.(performed) in + List.iter + (fun (id,f) -> if not (List.mem id ids_done) then f ()) + abort_env + end else begin + List.iter (fun (_,f) -> f ()) abort_env + end + end + +let basic_sync abort_env genev = + let performed = ref (-1) in + let condition = Condition.create() in + let bev = Array.make (Array.length genev) + (fst (genev.(0)) performed condition 0) in + for i = 1 to Array.length genev - 1 do + bev.(i) <- (fst genev.(i)) performed condition i + done; + (* See if any of the events is already activable *) + let rec poll_events i = + if i >= Array.length bev + then false + else bev.(i).poll() || poll_events (i+1) in + Mutex.lock masterlock; + if not (poll_events 0) then begin + (* Suspend on all events *) + for i = 0 to Array.length bev - 1 do bev.(i).suspend() done; + (* Wait until the condition is signalled *) + Condition.wait condition masterlock; + (* PR#7013: protect against spurious wake-up *) + while !performed < 0 do Condition.wait condition masterlock done + end; + Mutex.unlock masterlock; + (* Extract the result *) + if abort_env = [] then + (* Preserve tail recursion *) + bev.(!performed).result() + else begin + let num = !performed in + let result = bev.(num).result() in + (* Handle the aborts and return the result *) + do_aborts abort_env genev num; + result + end + +(* Apply a random permutation on an array *) + +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 + +(* Main synchronization function *) + +let gensym = let count = ref 0 in fun () -> incr count; !count + +let rec flatten_event + (abort_list : int list) + (accu : ('a behavior * int list) list) + (accu_abort : (int * (unit -> unit)) list) + ev = + match ev with + Communication bev -> ((bev,abort_list) :: accu) , accu_abort + | WrapAbort (ev,fn) -> + let id = gensym () in + flatten_event (id :: abort_list) accu ((id,fn)::accu_abort) ev + | Choose evl -> + let rec flatten_list accu' accu_abort'= function + ev :: l -> + let (accu'',accu_abort'') = + flatten_event abort_list accu' accu_abort' ev in + flatten_list accu'' accu_abort'' l + | [] -> (accu',accu_abort') in + flatten_list accu accu_abort evl + | Guard fn -> flatten_event abort_list accu accu_abort (fn ()) + +let sync ev = + let (evl,abort_env) = flatten_event [] [] [] ev in + basic_sync abort_env (scramble_array(Array.of_list evl)) + +(* Event polling -- like sync, but non-blocking *) + +let basic_poll abort_env genev = + let performed = ref (-1) in + let condition = Condition.create() in + let bev = Array.make(Array.length genev) + (fst genev.(0) performed condition 0) in + for i = 1 to Array.length genev - 1 do + bev.(i) <- fst genev.(i) performed condition i + done; + (* See if any of the events is already activable *) + let rec poll_events i = + if i >= Array.length bev + then false + else bev.(i).poll() || poll_events (i+1) in + Mutex.lock masterlock; + let ready = poll_events 0 in + if ready then begin + (* Extract the result *) + Mutex.unlock masterlock; + let result = Some(bev.(!performed).result()) in + do_aborts abort_env genev !performed; result + end else begin + (* Cancel the communication offers *) + performed := 0; + Mutex.unlock masterlock; + do_aborts abort_env genev (-1); + None + end + +let poll ev = + let (evl,abort_env) = flatten_event [] [] [] ev in + basic_poll abort_env (scramble_array(Array.of_list evl)) + +(* Remove all communication opportunities already synchronized *) + +let cleanup_queue q = + let q' = Queue.create() in + Queue.iter (fun c -> if !(c.performed) = -1 then Queue.add c q') q; + q' + +(* Event construction *) + +let always data = + Communication(fun performed condition evnum -> + { poll = (fun () -> performed := evnum; true); + suspend = (fun () -> ()); + result = (fun () -> data) }) + +let send channel data = + Communication(fun performed condition evnum -> + let wcomm = + { performed = performed; + condition = condition; + data = Some data; + event_number = evnum } in + { poll = (fun () -> + let rec poll () = + let rcomm = Queue.take channel.reads_pending in + if !(rcomm.performed) >= 0 then + poll () + else begin + rcomm.data <- wcomm.data; + performed := evnum; + rcomm.performed := rcomm.event_number; + Condition.signal rcomm.condition + end in + try + poll(); + true + with Queue.Empty -> + false); + suspend = (fun () -> + channel.writes_pending <- cleanup_queue channel.writes_pending; + Queue.add wcomm channel.writes_pending); + result = (fun () -> ()) }) + +let receive channel = + Communication(fun performed condition evnum -> + let rcomm = + { performed = performed; + condition = condition; + data = None; + event_number = evnum } in + { poll = (fun () -> + let rec poll () = + let wcomm = Queue.take channel.writes_pending in + if !(wcomm.performed) >= 0 then + poll () + else begin + rcomm.data <- wcomm.data; + performed := evnum; + wcomm.performed := wcomm.event_number; + Condition.signal wcomm.condition + end in + try + poll(); + true + with Queue.Empty -> + false); + suspend = (fun () -> + channel.reads_pending <- cleanup_queue channel.reads_pending; + Queue.add rcomm channel.reads_pending); + result = (fun () -> + match rcomm.data with + None -> invalid_arg "Event.receive" + | Some res -> res) }) + +let choose evl = Choose evl + +let wrap_abort ev fn = WrapAbort(ev,fn) + +let guard fn = Guard fn + +let rec wrap ev fn = + match ev with + Communication genev -> + Communication(fun performed condition evnum -> + let bev = genev performed condition evnum in + { poll = bev.poll; + suspend = bev.suspend; + result = (fun () -> fn(bev.result())) }) + | Choose evl -> + Choose(List.map (fun ev -> wrap ev fn) evl) + | WrapAbort (ev, f') -> + WrapAbort (wrap ev fn, f') + | Guard gu -> + Guard(fun () -> wrap (gu()) fn) + +(* Convenience functions *) + +let select evl = sync(Choose evl) diff --git a/ocaml/otherlibs/systhreads5/event.mli b/ocaml/otherlibs/systhreads5/event.mli new file mode 100644 index 00000000000..fd452652c69 --- /dev/null +++ b/ocaml/otherlibs/systhreads5/event.mli @@ -0,0 +1,81 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* David Nowak and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** First-class synchronous communication. + + This module implements synchronous inter-thread communications over + channels. As in John Reppy's Concurrent ML system, the communication + events are first-class values: they can be built and combined + independently before being offered for communication. +*) + +type 'a channel +(** The type of communication channels carrying values of type ['a]. *) + +val new_channel : unit -> 'a channel +(** Return a new channel. *) + +type +'a event +(** The type of communication events returning a result of type ['a]. *) + +(** [send ch v] returns the event consisting in sending the value [v] + over the channel [ch]. The result value of this event is [()]. *) +val send : 'a channel -> 'a -> unit event + +(** [receive ch] returns the event consisting in receiving a value + from the channel [ch]. The result value of this event is the + value received. *) +val receive : 'a channel -> 'a event + +val always : 'a -> 'a event +(** [always v] returns an event that is always ready for + synchronization. The result value of this event is [v]. *) + +val choose : 'a event list -> 'a event +(** [choose evl] returns the event that is the alternative of + all the events in the list [evl]. *) + +val wrap : 'a event -> ('a -> 'b) -> 'b event +(** [wrap ev fn] returns the event that performs the same communications + as [ev], then applies the post-processing function [fn] + on the return value. *) + +val wrap_abort : 'a event -> (unit -> unit) -> 'a event +(** [wrap_abort ev fn] returns the event that performs + the same communications as [ev], but if it is not selected + the function [fn] is called after the synchronization. *) + +val guard : (unit -> 'a event) -> 'a event +(** [guard fn] returns the event that, when synchronized, computes + [fn()] and behaves as the resulting event. This enables + computing events with side-effects at the time of the synchronization + operation. *) + +val sync : 'a event -> 'a +(** 'Synchronize' on an event: offer all the communication + possibilities specified in the event to the outside world, + and block until one of the communications succeed. The result + value of that communication is returned. *) + +val select : 'a event list -> 'a +(** 'Synchronize' on an alternative of events. + [select evl] is shorthand for [sync(choose evl)]. *) + +val poll : 'a event -> 'a option +(** Non-blocking version of {!Event.sync}: offer all the communication + possibilities specified in the event to the outside world, + and if one can take place immediately, perform it and return + [Some r] where [r] is the result value of that communication. + Otherwise, return [None] without blocking. *) diff --git a/ocaml/otherlibs/systhreads5/st_posix.h b/ocaml/otherlibs/systhreads5/st_posix.h new file mode 100644 index 00000000000..1ed25fdef35 --- /dev/null +++ b/ocaml/otherlibs/systhreads5/st_posix.h @@ -0,0 +1,96 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ +/* */ +/* Copyright 2009 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* POSIX thread implementation of the "st" interface */ + +#ifdef HAS_SYS_SELECT_H +#include +#endif + +Caml_inline void st_msleep(int msec) +{ + struct timeval timeout = {0, msec * 1000}; + select(0, NULL, NULL, NULL, &timeout); +} + +#include "st_pthreads.h" + +/* Signal handling */ + +static void st_decode_sigset(value vset, sigset_t * set) +{ + sigemptyset(set); + for (/*nothing*/; vset != Val_emptylist; vset = Field(vset, 1)) { + int sig = caml_convert_signal_number(Int_val(Field(vset, 0))); + sigaddset(set, sig); + } +} + +#ifndef NSIG +#define NSIG 64 +#endif + +static value st_encode_sigset(sigset_t * set) +{ + CAMLparam0(); + CAMLlocal1(res); + int i; + + res = Val_emptylist; + + for (i = 1; i < NSIG; i++) + if (sigismember(set, i) > 0) { + res = caml_alloc_2(Tag_cons, + Val_int(caml_rev_convert_signal_number(i)), res); + } + CAMLreturn(res); +} + +static int sigmask_cmd[3] = { SIG_SETMASK, SIG_BLOCK, SIG_UNBLOCK }; + +value caml_thread_sigmask(value cmd, value sigs) +{ + int how; + sigset_t set, oldset; + int retcode; + + how = sigmask_cmd[Int_val(cmd)]; + st_decode_sigset(sigs, &set); + caml_enter_blocking_section(); + retcode = pthread_sigmask(how, &set, &oldset); + caml_leave_blocking_section(); + sync_check_error(retcode, "Thread.sigmask"); + /* Run any handlers for just-unmasked pending signals */ + caml_process_pending_actions(); + return st_encode_sigset(&oldset); +} + +value caml_wait_signal(value sigs) +{ +#ifdef HAS_SIGWAIT + sigset_t set; + int retcode, signo; + + st_decode_sigset(sigs, &set); + caml_enter_blocking_section(); + retcode = sigwait(&set, &signo); + caml_leave_blocking_section(); + sync_check_error(retcode, "Thread.wait_signal"); + return Val_int(caml_rev_convert_signal_number(signo)); +#else + caml_invalid_argument("Thread.wait_signal not implemented"); + return Val_int(0); /* not reached */ +#endif +} diff --git a/ocaml/otherlibs/systhreads5/st_pthreads.h b/ocaml/otherlibs/systhreads5/st_pthreads.h new file mode 100644 index 00000000000..bd8839b6de2 --- /dev/null +++ b/ocaml/otherlibs/systhreads5/st_pthreads.h @@ -0,0 +1,305 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ +/* */ +/* Copyright 2009 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* POSIX thread implementation of the "st" interface */ + +#include +#include +#include +#include +#include +#include +#include +#include +#ifdef HAS_UNISTD +#include +#endif + +typedef int st_retcode; + +/* Variables used to stop "tick" threads */ +static atomic_uintnat tick_thread_stop[Max_domains]; +#define Tick_thread_stop tick_thread_stop[Caml_state->id] + +/* OS-specific initialization */ + +static int st_initialize(void) +{ + atomic_store_release(&Tick_thread_stop, 0); + return 0; +} + +/* Thread creation. Created in detached mode if [res] is NULL. */ + +typedef pthread_t st_thread_id; + + +static int st_thread_create(st_thread_id * res, + void * (*fn)(void *), void * arg) +{ + pthread_t thr; + pthread_attr_t attr; + int rc; + + pthread_attr_init(&attr); + if (res == NULL) pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); + rc = pthread_create(&thr, &attr, fn, arg); + if (res != NULL) *res = thr; + return rc; +} + +#define ST_THREAD_FUNCTION void * + +/* Thread termination */ + +static void st_thread_join(st_thread_id thr) +{ + pthread_join(thr, NULL); + /* best effort: ignore errors */ +} + +/* Thread-specific state */ + +typedef pthread_key_t st_tlskey; + +static int st_tls_newkey(st_tlskey * res) +{ + return pthread_key_create(res, NULL); +} + +Caml_inline void * st_tls_get(st_tlskey k) +{ + return pthread_getspecific(k); +} + +Caml_inline void st_tls_set(st_tlskey k, void * v) +{ + pthread_setspecific(k, v); +} + +/* The master lock. This is a mutex that is held most of the time, + so we implement it in a slightly convoluted way to avoid + all risks of busy-waiting. Also, we count the number of waiting + threads. */ + +typedef struct { + int init; /* have the mutex and the cond been + initialized already? */ + pthread_mutex_t lock; /* to protect contents */ + uintnat busy; /* 0 = free, 1 = taken */ + atomic_uintnat waiters; /* number of threads waiting on master lock */ + pthread_cond_t is_free; /* signaled when free */ +} st_masterlock; + +static void st_masterlock_init(st_masterlock * m) +{ + if (!m->init) { + // FIXME: check errors + pthread_mutex_init(&m->lock, NULL); + pthread_cond_init(&m->is_free, NULL); + m->init = 1; + } + m->busy = 1; + atomic_store_release(&m->waiters, 0); + + return; +}; + +static uintnat st_masterlock_waiters(st_masterlock * m) +{ + return atomic_load_acquire(&m->waiters); +} + +static void st_bt_lock_acquire(st_masterlock *m) { + + /* We do not want to signal the backup thread is it is not "working" + as it may very well not be, because we could have just resumed + execution from another thread right away. */ + if (caml_bt_is_in_blocking_section()) { + caml_bt_enter_ocaml(); + } + + caml_acquire_domain_lock(); + + return; +} + +static void st_bt_lock_release(st_masterlock *m) { + + /* Here we do want to signal the backup thread iff there's + no thread waiting to be scheduled, and the backup thread is currently + idle. */ + if (st_masterlock_waiters(m) == 0 && + caml_bt_is_in_blocking_section() == 0) { + caml_bt_exit_ocaml(); + } + + caml_release_domain_lock(); + + return; +} + +static void st_masterlock_acquire(st_masterlock *m) +{ + pthread_mutex_lock(&m->lock); + while (m->busy) { + atomic_fetch_add(&m->waiters, +1); + pthread_cond_wait(&m->is_free, &m->lock); + atomic_fetch_add(&m->waiters, -1); + } + m->busy = 1; + st_bt_lock_acquire(m); + pthread_mutex_unlock(&m->lock); + + return; +} + +static void st_masterlock_release(st_masterlock * m) +{ + pthread_mutex_lock(&m->lock); + m->busy = 0; + st_bt_lock_release(m); + pthread_cond_signal(&m->is_free); + pthread_mutex_unlock(&m->lock); + + return; +} + +/* Scheduling hints */ + +/* This is mostly equivalent to release(); acquire(), but better. In particular, + release(); acquire(); leaves both us and the waiter we signal() racing to + acquire the lock. Calling yield or sleep helps there but does not solve the + problem. Sleeping ourselves is much more reliable--and since we're handing + off the lock to a waiter we know exists, it's safe, as they'll certainly + re-wake us later. +*/ +Caml_inline void st_thread_yield(st_masterlock * m) +{ + pthread_mutex_lock(&m->lock); + /* We must hold the lock to call this. */ + + /* We already checked this without the lock, but we might have raced--if + there's no waiter, there's nothing to do and no one to wake us if we did + wait, so just keep going. */ + uintnat waiters = st_masterlock_waiters(m); + + if (waiters == 0) { + pthread_mutex_unlock(&m->lock); + return; + } + + m->busy = 0; + atomic_fetch_add(&m->waiters, +1); + pthread_cond_signal(&m->is_free); + /* releasing the domain lock but not triggering bt messaging + messaging the bt should not be required because yield assumes + that a thread will resume execution (be it the yielding thread + or a waiting thread */ + caml_release_domain_lock(); + + do { + /* Note: the POSIX spec prevents the above signal from pairing with this + wait, which is good: we'll reliably continue waiting until the next + yield() or enter_blocking_section() call (or we see a spurious condvar + wakeup, which are rare at best.) */ + pthread_cond_wait(&m->is_free, &m->lock); + } while (m->busy); + + m->busy = 1; + atomic_fetch_add(&m->waiters, -1); + + caml_acquire_domain_lock(); + + pthread_mutex_unlock(&m->lock); + + return; +} + +/* Triggered events */ + +typedef struct st_event_struct { + pthread_mutex_t lock; /* to protect contents */ + int status; /* 0 = not triggered, 1 = triggered */ + pthread_cond_t triggered; /* signaled when triggered */ +} * st_event; + + +static int st_event_create(st_event * res) +{ + int rc; + st_event e = caml_stat_alloc_noexc(sizeof(struct st_event_struct)); + if (e == NULL) return ENOMEM; + rc = pthread_mutex_init(&e->lock, NULL); + if (rc != 0) { caml_stat_free(e); return rc; } + rc = pthread_cond_init(&e->triggered, NULL); + if (rc != 0) + { pthread_mutex_destroy(&e->lock); caml_stat_free(e); return rc; } + e->status = 0; + *res = e; + return 0; +} + +static int st_event_destroy(st_event e) +{ + int rc1, rc2; + rc1 = pthread_mutex_destroy(&e->lock); + rc2 = pthread_cond_destroy(&e->triggered); + caml_stat_free(e); + return rc1 != 0 ? rc1 : rc2; +} + +static int st_event_trigger(st_event e) +{ + int rc; + rc = pthread_mutex_lock(&e->lock); + if (rc != 0) return rc; + e->status = 1; + rc = pthread_mutex_unlock(&e->lock); + if (rc != 0) return rc; + rc = pthread_cond_broadcast(&e->triggered); + return rc; +} + +static int st_event_wait(st_event e) +{ + int rc; + rc = pthread_mutex_lock(&e->lock); + if (rc != 0) return rc; + while(e->status == 0) { + rc = pthread_cond_wait(&e->triggered, &e->lock); + if (rc != 0) return rc; + } + rc = pthread_mutex_unlock(&e->lock); + return rc; +} + +/* The tick thread: interrupt the domain periodically to force preemption */ + +static void * caml_thread_tick(void * arg) +{ + int *domain_id = (int *) arg; + + caml_init_domain_self(*domain_id); + caml_domain_state *domain = Caml_state; + + while(! atomic_load_acquire(&Tick_thread_stop)) { + st_msleep(Thread_timeout); + + atomic_store_release(&domain->requested_external_interrupt, 1); + caml_interrupt_self(); + } + return NULL; +} diff --git a/ocaml/otherlibs/systhreads5/st_stubs.c b/ocaml/otherlibs/systhreads5/st_stubs.c new file mode 100644 index 00000000000..fe1df205eca --- /dev/null +++ b/ocaml/otherlibs/systhreads5/st_stubs.c @@ -0,0 +1,819 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS + +#if defined(_WIN32) && !defined(NATIVE_CODE) +/* Ensure that pthread.h marks symbols __declspec(dllimport) so that they can be + picked up from the runtime (which will have linked winpthreads statically). + mingw-w64 11.0.0 introduced WINPTHREADS_USE_DLLIMPORT to do this explicitly; + prior versions co-opted this on the internal DLL_EXPORT, but this is ignored + in 11.0 and later unless IN_WINPTHREAD is also defined, so we can safely + define both to support both versions. */ +#define WINPTHREADS_USE_DLLIMPORT +#define DLL_EXPORT +#endif + +#include "caml/alloc.h" +#include "caml/backtrace.h" +#include "caml/backtrace_prim.h" +#include "caml/callback.h" +#include "caml/custom.h" +#include "caml/debugger.h" +#include "caml/domain.h" +#include "caml/fail.h" +#include "caml/fiber.h" +#include "caml/io.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/printexc.h" +#include "caml/roots.h" +#include "caml/signals.h" +#include "caml/sync.h" +#include "caml/sys.h" +#include "caml/memprof.h" + +#include "../../runtime/sync_posix.h" + +/* threads.h is *not* included since it contains the _external_ declarations for + the caml_c_thread_register and caml_c_thread_unregister functions. */ + +/* Max computation time before rescheduling, in milliseconds */ +#define Thread_timeout 50 + +/* OS-specific code */ +#ifdef _WIN32 +#include "st_win32.h" +#else +#include "st_posix.h" +#endif + +/* The ML value describing a thread (heap-allocated) */ + +#define Ident(v) Field(v, 0) +#define Start_closure(v) Field(v, 1) +#define Terminated(v) Field(v, 2) + +/* The infos on threads (allocated via caml_stat_alloc()) */ + +struct caml_thread_struct { + + value descr; /* The heap-allocated descriptor (root) */ + struct caml_thread_struct * next; /* Doubly-linked list of running threads */ + struct caml_thread_struct * prev; + int domain_id; /* The id of the domain to which this thread belongs */ + struct stack_info* current_stack; /* saved Caml_state->current_stack */ + struct c_stack_link* c_stack; /* saved Caml_state->c_stack */ + /* Note: we do not save Caml_state->stack_cache, because it can + safely be shared between all threads on the same domain. */ + struct caml__roots_block *local_roots; /* saved value of local_roots */ + int backtrace_pos; /* saved value of Caml_state->backtrace_pos */ + backtrace_slot * backtrace_buffer; + /* saved value of Caml_state->backtrace_buffer */ + value backtrace_last_exn; + /* saved value of Caml_state->backtrace_last_exn (root) */ + value * gc_regs; /* saved value of Caml_state->gc_regs */ + value * gc_regs_buckets; /* saved value of Caml_state->gc_regs_buckets */ + void * exn_handler; /* saved value of Caml_state->exn_handler */ + +#ifndef NATIVE_CODE + intnat trap_sp_off; /* saved value of Caml_state->trap_sp_off */ + intnat trap_barrier_off; /* saved value of Caml_state->trap_barrier_off */ + struct caml_exception_context* external_raise; + /* saved value of Caml_state->external_raise */ +#endif + +#ifdef POSIX_SIGNALS + sigset_t init_mask; +#endif +}; + +typedef struct caml_thread_struct* caml_thread_t; + +/* Thread-local key for accessing the current thread's [caml_thread_t] */ +st_tlskey caml_thread_key; + +#define This_thread ((caml_thread_t) st_tls_get(caml_thread_key)) + +/* overall table for threads across domains */ +struct caml_thread_table { + caml_thread_t active_thread; + st_masterlock thread_lock; + int tick_thread_running; + st_thread_id tick_thread_id; +}; + +/* thread_table instance, up to Max_domains */ +static struct caml_thread_table thread_table[Max_domains]; + +#define Thread_lock(dom_id) &thread_table[dom_id].thread_lock + +static void thread_lock_acquire(int dom_id) +{ + st_masterlock_acquire(Thread_lock(dom_id)); +} + +static void thread_lock_release(int dom_id) +{ + st_masterlock_release(Thread_lock(dom_id)); +} + +/* The remaining fields are accessed while holding the domain lock */ + +/* The descriptor for the currently executing thread for this domain; + also the head of a circular list of thread descriptors for this + domain. Invariant: at every safe point, either Active_thread is + NULL, or Caml_state is setup for Active_thread. */ +#define Active_thread thread_table[Caml_state->id].active_thread + +/* Whether the "tick" thread is already running for this domain */ +#define Tick_thread_running thread_table[Caml_state->id].tick_thread_running + +/* The thread identifier of the "tick" thread for this domain */ +#define Tick_thread_id thread_table[Caml_state->id].tick_thread_id + +/* Identifier for next thread creation */ +static atomic_uintnat thread_next_id = 0; + +/* Forward declarations */ +static value caml_threadstatus_new (void); +static void caml_threadstatus_terminate (value); +static st_retcode caml_threadstatus_wait (value); + +/* Hook for scanning the stacks of the other threads */ + +static scan_roots_hook prev_scan_roots_hook; + +static void caml_thread_scan_roots( + scanning_action action, scanning_action_flags fflags, void *fdata, + caml_domain_state *domain_state) +{ + caml_thread_t th; + + th = Active_thread; + + /* GC could be triggered before [Active_thread] is initialized */ + if (th != NULL) { + do { + (*action)(fdata, th->descr, &th->descr); + (*action)(fdata, th->backtrace_last_exn, &th->backtrace_last_exn); + if (th != Active_thread) { + if (th->current_stack != NULL) + caml_do_local_roots(action, fflags, fdata, + th->local_roots, th->current_stack, th->gc_regs); + } + th = th->next; + } while (th != Active_thread); + + }; + + if (prev_scan_roots_hook != NULL) + (*prev_scan_roots_hook)(action, fflags, fdata, domain_state); + + return; +} + +static void save_runtime_state(void) +{ + CAMLassert(This_thread != NULL); + caml_thread_t this_thread = This_thread; + this_thread->current_stack = Caml_state->current_stack; + this_thread->c_stack = Caml_state->c_stack; + this_thread->gc_regs = Caml_state->gc_regs; + this_thread->gc_regs_buckets = Caml_state->gc_regs_buckets; + this_thread->exn_handler = Caml_state->exn_handler; + this_thread->local_roots = Caml_state->local_roots; + this_thread->backtrace_pos = Caml_state->backtrace_pos; + this_thread->backtrace_buffer = Caml_state->backtrace_buffer; + this_thread->backtrace_last_exn = Caml_state->backtrace_last_exn; +#ifndef NATIVE_CODE + this_thread->trap_sp_off = Caml_state->trap_sp_off; + this_thread->trap_barrier_off = Caml_state->trap_barrier_off; + this_thread->external_raise = Caml_state->external_raise; +#endif +} + +static void restore_runtime_state(caml_thread_t th) +{ + CAMLassert(th != NULL); + Active_thread = th; + Caml_state->current_stack = th->current_stack; + Caml_state->c_stack = th->c_stack; + Caml_state->gc_regs = th->gc_regs; + Caml_state->gc_regs_buckets = th->gc_regs_buckets; + Caml_state->exn_handler = th->exn_handler; + Caml_state->local_roots = th->local_roots; + Caml_state->backtrace_pos = th->backtrace_pos; + Caml_state->backtrace_buffer = th->backtrace_buffer; + Caml_state->backtrace_last_exn = th->backtrace_last_exn; +#ifndef NATIVE_CODE + Caml_state->trap_sp_off = th->trap_sp_off; + Caml_state->trap_barrier_off = th->trap_barrier_off; + Caml_state->external_raise = th->external_raise; +#endif +} + +CAMLprim value caml_thread_cleanup(value unit); + +static void reset_active(void) +{ + Active_thread = NULL; + /* If no other OCaml thread remains, ask the tick thread to stop + so that it does not prevent the whole process from exiting (#9971) */ + caml_thread_cleanup(Val_unit); +} + +/* Hooks for caml_enter_blocking_section and caml_leave_blocking_section */ + +static void caml_thread_enter_blocking_section(void) +{ + /* Save the current runtime state in the thread descriptor + of the current thread */ + save_runtime_state(); + /* Tell other threads that the runtime is free */ + thread_lock_release(Caml_state->id); +} + +static void caml_thread_leave_blocking_section(void) +{ + caml_thread_t th = This_thread; + /* Wait until the runtime is free */ + thread_lock_acquire(th->domain_id); + /* Update Active_thread to point to the thread descriptor + corresponding to the thread currently executing and restore the + runtime state */ + restore_runtime_state(th); +} + +/* Create and setup a new thread info block. + This block has no associated thread descriptor and + is not inserted in the list of threads. */ + +static caml_thread_t caml_thread_new_info(void) +{ + caml_thread_t th; + caml_domain_state *domain_state; + uintnat stack_wsize = caml_get_init_stack_wsize(); + + domain_state = Caml_state; + th = NULL; + th = (caml_thread_t)caml_stat_alloc_noexc(sizeof(struct caml_thread_struct)); + if (th == NULL) return NULL; + th->descr = Val_unit; + th->next = NULL; + th->prev = NULL; + th->domain_id = domain_state->id; + th->current_stack = caml_alloc_main_stack(stack_wsize); + if (th->current_stack == NULL) { + caml_stat_free(th); + return NULL; + } + th->c_stack = NULL; + th->local_roots = NULL; + th->backtrace_pos = 0; + th->backtrace_buffer = NULL; + th->backtrace_last_exn = Val_unit; + th->gc_regs = NULL; + th->gc_regs_buckets = NULL; + th->exn_handler = NULL; + +#ifndef NATIVE_CODE + th->trap_sp_off = 1; + th->trap_barrier_off = 2; + th->external_raise = NULL; +#endif + + return th; +} + +/* Free the resources held by a thread. */ +void caml_thread_free_info(caml_thread_t th) +{ + /* the following fields do not need any specific cleanup: + descr: heap-allocated + c_stack: stack-allocated + local_roots: stack-allocated + backtrace_last_exn: heap-allocated + gc_regs: + must be empty for a terminated thread + (we assume that the C call stack must be empty at + thread-termination point, so there are no gc_regs buckets in + use in this variable nor on the stack) + exn_handler: stack-allocated + external_raise: stack-allocated + init_mask: stack-allocated + */ + caml_free_stack(th->current_stack); + caml_free_backtrace_buffer(th->backtrace_buffer); + + /* Remark: we could share gc_regs_buckets between threads on a same + domain, but this might break the invariant that it is always + non-empty at the point where we switch from OCaml to C, so we + would need to do something more complex when activating a thread + to restore this invariant. */ + caml_free_gc_regs_buckets(th->gc_regs_buckets); + + caml_stat_free(th); +} + +/* Allocate a thread descriptor block. */ + +static value caml_thread_new_descriptor(value clos) +{ + CAMLparam1(clos); + CAMLlocal1(mu); + value descr; + /* Create and initialize the termination semaphore */ + mu = caml_threadstatus_new(); + /* Create a descriptor for the new thread */ + descr = caml_alloc_3(0, Val_long(atomic_fetch_add(&thread_next_id, +1)), + clos, mu); + CAMLreturn(descr); +} + +/* Remove a thread info block from the list of threads + and free its resources. */ +static void caml_thread_remove_and_free(caml_thread_t th) +{ + if (th->next == th) + reset_active(); /* last OCaml thread exiting */ + else if (Active_thread == th) + restore_runtime_state(th->next); /* PR#5295 */ + th->next->prev = th->prev; + th->prev->next = th->next; + + caml_thread_free_info(th); + return; +} + +/* Reinitialize the thread machinery after a fork() (PR#4577) */ +/* TODO(engil): more work on the multicore fork machinery. */ + +static void caml_thread_reinitialize(void) +{ + caml_thread_t th, next; + + th = Active_thread->next; + while (th != Active_thread) { + next = th->next; + caml_thread_free_info(th); + th = next; + } + Active_thread->next = Active_thread; + Active_thread->prev = Active_thread; + + /* Within the child, the domain_lock needs to be reset and acquired. */ + caml_reset_domain_lock(); + caml_acquire_domain_lock(); + /* The master lock needs to be initialized again. This process will also be + the effective owner of the lock. So there is no need to run + st_masterlock_acquire (busy = 1) */ + st_masterlock *m = Thread_lock(Caml_state->id); + m->init = 0; /* force initialization */ + st_masterlock_init(m); +} + +CAMLprim value caml_thread_join(value th); + +/* This hook is run when a domain shuts down (see domains.c). + + When a domain shuts down, the state must be cleared to allow proper reuse of + the domain slot the next time a domain is started on this slot. If a program + is single-domain, we mimic OCaml 4's behavior and do not care about ongoing + thread: the program will exit. */ +static void caml_thread_domain_stop_hook(void) { + /* If the program runs multiple domains, we should not let systhreads to hang + around when a domain exit. If the domain is not the last one (and the last + one will always be domain 0) we force the domain to join on every thread + on its chain before wrapping up. */ + if (!caml_domain_alone()) { + + while (Active_thread->next != Active_thread) { + caml_thread_join(Active_thread->next->descr); + } + + /* another domain thread may be joining on this domain's descriptor */ + caml_threadstatus_terminate(Terminated(Active_thread->descr)); + /* Shut down the tick thread */ + reset_active(); + /* We free the thread info but not its resources: they are owned + by Caml_state at this point, and will be cleaned-up later. */ + caml_stat_free(This_thread); + }; +} + +static void caml_thread_domain_initialize_hook(void) +{ + + caml_thread_t new_thread; + + /* OS-specific initialization */ + st_initialize(); + + st_masterlock_init(Thread_lock(Caml_state->id)); + + new_thread = + (caml_thread_t) caml_stat_alloc(sizeof(struct caml_thread_struct)); + + new_thread->domain_id = Caml_state->id; + new_thread->descr = caml_thread_new_descriptor(Val_unit); + new_thread->next = new_thread; + new_thread->prev = new_thread; + new_thread->backtrace_last_exn = Val_unit; + + st_tls_set(caml_thread_key, new_thread); + + Active_thread = new_thread; + +} + +CAMLprim value caml_thread_yield(value unit); + +void caml_thread_interrupt_hook(void) +{ + /* Do not attempt to yield from the backup thread */ + if (caml_bt_is_self()) return; + + uintnat is_on = 1; + atomic_uintnat* req_external_interrupt = + &Caml_state->requested_external_interrupt; + + if (atomic_compare_exchange_strong(req_external_interrupt, &is_on, 0)) { + caml_thread_yield(Val_unit); + } + + return; +} + +/* [caml_thread_initialize] initialises the systhreads infrastructure. This + function first sets up the chain for systhreads on this domain, then setup + the global variables and hooks for systhreads to cooperate with the runtime + system. */ +CAMLprim value caml_thread_initialize(value unit) +{ + /* Protect against repeated initialization (PR#3532) */ + if (Active_thread != NULL) return Val_unit; + + if (!caml_domain_alone()) + caml_failwith("caml_thread_initialize: cannot initialize Thread " + "while several domains are running."); + + /* Initialize the key to the [caml_thread_t] structure */ + st_tls_newkey(&caml_thread_key); + + /* First initialise the systhread chain on this domain */ + caml_thread_domain_initialize_hook(); + + prev_scan_roots_hook = atomic_exchange(&caml_scan_roots_hook, + caml_thread_scan_roots); + caml_enter_blocking_section_hook = caml_thread_enter_blocking_section; + caml_leave_blocking_section_hook = caml_thread_leave_blocking_section; + caml_domain_external_interrupt_hook = caml_thread_interrupt_hook; + caml_domain_initialize_hook = caml_thread_domain_initialize_hook; + caml_domain_stop_hook = caml_thread_domain_stop_hook; + + caml_atfork_hook = caml_thread_reinitialize; + + return Val_unit; +} + +CAMLprim value caml_thread_cleanup(value unit) +{ + if (Tick_thread_running){ + atomic_store_release(&Tick_thread_stop, 1); + st_thread_join(Tick_thread_id); + atomic_store_release(&Tick_thread_stop, 0); + Tick_thread_running = 0; + } + + return Val_unit; +} + +static void caml_thread_stop(void) +{ + /* PR#5188, PR#7220: some of the global runtime state may have + changed as the thread was running, so we save it in the + This_thread data to make sure that the cleanup logic + below uses accurate information. */ + save_runtime_state(); + + /* The main domain thread does not go through [caml_thread_stop]. There is + always one more thread in the chain at this point in time. */ + CAMLassert(Active_thread->next != Active_thread); + + caml_threadstatus_terminate(Terminated(Active_thread->descr)); + + /* The following also sets Active_thread to a sane value in case the + backup thread does a GC before the domain lock is acquired + again. */ + caml_thread_remove_and_free(Active_thread); + thread_lock_release(Caml_state->id); +} + +/* Create a thread */ + +/* the thread lock is not held when entering */ +static void * caml_thread_start(void * v) +{ + caml_thread_t th = (caml_thread_t) v; + int dom_id = th->domain_id; + value clos; + void * signal_stack; + + caml_init_domain_self(dom_id); + + st_tls_set(caml_thread_key, th); + + thread_lock_acquire(dom_id); + restore_runtime_state(th); + signal_stack = caml_init_signal_stack(); + +#ifdef POSIX_SIGNALS + /* restore the signal mask from the spawning thread, now it is safe for the + signal handler to run (as Caml_state is initialised) */ + pthread_sigmask(SIG_SETMASK, &th->init_mask, NULL); +#endif + + clos = Start_closure(Active_thread->descr); + caml_modify(&(Start_closure(Active_thread->descr)), Val_unit); + caml_callback_exn(clos, Val_unit); + caml_thread_stop(); + caml_free_signal_stack(signal_stack); + return 0; +} + +static int create_tick_thread(void) +{ + int err; +#ifdef POSIX_SIGNALS + sigset_t mask, old_mask; + + /* Block all signals so that we don't try to execute an OCaml signal + handler in the new tick thread */ + sigfillset(&mask); + pthread_sigmask(SIG_BLOCK, &mask, &old_mask); +#endif + + err = st_thread_create(&Tick_thread_id, caml_thread_tick, + (void *) &Caml_state->id); + +#ifdef POSIX_SIGNALS + pthread_sigmask(SIG_SETMASK, &old_mask, NULL); +#endif + + return err; +} + +CAMLprim value caml_thread_new(value clos) +{ + CAMLparam1(clos); + caml_thread_t th; + st_retcode err; +#ifdef POSIX_SIGNALS + sigset_t mask, old_mask; + + sigfillset(&mask); + pthread_sigmask(SIG_BLOCK, &mask, &old_mask); +#endif + +#ifndef NATIVE_CODE + if (caml_debugger_in_use) + caml_fatal_error("ocamldebug does not support multithreaded programs"); +#endif + /* Create a thread info block */ + th = caml_thread_new_info(); + + if (th == NULL) + caml_raise_out_of_memory(); + + th->descr = caml_thread_new_descriptor(clos); + +#ifdef POSIX_SIGNALS + th->init_mask = old_mask; +#endif + + th->next = Active_thread->next; + th->prev = Active_thread; + + Active_thread->next->prev = th; + Active_thread->next = th; + + err = st_thread_create(NULL, caml_thread_start, (void *) th); + +#ifdef POSIX_SIGNALS + /* regardless of error, return our sigmask to the original state */ + pthread_sigmask(SIG_SETMASK, &old_mask, NULL); +#endif + + if (err != 0) { + /* Creation failed, remove thread info block from list of threads */ + caml_thread_remove_and_free(th); + sync_check_error(err, "Thread.create"); + } + + if (! Tick_thread_running) { + err = create_tick_thread(); + sync_check_error(err, "Thread.create"); + Tick_thread_running = 1; + } + CAMLreturn(th->descr); +} + +/* Register a thread already created from C */ + +#define Dom_c_threads 0 + +/* the thread lock is not held when entering */ +CAMLexport int caml_c_thread_register(void) +{ + /* Already registered? */ + if (This_thread != NULL) return 0; + + CAMLassert(Caml_state_opt == NULL); + caml_init_domain_self(Dom_c_threads); + + /* Take master lock to protect access to the runtime */ + thread_lock_acquire(Dom_c_threads); + /* Create a thread info block */ + caml_thread_t th = caml_thread_new_info(); + /* If it fails, we release the lock and return an error. */ + if (th == NULL) { + thread_lock_release(Dom_c_threads); + return 0; + } + /* Add thread info block to the list of threads */ + if (Active_thread == NULL) { + th->next = th; + th->prev = th; + Active_thread = th; + } else { + th->next = Active_thread->next; + th->prev = Active_thread; + Active_thread->next->prev = th; + Active_thread->next = th; + } + /* Associate the thread descriptor with the thread */ + st_tls_set(caml_thread_key, (void *) th); + /* Allocate the thread descriptor on the heap */ + th->descr = caml_thread_new_descriptor(Val_unit); /* no closure */ + + if (! Tick_thread_running) { + st_retcode err = create_tick_thread(); + sync_check_error(err, "caml_register_c_thread"); + Tick_thread_running = 1; + } + + /* Release the master lock */ + thread_lock_release(Dom_c_threads); + return 1; +} + +/* Unregister a thread that was created from C and registered with + the function above */ + +/* the thread lock is not held when entering */ +CAMLexport int caml_c_thread_unregister(void) +{ + caml_thread_t th = This_thread; + + /* If this thread is not set, then it was not registered */ + if (th == NULL) return 0; + /* Wait until the runtime is available */ + thread_lock_acquire(Dom_c_threads); + /* Forget the thread descriptor */ + st_tls_set(caml_thread_key, NULL); + /* Remove thread info block from list of threads, and free it */ + caml_thread_remove_and_free(th); + /* Release the runtime */ + thread_lock_release(Dom_c_threads); + return 1; +} + +/* Return the current thread */ + +CAMLprim value caml_thread_self(value unit) +{ + return Active_thread->descr; +} + +/* Return the identifier of a thread */ + +CAMLprim value caml_thread_id(value th) +{ + return Ident(th); +} + +/* Print uncaught exception and backtrace */ + +CAMLprim value caml_thread_uncaught_exception(value exn) +{ + char * msg = caml_format_exception(exn); + fprintf(stderr, "Thread %d killed on uncaught exception %s\n", + Int_val(Ident(Active_thread->descr)), msg); + caml_stat_free(msg); + if (Caml_state->backtrace_active) caml_print_exception_backtrace(); + fflush(stderr); + return Val_unit; +} + +/* Allow re-scheduling */ + +CAMLprim value caml_thread_yield(value unit) +{ + st_masterlock *m = Thread_lock(Caml_state->id); + if (st_masterlock_waiters(m) == 0) + return Val_unit; + + /* Do all the parts of a blocking section enter/leave except lock + manipulation, which we'll do more efficiently in st_thread_yield. (Since + our blocking section doesn't contain anything interesting, don't bother + with saving errno.) + */ + + caml_raise_if_exception(caml_process_pending_signals_exn()); + save_runtime_state(); + st_thread_yield(m); + restore_runtime_state(This_thread); + caml_raise_if_exception(caml_process_pending_signals_exn()); + + return Val_unit; +} + +/* Suspend the current thread until another thread terminates */ + +CAMLprim value caml_thread_join(value th) +{ + st_retcode rc = caml_threadstatus_wait(Terminated(th)); + sync_check_error(rc, "Thread.join"); + return Val_unit; +} + +/* Thread status blocks */ + +#define Threadstatus_val(v) (* ((st_event *) Data_custom_val(v))) + +static void caml_threadstatus_finalize(value wrapper) +{ + st_event_destroy(Threadstatus_val(wrapper)); +} + +static int caml_threadstatus_compare(value wrapper1, value wrapper2) +{ + st_event ts1 = Threadstatus_val(wrapper1); + st_event ts2 = Threadstatus_val(wrapper2); + return ts1 == ts2 ? 0 : ts1 < ts2 ? -1 : 1; +} + +static struct custom_operations caml_threadstatus_ops = { + "_threadstatus", + caml_threadstatus_finalize, + caml_threadstatus_compare, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default, + custom_compare_ext_default, + custom_fixed_length_default +}; + +static value caml_threadstatus_new (void) +{ + st_event ts = NULL; /* suppress warning */ + value wrapper; + sync_check_error(st_event_create(&ts), "Thread.create"); + wrapper = caml_alloc_custom(&caml_threadstatus_ops, + sizeof(st_event *), + 0, 1); + Threadstatus_val(wrapper) = ts; + return wrapper; +} + +static void caml_threadstatus_terminate (value wrapper) +{ + st_event_trigger(Threadstatus_val(wrapper)); +} + +static st_retcode caml_threadstatus_wait (value wrapper) +{ + CAMLparam1(wrapper); /* prevent deallocation of ts */ + st_event ts = Threadstatus_val(wrapper); + st_retcode retcode; + + caml_enter_blocking_section(); + retcode = st_event_wait(ts); + caml_leave_blocking_section(); + + CAMLreturnT(st_retcode, retcode); +} diff --git a/ocaml/otherlibs/systhreads5/st_win32.h b/ocaml/otherlibs/systhreads5/st_win32.h new file mode 100644 index 00000000000..5092134db09 --- /dev/null +++ b/ocaml/otherlibs/systhreads5/st_win32.h @@ -0,0 +1,41 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ +/* */ +/* Copyright 2009 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +/* Win32 implementation of the "st" interface */ + +#undef _WIN32_WINNT +#define _WIN32_WINNT 0x0400 +#include + +Caml_inline void st_msleep(int msec) +{ + Sleep(msec); +} + +#include "st_pthreads.h" + +/* Signal handling -- none under Win32 */ + +value caml_thread_sigmask(value cmd, value sigs) +{ + caml_invalid_argument("Thread.sigmask not implemented"); + return Val_int(0); /* not reached */ +} + +value caml_wait_signal(value sigs) +{ + caml_invalid_argument("Thread.wait_signal not implemented"); + return Val_int(0); /* not reached */ +} diff --git a/ocaml/otherlibs/systhreads5/thread.ml b/ocaml/otherlibs/systhreads5/thread.ml new file mode 100644 index 00000000000..83cbb80ca83 --- /dev/null +++ b/ocaml/otherlibs/systhreads5/thread.ml @@ -0,0 +1,112 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* User-level threads *) + +type t + +external thread_initialize : unit -> unit = "caml_thread_initialize" +external thread_cleanup : unit -> unit = "caml_thread_cleanup" +external thread_new : (unit -> unit) -> t = "caml_thread_new" +external thread_uncaught_exception : exn -> unit = + "caml_thread_uncaught_exception" + +external yield : unit -> unit = "caml_thread_yield" +external self : unit -> t = "caml_thread_self" [@@noalloc] +external id : t -> int = "caml_thread_id" [@@noalloc] +external join : t -> unit = "caml_thread_join" + +(* For new, make sure the function passed to thread_new never + raises an exception. *) + +let[@inline never] check_memprof_cb () = ref () + +let default_uncaught_exception_handler = thread_uncaught_exception + +let uncaught_exception_handler = ref default_uncaught_exception_handler + +let set_uncaught_exception_handler fn = uncaught_exception_handler := fn + +exception Exit + +let create fn arg = + thread_new + (fun () -> + try + fn arg; + ignore (Sys.opaque_identity (check_memprof_cb ())) + with + | Exit -> + ignore (Sys.opaque_identity (check_memprof_cb ())) + | exn -> + let raw_backtrace = Printexc.get_raw_backtrace () in + flush stdout; flush stderr; + try + !uncaught_exception_handler exn + with + | Exit -> () + | exn' -> + Printf.eprintf + "Thread %d killed on uncaught exception %s\n" + (id (self ())) (Printexc.to_string exn); + Printexc.print_raw_backtrace stderr raw_backtrace; + Printf.eprintf + "Thread %d uncaught exception handler raised %s\n" + (id (self ())) (Printexc.to_string exn'); + Printexc.print_backtrace stdout; + flush stderr) + +let exit () = + raise Exit + +(* Preemption *) + +let preempt signal = yield() + +(* Initialization of the scheduler *) + +let preempt_signal = + match Sys.os_type with + | "Win32" -> Sys.sigterm + | _ -> Sys.sigvtalrm + +let () = + thread_initialize (); + Sys.set_signal preempt_signal (Sys.Signal_handle preempt); + (* Callback in [caml_shutdown], when the last domain exits. *) + Callback.register "Thread.at_shutdown" (fun () -> + thread_cleanup(); + (* In case of DLL-embedded OCaml the preempt_signal handler + will point to nowhere after DLL unloading and an accidental + preempt_signal will crash the main program. So restore the + default handler. *) + Sys.set_signal preempt_signal Sys.Signal_default + ) + +(* Wait functions *) + +let delay = Unix.sleepf + +let wait_timed_read fd d = + match Unix.select [fd] [] [] d with ([], _, _) -> false | (_, _, _) -> true +let wait_timed_write fd d = + match Unix.select [] [fd] [] d with (_, [], _) -> false | (_, _, _) -> true +let select = Unix.select + +let wait_pid p = Unix.waitpid [] p + +external sigmask : Unix.sigprocmask_command -> int list -> int list + = "caml_thread_sigmask" +external wait_signal : int list -> int = "caml_wait_signal" diff --git a/ocaml/otherlibs/systhreads5/thread.mli b/ocaml/otherlibs/systhreads5/thread.mli new file mode 100644 index 00000000000..b2cf78a5cdc --- /dev/null +++ b/ocaml/otherlibs/systhreads5/thread.mli @@ -0,0 +1,174 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* 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 Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Lightweight threads for Posix [1003.1c] and Win32. *) + +type t +(** The type of thread handles. *) + +(** {1 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 domain. + 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 the {!Thread.Exit} exception + or by raising any other uncaught exception. + In the last case, the uncaught 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. + + See also {!Domain.spawn} if you want parallel execution instead. + *) + +val self : unit -> t +(** Return the handle for 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. *) + +exception Exit +(** Exception raised by user code to initiate termination of the + current thread. + In a thread created by {!Thread.create} [funct] [arg], if the + {!Thread.Exit} exception reaches the top of the application + [funct arg], it has the effect of terminating the current thread + silently. In other contexts, there is no implicit handling of the + {!Thread.Exit} exception. *) + +val exit : unit -> unit +[@@ocaml.deprecated "Use 'raise Thread.Exit' instead."] +(** Raise the {!Thread.Exit} exception. + In a thread created by {!Thread.create}, this will cause the thread + to terminate prematurely, unless the thread function handles the + exception itself. {!Fun.protect} finalizers and catch-all + exception handlers will be executed. + + To make it clear that an exception is raised and will trigger + finalizers and catch-all exception handlers, it is recommended + to write [raise Thread.Exit] instead of [Thread.exit ()]. + + @before 5.0 A different implementation was used, not based on raising + an exception, and not running finalizers and catch-all handlers. + The previous implementation had a different behavior when called + outside of a thread created by {!Thread.create}. *) + +(** {1 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 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. *) + +(** {1 Waiting for file descriptors or processes} *) + +(** The functions below are leftovers from an earlier, VM-based threading + system. The {!Unix} module provides equivalent functionality, in + a more general and more standard-conformant manner. It is recommended + to use {!Unix} functions directly. *) + +val wait_timed_read : Unix.file_descr -> float -> bool +[@@ocaml.deprecated "Use Unix.select instead."] +(** See {!Thread.wait_timed_write}.*) + +val wait_timed_write : Unix.file_descr -> float -> bool +[@@ocaml.deprecated "Use Unix.select instead."] +(** Suspend the execution of the calling thread until at least + one character or EOF is available for reading ([wait_timed_read]) or + one character can be written without blocking ([wait_timed_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. + The same functionality can be achieved with {!Unix.select}. +*) + +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 +[@@ocaml.deprecated "Use Unix.select instead."] +(** Same function as {!Unix.select}. + Suspend the execution of the calling thread until input/output + becomes possible on the given Unix file descriptors. + The arguments and results have the same meaning as for + {!Unix.select}. *) + +val wait_pid : int -> int * Unix.process_status +[@@ocaml.deprecated "Use Unix.waitpid instead."] +(** Same function as {!Unix.waitpid}. + [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}. *) + +(** {1 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]. *) + +(** {1 Uncaught exceptions} *) + +val default_uncaught_exception_handler : exn -> unit +(** [Thread.default_uncaught_exception_handler] will print the thread's id, + exception and backtrace (if available). *) + +val set_uncaught_exception_handler : (exn -> unit) -> unit +(** [Thread.set_uncaught_exception_handler fn] registers [fn] as the handler + for uncaught exceptions. + + If the newly set uncaught exception handler raise an exception, + {!default_uncaught_exception_handler} will be called. *) diff --git a/ocaml/otherlibs/systhreads5/threads.h b/ocaml/otherlibs/systhreads5/threads.h new file mode 100644 index 00000000000..11da0471707 --- /dev/null +++ b/ocaml/otherlibs/systhreads5/threads.h @@ -0,0 +1,71 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, 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 Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_THREADS_H +#define CAML_THREADS_H + +#ifdef __cplusplus +extern "C" { +#endif + +CAMLextern void caml_enter_blocking_section (void); +CAMLextern void caml_leave_blocking_section (void); +#define caml_acquire_runtime_system caml_leave_blocking_section +#define caml_release_runtime_system caml_enter_blocking_section + +/* Manage the domain lock around the OCaml run-time system. + Only one thread at a time can execute OCaml compiled code or + OCaml run-time system functions within a domain. + + When OCaml calls a C function, the current thread holds the domain lock. + The C function can release it by calling + [caml_release_runtime_system]. Then, another thread can execute OCaml + code. However, the calling thread must not access any OCaml data, + nor call any runtime system function, nor call back into OCaml. + + Before returning to its OCaml caller, or accessing OCaml data, + or call runtime system functions, the current thread must + re-acquire the domain lock by calling [caml_acquire_runtime_system]. + + Symmetrically, if a C function (not called from OCaml) wishes to + call back into OCaml code, it should invoke [caml_acquire_runtime_system] + first, then do the callback, then invoke [caml_release_runtime_system]. + + For historical reasons, alternate names can be used: + [caml_enter_blocking_section] instead of [caml_release_runtime_system] + [caml_leave_blocking_section] instead of [caml_acquire_runtime_system] + Intuition: a ``blocking section'' is a piece of C code that does not + use the runtime system (typically, a blocking I/O operation). +*/ + +CAMLextern int caml_c_thread_register(void); +CAMLextern int caml_c_thread_unregister(void); + +/* If a thread is created by C code (instead of by OCaml itself), + it must be registered with the OCaml runtime system before + being able to call back into OCaml code or use other runtime system + functions. Just call [caml_c_thread_register] once. The domain lock + is not held when [caml_c_thread_register] returns. + Before the thread finishes, it must call [caml_c_thread_unregister] + (without holding the domain lock). + Both functions return 1 on success, 0 on error. + Note that threads registered by C code belong to the domain 0. +*/ + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_THREADS_H */ From 0cb1ca37583ac21f06ba0300f867abc16fa9c933 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 7 Nov 2023 14:16:54 +0000 Subject: [PATCH 04/10] Autogenerate otherlibs/dune to switch between systhreads implementations --- ocaml/.gitignore | 2 +- ocaml/Makefile.common-jst | 10 +++++++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/ocaml/.gitignore b/ocaml/.gitignore index cc1fc4428b3..cb0e4f7bec7 100644 --- a/ocaml/.gitignore +++ b/ocaml/.gitignore @@ -360,4 +360,4 @@ META /otherlibs/dynlink/natdynlinkops dune.runtime_selection - +/otherlibs/dune diff --git a/ocaml/Makefile.common-jst b/ocaml/Makefile.common-jst index 1c65adca01e..fe5ca7ae0fd 100644 --- a/ocaml/Makefile.common-jst +++ b/ocaml/Makefile.common-jst @@ -110,7 +110,15 @@ dune_config_targets = \ $(ocamldir)/duneconf/jst-extra.inc \ dune-project \ $(ocamldir)/stdlib/ocaml_compiler_internal_params \ - $(ocamldir)/dune.runtime_selection + $(ocamldir)/dune.runtime_selection \ + $(ocamldir)/otherlibs/dune + +$(ocamldir)/otherlibs/dune: + if [ "$(RUNTIME_DIR)" = "runtime4" ]; then \ + echo "(dirs (:standard \ systhreads))" > $@; \ + else \ + echo "(dirs (:standard \ systhreads4))" > $@; \ + fi $(ocamldir)/dune.runtime_selection: if [ "$(RUNTIME_DIR)" = "runtime4" ]; then \ From 52b6391ed67fe96ddd2ca8267399614330084e31 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 7 Nov 2023 14:18:27 +0000 Subject: [PATCH 05/10] Actually call systhreads5/ just systhreads/ --- ocaml/otherlibs/{systhreads5 => systhreads}/.depend | 0 ocaml/otherlibs/{systhreads5 => systhreads}/META.in | 0 ocaml/otherlibs/{systhreads5 => systhreads}/Makefile | 0 ocaml/otherlibs/{systhreads5 => systhreads}/event.ml | 0 ocaml/otherlibs/{systhreads5 => systhreads}/event.mli | 0 ocaml/otherlibs/{systhreads5 => systhreads}/st_posix.h | 0 ocaml/otherlibs/{systhreads5 => systhreads}/st_pthreads.h | 0 ocaml/otherlibs/{systhreads5 => systhreads}/st_stubs.c | 0 ocaml/otherlibs/{systhreads5 => systhreads}/st_win32.h | 0 ocaml/otherlibs/{systhreads5 => systhreads}/thread.ml | 0 ocaml/otherlibs/{systhreads5 => systhreads}/thread.mli | 0 ocaml/otherlibs/{systhreads5 => systhreads}/threads.h | 0 12 files changed, 0 insertions(+), 0 deletions(-) rename ocaml/otherlibs/{systhreads5 => systhreads}/.depend (100%) rename ocaml/otherlibs/{systhreads5 => systhreads}/META.in (100%) rename ocaml/otherlibs/{systhreads5 => systhreads}/Makefile (100%) rename ocaml/otherlibs/{systhreads5 => systhreads}/event.ml (100%) rename ocaml/otherlibs/{systhreads5 => systhreads}/event.mli (100%) rename ocaml/otherlibs/{systhreads5 => systhreads}/st_posix.h (100%) rename ocaml/otherlibs/{systhreads5 => systhreads}/st_pthreads.h (100%) rename ocaml/otherlibs/{systhreads5 => systhreads}/st_stubs.c (100%) rename ocaml/otherlibs/{systhreads5 => systhreads}/st_win32.h (100%) rename ocaml/otherlibs/{systhreads5 => systhreads}/thread.ml (100%) rename ocaml/otherlibs/{systhreads5 => systhreads}/thread.mli (100%) rename ocaml/otherlibs/{systhreads5 => systhreads}/threads.h (100%) diff --git a/ocaml/otherlibs/systhreads5/.depend b/ocaml/otherlibs/systhreads/.depend similarity index 100% rename from ocaml/otherlibs/systhreads5/.depend rename to ocaml/otherlibs/systhreads/.depend diff --git a/ocaml/otherlibs/systhreads5/META.in b/ocaml/otherlibs/systhreads/META.in similarity index 100% rename from ocaml/otherlibs/systhreads5/META.in rename to ocaml/otherlibs/systhreads/META.in diff --git a/ocaml/otherlibs/systhreads5/Makefile b/ocaml/otherlibs/systhreads/Makefile similarity index 100% rename from ocaml/otherlibs/systhreads5/Makefile rename to ocaml/otherlibs/systhreads/Makefile diff --git a/ocaml/otherlibs/systhreads5/event.ml b/ocaml/otherlibs/systhreads/event.ml similarity index 100% rename from ocaml/otherlibs/systhreads5/event.ml rename to ocaml/otherlibs/systhreads/event.ml diff --git a/ocaml/otherlibs/systhreads5/event.mli b/ocaml/otherlibs/systhreads/event.mli similarity index 100% rename from ocaml/otherlibs/systhreads5/event.mli rename to ocaml/otherlibs/systhreads/event.mli diff --git a/ocaml/otherlibs/systhreads5/st_posix.h b/ocaml/otherlibs/systhreads/st_posix.h similarity index 100% rename from ocaml/otherlibs/systhreads5/st_posix.h rename to ocaml/otherlibs/systhreads/st_posix.h diff --git a/ocaml/otherlibs/systhreads5/st_pthreads.h b/ocaml/otherlibs/systhreads/st_pthreads.h similarity index 100% rename from ocaml/otherlibs/systhreads5/st_pthreads.h rename to ocaml/otherlibs/systhreads/st_pthreads.h diff --git a/ocaml/otherlibs/systhreads5/st_stubs.c b/ocaml/otherlibs/systhreads/st_stubs.c similarity index 100% rename from ocaml/otherlibs/systhreads5/st_stubs.c rename to ocaml/otherlibs/systhreads/st_stubs.c diff --git a/ocaml/otherlibs/systhreads5/st_win32.h b/ocaml/otherlibs/systhreads/st_win32.h similarity index 100% rename from ocaml/otherlibs/systhreads5/st_win32.h rename to ocaml/otherlibs/systhreads/st_win32.h diff --git a/ocaml/otherlibs/systhreads5/thread.ml b/ocaml/otherlibs/systhreads/thread.ml similarity index 100% rename from ocaml/otherlibs/systhreads5/thread.ml rename to ocaml/otherlibs/systhreads/thread.ml diff --git a/ocaml/otherlibs/systhreads5/thread.mli b/ocaml/otherlibs/systhreads/thread.mli similarity index 100% rename from ocaml/otherlibs/systhreads5/thread.mli rename to ocaml/otherlibs/systhreads/thread.mli diff --git a/ocaml/otherlibs/systhreads5/threads.h b/ocaml/otherlibs/systhreads/threads.h similarity index 100% rename from ocaml/otherlibs/systhreads5/threads.h rename to ocaml/otherlibs/systhreads/threads.h From dc5a5962f4b3a5ad36ecbaffc24fff385f38620d Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 7 Nov 2023 14:19:41 +0000 Subject: [PATCH 06/10] Initial version of systhreads/dune --- ocaml/otherlibs/systhreads/dune | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 ocaml/otherlibs/systhreads/dune diff --git a/ocaml/otherlibs/systhreads/dune b/ocaml/otherlibs/systhreads/dune new file mode 100644 index 00000000000..68028fa05a6 --- /dev/null +++ b/ocaml/otherlibs/systhreads/dune @@ -0,0 +1,33 @@ +;************************************************************************** +;* * +;* OCaml * +;* * +;* Mark Shinwell, Jane Street Europe * +;* * +;* Copyright 2020 Jane Street Group LLC * +;* * +;* All rights reserved. This file is distributed under the terms of * +;* the GNU Lesser General Public License version 2.1, with the * +;* special exception on linking described in the file LICENSE. * +;* * +;************************************************************************** + +; For some reason the C header files aren't being found if this library +; is given a public name, so we do the installation manually. + +(install + (files + (byte/threads.cma as threads/threads.cma) + (native/threadsnat.cmxa as threads/threads.cmxa) + (native/threadsnat.a as threads/threads.a) + (byte/libthreads_stubs.a as libthreads_stubs.a) + (byte/dllthreads_stubs.so as stublibs/dllthreads_stubs.so) + (native/libthreadsnat_stubs.a as libthreadsnat_stubs.a) + (native/libthreadsnat_stubs.a as libthreadsnat_stubs_native.a) ; for special_dune compat + (thread.mli as threads/thread.mli) + (threads.h as caml/threads.h) + (native/.threadsnat.objs/native/thread.cmx as threads/thread.cmx) + (byte/.threads.objs/byte/thread.cmi as threads/thread.cmi) + (byte/.threads.objs/byte/thread.cmti as threads/thread.cmti)) + (section lib) + (package ocaml)) From a12aca59dc44ae7820e839d9a69eb8375819d020 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Wed, 8 Nov 2023 18:01:09 +0000 Subject: [PATCH 07/10] Fix upstream systhreads build --- ocaml/Makefile.common | 2 +- ocaml/Makefile.common-jst | 2 +- ocaml/configure | 12 +++++++++--- ocaml/configure.ac | 10 ++++++++-- ocaml/otherlibs/Makefile | 2 +- 5 files changed, 20 insertions(+), 8 deletions(-) diff --git a/ocaml/Makefile.common b/ocaml/Makefile.common index 5bec430b796..2855ef4b1a5 100644 --- a/ocaml/Makefile.common +++ b/ocaml/Makefile.common @@ -140,7 +140,7 @@ endif # ifeq "$(wildcard $(ROOTDIR)/flexlink.opt$(EXE))" "" endif # ifeq "$(BOOTSTRAPPING_FLEXDLL)" "false" # List of other libraries -ALL_OTHERLIBS = dynlink str systhreads unix runtime_events +ALL_OTHERLIBS = dynlink str systhreads$(RUNTIME_SUFFIX) unix runtime_events # Flags to pass to the C preprocessor when preprocessing assembly files OC_ASPPFLAGS=$(OC_CPPFLAGS) $(OC_NATIVE_CPPFLAGS) diff --git a/ocaml/Makefile.common-jst b/ocaml/Makefile.common-jst index fe5ca7ae0fd..7660136a16a 100644 --- a/ocaml/Makefile.common-jst +++ b/ocaml/Makefile.common-jst @@ -250,7 +250,7 @@ install_for_test: _install ln -s . lex; ln -s . yacc; \ ln -s _install/lib/ocaml/compiler-libs compilerlibs; \ mkdir -p otherlibs/{unix,dynlink/native,str,bigarray}; \ - ln -s ../stdlib/threads otherlibs/systhreads; \ + ln -s ../stdlib/threads otherlibs/systhreads$(RUNTIME_SUFFIX); \ $(cpl) stdlib/unix/{lib,}unix* otherlibs/unix; \ $(cpl) stdlib/dynlink/dynlink* otherlibs/dynlink; \ $(cpl) stdlib/str/{lib,}str* otherlibs/str; \ diff --git a/ocaml/configure b/ocaml/configure index c732c15a344..417f625592a 100755 --- a/ocaml/configure +++ b/ocaml/configure @@ -19285,6 +19285,12 @@ esac ## Activate the systhread library +if "$enable_runtime5" = "yes" ; then + runtime_suffix= +else + runtime_suffix=4 +fi + case $enable_systhreads,$enable_unix_lib in #( yes,no) : systhread_support=false @@ -19295,9 +19301,9 @@ case $enable_systhreads,$enable_unix_lib in #( printf "%s\n" "$as_me: the threads library is disabled" >&6;} ;; #( *) : systhread_support=true - ac_config_files="$ac_config_files otherlibs/systhreads/META" + ac_config_files="$ac_config_files otherlibs/systhreads${runtime_suffix}/META" - otherlibraries="$otherlibraries systhreads" + otherlibraries="$otherlibraries systhreads${runtime_suffix}" lib_systhreads=true { printf "%s\n" "$as_me:${as_lineno-$LINENO}: the threads library is supported" >&5 printf "%s\n" "$as_me: the threads library is supported" >&6;} ;; @@ -21257,7 +21263,7 @@ do "libtool") CONFIG_COMMANDS="$CONFIG_COMMANDS libtool" ;; "otherlibs/unix/META") CONFIG_FILES="$CONFIG_FILES otherlibs/unix/META" ;; "otherlibs/str/META") CONFIG_FILES="$CONFIG_FILES otherlibs/str/META" ;; - "otherlibs/systhreads/META") CONFIG_FILES="$CONFIG_FILES otherlibs/systhreads/META" ;; + "otherlibs/systhreads${runtime_suffix}/META") CONFIG_FILES="$CONFIG_FILES otherlibs/systhreads${runtime_suffix}/META" ;; "ocamldoc/META") CONFIG_FILES="$CONFIG_FILES ocamldoc/META" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; diff --git a/ocaml/configure.ac b/ocaml/configure.ac index d08b09731fc..dc232a042c6 100644 --- a/ocaml/configure.ac +++ b/ocaml/configure.ac @@ -2116,6 +2116,12 @@ AS_CASE([$host], ## Activate the systhread library +if [ "$enable_runtime5" = "yes" ]; then + runtime_suffix= +else + runtime_suffix=4 +fi + AS_CASE([$enable_systhreads,$enable_unix_lib], [yes,no], [systhread_support=false @@ -2124,8 +2130,8 @@ AS_CASE([$enable_systhreads,$enable_unix_lib], [systhread_support=false AC_MSG_NOTICE([the threads library is disabled])], [systhread_support=true - AC_CONFIG_FILES([otherlibs/systhreads/META]) - otherlibraries="$otherlibraries systhreads" + AC_CONFIG_FILES([otherlibs/systhreads${runtime_suffix}/META]) + otherlibraries="$otherlibraries systhreads${runtime_suffix}" lib_systhreads=true AC_MSG_NOTICE([the threads library is supported])]) diff --git a/ocaml/otherlibs/Makefile b/ocaml/otherlibs/Makefile index 5fe2d750cdf..8c8d34f8db5 100644 --- a/ocaml/otherlibs/Makefile +++ b/ocaml/otherlibs/Makefile @@ -21,7 +21,7 @@ include $(ROOTDIR)/Makefile.common # at the moment, the clean targets depend on this variable but # when they are invoked ../Makefile.config is not included, so that # OTHERLIBRARIES would be empty and the clean targets would thus not work. -OTHERLIBRARIES ?= dynlink str systhreads unix runtime_events +OTHERLIBRARIES ?= dynlink str systhreads$(RUNTIME_SUFFIX) unix runtime_events # $1: target name to dispatch to all otherlibs/*/Makefile define dispatch_ From 01ccb1be35d20a71360c0d11c43cdeaf8534ac0b Mon Sep 17 00:00:00 2001 From: Max Slater Date: Wed, 8 Nov 2023 14:40:24 -0500 Subject: [PATCH 08/10] fix builds --- ocaml/Makefile.common-jst | 2 +- ocaml/configure | 8 +++++--- ocaml/configure.ac | 3 +++ ocaml/ocamltest/ocaml_modifiers.ml | 2 +- ocaml/ocamltest/ocamltest_config.ml.in | 2 ++ ocaml/ocamltest/ocamltest_config.mli | 3 +++ 6 files changed, 15 insertions(+), 5 deletions(-) diff --git a/ocaml/Makefile.common-jst b/ocaml/Makefile.common-jst index 7660136a16a..fe5ca7ae0fd 100644 --- a/ocaml/Makefile.common-jst +++ b/ocaml/Makefile.common-jst @@ -250,7 +250,7 @@ install_for_test: _install ln -s . lex; ln -s . yacc; \ ln -s _install/lib/ocaml/compiler-libs compilerlibs; \ mkdir -p otherlibs/{unix,dynlink/native,str,bigarray}; \ - ln -s ../stdlib/threads otherlibs/systhreads$(RUNTIME_SUFFIX); \ + ln -s ../stdlib/threads otherlibs/systhreads; \ $(cpl) stdlib/unix/{lib,}unix* otherlibs/unix; \ $(cpl) stdlib/dynlink/dynlink* otherlibs/dynlink; \ $(cpl) stdlib/str/{lib,}str* otherlibs/str; \ diff --git a/ocaml/configure b/ocaml/configure index 417f625592a..a5be15bb4cb 100755 --- a/ocaml/configure +++ b/ocaml/configure @@ -784,6 +784,7 @@ ocamltest_libunix ocamltest_CPP lib_unix lib_systhreads +lib_systhreads_path lib_str lib_runtime_events lib_dynlink @@ -3214,6 +3215,7 @@ flexdll_dir= lib_dynlink=false lib_str=false lib_systhreads=false +lib_systhreads_path="" lib_unix=false ocamltest_libunix=None ocamltest_unix_impl="dummy" @@ -19305,6 +19307,7 @@ printf "%s\n" "$as_me: the threads library is disabled" >&6;} ;; #( otherlibraries="$otherlibraries systhreads${runtime_suffix}" lib_systhreads=true + lib_systhreads_path="systhreads${runtime_suffix}" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: the threads library is supported" >&5 printf "%s\n" "$as_me: the threads library is supported" >&6;} ;; esac @@ -21263,7 +21266,8 @@ do "libtool") CONFIG_COMMANDS="$CONFIG_COMMANDS libtool" ;; "otherlibs/unix/META") CONFIG_FILES="$CONFIG_FILES otherlibs/unix/META" ;; "otherlibs/str/META") CONFIG_FILES="$CONFIG_FILES otherlibs/str/META" ;; - "otherlibs/systhreads${runtime_suffix}/META") CONFIG_FILES="$CONFIG_FILES otherlibs/systhreads${runtime_suffix}/META" ;; + "otherlibs/systhreads/META") CONFIG_FILES="$CONFIG_FILES otherlibs/systhreads/META" ;; + "otherlibs/systhreads4/META") CONFIG_FILES="$CONFIG_FILES otherlibs/systhreads4/META" ;; "ocamldoc/META") CONFIG_FILES="$CONFIG_FILES ocamldoc/META" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; @@ -22400,5 +22404,3 @@ if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi - - diff --git a/ocaml/configure.ac b/ocaml/configure.ac index dc232a042c6..223533e3cca 100644 --- a/ocaml/configure.ac +++ b/ocaml/configure.ac @@ -69,6 +69,7 @@ flexdll_dir= lib_dynlink=false lib_str=false lib_systhreads=false +lib_systhreads_path="" lib_unix=false ocamltest_libunix=None ocamltest_unix_impl="dummy" @@ -170,6 +171,7 @@ AC_SUBST([lib_dynlink]) AC_SUBST([lib_runtime_events]) AC_SUBST([lib_str]) AC_SUBST([lib_systhreads]) +AC_SUBST([lib_systhreads_path]) AC_SUBST([lib_unix]) AC_SUBST([ocamltest_CPP]) AC_SUBST([ocamltest_libunix]) @@ -2133,6 +2135,7 @@ AS_CASE([$enable_systhreads,$enable_unix_lib], AC_CONFIG_FILES([otherlibs/systhreads${runtime_suffix}/META]) otherlibraries="$otherlibraries systhreads${runtime_suffix}" lib_systhreads=true + lib_systhreads_path="systhreads${runtime_suffix}" AC_MSG_NOTICE([the threads library is supported])]) ## Does the assembler support debug prefix map and CFI directives diff --git a/ocaml/ocamltest/ocaml_modifiers.ml b/ocaml/ocamltest/ocaml_modifiers.ml index af4ebc0684c..b3f20b72b8d 100644 --- a/ocaml/ocamltest/ocaml_modifiers.ml +++ b/ocaml/ocamltest/ocaml_modifiers.ml @@ -96,7 +96,7 @@ let str = make_library_modifier let systhreads = unix @ (make_library_modifier - "threads" [compiler_subdir ["otherlibs"; "systhreads"]]) + "threads" [compiler_subdir ["otherlibs"; Ocamltest_config.systhreads_path]]) let runtime_events = make_library_modifier diff --git a/ocaml/ocamltest/ocamltest_config.ml.in b/ocaml/ocamltest/ocamltest_config.ml.in index 47b890edc54..d414d227ab1 100644 --- a/ocaml/ocamltest/ocamltest_config.ml.in +++ b/ocaml/ocamltest/ocamltest_config.ml.in @@ -38,6 +38,8 @@ let libunix = @ocamltest_libunix@ let systhreads = @lib_systhreads@ +let systhreads_path = {@QS@|@lib_systhreads_path@|@QS@} + let str = @lib_str@ let objext = {@QS@|@OBJEXT@|@QS@} diff --git a/ocaml/ocamltest/ocamltest_config.mli b/ocaml/ocamltest/ocamltest_config.mli index 1643a8163e4..54bf3d43c7f 100644 --- a/ocaml/ocamltest/ocamltest_config.mli +++ b/ocaml/ocamltest/ocamltest_config.mli @@ -49,6 +49,9 @@ val libunix : bool option val systhreads : bool (** Indicates whether systhreads is available. *) +val systhreads_path : string +(** Indicates where the systhreads library is installed under otherlibs/. *) + val str : bool (** Indicates whether str is available. *) From 1aee22d99128b971aed4fd4c185bee06e0543b94 Mon Sep 17 00:00:00 2001 From: Max Slater Date: Wed, 8 Nov 2023 15:03:52 -0500 Subject: [PATCH 09/10] now it needs suffix for setup --- ocaml/Makefile.common-jst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/Makefile.common-jst b/ocaml/Makefile.common-jst index fe5ca7ae0fd..7660136a16a 100644 --- a/ocaml/Makefile.common-jst +++ b/ocaml/Makefile.common-jst @@ -250,7 +250,7 @@ install_for_test: _install ln -s . lex; ln -s . yacc; \ ln -s _install/lib/ocaml/compiler-libs compilerlibs; \ mkdir -p otherlibs/{unix,dynlink/native,str,bigarray}; \ - ln -s ../stdlib/threads otherlibs/systhreads; \ + ln -s ../stdlib/threads otherlibs/systhreads$(RUNTIME_SUFFIX); \ $(cpl) stdlib/unix/{lib,}unix* otherlibs/unix; \ $(cpl) stdlib/dynlink/dynlink* otherlibs/dynlink; \ $(cpl) stdlib/str/{lib,}str* otherlibs/str; \ From 548d18ba8cf98fe7ebf18fdbc6d9a809eea0a409 Mon Sep 17 00:00:00 2001 From: Max Slater Date: Wed, 8 Nov 2023 15:29:09 -0500 Subject: [PATCH 10/10] fix unquoted yes --- ocaml/configure | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/configure b/ocaml/configure index a5be15bb4cb..ac8a7156c27 100755 --- a/ocaml/configure +++ b/ocaml/configure @@ -19287,7 +19287,7 @@ esac ## Activate the systhread library -if "$enable_runtime5" = "yes" ; then +if [ "$enable_runtime5" = "yes" ]; then runtime_suffix= else runtime_suffix=4