sb-bsd-sockets: More robust inet-socket-bind test on Windows.
[sbcl.git] / 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 "sbcl.h"
17
18 #include <stdio.h>
19 #include <string.h>
20 #include <ctype.h>
21 #ifndef LISP_FEATURE_WIN32
22 #include <libgen.h>
23 #endif
24 #include <sys/types.h>
25 #ifndef LISP_FEATURE_WIN32
26 #include <sys/wait.h>
27 #endif
28 #include <stdlib.h>
29 #include <unistd.h>
30 #include <sys/file.h>
31 #include <sys/param.h>
32 #include <sys/stat.h>
33 #include "runtime.h"
34 #ifndef LISP_FEATURE_WIN32
35 #include <sched.h>
36 #endif
37 #include <errno.h>
38 #include <locale.h>
39 #include <limits.h>
40
41 #if defined(SVR4) || defined(__linux__)
42 #include <time.h>
43 #endif
44
45 #if !(defined(LISP_FEATURE_WIN32) && defined(LISP_FEATURE_SB_THREAD))
46 #include "signal.h"
47 #endif
48
49 #include "runtime.h"
50 #include "vars.h"
51 #include "globals.h"
52 #include "os.h"
53 #include "interr.h"
54 #include "alloc.h"
55 #include "interrupt.h"
56 #include "arch.h"
57 #include "gc.h"
58 #include "validate.h"
59 #include "core.h"
60 #include "save.h"
61 #include "lispregs.h"
62 #include "thread.h"
63
64 #include "genesis/static-symbols.h"
65 #include "genesis/symbol.h"
66
67
68 #ifdef irix
69 #include <string.h>
70 #include "interr.h"
71 #endif
72
73 #ifndef SBCL_HOME
74 #define SBCL_HOME SBCL_PREFIX"/lib/sbcl/"
75 #endif
76
77 #ifdef LISP_FEATURE_HPUX
78 extern void *return_from_lisp_stub;
79 #include "genesis/closure.h"
80 #include "genesis/simple-fun.h"
81 #endif
82
83 \f
84 /* SIGINT handler that invokes the monitor (for when Lisp isn't up to it) */
85 static void
86 sigint_handler(int signal, siginfo_t *info, os_context_t *context)
87 {
88     lose("\nSIGINT hit at 0x%08lX\n",
89          (unsigned long) *os_context_pc_addr(context));
90 }
91
92 /* (This is not static, because we want to be able to call it from
93  * Lisp land.) */
94 void
95 sigint_init(void)
96 {
97     SHOW("entering sigint_init()");
98     install_handler(SIGINT, sigint_handler, 1);
99     SHOW("leaving sigint_init()");
100 }
101 \f
102 /*
103  * helper functions for dealing with command line args
104  */
105
106 void *
107 successful_malloc(size_t size)
108 {
109     void* result = malloc(size);
110     if (0 == result) {
111         lose("malloc failure\n");
112     } else {
113         return result;
114     }
115     return (void *) NULL; /* dummy value: return something ... */
116 }
117
118 char *
119 copied_string(char *string)
120 {
121     return strcpy(successful_malloc(1+strlen(string)), string);
122 }
123
124 char *
125 copied_existing_filename_or_null(char *filename)
126 {
127     struct stat filename_stat;
128     if (stat(filename, &filename_stat)) { /* if failure */
129         return 0;
130     } else {
131         return copied_string(filename);
132     }
133 }
134
135 #ifndef LISP_FEATURE_WIN32
136 char *
137 copied_realpath(const char *pathname)
138 {
139     char *messy, *tidy;
140     size_t len;
141
142     /* realpath() supposedly can't be counted on to always return
143      * an absolute path, so we prepend the cwd to relative paths */
144     messy = NULL;
145     if (pathname[0] != '/') {
146         messy = successful_malloc(PATH_MAX + 1);
147         if (getcwd(messy, PATH_MAX + 1) == NULL) {
148             free(messy);
149             return NULL;
150         }
151         len = strlen(messy);
152         snprintf(messy + len, PATH_MAX + 1 - len, "/%s", pathname);
153     }
154
155     tidy = successful_malloc(PATH_MAX + 1);
156     if (realpath((messy ? messy : pathname), tidy) == NULL) {
157         free(messy);
158         free(tidy);
159         return NULL;
160     }
161
162     return tidy;
163 }
164 #endif /* LISP_FEATURE_WIN32 */
165 \f
166 /* miscellaneous chattiness */
167
168 void
169 print_help()
170 {
171     puts(
172 "Usage: sbcl [runtime-options] [toplevel-options] [user-options]\n\
173 Common runtime options:\n\
174   --help                     Print this message and exit.\n\
175   --version                  Print version information and exit.\n\
176   --core <filename>          Use the specified core file instead of the default.\n\
177   --dynamic-space-size <MiB> Size of reserved dynamic space in megabytes.\n\
178   --control-stack-size <MiB> Size of reserved control stack in megabytes.\n\
179 \n\
180 Common toplevel options:\n\
181   --sysinit <filename>       System-wide init-file to use instead of default.\n\
182   --userinit <filename>      Per-user init-file to use instead of default.\n\
183   --no-sysinit               Inhibit processing of any system-wide init-file.\n\
184   --no-userinit              Inhibit processing of any per-user init-file.\n\
185   --disable-debugger         Invoke sb-ext:disable-debugger.\n\
186   --noprint                  Run a Read-Eval Loop without printing results.\n\
187   --script [<filename>]      Skip #! line, disable debugger, avoid verbosity.\n\
188   --quit                     Exit with code 0 after option processing.\n\
189   --non-interactive          Sets both --quit and --disable-debugger.\n\
190 Common toplevel options that are processed in order:\n\
191   --eval <form>              Form to eval when processing this option.\n\
192   --load <filename>          File to load when processing this option.\n\
193 \n\
194 User options are not processed by SBCL. All runtime options must\n\
195 appear before toplevel options, and all toplevel options must\n\
196 appear before user options.\n\
197 \n\
198 For more information please refer to the SBCL User Manual, which\n\
199 should be installed along with SBCL, and is also available from the\n\
200 website <http://www.sbcl.org/>.\n");
201 }
202
203 void
204 print_version()
205 {
206     printf("SBCL %s\n", SBCL_VERSION_STRING);
207 }
208
209 void
210 print_banner()
211 {
212     printf(
213 "This is SBCL %s, an implementation of ANSI Common Lisp.\n\
214 More information about SBCL is available at <http://www.sbcl.org/>.\n\
215 \n\
216 SBCL is free software, provided as is, with absolutely no warranty.\n\
217 It is mostly in the public domain; some portions are provided under\n\
218 BSD-style licenses.  See the CREDITS and COPYING files in the\n\
219 distribution for more information.\n\
220 ", SBCL_VERSION_STRING);
221 }
222
223 /* Look for a core file to load, first in the directory named by the
224  * SBCL_HOME environment variable, then in a hardcoded default
225  * location.  Returns a malloced copy of the core filename. */
226 char *
227 search_for_core ()
228 {
229     char *sbcl_home = getenv("SBCL_HOME");
230     char *lookhere;
231     char *stem = "/sbcl.core";
232     char *core;
233
234     if (!(sbcl_home && *sbcl_home)) sbcl_home = SBCL_HOME;
235     lookhere = (char *) calloc(strlen(sbcl_home) +
236                                strlen(stem) +
237                                1,
238                                sizeof(char));
239     sprintf(lookhere, "%s%s", sbcl_home, stem);
240     core = copied_existing_filename_or_null(lookhere);
241
242     if (!core) {
243         lose("can't find core file at %s\n", lookhere);
244     }
245
246     free(lookhere);
247
248     return core;
249 }
250
251 /* Try to find the path to an executable from argv[0], this is only
252  * used when os_get_runtime_executable_path() returns NULL */
253 #ifdef LISP_FEATURE_WIN32
254 char *
255 search_for_executable(const char *argv0)
256 {
257     return NULL;
258 }
259 #else /* LISP_FEATURE_WIN32 */
260 char *
261 search_for_executable(const char *argv0)
262 {
263     char *search, *start, *end, *buf;
264
265     /* If argv[0] contains a slash then it's probably an absolute path
266      * or relative to the current directory, so check if it exists. */
267     if (strchr(argv0, '/') != NULL && access(argv0, F_OK) == 0)
268         return copied_realpath(argv0);
269
270     /* Bail on an absolute path which doesn't exist */
271     if (argv0[0] == '/')
272         return NULL;
273
274     /* Otherwise check if argv[0] exists relative to any directory in PATH */
275     search = getenv("PATH");
276     if (search == NULL)
277         return NULL;
278     search = copied_string(search);
279     buf = successful_malloc(PATH_MAX + 1);
280     for (start = search; (end = strchr(start, ':')) != NULL; start = end + 1) {
281         *end = '\0';
282         snprintf(buf, PATH_MAX + 1, "%s/%s", start, argv0);
283         if (access(buf, F_OK) == 0) {
284             free(search);
285             search = copied_realpath(buf);
286             free(buf);
287             return search;
288         }
289     }
290     /* The above for-loop fails to process the last part of PATH if PATH does
291      * not end with ':'. We may consider appending an extra ':' to the end of
292      * SEARCH.  -- houjingyi 2013-05-24 */
293     if (start != NULL && *start != '\0') {
294         snprintf(buf, PATH_MAX + 1, "%s/%s", start, argv0);
295         if (access(buf, F_OK) == 0) {
296             free(search);
297             search = copied_realpath(buf);
298             free(buf);
299             return search;
300         }
301     }
302
303     free(search);
304     free(buf);
305     return NULL;
306 }
307 #endif /* LISP_FEATURE_WIN32 */
308
309 size_t
310 parse_size_arg(char *arg, char *arg_name)
311 {
312   char *tail, *power_name;
313   size_t power, res;
314
315   res = strtoul(arg, &tail, 0);
316
317   if (arg == tail) {
318     lose("%s argument is not a number: %s", arg_name, arg);
319   } else if (tail[0]) {
320     int i, size;
321     power_name = copied_string(tail);
322     size = strlen(power_name);
323     for (i=0; i<size; i++)
324       power_name[i] = toupper(power_name[i]);
325   } else {
326     power = 20;
327     power_name = NULL;
328   }
329   if (power_name) {
330     if ((0==strcmp("KB", power_name)) ||
331         (0==strcmp("KIB", power_name))) {
332       power = 10;
333     } else if ((0==strcmp("MB", power_name)) ||
334                (0==strcmp("MIB", power_name))) {
335       power = 20;
336     } else if ((0==strcmp("GB", power_name)) ||
337                (0==strcmp("GIB", power_name))) {
338       power = 30;
339     } else {
340       lose("%s argument has an unknown suffix: %s", arg_name, tail);
341     }
342     free(power_name);
343   }
344   if ((res <= 0) ||
345       (res >= (SIZE_MAX >> power))) {
346     lose("%s argument is out of range: %s", arg_name, arg);
347   }
348   res <<= power;
349   return res;
350 }
351
352 char **posix_argv;
353 char *core_string;
354
355 struct runtime_options *runtime_options;
356
357 char *saved_runtime_path = NULL;
358 #if defined(LISP_FEATURE_WIN32) && defined(LISP_FEATURE_SB_THREAD)
359 void pthreads_win32_init();
360 #endif
361
362 void print_locale_variable(const char *name)
363 {
364   char *value = getenv(name);
365
366   if (value) {
367     fprintf(stderr, "\n  %s=%s", name, value);
368   }
369 }
370
371 void setup_locale()
372 {
373   if(setlocale(LC_ALL, "") == NULL) {
374 #ifndef LISP_FEATURE_WIN32
375
376     fprintf(stderr, "WARNING: Setting locale failed.\n");
377     fprintf(stderr, "  Check the following variables for correct values:");
378
379     if (setlocale(LC_CTYPE, "") == NULL) {
380       print_locale_variable("LC_ALL");
381       print_locale_variable("LC_CTYPE");
382       print_locale_variable("LANG");
383     }
384
385     if (setlocale(LC_MESSAGES, "") == NULL) {
386       print_locale_variable("LC_MESSAGES");
387     }
388     if (setlocale(LC_COLLATE, "") == NULL) {
389       print_locale_variable("LC_COLLATE");
390     }
391     if (setlocale(LC_MONETARY, "") == NULL) {
392       print_locale_variable("LC_MONETARY");
393     }
394     if (setlocale(LC_NUMERIC, "") == NULL) {
395       print_locale_variable("LC_NUMERIC");
396     }
397     if (setlocale(LC_TIME, "") == NULL) {
398       print_locale_variable("LC_TIME");
399     }
400     fprintf(stderr, "\n");
401
402 #endif
403   }
404 }
405
406 \f
407 int
408 main(int argc, char *argv[], char *envp[])
409 {
410 #ifdef LISP_FEATURE_WIN32
411     /* Exception handling support structure. Evil Win32 hack. */
412     struct lisp_exception_frame exception_frame;
413 #endif
414
415     /* the name of the core file we're to execute. Note that this is
416      * a malloc'ed string which should be freed eventually. */
417     char *core = 0;
418     char **sbcl_argv = 0;
419     os_vm_offset_t embedded_core_offset = 0;
420     char *runtime_path = 0;
421
422     /* other command line options */
423     boolean noinform = 0;
424     boolean end_runtime_options = 0;
425     boolean disable_lossage_handler_p = 0;
426
427     lispobj initial_function;
428     const char *sbcl_home = getenv("SBCL_HOME");
429
430 #if defined(LISP_FEATURE_WIN32) && defined(LISP_FEATURE_SB_THREAD)
431     os_preinit();
432     pthreads_win32_init();
433 #endif
434
435     interrupt_init();
436     block_blockable_signals(0, 0);
437
438     runtime_options = NULL;
439
440     /* Save the argv[0] derived runtime path in case
441      * os_get_runtime_executable_path(1) isn't able to get an
442      * externally-usable path later on. */
443     saved_runtime_path = search_for_executable(argv[0]);
444
445     /* Check early to see if this executable has an embedded core,
446      * which also populates runtime_options if the core has runtime
447      * options */
448     runtime_path = os_get_runtime_executable_path(0);
449     if (runtime_path || saved_runtime_path) {
450         os_vm_offset_t offset = search_for_embedded_core(
451             runtime_path ? runtime_path : saved_runtime_path);
452         if (offset != -1) {
453             embedded_core_offset = offset;
454             core = (runtime_path ? runtime_path :
455                     copied_string(saved_runtime_path));
456         } else {
457             if (runtime_path)
458                 free(runtime_path);
459         }
460     }
461
462
463     /* Parse our part of the command line (aka "runtime options"),
464      * stripping out those options that we handle. */
465     if (runtime_options != NULL) {
466         dynamic_space_size = runtime_options->dynamic_space_size;
467         thread_control_stack_size = runtime_options->thread_control_stack_size;
468         sbcl_argv = argv;
469     } else {
470         int argi = 1;
471
472         runtime_options = successful_malloc(sizeof(struct runtime_options));
473
474         while (argi < argc) {
475             char *arg = argv[argi];
476             if (0 == strcmp(arg, "--script")) {
477                 /* This is both a runtime and a toplevel option. As a
478                  * runtime option, it is equivalent to --noinform.
479                  * This exits, and does not increment argi, so that
480                  * TOPLEVEL-INIT sees the option. */
481                 noinform = 1;
482                 end_runtime_options = 1;
483                 disable_lossage_handler_p = 1;
484                 lose_on_corruption_p = 1;
485                 break;
486             } else if (0 == strcmp(arg, "--noinform")) {
487                 noinform = 1;
488                 ++argi;
489             } else if (0 == strcmp(arg, "--core")) {
490                 if (core) {
491                     lose("more than one core file specified\n");
492                 } else {
493                     ++argi;
494                     if (argi >= argc) {
495                         lose("missing filename for --core argument\n");
496                     }
497                     core = copied_string(argv[argi]);
498                     ++argi;
499                 }
500             } else if (0 == strcmp(arg, "--help")) {
501                 /* I think this is the (or a) usual convention: upon
502                  * seeing "--help" we immediately print our help
503                  * string and exit, ignoring everything else. */
504                 print_help();
505                 exit(0);
506             } else if (0 == strcmp(arg, "--version")) {
507                 /* As in "--help" case, I think this is expected. */
508                 print_version();
509                 exit(0);
510             } else if (0 == strcmp(arg, "--dynamic-space-size")) {
511                 ++argi;
512                 if (argi >= argc)
513                     lose("missing argument for --dynamic-space-size");
514                   dynamic_space_size = parse_size_arg(argv[argi++], "--dynamic-space-size");
515 #               ifdef MAX_DYNAMIC_SPACE_END
516                 if (!((DYNAMIC_SPACE_START <
517                        DYNAMIC_SPACE_START+dynamic_space_size) &&
518                       (DYNAMIC_SPACE_START+dynamic_space_size <=
519                        MAX_DYNAMIC_SPACE_END)))
520                   lose("--dynamic-space-size argument %s is too large, max %lu",
521                        argv[argi-1], MAX_DYNAMIC_SPACE_END-DYNAMIC_SPACE_START);
522 #               endif
523             } else if (0 == strcmp(arg, "--control-stack-size")) {
524                 ++argi;
525                 if (argi >= argc)
526                     lose("missing argument for --control-stack-size");
527                 errno = 0;
528                 thread_control_stack_size = parse_size_arg(argv[argi++], "--control-stack-size");
529             } else if (0 == strcmp(arg, "--debug-environment")) {
530                 int n = 0;
531                 printf("; Commandline arguments:\n");
532                 while (n < argc) {
533                     printf(";  %2d: \"%s\"\n", n, argv[n]);
534                     ++n;
535                 }
536                 n = 0;
537                 printf(";\n; Environment:\n");
538                 while (ENVIRON[n]) {
539                     printf(";  %2d: \"%s\"\n", n, ENVIRON[n]);
540                     ++n;
541                 }
542                 ++argi;
543             } else if (0 == strcmp(arg, "--disable-ldb")) {
544                 disable_lossage_handler_p = 1;
545                 ++argi;
546             } else if (0 == strcmp(arg, "--lose-on-corruption")) {
547                 lose_on_corruption_p = 1;
548                 ++argi;
549             } else if (0 == strcmp(arg, "--end-runtime-options")) {
550                 end_runtime_options = 1;
551                 ++argi;
552                 break;
553             } else if (0 == strcmp(arg, "--merge-core-pages")) {
554                 ++argi;
555                 merge_core_pages = 1;
556             } else if (0 == strcmp(arg, "--no-merge-core-pages")) {
557                 ++argi;
558                 merge_core_pages = 0;
559             } else if (0 == strcmp(arg, "--default-merge-core-pages")) {
560                 ++argi;
561                 merge_core_pages = -1;
562             } else {
563                 /* This option was unrecognized as a runtime option,
564                  * so it must be a toplevel option or a user option,
565                  * so we must be past the end of the runtime option
566                  * section. */
567                 break;
568             }
569         }
570         /* This is where we strip out those options that we handle. We
571          * also take this opportunity to make sure that we don't find
572          * an out-of-place "--end-runtime-options" option. */
573         {
574             char *argi0 = argv[argi];
575             int argj = 1;
576             /* (argc - argi) for the arguments, one for the binary,
577                and one for the terminating NULL. */
578             sbcl_argv = successful_malloc((2 + argc - argi) * sizeof(char *));
579             sbcl_argv[0] = argv[0];
580             while (argi < argc) {
581                 char *arg = argv[argi++];
582                 /* If we encounter --end-runtime-options for the first
583                  * time after the point where we had to give up on
584                  * runtime options, then the point where we had to
585                  * give up on runtime options must've been a user
586                  * error. */
587                 if (!end_runtime_options &&
588                     0 == strcmp(arg, "--end-runtime-options")) {
589                     lose("bad runtime option \"%s\"\n", argi0);
590                 }
591                 sbcl_argv[argj++] = arg;
592             }
593             sbcl_argv[argj] = 0;
594         }
595     }
596
597     /* Align down to multiple of page_table page size, and to the appropriate
598      * stack alignment. */
599     dynamic_space_size &= ~(sword_t)(PAGE_BYTES-1);
600 #ifdef LISP_FEATURE_GENCGC
601     dynamic_space_size &= ~(sword_t)(GENCGC_CARD_BYTES-1);
602 #endif
603     thread_control_stack_size &= ~(sword_t)(CONTROL_STACK_ALIGNMENT_BYTES-1);
604
605     /* Preserve the runtime options for possible future core saving */
606     runtime_options->dynamic_space_size = dynamic_space_size;
607     runtime_options->thread_control_stack_size = thread_control_stack_size;
608
609     /* KLUDGE: os_vm_page_size is set by os_init(), and on some
610      * systems (e.g. Alpha) arch_init() needs need os_vm_page_size, so
611      * it must follow os_init(). -- WHN 2000-01-26 */
612     os_init(argv, envp);
613     dyndebug_init(); /* after os_init: do not print output before execve */
614     arch_init();
615     gc_init();
616     validate();
617
618     setup_locale();
619
620     /* If no core file was specified, look for one. */
621     if (!core) {
622         core = search_for_core();
623     }
624
625     /* Make sure that SBCL_HOME is set and not the empty string,
626        unless loading an embedded core. */
627     if (!(sbcl_home && *sbcl_home) && embedded_core_offset == 0) {
628         char *envstring, *copied_core, *dir;
629         char *stem = "SBCL_HOME=";
630         copied_core = copied_string(core);
631         dir = dirname(copied_core);
632         envstring = (char *) calloc(strlen(stem) +
633                                     strlen(dir) +
634                                     1,
635                                     sizeof(char));
636         sprintf(envstring, "%s%s", stem, dir);
637         putenv(envstring);
638         free(copied_core);
639     }
640
641     if (!noinform && embedded_core_offset == 0) {
642         print_banner();
643         fflush(stdout);
644     }
645
646     if (embedded_core_offset == 0) {
647         /* Here we make a last attempt at recognizing an embedded core,
648          * so that a file with an embedded core is a valid argument to
649          * --core.  We take care that any decisions on special behaviour
650          * (suppressed banner, embedded options) have already been made
651          * before we reach this block, so that there is no observable
652          * difference between "embedded" and "bare" images given to
653          * --core. */
654         os_vm_offset_t offset = search_for_embedded_core(core);
655         if (offset != -1)
656             embedded_core_offset = offset;
657     }
658
659 #if defined(SVR4) || defined(__linux__) || defined(__NetBSD__)
660     tzset();
661 #endif
662
663     define_var("nil", NIL, 1);
664     define_var("t", T, 1);
665
666     if (!disable_lossage_handler_p)
667         enable_lossage_handler();
668
669     globals_init();
670
671     initial_function = load_core_file(core, embedded_core_offset);
672     if (initial_function == NIL) {
673         lose("couldn't find initial function\n");
674     }
675 #ifdef LISP_FEATURE_SB_DYNAMIC_CORE
676     os_link_runtime();
677 #endif
678 #ifdef LISP_FEATURE_HPUX
679     /* -1 = CLOSURE_FUN_OFFSET, 23 = SIMPLE_FUN_CODE_OFFSET, we are
680      * not in LANGUAGE_ASSEMBLY so we cant reach them. */
681     return_from_lisp_stub = (void *) ((char *)*((unsigned long *)
682                  ((char *)initial_function + -1)) + 23);
683 #endif
684
685     gc_initialize_pointers();
686
687     arch_install_interrupt_handlers();
688 #ifndef LISP_FEATURE_WIN32
689     os_install_interrupt_handlers();
690 #else
691 /*     wos_install_interrupt_handlers(handler); */
692     wos_install_interrupt_handlers(&exception_frame);
693 #endif
694
695     /* Pass core filename and the processed argv into Lisp. They'll
696      * need to be processed further there, to do locale conversion.
697      */
698     core_string = core;
699     posix_argv = sbcl_argv;
700
701     FSHOW((stderr, "/funcalling initial_function=0x%lx\n",
702           (unsigned long)initial_function));
703 #ifdef LISP_FEATURE_WIN32
704     fprintf(stderr, "\n\
705 This is experimental prerelease support for the Windows platform: use\n\
706 at your own risk.  \"Your Kitten of Death awaits!\"\n");
707     fflush(stdout);
708     fflush(stderr);
709 #endif
710     create_initial_thread(initial_function);
711     lose("CATS.  CATS ARE NICE.\n");
712     return 0;
713 }