#include <stdio.h>
#include <string.h>
+#include <libgen.h>
#include <sys/types.h>
+#include <sys/wait.h>
#include <stdlib.h>
#include <unistd.h>
#include <sys/file.h>
#include <sys/param.h>
#include <sys/stat.h>
+#include <signal.h>
+#include <sys/ptrace.h>
+#include <sched.h>
+#include <errno.h>
#if defined(SVR4) || defined(__linux__)
#include <time.h>
#include "interr.h"
#include "monitor.h"
#include "validate.h"
-#if defined GENCGC
-#include "gencgc.h"
-#endif
#include "core.h"
#include "save.h"
#include "lispregs.h"
+#include "thread.h"
+
+#include "genesis/static-symbols.h"
+#include "genesis/symbol.h"
+
#ifdef irix
#include <string.h>
}
}
\f
+/* miscellaneous chattiness */
+
+void
+print_help()
+{
+ puts(
+"SBCL is a Common Lisp programming environment. Ordinarily you shouldn't\n\
+need command line options when you invoke it interactively: you can just\n\
+start it and work with the customary Lisp READ-EVAL-PRINT loop.\n\
+\n\
+One option idiom which is sometimes useful interactively (e.g. when\n\
+exercising a test case for a bug report) is\n\
+ sbcl --sysinit /dev/null --userinit /dev/null\n\
+to keep SBCL from reading any initialization files at startup. And some\n\
+people like to suppress the default startup message:\n\
+ sbcl --noinform\n\
+\n\
+Other options can be useful when you're running SBCL noninteractively,\n\
+e.g. from a script, or if you have a strange system configuration, so\n\
+that SBCL can't by default find one of the files it needs. For\n\
+information on such options, see the sbcl(1) man page.\n\
+\n\
+More information on SBCL can be found on its man page, or at\n\
+<http://sbcl.sf.net/>.\n");
+}
+
+void
+print_version()
+{
+ printf("SBCL %s\n", SBCL_VERSION_STRING);
+}
+
+void
+print_banner()
+{
+ printf(
+"This is SBCL %s, an implementation of ANSI Common Lisp.\n\
+\n\
+SBCL is derived from the CMU CL system created at Carnegie Mellon University.\n\
+Besides software and documentation originally created at Carnegie Mellon\n\
+University, SBCL contains some software originally from the Massachusetts\n\
+Institute of Technology, Symbolics Incorporated, and Xerox Corporation, and\n\
+material contributed by volunteers since the release of CMU CL into the\n\
+public domain. See the CREDITS file in the distribution for more information.\n\
+\n\
+SBCL is a free software system, provided as is, with absolutely no warranty.\n\
+It is mostly in the public domain, but also includes some software copyrighted\n\
+ Massachusetts Institute of Technology, 1986;\n\
+ Symbolics, Inc., 1989, 1990, 1991, 1992; and\n\
+ Xerox Corporation, 1985, 1986, 1987, 1988, 1989, 1990\n\
+used under BSD-style licenses allowing copying only under certain conditions.\n\
+See the COPYING file in the distribution for more information.\n\
+\n\
+More information about SBCL is available at <http://sbcl.sourceforge.net/>.\n\
+", SBCL_VERSION_STRING);
+}
+\f
+int gc_thread_pid;
+FILE *stdlog;
+
+\f
int
main(int argc, char *argv[], char *envp[])
{
lose("more than one core file specified");
} else {
++argi;
- core = copied_string(argv[argi]);
if (argi >= argc) {
lose("missing filename for --core argument");
}
+ core = copied_string(argv[argi]);
++argi;
}
+ } else if (0 == strcmp(arg, "--help")) {
+ /* I think this is the (or a) usual convention: upon
+ * seeing "--help" we immediately print our help
+ * string and exit, ignoring everything else. */
+ print_help();
+ exit(0);
+ } else if (0 == strcmp(arg, "--version")) {
+ /* As in "--help" case, I think this is expected. */
+ print_version();
+ exit(0);
} else if (0 == strcmp(arg, "--end-runtime-options")) {
end_runtime_options = 1;
++argi;
core = copied_existing_filename_or_null(lookhere);
free(lookhere);
} else {
- core = copied_existing_filename_or_null("/usr/lib/sbcl.core");
+ putenv("SBCL_HOME=/usr/local/lib/sbcl/");
+ core = copied_existing_filename_or_null("/usr/local/lib/sbcl/sbcl.core");
if (!core) {
+ putenv("SBCL_HOME=/usr/lib/sbcl/");
core =
- copied_existing_filename_or_null("/usr/local/lib/sbcl.core");
+ copied_existing_filename_or_null("/usr/lib/sbcl/sbcl.core");
}
}
if (!core) {
lose("can't find core file");
}
+ } else {
+ /* If a core was specified and SBCL_HOME is unset, set it */
+ char *sbcl_home = getenv("SBCL_HOME");
+ if (!sbcl_home) {
+ char *envstring, *copied_core, *dir;
+ char *stem = "SBCL_HOME=";
+ copied_core = copied_string(core);
+ dir = dirname(copied_core);
+ envstring = (char *) calloc(strlen(stem) +
+ strlen(dir) +
+ 1,
+ sizeof(char));
+ sprintf(envstring, "%s%s", stem, dir);
+ putenv(envstring);
+ free(copied_core);
+ }
}
if (!noinform) {
- printf(
-"This is SBCL %s, an implementation of ANSI Common Lisp.\n\
-\n\
-SBCL is derived from the CMU CL system created at Carnegie Mellon University.\n\
-Besides software and documentation originally created at Carnegie Mellon\n\
-University, SBCL contains some software originally from the Massachusetts\n\
-Institute of Technology, Symbolics Incorporated, and Xerox Corporation, and\n\
-material contributed by volunteers since the release of CMU CL into the\n\
-public domain. See the CREDITS file in the distribution for more information.\n\
-\n\
-SBCL is a free software system, provided as is, with absolutely no warranty.\n\
-It is mostly in the public domain, but also includes some software copyrighted\n\
- Massachusetts Institute of Technology, 1986;\n\
- Symbolics, Inc., 1989, 1990, 1991, 1992; and\n\
- Xerox Corporation, 1985, 1986, 1987, 1988, 1989, 1990\n\
-used under BSD-style licenses allowing copying only under certain conditions.\n\
-See the COPYING file in the distribution for more information.\n\
-\n\
-More information about SBCL is available at <http://sbcl.sourceforge.net/>.\n\
-", SBCL_VERSION_STRING);
+ print_banner();
fflush(stdout);
}
set_lossage_handler(monitor_or_something);
-#if 0
- os_init();
- gc_init();
- validate();
-#endif
globals_init();
initial_function = load_core_file(core);
SHOW("freeing core");
free(core);
-#if defined GENCGC
- gencgc_pickup_dynamic();
-#else
-#endif
-
-#ifdef BINDING_STACK_POINTER
- SetSymbolValue(BINDING_STACK_POINTER, BINDING_STACK_START);
-#endif
+ gc_initialize_pointers();
interrupt_init();
-
arch_install_interrupt_handlers();
os_install_interrupt_handlers();
-#ifdef PSEUDO_ATOMIC_ATOMIC
- /* Turn on pseudo atomic for when we call into Lisp. */
- SHOW("turning on pseudo atomic");
- SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1));
- SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0));
-#endif
-
/* Convert remaining argv values to something that Lisp can grok. */
SHOW("setting POSIX-ARGV symbol value");
- SetSymbolValue(POSIX_ARGV, alloc_string_list(argv));
+ SetSymbolValue(POSIX_ARGV, alloc_string_list(argv),0);
/* Install a handler to pick off SIGINT until the Lisp system gets
* far enough along to install its own handler. */
sigint_init();
FSHOW((stderr, "/funcalling initial_function=0x%lx\n", initial_function));
- funcall0(initial_function);
+ create_thread(initial_function);
+ /* in a unithread build, create_thread never returns */
+#ifdef LISP_FEATURE_SB_THREAD
+ gc_thread_pid=getpid();
+ parent_loop();
+#endif
+}
+
+static void parent_sighandler(int signum,siginfo_t *info, void *void_context)
+{
+#if 0
+ os_context_t *context = (os_context_t*)void_context;
+ fprintf(stderr,
+ "parent thread got signal %d from %d, maybe_gc_pending=%d\n",
+ signum, info->si_pid,
+ maybe_gc_pending);
+#endif
+}
+
+#ifdef LISP_FEATURE_SB_THREAD
+static void parent_do_garbage_collect(void)
+{
+ int waiting_threads=0;
+ struct thread *th;
+ int status,p;
+
+ for_each_thread(th) {
+ if(ptrace(PTRACE_ATTACH,th->pid,0,0)) {
+ perror("PTRACE_ATTACH");
+ }
+ else waiting_threads++;
+ }
+ stop_the_world=1;
+
+ do {
+ /* not sure if we have to wait for PTRACE_ATTACH to finish
+ * before we can send PTRACE_CONT, so let's play it safe
+ */
+ while(waiting_threads>0) {
+ if((p=waitpid(-1,&status, WUNTRACED|__WALL))>0) {
+ if(WIFEXITED(status) || WIFSIGNALED(status))
+ destroy_thread(find_thread_by_pid(p));
+ else {
+#if 0
+ fprintf(stderr, "wait returned pid %d signal %x\n",
+ p,WSTOPSIG(status));
+#endif
+ if(WSTOPSIG(status)==SIGTRAP) {
+ if(ptrace(PTRACE_CONT,p,0,SIGTRAP))
+ perror("PTRACE_CONT");
+ }
+ else waiting_threads--;
+ }
+ }
+ }
+ for_each_thread(th) {
+ if(SymbolTlValue(PSEUDO_ATOMIC_ATOMIC,th)) {
+ /* restart the child, setting *p-a-i* which will cause it
+ * to go into interrupt_handle_pending as soon as it's
+ * finished being pseudo_atomic. once there it will
+ * signal itself SIGSTOP, which will give us another
+ * event to wait for */
+#if 0
+ fprintf(stderr, "%d was pseudo-atomic, letting it resume \n",
+ th->pid);
+#endif
+ SetTlSymbolValue(PSEUDO_ATOMIC_INTERRUPTED,make_fixnum(1),th);
+ if(ptrace(PTRACE_CONT,th->pid,0,0))
+ perror("PTRACE_CONT");
+ waiting_threads++;
+ }
+ }
+ } while (waiting_threads>0);
+
+ collect_garbage(maybe_gc_pending-1);
+ maybe_gc_pending=0;
+ stop_the_world=0;
+ for_each_thread(th)
+ if(ptrace(PTRACE_DETACH,th->pid,0,0))
+ perror("PTRACE_DETACH");
+}
- /* initial_function() is not supposed to return. */
- lose("Lisp initial_function gave up control.");
- return 0; /* dummy value: return something */
+static void /* noreturn */ parent_loop(void)
+{
+ struct sigaction sa;
+ sigset_t sigset;
+ int status;
+ pid_t pid=0;
+
+ sigemptyset(&sigset);
+
+ sigaddset(&sigset, SIGALRM);
+ sigaddset(&sigset, SIGCHLD);
+ sigprocmask(SIG_UNBLOCK,&sigset,0);
+ sa.sa_handler=parent_sighandler;
+ sa.sa_mask=sigset;
+ sa.sa_flags=SA_SIGINFO;
+ sigaction(SIGALRM, &sa, 0);
+ sigaction(SIGCHLD, &sa, 0);
+
+ sigemptyset(&sigset);
+ sa.sa_handler=SIG_IGN;
+ sa.sa_mask=sigset;
+ sa.sa_flags=0;
+ sigaction(SIGINT, &sa, 0);
+
+ while(!all_threads) {
+ sched_yield();
+ }
+ maybe_gc_pending=0;
+ while(all_threads && (pid=waitpid(-1,&status,__WALL|WUNTRACED))) {
+ struct thread *th;
+ while(maybe_gc_pending) parent_do_garbage_collect();
+ if(pid==-1) {
+ if(errno == EINTR) {
+ continue;
+ }
+ if(errno == ECHILD) break;
+ fprintf(stderr,"waitpid: %s\n",strerror(errno));
+ continue;
+ }
+ th=find_thread_by_pid(pid);
+ if(!th) continue;
+ if(WIFEXITED(status) || WIFSIGNALED(status)) {
+ fprintf(stderr,"waitpid : child %d %x exited \n", pid,th);
+ destroy_thread(th);
+ /* FIXME arrange to call or fake (free-mutex *session-lock*)
+ * if necessary */
+ if(!all_threads) break;
+ }
+ }
+ exit(WEXITSTATUS(status));
}
+#endif
projects / sbcl.git / blobdiff