[m-rev.] for review: make the deep profiler work again
Zoltan Somogyi
zs at cs.mu.OZ.AU
Thu Nov 14 10:27:49 AEDT 2002
For review by Fergus. Changes to the installation procedures for the deep
profiler will come later.
Zoltan.
Make the deep profiler work again.
The existing process structure of the deep profiler made it very hard to debug,
mainly because the Mercury debugger is confused by forks and stymied by execs.
This change completely replaces the process structure. The old structure had
two separate programs, mdprof_cgi and mdprof_server, the first always acting
as client and the second always acting as server. The new structure has only
one program, mdprof_cgi, which acts as a server if there is no existing server
for the relevant profiling data file, and as a client otherwise.
Although mdprof_cgi normally forks when it becomes a server to let the parent
exit and let the web server know that the web page it has generated is
complete, the fork can be disabled for debugging via an option. This allows
the communication between client and server to be debugged by running two
instances of mdprof_cgi in different windows, one or both under mdb.
deep_profiler/DESIGN:
New file describing the new process structure, its race conditions,
and their solutions.
deep_profiler/.nocopyright:
Add DESIGN.
deep_profiler/mdprof_cgi.m:
A complete rewrite of this module to enable it act as both client and
server.
deep_profiler/mdprof_test.m:
A new module to hold the testing functionality of mdprof_server.m.
deep_profiler/mdprof_server.m:
deep_profiler/server.m:
Delete these now unnecessary modules.
Mmakefile:
Replace references to mdprof_server with references to mdprof_test.
deep_profiler/Mmakefile:
Replace references to mdprof_server with references to mdprof_test.
Move the include of Mmake.deep.params, to allow it to override
top level parameter settings.
deep_profiler/Mercury.options:
Work around a compiler bug by turning off the offending optimization.
deep_profiler/timeout.m:
A rewrite of major parts of this module to support the new design
of mdprof_cgi.m, and to make unexpected signals easier to debug.
deep_profiler/interface.m:
Implement the mechanisms needed by the new process structure.
Change the characters we use to separate components of the URL.
The old ones were special to the shell, and screwed up command lines.
(As double insurance, we ignore the command line anyway when invoked
by the web server.)
Change some names to be more expressive.
deep_profiler/conf.m:
Add a new function, getpid, for use by interface.m.
Rewrite some code to use streams explicitly, not implicitly.
deep_profiler/callgraph.m:
deep_profiler/cliques.m:
Add (now commented out) code to help debug these modules, for use
in cases where mdb doesn't help, because the program works perfectly
with debugging enabled :-(
deep_profiler/query.m:
Move the predicate try_exec here from the deleted file server.m.
deep_profiler/html_format.m:
Trivial change to conform to name change in interface.m.
deep_profiler/startup.m:
Generate debugging output to a caller specified stream, not to
stdout and stderr.
Disable the generation of statistics temporarily, since the diff
to make statistics reporting routines write to a specified stream
instead of stdout and stderr won't be committed on the release branch.
Currently, they always write to stdout, which in the new design
goes to the web page, not to the startup file.
configure.in:
Detect the presence of opendir, readdir and closedir, and the header
file they need, dirent.h. Enable the deep profiler only if all exist,
since the deep profiler now needs them.
runtime/mercury_conf.h.in:
Support the changes to configure.in.
runtime/mercury_misc.[ch]:
Add a mechanism for registering cleanup functions to be executed when
we terminate the program due to an uncaught exception.
library/exception.m:
Invoke the registered cleanup functions just before terminating
the program due to an uncaught exception.
cvs diff: Diffing .
Index: Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/Mmakefile,v
retrieving revision 1.92
diff -u -b -r1.92 Mmakefile
--- Mmakefile 1 Nov 2002 07:10:15 -0000 1.92
+++ Mmakefile 12 Nov 2002 14:43:13 -0000
@@ -84,7 +84,7 @@
.PHONY: dep_deep_profiler
ifeq ("$(ENABLE_DEEP_PROFILER)","yes")
dep_deep_profiler: deep_profiler/$(deps_subdir)mdprof_cgi.dep \
- deep_profiler/$(deps_subdir)mdprof_server.dep
+ deep_profiler/$(deps_subdir)mdprof_test.dep
else
dep_deep_profiler:
endif
@@ -92,8 +92,8 @@
deep_profiler/$(deps_subdir)mdprof_cgi.dep: library/$(deps_subdir)mer_std.dep
+cd deep_profiler && $(SUBDIR_MMAKE) mdprof_cgi.depend
-deep_profiler/$(deps_subdir)mdprof_server.dep: library/$(deps_subdir)mer_std.dep
- +cd deep_profiler && $(SUBDIR_MMAKE) mdprof_server.depend
+deep_profiler/$(deps_subdir)mdprof_test.dep: library/$(deps_subdir)mer_std.dep
+ +cd deep_profiler && $(SUBDIR_MMAKE) mdprof_test.depend
# depend_library MUST be done before depend_compiler and depend_profiler
Index: configure.in
===================================================================
RCS file: /home/mercury1/repository/mercury/configure.in,v
retrieving revision 1.338
diff -u -b -r1.338 configure.in
--- configure.in 7 Nov 2002 16:12:19 -0000 1.338
+++ configure.in 12 Nov 2002 02:58:51 -0000
@@ -524,14 +524,14 @@
open close dup dup2 fdopen fileno fstat stat isatty \
getpid setpgid fork execlp wait kill \
grantpt unlockpt ptsname tcgetattr tcsetattr ioctl \
- access sleep
+ access sleep opendir readdir closedir
#-----------------------------------------------------------------------------#
MERCURY_CHECK_FOR_HEADERS( \
unistd.h sys/wait.h sys/siginfo.h sys/signal.h ucontext.h \
asm/sigcontext.h sys/param.h sys/time.h sys/times.h \
sys/types.h sys/stat.h fcntl.h termios.h sys/ioctl.h \
- sys/stropts.h windows.h)
+ sys/stropts.h windows.h dirent.h)
if test "$MR_HAVE_UCONTEXT_H" != 1; then
MERCURY_CHECK_FOR_HEADERS(sys/ucontext.h)
@@ -1831,7 +1831,13 @@
# Currently it only distinguishes between systems which have
# unistd.h or not, but at a later date we may also need to test for
# other posix features.
-if test "$MR_HAVE_UNISTD_H" = 1; then
+if test "$MR_HAVE_UNISTD_H" = 1 && \
+ test "$MR_HAVE_DIRENT_H" = 1 && \
+ test "$ac_cv_func_getpid" = yes && \
+ test "$ac_cv_func_opendir" = yes && \
+ test "$ac_cv_func_readdir" = yes && \
+ test "$ac_cv_func_closedir" = yes
+then
mercury_cv_can_enable_deep_profiler=yes
else
mercury_cv_can_enable_deep_profiler=no
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing deep_profiler
Index: deep_profiler/.nocopyright
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/.nocopyright,v
retrieving revision 1.3
diff -u -b -r1.3 .nocopyright
--- deep_profiler/.nocopyright 18 Jul 2001 08:21:34 -0000 1.3
+++ deep_profiler/.nocopyright 11 Nov 2002 01:08:26 -0000
@@ -1 +1,2 @@
.cvsignore
+DESIGN
Index: deep_profiler/DESIGN
===================================================================
RCS file: deep_profiler/DESIGN
diff -N deep_profiler/DESIGN
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ deep_profiler/DESIGN 11 Nov 2002 05:39:50 -0000
@@ -0,0 +1,125 @@
+This file describes, explains and justifies the changes made in the design
+of the deep profiler since the deep profiler paper.
+
+The mdprof_cgi program is the core of the deep profiler. Every web page the
+user looks at in a profile viewing session is generated by a separate
+invocation of mdprof_cgi. We don't have a choice about this; the design
+of the CGI interface to web servers dictates this mode of operation.
+The CGI interface also requires each invocation of mdprof_cgi to exit
+when it finishes generating a web page; the web server doesn't know
+that the web page is complete until the program generating it exits.
+
+Unfortunately, reading and processing a deep profiling data file takes a
+significant amount of time, so we don't want to reread the profiling data file
+on every query. The solution we have adopted has mdprof_cgi sometimes
+forking into two processes after it has generated a web page. The original
+process (the parent) exits, to allow the web browser to display the generated
+page. The child process sticks around as a server, processing queries from
+later invocations of mdprof_cgi that specify the same profiling data file.
+This server process communicates with these later invocations through a pair
+of named pipes, whose names include the name of the profiling data file
+(in a mangled form which translates /s to other characters).
+
+This design has an inherent race condition when two mdprof_cgi processes
+are created close together in time, they specify the same profiling data file,
+and no server process for that data file exists. (If they specify different
+profiling data files, then they are handled independently; if there is already
+a server process for that data file, they will both send their queries to it.)
+The problem is that the two processes compete to become the server.
+
+The solution we adopt is to create a critical section, a piece of code that can
+be executed by only one mdprof_cgi process at a time. To be maximally portable,
+we use the `open' system call with the O_CREAT and O_EXCL flags, which make
+the open call fail if the file we want to create already exists. Since the rate
+at which we get new CGI requests is limited by human typing and/or clicking
+speed, we can tolerate the overhead of this method of gaining mutual exclusion.
+Releasing the mutual exclusion involves simply removing the lock file.
+
+The code in the critical section includes both checking for the prior existence
+of a server (which consists of checking for the existence of the two named
+pipes) and, in the absence of an existing server process, the creation of the
+named pipes and the commitment to become the server behind those pipes.
+This solves the race condition described above: whichever mdprof_cgi process
+gains entry to the critical section first will become the server, and all other
+mdprof_cgi processes will send their queries to it (i.e. they will become
+clients of the server).
+
+Of course, we don't want server processes to live and thus consume resources
+forever. The server process therefore has a timeout: it deletes its pipes
+and exits when it has been idle for a given amount of time. The timeout
+sets up another race condition, since there is a time window between the
+delivery of the timeout alarm signal and the deletion of the pipes. If another
+mdprof_cgi process tests for the existence of the pipes during this interval,
+it could find that they do exist, and therefore commit to becoming a client,
+only to find that either the pipes or the process behind don't exist when it
+actually tries to send its query to the server.
+
+The solution we use to eliminate this race condition has two parts. First,
+we make the timeout code in the server get mutual exclusion on the same lock
+file that we use to solve client/client races, thus ensuring that all
+operations that create or delete the pipes are guarded by the same mutex.
+This is necessary because we use the existence of the pipes to denote the
+existence of a server process committed to serving queries on the associated
+profiling data file. However, this doesn't prevent the server from getting
+the mutex, deleting the pipes and exiting immediately another mdprof_cgi
+process got the mutex, found that the pipes existed, committed to becoming
+a client, and released the mutex. Therefore inside the critical section
+in the timeout code, we check for the existence of waiting clients, and
+abort the timeout if any exist. Since all operations on one end of a named
+pipe block until another process performs the complementary operation on
+the other end, we cannot use tests on the pipes to check for waiting clients.
+Instead, each client creates a file with a known prefix to indicate that it
+wants to use the services of a server, if one already exists. Would-be clients
+create this file before releasing the mutex (actually, before even getting
+the mutex) and do not delete it until they exit. (Unless they become the server
+instead, in which case they delete it when they make that decision.)
+The server aborts the timeout if it finds any of these `want' files.
+
+On a very slow machine, it is possible for the server to abort a timeout
+because of a want file that its creator is about to delete just before exiting.
+However, this is OK, because when the server aborts its timeout, it sets up
+another timeout, so the exit of the server is not delayed indefinitely.
+
+The following is a high level description of mdprof_cgi in pseudocode:
+
+ create "want" file
+ get mutual exclusion (i.e. create mutex file)
+ if the named pipes exist
+ commit to being a client
+ send the query to the server through the toserver pipe
+ release mutual exclusion (i.e. delete mutex file)
+ receive the result from the server through the fromserver pipe
+ remove "want" file
+ else
+ read the profile data file and preprocess it
+ if the reading and preprocessing found any errors
+ report the error
+ release mutual exclusion (i.e. delete mutex file)
+ remove "want" file
+ else
+ report the result of the initial query
+ commit to being a server
+ create the named pipes
+ release mutual exclusion (i.e. delete mutex file)
+ remove "want" file
+ loop forever
+ setup timeout
+ receive query on toserver pipe
+ send result to fromserver pipe
+ done
+ fi
+ fi
+
+The initial design of the deep profiler had two separate programs. The old
+mdprof_cgi was strictly a client: it *always* sent the query to a process
+running the other program, mdprof_server. The problem with this approach
+is that having mdprof_cgi invoke mdprof_server via fork and exec made
+it very difficult to debug mdprof_server and its interaction with mdprof_cgi,
+and to control the level of detail in the diagnostics we print about any
+problems we discover (whether in the profiling data file or in the manipulation
+of the underlying infrastructure, e.g. the named pipes). The current design
+allows a single debugging session to debug any part of the deep profiler
+simply by specifying an option that inhibits the fork that normally detaches
+the server process, and we can set option flags controlling diagnostics
+directly, instead of setting the server's flags indirectly by specifying flags
+to the client.
Index: deep_profiler/Mercury.options
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/Mercury.options,v
retrieving revision 1.1
diff -u -b -r1.1 Mercury.options
--- deep_profiler/Mercury.options 22 Jun 2002 19:16:01 -0000 1.1
+++ deep_profiler/Mercury.options 13 Nov 2002 22:52:54 -0000
@@ -5,3 +5,31 @@
#-----------------------------------------------------------------------------#
# Mercury.options - module-specific flags for Mmake and `mmc --make'.
#-----------------------------------------------------------------------------#
+
+# --optimize-duplicate-calls interacts badly with the current definition
+# of the mode `array_uo'. `array_uo' is supposed to be a unique output,
+# but is currently defined as plain, nonunique output. This allows the
+# duplicate call optimization to merge two calls that generate separate arrays,
+# even though those arrays will be updated destructively later on.
+#
+# At the moment, this causes the compiler to miscompile topological_sort/2
+# in cliques.m, which (after inlining dfs_graph) has two seemingly identical
+# calls to dense_bitset__init, whose output has mode `array_uo'.
+#
+# We therefore turn off this optimization in all modules that may deal
+# with arrays. This should not cause any performance problem, since there
+# are no known duplicate calls in any performance critical predicates.
+
+MCFLAGS-array_util = --no-optimize-duplicate-calls
+MCFLAGS-callgraph = --no-optimize-duplicate-calls
+MCFLAGS-canonical = --no-optimize-duplicate-calls
+MCFLAGS-clique = --no-optimize-duplicate-calls
+MCFLAGS-dense_bitset = --no-optimize-duplicate-calls
+MCFLAGS-exclude = --no-optimize-duplicate-calls
+MCFLAGS-html_format = --no-optimize-duplicate-calls
+MCFLAGS-measurements = --no-optimize-duplicate-calls
+MCFLAGS-profile = --no-optimize-duplicate-calls
+MCFLAGS-query = --no-optimize-duplicate-calls
+MCFLAGS-read_profile = --no-optimize-duplicate-calls
+MCFLAGS-startup = --no-optimize-duplicate-calls
+MCFLAGS-top_procs = --no-optimize-duplicate-calls
Index: deep_profiler/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/Mmakefile,v
retrieving revision 1.5
diff -u -b -r1.5 Mmakefile
--- deep_profiler/Mmakefile 22 Jun 2002 19:16:01 -0000 1.5
+++ deep_profiler/Mmakefile 12 Nov 2002 13:03:05 -0000
@@ -6,20 +6,20 @@
# Mmake - this is Mmake file for building the Mercury deep profiler
--include Mmake.deep.params
-
MERCURY_DIR=..
LINK_STATIC=yes
include $(MERCURY_DIR)/Mmake.common
+-include Mmake.deep.params
+
# Module-specific options should go in Mercury.options so they
# can be found by `mmc --make'.
include Mercury.options
ifeq ("$(ENABLE_DEEP_PROFILER)","yes")
- MAIN_TARGET=mdprof_cgi mdprof_server
- MERCURY_MAIN_MODULES=mdprof_cgi mdprof_server
- DEPEND=mdprof_cgi.depend mdprof_server.depend
+ MAIN_TARGET=all
+ MERCURY_MAIN_MODULES=mdprof_cgi mdprof_test
+ DEPEND=mdprof_cgi.depend mdprof_test.depend
INSTALL=install_deep
else
MAIN_TARGET=nothing
@@ -44,7 +44,7 @@
depend: $(DEPEND)
.PHONY: all
-all: mdprof_cgi mdprof_server
+all: mdprof_cgi mdprof_test
#-----------------------------------------------------------------------------#
@@ -53,22 +53,22 @@
mdprof_cgi: $(RUNTIME_DIR)/lib$(RT_LIB_NAME).$A
mdprof_cgi: $(LIBRARY_DIR)/lib$(STD_LIB_NAME).$A
-mdprof_server: $(RUNTIME_DIR)/lib$(RT_LIB_NAME).$A
-mdprof_server: $(LIBRARY_DIR)/lib$(STD_LIB_NAME).$A
+mdprof_test: $(RUNTIME_DIR)/lib$(RT_LIB_NAME).$A
+mdprof_test: $(LIBRARY_DIR)/lib$(STD_LIB_NAME).$A
# Should also depend on $(BOEHM_GC_DIR)/libgc(_prof).$A, but only
# if in .gc(.prof) grade; GNU make does not support dynamic dependencies,
# so just leave it out.
$(cs_subdir)mdprof_cgi_init.c: $(UTIL_DIR)/mkinit
-$(cs_subdir)mdprof_server_init.c: $(UTIL_DIR)/mkinit
+$(cs_subdir)mdprof_test_init.c: $(UTIL_DIR)/mkinit
#-----------------------------------------------------------------------------#
.PHONY: check
-check: mdprof_cgi.check mdprof_server.check
+check: mdprof_cgi.check mdprof_test.check
.PHONY: ints
-ints: mdprof_cgi.ints mdprof_server.ints
+ints: mdprof_cgi.ints mdprof_test.ints
#-----------------------------------------------------------------------------#
@@ -80,23 +80,23 @@
.PHONY: tags
tags: .deep.tags
-.deep.tags: $(MTAGS) $(mdprof_cgi.ms) $(mdprof_server.ms) $(LIBRARY_DIR)/*.m
- $(MTAGS) $(mdprof_cgi.ms) $(mdprof_server.ms) $(LIBRARY_DIR)/*.m
+.deep.tags: $(MTAGS) $(mdprof_cgi.ms) $(mdprof_test.ms) $(LIBRARY_DIR)/*.m
+ $(MTAGS) $(mdprof_cgi.ms) $(mdprof_test.ms) $(LIBRARY_DIR)/*.m
touch .deep.tags
#-----------------------------------------------------------------------------#
.PHONY: dates
dates:
- touch $(mdprof_cgi.dates) $(mdprof_server.dates)
+ touch $(mdprof_cgi.dates) $(mdprof_test.dates)
#-----------------------------------------------------------------------------#
.PHONY: os cs
os: $(mdprof_cgi.os) $(os_subdir)mdprof_cgi_init.o
-os: $(mdprof_server.os) $(os_subdir)mdprof_server_init.o
+os: $(mdprof_test.os) $(os_subdir)mdprof_test_init.o
cs: $(mdprof_cgi.cs) $(cs_subdir)mdprof_cgi_init.c
-cs: $(mdprof_server.cs) $(cs_subdir)mdprof_server_init.c
+cs: $(mdprof_test.cs) $(cs_subdir)mdprof_test_init.c
#-----------------------------------------------------------------------------#
@@ -110,12 +110,12 @@
.PHONY: install
install: $(INSTALL)
+# We don't install mdprof_test, since it is not for users.
+
.PHONY: install_deep
-install_deep: mdprof_cgi mdprof_server
+install_deep: mdprof_cgi
-[ -d $(INSTALL_MERC_BIN_DIR) ] || mkdir -p $(INSTALL_MERC_BIN_DIR)
cp `vpath_find mdprof_cgi$(EXT_FOR_EXE)` \
$(INSTALL_MERC_BIN_DIR)/mdprof_cgi
- cp `vpath_find mdprof_server$(EXT_FOR_EXE)`\
- $(INSTALL_MERC_BIN_DIR)/mdprof_server
#-----------------------------------------------------------------------------#
Index: deep_profiler/callgraph.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/callgraph.m,v
retrieving revision 1.2
diff -u -b -r1.2 callgraph.m
--- deep_profiler/callgraph.m 3 Jul 2001 08:16:17 -0000 1.2
+++ deep_profiler/callgraph.m 13 Nov 2002 16:07:43 -0000
@@ -30,6 +30,7 @@
:- import_module profile, cliques, array_util.
:- import_module int, set.
+% :- import_module io, string, unsafe, require.
find_cliques(InitDeep, BottomUpPDPtrCliqueList) :-
make_graph(InitDeep, Graph),
@@ -95,12 +96,15 @@
:- pred add_csd_arcs(initial_deep::in, int::in, call_site_dynamic_ptr::in,
graph::in, graph::out) is det.
+% :- pragma promise_pure(add_csd_arcs/5).
+
add_csd_arcs(InitDeep, FromPDI, CSDPtr, Graph0, Graph) :-
CSDPtr = call_site_dynamic_ptr(CSDI),
( CSDI > 0 ->
array__lookup(InitDeep ^ init_call_site_dynamics, CSDI, CSD),
ToPDPtr = CSD ^ csd_callee,
ToPDPtr = proc_dynamic_ptr(ToPDI),
+ % impure unsafe_perform_io(write_arc(FromPDI, ToPDI, CSDI)),
add_arc(Graph0, FromPDI, ToPDI, Graph)
;
Graph = Graph0
@@ -126,6 +130,30 @@
:- pred index_clique_member(int::in, proc_dynamic_ptr::in,
array(clique_ptr)::array_di, array(clique_ptr)::array_uo) is det.
+% :- pragma promise_pure(index_clique_member/4).
+
index_clique_member(CliqueNum, PDPtr, CliqueIndex0, CliqueIndex) :-
PDPtr = proc_dynamic_ptr(PDI),
+ % impure unsafe_perform_io(write_pdi_cn(PDI, CliqueNum)),
array__set(CliqueIndex0, PDI, clique_ptr(CliqueNum), CliqueIndex).
+
+%-----------------------------------------------------------------------------%
+
+% Predicates for use in debugging.
+
+% :- pred write_arc(int::in, int::in, int::in, io__state::di, io__state::uo)
+% is det.
+%
+% write_arc(FromPDI, ToPDI, CSDI) -->
+% io__format("arc from pd %d to pd %d through csd %d\n",
+% [i(FromPDI), i(ToPDI), i(CSDI)]).
+%
+% :- pred write_pdi_cn(int::in, int::in, io__state::di, io__state::uo) is det.
+%
+% write_pdi_cn(PDI, CN) -->
+% io__write_string("pdi "),
+% io__write_int(PDI),
+% io__write_string(" -> clique "),
+% io__write_int(CN),
+% io__nl,
+% io__flush_output.
Index: deep_profiler/cliques.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/cliques.m,v
retrieving revision 1.2
diff -u -b -r1.2 cliques.m
--- deep_profiler/cliques.m 5 Jun 2001 04:47:31 -0000 1.2
+++ deep_profiler/cliques.m 13 Nov 2002 16:07:27 -0000
@@ -36,6 +36,7 @@
:- import_module array_util, dense_bitset.
:- import_module array, int.
+% :- import_module io, unsafe, string.
:- type graph
---> graph(
@@ -81,25 +82,72 @@
mklist(N - 1, Acc1, Acc)
).
+% :- pragma promise_pure(topological_sort/2).
+
topological_sort(Graph, TSort) :-
+ % impure unsafe_perform_io(io__nl),
+ % impure unsafe_perform_io(io__write_string("the graph:\n")),
+ % impure unsafe_perform_io(write_graph(Graph)),
+ % impure unsafe_perform_io(io__nl),
+
dfs_graph(Graph, Dfs),
+
+ % impure unsafe_perform_io(io__nl),
+ % impure unsafe_perform_io(io__write_string("the dfs:\n")),
+ % impure unsafe_perform_io(write_dfs(Dfs)),
+ % impure unsafe_perform_io(io__nl),
+
inverse(Graph, InvGraph),
+
+ % impure unsafe_perform_io(io__nl),
+ % impure unsafe_perform_io(io__write_string("the inverse graph:\n")),
+ % impure unsafe_perform_io(write_graph(InvGraph)),
+ % impure unsafe_perform_io(io__nl),
+
Visit = dense_bitset__init,
tsort(Dfs, InvGraph, Visit, [], TSort0),
reverse(TSort0, TSort).
+ % impure unsafe_perform_io(io__nl),
+ % impure unsafe_perform_io(io__write_string("the cliques:\n")),
+ % impure unsafe_perform_io(write_cliques(TSort)),
+ % impure unsafe_perform_io(io__nl),
+ % impure unsafe_perform_io(io__nl).
+
:- pred tsort(list(int)::in, graph::in, visit::array_di, list(set(int))::in,
list(set(int))::out) is det.
+% :- pragma promise_pure(tsort/5).
+
tsort([], _InvGraph, _Visit, TSort, TSort).
tsort([Node | Nodes], InvGraph, Visit0, TSort0, TSort) :-
+ % impure unsafe_perform_io(io__write_string("tsort check ")),
+ % impure unsafe_perform_io(io__write_int(Node)),
+ % impure unsafe_perform_io(io__nl),
+
( dense_bitset__member(Node, Visit0) ->
- tsort(Nodes, InvGraph, Visit0, TSort0, TSort)
- ;
- dfs([Node], InvGraph, Visit0, [], Visit, CliqueList),
+ % impure unsafe_perform_io(io__write_string("tsort old ")),
+ % impure unsafe_perform_io(io__write_int(Node)),
+ % impure unsafe_perform_io(io__nl),
+ Visit1 = Visit0,
+ TSort1 = TSort0
+ ;
+ % impure unsafe_perform_io(io__write_string("tsort new ")),
+ % impure unsafe_perform_io(io__write_int(Node)),
+ % impure unsafe_perform_io(io__nl),
+
+ dfs([Node], InvGraph, Visit0, [], Visit1, CliqueList),
+
+ % impure unsafe_perform_io(io__write_string("tsort clique ")),
+ % impure unsafe_perform_io(io__write_int(Node)),
+ % impure unsafe_perform_io(io__write_string(" -> ")),
+ % impure unsafe_perform_io(write_clique(CliqueList)),
+ % impure unsafe_perform_io(io__nl),
+
set__list_to_set(CliqueList, Clique),
- tsort(Nodes, InvGraph, Visit, [Clique | TSort0], TSort)
- ).
+ TSort1 = [Clique | TSort0]
+ ),
+ tsort(Nodes, InvGraph, Visit1, TSort1, TSort).
% Return a list containing all the nodes of the graph. The list is effectively
% computed by randomly breaking all cycles, doing a pre-order traversal of
@@ -131,11 +179,21 @@
:- pred dfs(list(int)::in, graph::in, visit::array_di, list(int)::in,
visit::array_uo, list(int)::out) is det.
+% :- pragma promise_pure(dfs/6).
+
dfs([], _Graph, Visit, Dfs, Visit, Dfs).
dfs([Node | Nodes], Graph, Visit0, Dfs0, Visit, Dfs) :-
( dense_bitset__member(Node, Visit0) ->
+ % impure unsafe_perform_io(io__write_string("dfs old ")),
+ % impure unsafe_perform_io(io__write_int(Node)),
+ % impure unsafe_perform_io(io__nl),
+
dfs(Nodes, Graph, Visit0, Dfs0, Visit, Dfs)
;
+ % impure unsafe_perform_io(io__write_string("dfs new ")),
+ % impure unsafe_perform_io(io__write_int(Node)),
+ % impure unsafe_perform_io(io__nl),
+
Visit1 = dense_bitset__insert(Visit0, Node),
successors(Graph, Node, Succ),
set__to_sorted_list(Succ, SuccList),
@@ -169,3 +227,48 @@
add_arcs_to([From | FromList], To, Graph0, Graph) :-
add_arc(Graph0, From, To, Graph1),
add_arcs_to(FromList, To, Graph1, Graph).
+
+%-----------------------------------------------------------------------------%
+
+% Predicates to use in debugging.
+
+% :- pred write_graph(graph::in, io__state::di, io__state::uo)
+% is det.
+%
+% write_graph(Graph) -->
+% { Graph = graph(Size, Array) },
+% io__format("graph size: %d\n", [i(Size)]),
+% write_graph_nodes(0, Size, Array).
+%
+% :- pred write_graph_nodes(int::in, int::in, array(set(int))::in,
+% io__state::di, io__state::uo) is det.
+%
+% write_graph_nodes(Cur, Max, Array) -->
+% ( { Cur =< Max } ->
+% io__format("%d -> ", [i(Cur)]),
+% { array__lookup(Array, Cur, SuccSet) },
+% { set__to_sorted_list(SuccSet, Succs) },
+% io__write_list(Succs, ", ", io__write_int),
+% io__nl,
+% write_graph_nodes(Cur + 1, Max, Array)
+% ;
+% []
+% ).
+%
+% :- pred write_dfs(list(int)::in, io__state::di, io__state::uo)
+% is det.
+%
+% write_dfs(Dfs) -->
+% io__write_list(Dfs, "\n", io__write_int).
+%
+% :- pred write_cliques(list(set(int))::in, io__state::di, io__state::uo)
+% is det.
+%
+% write_cliques(Cliques) -->
+% io__write_list(Cliques, "\n", io__write).
+%
+% :- pred write_clique(list(int)::in, io__state::di, io__state::uo)
+% is det.
+%
+% write_clique(Nodes) -->
+% io__write_list(Nodes, "\n", io__write_int).
Index: deep_profiler/conf.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/conf.m,v
retrieving revision 1.2
diff -u -b -r1.2 conf.m
--- deep_profiler/conf.m 1 Feb 2002 03:16:49 -0000 1.2
+++ deep_profiler/conf.m 13 Nov 2002 10:51:40 -0000
@@ -1,5 +1,5 @@
%-----------------------------------------------------------------------------%
-% Copyright (C) 2001 The University of Melbourne.
+% Copyright (C) 2001-2002 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
@@ -23,6 +23,8 @@
% The name of the server on which mdprof is being run.
:- pred server_name(string::out, io__state::di, io__state::uo) is det.
+:- func getpid = int.
+
:- implementation.
:- import_module string, list, require.
@@ -42,33 +44,36 @@
string__format("%s > %s", [s(HostnameCmd), s(TmpFile)]) },
io__call_system(ServerRedirectCmd, Res1),
( { Res1 = ok(0) } ->
- io__see(TmpFile, Res2),
- ( { Res2 = ok } ->
- io__read_file(Res3),
- ( { Res3 = ok(ServerNameChars0) } ->
+ io__open_input(TmpFile, TmpRes),
+ ( { TmpRes = ok(TmpStream) } ->
+ io__read_file(TmpStream, TmpReadRes),
+ { TmpReadRes = ok(ServerNameChars0) ->
(
- { list__remove_suffix(ServerNameChars0,
- ['\n'], ServerNameChars) }
+ list__remove_suffix(ServerNameChars0,
+ ['\n'], ServerNameChars)
->
- { string__from_char_list(
- ServerNameChars, ServerName) },
- io__seen
+ string__from_char_list(
+ ServerNameChars, ServerName)
;
- { error("malformed server name") }
+ error("malformed server name")
)
;
- { error("cannot read server's name") }
- )
+ error("cannot read server's name")
+ },
+ io__close_input(TmpStream)
;
{ error("cannot open file to out the server's name") }
- )
+ ),
+ { RmTmpCmd = string__format("rm %s", [s(TmpFile)]) },
+ io__call_system(RmTmpCmd, _)
;
{ error("cannot execute cmd to find out the server's name") }
).
:- pred mkfifo_cmd(string::out) is det.
-:- pragma foreign_proc("C", mkfifo_cmd(Mkfifo::out),
+:- pragma foreign_proc("C",
+ mkfifo_cmd(Mkfifo::out),
[will_not_call_mercury, promise_pure],
"
/* shut up warnings about casting away const */
@@ -77,9 +82,35 @@
:- pred hostname_cmd(string::out) is det.
-:- pragma foreign_proc("C", hostname_cmd(Hostname::out),
+:- pragma foreign_proc("C",
+ hostname_cmd(Hostname::out),
[will_not_call_mercury, promise_pure],
"
/* shut up warnings about casting away const */
Hostname = (MR_String) (MR_Integer) MR_HOSTNAMECMD;
+").
+
+:- pragma foreign_decl("C",
+"
+#ifdef MR_HAVE_UNISTD_H
+#include <sys/types.h>
+#include <unistd.h>
+#endif
+").
+
+:- pragma foreign_proc("C",
+ getpid = (Pid::out),
+ [will_not_call_mercury, promise_pure],
+"
+#if defined(MR_HAVE_UNISTD_H) && defined(MR_HAVE_GETPID)
+ Pid = getpid();
+#else
+ /*
+ ** If MR_HAVE_GETPID is not defined, the deep profiler is not enabled
+ ** anyway, so what the code here does doesn't matter. We still want to
+ ** make it compile cleanly, though.
+ */
+
+ Pid = 0;
+#endif
").
Index: deep_profiler/html_format.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/html_format.m,v
retrieving revision 1.1
diff -u -b -r1.1 html_format.m
--- deep_profiler/html_format.m 3 Jul 2001 08:16:17 -0000 1.1
+++ deep_profiler/html_format.m 25 Aug 2002 02:27:05 -0000
@@ -1839,7 +1839,8 @@
[s(URL), s(ProcName)]).
deep_cmd_pref_to_url(Pref, Deep, Cmd) =
- cmd_pref_to_url(Deep ^ server_name, Deep ^ data_file_name, Cmd, Pref).
+ machine_datafile_cmd_pref_to_url(Deep ^ server_name,
+ Deep ^ data_file_name, Cmd, Pref).
%-----------------------------------------------------------------------------%
Index: deep_profiler/interface.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/interface.m,v
retrieving revision 1.4
diff -u -b -r1.4 interface.m
--- deep_profiler/interface.m 18 Jul 2001 04:38:04 -0000 1.4
+++ deep_profiler/interface.m 13 Nov 2002 17:11:16 -0000
@@ -1,23 +1,33 @@
%-----------------------------------------------------------------------------%
-% Copyright (C) 2001 The University of Melbourne.
+% Copyright (C) 2001-2002 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
%
% Author: zs.
%
-% This module defines interface between the CGI program (mdprof_cgi.m)
-% and the deep profiling server (mdprof_server.m).
+% This module defines interface between CGI programs acting as clients
+% and CGI programs acting as servers.
%
% The interface consists of queries (sent from the CGI program to the server)
% and responses (sent back from the server to the CGI program), and shared
% knowledge of how to derive the names of some files from the name of the
% profiling data file being explored.
%
+% Queries are sent and received as printed representations of Mercury terms,
+% using the predicates send_term and recv_term. Responses are sent as strings
+% using the predicates send_string and recv_string. Each response is actually
+% the name of a file contained a web page, rather than the text of the web page
+% itself. This makes things easy to debug (since we can leave the file around
+% for inspection) and avoids any potential problems with the web page being too
+% big to transmit atomically across the named pipe. (Printable representations
+% of queries and filenames are both guaranteed to be smaller than eight
+% kilobytes, which is the typical named pipe buffer size.)
+%
% A query consists of three components, a command, a set of preferences, and
% the name of the profiling data file. The command tells the server what
-% information the user wants displayed. The preferences tell the server how the
-% user wants data displayed; they persist across queries unless the user
+% information the user wants displayed. The preferences tell the server how
+% the user wants data displayed; they persist across queries unless the user
% changes them.
%
% This module defines the types of commands and preferences. It provides
@@ -34,26 +44,63 @@
:- interface.
-:- import_module std_util.
+:- import_module bool, char, std_util, io.
- % These functions derive the names of auxiliary files from the name of
- % the profiling data file being explored. The auxiliary files are:
+ % These functions derive the names of auxiliary files (or parts
+ % thereof) from the name of the profiling data file being explored.
+ % The auxiliary files are:
%
% - the name of the named pipe for transmitting queries to the server;
% - the name of the named pipe for transmitting responses back to the
% CGI program;
% - the name of the file containing the output of the server program,
% which prints statistics about its own performance at startup
- % (and if invoked with the --debug option, debugging information
- % during its execution)
+ % (and if invoked with debugging option, debugging information
+ % during its execution);
+ % - the name of the mutual exclusion file (which is always empty);
+ % - the naming scheme of the `want' files (which are always empty);
+ % - the names of the files containing the web page responses;
% - the name of the file containing contour exclusion information
% (see exclude.m).
:- func to_server_pipe_name(string) = string.
:- func from_server_pipe_name(string) = string.
:- func server_startup_name(string) = string.
+:- func mutex_file_name(string) = string.
+:- func want_dir = string.
+:- func want_prefix = string.
+:- func want_file_name = string.
+:- func response_file_name(string, int) = string.
:- func contour_file_name(string) = string.
+ % send_term(ToFileName, Debug, Term):
+ % Write the term Term to ToFileName, making it is new contents.
+ % If Debug is `yes', write it to the file `/tmp/.send_term'
+ % as well.
+:- pred send_term(string::in, bool::in, T::in,
+ io__state::di, io__state::uo) is det.
+
+ % send_string(ToFileName, Debug, Str):
+ % Write the string Str to ToFileName, making it is new contents.
+ % If Debug is `yes', write it to the file `/tmp/.send_string'
+ % as well.
+:- pred send_string(string::in, bool::in, string::in,
+ io__state::di, io__state::uo) is det.
+
+ % recv_term(FromFileName, Debug, Term):
+ % Read the contents of FromFileName, which should be a single
+ % Mercury term. If Debug is `yes', write the result of the read
+ % to the file `/tmp/.recv_term' as well.
+:- pred recv_term(string::in, bool::in, T::out,
+ io__state::di, io__state::uo) is det.
+
+ % recv_string(FromFileName, Debug, Str):
+ % Read the contents of FromFileName, and return it as Str.
+ % If Debug is `yes', write the result of the read to the file
+ % `/tmp/.recv_string' as well.
+:- pred recv_string(string::in, bool::in, string::out,
+ io__state::di, io__state::uo) is det.
+
:- type resp
---> html(string).
@@ -211,15 +258,18 @@
:- func default_contour = contour.
:- func default_time_format = time_format.
-:- func cmd_pref_to_url(string, string, cmd, preferences) = string.
-:- func url_component_to_cmd(string) = maybe(cmd).
-:- func url_component_to_pref(string) = maybe(preferences).
+:- func query_separator_char = char.
+:- func machine_datafile_cmd_pref_to_url(string, string, cmd, preferences)
+ = string.
+:- func url_component_to_cmd(string, cmd) = cmd.
+:- func url_component_to_maybe_cmd(string) = maybe(cmd).
+:- func url_component_to_maybe_pref(string) = maybe(preferences).
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module util.
+:- import_module conf, util.
:- import_module char, string, list, set, require.
default_preferences =
@@ -251,18 +301,31 @@
to_server_pipe_name(DataFileName) =
server_dir ++ "/" ++
- "mdprof_server_to" ++
- filename_mangle(DataFileName).
+ "mdprof_server_to" ++ filename_mangle(DataFileName).
from_server_pipe_name(DataFileName) =
server_dir ++ "/" ++
- "mdprof_server_from" ++
- filename_mangle(DataFileName).
+ "mdprof_server_from" ++ filename_mangle(DataFileName).
server_startup_name(DataFileName) =
server_dir ++ "/" ++
- "mdprof_startup_err" ++
- filename_mangle(DataFileName).
+ "mdprof_startup_err" ++ filename_mangle(DataFileName).
+
+mutex_file_name(DataFileName) =
+ server_dir ++ "/" ++
+ "mdprof_mutex" ++ filename_mangle(DataFileName).
+
+want_dir = server_dir.
+
+want_prefix = "mdprof_want".
+
+want_file_name =
+ want_dir ++ "/" ++ want_prefix ++ string__int_to_string(getpid).
+
+response_file_name(DataFileName, QueryNum) =
+ server_dir ++ "/" ++
+ "mdprof_response" ++ filename_mangle(DataFileName) ++
+ string__int_to_string(QueryNum).
contour_file_name(DataFileName) =
DataFileName ++ ".contour".
@@ -295,16 +358,127 @@
MangledChars = [First | MangledRest]
).
+send_term(ToPipeName, Debug, Data) -->
+ io__open_output(ToPipeName, Res),
+ ( { Res = ok(ToStream) } ->
+ io__write(ToStream, Data),
+ io__write_string(ToStream, ".\n"),
+ io__close_output(ToStream)
+ ;
+ { error("send_term: couldn't open pipe") }
+ ),
+ (
+ { Debug = yes },
+ io__open_output("/tmp/.send_term", Res2),
+ ( { Res2 = ok(DebugStream) } ->
+ io__write(DebugStream, Data),
+ io__write_string(DebugStream, ".\n"),
+ io__close_output(DebugStream)
+ ;
+ { error("send_term: couldn't debug") }
+ )
+ ;
+ { Debug = no }
+ ).
+
+send_string(ToPipeName, Debug, Data) -->
+ io__open_output(ToPipeName, Res),
+ ( { Res = ok(ToStream) } ->
+ io__write_string(ToStream, Data),
+ io__close_output(ToStream)
+ ;
+ { error("send_string: couldn't open pipe") }
+ ),
+ (
+ { Debug = yes },
+ io__open_output("/tmp/.send_string", Res2),
+ ( { Res2 = ok(DebugStream) } ->
+ io__write_string(DebugStream, Data),
+ io__close_output(DebugStream)
+ ;
+ { error("send_string: couldn't debug") }
+ )
+ ;
+ { Debug = no }
+ ).
+
+recv_term(FromPipeName, Debug, Resp) -->
+ io__open_input(FromPipeName, Res0),
+ ( { Res0 = ok(FromStream) } ->
+ io__read(FromStream, Res1),
+ ( { Res1 = ok(Resp0) } ->
+ { Resp = Resp0 }
+ ;
+ { error("recv_term: read failed") }
+ ),
+ io__close_input(FromStream),
+ (
+ { Debug = yes },
+ io__open_output("/tmp/.recv_term", Res2),
+ ( { Res2 = ok(DebugStream) } ->
+ io__write(DebugStream, Res1),
+ io__write_string(DebugStream, ".\n"),
+ io__close_output(DebugStream)
+ ;
+ { error("recv_term: couldn't debug") }
+ )
+ ;
+ { Debug = no }
+ )
+ ;
+ { error("recv_term: couldn't open pipe") }
+ ).
+
+recv_string(FromPipeName, Debug, Resp) -->
+ io__open_input(FromPipeName, Res0),
+ ( { Res0 = ok(FromStream) } ->
+ io__read_file_as_string(FromStream, Res1),
+ ( { Res1 = ok(Resp0) } ->
+ { Resp = Resp0 }
+ ;
+ { error("recv_string: read failed") }
+ ),
+ io__close_input(FromStream),
+ (
+ { Debug = yes },
+ io__open_output("/tmp/.recv_string", Res2),
+ ( { Res2 = ok(DebugStream) } ->
+ io__write(DebugStream, Res1),
+ io__write_string(DebugStream, ".\n"),
+ io__close_output(DebugStream)
+ ;
+ { error("recv_string: couldn't debug") }
+ )
+ ;
+ { Debug = no }
+ )
+ ;
+ { error("recv_term: couldn't open pipe") }
+ ).
+
%-----------------------------------------------------------------------------%
-cmd_pref_to_url(Machine, DataFileName, Cmd, Preferences) =
+:- func cmd_separator_char = char.
+:- func pref_separator_char = char.
+:- func criteria_separator_char = char.
+:- func field_separator_char = char.
+:- func limit_separator_char = char.
+
+query_separator_char = ('%').
+cmd_separator_char = ('/').
+pref_separator_char = ('/').
+criteria_separator_char = ('-').
+field_separator_char = ('-').
+limit_separator_char = ('-').
+
+machine_datafile_cmd_pref_to_url(Machine, DataFileName, Cmd, Preferences) =
"http://" ++
Machine ++
"/cgi-bin/mdprof?" ++
cmd_to_string(Cmd) ++
- "$" ++
+ string__char_to_string(query_separator_char) ++
preferences_to_string(Preferences) ++
- "$" ++
+ string__char_to_string(query_separator_char) ++
DataFileName.
:- func cmd_to_string(cmd) = string.
@@ -318,7 +492,8 @@
CmdStr = "restart"
;
Cmd = timeout(Minutes),
- CmdStr = string__format("timeout+%d", [i(Minutes)])
+ CmdStr = string__format("timeout%c%d",
+ [c(cmd_separator_char), i(Minutes)])
;
Cmd = menu,
CmdStr = "menu"
@@ -326,52 +501,66 @@
Cmd = root(MaybePercent),
(
MaybePercent = yes(Percent),
- CmdStr = string__format("root+%d", [i(Percent)])
+ CmdStr = string__format("root%c%d",
+ [c(cmd_separator_char), i(Percent)])
;
MaybePercent = no,
- CmdStr = "root+no"
+ CmdStr = string__format("root%c%s",
+ [c(cmd_separator_char), s("no")])
)
;
Cmd = clique(CliqueNum),
- CmdStr = string__format("clique+%d", [i(CliqueNum)])
+ CmdStr = string__format("clique%c%d",
+ [c(cmd_separator_char), i(CliqueNum)])
;
Cmd = proc(ProcNum),
- CmdStr = string__format("proc+%d", [i(ProcNum)])
+ CmdStr = string__format("proc%c%d",
+ [c(cmd_separator_char), i(ProcNum)])
;
Cmd = proc_callers(ProcNum, GroupCallers, BunchNum),
GroupCallersStr = caller_groups_to_string(GroupCallers),
- CmdStr = string__format("proc_callers+%d+%s+%d",
- [i(ProcNum), s(GroupCallersStr), i(BunchNum)])
+ CmdStr = string__format("proc_callers%c%d%c%s%c%d",
+ [c(cmd_separator_char), i(ProcNum),
+ c(cmd_separator_char), s(GroupCallersStr),
+ c(cmd_separator_char), i(BunchNum)])
;
Cmd = modules,
CmdStr = "modules"
;
Cmd = module(ModuleName),
- CmdStr = "module+" ++ ModuleName
+ CmdStr = string__format("module%c%s",
+ [c(cmd_separator_char), s(ModuleName)])
;
Cmd = top_procs(Limit, CostKind, InclDesc, Scope),
LimitStr = limit_to_string(Limit),
CostKindStr = cost_kind_to_string(CostKind),
InclDescStr = incl_desc_to_string(InclDesc),
ScopeStr = scope_to_string(Scope),
- CmdStr = string__format("top_procs+%s+%s+%s+%s",
- [s(LimitStr), s(CostKindStr),
- s(InclDescStr), s(ScopeStr)])
+ CmdStr = string__format("top_procs%c%s%c%s%c%s%c%s",
+ [c(cmd_separator_char), s(LimitStr),
+ c(cmd_separator_char), s(CostKindStr),
+ c(cmd_separator_char), s(InclDescStr),
+ c(cmd_separator_char), s(ScopeStr)])
;
Cmd = proc_static(PSI),
- CmdStr = string__format("proc_static+%d", [i(PSI)])
+ CmdStr = string__format("proc_static%c%d",
+ [c(cmd_separator_char), i(PSI)])
;
Cmd = proc_dynamic(PDI),
- CmdStr = string__format("proc_dynamic+%d", [i(PDI)])
+ CmdStr = string__format("proc_dynamic%c%d",
+ [c(cmd_separator_char), i(PDI)])
;
Cmd = call_site_static(CSSI),
- CmdStr = string__format("call_site_static+%d", [i(CSSI)])
+ CmdStr = string__format("call_site_static%c%d",
+ [c(cmd_separator_char), i(CSSI)])
;
Cmd = call_site_dynamic(CSDI),
- CmdStr = string__format("call_site_dynamic+%d", [i(CSDI)])
+ CmdStr = string__format("call_site_dynamic%c%d",
+ [c(cmd_separator_char), i(CSDI)])
;
Cmd = raw_clique(CI),
- CmdStr = string__format("raw_clique+%d", [i(CI)])
+ CmdStr = string__format("raw_clique%c%d",
+ [c(cmd_separator_char), i(CI)])
).
:- func preferences_to_string(preferences) = string.
@@ -387,16 +576,27 @@
MaybeAncestorLimit = no,
MaybeAncestorLimitStr = "no"
),
- PrefStr = string__format("%s+%s+%s+%s+%s+%s+%s+%s",
- [s(fields_to_string(Fields)), s(box_to_string(Box)),
- s(colour_scheme_to_string(Colour)), s(MaybeAncestorLimitStr),
- s(summarize_to_string(Summarize)),
- s(order_criteria_to_string(Order)),
- s(contour_to_string(Contour)),
- s(time_format_to_string(Time))]).
+ PrefStr = string__format("%s%c%s%c%s%c%s%c%s%c%s%c%s%c%s",
+ [s(fields_to_string(Fields)),
+ c(pref_separator_char), s(box_to_string(Box)),
+ c(pref_separator_char), s(colour_scheme_to_string(Colour)),
+ c(pref_separator_char), s(MaybeAncestorLimitStr),
+ c(pref_separator_char), s(summarize_to_string(Summarize)),
+ c(pref_separator_char), s(order_criteria_to_string(Order)),
+ c(pref_separator_char), s(contour_to_string(Contour)),
+ c(pref_separator_char), s(time_format_to_string(Time))]).
+
+url_component_to_cmd(QueryString, DefaultCmd) = Cmd :-
+ MaybeCmd = url_component_to_maybe_cmd(QueryString),
+ (
+ MaybeCmd = yes(Cmd)
+ ;
+ MaybeCmd = no,
+ Cmd = DefaultCmd
+ ).
-url_component_to_cmd(QueryString) = MaybeCmd :-
- split(QueryString, ('+'), Pieces),
+url_component_to_maybe_cmd(QueryString) = MaybeCmd :-
+ split(QueryString, pref_separator_char, Pieces),
(
Pieces = ["root", MaybePercentStr],
( MaybePercentStr = "no" ->
@@ -488,8 +688,8 @@
MaybeCmd = no
).
-url_component_to_pref(QueryString) = MaybePreferences :-
- split(QueryString, ('+'), Pieces),
+url_component_to_maybe_pref(QueryString) = MaybePreferences :-
+ split(QueryString, pref_separator_char, Pieces),
(
Pieces = [FieldsStr, BoxStr, ColourStr, MaybeAncestorLimitStr,
SummarizeStr, OrderStr, ContourStr, TimeStr],
@@ -576,16 +776,19 @@
:- func fields_to_string(fields) = string.
fields_to_string(fields(Port, Time, Allocs, Memory)) =
- port_fields_to_string(Port) ++ "-" ++
- time_fields_to_string(Time) ++ "-" ++
- alloc_fields_to_string(Allocs) ++ "-" ++
+ port_fields_to_string(Port) ++
+ string__char_to_string(field_separator_char) ++
+ time_fields_to_string(Time) ++
+ string__char_to_string(field_separator_char) ++
+ alloc_fields_to_string(Allocs) ++
+ string__char_to_string(field_separator_char) ++
memory_fields_to_string(Memory).
:- pred string_to_fields(string::in, fields::out) is semidet.
string_to_fields(FieldsStr, Fields) :-
(
- split(FieldsStr, '-', Pieces),
+ split(FieldsStr, field_separator_char, Pieces),
Pieces = [PortStr, TimeStr, AllocStr, MemoryStr],
string_to_port_fields(PortStr, Port),
string_to_time_fields(TimeStr, Time),
@@ -637,14 +840,16 @@
:- func limit_to_string(display_limit) = string.
-limit_to_string(rank_range(Lo, Hi)) = string__format("%d-%d", [i(Lo), i(Hi)]).
-limit_to_string(threshold(Threshold)) = string__format("%f", [f(Threshold)]).
+limit_to_string(rank_range(Lo, Hi)) =
+ string__format("%d%c%d", [i(Lo), c(limit_separator_char), i(Hi)]).
+limit_to_string(threshold(Threshold)) =
+ string__format("%f", [f(Threshold)]).
:- pred string_to_limit(string::in, display_limit::out) is semidet.
string_to_limit(LimitStr, Limit) :-
(
- split(LimitStr, '-', Pieces),
+ split(LimitStr, limit_separator_char, Pieces),
Pieces = [FirstStr, LastStr],
string__to_int(FirstStr, First),
string__to_int(LastStr, Last)
@@ -673,9 +878,12 @@
order_criteria_to_string(by_context) = "context".
order_criteria_to_string(by_name) = "name".
order_criteria_to_string(by_cost(CostKind, InclDesc, Scope)) =
- "cost" ++ "-" ++
- cost_kind_to_string(CostKind) ++ "-" ++
- incl_desc_to_string(InclDesc) ++ "-" ++
+ "cost" ++
+ string__char_to_string(criteria_separator_char) ++
+ cost_kind_to_string(CostKind) ++
+ string__char_to_string(criteria_separator_char) ++
+ incl_desc_to_string(InclDesc) ++
+ string__char_to_string(criteria_separator_char) ++
scope_to_string(Scope).
:- pred string_to_order_criteria(string::in, order_criteria::out) is semidet.
@@ -690,7 +898,7 @@
->
Criteria = by_name
;
- split(CriteriaStr, '-', Pieces),
+ split(CriteriaStr, criteria_separator_char, Pieces),
Pieces = ["cost", CostKindStr, InclDescStr, ScopeStr],
string_to_cost_kind(CostKindStr, CostKind),
string_to_incl_desc(InclDescStr, InclDesc),
Index: deep_profiler/mdprof_cgi.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/mdprof_cgi.m,v
retrieving revision 1.3
diff -u -b -r1.3 mdprof_cgi.m
--- deep_profiler/mdprof_cgi.m 18 Jul 2001 04:38:04 -0000 1.3
+++ deep_profiler/mdprof_cgi.m 13 Nov 2002 22:06:59 -0000
@@ -1,17 +1,14 @@
%-----------------------------------------------------------------------------%
-% Copyright (C) 2001 The University of Melbourne.
+% Copyright (C) 2001-2002 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
%
-% Authors: conway, zs.
+% Author of initial version: conway.
+% Author of this version: zs.
%
% This file contains the CGI "script" that is executed by the web server
% to handle web page requests implemented by the Mercury deep profiler server.
-%
-% A shell script installed as /usr/lib/cgi-bin/mdprof should invoke this
-% program after setting up the executable search path in the environment
-% to include the directory that contains the server program, mdprof_server.
:- module mdprof_cgi.
@@ -19,155 +16,640 @@
:- import_module io.
-:- pred main(io__state, io__state).
-:- mode main(di, uo) is det.
+:- pred main(io__state::di, io__state::uo) is cc_multi.
:- implementation.
-:- import_module interface, util.
-:- import_module char, string, int, list, set, require, std_util.
+:- import_module profile, interface, startup, query, conf, timeout, util.
+:- import_module bool, char, string, int, array, list, set.
+:- import_module require, std_util, getopt.
+
+:- import_module int, string, list, array, map, exception, require.
+
+% The web server should always set QUERY_STRING. It may also pass its contents
+% as arguments, but if any characters specials to the shell occur in the query,
+% they will screw up the argument list. We therefore look at the argument list
+% only if QUERY_STRING isn't set, which means that the program was invoked
+% from the command line for debugging.
main -->
- io__command_line_arguments(Args),
- ( { Args = [] } ->
+ write_html_header,
io__get_environment_var("QUERY_STRING", MaybeQueryString),
(
{ MaybeQueryString = yes(QueryString0) },
- { split(QueryString0, ('$'), Pieces) },
+ { getopt__process_options(option_ops(short, long, defaults),
+ [], _, MaybeOptions) },
+ {
+ MaybeOptions = ok(Options)
+ ;
+ MaybeOptions = error(_Msg),
+ error("mdprof_cgi: error parsing empty command line")
+ },
+ { split(QueryString0, query_separator_char, Pieces) },
( { Pieces = [CmdStr, PrefStr, FileName] } ->
- process_query(CmdStr, yes(PrefStr), FileName)
+ { Cmd = url_component_to_cmd(CmdStr, menu) },
+ process_query(Cmd, yes(PrefStr), FileName,
+ Options)
; { Pieces = [CmdStr, FileName] } ->
- process_query(CmdStr, no, FileName)
+ { Cmd = url_component_to_cmd(CmdStr, menu) },
+ process_query(Cmd, no, FileName, Options)
; { Pieces = [FileName] } ->
- process_query("menu", no, FileName)
+ process_query(menu, no, FileName, Options)
;
- io__write_string(
- "Bad URL; expected query$/full/path/name\n")
+ io__set_exit_status(1),
+ % Give the simplest URL in the error message.
+ io__write_string("Bad URL; expected filename\n")
)
;
- { MaybeQueryString = no }
- )
- ;
- io__write_string("Usage: mdprof_cgi\n")
+ { MaybeQueryString = no },
+ process_command_line
).
-:- pred process_query(string::in, maybe(string)::in, string::in,
- io__state::di, io__state::uo) is det.
-process_query(CmdStr, MaybePrefStr, DataFileName) -->
- { ToServer = to_server_pipe_name(DataFileName) },
- { FromServer = from_server_pipe_name(DataFileName) },
- { TestCmd = string__format("test -p %s -a -p %s",
- [s(ToServer), s(FromServer)]) },
- io__call_system(TestCmd, TestRes),
- io__write_string("Content-type: text/html\n\n"),
- (
- { TestRes = ok(ExitStatus) },
- ( { ExitStatus = 0 } ->
- { MaybeError = no }
- ;
- create_server(DataFileName, MaybeError)
- ),
- (
- { MaybeError = no },
- handle_query(CmdStr, MaybePrefStr,
- ToServer, FromServer)
- ;
- { MaybeError = yes(Error) },
- io__write_string(Error)
- )
+:- pred process_command_line(io__state::di, io__state::uo) is cc_multi.
+
+process_command_line -->
+ io__progname_base("mdprof_cgi", ProgName),
+ io__command_line_arguments(Args0),
+ % io__write_string("Args0: "),
+ % io__write_list(Args0, " ", write_bracketed_string),
+ % io__nl,
+ { getopt__process_options(option_ops(short, long, defaults),
+ Args0, Args, MaybeOptions) },
+ (
+ { MaybeOptions = ok(Options) },
+ process_args(Args, Options)
;
- { TestRes = error(Err) },
- { io__error_message(Err, Msg) },
- io__write_string(Msg)
+ { MaybeOptions = error(Msg) },
+ io__set_exit_status(1),
+ io__format("%s: error parsing options: %s\n",
+ [s(ProgName), s(Msg)])
).
-:- pred create_server(string::in, maybe(string)::out,
- io__state::di, io__state::uo) is det.
+:- pred process_args(list(string)::in, option_table::in,
+ io__state::di, io__state::uo) is cc_multi.
-create_server(DataFileName, MaybeError) -->
- { StartupFileName = server_startup_name(DataFileName) },
- { ServerCmd = string__format(
- "%s %s < /dev/null > /dev/null 2> %s",
- [s(server_path_name), s(DataFileName),
- s(StartupFileName)]) },
- io__call_system(ServerCmd, Res),
- (
- { Res = ok(ExitStatus) },
- ( { ExitStatus = 0 } ->
- { MaybeError = no }
- ;
- { MaybeError = yes("Command to start server failed") },
- { ToServer = to_server_pipe_name(DataFileName) },
- { FromServer = from_server_pipe_name(DataFileName) },
- { RemoveToServerCmd = string__format(
- "rm -f %s", [s(ToServer)]) },
- { RemoveFromServerCmd = string__format(
- "rm -f %s", [s(FromServer)]) },
- { RemoveStartupFileCmd = string__format(
- "rm -f %s", [s(StartupFileName)]) },
- % We ignore any errors since we can't do anything
- % about them anyway.
- io__call_system(RemoveToServerCmd, _),
- io__call_system(RemoveFromServerCmd, _),
- io__call_system(RemoveStartupFileCmd, _)
- )
- ;
- { Res = error(Err) },
- { io__error_message(Err, Msg) },
- { MaybeError = yes(Msg) }
+process_args(Args, Options) -->
+ ( { Args = [FileName] } ->
+ % Although this mode of usage is not intended for production
+ % use, allowing the filename and a limited range of commands
+ % to be supplied on the command line makes debugging very much
+ % easier.
+ process_query(default_cmd(Options), no, FileName, Options)
+ ;
+ io__set_exit_status(1),
+ % The options are deliberately not documented; they change
+ % quite rapidly, based on the debugging needs of the moment.
+ io__write_string("Usage: mdprof_cgi [filename]\n"),
+ io__write_list(Args, " ", write_bracketed_string)
).
-:- func server_path_name = string.
+:- pred write_bracketed_string(string::in, io__state::di, io__state::uo)
+ is det.
-server_path_name = "mdprof_server".
+write_bracketed_string(S) -->
+ io__write_string("<"),
+ io__write_string(S),
+ io__write_string(">").
-:- pred handle_query(string::in, maybe(string)::in, string::in, string::in,
- io__state::di, io__state::uo) is det.
+:- pred write_html_header(io__state::di, io__state::uo) is det.
+
+write_html_header -->
+ io__write_string(html_header_text),
+ io__flush_output.
+
+:- func html_header_text = string.
+
+html_header_text = "Content-type: text/html\n\n".
+
+%-----------------------------------------------------------------------------%
+
+:- pred process_query(cmd::in, maybe(string)::in, string::in,
+ option_table::in, io__state::di, io__state::uo) is cc_multi.
-handle_query(CmdStr, MaybePrefStr, ToServer, FromServer) -->
- { MaybeCmd = url_component_to_cmd(CmdStr) },
+process_query(Cmd, MaybePrefStr, DataFileName, Options) -->
{
MaybePrefStr = yes(PrefStr),
- MaybePref = url_component_to_pref(PrefStr)
+ MaybePref = url_component_to_maybe_pref(PrefStr)
;
MaybePrefStr = no,
- MaybePref = yes(default_preferences)
+ MaybePref = no
},
- ( { MaybeCmd = yes(Cmd), MaybePref = yes(Pref) } ->
- to(ToServer, cmd_pref(Cmd, Pref)),
- from(FromServer, html(Page)),
- io__write_string(Page)
+ {
+ MaybePref = yes(Pref)
+ ;
+ MaybePref = no,
+ Pref = default_preferences
+ },
+ { ToServerPipe = to_server_pipe_name(DataFileName) },
+ { FromServerPipe = from_server_pipe_name(DataFileName) },
+ { StartupFile = server_startup_name(DataFileName) },
+ { MutexFile = mutex_file_name(DataFileName) },
+ { lookup_bool_option(Options, debug, Debug) },
+ { WantFile = want_file_name },
+ make_want_file(WantFile),
+ get_lock(Debug, MutexFile),
+ (
+ { Debug = yes }
+ % Do not set up any cleanups; leave all files around,
+ % since they may be needed for postmortem examination.
;
- io__write_string("mdprof: unknown URL format")
+ { Debug = no },
+ setup_signals(MutexFile, want_dir, want_prefix)
+ ),
+ check_for_existing_fifos(ToServerPipe, FromServerPipe, FifoCount),
+ ( { FifoCount = 0 } ->
+ handle_query_from_new_server(Cmd, Pref, DataFileName,
+ ToServerPipe, FromServerPipe, StartupFile,
+ MutexFile, WantFile, Options)
+ ; { FifoCount = 2 } ->
+ handle_query_from_existing_server(Cmd, Pref,
+ ToServerPipe, FromServerPipe,
+ MutexFile, WantFile, Options)
+ ;
+ release_lock(Debug, MutexFile),
+ remove_want_file(WantFile),
+ io__set_exit_status(1),
+ io__write_string("mdprof internal error: bad fifo count")
).
- % Send a query to the server.
-:- pred to(string::in, cmd_pref::in, io__state::di, io__state::uo) is det.
+% Handle the given query using the existing server. Delete the mutex and want
+% files when we get out of the critical region.
-to(ToServerPipeName, CmdPref) -->
- io__tell(ToServerPipeName, Res),
- ( { Res = ok } ->
- io__write(CmdPref),
- io__write_string(".\n"),
- io__told
+:- pred handle_query_from_existing_server(cmd::in, preferences::in,
+ string::in, string::in, string::in, string::in, option_table::in,
+ io__state::di, io__state::uo) is det.
+
+handle_query_from_existing_server(Cmd, Pref, ToServerPipe, FromServerPipe,
+ MutexFile, WantFile, Options) -->
+ { lookup_bool_option(Options, debug, Debug) },
+ send_term(ToServerPipe, Debug, cmd_pref(Cmd, Pref)),
+ release_lock(Debug, MutexFile),
+ remove_want_file(WantFile),
+ recv_string(FromServerPipe, Debug, ResponseFileName),
+ { CatCmd = string__format("cat %s", [s(ResponseFileName)]) },
+ io__call_system(CatCmd, _),
+ (
+ { Debug = yes }
+ % Leave the response file to be examined.
;
- { error("mdprof_cgi to: couldn't open pipe") }
+ { Debug = no },
+ { RmCmd = string__format("rm %s", [s(ResponseFileName)]) },
+ io__call_system(RmCmd, _)
).
- % Read a response from the server.
-:- pred from(string::in, resp::out, io__state::di, io__state::uo) is det.
+% Handle the given query and then become the new server. Delete the mutex
+% and want files when we get out of the critical region.
-from(FromServerPipeName, Resp) -->
- io__see(FromServerPipeName, Res0),
- ( { Res0 = ok } ->
- io__read(Res1),
- ( { Res1 = ok(Resp0) } ->
- { Resp = Resp0 }
+:- pred handle_query_from_new_server(cmd::in, preferences::in, string::in,
+ string::in, string::in, string::in, string::in, string::in,
+ option_table::in, io__state::di, io__state::uo) is cc_multi.
+
+handle_query_from_new_server(Cmd, Pref, FileName, ToServerPipe, FromServerPipe,
+ StartupFile, MutexFile, WantFile, Options) -->
+ server_name(Machine),
+ { lookup_bool_option(Options, canonical_clique, Canonical) },
+ { lookup_bool_option(Options, server_process, ServerProcess) },
+ { lookup_bool_option(Options, debug, Debug) },
+ { lookup_bool_option(Options, record_startup, RecordStartup) },
+ (
+ { RecordStartup = yes },
+ io__open_output(StartupFile, StartupStreamRes),
+ (
+ { StartupStreamRes = ok(StartupStream0) },
+ { MaybeStartupStream = yes(StartupStream0) },
+ register_file_for_cleanup(StartupFile)
;
- { error("mdprof_cgi from: read failed") }
+ { StartupStreamRes = error(_) },
+ { error("cannot create startup file") }
+ )
+ ;
+ { RecordStartup = no },
+ { MaybeStartupStream = no }
),
- io__seen
+ read_and_startup(Machine, [FileName], Canonical, MaybeStartupStream,
+ Res),
+ (
+ { Res = ok(Deep) },
+ try_exec(Cmd, Pref, Deep, HTML),
+ (
+ { MaybeStartupStream = yes(StartupStream1) },
+ io__format(StartupStream1, "query 0 output:\n%s\n",
+ [s(HTML)]),
+ % If we don't flush the output before the fork, it will
+ % be flushed twice, once by the parent process and
+ % once by the child process.
+ io__flush_output(StartupStream1)
+ ;
+ { MaybeStartupStream = no }
+ ),
+ (
+ { ServerProcess = no },
+ % --no-server process should be specified only during
+ % debugging.
+ release_lock(Debug, MutexFile),
+ remove_want_file(WantFile),
+ io__write_string(HTML)
+ ;
+ { ServerProcess = yes },
+ make_pipes(FileName, Success),
+ (
+ { Success = yes },
+ io__write_string(HTML),
+ io__flush_output,
+ start_server(Options,
+ ToServerPipe, FromServerPipe,
+ MaybeStartupStream,
+ MutexFile, WantFile, Deep)
+ ;
+ { Success = no },
+ release_lock(Debug, MutexFile),
+ remove_want_file(WantFile),
+ io__set_exit_status(1),
+ io__write_string("could not make pipes\n")
+ )
+ )
;
- { error("mdprof_cgi from: couldn't open pipe") }
+ { Res = error(Error) },
+ release_lock(Debug, MutexFile),
+ remove_want_file(WantFile),
+ io__set_exit_status(1),
+ io__format("error reading data file: %s\n", [s(Error)])
).
+
+% Become the new server. Delete the mutex and want files when we get out
+% of the critical region.
+
+:- pred start_server(option_table::in, string::in, string::in,
+ maybe(io__output_stream)::in, string::in, string::in, deep::in,
+ io__state::di, io__state::uo) is cc_multi.
+
+start_server(Options, ToServerPipe, FromServerPipe, MaybeStartupStream,
+ MutexFile, WantFile, Deep) -->
+ { lookup_bool_option(Options, detach_process, DetachProcess) },
+ { lookup_bool_option(Options, record_loop, RecordLoop) },
+ { lookup_bool_option(Options, debug, Debug) },
+ (
+ { DetachProcess = no },
+ % We behave as if we were in the child, to allow the server
+ % loop to be debugged.
+ { DetachRes = in_child(child_has_no_parent) }
+ ;
+ { DetachProcess = yes },
+ detach_process(DetachRes)
+ ),
+ (
+ { DetachRes = in_child(ChildHasParent) } ->
+ % We are in the child; start serving queries.
+ (
+ { ChildHasParent = child_has_parent },
+ % Our parent process will perform the file removals
+ % needed to exit the critical section; we don't
+ % want to duplicate them. We also don't want to delete
+ % the pipes we need or the startup file.
+ unregister_file_for_cleanup(MutexFile),
+ unregister_file_for_cleanup(WantFile)
+ ;
+ { ChildHasParent = child_has_no_parent },
+ % We don't actually have a parent process, so we need
+ % to perform the file removals needed to exit the
+ % critical section ourselves.
+ release_lock(Debug, MutexFile),
+ remove_want_file(WantFile)
+ ),
+ (
+ { RecordLoop = yes },
+ { MaybeDebugStream = MaybeStartupStream }
+ ;
+ { RecordLoop = no },
+ { MaybeDebugStream = no }
+ ),
+ { lookup_int_option(Options, timeout, TimeOut) },
+ { lookup_bool_option(Options, canonical_clique, Canonical) },
+ server_loop(ToServerPipe, FromServerPipe, TimeOut,
+ MaybeDebugStream, Debug, Canonical, 0, Deep)
+ ;
+ { DetachRes = in_parent } ->
+ % We are in the parent after we spawned the child. We cause
+ % the process to exit simply by not calling server_loop.
+ %
+ % We leave the pipes and the startup file; we clean up only
+ % the files involved in the critical section.
+ release_lock(Debug, MutexFile),
+ remove_want_file(WantFile)
+ ;
+ % We are in the parent because the fork failed. Again we cause
+ % the process to exit simply by not calling server_loop, but we
+ % also report the failure through the exit status. We don't
+ % report it via the generated web page, since the cause could
+ % be transitory and may not recur.
+ %
+ % This deletes all the files created by the process, including
+ % WantFile and MutexFile, with MutexFile being deleted last.
+ delete_cleanup_files,
+ io__set_exit_status(1)
+ ).
+
+:- pred server_loop(string::in, string::in, int::in,
+ maybe(io__output_stream)::in, bool::in, bool::in, int::in, deep::in,
+ io__state::di, io__state::uo) is cc_multi.
+
+server_loop(ToServerPipe, FromServerPipe, TimeOut0, MaybeStartupStream,
+ Debug, Canonical, QueryNum0, Deep0) -->
+ setup_timeout(TimeOut0),
+ { QueryNum = QueryNum0 + 1 },
+ recv_term(ToServerPipe, Debug, CmdPref0),
+ (
+ { MaybeStartupStream = yes(StartupStream0) },
+ io__format(StartupStream0, "server loop query %d\n",
+ [i(QueryNum)]),
+ io__write(StartupStream0, CmdPref0),
+ io__nl(StartupStream0),
+ io__flush_output(StartupStream0)
+ ;
+ { MaybeStartupStream = no }
+ ),
+ { CmdPref0 = cmd_pref(Cmd0, Pref0) },
+ ( { Cmd0 = restart } ->
+ read_and_startup(Deep0 ^ server_name, [Deep0 ^ data_file_name],
+ Canonical, MaybeStartupStream, MaybeDeep),
+ (
+ { MaybeDeep = ok(Deep) },
+ { MaybeMsg = no },
+ { Cmd = menu }
+ ;
+ { MaybeDeep = error(ErrorMsg) },
+ { MaybeMsg = yes(ErrorMsg) },
+ { Deep = Deep0 },
+ { Cmd = quit }
+ )
+ ;
+ { Deep = Deep0 },
+ { MaybeMsg = no },
+ { Cmd = Cmd0 }
+ ),
+ (
+ { MaybeMsg = yes(HTML) }
+ ;
+ { MaybeMsg = no },
+ try_exec(Cmd, Pref0, Deep, HTML)
+ ),
+
+ { ResponseFileName =
+ response_file_name(Deep0 ^ data_file_name, QueryNum) },
+ io__open_output(ResponseFileName, ResponseRes),
+ (
+ { ResponseRes = ok(ResponseStream) }
+ ;
+ { ResponseRes = error(_) },
+ { error("cannot open response file") }
+ ),
+ io__write_string(ResponseStream, HTML),
+ io__close_output(ResponseStream),
+
+ send_string(FromServerPipe, Debug, ResponseFileName),
+
+ (
+ { MaybeStartupStream = yes(StartupStream1) },
+ io__format(StartupStream1, "query %d output:\n%s\n",
+ [i(QueryNum), s(HTML)]),
+ io__flush_output(StartupStream1)
+ ;
+ { MaybeStartupStream = no }
+ ),
+
+ ( { Cmd = quit } ->
+ % The lack of a recursive call here shuts down the server.
+ %
+ % This deletes all the files created by the process, including
+ % WantFile and MutexFile, with MutexFile being deleted last.
+ delete_cleanup_files
+ ; { Cmd = timeout(TimeOut) } ->
+ server_loop(ToServerPipe, FromServerPipe, TimeOut,
+ MaybeStartupStream, Debug, Canonical, QueryNum, Deep)
+ ;
+ server_loop(ToServerPipe, FromServerPipe, TimeOut0,
+ MaybeStartupStream, Debug, Canonical, QueryNum, Deep)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pred make_pipes(string::in, bool::out, io__state::di, io__state::uo) is det.
+
+make_pipes(FileName, Success) -->
+ { ToServerPipe = to_server_pipe_name(FileName) },
+ { FromServerPipe = from_server_pipe_name(FileName) },
+ { MakeToServerPipeCmd = make_pipe_cmd(ToServerPipe) },
+ { MakeFromServerPipeCmd = make_pipe_cmd(FromServerPipe) },
+ io__call_system(MakeToServerPipeCmd, ToServerRes),
+ io__call_system(MakeFromServerPipeCmd, FromServerRes),
+ (
+ { ToServerRes = ok(0) },
+ { FromServerRes = ok(0) }
+ ->
+ register_file_for_cleanup(ToServerPipe),
+ register_file_for_cleanup(FromServerPipe),
+ { Success = yes }
+ ;
+ % In case one of the pipes was created.
+ io__remove_file(ToServerPipe, _),
+ io__remove_file(FromServerPipe, _),
+ { Success = no }
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pragma foreign_decl("C", "
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+").
+
+:- pragma foreign_decl("C", "
+#include <stdio.h>
+#include <stdlib.h>
+#include <unistd.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+").
+
+:- pred check_for_existing_fifos(string::in, string::in, int::out,
+ io__state::di, io__state::uo) is det.
+
+:- pragma foreign_proc("C",
+ check_for_existing_fifos(Fifo1::in, Fifo2::in, FifoCount::out,
+ S0::di, S::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io],
+"
+ struct stat statbuf;
+ int status;
+
+ FifoCount = 0;
+ status = stat(Fifo1, &statbuf);
+ if ((status == 0) && (S_ISFIFO(statbuf.st_mode))) {
+ FifoCount++;
+ }
+ status = stat(Fifo2, &statbuf);
+ if ((status == 0) && (S_ISFIFO(statbuf.st_mode))) {
+ FifoCount++;
+ }
+
+ S = S0;
+").
+
+:- type child_has_parent
+ ---> child_has_parent
+ ; child_has_no_parent.
+
+:- type detach_process_result
+ ---> in_child(child_has_parent)
+ ; in_parent
+ ; fork_failed.
+
+:- pred detach_process(detach_process_result::out,
+ io__state::di, io__state::uo) is cc_multi.
+
+detach_process(Result) -->
+ raw_detach_process(ResCode),
+ { ResCode < 0 ->
+ Result = fork_failed
+ ; ResCode > 0 ->
+ Result = in_parent
+ ;
+ Result = in_child(child_has_parent)
+ }.
+
+% Raw_detach_process performs a fork.
+%
+% If the fork succeeds, the result returned by detach_process is:
+%
+% - a positive number in the parent, and
+% - zero in the child.
+%
+% If the fork fails, the result returned by detach_process is:
+%
+% - a negative number in the parent (there is no child process).
+
+:- pred raw_detach_process(int::out, io__state::di, io__state::uo) is cc_multi.
+
+:- pragma foreign_proc("C",
+ raw_detach_process(ResCode::out, S0::di, S::uo),
+ [will_not_call_mercury, promise_pure],
+"{
+ pid_t status;
+
+ fflush(stdout);
+ fflush(stderr);
+ status = fork();
+ if (status < 0) {
+ ResCode = -1;
+ } else if (status > 0) {
+ ResCode = 1;
+ } else {
+#ifdef MR_HAVE_SETPGID
+ /* detach the server process from the parent's process group */
+ setpgid(0, 0);
+#else
+ /* hope that web server doesn't depend on the process group */
+#endif
+ ResCode = 0;
+ }
+
+ S = S0;
+}").
+
+%-----------------------------------------------------------------------------%
+
+:- type option
+ ---> canonical_clique
+ ; clique
+ ; debug
+ ; detach_process
+ ; modules
+ ; proc
+ ; quit
+ ; root
+ ; record_startup
+ ; record_loop
+ ; server_process
+ ; timeout
+ ; write_query_string.
+
+:- type options ---> options.
+:- type option_table == (option_table(option)).
+
+:- pred short(char::in, option::out) is semidet.
+
+short('c', canonical_clique).
+short('C', clique).
+short('d', debug).
+short('m', modules).
+short('p', proc).
+short('q', quit).
+short('r', root).
+short('s', server_process).
+short('t', timeout).
+short('w', write_query_string).
+
+:- pred long(string::in, option::out) is semidet.
+
+long("canonical-clique", canonical_clique).
+long("clique", clique).
+long("debug", debug).
+long("detach-process", detach_process).
+long("modules", modules).
+long("proc", proc).
+long("quit", quit).
+long("root", root).
+long("record-startup", record_startup).
+long("record-loop", record_loop).
+long("server-process", server_process).
+long("timeout", timeout).
+long("write-query-string", write_query_string).
+
+:- pred defaults(option::out, option_data::out) is nondet.
+
+defaults(Option, Data) :-
+ semidet_succeed,
+ defaults0(Option, Data).
+
+:- pred defaults0(option::out, option_data::out) is multi.
+
+defaults0(canonical_clique, bool(no)).
+defaults0(clique, int(0)).
+defaults0(debug, bool(no)).
+defaults0(detach_process, bool(yes)).
+defaults0(modules, bool(no)).
+defaults0(proc, int(0)).
+defaults0(quit, bool(no)).
+defaults0(root, bool(no)).
+defaults0(record_loop, bool(yes)).
+defaults0(record_startup, bool(yes)).
+defaults0(server_process, bool(yes)).
+defaults0(timeout, int(30)).
+defaults0(write_query_string, bool(yes)).
+
+:- func default_cmd(option_table) = cmd.
+
+default_cmd(Options) = Cmd :-
+ lookup_bool_option(Options, quit, Quit),
+ lookup_bool_option(Options, root, Root),
+ lookup_bool_option(Options, modules, Modules),
+ lookup_int_option(Options, clique, CliqueNum),
+ lookup_int_option(Options, proc, ProcNum),
+ ( Root = yes ->
+ Cmd = root(no)
+ ; Modules = yes ->
+ Cmd = modules
+ ; CliqueNum > 0 ->
+ Cmd = clique(CliqueNum)
+ ; ProcNum > 0 ->
+ Cmd = proc(ProcNum)
+ ; Quit = yes ->
+ Cmd = quit
+ ;
+ Cmd = menu
+ ).
+
+%-----------------------------------------------------------------------------%
Index: deep_profiler/mdprof_server.m
===================================================================
RCS file: deep_profiler/mdprof_server.m
diff -N deep_profiler/mdprof_server.m
--- deep_profiler/mdprof_server.m 3 Jul 2001 08:16:18 -0000 1.2
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,163 +0,0 @@
-%-----------------------------------------------------------------------------%
-% Copyright (C) 2001 The University of Melbourne.
-% This file may only be copied under the terms of the GNU General
-% Public License - see the file COPYING in the Mercury distribution.
-%-----------------------------------------------------------------------------%
-%
-% Authors: conway, zs.
-%
-% This file defines the top level predicates of the server process of the
-% Mercury deep profiler. It is mostly concerned with option handling.
-
-:- module mdprof_server.
-
-:- interface.
-
-:- import_module io.
-
-:- pred main(io__state::di, io__state::uo) is cc_multi.
-
-:- implementation.
-
-:- import_module conf, interface.
-:- import_module profile, read_profile, startup, timeout, server.
-:- import_module array, bool, char, getopt, int, list, assoc_list.
-:- import_module map, require, set, std_util, string, require.
-
-:- type option
- ---> canonical_clique
- ; debug
- ; test
- ; test_dir
- ; timeout.
-
-:- type options ---> options.
-:- type option_table == (option_table(option)).
-
-main -->
- io__stderr_stream(StdErr),
- io__report_stats,
- io__write_string(StdErr, " Handling options...\n"),
- io__command_line_arguments(Args0),
- { getopt__process_options(option_ops(short, long, defaults),
- Args0, Args, MaybeOptions) },
- (
- { MaybeOptions = ok(Options) },
- ( { Args = [] } ->
- io__set_exit_status(1),
- io__write_string(StdErr,
- "no data file name specified\n")
- ;
- main2(Args, Options)
- )
- ;
- { MaybeOptions = error(Msg) },
- io__set_exit_status(1),
- io__format(StdErr, "error parsing options: %s\n", [s(Msg)])
- ).
-
-:- pred main2(list(string)::in, option_table::in,
- io__state::di, io__state::uo) is cc_multi.
-
-main2(FileNames, Options) -->
- io__stderr_stream(StdErr),
- server_name(Machine),
- { lookup_bool_option(Options, test, Test) },
- { lookup_bool_option(Options, canonical_clique, CanonicalClique) },
- (
- { Test = yes },
- read_and_startup(Machine, FileNames, CanonicalClique, Res),
- (
- { Res = ok(Deep) },
- { lookup_string_option(Options, test_dir, TestDir) },
- { Pref = default_preferences },
- test_server(TestDir, Pref, Deep)
- ;
- { Res = error(Error) },
- io__set_exit_status(1),
- io__format(StdErr, "error reading data file: %s\n",
- [s(Error)])
- )
- ;
- { Test = no },
- make_pipes(FileNames, IsOK),
- (
- { IsOK = yes },
- read_and_startup(Machine, FileNames, CanonicalClique,
- Res),
- (
- { Res = ok(Deep) },
- { lookup_int_option(Options, timeout,
- TimeOut) },
- { lookup_bool_option(Options, debug, Debug) },
- server(TimeOut, Debug, CanonicalClique, Deep)
- ;
- { Res = error(Error) },
- io__set_exit_status(1),
- io__format(StdErr,
- "error reading data file: %s\n",
- [s(Error)])
- )
- ;
- { IsOK = no },
- io__set_exit_status(1),
- io__write_string(StdErr,
- "could not make pipes to CGI script\n")
- )
- ).
-
-:- pred make_pipes(list(string)::in, bool::out, io__state::di, io__state::uo)
- is det.
-
-make_pipes(FileNames, OK) -->
- ( { FileNames = [FileName] } ->
- { InputPipe = to_server_pipe_name(FileName) },
- { OutputPipe = from_server_pipe_name(FileName) },
- { MakeInputPipeCmd = make_pipe_cmd(InputPipe) },
- { MakeOutputPipeCmd = make_pipe_cmd(OutputPipe) },
- io__call_system(MakeInputPipeCmd, InputRes),
- io__call_system(MakeOutputPipeCmd, OutputRes),
- (
- { InputRes = ok(0) },
- { OutputRes = ok(0) }
- ->
- { OK = yes },
- { StartupFile = server_startup_name(FileName) },
- setup_exit(InputPipe, OutputPipe, StartupFile)
- ;
- { OK = no }
- )
- ;
- { error("make_pipes: multiple filenames not yet implemented") }
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred short(char::in, option::out) is semidet.
-
-short('c', canonical_clique).
-short('D', test_dir).
-short('t', timeout).
-short('T', test).
-
-:- pred long(string::in, option::out) is semidet.
-
-long("canonical-clique",canonical_clique).
-long("debug", debug).
-long("test", test).
-long("test-dir", test_dir).
-long("timeout", timeout).
-
-:- pred defaults(option::out, option_data::out) is nondet.
-
-defaults(Option, Data) :-
- semidet_succeed,
- defaults0(Option, Data).
-
-:- pred defaults0(option::out, option_data::out) is multi.
-
-defaults0(canonical_clique, bool(no)).
-defaults0(debug, bool(yes)).
-defaults0(test, bool(no)).
-defaults0(test_dir, string("deep_test")).
-defaults0(timeout, int(30)).
Index: deep_profiler/mdprof_test.m
===================================================================
RCS file: deep_profiler/mdprof_test.m
diff -N deep_profiler/mdprof_test.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ deep_profiler/mdprof_test.m 12 Nov 2002 13:00:30 -0000
@@ -0,0 +1,180 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2002 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% Author: zs.
+%
+% This file contains a tool for testing the behavior of the deep profiler.
+
+:- module mdprof_test.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is cc_multi.
+
+:- implementation.
+
+:- import_module profile, interface, startup, query, conf, timeout, util.
+:- import_module bool, char, string, int, array, list, set.
+:- import_module require, std_util, getopt.
+
+:- import_module int, string, list, array, exception, require.
+
+main -->
+ io__progname_base("mdprof_tool", ProgName),
+ io__command_line_arguments(Args0),
+ { getopt__process_options(option_ops(short, long, defaults),
+ Args0, Args, MaybeOptions) },
+ (
+ { MaybeOptions = ok(Options) },
+ ( { Args = [FileName] } ->
+ { lookup_bool_option(Options, canonical_clique,
+ Canonical) },
+ server_name(Machine),
+ read_and_startup(Machine, [FileName], Canonical, no,
+ Res),
+ (
+ { Res = ok(Deep) },
+ main2(Options, Deep)
+ ;
+ { Res = error(Error) },
+ io__set_exit_status(1),
+ io__format("%s: error reading data file: %s\n",
+ [s(ProgName), s(Error)])
+ )
+ ;
+ io__set_exit_status(1),
+ io__format("Usage: %s [options*] filename\n",
+ [s(ProgName)])
+ )
+ ;
+ { MaybeOptions = error(Msg) },
+ io__set_exit_status(1),
+ io__format("%s: error parsing options: %s\n",
+ [s(ProgName), s(Msg)])
+ ).
+
+:- pred main2(option_table::in, deep::in, io__state::di, io__state::uo)
+ is cc_multi.
+
+main2(Options, Deep) -->
+ { lookup_bool_option(Options, test, Test) },
+ (
+ { Test = no }
+ ;
+ { Test = yes },
+ { lookup_string_option(Options, test_dir, TestDir) },
+ test_server(TestDir, default_preferences, Deep)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pred test_server(string::in, preferences::in, deep::in,
+ io__state::di, io__state::uo) is cc_multi.
+
+test_server(DirName, Pref, Deep) -->
+ { string__format("test -d %s || mkdir -p %s",
+ [s(DirName), s(DirName)], Cmd) },
+ io__call_system(Cmd, _),
+ { array__max(Deep ^ clique_members, NumCliques) },
+ test_cliques(1, NumCliques, DirName, Pref, Deep),
+ { array__max(Deep ^ proc_statics, NumProcStatics) },
+ test_procs(1, NumProcStatics, DirName, Pref, Deep).
+
+:- pred test_cliques(int::in, int::in, string::in, preferences::in, deep::in,
+ io__state::di, io__state::uo) is cc_multi.
+
+test_cliques(Cur, Max, DirName, Pref, Deep) -->
+ ( { Cur =< Max } ->
+ try_exec(clique(Cur), Pref, Deep, HTML),
+ write_test_html(DirName, "clique", Cur, HTML),
+ test_cliques(Cur + 1, Max, DirName, Pref, Deep)
+ ;
+ []
+ ).
+
+:- pred test_procs(int::in, int::in, string::in, preferences::in, deep::in,
+ io__state::di, io__state::uo) is cc_multi.
+
+test_procs(Cur, Max, DirName, Pref, Deep) -->
+ ( { Cur =< Max } ->
+ try_exec(proc(Cur), Pref, Deep, HTML),
+ write_test_html(DirName, "proc", Cur, HTML),
+ test_procs(Cur + 1, Max, DirName, Pref, Deep)
+ ;
+ []
+ ).
+
+:- pred write_test_html(string::in, string::in, int::in, string::in,
+ io__state::di, io__state::uo) is det.
+
+write_test_html(DirName, BaseName, Num, HTML) -->
+ % For large programs such as the Mercury compiler, the profiler data
+ % file may contain hundreds of thousands of cliques. We therefore put
+ % each batch of pages in a different subdirectory, thus limiting the
+ % number of files/subdirs in each directory.
+ { Bunch = (Num - 1) // 1000 },
+ { string__format("%s/%s_%04d",
+ [s(DirName), s(BaseName), i(Bunch)], BunchName) },
+ ( { (Num - 1) rem 1000 = 0 } ->
+ { string__format("test -p %s || mkdir -p %s",
+ [s(BunchName), s(BunchName)], Cmd) },
+ io__call_system(Cmd, _)
+ ;
+ []
+ ),
+ { string__format("%s/%s_%06d.html",
+ [s(BunchName), s(BaseName), i(Num)], FileName) },
+ io__open_output(FileName, Res),
+ (
+ { Res = ok(Stream) },
+ io__write_string(Stream, HTML),
+ io__close_output(Stream),
+ { string__format("gzip %s", [s(FileName)], GzipCmd) },
+ io__call_system(GzipCmd, _)
+ ;
+ { Res = error(Err) },
+ { io__error_message(Err, ErrMsg) },
+ { error(ErrMsg) }
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- type option
+ ---> canonical_clique
+ ; flat
+ ; test
+ ; test_dir.
+
+:- type options ---> options.
+:- type option_table == (option_table(option)).
+
+:- pred short(char::in, option::out) is semidet.
+
+short('c', canonical_clique).
+short('D', test_dir).
+short('T', test).
+
+:- pred long(string::in, option::out) is semidet.
+
+long("canonical-clique", canonical_clique).
+long("test", test).
+long("test-dir", test_dir).
+
+:- pred defaults(option::out, option_data::out) is nondet.
+
+defaults(Option, Data) :-
+ semidet_succeed,
+ defaults0(Option, Data).
+
+:- pred defaults0(option::out, option_data::out) is multi.
+
+defaults0(canonical_clique, bool(no)).
+defaults0(test, bool(no)).
+defaults0(test_dir, string("deep_test")).
+
+%-----------------------------------------------------------------------------%
Index: deep_profiler/query.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/query.m,v
retrieving revision 1.3
diff -u -b -r1.3 query.m
--- deep_profiler/query.m 18 Jul 2001 04:38:05 -0000 1.3
+++ deep_profiler/query.m 5 Sep 2002 13:35:42 -0000
@@ -16,8 +16,8 @@
:- import_module profile, interface.
:- import_module io.
-:- pred exec(cmd::in, preferences::in, deep::in, string::out,
- io__state::di, io__state::uo) is det.
+:- pred try_exec(cmd::in, preferences::in, deep::in, string::out,
+ io__state::di, io__state::uo) is cc_multi.
%-----------------------------------------------------------------------------%
@@ -25,9 +25,31 @@
:- import_module measurements, top_procs, html_format, exclude.
:- import_module std_util, bool, int, float, char, string.
-:- import_module array, list, assoc_list, set, map, require.
+:- import_module array, list, assoc_list, set, map, exception, require.
%-----------------------------------------------------------------------------%
+
+try_exec(Cmd, Pref, Deep, HTML, IO0, IO) :-
+ try_io(exec(Cmd, Pref, Deep), Result, IO0, IO),
+ (
+ Result = succeeded(HTML)
+ ;
+ Result = exception(Exception),
+ ( univ_to_type(Exception, MsgPrime) ->
+ Msg = MsgPrime
+ ; univ_to_type(Exception, software_error(MsgPrime)) ->
+ Msg = MsgPrime
+ ;
+ Msg = "unknown exception"
+ ),
+ HTML =
+ string__format(
+ "<H3>AN EXCEPTION HAS OCCURRED: %s</H3>\n",
+ [s(Msg)])
+ ).
+
+:- pred exec(cmd::in, preferences::in, deep::in, string::out,
+ io__state::di, io__state::uo) is det.
exec(restart, _Pref, _Deep, _HTML, IO, IO) :-
% Our caller is supposed to filter out restart commands.
Index: deep_profiler/server.m
===================================================================
RCS file: deep_profiler/server.m
diff -N deep_profiler/server.m
--- deep_profiler/server.m 12 Mar 2002 09:55:14 -0000 1.8
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,271 +0,0 @@
-%-----------------------------------------------------------------------------%
-% Copyright (C) 2001 The University of Melbourne.
-% This file may only be copied under the terms of the GNU General
-% Public License - see the file COPYING in the Mercury distribution.
-%-----------------------------------------------------------------------------%
-%
-% Authors: conway, zs.
-%
-% This module contains the main server loop of the Mercury deep profiler:
-% each iteration of the server loop serves up one web page.
-%
-% The module also contains test code for checking that all the web pages
-% can be created without runtime aborts.
-
-:- module server.
-
-:- interface.
-
-:- import_module profile, interface.
-:- import_module bool, io.
-
-:- pred test_server(string::in, preferences::in, deep::in,
- io__state::di, io__state::uo) is cc_multi.
-
-:- pred server(int::in, bool::in, bool::in, deep::in,
- io__state::di, io__state::uo) is cc_multi.
-
-:- implementation.
-
-:- import_module query, startup, timeout.
-:- import_module std_util, int, string, array, list, exception, require.
-
-%-----------------------------------------------------------------------------%
-
-test_server(DirName, Pref, Deep) -->
- { string__format("test -d %s || mkdir -p %s",
- [s(DirName), s(DirName)], Cmd) },
- io__call_system(Cmd, _),
- { array__max(Deep ^ clique_members, NumCliques) },
- test_cliques(1, NumCliques, DirName, Pref, Deep),
- { array__max(Deep ^ proc_statics, NumProcStatics) },
- test_procs(1, NumProcStatics, DirName, Pref, Deep).
-
-:- pred test_cliques(int::in, int::in, string::in, preferences::in, deep::in,
- io__state::di, io__state::uo) is cc_multi.
-
-test_cliques(Cur, Max, DirName, Pref, Deep) -->
- ( { Cur =< Max } ->
- try_exec(clique(Cur), Pref, Deep, HTML),
- write_html(DirName, "clique", Cur, HTML),
- test_cliques(Cur + 1, Max, DirName, Pref, Deep)
- ;
- []
- ).
-
-:- pred test_procs(int::in, int::in, string::in, preferences::in, deep::in,
- io__state::di, io__state::uo) is cc_multi.
-
-test_procs(Cur, Max, DirName, Pref, Deep) -->
- ( { Cur =< Max } ->
- try_exec(proc(Cur), Pref, Deep, HTML),
- write_html(DirName, "proc", Cur, HTML),
- test_procs(Cur + 1, Max, DirName, Pref, Deep)
- ;
- []
- ).
-
-:- pred write_html(string::in, string::in, int::in, string::in,
- io__state::di, io__state::uo) is det.
-
-write_html(DirName, BaseName, Num, HTML) -->
- % For large programs such as the Mercury compiler, the profiler data
- % file may contain hundreds of thousands of cliques. We therefore put
- % each batch of pages in a different subdirectory, thus limiting the
- % number of files/subdirs in each directory.
- { Bunch = (Num - 1) // 1000 },
- { string__format("%s/%s_%04d",
- [s(DirName), s(BaseName), i(Bunch)], BunchName) },
- ( { (Num - 1) rem 1000 = 0 } ->
- { string__format("test -p %s || mkdir -p %s",
- [s(BunchName), s(BunchName)], Cmd) },
- io__call_system(Cmd, _)
- ;
- []
- ),
- { string__format("%s/%s_%06d.html",
- [s(BunchName), s(BaseName), i(Num)], FileName) },
- io__tell(FileName, _),
- io__write_string(HTML),
- io__told.
-
-%-----------------------------------------------------------------------------%
-
-server(TimeOut, Debug, CanonicalClique, Deep) -->
- { DataFileName = Deep ^ data_file_name },
- { InputPipe = to_server_pipe_name(DataFileName) },
- { OutputPipe = from_server_pipe_name(DataFileName) },
- % Comment out the following line if you want to debug query processing.
- % Otherwise, the process started by mdb will exit before the first
- % query is read.
- detach_server_loop,
- server_loop(InputPipe, OutputPipe, TimeOut, Debug, CanonicalClique,
- 0, Deep).
-
-:- pragma foreign_decl("C", "
-#include <stdio.h>
-#include <stdlib.h>
-#include <unistd.h>
-").
-
-:- pred detach_server_loop(io__state::di, io__state::uo) is cc_multi.
-
-:- pragma foreign_proc("C", detach_server_loop(S0::di, S::uo),
- [will_not_call_mercury, promise_pure], "
-{
- int status;
-
- S = S0;
- fflush(stdout);
- fflush(stderr);
- status = fork();
- if (status < 0) {
- /*
- ** The fork failed; we cannot detach the server loop from the
- ** startup process. The cgi script would therefore wait forever
- ** if we did not exit now.
- */
-
- exit(1);
- } else if (status > 0) {
- /*
- ** The fork succeeded; we are in the parent. We therefore exit
- ** now to let the io__call_system in the cgi script succeed.
- */
-
- extern MR_bool MP_process_is_detached_server;
-
- MP_process_is_detached_server = MR_TRUE;
- exit(0);
- }
-
- /*
- ** Else the fork succeeded; we are in the child. We continue
- ** executing, and start serving answers to queries.
- */
-}").
-
-:- pred server_loop(string::in, string::in, int::in, bool::in,
- bool::in, int::in, deep::in, io__state::di, io__state::uo) is cc_multi.
-
-server_loop(InputPipe, OutputPipe, TimeOut, Debug, CanonicalClique,
- QueryNum, Deep0) -->
- setup_timeout(TimeOut),
- io__see(InputPipe, SeeRes),
- (
- { SeeRes = ok },
- io__read(ReadRes),
- stderr_stream(StdErr),
- (
- { Debug = yes },
- io__write(StdErr, ReadRes),
- io__nl(StdErr)
- ;
- { Debug = no }
- ),
- (
- { ReadRes = eof },
- (
- { Debug = yes },
- write_string(StdErr, "eof.\n")
- ;
- { Debug = no }
- ),
- server_loop(InputPipe, OutputPipe, TimeOut, Debug,
- CanonicalClique, QueryNum + 1, Deep0)
- ;
- { ReadRes = error(Msg, Line) },
- (
- { Debug = yes },
- io__format(StdErr,
- "error reading input line %d: %s\n",
- [i(Line), s(Msg)])
- ;
- { Debug = no }
- ),
- server_loop(InputPipe, OutputPipe, TimeOut, Debug,
- CanonicalClique, QueryNum + 1, Deep0)
- ;
- { ReadRes = ok(CmdPref0) },
- { CmdPref0 = cmd_pref(Cmd0, Pref0) },
- ( { Cmd0 = restart } ->
- read_and_startup(Deep0 ^ server_name,
- [Deep0 ^ data_file_name],
- CanonicalClique, MaybeDeep),
- (
- { MaybeDeep = ok(Deep) },
- { Cmd = menu }
- ;
- { MaybeDeep = error(Msg) },
- io__tell(OutputPipe, _),
- io__write(html(Msg)),
- io__write_string(".\n"),
- io__told,
- { Deep = Deep0 },
- { Cmd = quit }
- )
- ;
- { Deep = Deep0 },
- { Cmd = Cmd0 }
- ),
- try_exec(Cmd, Pref0, Deep, HTML),
- (
- { Debug = yes },
- io__format(StdErr, "query %d output:\n%s\n",
- [i(QueryNum), s(HTML)])
- ;
- { Debug = no }
- ),
-
- % If we can't open the output pipe, then we have
- % no way to report our failure anyway.
- io__tell(OutputPipe, _),
- io__write(html(HTML)),
- io__write_string(".\n"),
- io__told,
- ( { Cmd = quit } ->
- % The lack of a recursive call here shuts down
- % the server process.
- []
- ; { Cmd = timeout(NewTimeOut) } ->
- server_loop(InputPipe, OutputPipe, NewTimeOut,
- Debug, CanonicalClique,
- QueryNum + 1, Deep)
- ;
- server_loop(InputPipe, OutputPipe, TimeOut,
- Debug, CanonicalClique,
- QueryNum + 1, Deep)
- )
- )
- ;
- { SeeRes = error(Error) },
- { io__error_message(Error, Msg) },
- io__write_string(Msg),
- io__set_exit_status(1)
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred try_exec(cmd::in, preferences::in, deep::in, string::out,
- io__state::di, io__state::uo) is cc_multi.
-
-try_exec(Cmd, Pref, Deep, HTML, IO0, IO) :-
- try_io(exec(Cmd, Pref, Deep), Result, IO0, IO),
- (
- Result = succeeded(HTML)
- ;
- Result = exception(Exception),
- ( univ_to_type(Exception, MsgPrime) ->
- Msg = MsgPrime
- ; univ_to_type(Exception, software_error(MsgPrime)) ->
- Msg = MsgPrime
- ;
- Msg = "unknown exception"
- ),
- HTML =
- string__format(
- "<H3>AN EXCEPTION HAS OCCURRED: %s</H3>\n",
- [s(Msg)])
- ).
-
-%-----------------------------------------------------------------------------%
Index: deep_profiler/startup.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/startup.m,v
retrieving revision 1.5
diff -u -b -r1.5 startup.m
--- deep_profiler/startup.m 18 Jul 2001 04:38:05 -0000 1.5
+++ deep_profiler/startup.m 13 Nov 2002 16:17:33 -0000
@@ -1,5 +1,5 @@
%-----------------------------------------------------------------------------%
-% Copyright (C) 2001 The University of Melbourne.
+% Copyright (C) 2001-2002 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
@@ -19,7 +19,8 @@
:- import_module io, bool, list, std_util.
:- pred read_and_startup(string::in, list(string)::in, bool::in,
- maybe_error(deep)::out, io__state::di, io__state::uo) is det.
+ maybe(io__output_stream)::in, maybe_error(deep)::out,
+ io__state::di, io__state::uo) is det.
%-----------------------------------------------------------------------------%
@@ -28,24 +29,26 @@
:- import_module profile, read_profile, callgraph, canonical.
:- import_module measurements, array_util.
:- import_module std_util, int, string, array, assoc_list, set, map, require.
+:- import_module unsafe.
-read_and_startup(Machine, DataFileNames, CanonicalClique, Res) -->
+read_and_startup(Machine, DataFileNames, Canonical, MaybeOutputStream, Res) -->
(
{ DataFileNames = [] },
% This should have been caught and reported by main.
{ error("read_and_startup: no data files") }
;
{ DataFileNames = [DataFileName] },
- io__stderr_stream(StdErr),
- io__report_stats,
- io__write_string(StdErr, " Reading graph data...\n"),
+ maybe_report_stats(MaybeOutputStream),
+ maybe_report_msg(MaybeOutputStream,
+ " Reading graph data...\n"),
read_call_graph(DataFileName, Res0),
- io__write_string(StdErr, " Done.\n"),
- io__report_stats,
+ maybe_report_msg(MaybeOutputStream,
+ " Done.\n"),
+ maybe_report_stats(MaybeOutputStream),
(
{ Res0 = ok(InitDeep) },
- startup(Machine, DataFileName, CanonicalClique,
- InitDeep, Deep),
+ startup(Machine, DataFileName, Canonical,
+ MaybeOutputStream, InitDeep, Deep),
{ Res = ok(Deep) }
;
{ Res0 = error(Error) },
@@ -56,47 +59,48 @@
{ error("mdprof_server: merging of data files is not yet implemented") }
).
-:- pred startup(string::in, string::in, bool::in, initial_deep::in, deep::out,
- io__state::di, io__state::uo) is det.
-
-startup(Machine, DataFileName, CanonicalClique, InitDeep0, Deep) -->
- stderr_stream(StdErr),
+:- pred startup(string::in, string::in, bool::in, maybe(io__output_stream)::in,
+ initial_deep::in, deep::out, io__state::di, io__state::uo) is det.
+startup(Machine, DataFileName, Canonical, MaybeOutputStream, InitDeep0, Deep)
+ -->
{ InitDeep0 = initial_deep(InitStats, Root,
CallSiteDynamics0, ProcDynamics,
CallSiteStatics0, ProcStatics0) },
- io__format(StdErr,
- " Mapping static call sites to containing procedures...\n",
- []),
+ maybe_report_msg(MaybeOutputStream,
+ " Mapping static call sites to containing procedures...\n"),
{ array_foldl2_from_1(record_css_containers_module_procs, ProcStatics0,
u(CallSiteStatics0), CallSiteStatics,
map__init, ModuleProcs) },
- io__format(StdErr, " Done.\n", []),
- io__report_stats,
+ maybe_report_msg(MaybeOutputStream,
+ " Done.\n"),
+ maybe_report_stats(MaybeOutputStream),
- io__format(StdErr,
- " Mapping dynamic call sites to containing procedures...\n",
- []),
+ maybe_report_msg(MaybeOutputStream,
+ " Mapping dynamic call sites to containing procedures...\n"),
{ array_foldl2_from_1(record_csd_containers_zeroed_pss, ProcDynamics,
u(CallSiteDynamics0), CallSiteDynamics,
u(ProcStatics0), ProcStatics) },
- io__format(StdErr, " Done.\n", []),
- io__report_stats,
+ maybe_report_msg(MaybeOutputStream,
+ " Done.\n"),
+ maybe_report_stats(MaybeOutputStream),
{ InitDeep1 = initial_deep(InitStats, Root,
CallSiteDynamics, ProcDynamics,
CallSiteStatics, ProcStatics) },
(
- { CanonicalClique = no },
+ { Canonical = no },
{ InitDeep = InitDeep1 }
;
- { CanonicalClique = yes },
- io__format(StdErr, " Canonicalizing cliques...\n", []),
+ { Canonical = yes },
+ maybe_report_msg(MaybeOutputStream,
+ " Canonicalizing cliques...\n"),
{ canonicalize_cliques(InitDeep1, InitDeep) },
- io__format(StdErr, " Done.\n", []),
- io__report_stats
+ maybe_report_msg(MaybeOutputStream,
+ " Done.\n"),
+ maybe_report_stats(MaybeOutputStream)
),
{ array__max(InitDeep ^ init_proc_dynamics, PDMax) },
@@ -108,19 +112,22 @@
{ array__max(InitDeep ^ init_call_site_statics, CSSMax) },
{ NCSSs = CSSMax + 1 },
- io__format(StdErr, " Finding cliques...\n", []),
- flush_output(StdErr),
+ maybe_report_msg(MaybeOutputStream,
+ " Finding cliques...\n"),
{ find_cliques(InitDeep, CliqueList) },
- io__format(StdErr, " Done.\n", []),
- io__report_stats,
+ maybe_report_msg(MaybeOutputStream,
+ " Done.\n"),
+ maybe_report_stats(MaybeOutputStream),
- io__format(StdErr, " Constructing clique indexes...\n", []),
- flush_output(StdErr),
+ maybe_report_msg(MaybeOutputStream,
+ " Constructing clique indexes...\n"),
{ make_clique_indexes(NPDs, CliqueList, Cliques, CliqueIndex) },
- io__format(StdErr, " Done.\n", []),
- io__report_stats,
+ maybe_report_msg(MaybeOutputStream,
+ " Done.\n"),
+ maybe_report_stats(MaybeOutputStream),
- io__format(StdErr, " Constructing clique parent map...\n", []),
+ maybe_report_msg(MaybeOutputStream,
+ " Constructing clique parent map...\n"),
% For each CallSiteDynamic pointer, if it points to
% a ProcDynamic which is in a different clique to
@@ -138,31 +145,39 @@
CliqueParents0, CliqueParents,
CliqueMaybeChildren0, CliqueMaybeChildren) },
- io__format(StdErr, " Done.\n", []),
- io__report_stats,
+ maybe_report_msg(MaybeOutputStream,
+ " Done.\n"),
+ maybe_report_stats(MaybeOutputStream),
- io__format(StdErr, " Finding procedure callers...\n", []),
+ maybe_report_msg(MaybeOutputStream,
+ " Finding procedure callers...\n"),
{ array__init(NPSs, [], ProcCallers0) },
{ array_foldl_from_1(construct_proc_callers(InitDeep),
CallSiteDynamics, ProcCallers0, ProcCallers) },
- io__format(StdErr, " Done.\n", []),
- io__report_stats,
+ maybe_report_msg(MaybeOutputStream,
+ " Done.\n"),
+ maybe_report_stats(MaybeOutputStream),
- io__format(StdErr, " Constructing call site static map...\n", []),
+ maybe_report_msg(MaybeOutputStream,
+ " Constructing call site static map...\n"),
{ array__init(NCSDs, call_site_static_ptr(-1), CallSiteStaticMap0) },
{ array_foldl_from_1(construct_call_site_caller(InitDeep),
ProcDynamics, CallSiteStaticMap0, CallSiteStaticMap) },
- io__format(StdErr, " Done.\n", []),
- io__report_stats,
+ maybe_report_msg(MaybeOutputStream,
+ " Done.\n"),
+ maybe_report_stats(MaybeOutputStream),
- io__format(StdErr, " Finding call site calls...\n", []),
+ maybe_report_msg(MaybeOutputStream,
+ " Finding call site calls...\n"),
{ array__init(NCSSs, map__init, CallSiteCalls0) },
{ array_foldl_from_1(construct_call_site_calls(InitDeep),
ProcDynamics, CallSiteCalls0, CallSiteCalls) },
- io__format(StdErr, " Done.\n", []),
- io__report_stats,
+ maybe_report_msg(MaybeOutputStream,
+ " Done.\n"),
+ maybe_report_stats(MaybeOutputStream),
- io__format(StdErr, " Propagating time up call graph...\n", []),
+ maybe_report_msg(MaybeOutputStream,
+ " Propagating time up call graph...\n"),
{ array__init(NCSDs, zero_inherit_prof_info, CSDDesc0) },
{ array__init(NPDs, zero_own_prof_info, PDOwn0) },
@@ -186,15 +201,18 @@
PDCompTable0, CSDCompTable0, ModuleData) },
{ array_foldl_from_1(propagate_to_clique, Cliques, Deep0, Deep1) },
- io__format(StdErr, " Done.\n", []),
- io__report_stats,
+ maybe_report_msg(MaybeOutputStream,
+ " Done.\n"),
+ maybe_report_stats(MaybeOutputStream),
- io__format(StdErr, " Summarizing information...\n", []),
+ maybe_report_msg(MaybeOutputStream,
+ " Summarizing information...\n"),
{ summarize_proc_dynamics(Deep1, Deep2) },
{ summarize_call_site_dynamics(Deep2, Deep3) },
{ summarize_modules(Deep3, Deep) },
- io__format(StdErr, " Done.\n", []),
- io__report_stats.
+ maybe_report_msg(MaybeOutputStream,
+ " Done.\n"),
+ maybe_report_stats(MaybeOutputStream).
:- pred count_quanta(int::in, call_site_dynamic::in, int::in, int::out) is det.
@@ -206,6 +224,7 @@
initialize_module_data(_ModuleName, PSPtrs) =
module_data(zero_own_prof_info, zero_inherit_prof_info, PSPtrs).
+
%-----------------------------------------------------------------------------%
:- pred record_css_containers_module_procs(int::in, proc_static::in,
@@ -330,6 +349,8 @@
array(maybe(clique_ptr))::array_di,
array(maybe(clique_ptr))::array_uo) is det.
+% :- pragma promise_pure(construct_clique_parents_2/8).
+
construct_clique_parents_2(InitDeep, CliqueIndex, ParentCliquePtr, CSDPtr,
CliqueParents0, CliqueParents,
CliqueMaybeChildren0, CliqueMaybeChildren) :-
@@ -342,6 +363,9 @@
array__lookup(CliqueIndex, ChildPDI, ChildCliquePtr),
( ChildCliquePtr \= ParentCliquePtr ->
ChildCliquePtr = clique_ptr(ChildCliqueNum),
+ % impure unsafe_perform_io(
+ % write_pdi_cn_csd(ChildPDI,
+ % ChildCliqueNum, CSDI)),
array__set(CliqueParents0, ChildCliqueNum,
CSDPtr, CliqueParents),
array__set(CliqueMaybeChildren0, CSDI,
@@ -840,3 +864,96 @@
).
%-----------------------------------------------------------------------------%
+
+:- pred maybe_report_stats(maybe(io__output_stream)::in,
+ io__state::di, io__state::uo) is det.
+
+maybe_report_stats(yes(_)) --> [].
+ % io__report_stats("standard"). XXX
+maybe_report_stats(no) --> [].
+
+:- pred maybe_report_msg(maybe(io__output_stream)::in, string::in,
+ io__state::di, io__state::uo) is det.
+
+maybe_report_msg(yes(OutputStream), Msg) -->
+ io__write_string(OutputStream, Msg),
+ flush_output(OutputStream).
+maybe_report_msg(no, _) --> [].
+
+%-----------------------------------------------------------------------------%
+
+% Predicates for use in debugging.
+
+% :- pred print_pdis(initial_deep::in, list(int)::in,
+% io__state::di, io__state::uo) is det.
+%
+% print_pdis(InitDeep, PDIs) -->
+% io__nl,
+% io__write_list(PDIs, "", print_pdi_nl(InitDeep)).
+%
+% :- pred print_pdi_nl(initial_deep::in, int::in, io__state::di, io__state::uo)
+% is det.
+%
+% print_pdi_nl(InitDeep, PDI) -->
+% print_pdi(InitDeep, PDI),
+% io__nl.
+%
+% :- pred print_pdi(initial_deep::in, int::in, io__state::di, io__state::uo)
+% is det.
+%
+% print_pdi(InitDeep, PDI) -->
+% { PDIsTmp = InitDeep ^ init_proc_dynamics },
+% { lookup_proc_dynamics(PDIsTmp, proc_dynamic_ptr(PDI), PD) },
+% io__format("pd %d: ", [i(PDI)]),
+% io__write(PD),
+% io__nl,
+% { proc_static_ptr(PSI) = PD ^ pd_proc_static },
+% { PSIsTmp = InitDeep ^ init_proc_statics },
+% { lookup_proc_statics(PSIsTmp, proc_static_ptr(PSI), PS) },
+% io__format("ps %d: ", [i(PSI)]),
+% io__write(PS),
+% io__nl.
+%
+% :- pred print_csdis(initial_deep::in, list(int)::in,
+% io__state::di, io__state::uo) is det.
+%
+% print_csdis(InitDeep, CSDIs) -->
+% io__nl,
+% io__write_list(CSDIs, "", print_csdi_nl(InitDeep)).
+%
+% :- pred print_csdi_nl(initial_deep::in, int::in, io__state::di, io__state::uo)
+% is det.
+%
+% print_csdi_nl(InitDeep, CSDI) -->
+% print_csdi(InitDeep, CSDI),
+% io__nl.
+%
+% :- pred print_csdi(initial_deep::in, int::in, io__state::di, io__state::uo)
+% is det.
+%
+% print_csdi(InitDeep, CSDI) -->
+% { CSDIsTmp = InitDeep ^ init_call_site_dynamics },
+% { lookup_call_site_dynamics(CSDIsTmp, call_site_dynamic_ptr(CSDI),
+% CSD) },
+% io__format("csd %d: ", [i(CSDI)]),
+% io__write(CSD),
+% io__nl,
+% io__write_string("caller pd:\n"),
+% { proc_dynamic_ptr(CallerPDI) = CSD ^ csd_caller },
+% print_pdi(InitDeep, CallerPDI),
+% io__write_string("callee pd:\n"),
+% { proc_dynamic_ptr(CalleePDI) = CSD ^ csd_callee },
+% print_pdi(InitDeep, CalleePDI).
+%
+% :- pred write_pdi_cn_csd(int::in, int::in, int::in,
+% io__state::di, io__state::uo) is det.
+%
+% write_pdi_cn_csd(PDI, CN, CSDI) -->
+% io__write_string("pdi "),
+% io__write_int(PDI),
+% io__write_string(", cn "),
+% io__write_int(CN),
+% io__write_string(", csdi "),
+% io__write_int(CSDI),
+% io__nl,
+% io__flush_output.
Index: deep_profiler/timeout.m
===================================================================
RCS file: /home/mercury1/repository/mercury/deep_profiler/timeout.m,v
retrieving revision 1.7
diff -u -b -r1.7 timeout.m
--- deep_profiler/timeout.m 18 Feb 2002 07:01:00 -0000 1.7
+++ deep_profiler/timeout.m 13 Nov 2002 12:15:12 -0000
@@ -1,32 +1,20 @@
%-----------------------------------------------------------------------------%
-% Copyright (C) 2001 The University of Melbourne.
+% Copyright (C) 2001-2002 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
%
% Author: zs.
%
-% This module implements timeouts for the deep profiler.
+% This module implements timeouts and cleanup for the deep profiler.
%
-% The deep profiler uses timeouts to shut down the server process if the
-% programmer has not sent it queries in a while. Before shutdown, we remove the
-% named pipes that the CGI script and the server process use to communicate.
-% Any later invocation of the CGI script will take the absence of the named
-% pipes as indicating that there is no server process for the given data file,
-% and will create a new server process, which will recreate the named pipes.
+% The timeout design we use and its rationale are given in the file DESIGN.
%
-% Since the receipt of the alarm signal, the removal the pipes and exiting
-% is not an atomic action, there is a potential race condition. However,
-% there is no simple, portable way to eliminate the race condition, and the
-% window of vulnerability is quite small.
-%
-% This module also sets up the automatic execution of the timeout action
-% when the process exits, for use both when the user explicitly requests
-% the shutdown of the server (which will of course happen after startup)
-% and in case of program aborts (which may happen both before and after
-% startup). However, immediately after startup is complete, the server
-% process forks, with the parent exiting to let mdprof_cgi's wait finish,
-% and the child entering a loop waiting for requests.
+% The cleanup system consists of an array of filenames. When the profiler
+% creates a temporary file, it adds its name to the array; when it deletes
+% the temporary file, it deletes its name from the array. When we get an
+% unexpected signal, we clean up by deleting all the temporary files named
+% in the array. The
%
% We establish the exit action to clean up the files as soon as they are
% created, but we don't want the parent process after the fork to delete them
@@ -37,13 +25,57 @@
:- interface.
-:- import_module io.
+:- import_module bool, io.
+
+% Add the given file name to the list of files to be cleaned up.
+
+:- pred register_file_for_cleanup(string::in, io__state::di, io__state::uo)
+ is det.
+
+% Remove the given file name from the list of files to be cleaned up.
+
+:- pred unregister_file_for_cleanup(string::in, io__state::di, io__state::uo)
+ is det.
+
+% Remove all file names from the list of files to be cleaned up.
+
+:- pred unregister_all_files_for_cleanup(io__state::di, io__state::uo) is det.
-:- pred setup_exit(string::in, string::in, string::in,
+% Delete all the files on the cleanup list.
+
+:- pred delete_cleanup_files(io__state::di, io__state::uo) is det.
+
+% Set up signal handlers for all the signals we can catch. The three strings
+% specify the name of the mutex file, the name of the directory containing the
+% `want' files, and the prefix of the names of the `want' files.
+
+:- pred setup_signals(string::in, string::in, string::in,
io__state::di, io__state::uo) is det.
+% Set up a timeout for the given number of minutes in the future.
+
:- pred setup_timeout(int::in, io__state::di, io__state::uo) is det.
+% Get the lock on the named mutex file if the bool is `no'.
+% If the bool is `yes', meaning debugging is enabled, do nothing.
+
+:- pred get_lock(bool::in, string::in,
+ io__state::di, io__state::uo) is det.
+
+% Release the lock on the named mutex file if the bool is `no'.
+% If the bool is `yes', meaning debugging is enabled, do nothing.
+
+:- pred release_lock(bool::in, string::in,
+ io__state::di, io__state::uo) is det.
+
+% Create the `want' file with the given name.
+
+:- pred make_want_file(string::in, io__state::di, io__state::uo) is det.
+
+% Delete the `want' file with the given name.
+
+:- pred remove_want_file(string::in, io__state::di, io__state::uo) is det.
+
:- implementation.
:- import_module int.
@@ -51,29 +83,199 @@
:- pragma foreign_decl("C",
"
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
#include <stdio.h>
#include <signal.h> /* for signal numbers */
#include <unistd.h> /* for alarm() */
#include <stdlib.h> /* for atexit() */
+#include <errno.h> /* for EEXIST etc */
#include ""mercury_signal.h""
-extern char *MP_timeout_file1;
-extern char *MP_timeout_file2;
-extern char *MP_timeout_file3;
-
-extern const int MP_signal_numbers[];
-
-extern void MP_delete_timeout_files(void);
-extern void MP_delete_timeout_files_and_exit_success(void);
-extern void MP_delete_timeout_files_and_exit_failure(void);
+#define MP_MAX_CLEANUP_FILES 20 /* this should be plenty */
+
+extern const char *MP_cleanup_files[MP_MAX_CLEANUP_FILES];
+extern int MP_cleanup_file_next;
+
+extern void MP_maybe_print_cleanup_files(const char *msg);
+extern void MP_register_cleanup_file(const char *filename);
+extern void MP_unregister_cleanup_file(const char *filename);
+extern void MP_handle_fatal_exception(void *data);
+extern void MP_delete_cleanup_files(void);
+extern void MP_delete_cleanup_files_and_exit_failure(
+ const char *signal_name);
+
+extern int MP_timeout_seconds;
+extern const char *MP_timeout_mutex_file;
+extern const char *MP_timeout_want_dir;
+extern const char *MP_timeout_want_prefix;
+
+typedef struct
+{
+ int MP_signum;
+ void (*MP_handler)(void);
+} MP_sig_handler;
+
+extern const MP_sig_handler MP_signal_structs[];
+
+extern void MP_handle_timeout(void);
+
+extern void MP_handle_sig_term(void);
+extern void MP_handle_sig_hup(void);
+extern void MP_handle_sig_int(void);
+extern void MP_handle_sig_quit(void);
+extern void MP_handle_sig_ill(void);
+extern void MP_handle_sig_abrt(void);
+extern void MP_handle_sig_bus(void);
+extern void MP_handle_sig_fpe(void);
+extern void MP_handle_sig_segv(void);
+extern void MP_handle_sig_pipe(void);
+
+extern MR_bool MP_do_try_get_lock(const char *mutex_file);
+extern void MP_do_get_lock(const char *mutex_file);
+extern void MP_do_release_lock(const char *mutex_file);
").
:- pragma foreign_code("C",
"
-MR_bool MP_process_is_detached_server = MR_FALSE;
-char *MP_timeout_file1;
-char *MP_timeout_file2;
-char *MP_timeout_file3;
+#if defined(MR_HAVE_DIRENT_H)
+ #include <sys/types.h>
+ #include <dirent.h>
+#else
+ /* if we get here, the deep profiler isn't enabled */
+#endif
+
+const char *MP_cleanup_files[MP_MAX_CLEANUP_FILES];
+int MP_cleanup_file_next = 0;
+
+int MP_timeout_seconds = 30 * 60;
+const char *MP_timeout_mutex_file = NULL;
+const char *MP_timeout_want_dir = NULL;
+const char *MP_timeout_want_prefix = NULL;
+
+/* set this variable to MR_TRUE to debug the code cleanup array */
+MR_bool MP_print_cleanup_files = MR_FALSE;
+
+void
+MP_maybe_print_cleanup_files(const char *msg)
+{
+ int i;
+
+ if (MP_print_cleanup_files) {
+ fprintf(stderr, ""\n%s cleanup files:\n"", msg);
+ for (i = 0; i < MP_cleanup_file_next; i++) {
+ fprintf(stderr, ""%i %s\n"", i, MP_cleanup_files[i]);
+ }
+ }
+}
+
+void
+MP_register_cleanup_file(const char *filename)
+{
+ int i;
+
+ if (MP_cleanup_file_next >= MP_MAX_CLEANUP_FILES - 1) {
+ MR_fatal_error(""MP_register_cleanup_file: too many entries"");
+ }
+
+ for (i = 0; i < MP_cleanup_file_next; i++) {
+ if (MR_streq(filename, MP_cleanup_files[i])) {
+ MR_fatal_error(""MP_register_cleanup_file: duplicate"");
+ }
+ }
+
+ MP_cleanup_files[MP_cleanup_file_next] = filename;
+ MP_cleanup_file_next++;
+ MP_maybe_print_cleanup_files(""register"");
+}
+
+void
+MP_unregister_cleanup_file(const char *filename)
+{
+ int i;
+ int j;
+
+ for (i = 0; i < MP_cleanup_file_next; i++) {
+ if (MR_streq(filename, MP_cleanup_files[i])) {
+ /* shift the array entries above index i down one */
+ for (j = i + 1; j < MP_cleanup_file_next; j++) {
+ MP_cleanup_files[j - 1] = MP_cleanup_files[j];
+ }
+
+ MP_cleanup_file_next--;
+ MP_maybe_print_cleanup_files(""unregister"");
+ return;
+ }
+ }
+
+ MR_fatal_error(""MP_unregister_cleanup_file: not found"");
+}
+
+void
+MP_handle_fatal_exception(void *data)
+{
+ /* we ignore data */
+ MP_delete_cleanup_files();
+}
+
+void
+MP_delete_cleanup_files(void)
+{
+ int i;
+ MR_bool delayed_mutex_file;
+
+ /*
+ ** We want to remove the mutex file only after we have removed the
+ ** files manipulated by the critical section it was protecting.
+ */
+
+ MP_maybe_print_cleanup_files(""delete"");
+
+ delayed_mutex_file = MR_FALSE;
+ for (i = 0; i < MP_cleanup_file_next; i++) {
+ if (MR_streq(MP_timeout_mutex_file, MP_cleanup_files[i])) {
+ delayed_mutex_file = MR_TRUE;
+ } else {
+ if (remove(MP_cleanup_files[i]) != 0) {
+ perror(MP_cleanup_files[i]);
+ }
+ }
+ }
+
+ if (delayed_mutex_file) {
+ if (remove(MP_timeout_mutex_file) != 0) {
+ perror(MP_timeout_mutex_file);
+ }
+ }
+
+ MP_cleanup_file_next = 0;
+}
+
+void
+MP_delete_cleanup_files_and_exit_failure(const char *signal_name)
+{
+ FILE *fp;
+ char buf[1024]; /* that should be big enough */
+
+#ifdef MP_DEBUG_SIGNAL
+ fp = fopen(""/tmp/mdprof_signal"", ""w"");
+ if (fp != NULL) {
+ fprintf(fp, ""%s\n"", signal_name);
+ (void) fclose(fp);
+ }
+#endif
+
+ MP_delete_cleanup_files();
+
+#ifdef MP_DEBUG_SIGNAL
+ sprintf(buf, ""Mercury deep profiler: received unexpected signal %s"",
+ signal_name);
+ MR_fatal_error(buf);
+#else
+ exit(EXIT_FAILURE);
+#endif
+}
/*
** SIGALRM alarm signal indicates a timeout. SIGTERM usually indicates the
@@ -93,113 +295,337 @@
** its actions even when the program exits after a signal.
*/
-const int MP_signal_numbers[] =
+const MP_sig_handler MP_signal_structs[] =
{
- SIGALRM,
+ { SIGALRM, MP_handle_timeout },
#ifdef SIGTERM
- SIGTERM,
+ { SIGTERM, MP_handle_sig_term },
#endif
#ifdef SIGHUP
- SIGHUP,
+ { SIGHUP, MP_handle_sig_hup },
#endif
#ifdef SIGINT
- SIGINT,
+ { SIGINT, MP_handle_sig_int },
#endif
#ifdef SIGQUIT
- SIGQUIT,
+ { SIGQUIT, MP_handle_sig_quit },
#endif
#ifdef SIGILL
- SIGILL,
+ { SIGILL, MP_handle_sig_ill },
#endif
#ifdef SIGABRT
- SIGABRT,
+ { SIGABRT, MP_handle_sig_abrt },
#endif
#ifdef SIGBUS
- SIGBUS,
+ { SIGBUS, MP_handle_sig_bus },
#endif
#ifdef SIGFPE
- SIGFPE,
+ { SIGFPE, MP_handle_sig_fpe },
#endif
#ifdef SIGSEGV
- SIGSEGV,
+ { SIGSEGV, MP_handle_sig_segv },
#endif
#ifdef SIGPIPE
- SIGPIPE,
+ { SIGPIPE, MP_handle_sig_pipe },
#endif
- -1
+ { -1, NULL }
};
void
-MP_delete_timeout_files(void)
+MP_handle_timeout(void)
{
- if (! MP_process_is_detached_server) {
- if (remove(MP_timeout_file1) != 0) {
- perror(MP_timeout_file1);
- }
+#if defined(MR_HAVE_DIRENT_H) && defined(MR_HAVE_OPENDIR) \
+ && defined(MR_HAVE_READDIR) && defined(MR_HAVE_CLOSEDIR)
- if (remove(MP_timeout_file2) != 0) {
- perror(MP_timeout_file2);
+ DIR *dir;
+ struct dirent *dirent;
+ int matchlen;
+ MR_bool success;
+
+ if (MP_timeout_want_dir == NULL || MP_timeout_want_prefix == NULL) {
+ MR_fatal_error(""MP_handle_timeout: null dir or prefix"");
}
+ matchlen = strlen(MP_timeout_want_prefix);
+
+ success = MP_do_try_get_lock(MP_timeout_mutex_file);
+ if (! success) {
/*
- if (remove(MP_timeout_file3) != 0) {
- perror(MP_timeout_file3);
+ ** We could not get the lock, so some other process holds it.
+ ** We therefore abort the timeout, but schedule the next one.
+ */
+
+ (void) alarm(MP_timeout_seconds);
+ return;
}
+
+ dir = opendir(MP_timeout_want_dir);
+ if (dir == NULL) {
+ MR_fatal_error(""MP_handle_timeout: opendir failed"");
+ }
+
+ while ((dirent = readdir(dir)) != NULL) {
+ if (MR_strneq(dirent->d_name, MP_timeout_want_prefix,
+ matchlen))
+ {
+ /* abort the timeout */
+ (void) closedir(dir);
+ (void) alarm(MP_timeout_seconds);
+ return;
+ }
+ }
+
+ (void) closedir(dir);
+
+ /*
+ ** This call will delete the mutex file last, releasing the mutex
*/
+ MP_delete_cleanup_files();
+ exit(EXIT_SUCCESS);
+
+#else
+ /* if we get here, the deep profiler isn't enabled */
+#endif
+}
+
+void
+MP_handle_sig_term(void)
+{
+ MP_delete_cleanup_files_and_exit_failure(""SIGTERM"");
+}
+
+void
+MP_handle_sig_hup(void)
+{
+ MP_delete_cleanup_files_and_exit_failure(""SIGHUP"");
+}
+
+void
+MP_handle_sig_int(void)
+{
+ MP_delete_cleanup_files_and_exit_failure(""SIGINT"");
+}
+
+void
+MP_handle_sig_quit(void)
+{
+ MP_delete_cleanup_files_and_exit_failure(""SIGQUIT"");
+}
+
+void
+MP_handle_sig_ill(void)
+{
+ MP_delete_cleanup_files_and_exit_failure(""SIGILL"");
+}
+
+void
+MP_handle_sig_abrt(void)
+{
+ MP_delete_cleanup_files_and_exit_failure(""SIGABRT"");
+}
+
+void
+MP_handle_sig_bus(void)
+{
+ MP_delete_cleanup_files_and_exit_failure(""SIGBUS"");
+}
+
+void
+MP_handle_sig_fpe(void)
+{
+ MP_delete_cleanup_files_and_exit_failure(""SIGFPE"");
+}
+
+void
+MP_handle_sig_segv(void)
+{
+ MP_delete_cleanup_files_and_exit_failure(""SIGSEGV"");
+}
+
+void
+MP_handle_sig_pipe(void)
+{
+ MP_delete_cleanup_files_and_exit_failure(""SIGPIPE"");
+}
+
+MR_bool
+MP_do_try_get_lock(const char *mutex_file)
+{
+ int res;
+ MR_bool success;
+
+ res = open(mutex_file, O_CREAT | O_EXCL, 0);
+ if (res >= 0) {
+ (void) close(res);
+ MP_register_cleanup_file(mutex_file);
+ success = MR_TRUE;
+ } else if (res < 0 && errno == EEXIST) {
+ success = MR_FALSE;
+ } else {
+ MR_fatal_error(""MP_do_try_get_lock failed"");
}
+
+ return res;
}
void
-MP_delete_timeout_files_and_exit_success(void)
+MP_do_get_lock(const char *mutex_file)
{
- MP_delete_timeout_files();
- exit(EXIT_SUCCESS);
+ int res;
+
+ for (;;) {
+ res = open(mutex_file, O_CREAT | O_EXCL, 0);
+ if (res >= 0) {
+ (void) close(res);
+ MP_register_cleanup_file(mutex_file);
+ return;
+ } else if (res < 0 && errno == EEXIST) {
+ sleep(5);
+ continue;
+ } else {
+ MR_fatal_error(""MP_do_get_lock failed"");
+ }
+ }
}
void
-MP_delete_timeout_files_and_exit_failure(void)
+MP_do_release_lock(const char *mutex_file)
{
- MP_delete_timeout_files();
- exit(EXIT_FAILURE);
+ MP_unregister_cleanup_file(mutex_file);
+ (void) unlink(mutex_file);
}
").
:- pragma foreign_proc("C",
- setup_exit(File1::in, File2::in, File3::in, IO0::di, IO::uo),
+ register_file_for_cleanup(File::in, S0::di, S::uo),
[will_not_call_mercury, promise_pure],
"
- int i;
- void (*handler)(void);
+ MP_register_cleanup_file(File);
+ S = S0;
+").
- MP_timeout_file1 = File1;
- MP_timeout_file2 = File2;
- MP_timeout_file3 = File3;
-
- for (i = 0; MP_signal_numbers[i] >= 0; i++) {
- if (MP_signal_numbers[i] == SIGALRM) {
- handler = MP_delete_timeout_files_and_exit_success;
- } else {
- handler = MP_delete_timeout_files_and_exit_failure;
- }
+:- pragma foreign_proc("C",
+ unregister_file_for_cleanup(File::in, S0::di, S::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ MP_unregister_cleanup_file(File);
+ S = S0;
+").
+
+:- pragma foreign_proc("C",
+ unregister_all_files_for_cleanup(S0::di, S::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ MP_cleanup_file_next = 0;
+ S = S0;
+").
- MR_setup_signal(MP_signal_numbers[i], handler, MR_FALSE,
+:- pragma foreign_proc("C",
+ delete_cleanup_files(S0::di, S::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ MP_delete_cleanup_files();
+ S = S0;
+").
+
+:- pragma foreign_proc("C",
+ setup_signals(MutexFile::in, WantDir::in, WantPrefix::in,
+ S0::di, S::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ int i;
+
+ MP_timeout_mutex_file = MutexFile;
+ MP_timeout_want_dir = WantDir;
+ MP_timeout_want_prefix = WantPrefix;
+
+ for (i = 0; MP_signal_structs[i].MP_signum >= 0; i++) {
+ MR_setup_signal(MP_signal_structs[i].MP_signum,
+ MP_signal_structs[i].MP_handler, MR_FALSE,
""Mercury deep profiler: cannot setup signal exit"");
}
- if (atexit(MP_delete_timeout_files) != 0) {
- MR_fatal_error(""Mercury deep profiler: cannot setup exit"");
- }
+ /*
+ ** Mercury exceptions do not cause signals. The default exception
+ ** handler prints and error message and exits. To ensure that
+ ** we delete up the files we need to clean up, we get the exit
+ ** library function to invoke MP_delete_cleanup_files through
+ ** MP_handle_fatal_exception.
+ */
+
+ MR_register_exception_cleanup(MP_handle_fatal_exception, NULL);
+
+ S = S0;
+").
+
+:- pragma foreign_proc("C",
+ setup_timeout(Minutes::in, S0::di, S::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ MP_timeout_seconds = Minutes * 60;
+ (void) alarm(MP_timeout_seconds);
+ S = S0;
+").
+
+%-----------------------------------------------------------------------------%
+
+get_lock(Debug, MutexFile) -->
+ (
+ { Debug = yes }
+ ;
+ { Debug = no },
+ do_get_lock(MutexFile)
+ ).
+
+release_lock(Debug, MutexFile) -->
+ (
+ { Debug = yes }
+ ;
+ { Debug = no },
+ do_release_lock(MutexFile)
+ ).
+
+:- pred do_get_lock(string::in, io__state::di, io__state::uo) is det.
- IO = IO0;
+:- pragma foreign_proc("C",
+ do_get_lock(MutexFile::in, S0::di, S::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io],
+"
+ MP_do_get_lock(MutexFile);
+ S = S0;
+").
+
+:- pred do_release_lock(string::in, io__state::di, io__state::uo)
+ is det.
+
+:- pragma foreign_proc("C",
+ do_release_lock(MutexFile::in, S0::di, S::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io],
+"
+ MP_do_release_lock(MutexFile);
+ S = S0;
").
:- pragma foreign_proc("C",
- setup_timeout(Minutes::in, IO0::di, IO::uo),
+ make_want_file(WantFileName::in, S0::di, S::uo),
[will_not_call_mercury, promise_pure],
"
- int seconds;
+ int fd;
- seconds = Minutes * 60;
- (void) alarm(seconds);
- IO = IO0;
+ fd = open(WantFileName, O_CREAT, 0);
+ if (fd < 0) {
+ MR_fatal_error(""make_want_file: open failed"");
+ }
+ (void) close(fd);
+ MP_register_cleanup_file(WantFileName);
+ S = S0;
+").
+
+:- pragma foreign_proc("C",
+ remove_want_file(WantFileName::in, S0::di, S::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ MP_unregister_cleanup_file(WantFileName);
+ (void) unlink(WantFileName);
+ S = S0;
").
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/aditi
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/stream
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing java
cvs diff: Diffing java/library
cvs diff: Diffing java/runtime
cvs diff: Diffing library
Index: library/exception.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/exception.m,v
retrieving revision 1.72
diff -u -b -r1.72 exception.m
--- library/exception.m 10 Oct 2002 17:55:45 -0000 1.72
+++ library/exception.m 13 Nov 2002 12:03:48 -0000
@@ -1847,6 +1847,8 @@
MR_dump_stack(MR_succip, MR_sp, MR_curfr,
MR_FALSE);
}
+
+ MR_perform_registered_exception_cleanups();
exit(1);
}
}
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
Index: runtime/mercury_conf.h.in
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_conf.h.in,v
retrieving revision 1.46
diff -u -b -r1.46 mercury_conf.h.in
--- runtime/mercury_conf.h.in 24 Oct 2002 16:30:33 -0000 1.46
+++ runtime/mercury_conf.h.in 11 Nov 2002 10:44:59 -0000
@@ -126,6 +126,7 @@
** MR_HAVE_SYS_IOCTL_H we have <sys/ioctl.h>
** MR_HAVE_SYS_STROPTS_H we have <sys/stropts.h>
** MR_HAVE_WINDOWS_H we have <windows.h>
+** MR_HAVE_DIRENT_H we have <dirent.h>
*/
#undef MR_HAVE_SYS_SIGINFO_H
#undef MR_HAVE_SYS_SIGNAL_H
@@ -145,6 +146,7 @@
#undef MR_HAVE_SYS_IOCTL_H
#undef MR_HAVE_SYS_STROPTS_H
#undef MR_HAVE_WINDOWS_H
+#undef MR_HAVE_DIRENT_H
/*
** MR_HAVE_POSIX_TIMES is defined if we have the POSIX
@@ -216,6 +218,9 @@
** MR_HAVE_ACCESS we have the access() function.
** MR_HAVE_SLEEP we have the sleep() function.
** MR_HAVE_CAPITAL_S_SLEEP we have the Sleep() function.
+** MR_HAVE_OPENDIR we have the opendir() function.
+** MR_HAVE_READDIR we have the readdir() function.
+** MR_HAVE_CLOSEDIR we have the closedir() function.
*/
#undef MR_HAVE_GETPID
#undef MR_HAVE_SETPGID
@@ -259,6 +264,9 @@
#undef MR_HAVE_ACCESS
#undef MR_HAVE_SLEEP
#undef MR_HAVE_CAPITAL_S_SLEEP
+#undef MR_HAVE_OPENDIR
+#undef MR_HAVE_READDIR
+#undef MR_HAVE_CLOSEDIR
/*
** We use mprotect() and signals to catch stack and heap overflows.
Index: runtime/mercury_misc.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_misc.c,v
retrieving revision 1.25
diff -u -b -r1.25 mercury_misc.c
--- runtime/mercury_misc.c 30 Sep 2002 06:08:22 -0000 1.25
+++ runtime/mercury_misc.c 13 Nov 2002 12:35:17 -0000
@@ -10,6 +10,7 @@
#endif
#include "mercury_string.h"
#include "mercury_misc.h"
+#include "mercury_array_macros.h"
#include <stdio.h>
#include <stdarg.h>
@@ -117,4 +118,35 @@
MR_hash_string(MR_ConstString s)
{
MR_HASH_STRING_FUNC_BODY
+}
+
+typedef struct {
+ void (*func)(void *);
+ void *data;
+} MR_cleanup_record;
+
+static MR_cleanup_record *MR_cleanup_records = NULL;
+static int MR_cleanup_record_next = 0;
+static int MR_cleanup_record_max = 0;
+
+#define INIT_CLEANUP_RECORD_ARRAY_SIZE 10
+
+void
+MR_register_exception_cleanup(void (*func)(void *), void *data)
+{
+ MR_ensure_room_for_next(MR_cleanup_record, MR_cleanup_record,
+ INIT_CLEANUP_RECORD_ARRAY_SIZE);
+ MR_cleanup_records[MR_cleanup_record_next].func = func;
+ MR_cleanup_records[MR_cleanup_record_next].data = data;
+ MR_cleanup_record_next++;
+}
+
+void
+MR_perform_registered_exception_cleanups(void)
+{
+ int i;
+
+ for (i = 0; i < MR_cleanup_record_next; i++) {
+ MR_cleanup_records[i].func(MR_cleanup_records[i].data);
+ }
}
Index: runtime/mercury_misc.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_misc.h,v
retrieving revision 1.22
diff -u -b -r1.22 mercury_misc.h
--- runtime/mercury_misc.h 18 Feb 2002 07:01:18 -0000 1.22
+++ runtime/mercury_misc.h 13 Nov 2002 12:05:53 -0000
@@ -27,4 +27,9 @@
extern void MR_fatal_error(const char *msg, ...) MR_NO_RETURN;
+extern void MR_register_exception_cleanup(void (*func)(void *),
+ void *data);
+
+extern void MR_perform_registered_exception_cleanups(void);
+
#endif /* not MERCURY_MISC_H */
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list