* files for more information.
*/
+#include "sbcl.h"
+
#include <stdio.h>
#include <string.h>
#include <libgen.h>
#include <sys/param.h>
#include <sys/stat.h>
#include <signal.h>
-#include <sys/ptrace.h>
#include <sched.h>
#include <errno.h>
#include "signal.h"
#include "runtime.h"
-#include "sbcl.h"
#include "alloc.h"
#include "vars.h"
#include "globals.h"
#include <string.h>
#include "interr.h"
#endif
+
+#ifndef SBCL_HOME
+#define SBCL_HOME "/usr/local/lib/sbcl/"
+#endif
+
\f
/* SIGINT handler that invokes the monitor (for when Lisp isn't up to it) */
static void
}
/* Convert a null-terminated array of null-terminated strings (e.g.
- * argv or envp) into a Lisp list of Lisp strings. */
+ * argv or envp) into a Lisp list of Lisp base-strings. */
static lispobj
-alloc_string_list(char *array_ptr[])
+alloc_base_string_list(char *array_ptr[])
{
if (*array_ptr) {
- return alloc_cons(alloc_string(*array_ptr),
- alloc_string_list(1 + array_ptr));
+ return alloc_cons(alloc_base_string(*array_ptr),
+ alloc_base_string_list(1 + array_ptr));
} else {
return NIL;
}
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\
+More information about SBCL is available at <http://www.sbcl.org/>.\
\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 is free software, provided as is, with absolutely no warranty.\n\
+It is mostly in the public domain; some portions are provided under\n\
+BSD-style licenses. See the CREDITS and COPYING files in the\n\
+distribution for more information.\n\
", SBCL_VERSION_STRING);
}
\f
-int gc_thread_pid;
FILE *stdlog;
\f
/* If no core file was specified, look for one. */
if (!core) {
char *sbcl_home = getenv("SBCL_HOME");
- if (sbcl_home) {
- char *lookhere;
- char *stem = "/sbcl.core";
- lookhere = (char *) calloc(strlen(sbcl_home) +
- strlen(stem) +
- 1,
- sizeof(char));
- sprintf(lookhere, "%s%s", sbcl_home, stem);
- core = copied_existing_filename_or_null(lookhere);
- free(lookhere);
- } else {
- 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/lib/sbcl/sbcl.core");
- }
- }
+ char *lookhere;
+ char *stem = "/sbcl.core";
+ if(!sbcl_home) sbcl_home = SBCL_HOME;
+ lookhere = (char *) calloc(strlen(sbcl_home) +
+ strlen(stem) +
+ 1,
+ sizeof(char));
+ sprintf(lookhere, "%s%s", sbcl_home, stem);
+ core = copied_existing_filename_or_null(lookhere);
+ free(lookhere);
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);
- }
}
-
+ /* Make sure that SBCL_HOME is set, no matter where the core was
+ * found */
+ if (!getenv("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) {
print_banner();
fflush(stdout);
}
-#ifdef MACH
- mach_init();
-#endif
#if defined(SVR4) || defined(__linux__)
tzset();
#endif
/* Convert remaining argv values to something that Lisp can grok. */
SHOW("setting POSIX-ARGV symbol value");
- SetSymbolValue(POSIX_ARGV, alloc_string_list(argv),0);
+ SetSymbolValue(POSIX_ARGV, alloc_base_string_list(argv),0);
/* Install a handler to pick off SIGINT until the Lisp system gets
* far enough along to install its own handler. */
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)) {
- fprintf(stderr,"attaching to %d ...",th->pid);
- 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 */
- fprintf(stderr, "%d was pseudo-atomic, letting it resume \n",
- th->pid);
- SetTlSymbolValue(PSEUDO_ATOMIC_INTERRUPTED,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;
- /* fprintf(stderr, "gc done\n"); */
- for_each_thread(th)
- if(ptrace(PTRACE_DETACH,th->pid,0,0))
- perror("PTRACE_DETACH");
-}
+
+/* this is being pared down as time goes on; eventually we want to get
+ * to the point that we have no parent loop at all and the parent
+ * thread runs Lisp just like any other */
static void /* noreturn */ parent_loop(void)
{
struct sigaction sa;
sigset_t sigset;
int status;
-
- 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);
+ pid_t pid=0;
sigemptyset(&sigset);
sa.sa_handler=SIG_IGN;
sa.sa_mask=sigset;
sa.sa_flags=0;
- sigaction(SIGINT, &sa, 0);
-
- while(all_threads) {
- pid_t pid=0;
- while(pid=waitpid(-1,&status,__WALL|WUNTRACED)) {
- struct thread *th;
- fprintf(stderr,"waitpid pid %d\n",pid);
- if(pid==-1) {
- if(errno == EINTR) {
- if(maybe_gc_pending) parent_do_garbage_collect();
- continue;
- }
- if(errno == ECHILD) break;
- fprintf(stderr,"waitpid: %s\n",strerror(errno));
- continue;
- }
+ sigaction(SIGINT, &sa, 0); /* ^c should go to the lisp thread instead */
+ sigaction(SIG_THREAD_EXIT, &sa, 0);
+ sigaction(SIGCHLD, &sa, 0);
+
+ while(!all_threads) {
+ sched_yield();
+ }
+ while(all_threads && (pid=waitpid(-1,&status,__WALL))) {
+ struct thread *th;
+ if(pid==-1) {
+ if(errno == EINTR) continue;
+ fprintf(stderr,"waitpid: %s\n",strerror(errno));
+ }
+ else if(WIFEXITED(status) || WIFSIGNALED(status)) {
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;
- }
+ destroy_thread(th);
+ if(!all_threads) break;
}
}
exit(WEXITSTATUS(status));
projects / sbcl.git / blobdiff