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