src/runtime/runtime.c

   1 /*
   2  * main() entry point for a stand-alone SBCL image
   3  */
   4
   5 /*
   6  * This software is part of the SBCL system. See the README file for
   7  * more information.
   8  *
   9  * This software is derived from the CMU CL system, which was
  10  * written at Carnegie Mellon University and released into the
  11  * public domain. The software is in the public domain and is
  12  * provided with absolutely no warranty. See the COPYING and CREDITS
  13  * files for more information.
  14  */
  15
  16 #include <stdio.h>
  17 #include <string.h>
  18 #include <libgen.h>
  19 #include <sys/types.h>
  20 #include <sys/wait.h>
  21 #include <stdlib.h>
  22 #include <unistd.h>
  23 #include <sys/file.h>
  24 #include <sys/param.h>
  25 #include <sys/stat.h>
  26 #include <signal.h>
  27 #ifdef LISP_FEATURE_SB_THREAD
  28 #include <sys/ptrace.h>
  29 #endif
  30 #include <sched.h>
  31 #include <errno.h>
  32
  33 #if defined(SVR4) || defined(__linux__)
  34 #include <time.h>
  35 #endif
  36
  37 #include "signal.h"
  38
  39 #include "runtime.h"
  40 #include "sbcl.h"
  41 #include "alloc.h"
  42 #include "vars.h"
  43 #include "globals.h"
  44 #include "os.h"
  45 #include "interrupt.h"
  46 #include "arch.h"
  47 #include "gc.h"
  48 #include "interr.h"
  49 #include "monitor.h"
  50 #include "validate.h"
  51 #include "core.h"
  52 #include "save.h"
  53 #include "lispregs.h"
  54 #include "thread.h"
  55
  56 #include "genesis/static-symbols.h"
  57 #include "genesis/symbol.h"
  58
  59
  60 #ifdef irix
  61 #include <string.h>
  62 #include "interr.h"
  63 #endif
  64 \f
  65 /* SIGINT handler that invokes the monitor (for when Lisp isn't up to it) */
  66 static void
  67 sigint_handler(int signal, siginfo_t *info, void *void_context)
  68 {
  69     lose("\nSIGINT hit at 0x%08lX\n",
  70          (unsigned long) *os_context_pc_addr(void_context));
  71 }
  72
  73 /* (This is not static, because we want to be able to call it from
  74  * Lisp land.) */
  75 void
  76 sigint_init(void)
  77 {
  78     SHOW("entering sigint_init()");
  79     install_handler(SIGINT, sigint_handler);
  80     SHOW("leaving sigint_init()");
  81 }
  82 \f
  83 /*
  84  * helper functions for dealing with command line args
  85  */
  86
  87 void *
  88 successful_malloc(size_t size)
  89 {
  90     void* result = malloc(size);
  91     if (0 == result) {
  92         lose("malloc failure");
  93     } else {
  94         return result;
  95     }
  96     return (void *) NULL; /* dummy value: return something ... */
  97 }
  98
  99 char *
 100 copied_string(char *string)
 101 {
 102     return strcpy(successful_malloc(1+strlen(string)), string);
 103 }
 104
 105 char *
 106 copied_existing_filename_or_null(char *filename)
 107 {
 108     struct stat filename_stat;
 109     if (stat(filename, &filename_stat)) { /* if failure */
 110         return 0;
 111     } else {
 112         return copied_string(filename);
 113     }
 114 }
 115
 116 /* Convert a null-terminated array of null-terminated strings (e.g.
 117  * argv or envp) into a Lisp list of Lisp base-strings. */
 118 static lispobj
 119 alloc_base_string_list(char *array_ptr[])
 120 {
 121     if (*array_ptr) {
 122         return alloc_cons(alloc_base_string(*array_ptr),
 123                           alloc_base_string_list(1 + array_ptr));
 124     } else {
 125         return NIL;
 126     }
 127 }
 128 \f
 129 /* miscellaneous chattiness */
 130
 131 void
 132 print_help()
 133 {
 134     puts(
 135 "SBCL is a Common Lisp programming environment. Ordinarily you shouldn't\n\
 136 need command line options when you invoke it interactively: you can just\n\
 137 start it and work with the customary Lisp READ-EVAL-PRINT loop.\n\
 138 \n\
 139 One option idiom which is sometimes useful interactively (e.g. when\n\
 140 exercising a test case for a bug report) is\n\
 141   sbcl --sysinit /dev/null --userinit /dev/null\n\
 142 to keep SBCL from reading any initialization files at startup. And some\n\
 143 people like to suppress the default startup message:\n\
 144   sbcl --noinform\n\
 145 \n\
 146 Other options can be useful when you're running SBCL noninteractively,\n\
 147 e.g. from a script, or if you have a strange system configuration, so\n\
 148 that SBCL can't by default find one of the files it needs. For\n\
 149 information on such options, see the sbcl(1) man page.\n\
 150 \n\
 151 More information on SBCL can be found on its man page, or at\n\
 152 <http://sbcl.sf.net/>.\n");
 153 }
 154
 155 void
 156 print_version()
 157 {
 158     printf("SBCL %s\n", SBCL_VERSION_STRING);
 159 }
 160
 161 void
 162 print_banner()
 163 {
 164     printf(
 165 "This is SBCL %s, an implementation of ANSI Common Lisp.\n\
 166 \n\
 167 SBCL is derived from the CMU CL system created at Carnegie Mellon University.\n\
 168 Besides software and documentation originally created at Carnegie Mellon\n\
 169 University, SBCL contains some software originally from the Massachusetts\n\
 170 Institute of Technology, Symbolics Incorporated, and Xerox Corporation, and\n\
 171 material contributed by volunteers since the release of CMU CL into the\n\
 172 public domain. See the CREDITS file in the distribution for more information.\n\
 173 \n\
 174 SBCL is a free software system, provided as is, with absolutely no warranty.\n\
 175 It is mostly in the public domain, but also includes some software copyrighted\n\
 176   Massachusetts Institute of Technology, 1986;\n\
 177   Symbolics, Inc., 1989, 1990, 1991, 1992; and\n\
 178   Xerox Corporation, 1985, 1986, 1987, 1988, 1989, 1990\n\
 179 used under BSD-style licenses allowing copying only under certain conditions.\n\
 180 See the COPYING file in the distribution for more information.\n\
 181 \n\
 182 More information about SBCL is available at <http://sbcl.sourceforge.net/>.\n\
 183 ", SBCL_VERSION_STRING);
 184 }
 185 \f
 186 int gc_thread_pid;
 187 FILE *stdlog;
 188
 189 \f
 190 int
 191 main(int argc, char *argv[], char *envp[])
 192 {
 193     /* the name of the core file we're to execute. Note that this is
 194      * a malloc'ed string which should be freed eventually. */
 195     char *core = 0;
 196
 197     /* other command line options */
 198     boolean noinform = 0;
 199     boolean end_runtime_options = 0;
 200
 201     lispobj initial_function;
 202
 203     /* KLUDGE: os_vm_page_size is set by os_init(), and on some
 204      * systems (e.g. Alpha) arch_init() needs need os_vm_page_size, so
 205      * it must follow os_init(). -- WHN 2000-01-26 */
 206     os_init();
 207     arch_init();
 208     gc_init();
 209     validate();
 210
 211     /* Parse our part of the command line (aka "runtime options"),
 212      * stripping out those options that we handle. */
 213     {
 214         int argi = 1;
 215         while (argi < argc) {
 216             char *arg = argv[argi];
 217             if (0 == strcmp(arg, "--noinform")) {
 218                 noinform = 1;
 219                 ++argi;
 220             } else if (0 == strcmp(arg, "--core")) {
 221                 if (core) {
 222                     lose("more than one core file specified");
 223                 } else {
 224                     ++argi;
 225                     if (argi >= argc) {
 226                         lose("missing filename for --core argument");
 227                     }
 228                     core = copied_string(argv[argi]);
 229                     ++argi;
 230                 }
 231             } else if (0 == strcmp(arg, "--help")) {
 232                 /* I think this is the (or a) usual convention: upon
 233                  * seeing "--help" we immediately print our help
 234                  * string and exit, ignoring everything else. */
 235                 print_help();
 236                 exit(0);
 237             } else if (0 == strcmp(arg, "--version")) {
 238                 /* As in "--help" case, I think this is expected. */
 239                 print_version();
 240                 exit(0);
 241             } else if (0 == strcmp(arg, "--end-runtime-options")) {
 242                 end_runtime_options = 1;
 243                 ++argi;
 244                 break;
 245             } else {
 246                 /* This option was unrecognized as a runtime option,
 247                  * so it must be a toplevel option or a user option,
 248                  * so we must be past the end of the runtime option
 249                  * section. */
 250                 break;
 251             }
 252         }
 253         /* This is where we strip out those options that we handle. We
 254          * also take this opportunity to make sure that we don't find
 255          * an out-of-place "--end-runtime-options" option. */
 256         {
 257             char *argi0 = argv[argi];
 258             int argj = 1;
 259             while (argi < argc) {
 260                 char *arg = argv[argi++];
 261                 /* If we encounter --end-runtime-options for the first
 262                  * time after the point where we had to give up on
 263                  * runtime options, then the point where we had to
 264                  * give up on runtime options must've been a user
 265                  * error. */
 266                 if (!end_runtime_options &&
 267                     0 == strcmp(arg, "--end-runtime-options")) {
 268                     lose("bad runtime option \"%s\"", argi0);
 269                 }
 270                 argv[argj++] = arg;
 271             }
 272             argv[argj] = 0;
 273             argc = argj;
 274         }
 275     }
 276
 277     /* If no core file was specified, look for one. */
 278     if (!core) {
 279         char *sbcl_home = getenv("SBCL_HOME");
 280         if (sbcl_home) {
 281             char *lookhere;
 282             char *stem = "/sbcl.core";
 283             lookhere = (char *) calloc(strlen(sbcl_home) +
 284                                        strlen(stem) +
 285                                        1,
 286                                        sizeof(char));
 287             sprintf(lookhere, "%s%s", sbcl_home, stem);
 288             core = copied_existing_filename_or_null(lookhere);
 289             free(lookhere);
 290         } else {
 291             putenv("SBCL_HOME=/usr/local/lib/sbcl/");
 292             core = copied_existing_filename_or_null("/usr/local/lib/sbcl/sbcl.core");
 293             if (!core) {
 294                 putenv("SBCL_HOME=/usr/lib/sbcl/");
 295                 core =
 296                     copied_existing_filename_or_null("/usr/lib/sbcl/sbcl.core");
 297             }
 298         }
 299         if (!core) {
 300             lose("can't find core file");
 301         }
 302     } else {
 303         /* If a core was specified and SBCL_HOME is unset, set it */
 304         char *sbcl_home = getenv("SBCL_HOME");
 305         if (!sbcl_home) {
 306             char *envstring, *copied_core, *dir;
 307             char *stem = "SBCL_HOME=";
 308             copied_core = copied_string(core);
 309             dir = dirname(copied_core);
 310             envstring = (char *) calloc(strlen(stem) +
 311                                         strlen(dir) +
 312                                         1,
 313                                         sizeof(char));
 314             sprintf(envstring, "%s%s", stem, dir);
 315             putenv(envstring);
 316             free(copied_core);
 317         }
 318     }
 319
 320     if (!noinform) {
 321         print_banner();
 322         fflush(stdout);
 323     }
 324
 325 #ifdef MACH
 326     mach_init();
 327 #endif
 328 #if defined(SVR4) || defined(__linux__)
 329     tzset();
 330 #endif
 331
 332     define_var("nil", NIL, 1);
 333     define_var("t", T, 1);
 334
 335     set_lossage_handler(monitor_or_something);
 336
 337     globals_init();
 338
 339     initial_function = load_core_file(core);
 340     if (initial_function == NIL) {
 341         lose("couldn't find initial function");
 342     }
 343     SHOW("freeing core");
 344     free(core);
 345
 346     gc_initialize_pointers();
 347
 348     interrupt_init();
 349     arch_install_interrupt_handlers();
 350     os_install_interrupt_handlers();
 351
 352     /* Convert remaining argv values to something that Lisp can grok. */
 353     SHOW("setting POSIX-ARGV symbol value");
 354     SetSymbolValue(POSIX_ARGV, alloc_base_string_list(argv),0);
 355
 356     /* Install a handler to pick off SIGINT until the Lisp system gets
 357      * far enough along to install its own handler. */
 358     sigint_init();
 359
 360     FSHOW((stderr, "/funcalling initial_function=0x%lx\n", initial_function));
 361     create_thread(initial_function);
 362     /* in a unithread build, create_thread never returns */
 363 #ifdef LISP_FEATURE_SB_THREAD
 364     gc_thread_pid=getpid();
 365     parent_loop();
 366 #endif
 367 }
 368
 369 static void parent_sighandler(int signum,siginfo_t *info, void *void_context)
 370 {
 371 #if 0
 372     os_context_t *context = (os_context_t*)void_context;
 373     fprintf(stderr,
 374             "parent thread got signal %d from %d, maybe_gc_pending=%d\n",
 375             signum, info->si_pid,
 376             maybe_gc_pending);
 377 #endif
 378 }
 379
 380 #ifdef LISP_FEATURE_SB_THREAD
 381 static void parent_do_garbage_collect(void)
 382 {
 383     int waiting_threads=0;
 384     struct thread *th;
 385     int status,p;
 386
 387     for_each_thread(th) {
 388         if(ptrace(PTRACE_ATTACH,th->pid,0,0)) {
 389             perror("PTRACE_ATTACH");
 390         }
 391         else waiting_threads++;
 392     }
 393     stop_the_world=1;
 394
 395     do {
 396         /* not sure if we have to wait for PTRACE_ATTACH to finish
 397          * before we can send PTRACE_CONT, so let's play it safe
 398          */
 399         while(waiting_threads>0) {
 400             if((p=waitpid(-1,&status, WUNTRACED|__WALL))>0) {
 401                 if(WIFEXITED(status) || WIFSIGNALED(status))
 402                     destroy_thread(find_thread_by_pid(p));
 403                 else {
 404 #if 0
 405                     fprintf(stderr, "wait returned pid %d signal %x\n",
 406                             p,WSTOPSIG(status));
 407 #endif
 408                     if(WSTOPSIG(status)==SIGTRAP) {
 409                         if(ptrace(PTRACE_CONT,p,0,SIGTRAP))
 410                             perror("PTRACE_CONT");
 411                     }
 412                     else waiting_threads--;
 413                 }
 414             }
 415         }
 416         for_each_thread(th) {
 417             if(SymbolTlValue(PSEUDO_ATOMIC_ATOMIC,th)) {
 418                 /* restart the child, setting *p-a-i* which will cause it
 419                  * to go into interrupt_handle_pending as soon as it's
 420                  * finished being pseudo_atomic.  once there it will
 421                  * signal itself SIGSTOP, which will give us another
 422                  * event to wait for */
 423 #if 0
 424                 fprintf(stderr, "%d was pseudo-atomic, letting it resume \n",
 425                         th->pid);
 426 #endif
 427                 SetTlSymbolValue(PSEUDO_ATOMIC_INTERRUPTED,make_fixnum(1),th);
 428                 if(ptrace(PTRACE_CONT,th->pid,0,0))
 429                     perror("PTRACE_CONT");
 430                 waiting_threads++;
 431             }
 432         }
 433     } while (waiting_threads>0);
 434
 435     collect_garbage(maybe_gc_pending-1);
 436     maybe_gc_pending=0;
 437     stop_the_world=0;
 438     for_each_thread(th)
 439         if(ptrace(PTRACE_DETACH,th->pid,0,0))
 440             perror("PTRACE_DETACH");
 441 }
 442
 443 static void /* noreturn */ parent_loop(void)
 444 {
 445     struct sigaction sa;
 446     sigset_t sigset;
 447     int status;
 448     pid_t pid=0;
 449
 450     sigemptyset(&sigset);
 451
 452     sigaddset(&sigset, SIGALRM);
 453     sigaddset(&sigset, SIGCHLD);
 454     sigprocmask(SIG_UNBLOCK,&sigset,0);
 455     sa.sa_handler=parent_sighandler;
 456     sa.sa_mask=sigset;
 457     sa.sa_flags=SA_SIGINFO;
 458     sigaction(SIGALRM, &sa, 0);
 459     sigaction(SIGCHLD, &sa, 0);
 460
 461     sigemptyset(&sigset);
 462     sa.sa_handler=SIG_IGN;
 463     sa.sa_mask=sigset;
 464     sa.sa_flags=0;
 465     sigaction(SIGINT, &sa, 0);
 466
 467     while(!all_threads) {
 468         sched_yield();
 469     }
 470     maybe_gc_pending=0;
 471     while(all_threads && (pid=waitpid(-1,&status,__WALL|WUNTRACED))) {
 472         struct thread *th;
 473         int real_errno=errno;
 474         while(maybe_gc_pending) parent_do_garbage_collect();
 475         if(pid==-1) {
 476             if(real_errno == EINTR) {
 477                 continue;
 478             }
 479             if(real_errno == ECHILD) break;
 480             fprintf(stderr,"waitpid: %s\n",strerror(real_errno));
 481             continue;
 482         }
 483         th=find_thread_by_pid(pid);
 484         if(!th) continue;
 485         if(WIFEXITED(status) || WIFSIGNALED(status)) {
 486             fprintf(stderr,"waitpid : child %d %x exited \n", pid,th);
 487             destroy_thread(th);
 488             /* FIXME arrange to call or fake (free-mutex *session-lock*)
 489              * if necessary */
 490             if(!all_threads) break;
 491         }
 492     }
 493     exit(WEXITSTATUS(status));
 494 }
 495
 496 #endif