1 /*
2 * (SPVW = Speicherverwaltung): Memory Management for CLISP
3 * Bruno Haible 1990-2011, 2016-2018
4 * Sam Steingold 1998-2013, 2016-2017
5 * German comments translated into English: Stefan Kain 2002-03-24
6
7 Content:
8 module management
9 debug utilities
10 memory size
11 object size determination
12 Page Fault and Protection handling
13 Garbage Collection
14 memory provision functions
15 cycle test
16 memory walk
17 elementary string functions
18 other global auxiliary functions
19 initialization
20 loading and storing MEM-files
21 dynamic loading of modules
22 version */
23 #include "lispbibl.c"
24
25 #include "c-strtod.h"
26 #include "sha1.h"
27
28 #ifdef MULTITHREAD
29 #define bzero(ptr,len) memset(ptr,0,len)
30 #define bcopy(source,dest,len) memcpy(dest,source,len)
31 #endif
32
33 /* libsigsegv >= 2.10 defines SIGSEGV_FAULT_ADDRESS_ALIGNMENT in <sigsegv.h>,
34 but older versions didn't define it. */
35 #ifndef SIGSEGV_FAULT_ADDRESS_ALIGNMENT
36 #define SIGSEGV_FAULT_ADDRESS_ALIGNMENT 1UL
37 #endif
38
39 /* in this file, the table macros have a different utilization: */
40 #undef LISPSPECFORM
41 #undef LISPFUN
42 #undef LISPSYM
43 #undef LISPOBJ
44
45 /* table of all SUBRs: out-sourced to SPVWTABF
46 size of this table: */
47 #define subr_count ((sizeof(subr_tab)-varobjects_misaligned)/sizeof(subr_t))
48
49 /* table of all FSUBRs: moved to CONTROL
50 size of this table: */
51 #define fsubr_count (sizeof(fsubr_tab)/sizeof(fsubr_t))
52
53 /* tables of all relocatable pointers: moved to STREAM
54 size of these tables: */
55 #define pseudocode_count (sizeof(pseudocode_tab)/sizeof(Pseudofun))
56 #if defined(MICROSOFT) && !defined(ENABLE_UNICODE)
57 #define pseudodata_count 0
58 #else
59 #define pseudodata_count (sizeof(pseudodata_tab)/sizeof(Pseudofun))
60 #endif
61 /* total table: */
62 #define pseudofun_count (pseudocode_count+pseudodata_count)
63 local struct pseudofun_tab_ { object pointer[pseudofun_count]; } pseudofun_tab;
64
65 /* table of all fixed symbols: moved to SPVWTABS
66 size of these tables: */
67 #define symbol_count ((sizeof(symbol_tab)-varobjects_misaligned)/sizeof(symbol_))
68
69 /* table of all other fixed objects: moved to SPVWTABO
70 size of these tables: */
71 #define object_count (sizeof(object_tab)/sizeof(gcv_object_t))
72
73 /* looping over subr_tab:
74 (NB: subr_tab_ptr_as_object(ptr) turns a traversing pointer
75 into a genuine lisp-object.) */
76 #ifdef MAP_MEMORY_TABLES
77 local uintC total_subr_count;
78 #define for_all_subrs(statement) \
79 do { \
80 var subr_t* ptr = (subr_t*)((char*)&subr_tab+varobjects_misaligned); /* traverse subr_tab */ \
81 var uintC count; \
82 dotimesC(count,total_subr_count, { statement; ptr++; } ); \
83 } while(0)
84 #else
85 #define for_all_subrs(statement) \
86 do { \
87 var module_t* module; /* traverse modules */ \
88 for_modules(all_modules,{ \
89 if (module->initialized) \
90 if (*module->stab_size > 0) { \
91 var subr_t* ptr = module->stab; \
92 var uintC count; \
93 dotimespC(count,*module->stab_size, \
94 { statement; ptr++; } ); \
95 } \
96 }); \
97 } while(0)
98 #endif
99
100 /* On traversal of symbol_tab:
101 turns a traversing pointer into a genuine lisp-object. */
102 #ifdef MAP_MEMORY_TABLES
103 #define symbol_tab_ptr_as_object(ptr) as_object((oint)(ptr))
104 #else
105 #ifdef TYPECODES
106 #define symbol_tab_ptr_as_object(ptr) type_pointer_object(symbol_type,ptr)
107 #else
108 #define symbol_tab_ptr_as_object(ptr) as_object((oint)(ptr)+varobject_bias)
109 #endif
110 #endif
111 /* traversal of symbol_tab: */
112 #define for_all_constsyms(statement) \
113 do { var symbol_* ptr = (symbol_*)((char*)&symbol_tab+varobjects_misaligned); /* pass through symbol_tab */ \
114 var uintC count; \
115 dotimesC(count,symbol_count, { statement; ptr++; } ); \
116 } while(0)
117
118 /* Traverse object_tab: */
119 #define for_all_constobjs(statement) \
120 do { module_t* module; /* loop over modules */ \
121 for_modules(all_modules,{ \
122 if (module->initialized) \
123 if (*module->otab_size > 0) { \
124 gcv_object_t* objptr = module->otab; /* loop over object_tab */ \
125 uintC count; \
126 dotimespC(count,*module->otab_size, \
127 { statement; objptr++; } ); \
128 }}); \
129 } while(0)
130
131 /* Semaphores: decide, if a break is effectless (/=0) or
132 effectual (all = 0) .
133 Are set with set_break_sem_x and deleted with clr_break_sem_x again. */
134 #if !defined(MULTITHREAD)
135 /* in MT these semaphores are per thread */
136 global break_sems_ break_sems;
137 #endif
138 /* break_sem_0 == break_sems.einzeln[0]
139 set, as long as a page-fault-handling is in progress
140 break_sem_1 == break_sems.einzeln[1]
141 set, as long as the memory management forbids a break
142 (so that empty memory cannot be traversed by the GC)
143 break_sem_2 == break_sems.einzeln[2]
144 for package-management on lower level and hashtable-management
145 break_sem_3 == break_sems.einzeln[3]
146 for package-management on higher level
147 break_sem_4 == break_sems.einzeln[4]
148 set, as long as external functions are being called.
149 break_sem_5 == break_sems.einzeln[5]
150 set, as long as (UNIX) a signal-handler is being called. */
151
152 /* --------------------------------------------------------------------------
153 module management */
154
155 #include "spvw_module.c"
156
157 /* --------------------------------------------------------------------------
158 debug-helper */
159
160 #include "spvw_debug.c"
161
162 /* --------------------------------------------------------------------------
163 our own alloca() */
164
165 #include "spvw_alloca.c"
166
167 /* --------------------------------------------------------------------------
168 fast program-exit */
169
170 local _Noreturn void quit_instantly (int);
171 /* --------------------------------------------------------------------------
172 bit mask computation */
173
174 /* Compute the set of bits used by the interval [start,end]. */
bits_used_by_range(uintP start,uintP end)175 local uintP bits_used_by_range (uintP start, uintP end) {
176 /* If start < end, it goes like this:
177 Split start and end (as bit sequences) into a common part
178 (the longest common sequence of bits) and the first bit that differs.
179 Then the result is
180 the common part, OR that different bit, OR all lower bits.
181 For example:
182 start = 0001001 011000000
183 end = 0001001 101011111
184 => range_mask = 0001001 111111111
185 because x1 = 0001001 011111111
186 and x2 = 0001001 100000000
187 are consecutive numbers in the range (start <= x1 < x2 <= end)
188 with x1 | x2 = range_mask.
189 The resulting code is symmetric in start <--> end, therefore works
190 also when start > end. */
191 var uintP diff = start ^ end;
192 diff |= diff >> 1;
193 diff |= diff >> 2;
194 diff |= diff >> 4;
195 diff |= diff >> 8;
196 diff |= diff >> 16;
197 #if (pointer_bitsize > 32)
198 diff |= diff >> 32;
199 #endif
200 var uintP range_bits = start | diff;
201 ASSERT(range_bits == (end | diff));
202 return range_bits;
203 }
204
205 /* --------------------------------------------------------------------------
206 memory management, common part */
207
208 /* method of the memory management: */
209 #if defined(SPVW_BLOCKS) && defined(SPVW_MIXED) /* e.g. ATARI */
210 #define SPVW_MIXED_BLOCKS
211 #if !defined(TRIVIALMAP_MEMORY)
212 /* Blocks grow like this: |******--> <--****| */
213 #define SPVW_MIXED_BLOCKS_OPPOSITE
214 #else /* defined(TRIVIALMAP_MEMORY) */
215 #if (!defined(WIDE_SOFT) || defined(CONS_HEAP_GROWS_DOWN)) && !defined(CONS_HEAP_GROWS_UP)
216 /* Blocks grow like this: |******--> <--****| */
217 #define SPVW_MIXED_BLOCKS_OPPOSITE
218 #else
219 /* Blocks grow like this: |******--> |***--> */
220 #define SPVW_MIXED_BLOCKS_STAGGERED
221 #endif
222 #endif
223 #endif
224 #if defined(SPVW_BLOCKS) && defined(SPVW_PURE) /* e.g. UNIX_LINUX, Linux 0.99.7 */
225 #define SPVW_PURE_BLOCKS
226 #endif
227 #if defined(SPVW_PAGES) && defined(SPVW_MIXED) /* e.g. HP9000_800 */
228 #define SPVW_MIXED_PAGES
229 #endif
230 #if defined(SPVW_PAGES) && defined(SPVW_PURE) /* e.g. SUN4 */
231 #define SPVW_PURE_PAGES
232 #endif
233
234 /* --------------------------------------------------------------------------
235 Memory map facility */
236
237 #include "vma-iter.h"
238
239 #if VMA_ITERATE_SUPPORTED
240
dump_process_memory_map_callback(void * data,uintptr_t start,uintptr_t end,unsigned int flags)241 local int dump_process_memory_map_callback (void *data,
242 uintptr_t start, uintptr_t end,
243 unsigned int flags)
244 {
245 unused(flags);
246 fprintf((FILE*)data," 0x%lx - 0x%lx\n",
247 (unsigned long)start, (unsigned long)(end-1));
248 return 0; /* continue */
249 }
250
251 /* Print out the memory map of the process. */
dump_process_memory_map(FILE * out)252 local void dump_process_memory_map (FILE* out)
253 {
254 fprint(out,"Memory dump:\n");
255 vma_iterate (&dump_process_memory_map_callback, out);
256 }
257
258 #endif
259
260 /* --------------------------------------------------------------------------
261 Page-Allocation */
262
263 #include "spvw_mmap.c"
264
265 /* Check the MAPPABLE_ADDRESS_RANGE_* values.
266 Return an exit code. */
mappable_address_range_check(void)267 local int mappable_address_range_check (void)
268 {
269 var int exitcode = 0;
270 #if defined(HAVE_MMAP_ANON) || defined(HAVE_MMAP_DEVZERO) || defined(HAVE_MACH_VM) || defined(HAVE_WIN32_VM)
271 #if defined(MAPPABLE_ADDRESS_RANGE_START) && defined(MAPPABLE_ADDRESS_RANGE_END)
272 var const uintL count = 256;
273 var uintL i;
274 mmap_init_pagesize();
275 mmap_init();
276 #if VMA_ITERATE_SUPPORTED
277 dump_process_memory_map(stdout);
278 #endif
279 fprint(stdout,"Starting check...\n");
280 for (i = 0; i <= count; i++) {
281 var uintP addr = MAPPABLE_ADDRESS_RANGE_START + ((MAPPABLE_ADDRESS_RANGE_END - MAPPABLE_ADDRESS_RANGE_START) / count) * i;
282 addr = addr & ~(mmap_pagesize-1);
283 var uintP endaddr = addr + mmap_pagesize;
284 if (mmap_prepare(&addr,&endaddr,false) < 0
285 || mmap_zeromap((void*)addr,endaddr-addr) < 0) {
286 fprintf(stdout," %p FAILED\n",(void*)addr);
287 exitcode = 1;
288 } else {
289 fprintf(stdout," %p OK\n",(void*)addr);
290 }
291 }
292 #if VMA_ITERATE_SUPPORTED
293 dump_process_memory_map(stdout);
294 #endif
295 #else
296 fprint(stdout,"Nothing to check: MAPPABLE_ADDRESS_RANGE_START and MAPPABLE_ADDRESS_RANGE_END are not defined.\n");
297 #endif
298 #else
299 fprint(stdout,"Nothing to check: The OS does not provide memory mapping facilities.\n");
300 #endif
301 return exitcode;
302 }
303
304 #if defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY)
305
306 #include "spvw_singlemap.c"
307
308 #if defined(SINGLEMAP_MEMORY) && defined(HAVE_WIN32_VM)
309 /* Despite SINGLEMAP_MEMORY, a relocation may be necessary
310 at loadmem() time. */
311 #define SINGLEMAP_MEMORY_RELOCATE
312 #endif
313
314 #endif /* SINGLEMAP_MEMORY || TRIVIALMAP_MEMORY */
315
316 /* Global variables. */
317
318 #ifndef MULTITHREAD
319
320 /* the STACK: */
321 #if !defined(STACK_register)
322 modexp gcv_object_t* STACK;
323 #endif
324 #ifdef HAVE_SAVED_STACK
325 modexp gcv_object_t* saved_STACK;
326 #endif
327
328 /* MULTIPLE-VALUE-SPACE: */
329 #if !defined(mv_count_register)
330 modexp uintC mv_count;
331 #endif
332 #ifdef NEED_temp_mv_count
333 global uintC temp_mv_count;
334 #endif
335 #ifdef HAVE_SAVED_mv_count
336 modexp uintC saved_mv_count;
337 #endif
338 modexp object mv_space [mv_limit-1];
339 #ifdef NEED_temp_value1
340 global object temp_value1;
341 #endif
342 #ifdef HAVE_SAVED_value1
343 modexp object saved_value1;
344 #endif
345
346 /* During the execution of a SUBR, FSUBR: the current SUBR resp. FSUBR */
347 #if !defined(back_trace_register)
348 modexp p_backtrace_t back_trace = NULL;
349 #endif
350 #ifdef HAVE_SAVED_back_trace
351 modexp p_backtrace_t saved_back_trace;
352 #endif
353
354 /* during callbacks, the saved registers: */
355 #if defined(HAVE_SAVED_REGISTERS)
356 global struct registers * callback_saved_registers = NULL;
357 #endif
358
359 /* stack-limits: */
360 #ifndef NO_SP_CHECK
361 global void* SP_bound; /* SP-growth-limit */
362 #endif
363 modexp void* STACK_bound; /* STACK-growth-limit */
364 global void* STACK_start; /* STACK initial value */
365
366 /* the lexical environment: */
367 global gcv_environment_t aktenv;
368
369 global unwind_protect_caller_t unwind_protect_to_save;
370
371 /* variables for passing of information to the top of the handler: */
372 global handler_args_t handler_args;
373
374 /* As only whole regions of handlers are deactivated and activated again,
375 we treat the handlers on deactivation separately, but we maintain
376 a list of the STACK-regions, in which the handlers are deactivated.
377 A handler counts as inactive if and only if:
378 low_limit <= handler < high_limit
379 is true for one of the regions listed in inactive_handlers */
380 global stack_range_t* inactive_handlers = NULL;
381
382 #endif /* !MULTITHREAD */
383
384 /* --------------------------------------------------------------------------
385 Multithreading */
386
387 #ifndef MULTITHREAD
388
389 #define for_all_threadobjs(statement) \
390 do { var gcv_object_t* objptr = (gcv_object_t*)&aktenv; \
391 var uintC count; \
392 dotimespC(count,sizeof(gcv_environment_t)/sizeof(gcv_object_t), \
393 { statement; objptr++; }); \
394 } while(0)
395
396 #define for_all_STACKs(statement) \
397 do { var gcv_object_t* objptr = &STACK_0; \
398 { statement; } \
399 } while(0)
400
401 #define for_all_back_traces(statement) \
402 do { var p_backtrace_t bt = back_trace; \
403 { statement; } \
404 } while(0)
405
406 #else
407
408 /* forward decalration of MT signal handler */
409 local void install_async_signal_handlers();
410 local void *signal_handler_thread(void *arg);
411
412 /* Mutex protecting the set of threads. */
413 global xmutex_t allthreads_lock;
414 /* double linked list with all threads */
415 local struct {
416 /* new threads are appended to the tail (when CTRL-C usually the first
417 thread is interrupted - probably "main thread").*/
418 clisp_thread_t *head, *tail;
419 /* how many active threads we have. can be used to limit the number of
420 threads without scanning the list */
421 uintC count;
422 } allthreads = { NULL, NULL, 0 };
423
424 /* per thread symvalues of special variables are allocated on "pages" of
425 1024 gcv_object_t each. Freshly new build clisp image contains less
426 than 900 special symbols. */
427 #define THREAD_SYMVALUES_ALLOCATION_SIZE (1024*sizeof(gcv_object_t))
428 #define SYMVALUES_PER_PAGE (THREAD_SYMVALUES_ALLOCATION_SIZE/sizeof(gcv_object_t))
429 /* Set of threads. */
430 local xthread_t thr_signal_handler; /* the id of the signal handling thread */
431
432 /* the first index in _ptr_symvalues used for per thread symbol bindings */
433 #define FIRST_SYMVALUE_INDEX 1
434 /* Number of symbol values currently in use in every thread. */
435 /* The first symvalue in thread is dummy - for faster Symbol_value*/
436 local uintL num_symvalues = FIRST_SYMVALUE_INDEX;
437 /* Maximum number of symbol values in every thread before new thread-local
438 storage must be added.
439 = THREAD_SYMVALUES_ALLOCATION_SIZE/sizeof(gcv_object_t) */
440 global uintL maxnum_symvalues;
441 /* lock guarding the addition of new per thread special variables. */
442 local xmutex_t thread_symvalues_lock;
443
444 /* UP: checks that the calling thread is the only one running.
445 used only from savemem(). defined here in order not to expose the
446 threads array.
447 no locking is performed. if returns true - the caller may be sure that
448 there is no other running thread (only the caller) */
449 global bool single_running_threadp();
single_running_threadp()450 global bool single_running_threadp()
451 {
452 return allthreads.head->thr_next == NULL;
453 }
454
455 #ifdef DEBUG_GCSAFETY
456 /* used during static initialization (before main() is called)
457 at that time the multithreading has not been initialized and
458 there is no current thread. */
459 local uintL dummy_alloccount=0;
460 local bool use_dummy_alloccount=true;
current_thread_alloccount()461 modexp uintL* current_thread_alloccount()
462 {
463 /* if MT is initialized - return the real alloccount.
464 otherwise (during subr_tab static initialization and signal handling) -
465 the dummy one - simple there is no current lisp thread */
466 return !use_dummy_alloccount ? ¤t_thread()->_alloccount : &dummy_alloccount;
467 }
468 #endif
469
470 #ifdef per_thread
471 modexp per_thread clisp_thread_t *_current_thread;
472 #else
473 #if USE_CUSTOM_TLS == 1
474 modexp xthread_key_t current_thread_tls_key;
475 #elif USE_CUSTOM_TLS == 2
476
477 modexp tsd threads_tls;
478
479 /* A thread-specific data entry which will never */
480 /* appear valid to a reader. Used to fill in empty */
481 /* cache entries to avoid a check for 0. */
482 local tse invalid_tse = {INVALID_QTID, 0, 0, 0};
483
tsd_initialize()484 local void tsd_initialize()
485 {
486 var int i;
487 spinlock_init(&(threads_tls.lock));
488 for (i = 0; i < TS_CACHE_SIZE; ++i) {
489 threads_tls.cache[i] = &invalid_tse;
490 }
491 memset(threads_tls.hash,0,sizeof(threads_tls.hash));
492 }
493
494 /* entry should be allocated by the caller (or reside on
495 the stack at a location that will survive the thread
496 lifespan) */
tsd_setspecific(tse * entry,void * value)497 modexp void tsd_setspecific(tse *entry, void *value)
498 {
499 var xthread_t self = xthread_self();
500 var int hash_val = TSD_HASH(self);
501 entry -> thread = self;
502 entry -> value = value;
503 entry -> qtid = INVALID_QTID;
504 spinlock_acquire(&(threads_tls.lock));
505 entry -> next = threads_tls.hash[hash_val];
506 *(threads_tls.hash + hash_val)=entry;
507 spinlock_release(&(threads_tls.lock));
508 }
509
510 /* UP: Remove thread-specific data for current thread. Should be called on
511 thread exit */
tsd_remove_specific()512 global void tsd_remove_specific()
513 {
514 var xthread_t self = xthread_self();
515 var unsigned hash_val = TSD_HASH(self);
516 var tse *entry;
517 spinlock_acquire(&(threads_tls.lock));
518 var tse **link = threads_tls.hash + hash_val;
519 entry = *link;
520 while (entry != NULL && entry->thread != self) {
521 link = &(entry->next);
522 entry = *link;
523 }
524 *link = entry->next; /* remove the entry from the list */
525 entry->qtid = INVALID_QTID;
526 spinlock_release(&(threads_tls.lock));
527 /* now remove it from the cache as well. it is important since the entry
528 is on the C stack of dying thread and soon the memory will be reclaimed.
529 NB: this may cause cache misses in worst case (from other threads)*/
530 var int i;
531 for (i = 0; i < TS_CACHE_SIZE; ++i) {
532 if (threads_tls.cache[i] == entry)
533 threads_tls.cache[i] = &invalid_tse;
534 }
535 }
536
537 /* slow path locks - but uses spinlock for very short time and it is
538 not likely to cause contention */
tsd_slow_getspecific(unsigned long qtid,tse * volatile * cache_ptr)539 modexp void* tsd_slow_getspecific(unsigned long qtid,
540 tse * volatile *cache_ptr)
541 {
542 ASSERT(qtid != INVALID_QTID);
543 var xthread_t self = xthread_self();
544 var unsigned hash_val = TSD_HASH(self);
545 /* lock the hash table */
546 spinlock_acquire(&(threads_tls.lock));
547 var tse *entry = threads_tls.hash[hash_val];
548 while (entry != NULL && entry->thread != self) {
549 entry = entry->next;
550 }
551 #if defined(UNIX_MACOSX) && defined(GENERATIONAL_GC)
552 /* needed since we may get called from SIGPIPE handler in
553 libsigsegv thread where there is no lisp thread associated*/
554 if (!entry) { spinlock_release(&(threads_tls.lock)); return NULL; }
555 #endif
556 /* Set cache_entry. */
557 entry->qtid = qtid;
558 /* It's safe to do this asynchronously. Either value */
559 /* is safe, though may produce spurious misses. */
560 /* We're replacing one qtid with another one for the */
561 /* same thread. */
562 *cache_ptr = entry;
563 /* Again this is safe since pointer assignments are */
564 /* presumed atomic, and either pointer is valid. */
565 spinlock_release(&(threads_tls.lock));
566 return entry->value;
567 }
568 #elif USE_CUSTOM_TLS == 3
569 #if defined(POSIX_THREADS)
570 /* UP: return the base address and size of current thread stack
571 > base: base address (top of the stack if SP_DOWN)
572 > size: stack size */
get_stack_region(aint * base,size_t * size)573 local bool get_stack_region(aint *base, size_t *size)
574 {
575 #ifdef UNIX_MACOSX
576 var pthread_t self_id;
577 self_id = pthread_self();
578 *base = (aint)pthread_get_stackaddr_np(self_id);
579 *size = pthread_get_stacksize_np(self_id);
580 *base -= *size; /* always SP_DOWN but *base is bottom of the stack */
581 return true;
582 #else /* assume fairly recent pthreads implementation */
583 var pthread_attr_t attr;
584 if (0 == pthread_getattr_np(pthread_self(), &attr)) {
585 var bool ret = (0 == pthread_attr_getstack(&attr, (void **)base, size));
586 pthread_attr_destroy(&attr);
587 return ret;
588 }
589 #endif
590 return false;
591 }
592 #endif /* POSIX_THREADS */
593 #ifdef WIN32_THREADS
get_stack_region(aint * base,size_t * size)594 local bool get_stack_region(aint *base, size_t *size)
595 {
596 MEMORY_BASIC_INFORMATION minfo;
597 aint stack_bottom;
598 size_t stack_size;
599 VirtualQuery(&minfo, &minfo, sizeof(minfo));
600 stack_bottom = (aint)minfo.AllocationBase;
601 stack_size = minfo.RegionSize;
602 /* Add up the sizes of all the regions with the same */
603 /* AllocationBase. */
604 while( 1 ) {
605 VirtualQuery((void *)(stack_bottom+stack_size), &minfo, sizeof(minfo));
606 if ( stack_bottom == (aint)minfo.AllocationBase )
607 stack_size += minfo.RegionSize;
608 else
609 break;
610 }
611 *base = stack_bottom;
612 *size = stack_size;
613 return true;
614 }
615 #endif /* WIN32_THREADS */
616
617 modexp clisp_thread_t *threads_map[1UL << (32 - TLS_SP_SHIFT)]={0};
set_current_thread(clisp_thread_t * thr)618 global void set_current_thread(clisp_thread_t *thr)
619 {
620 /* we should initialize the threads_map items in the
621 stack range of the current thread to point to thr. */
622 var aint stack_base, p;
623 var size_t stack_size, mapped=0;
624 if (!get_stack_region(&stack_base,&stack_size)) {
625 /* this either works or not. so on first (main) thread created
626 it will barf if not supported. */
627 fprint(stderr,"FATAL: get_stack_region() failed.");
628 abort();
629 }
630 for (p=stack_base, mapped=0;
631 mapped < stack_size;
632 p+=TLS_PAGE_SIZE, mapped+=TLS_PAGE_SIZE) {
633 threads_map[(unsigned long)p >> TLS_SP_SHIFT] = thr;
634 }
635 }
636 #else /* bad value for USE_CUSTOM_TLS */
637 #error "USE_CUSTOM_TLS should be defined as 1,2 or 3."
638 #endif
639 #endif /* !per_thread */
640
641 /* forward definition */
642 extern void initialize_circ_detection();
643
644 /* UP: Initialization of multithreading. Called at the beginning of main().*/
init_multithread(void)645 local void init_multithread (void) {
646 xthread_init();
647 /* TODO: put all global locks in some table. Soon we will have too many
648 of them and the things will become unmanageble. */
649 xmutex_init(&allthreads_lock); /* threads lock */
650 xmutex_init(&thread_symvalues_lock); /* for adding new thread symvalues */
651 xmutex_init(&open_files_lock); /* open files lock i.e. O(open_files) */
652 xmutex_init(&all_finalizers_lock); /* finalizer lock */
653 xmutex_init(&all_mutexes_lock); /* O(all_mutexes) lock */
654 xmutex_init(&all_exemptions_lock); /* O(all_exemptions) lock */
655 xmutex_init(&all_weakpointers_lock); /* O(all_weakpointers) lock */
656 xmutex_init(&all_packages_lock); /* O(all_packages) lock */
657 xmutex_init(&gensym_lock); /* GENSYM lock */
658 xmutex_init(&gentemp_lock); /* internal GENTEMP counter lock */
659
660 initialize_circ_detection(); /* initialize the circ detection */
661 spinlock_init(&timeout_call_chain_lock);
662 maxnum_symvalues = SYMVALUES_PER_PAGE;
663 #if !defined(per_thread)
664 #if USE_CUSTOM_TLS == 1
665 xthread_key_create(¤t_thread_tls_key);
666 #elif USE_CUSTOM_TLS == 2
667 tsd_initialize();
668 #elif USE_CUSTOM_TLS == 3
669 #endif
670 #endif
671 }
672
673 /* UP: Makes per thread bindings (symvalues) for all standard special
674 variables. Called after the LISP heap and symbols are initialized.
675 < num_symvalues: modified.
676 < allthreads: _ptr_symvalues up to num_symvalues initialized.
677 < symbol_tab: tls_index of all special symbols initialized.*/
init_multithread_special_symbols()678 local void init_multithread_special_symbols()
679 {
680 /* currently there is just a single thread. get it.*/
681 var clisp_thread_t *thr=current_thread();
682 for_all_constsyms({
683 if (special_var_p(ptr)) {
684 /* Also we do not care about possibility to exceed the already allocated
685 space for _symvalues - we have enough space for standard symbols.*/
686 thr->_ptr_symvalues[num_symvalues]=SYMVALUE_EMPTY;
687 ptr->tls_index=num_symvalues++;
688 }
689 });
690 /* symbol_tab is initialized. it's safe to enable interrupts in main thread */
691 thr->_ptr_symvalues[TheSymbol(S(defer_interrupts))->tls_index] = NIL;
692 thr->_ptr_symvalues[TheSymbol(S(deferred_interrupts))->tls_index] = NIL;
693 }
694
695 /* UP: allocates a LISP stack for new thread (except for the main one)
696 > thread: the CLISP thread object for which we are allocating STACK
697 > stack_size: the number of gcv_object_t that the STACK will be able to hold
698 Always called with main thread lock - so we are not going to call
699 begin/end_system_call. */
allocate_lisp_thread_stack(clisp_thread_t * thread,uintM stack_size)700 local void* allocate_lisp_thread_stack(clisp_thread_t* thread, uintM stack_size)
701 {
702 var uintM low,high,byte_size = stack_size*sizeof(gcv_object_t)+0x40;
703 begin_system_call();
704 low = (uintM)malloc(byte_size);
705 end_system_call();
706 if (!low) return NULL;
707 high = low + byte_size;
708 #ifdef STACK_DOWN
709 thread->_STACK_bound = (gcv_object_t *)(low + 0x40);
710 thread->_STACK = (gcv_object_t *)high;
711 #endif
712 #ifdef STACK_UP
713 thread->_STACK_bound = (gcv_object_t *)(high - 0x40);
714 thread->_STACK = (gcv_object_t *)low;
715 #endif
716 thread->_STACK_start=thread->_STACK;
717 return thread->_STACK;
718 }
719
720 /* UP: creates new cisp_thread_t structure and allocates LISP stack.
721 > lisp_stack_size: the size of Lisp STACK to allocate (in gcv_object_t)
722 when 0 - this is the very first thread, so we may(should not)
723 perform some initializations
724 < clisp thread object
725 It is always called with the main thread mutex locked. */
create_thread(uintM lisp_stack_size)726 global clisp_thread_t* create_thread(uintM lisp_stack_size)
727 {
728 /* TBD: may be limit the number of active threads? */
729 var clisp_thread_t* thread;
730 begin_system_call();
731 thread=(clisp_thread_t *)malloc(sizeof(clisp_thread_t));
732 end_system_call();
733 if (!thread) return NULL;
734 begin_system_call();
735 memset(thread,0,sizeof(clisp_thread_t)); /* zero-up everything */
736 /* init _symvalues "proxy" */
737 thread->_ptr_symvalues = (gcv_object_t *)malloc(sizeof(gcv_object_t)*
738 maxnum_symvalues);
739 if (!thread->_ptr_symvalues) {
740 free(thread);
741 end_system_call();
742 return NULL;
743 }
744 end_system_call();
745 { /* initialize the per thread special vars bindings to be "empty" */
746 var gcv_object_t* objptr = thread->_ptr_symvalues;
747 var uintC count;
748 dotimespC(count,maxnum_symvalues,{ *objptr++ = SYMVALUE_EMPTY; });
749 /* fill thread _object_tab with NIL-s in case GC is triggered before
750 they are really initialized.*/
751 objptr=(gcv_object_t*)&(thread->_object_tab);
752 dotimespC(count,sizeof(thread->_object_tab)/sizeof(gcv_object_t),
753 { *objptr++=NIL; });
754 /* allow interrupts in the new, not yet spawned thread, unless this is the
755 main one which will be handled in init_multithread_special_symbols() */
756 var gcv_object_t *symvals = thread->_ptr_symvalues;
757 if (num_symvalues != FIRST_SYMVALUE_INDEX) {
758 symvals[TheSymbol(S(defer_interrupts))->tls_index] = NIL;
759 symvals[TheSymbol(S(deferred_interrupts))->tls_index] = NIL;
760 }
761 }
762 if (lisp_stack_size) {
763 /* allocate the LISP stack */
764 if (!allocate_lisp_thread_stack(thread,lisp_stack_size)) {
765 begin_system_call();
766 free(thread->_ptr_symvalues);
767 free(thread);
768 end_system_call();
769 return NULL;
770 }
771 /* we own the stack and should free it on return */
772 thread->_own_stack=true;
773 }
774 spinlock_init(&thread->_gc_suspend_request); spinlock_acquire(&thread->_gc_suspend_request);
775 spinlock_init(&thread->_gc_suspend_ack); spinlock_acquire(&thread->_gc_suspend_ack);
776 xmutex_raw_init(&thread->_gc_suspend_lock);
777 spinlock_init(&thread->_signal_reenter_ok);
778 /* initialize the environment*/
779 thread->_aktenv.var_env = NIL;
780 thread->_aktenv.fun_env = NIL;
781 thread->_aktenv.block_env = NIL;
782 thread->_aktenv.go_env = NIL;
783 thread->_aktenv.decl_env = O(top_decl_env);
784 /* VTZ:TODO. get the right SP_bound (pthreads and win32 can provide it ??).
785 in USE_CUSTOM_TLS we have the functions. */
786 #ifndef NO_SP_CHECK
787 thread->_SP_bound=0;
788 #endif
789 /* add to allthreads list (at the end) */
790 if (allthreads.tail) {
791 allthreads.tail->thr_next = thread;
792 thread->thr_prev = allthreads.tail;
793 allthreads.tail = thread;
794 } else {
795 allthreads.head = allthreads.tail = thread;
796 }
797 allthreads.count++;
798 return thread;
799 }
800
801 /* UP: removes the current_thread from the list (array) of threads.
802 Also frees any allocated resource.
803 > thread: thread to be removed */
delete_thread(clisp_thread_t * thread)804 global void delete_thread (clisp_thread_t *thread) {
805 /* lock the threads mutex. we are going to change allthreads[].
806 NB: we are called here in 2 cases:
807 1. thread is exiting - we do not hold allthreads_lock, but interrupts
808 are disabled.
809 2. thread has failed to start - in this case we already hold allthreads_lock */
810 var bool threads_locked = false;
811 if (thread == current_thread()) {
812 begin_blocking_system_call();
813 xmutex_lock(&allthreads_lock);
814 end_blocking_system_call();
815 threads_locked = true;
816 }
817 /* destroy OS mutex */
818 begin_system_call();
819 xmutex_raw_destroy(&thread->_gc_suspend_lock);
820 end_system_call();
821
822 #ifdef WIN32_NATIVE
823 /* deinitialize COM library */
824 begin_system_call();
825 CoUninitialize();
826 end_system_call();
827 #endif
828
829 /* remove from threads list */
830 if (thread->thr_prev) { /* ! first threads */
831 thread->thr_prev->thr_next = thread->thr_next;
832 } else {
833 allthreads.head = thread->thr_next;
834 }
835 if (thread->thr_next) { /* ! last_thread */
836 thread->thr_next->thr_prev = thread->thr_prev;
837 } else {
838 allthreads.tail = thread->thr_prev;
839 }
840 allthreads.count--;
841
842 if (!allthreads.head) { /* this was the last thread ?*/
843 begin_system_call();
844 xmutex_unlock(&allthreads_lock);
845 end_system_call();
846 quit();
847 return; /* quit will unwind the stack and call hooks */
848 }
849 /* no globals for this thread record anymore */
850 TheThread(thread->_lthread)->xth_globals = NULL;
851 /* DO NOT remove from global list of all threads - i.e.
852 O(all_threads) = deleteq(O(all_threads), thread->_lthread); */
853
854 /* The LISP stack should be unwound so no
855 interesting stuff on it. Let's deallocate it.*/
856 begin_system_call();
857 if (thread->_own_stack) {
858 #ifdef STACK_DOWN
859 free((char *)thread->_STACK_bound - 0x40);
860 #else /* STACK_UP */
861 free(thread->_STACK_start);
862 #endif
863 }
864 free(thread->_ptr_symvalues); /* free per trread special var bindings */
865 free(thread);
866 end_system_call();
867 #if USE_CUSTOM_TLS == 2
868 /* cleanup the cache - the memory on the C stack will become invalid */
869 if (thread == current_thread())
870 tsd_remove_specific();
871 #endif
872 if (threads_locked) { /* here we may not have current_thread() anymore*/
873 begin_system_call();
874 xmutex_unlock(&allthreads_lock);
875 end_system_call();
876 }
877 }
878
879 #define for_all_threads(statement) \
880 do { var clisp_thread_t *_cthread = allthreads.head; \
881 while (_cthread) { \
882 var clisp_thread_t *thread = _cthread; \
883 _cthread=_cthread->thr_next; statement; } \
884 } while(0)
885
886 /* UP: reallocates _ptr_symvalues in all threads - so there is a place for
887 nsyms per thread symbol values.
888 > nsyms: number od symvalues to be available.
889 < true if reallocation succeeded.
890 should be called with allthreads_lock locked */
realloc_threads_symvalues(uintL nsyms)891 local bool realloc_threads_symvalues(uintL nsyms)
892 {
893 if (nsyms <= maxnum_symvalues) /* we already have enough place */
894 return true;
895 for_all_threads({
896 var gcv_object_t *p=(gcv_object_t *)realloc(thread->_ptr_symvalues,
897 nsyms*sizeof(gcv_object_t));
898 /* in case of allocation error - abort immediately */
899 if (p) thread->_ptr_symvalues=p; else return false;
900 /* initialize all newly allocated cells to SYMVALUE_EMPTY (otherwise
901 we will have to lock threads when we add new per thread variable) */
902 var gcv_object_t* objptr = thread->_ptr_symvalues + num_symvalues;
903 var uintC count;
904 for (count = num_symvalues; count<nsyms; count++)
905 *objptr++ = SYMVALUE_EMPTY;
906 });
907 return true;
908 }
909
910 #define for_all_threadobjs(statement) \
911 for_all_threads({ \
912 var gcv_object_t* objptr = (gcv_object_t*)(&thread->_aktenv); \
913 var uintC count; \
914 dotimespC(count,sizeof(thread->_aktenv)/sizeof(gcv_object_t), \
915 { statement; objptr++; }); \
916 objptr=thread->_ptr_symvalues; \
917 dotimespC(count,num_symvalues,{ statement; objptr++; }); \
918 objptr=(gcv_object_t*)&(thread->_object_tab); \
919 dotimespC(count,sizeof(thread->_object_tab)/sizeof(gcv_object_t), \
920 { statement; objptr++; }); \
921 })
922
923 #define for_all_STACKs(statement) \
924 for_all_threads({ \
925 var gcv_object_t* objptr = STACKpointable(thread->_STACK); \
926 { statement; } \
927 })
928
929 #define for_all_back_traces(statement) \
930 for_all_threads({ var p_backtrace_t bt = thread->_back_trace; \
931 { statement; } \
932 })
933
934 #endif
935
936 /* --------------------------------------------------------------------------
937 Page-Management */
938
939 #include "spvw_page.c"
940 #if !defined(OLD_GC)
941 #include "spvw_heap.c"
942 #else
943 #include "spvw_heap_old.c"
944 #endif
945 #if !defined(OLD_GC)
946 #include "spvw_global.c"
947 #else
948 #include "spvw_global_old.c"
949 #endif
950
951 #ifdef SPVW_PAGES
952
953 /* A dummy-page for lastused: */
954 local NODE dummy_NODE;
955 #define dummy_lastused (&dummy_NODE)
956
957 #endif
958
959 /* ------------------------------------------------------------------------ */
960
961 #if defined(NOCOST_SP_CHECK) && !defined(WIN32_NATIVE)
962 /* Check for near stack overflow. */
near_SP_overflow(void)963 global bool near_SP_overflow (void) {
964 /* Force a stack overflow if there is not a minimum of room available. */
965 var uintB dummy[0x1001];
966 dummy[0] = 0; dummy[0x800] = 0; dummy[0x1000] = 0;
967 #ifdef GNU
968 alloca(1); /* Makes this function non-inlinable. */
969 #endif
970 return false;
971 }
972 #endif
973
974 /* At overflow of one of the stacks: */
SP_ueber(void)975 global _Noreturn void SP_ueber (void) {
976 var bool interactive_p = interactive_stream_p(Symbol_value(S(debug_io)));
977 begin_system_call();
978 fprint(stderr,"\n");
979 fprint(stderr,GETTEXTL("*** - " "Program stack overflow. RESET"));
980 fprint(stderr,"\n");
981 fflush(stderr);
982 end_system_call();
983 if (interactive_p)
984 reset(1);
985 else {
986 /* non-interactive session: quit */
987 final_exitcode = 1; quit();
988 }
989 }
STACK_ueber(void)990 modexp _Noreturn void STACK_ueber (void) {
991 var bool interactive_p = interactive_stream_p(Symbol_value(S(debug_io)));
992 begin_system_call();
993 fprint(stderr,"\n");
994 fprint(stderr,GETTEXTL("*** - " "Lisp stack overflow. RESET"));
995 fprint(stderr,"\n");
996 fflush(stderr);
997 end_system_call();
998 if (interactive_p)
999 reset(1);
1000 else {
1001 /* non-interactive session: quit */
1002 final_exitcode = 1; quit();
1003 }
1004 }
1005
1006 /* -------------------------------------------------------------------------
1007 GC-Statistics */
1008
1009 #include "spvw_gcstat.c"
1010
1011 /* --------------------------------------------------------------------------
1012 Memory-Size */
1013
1014 #include "spvw_space.c"
1015
1016 /* --------------------------------------------------------------------------
1017 Marks */
1018
1019 #include "spvw_mark.c"
1020
1021 /* --------------------------------------------------------------------------
1022 object size determination */
1023
1024 #include "spvw_objsize.c"
1025
1026 /* --------------------------------------------------------------------------
1027 Memory Update */
1028
1029 #include "spvw_update.c"
1030
1031 /* --------------------------------------------------------------------------
1032 Page Fault and Protection Handling */
1033
1034 #if defined(GENERATIONAL_GC)
1035
1036 #if !defined(OLD_GC)
1037 #include "spvw_fault.c"
1038 #else
1039 #include "spvw_fault_old.c"
1040 #endif
1041
1042 #endif /* GENERATIONAL_GC */
1043
1044 /* --------------------------------------------------------------------------
1045 Signal handlers */
1046
1047 #include "spvw_sigsegv.c"
1048 #include "spvw_sigcld.c"
1049 #include "spvw_sigpipe.c"
1050 #include "spvw_sigint.c"
1051 #include "spvw_sigwinch.c"
1052 #include "spvw_sigterm.c"
1053
1054 /* --------------------------------------------------------------------------
1055 Garbage-Collector */
1056
1057 /* defines memory region in the varobject heap page.
1058 used during sweep phase and holes filling. */
1059 typedef struct varobj_mem_region {
1060 #if defined(SPVW_PURE)
1061 uintL heapnr; /* heap where region is located - for faster checking */
1062 #endif
1063 aint start; /* start address */
1064 aint size; /* region size */
1065 } varobj_mem_region;
1066
1067 #if !defined(OLD_GC)
1068 #include "spvw_garcol.c"
1069 #else
1070 #include "spvw_garcol_old.c"
1071 #endif
1072
1073 /* --------------------------------------------------------------------------
1074 Memory Allocation Functions */
1075
1076 #if !defined(OLD_GC)
1077 #include "spvw_allocate.c"
1078 #else
1079 #include "spvw_allocate_old.c"
1080 #endif
1081 #include "spvw_typealloc.c"
1082
1083 /* --------------------------------------------------------------------------
1084 Circularity Test */
1085
1086 #if !defined(OLD_GC)
1087 #include "spvw_circ.c"
1088 #else
1089 #include "spvw_circ_old.c"
1090 #endif
1091
1092 /* --------------------------------------------------------------------------
1093 Memory Walk */
1094
1095 #include "spvw_walk.c"
1096
1097 /* --------------------------------------------------------------------------
1098 Elementary String Functions */
1099
1100 #ifndef asciz_length
1101 /* UP: Returns the length of an ASCIZ-string.
1102 asciz_length(asciz)
1103 > char* asciz: ASCIZ-string
1104 (address of a character sequence terminated by a nullbyte)
1105 < result: length of the character sequence (without nullbyte) */
asciz_length(const char * asciz)1106 modexp uintL asciz_length (const char * asciz) {
1107 var const char* ptr = asciz;
1108 var uintL len = 0;
1109 /* search nullbyte and increment length: */
1110 while (*ptr++ != 0) { len++; }
1111 return len;
1112 }
1113 #endif
1114
1115 /* UP: compares two ASCIZ-strings.
1116 asciz_equal(asciz1,asciz2)
1117 > char* asciz1: first ASCIZ-string
1118 > char* asciz2: second ASCIZ-string
1119 < result: true if both sequences are equal */
asciz_equal(const char * asciz1,const char * asciz2)1120 modexp bool asciz_equal (const char * asciz1, const char * asciz2) {
1121 /* compare bytes until the first nullbyte: */
1122 while (1) {
1123 var char ch1 = *asciz1++;
1124 if (ch1 != *asciz2++) goto no;
1125 if (ch1 == '\0') goto yes;
1126 }
1127 yes: return true;
1128 no: return false;
1129 }
1130
1131 /* UP: check that the first ASCIZ-string starts with the second one.
1132 asciz_startswith(asciz,prefix) === (strncmp(asciz,prefix,strlen(prefix))==0)
1133 > char* asciz: first ASCIZ-string
1134 > char* prefix: second ASCIZ-string
1135 < result: true if both sequences are equal up to the length of the second */
asciz_startswith(const char * asciz,const char * prefix)1136 modexp bool asciz_startswith (const char *asciz, const char *prefix) {
1137 /* compare bytes until the first nullbyte: */
1138 while (1) {
1139 var char ch = *prefix++;
1140 if (ch == '\0') return true;
1141 if (ch != *asciz++) return false;
1142 }
1143 }
1144
1145
1146
1147 /* --------------------------------------------------------------------------
1148 Other Global Helper Functions */
1149
1150 /* malloc() with error check. */
clisp_malloc(size_t size)1151 modexp void* clisp_malloc (size_t size)
1152 {
1153 begin_system_call();
1154 var void* ptr = malloc(size);
1155 end_system_call();
1156 if (ptr)
1157 return ptr;
1158 pushSTACK(TheSubr(subr_self)->name);
1159 error(storage_condition,GETTEXT("~S: malloc() failed"));
1160 }
1161 /* realloc() with error check. */
clisp_realloc(void * ptr,size_t size)1162 modexp void* clisp_realloc (void* ptr, size_t size)
1163 {
1164 begin_system_call();
1165 ptr = realloc(ptr,size);
1166 end_system_call();
1167 if (ptr)
1168 return ptr;
1169 pushSTACK(TheSubr(subr_self)->name);
1170 error(storage_condition,GETTEXT("~S: realloc() failed"));
1171 }
1172
1173 #if (int_bitsize < long_bitsize) && !defined(MULTITHREAD)
1174 /* passing value from longjmpl() to setjmpl() : */
1175 #if DYNAMIC_TABLES && defined(export_unwind_protect_macros)
1176 modexp
1177 #endif
1178 long jmpl_value;
1179 #endif
1180
1181 #ifdef NEED_OWN_GETSP
1182 /* determine (an approximation) of the SP-stackpointer. */
getSP(void)1183 global void* getSP (void) {
1184 var long dummy;
1185 return &dummy;
1186 }
1187 #endif
1188
1189 /* VTZ: moved SP_anchor to clisp_thread_t. in MT it is part of the thread
1190 Seems it is used only for debugging/checking purposes. */
1191 #if !defined(MULTITHREAD)
1192 /* The initial value of SP() during main(). */
1193 global void* SP_anchor;
1194 #endif
1195
1196 /* error-message when a location of the program is reached that is (should be)
1197 unreachable. Does not return.
1198 error_notreached(file,line);
1199 > file: filename (with quotation marks) as constant ASCIZ-string
1200 > line: line number */
error_notreached(const char * file,uintL line)1201 modexp _Noreturn void error_notreached (const char* file, uintL line) {
1202 end_system_call(); /* just in case */
1203 pushSTACK(fixnum(line));
1204 pushSTACK(ascii_to_string(file));
1205 error(serious_condition,
1206 GETTEXT("Internal error: statement in file ~S, line ~S has been reached!!\n"
1207 "Please see <http://clisp.org/impnotes/faq.html#faq-bugs> for bug reporting instructions."));
1208 }
1209
1210 #include "spvw_ctype.c"
1211
1212 #include "spvw_language.c"
1213
1214 /* --------------------------------------------------------------------------
1215 Initialization */
1216
1217 /* name of the program (for error reporting) */
1218 local const char* program_name;
1219
1220 extern char *get_executable_name (void);
1221
1222 /* Flag, if SYS::READ-FORM should behave ILISP-compatible: */
1223 global bool ilisp_mode = false;
1224
1225 /* Flag, whether libreadline should be avoided */
1226 global bool disable_readline = false;
1227
fsubr_argtype(uintW req_count,uintW opt_count,fsubr_body_t body_flag)1228 local fsubr_argtype_t fsubr_argtype (uintW req_count, uintW opt_count,
1229 fsubr_body_t body_flag)
1230 { /* conversion of the argument types of a FSUBR into a code: */
1231 switch (body_flag) {
1232 case fsubr_nobody:
1233 switch (opt_count) {
1234 case 0:
1235 switch (req_count) {
1236 case 1: return(fsubr_argtype_1_0_nobody);
1237 case 2: return(fsubr_argtype_2_0_nobody);
1238 default: goto illegal;
1239 }
1240 case 1:
1241 switch (req_count) {
1242 case 1: return(fsubr_argtype_1_1_nobody);
1243 case 2: return(fsubr_argtype_2_1_nobody);
1244 default: goto illegal;
1245 }
1246 default: goto illegal;
1247 }
1248 case fsubr_body:
1249 switch (opt_count) {
1250 case 0:
1251 switch (req_count) {
1252 case 0: return(fsubr_argtype_0_body);
1253 case 1: return(fsubr_argtype_1_body);
1254 case 2: return(fsubr_argtype_2_body);
1255 default: goto illegal;
1256 }
1257 default: goto illegal;
1258 }
1259 default: goto illegal;
1260 }
1261 illegal:
1262 fprintf(stderr,GETTEXTL("Unknown FSUBR signature: %d %d %d\n"),
1263 req_count,opt_count,body_flag);
1264 quit_instantly(1);
1265 }
1266
subr_argtype(uintW req_count,uintW opt_count,subr_rest_t rest_flag,subr_key_t key_flag,const subr_initdata_t * sid)1267 local subr_argtype_t subr_argtype (uintW req_count, uintW opt_count,
1268 subr_rest_t rest_flag, subr_key_t key_flag,
1269 const subr_initdata_t *sid)
1270 { /* conversion of the argument types of a FSUBR into a code: */
1271 switch (key_flag) {
1272 case subr_nokey:
1273 switch (rest_flag) {
1274 case subr_norest:
1275 switch (opt_count) {
1276 case 0:
1277 switch (req_count) {
1278 case 0: return(subr_argtype_0_0);
1279 case 1: return(subr_argtype_1_0);
1280 case 2: return(subr_argtype_2_0);
1281 case 3: return(subr_argtype_3_0);
1282 case 4: return(subr_argtype_4_0);
1283 case 5: return(subr_argtype_5_0);
1284 case 6: return(subr_argtype_6_0);
1285 default: goto illegal;
1286 }
1287 case 1:
1288 switch (req_count) {
1289 case 0: return(subr_argtype_0_1);
1290 case 1: return(subr_argtype_1_1);
1291 case 2: return(subr_argtype_2_1);
1292 case 3: return(subr_argtype_3_1);
1293 case 4: return(subr_argtype_4_1);
1294 default: goto illegal;
1295 }
1296 case 2:
1297 switch (req_count) {
1298 case 0: return(subr_argtype_0_2);
1299 case 1: return(subr_argtype_1_2);
1300 case 2: return(subr_argtype_2_2);
1301 case 3: return(subr_argtype_3_2);
1302 default: goto illegal;
1303 }
1304 case 3:
1305 switch (req_count) {
1306 case 0: return(subr_argtype_0_3);
1307 case 1: return(subr_argtype_1_3);
1308 case 2: return(subr_argtype_2_3);
1309 default: goto illegal;
1310 }
1311 case 4:
1312 switch (req_count) {
1313 case 0: return(subr_argtype_0_4);
1314 default: goto illegal;
1315 }
1316 case 5:
1317 switch (req_count) {
1318 case 0: return(subr_argtype_0_5);
1319 default: goto illegal;
1320 }
1321 default: goto illegal;
1322 }
1323 case subr_rest:
1324 switch (opt_count) {
1325 case 0:
1326 switch (req_count) {
1327 case 0: return(subr_argtype_0_0_rest);
1328 case 1: return(subr_argtype_1_0_rest);
1329 case 2: return(subr_argtype_2_0_rest);
1330 case 3: return(subr_argtype_3_0_rest);
1331 default: goto illegal;
1332 }
1333 default: goto illegal;
1334 }
1335 default: goto illegal;
1336 }
1337 case subr_key:
1338 switch (rest_flag) {
1339 case subr_norest:
1340 switch (opt_count) {
1341 case 0:
1342 switch (req_count) {
1343 case 0: return(subr_argtype_0_0_key);
1344 case 1: return(subr_argtype_1_0_key);
1345 case 2: return(subr_argtype_2_0_key);
1346 case 3: return(subr_argtype_3_0_key);
1347 case 4: return(subr_argtype_4_0_key);
1348 default: goto illegal;
1349 }
1350 case 1:
1351 switch (req_count) {
1352 case 0: return(subr_argtype_0_1_key);
1353 case 1: return(subr_argtype_1_1_key);
1354 default: goto illegal;
1355 }
1356 case 2:
1357 switch (req_count) {
1358 case 1: return(subr_argtype_1_2_key);
1359 default: goto illegal;
1360 }
1361 default: goto illegal;
1362 }
1363 case subr_rest:
1364 default: goto illegal;
1365 }
1366 case subr_key_allow: goto illegal;
1367 default: goto illegal;
1368 }
1369 illegal:
1370 fprintf(stderr,GETTEXTL("Unknown SUBR signature: %d %d %d %d"),
1371 req_count,opt_count,rest_flag,key_flag);
1372 if (sid)
1373 fprintf(stderr," (%s::%s)\n",sid->packname,sid->symname);
1374 else
1375 fprint(stderr,"\n");
1376 quit_instantly(1);
1377 }
1378 /* set the argtype of a subr_t *ptr */
1379 #define SUBR_SET_ARGTYPE(ptr,sid) \
1380 ptr->argtype = (uintW)subr_argtype(ptr->req_count,ptr->opt_count, \
1381 (subr_rest_t)(ptr->rest_flag), \
1382 (subr_key_t)(ptr->key_flag),sid)
1383
module_set_argtypes(module_t * module)1384 local inline void module_set_argtypes (module_t *module)
1385 { /* set artype for all SUBRs in the module */
1386 var subr_t* stab_ptr = module->stab; /* traverse subr_tab */
1387 var const subr_initdata_t *stab_init_ptr = module->stab_initdata;
1388 var uintC count = *module->stab_size;
1389 do { SUBR_SET_ARGTYPE(stab_ptr,stab_init_ptr);
1390 stab_ptr++; stab_init_ptr++;
1391 } while (--count);
1392 }
1393
1394 /* Verify that an address has the PSEUDODATA_ALIGNMENT.
1395 This is important for calling make_machine. */
1396 #if PSEUDODATA_ALIGNMENT==1
1397 #define verify_pseudodata_alignment(ptr,name) /* not needed */
1398 #else
1399 #define verify_pseudodata_alignment(ptr,name) \
1400 if ((uintP)(void*)(ptr) & (PSEUDODATA_ALIGNMENT-1)) \
1401 error_pseudodata_alignment((uintP)(void*)(ptr),name)
error_pseudodata_alignment(uintP address,const char * name)1402 local _Noreturn void error_pseudodata_alignment (uintP address, const char* name) {
1403 fprintf(stderr,"PSEUDODATA_ALIGNMENT is not fulfilled. &%s = 0x%lx.\n",
1404 name, (unsigned long)address);
1405 fprintf(stderr,"Use <stdalign.h> and alignas(%d) to its declaration.\n",
1406 PSEUDODATA_ALIGNMENT);
1407 abort();
1408 }
1409 #endif
1410
1411 /* Verify that a code address has the PSEUDOCODE_ALIGNMENT.
1412 This is important for calling make_machine_code. */
1413 #if PSEUDOCODE_ALIGNMENT==1
1414 #define verify_pseudocode_alignment(ptr,name) /* not needed */
1415 #else
1416 #define verify_pseudocode_alignment(ptr,name) \
1417 if (((uintP)(void*)(ptr)-C_FUNCTION_POINTER_BIAS) & (PSEUDOCODE_ALIGNMENT-1)) \
1418 error_pseudocode_alignment((uintP)(void*)(ptr),"&",name)
error_pseudocode_alignment(uintP address,const char * prefix,const char * name)1419 global _Noreturn void error_pseudocode_alignment (uintP address, const char* prefix, const char* name) {
1420 fprintf(stderr,"PSEUDOCODE_ALIGNMENT is not fulfilled. %s%s = 0x%lx.\n",
1421 prefix, name, (unsigned long)address);
1422 #if (__GNUC__ >= 3)
1423 fprintf(stderr,"Add -falign-functions=%d to FALIGNFLAGS in the Makefile.\n",
1424 PSEUDOCODE_ALIGNMENT);
1425 #endif
1426 abort();
1427 }
1428 #endif
1429
1430 /* Initialization-routines for the tables
1431 during the first part of the initialization phase:
1432 initialize subr_tab: */
init_subr_tab_1(void)1433 local void init_subr_tab_1 (void) {
1434 #if defined(HEAPCODES)
1435 /* lispbibl.d normally takes care of this, using a gcc __attribute__.
1436 But __attribute__((aligned(4))) is ignored for some GCC targets,
1437 so we check it here for safety. */
1438 if (alignof(subr_t) < 4) {
1439 fprintf(stderr,"Alignment of SUBRs is %d. HEAPCODES requires it to be at least 4.\nRecompile CLISP with -DTYPECODES.\n",(int)alignof(subr_t));
1440 abort();
1441 }
1442 #endif
1443 #if defined(INIT_SUBR_TAB)
1444 #ifdef MAP_MEMORY_TABLES
1445 /* copy table into the designated region: */
1446 subr_tab = subr_tab_data;
1447 #endif
1448 #if !NIL_IS_CONSTANT
1449 { /* initialize the name-slot first: */
1450 var subr_t* ptr = (subr_t*)((char*)&subr_tab+varobjects_misaligned); /* traverse subr_tab */
1451 #define LISPFUN LISPFUN_E
1452 #include "subr.c"
1453 #undef LISPFUN
1454 }
1455 { /* and initialize the GCself and keywords-slot temporarily: */
1456 var subr_t* ptr = (subr_t*)((char*)&subr_tab+varobjects_misaligned); /* traverse subr_tab */
1457 var uintC count = subr_count;
1458 while (count--) {
1459 ptr->GCself = subr_tab_ptr_as_object(ptr);
1460 ptr->keywords = NIL;
1461 ptr++;
1462 }
1463 }
1464 #endif
1465 /* Because of SPVWTABF all slots except keywords and argtype
1466 are already initialized. */
1467 { /* now initialize the argtype-slot: */
1468 var subr_t* ptr = (subr_t*)((char*)&subr_tab+varobjects_misaligned); /* traverse subr_tab */
1469 var uintC count = subr_count;
1470 while (count--) { SUBR_SET_ARGTYPE(ptr,NULL); ptr++; }
1471 }
1472 #else
1473 { /* initialize all slots except keywords: */
1474 var subr_t* ptr = (subr_t*)((char*)&subr_tab+varobjects_misaligned); /* traverse subr_tab */
1475 #define LISPFUN LISPFUN_D
1476 #include "subr.c"
1477 #undef LISPFUN
1478 }
1479 #endif
1480 {
1481 var module_t* module;
1482 for_modules(all_other_modules,{
1483 if (*module->stab_size > 0) module_set_argtypes(module);
1484 });
1485 }
1486 #ifdef MAP_MEMORY_TABLES
1487 { /* ditto, copy other tables into the mapped region: */
1488 var subr_t* newptr = (subr_t*)((char*)&subr_tab+varobjects_misaligned);
1489 var module_t* module;
1490 main_module.stab = newptr; newptr += subr_count;
1491 for_modules(all_other_modules,{
1492 var subr_t* oldptr = module->stab;
1493 var uintC count = *module->stab_size;
1494 module->stab = newptr;
1495 if (count > 0) {
1496 do { *newptr++ = *oldptr++; } while (--count);
1497 }
1498 });
1499 ASSERT(newptr == (subr_t*)((char*)&subr_tab+varobjects_misaligned) + total_subr_count);
1500 }
1501 #endif
1502 }
1503 /* initialize symbol_tab: */
init_symbol_tab_1(void)1504 local void init_symbol_tab_1 (void) {
1505 #if defined(INIT_SYMBOL_TAB) && NIL_IS_CONSTANT
1506 #ifdef MAP_MEMORY_TABLES
1507 /* copy table into the designated region: */
1508 symbol_tab = symbol_tab_data;
1509 #endif
1510 #else
1511 { /* traverse symbol_tab */
1512 var symbol_* ptr = (symbol_*)((char*)&symbol_tab+varobjects_misaligned);
1513 var uintC count;
1514 for (count = symbol_count; count > 0; count--) {
1515 ptr->GCself = symbol_tab_ptr_as_object(ptr);
1516 #ifndef TYPECODES
1517 ptr->tfl = xrecord_tfl(Rectype_Symbol,0,5,0);
1518 #endif
1519 ptr->symvalue = unbound;
1520 ptr->symfunction = unbound;
1521 ptr->hashcode = unbound;
1522 ptr->proplist = NIL;
1523 ptr->pname = NIL;
1524 ptr->homepackage = NIL;
1525 ptr++;
1526 }
1527 }
1528 #endif
1529 }
1530 /* initialize object_tab: */
init_object_tab_1(void)1531 local void init_object_tab_1 (void) {
1532 var module_t* module;
1533 #if defined(INIT_OBJECT_TAB) && NIL_IS_CONSTANT /* object_tab already pre-initialized? */
1534 for_modules(all_other_modules,{
1535 if (*module->otab_size > 0) {
1536 var gcv_object_t* ptr = module->otab; /* traverse object_tab */
1537 var uintC count;
1538 dotimespC(count,*module->otab_size, { *ptr++ = NIL; });
1539 }
1540 });
1541 #else
1542 for_modules(all_modules,{
1543 if (*module->otab_size > 0) {
1544 var gcv_object_t* ptr = module->otab; /* traverse object_tab */
1545 var uintC count;
1546 dotimespC(count,*module->otab_size, { *ptr++ = NIL; });
1547 }
1548 });
1549 #endif
1550 O(all_weakpointers) = Fixnum_0;
1551 O(all_finalizers) = Fixnum_0; O(pending_finalizers) = Fixnum_0;
1552 }
1553 /* initialize other modules coarsely: */
init_other_modules_1(void)1554 local void init_other_modules_1 (void) {
1555 var module_t* module;
1556 for_modules(all_other_modules, {
1557 /* fill pointer in the subr-table with NIL, for GC to become possible: */
1558 if (*module->stab_size > 0) {
1559 var subr_t* ptr = module->stab;
1560 var uintC count;
1561 dotimespC(count,*module->stab_size, {
1562 ptr->GCself = subr_tab_ptr_as_object(ptr);
1563 ptr->name = NIL; ptr->keywords = NIL;
1564 ptr++;
1565 });
1566 }
1567 /* the pointers in the object-table have already been inizialized
1568 by init_object_tab_1(). */
1569 });
1570 }
1571
1572 /* Initialization-routines for the tables
1573 during the second part of the initialization phase:
1574 finish initialization of subr_tab: enter keyword-vectors. */
init_subr_tab_2(void)1575 local void init_subr_tab_2 (void) {
1576 #define LISPFUN LISPFUN_H
1577 #define kw(name) *vecptr++ = S(K##name)
1578 #include "subr.c"
1579 #undef LISPFUN
1580 #undef kw
1581 }
1582 /* finish initialization of symbol_tab: enter printnames and home-package. */
init_symbol_tab_2(void)1583 local void init_symbol_tab_2 (void) {
1584 /* table of printnames: */
1585 local const char * const pname_table[symbol_count] = {
1586 #define LISPSYM LISPSYM_C
1587 #include "constsym.c"
1588 #undef LISPSYM
1589 };
1590 /* table of packages: */
1591 enum { /* the values in this enum are 0,1,2,... */
1592 enum_lisp_index,
1593 enum_user_index,
1594 enum_system_index,
1595 enum_keyword_index,
1596 enum_charset_index,
1597 enum_cs_lisp_index,
1598 enum_cs_user_index,
1599 #define LISPPACK LISPPACK_A
1600 #include "constpack.c"
1601 #undef LISPPACK
1602 enum_dummy_index
1603 };
1604 #define package_count ((uintL)enum_dummy_index)
1605 local const uintB package_index_table[symbol_count] = {
1606 #define LISPSYM LISPSYM_D
1607 #include "constsym.c"
1608 #undef LISPSYM
1609 };
1610 {
1611 var object list = O(all_packages); /* list of packages */
1612 /* shortly after the initialization:
1613 (#<PACKAGE LISP> #<PACKAGE SYSTEM> #<PACKAGE KEYWORD> #<PACKAGE CHARSET> ...) */
1614 var uintC count = package_count;
1615 do { pushSTACK(Car(list)); list = Cdr(list); } while (--count);
1616 }
1617 { /* traverse symbol_tab */
1618 var symbol_* ptr = (symbol_*)((char*)&symbol_tab+varobjects_misaligned);
1619 var const char * const * pname_ptr = &pname_table[0]; /* traverse pname_table */
1620 var const uintB* index_ptr = &package_index_table[0]; /* traverse package_index_table */
1621 var uintC count = symbol_count;
1622 do {
1623 ptr->pname =
1624 coerce_imm_ss(' ' == **pname_ptr /* non-ASCII */
1625 ? asciz_to_string(*pname_ptr+1, /* skip ' ' */
1626 Symbol_value(S(utf_8)))
1627 : ascii_to_string(*pname_ptr));
1628 pname_ptr++;
1629 var uintB this_index = *index_ptr++;
1630 var gcv_object_t* package_ = /* pointer to the package */
1631 &STACK_(package_count-1) STACKop -(uintP)this_index;
1632 pushSTACK(symbol_tab_ptr_as_object(ptr)); /* Symbol */
1633 import(&STACK_0,package_); /* import normally */
1634 switch (this_index) {
1635 case enum_lisp_index: /* in #<PACKAGE COMMON-LISP>? */
1636 case enum_charset_index: /* in #<PACKAGE CHARSET>? */
1637 case enum_cs_lisp_index: /* in #<PACKAGE CS-COMMON-LISP>? */
1638 case enum_socket_index:
1639 case enum_custom_index:
1640 export(&STACK_0,package_); /* also export */
1641 }
1642 Symbol_package(popSTACK()) = *package_; /* set the home-package */
1643 ptr++;
1644 } while (--count != 0);
1645 skipSTACK(package_count);
1646 }
1647 }
1648 /* enter FSUBRs/SUBRs into their symbols: */
init_symbol_functions(void)1649 local void init_symbol_functions (void) {
1650 { /* enter FSUBRs: */
1651 typedef struct {
1652 #if defined(INIT_SUBR_TAB) && NIL_IS_CONSTANT
1653 #define LISPSPECFORM LISPSPECFORM_F
1654 gcv_object_t name;
1655 #define fsubr_name(p) (p)->name
1656 #else
1657 #define LISPSPECFORM LISPSPECFORM_E
1658 uintL name_offset;
1659 #define fsubr_name(p) symbol_tab_ptr_as_object((char*)&symbol_tab+(p)->name_offset)
1660 #endif
1661 uintW req_count;
1662 uintW opt_count;
1663 uintW body_flag;
1664 } fsubr_data_t;
1665 local const fsubr_data_t fsubr_data_tab[] = {
1666 #include "fsubr.c"
1667 };
1668 #undef LISPSPECFORM
1669 var const fsubr_t* ptr1 = (const fsubr_t *)&fsubr_tab; /* traverse fsubr_tab */
1670 var const fsubr_data_t * ptr2 = &fsubr_data_tab[0]; /* traverse fsubr_data_tab */
1671 var uintC count = fsubr_count;
1672 while (count--) {
1673 var object sym = fsubr_name(ptr2);
1674 var object obj = allocate_fsubr();
1675 TheFsubr(obj)->name = sym;
1676 TheFsubr(obj)->argtype =
1677 fixnum((uintW)fsubr_argtype(ptr2->req_count,ptr2->opt_count,
1678 (fsubr_body_t)(ptr2->body_flag)));
1679 TheFsubr(obj)->function = (void*)(*ptr1);
1680 Symbol_function(sym) = obj;
1681 ptr1++; ptr2++;
1682 }
1683 }
1684 { /* enter SUBRs: */
1685 var subr_t* ptr = (subr_t*)((char*)&subr_tab+varobjects_misaligned); /* traverse subr_tab */
1686 var uintC count = subr_count;
1687 while (count--) {
1688 Symbol_function(ptr->name) = subr_tab_ptr_as_object(ptr);
1689 ptr++;
1690 }
1691 }
1692 }
1693 /* assign values to constants/variables: */
init_symbol_values(void)1694 local void init_symbol_values (void) {
1695 /* helper macro: constant := value+1 */
1696 #define define_constant_UL1(symbol,value) \
1697 do { var object x = /* value+1 as integer */ \
1698 (((uintV)(value) < (uintV)(vbitm(oint_data_len)-1)) \
1699 ? fixnum(value+1) \
1700 : I_1_plus_I(UV_to_I(value)) \
1701 ); \
1702 define_constant(symbol,x); \
1703 } while(0)
1704 /* common: */
1705 define_constant(S(nil),S(nil)); /* NIL := NIL */
1706 define_constant(S(t),S(t)); /* T := T */
1707 define_variable(S(gc_statistics_star),Fixnum_minus1); /* SYS::*GC-STATISTICS* := -1 */
1708 /* for EVAL/CONTROL: */
1709 define_constant_UL1(S(lambda_parameters_limit),lp_limit_1); /* LAMBDA-PARAMETERS-LIMIT := lp_limit_1 + 1 */
1710 define_constant_UL1(S(call_arguments_limit),ca_limit_1); /* CALL-ARGUMENTS-LIMIT := ca_limit_1 + 1 */
1711 define_constant(S(multiple_values_limit),fixnum(mv_limit)); /* MULTIPLE-VALUES-LIMIT := mv_limit */
1712 define_constant(S(jmpbuf_size),fixnum(jmpbufsize)); /* SYS::*JMPBUF-SIZE* := size of a jmp_buf */
1713 define_constant(S(big_endian),(BIG_ENDIAN_P ? T : NIL)); /* SYS::*BIG-ENDIAN* := NIL resp. T */
1714 define_variable(S(macroexpand_hook),L(funcall)); /* *MACROEXPAND-HOOK* := #'FUNCALL */
1715 define_variable(S(evalhookstar),NIL); /* *EVALHOOK* */
1716 define_variable(S(applyhookstar),NIL); /* *APPLYHOOK* */
1717 /* for HASHTABL: */
1718 define_variable(S(eq_hashfunction),S(fasthash_eq)); /* EXT:*EQ-HASHFUNCTION* := 'EXT:FASTHASH-EQ */
1719 define_variable(S(eql_hashfunction),S(fasthash_eql)); /* EXT:*EQL-HASHFUNCTION* := 'EXT:FASTHASH-EQL */
1720 define_variable(S(equal_hashfunction),S(fasthash_equal)); /* EXT:*EQUAL-HASHFUNCTION* := 'EXT:FASTHASH-EQUAL */
1721 define_variable(S(warn_on_hashtable_needing_rehash_after_gc),NIL); /* CUSTOM:*WARN-ON-HASHTABLE-NEEDING-REHASH-AFTER-GC* := NIL */
1722 /* for PACKAGE: */
1723 define_variable(S(packagestar),Car(O(all_packages))); /* *PACKAGE* := '#<PACKAGE LISP> */
1724 /* for SYMBOL: */
1725 define_variable(S(gensym_counter),Fixnum_1); /* *GENSYM-COUNTER* := 1 */
1726 /* for PATHNAME: */
1727 define_variable(S(merge_pathnames_ansi),NIL); /* *MERGE-PATHNAMES-ANSI* */
1728 /* for LISPARIT: */
1729 init_arith(); /* defines the following: */
1730 /* define_variable(S(pi),); - PI
1731 define_constant(S(most_positive_fixnum),); - MOST-POSITIVE-FIXNUM
1732 define_constant(S(most_negative_fixnum),); - MOST-NEGATIVE-FIXNUM
1733 define_constant(S(most_positive_short_float),); - MOST-POSITIVE-SHORT-FLOAT
1734 define_constant(S(least_positive_short_float),); - LEAST-POSITIVE-SHORT-FLOAT
1735 define_constant(S(least_negative_short_float),); - LEAST-NEGATIVE-SHORT-FLOAT
1736 define_constant(S(most_negative_short_float),); - MOST-NEGATIVE-SHORT-FLOAT
1737 define_constant(S(most_positive_single_float),); - MOST-POSITIVE-SINGLE-FLOAT
1738 define_constant(S(least_positive_single_float),); - LEAST-POSITIVE-SINGLE-FLOAT
1739 define_constant(S(least_negative_single_float),); - LEAST-NEGATIVE-SINGLE-FLOAT
1740 define_constant(S(most_negative_single_float),); - MOST-NEGATIVE-SINGLE-FLOAT
1741 define_constant(S(most_positive_double_float),); - MOST-POSITIVE-DOUBLE-FLOAT
1742 define_constant(S(least_positive_double_float),); - LEAST-POSITIVE-DOUBLE-FLOAT
1743 define_constant(S(least_negative_double_float),); - LEAST-NEGATIVE-DOUBLE-FLOAT
1744 define_constant(S(most_negative_double_float),); - MOST-NEGATIVE-DOUBLE-FLOAT
1745 define_variable(S(most_positive_long_float),); - MOST-POSITIVE-LONG-FLOAT
1746 define_variable(S(least_positive_long_float),); - LEAST-POSITIVE-LONG-FLOAT
1747 define_variable(S(least_negative_long_float),); - LEAST-NEGATIVE-LONG-FLOAT
1748 define_variable(S(most_negative_long_float),); - MOST-NEGATIVE-LONG-FLOAT
1749 define_variable(S(least_positive_normalized_long_float),); - LEAST-POSITIVE-NORMALIZED-LONG-FLOAT
1750 define_variable(S(least_negative_normalized_long_float),); - LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT
1751 define_constant(S(short_float_epsilon),); - SHORT-FLOAT-EPSILON
1752 define_constant(S(single_float_epsilon),); - SINGLE-FLOAT-EPSILON
1753 define_constant(S(double_float_epsilon),); - DOUBLE-FLOAT-EPSILON
1754 define_variable(S(long_float_epsilon),); - LONG-FLOAT-EPSILON
1755 define_constant(S(short_float_negative_epsilon),); - SHORT-FLOAT-NEGATIVE-EPSILON
1756 define_constant(S(single_float_negative_epsilon),); - SINGLE-FLOAT-NEGATIVE-EPSILON
1757 define_constant(S(double_float_negative_epsilon),); - DOUBLE-FLOAT-NEGATIVE-EPSILON
1758 define_variable(S(long_float_negative_epsilon),); - LONG-FLOAT-NEGATIVE-EPSILON
1759 define_variable(S(read_default_float_format),); - *READ-DEFAULT-FLOAT-FORMAT*
1760 define_variable(S(random_state),); - *RANDOM-STATE*
1761 for ARRAY: */
1762 define_constant(S(array_total_size_limit),fixnum(arraysize_limit_1+1)); /* ARRAY-TOTAL-SIZE-LIMIT := arraysize_limit_1 + 1 */
1763 define_constant(S(array_dimension_limit),fixnum(arraysize_limit_1+1)); /* ARRAY-DIMENSION-LIMIT := arraysize_limit_1 + 1 */
1764 define_constant_UL1(S(string_dimension_limit),stringsize_limit_1); /* SYSTEM::STRING-DIMENSION-LIMIT := stringsize_limit_1 + 1 */
1765 define_constant(S(array_rank_limit),fixnum(arrayrank_limit_1+1)); /* ARRAY-RANK-LIMIT := arrayrank_limit_1 + 1 */
1766 /* for CHARSTRG: */
1767 define_constant(S(char_cod_limit),fixnum(char_code_limit)); /* CHAR-CODE-LIMIT */
1768 define_constant(S(base_char_cod_limit),fixnum(base_char_code_limit)); /* BASE-CHAR-CODE-LIMIT */
1769 define_variable(S(coerce_fixnum_char_ansi),NIL); /* LISP:*COERCE-FIXNUM-CHAR-ANSI* */
1770 /* for SEQUENCE: */
1771 define_variable(S(sequence_count_ansi),NIL); /* LISP:*SEQUENCE-COUNT-ANSI* */
1772 /* for DEBUG: */
1773 define_variable(S(plus),NIL); /* + */
1774 define_variable(S(plus2),NIL); /* ++ */
1775 define_variable(S(plus3),NIL); /* +++ */
1776 define_variable(S(minus),NIL); /* - */
1777 define_variable(S(star),NIL); /* * */
1778 define_variable(S(star2),NIL); /* ** */
1779 define_variable(S(star3),NIL); /* *** */
1780 define_variable(S(slash),NIL); /* / */
1781 define_variable(S(slash2),NIL); /* // */
1782 define_variable(S(slash3),NIL); /* /// */
1783 define_variable(S(driverstar),NIL); /* *DRIVER* := NIL */
1784 define_variable(S(break_driver),NIL); /* *BREAK-DRIVER* := NIL */
1785 define_variable(S(break_count),Fixnum_0); /* SYS::*BREAK-COUNT* := 0 */
1786 define_variable(S(recurse_count_standard_output),Fixnum_0); /* SYS::*RECURSE-COUNT-STANDARD-OUTPUT* := 0 */
1787 define_variable(S(recurse_count_debug_io),Fixnum_0); /* SYS::*RECURSE-COUNT-DEBUG-IO* := 0 */
1788 /* for STREAM:
1789 later: init_streamvars(); - defines the following:
1790 define_variable(S(standard_input),); - *STANDARD-INPUT*
1791 define_variable(S(standard_output),); - *STANDARD-OUTPUT*
1792 define_variable(S(error_output),); - *ERROR-OUTPUT*
1793 define_variable(S(query_io),); - *QUERY-IO*
1794 define_variable(S(debug_io),); - *DEBUG-IO*
1795 define_variable(S(terminal_io),); - *TERMINAL-IO*
1796 define_variable(S(trace_output),); - *TRACE-OUTPUT*
1797 define_variable(S(keyboard_input),); - *KEYBOARD-INPUT* */
1798 define_variable(S(default_pathname_defaults),unbound); /* *DEFAULT-PATHNAME-DEFAULTS* */
1799 /* for IO: */
1800 define_variable(S(completion),NIL); /* CUSTOM:*COMPLETION* */
1801 init_reader(); /* defines the following:
1802 define_variable(S(read_base),); - *READ-BASE* := 10
1803 define_variable(S(read_suppress),); - *READ-SUPPRESS* := NIL
1804 define_variable(S(read_eval),); - *READ-EVAL* := T
1805 define_variable(S(readtablestar),); - *READTABLE* */
1806 define_variable(S(read_preserve_whitespace),unbound); /* SYS::*READ-PRESERVE-WHITESPACE* */
1807 define_variable(S(read_recursive_p),unbound); /* SYS::*READ-RECURSIVE-P* */
1808 define_variable(S(read_reference_table),unbound); /* SYS::*READ-REFERENCE-TABLE* */
1809 define_variable(S(backquote_level),unbound); /* SYS::*BACKQUOTE-LEVEL* */
1810 define_variable(S(compiling),NIL); /* SYS::*COMPILING* ;= NIL */
1811 define_variable(S(print_case),S(Kupcase)); /* *PRINT-CASE* := :UPCASE */
1812 define_variable(S(print_level),NIL); /* *PRINT-LEVEL* := NIL */
1813 define_variable(S(print_length),NIL); /* *PRINT-LENGTH* := NIL */
1814 define_variable(S(print_gensym),T); /* *PRINT-GENSYM* := T */
1815 define_variable(S(print_escape),T); /* *PRINT-ESCAPE* := T */
1816 define_variable(S(print_radix),NIL); /* *PRINT-RADIX* := NIL */
1817 define_variable(S(print_base),fixnum(10)); /* *PRINT-BASE* := 10 */
1818 define_variable(S(print_array),T); /* *PRINT-ARRAY* := T */
1819 define_variable(S(print_circle),NIL); /* *PRINT-CIRCLE* := NIL */
1820 define_variable(S(print_pretty),NIL); /* *PRINT-PRETTY* := NIL */
1821 define_variable(S(print_closure),NIL); /* *PRINT-CLOSURE* := NIL */
1822 define_variable(S(print_readably),NIL); /* *PRINT-READABLY* := NIL */
1823 define_variable(S(print_lines),NIL); /* *PRINT-LINES* := NIL */
1824 define_variable(S(print_miser_width),NIL); /* *PRINT-MISER-WIDTH* := NIL */
1825 define_variable(S(prin_line_prefix),unbound); /* *PRIN-LINE-PREFIX* */
1826 define_variable(S(prin_miserp),unbound); /* *PRIN-MISERP* */
1827 define_variable(S(prin_pprinter),unbound); /* *PRIN-PPRINTER* */
1828 define_variable(S(prin_indentation),unbound); /* *PRIN-INDENTATION* */
1829 define_variable(S(print_pprint_dispatch),NIL); /* *PRINT-PPRINT-DISPATCH* := NIL */
1830 define_variable(S(print_right_margin),NIL); /* *PRINT-RIGHT-MARGIN* := NIL */
1831 define_variable(S(print_rpars),NIL); /* *PRINT-RPARS* := NIL */
1832 define_variable(S(print_indent_lists),fixnum(1)); /* *PRINT-INDENT-LISTS* := 1 */
1833 define_variable(S(print_pretty_fill),NIL); /* *PRINT-PRETTY-FILL* := NIL */
1834 define_variable(S(print_circle_table),unbound); /* SYS::*PRINT-CIRCLE-TABLE* */
1835 define_variable(S(print_symbol_package_prefix_shortest),NIL); /* CUSTOM:*PRINT-SYMBOL-PACKAGE-PREFIX-SHORTEST* */
1836 define_variable(S(prin_level),unbound); /* SYS::*PRIN-LEVEL* */
1837 define_variable(S(prin_lines),unbound); /* SYS::*PRIN-LINES* */
1838 define_variable(S(prin_stream),unbound); /* SYS::*PRIN-STREAM* */
1839 define_variable(S(prin_linelength),fixnum(79)); /* SYS::*PRIN-LINELENGTH* := 79 (preliminarily) */
1840 define_variable(S(prin_l1),unbound); /* SYS::*PRIN-L1* */
1841 define_variable(S(prin_lm),unbound); /* SYS::*PRIN-LM* */
1842 define_variable(S(prin_rpar),unbound); /* SYS::*PRIN-RPAR* */
1843 define_variable(S(prin_traillength),unbound); /* SYS::*PRIN-TRAILLENGTH* */
1844 define_variable(S(prin_prev_traillength),unbound); /* SYS::*PRIN-PREV-TRAILLENGTH* */
1845 define_variable(S(prin_jblocks),unbound); /* SYS::*PRIN-JBLOCKS* */
1846 define_variable(S(prin_jbstrings),unbound); /* SYS::*PRIN-JBSTRINGS* */
1847 define_variable(S(prin_jbmodus),unbound); /* SYS::*PRIN-JBMODUS* */
1848 define_variable(S(prin_jblpos),unbound); /* SYS::*PRIN-JBLPOS* */
1849 define_variable(S(load_forms),NIL); /* SYS::*LOAD-FORMS* */
1850 define_variable(S(terminal_read_open_object),unbound); /* SYS::*TERMINAL-READ-OPEN-OBJECT* */
1851 define_variable(S(terminal_read_stream),unbound); /* SYS::*TERMINAL-READ-STREAM* */
1852 define_variable(S(pprint_first_newline),T); /* CUSTOM:*PPRINT-FIRST-NEWLINE* */
1853 define_variable(S(print_pathnames_ansi),NIL); /* CUSTOM:*PRINT-PATHNAMES-ANSI* */
1854 define_variable(S(print_space_char_ansi),NIL); /* CUSTOM:*PRINT-SPACE-CHAR-ANSI* */
1855 define_variable(S(print_empty_arrays_ansi),NIL); /* CUSTOM:*PRINT-EMPTY-ARRAYS-ANSI* */
1856 define_variable(S(print_unreadable_ansi),NIL); /* CUSTOM:*PRINT-UNREADABLE-ANSI* */
1857 define_variable(S(parse_namestring_ansi),NIL); /* CUSTOM:*PARSE-NAMESTRING-ANSI* */
1858 define_variable(S(reopen_open_file),S(error)); /* CUSTOM:*REOPEN-OPEN-FILE* */
1859 #ifdef PATHNAME_NOEXT
1860 define_variable(S(parse_namestring_dot_file),S(Ktype)); /* CUSTOM:*PARSE-NAMESTRING-DOT-FILE* */
1861 #endif
1862 define_variable(S(deftype_depth_limit),NIL); /* CUSTOM:*DEFTYPE-DEPTH-LIMIT* */
1863 #if defined(WIN32_NATIVE) || defined(UNIX_CYGWIN)
1864 define_variable(S(device_prefix),NIL); /* CUSTOM:*DEVICE-PREFIX* */
1865 #endif
1866 /* for EVAL: */
1867 define_variable(S(evalhookstar),NIL); /* *EVALHOOK* := NIL */
1868 define_variable(S(applyhookstar),NIL); /* *APPLYHOOK* := NIL */
1869 /* for MISC: */
1870 define_constant(S(internal_time_units_per_second), /* INTERNAL-TIME-UNITS-PER-SECOND */
1871 fixnum(ticks_per_second) ); /* := 200 resp. 1000000 */
1872 /* for PREDTYPE: */
1873 define_variable(S(recurse_count_gc_statistics),Fixnum_0); /* SYS::*RECURSE-COUNT-GC-STATISTICS* := 0 */
1874 /* for ERROR: */
1875 define_variable(S(use_clcs),NIL); /* SYS::*USE-CLCS* := NIL */
1876 define_variable(S(recursive_error_count),Fixnum_0); /* SYS::*RECURSIVE-ERROR-COUNT* := 0 */
1877 define_variable(S(error_handler),NIL); /* *ERROR-HANDLER* := NIL */
1878 /* for SPVW: */
1879 define_variable(S(init_hooks),NIL); /* CUSTOM::*INIT-HOOKS* := NIL */
1880 define_variable(S(fini_hooks),NIL); /* CUSTOM::*FINI-HOOKS* := NIL */
1881 define_variable(S(quiet),NIL); /* SYS::*QUIET* := NIL */
1882 define_variable(S(norc),NIL); /* SYS::*NORC* := NIL */
1883 define_variable(S(script),T); /* SYS::*SCRIPT* := T */
1884 define_variable(S(image_doc),NIL); /* SYS::*IMAGE-DOC* := NIL */
1885 define_variable(S(args),NIL); /* EXT:*ARGS* := NIL */
1886 define_variable(S(load_compiling),NIL); /* *LOAD-COMPILING* := NIL */
1887 define_variable(S(load_verbose),T); /* *LOAD-VERBOSE* := T */
1888 define_variable(S(load_print),NIL); /* *LOAD-PRINT* := NIL */
1889 define_variable(S(load_echo),NIL); /* *LOAD-ECHO* := NIL */
1890 define_variable(S(load_paths),NIL); /* *LOAD-PATHS* := NIL */
1891 define_variable(S(compile_print),NIL); /* *COMPILE-PRINT* := NIL */
1892 define_variable(S(compile_verbose),T); /* *COMPILE-VERBOSE* := T */
1893 define_variable(S(saveinitmem_verbose),T); /* *SAVEINITMEM-VERBOSE* := T */
1894 define_variable(S(report_error_print_backtrace),NIL); /* *REPORT-ERROR-PRINT-BACKTRACE* := NIL */
1895 define_variable(S(loop_ansi),NIL); /* CUSTOM:*LOOP-ANSI* := NIL */
1896 define_variable(S(defun_accept_specialized_lambda_list),NIL); /* CUSTOM:*DEFUN-ACCEPT-SPECIALIZED-LAMBDA-LIST* := NIL */
1897 /* for FOREIGN: */
1898 #ifdef DYNAMIC_FFI
1899 define_constant(S(fv_flag_readonly),fixnum(fv_readonly)); /* FFI::FV-FLAG-READONLY */
1900 define_constant(S(fv_flag_malloc_free),fixnum(fv_malloc)); /* FFI::FV-FLAG-MALLOC-FREE */
1901 define_constant(S(ff_flag_alloca),fixnum(ff_alloca)); /* FFI::FF-FLAG-ALLOCA */
1902 define_constant(S(ff_flag_malloc_free),fixnum(ff_malloc)); /* FFI::FF-FLAG-MALLOC-FREE */
1903 define_constant(S(ff_flag_out),fixnum(ff_out)); /* FFI::FF-FLAG-OUT */
1904 define_constant(S(ff_flag_in_out),fixnum(ff_inout)); /* FFI::FF-FLAG-IN-OUT */
1905 define_constant(S(ff_language_asm),fixnum(ff_lang_asm)); /* FFI::FF-LANGUAGE-ASM */
1906 define_constant(S(ff_language_c),fixnum(ff_lang_c)); /* FFI::FF-LANGUAGE-C */
1907 define_constant(S(ff_language_ansi_c),fixnum(ff_lang_ansi_c)); /* FFI::FF-LANGUAGE-ANSI-C */
1908 define_constant(S(ff_language_stdcall),fixnum(ff_lang_stdcall)); /* FFI::FF-LANGUAGE-STDCALL */
1909 #endif
1910 /* for DISASSEM.LISP: */
1911 #ifdef UNIX
1912 /* SYS::*DISASSEMBLE-USE-LIVE-PROCESS* is system dependent:
1913 We use it where possible, because it allows peeking into dynamically
1914 loaded shared libraries.
1915 On FreeBSD 4.0, if set to T, gdb stops the clisp process.
1916 On Linux ppc64 & MacOSX, if set to T, clisp hangs until C-c.
1917 On Woe32, the debugging APIs are flawed, the Cygwin developers say. */
1918 #if defined(UNIX_FREEBSD) || defined(UNIX_MACOSX) || defined(UNIX_CYGWIN) || (defined(UNIX_LINUX) && defined(POWERPC))
1919 define_variable(S(disassemble_use_live_process),NIL);
1920 #else
1921 define_variable(S(disassemble_use_live_process),T);
1922 #endif
1923 #endif
1924 /* for PATHNAME: */
1925 { /* SYS::*LOGICAL-PATHNAME-TRANSLATIONS* :=
1926 (MAKE-HASH-TABLE :KEY-TYPE 'STRING :VALUE-TYPE 'LIST :TEST #'EQUALP) */
1927 pushSTACK(S(Ktest)); pushSTACK(L(equalp)); funcall(L(make_hash_table),2);
1928 define_variable(S(logpathname_translations),value1);
1929 }
1930 O(empty_logical_pathname) = allocate_logpathname();
1931 /* initialize *DEFAULT-PATHNAME-DEFAULTS* preliminarily: */
1932 define_variable(S(default_pathname_defaults),allocate_pathname());
1933 define_variable(S(user_lib_directory),NIL);
1934 #undef define_constant_UL1
1935 }
1936 /* create other objects and fill object table: */
init_object_tab(void)1937 local void init_object_tab (void) {
1938 /* table with initialization strings: */
1939 local var const char * const object_initstring_tab [] = {
1940 #define LISPOBJ LISPOBJ_C
1941 #include "constobj.c"
1942 #undef LISPOBJ
1943 };
1944 { /* initialize *FEATURES* : */
1945 var const char * features_initstring =
1946 "(:CLISP :ANSI-CL :COMMON-LISP :LISP=CL :INTERPRETER :LOGICAL-PATHNAMES"
1947 #ifdef DEBUG_COMPILER
1948 " :CLISP-DEBUG"
1949 #endif
1950 #ifdef MULTITHREAD
1951 " :MT"
1952 #endif
1953 #ifdef SOCKET_STREAMS
1954 " :SOCKETS"
1955 #endif
1956 #ifdef GENERIC_STREAMS
1957 " :GENERIC-STREAMS"
1958 #endif
1959 #ifdef SCREEN
1960 " :SCREEN"
1961 #endif
1962 #ifdef DYNAMIC_FFI
1963 " :FFI"
1964 #endif
1965 #ifdef GNU_GETTEXT
1966 " :GETTEXT"
1967 #endif
1968 #ifdef ENABLE_UNICODE
1969 " :UNICODE"
1970 #endif
1971 #if (base_char_code_limit == char_code_limit)
1972 " :BASE-CHAR=CHARACTER"
1973 #endif
1974 #ifdef WIDE_HARD
1975 " :WORD-SIZE=64"
1976 #endif
1977 #ifdef PC386
1978 " :PC386"
1979 #endif
1980 #ifdef UNIX
1981 " :UNIX"
1982 #endif
1983 #ifdef UNIX_MACOSX
1984 " :MACOS"
1985 #endif
1986 #ifdef UNIX_CYGWIN
1987 " :CYGWIN"
1988 #endif
1989 #ifdef UNIX_BEOS
1990 " :BEOS"
1991 #endif
1992 #ifdef UNIX_HAIKU
1993 " :HAIKU"
1994 #endif
1995 #ifdef WIN32
1996 " :WIN32"
1997 #endif
1998 ")";
1999 pushSTACK(ascii_to_string(features_initstring));
2000 var object list = (funcall(L(read_from_string),1), value1);
2001 define_variable(S(features),list); /* *FEATURES* */
2002 }
2003 { /* read objects from the strings: */
2004 var gcv_object_t* objptr = (gcv_object_t*)&object_tab; /* traverse object_tab */
2005 var const char * const * stringptr = &object_initstring_tab[0]; /* traverse string table */
2006 var uintC count = object_count;
2007 while (count--) {
2008 var const char * string = *stringptr++;
2009 if (*string == '@') {
2010 /* no READ-FROM-STRING for LISPOBJ_L && GNU_GETTEXT */
2011 *objptr = asciz_to_string(&string[1],O(internal_encoding));
2012 } else if (!(string[0] == '.' && string[1] == 0)) {
2013 pushSTACK(asciz_to_string(string,O(internal_encoding))); /* string */
2014 funcall(L(make_string_input_stream),1); /* pack into stream */
2015 pushSTACK(value1);
2016 var object obj = stream_read(&STACK_0,NIL,NIL); /* read object */
2017 skipSTACK(1);
2018 *objptr = obj; /* store (except ".") */
2019 }
2020 objptr++;
2021 }
2022 }
2023 /* initialize software_type */
2024 O(software_type) = built_flags();
2025 /* build toplevel-declaration-environment */
2026 Car(O(top_decl_env)) = O(declaration_types);
2027 /* Initialize compiled closures. */
2028 init_cclosures();
2029 }
2030 /* manual initialization of all LISP-data: */
initmem(void)2031 local void initmem (void) {
2032 init_symbol_tab_1(); /* initialize symbol_tab */
2033 init_object_tab_1(); /* initialize object_tab */
2034 init_other_modules_1(); /* initialize other modules coarsely */
2035 {
2036 aktenv.var_env = NIL; aktenv.fun_env = NIL; aktenv.block_env = NIL;
2037 aktenv.go_env = NIL; aktenv.decl_env = NIL;
2038 }
2039 /* Now the tables are coarsely initialized,
2040 nothing can happen at GC.
2041 finish initialization of subr_tab: */
2042 init_subr_tab_2();
2043 /* initialize packages: */
2044 #ifdef MULTITHREAD
2045 /* initialize O(all_mutexes) since every packages creates ones that
2046 is added to it */
2047 O(all_mutexes) = NIL;
2048 #endif
2049 init_packages();
2050 init_encodings_1(); /* init some encodings (utf_8 for init_symbol_tab_2) */
2051 /* finish initialization of symbol_tab: */
2052 init_symbol_tab_2();
2053 init_encodings_2(); /* init the rest of encodings */
2054 /* enter SUBRs/FSUBRs into their symbols: */
2055 init_symbol_functions();
2056 /* constants/variables: enter value into the symbols: */
2057 init_symbol_values();
2058 /* create other objects: */
2059 init_object_tab();
2060 }
2061 /* initialization of the other, not yet initialized modules: */
2062 local void init_other_modules_2 (void);
init_module_2(module_t * module)2063 local void init_module_2 (module_t* module) {
2064 /* pre-initialize subr_tab, object_tab, so that GC becomes possible: */
2065 if (*module->stab_size > 0) {
2066 var subr_t* ptr = module->stab; /* traverse subr_tab */
2067 var uintC count = *module->stab_size;
2068 do {
2069 ptr->GCself = subr_tab_ptr_as_object(ptr);
2070 ptr->name = NIL; ptr->keywords = NIL;
2071 ptr++;
2072 } while (--count);
2073 }
2074 if (*module->otab_size > 0) {
2075 var gcv_object_t* ptr = module->otab; /* traverse object_tab */
2076 var uintC count = *module->otab_size;
2077 do { *ptr++ = NIL; } while(--count);
2078 }
2079 module->initialized = true; /* GC can see this subr_tab, object_tab */
2080 /* enter Subr-symbols: */
2081 if (*module->stab_size > 0) {
2082 var subr_t* subr_ptr = module->stab;
2083 var const subr_initdata_t* init_ptr = module->stab_initdata;
2084 var uintC count = *module->stab_size;
2085 do {
2086 var const char* packname = init_ptr->packname;
2087 var object symname = asciz_to_string(init_ptr->symname,O(internal_encoding));
2088 var object symbol;
2089 if (packname==NULL) {
2090 symbol = make_symbol(symname);
2091 } else {
2092 pushSTACK(symname);
2093 var object pack =
2094 find_package(asciz_to_string(packname,O(internal_encoding)));
2095 if (nullp(pack)) { /* package not found? */
2096 fprintf(stderr,GETTEXTL("module '%s' requires package %s.\n"),
2097 module->name, packname);
2098 quit_instantly(1);
2099 }
2100 symname = popSTACK();
2101 intern(symname,false,pack,&symbol);
2102 }
2103 subr_ptr->name = symbol; /* complete Subr */
2104 if (pack_locked_p(Symbol_package(symbol))
2105 && !nullp(Symbol_function(symbol))) { /* package lock error */
2106 fprintf(stderr,GETTEXTL("module '%s' redefines symbol "),module->name);
2107 nobject_out(stderr,symbol);
2108 fprint(stderr,GETTEXTL(" in the locked package "));
2109 nobject_out(stderr,Symbol_package(symbol));
2110 fprint(stderr,GETTEXTL("\nold definition: "));
2111 nobject_out(stderr,Symbol_function(symbol));
2112 fprint(stderr,"\n");
2113 quit_instantly(1);
2114 }
2115 Symbol_function(symbol) = subr_tab_ptr_as_object(subr_ptr); /* define function */
2116 init_ptr++; subr_ptr++;
2117 } while (--count);
2118 }
2119 /* enter objects: */
2120 if (*module->otab_size > 0) {
2121 var gcv_object_t* object_ptr = module->otab;
2122 var const object_initdata_t* init_ptr = module->otab_initdata;
2123 var uintC count = *module->otab_size;
2124 do {
2125 pushSTACK(asciz_to_string(init_ptr->initstring,O(internal_encoding))); /* string */
2126 funcall(L(make_string_input_stream),1); /* pack into stream */
2127 pushSTACK(value1);
2128 *object_ptr = stream_read(&STACK_0,NIL,NIL); /* read object */
2129 skipSTACK(1);
2130 object_ptr++; init_ptr++;
2131 } while (--count);
2132 }
2133 /* call initialization function: */
2134 (*module->initfunction1)(module);
2135 }
init_other_modules_2(void)2136 local void init_other_modules_2 (void) {
2137 var module_t* module; /* traverse modules */
2138 for_modules(all_other_modules,{
2139 if (!module->initialized)
2140 init_module_2(module);
2141 });
2142 }
2143
2144 /* print usage */
usage(bool delegating)2145 local void usage (bool delegating) {
2146 printf(PACKAGE_NAME " (" PACKAGE_BUGREPORT ") ");
2147 puts(GETTEXTL("is an ANSI Common Lisp implementation."));
2148 if (delegating) {
2149 printf(GETTEXTL("This image does not process the usual command line arguments.\n"
2150 "To create a normal image \"myclisp\", please do\n"
2151 "%s --clisp-x '(ext:saveinitmem \"myclisp\" :executable t :init-function nil)'\n"),program_name);
2152 return;
2153 }
2154 printf(GETTEXTL("Usage: %s [options] [lispfile [argument ...]]\n"
2155 " When 'lispfile' is given, it is loaded and '*ARGS*' is set\n"
2156 " to the list of argument strings. Otherwise, an interactive\n"
2157 " read-eval-print loop is entered.\n"),program_name);
2158 puts(GETTEXTL("Informative output:"));
2159 puts(GETTEXTL(" -h, --help - print this help and exit"));
2160 puts(GETTEXTL(" --version - print the version information"));
2161 puts(GETTEXTL(" --license - print the licensing information"));
2162 puts(GETTEXTL(" -help-image - print image-specific help and exit"));
2163 puts(GETTEXTL("Memory image selection:"));
2164 puts(GETTEXTL(" -B lisplibdir - set the installation directory"));
2165 #if defined(UNIX) || defined(WIN32_NATIVE)
2166 puts(GETTEXTL(" -K linkingset - use this executable and memory image"));
2167 #endif
2168 puts(GETTEXTL(" -M memfile - use this memory image"));
2169 puts(GETTEXTL(" -m size - memory size (size = nB or nKB or nMB)"));
2170 puts(GETTEXTL("Internationalization:"));
2171 puts(GETTEXTL(" -L language - set user language"));
2172 puts(GETTEXTL(" -N nlsdir - NLS catalog directory"));
2173 puts(GETTEXTL(" -Edomain encoding - set encoding"));
2174 puts(GETTEXTL("Interoperability:"));
2175 puts(GETTEXTL(" -q, --quiet, --silent, -v, --verbose - verbosity level:\n"
2176 " affects banner, *LOAD-VERBOSE*/*COMPILE-VERBOSE*,\n"
2177 " and *LOAD-PRINT*/*COMPILE-PRINT*"));;
2178 puts(GETTEXTL(" -w - wait for a keypress after program termination"));
2179 puts(GETTEXTL(" -I - be ILISP-friendly"));
2180 puts(GETTEXTL(" -disable-readline - do not use the gnu readline library"));
2181 puts(GETTEXTL("Startup actions:"));
2182 puts(GETTEXTL(" -ansi - more ANSI CL compliance"));
2183 puts(GETTEXTL(" -traditional - traditional (undoes -ansi)"));
2184 puts(GETTEXTL(" -modern - start in a case-sensitive lowercase-preferring package"));
2185 puts(GETTEXTL(" -p package - start in the package"));
2186 puts(GETTEXTL(" -C - set *LOAD-COMPILING* to T"));
2187 puts(GETTEXTL(" -norc - do not load the user ~/.clisprc file"));
2188 puts(GETTEXTL(" -lp dir - add dir to *LOAD-PATHS* (can be repeated)"));
2189 puts(GETTEXTL(" -i file - load initfile (can be repeated)"));
2190 puts(GETTEXTL("Actions:"));
2191 puts(GETTEXTL(" -c [-l] lispfile [-o outputfile] - compile lispfile"));
2192 puts(GETTEXTL(" -x expressions - execute the expressions, then exit"));
2193 puts(GETTEXTL(" Depending on the image, positional arguments can mean:"));
2194 puts(GETTEXTL(" lispscript [argument ...] - load script, then exit"));
2195 puts(GETTEXTL(" [argument ...] - run the init-function"));
2196 puts(GETTEXTL(" arguments are placed in EXT:*ARGS* as strings."));
2197 puts(GETTEXTL("These actions put CLISP into a batch mode, which is overridden by"));
2198 puts(GETTEXTL(" -on-error action - action can be one of debug, exit, abort, appease"));
2199 puts(GETTEXTL(" -repl - enter the interactive read-eval-print loop when done"));
2200 puts(GETTEXTL("Default action is an interactive read-eval-print loop."));
2201 }
2202
2203 /* argument diagnostics */
arg_error(const char * error_message,const char * arg)2204 local void arg_error (const char *error_message, const char *arg) {
2205 if (arg)
2206 fprintf(stderr,"%s: %s: '%s'\n",PACKAGE_NAME,error_message,arg);
2207 else
2208 fprintf(stderr,"%s: %s\n",PACKAGE_NAME,error_message);
2209 fprintf(stderr,GETTEXTL("%s: use '-h' for help"),PACKAGE_NAME);
2210 fprint(stderr,"\n");
2211 }
2212 #define INVALID_ARG(a) do { \
2213 arg_error(GETTEXTL("invalid argument"),a); \
2214 return 1; \
2215 } while (0)
2216
2217 /* print license */
print_license(void)2218 local _Noreturn void print_license (void) {
2219 local const char * const license [] = {
2220 PACKAGE_NAME " is free software; you can redistribute and/or modify it\n",
2221 "under the terms of the GNU General Public License as published by\n",
2222 "the Free Software Foundation; either version 2, or (at your option)\n",
2223 "any later version.\n",
2224 "\n",
2225 PACKAGE_NAME " is distributed in the hope that it will be useful,\n",
2226 "but WITHOUT ANY WARRANTY; without even the implied warranty of\n",
2227 "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n",
2228 "See the GNU General Public License for more details.\n",
2229 "\n",
2230 "You should have received a copy of the GNU General Public License\n",
2231 "along with " PACKAGE_NAME ", see file GNU-GPL.\n",
2232 "If not, write to the Free Software Foundation, Inc.,\n",
2233 "51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.\n",
2234 "\n",
2235 "Distribution of Lisp programs meant to run in " PACKAGE_NAME "\n",
2236 "without sources is possible under certain conditions.\n",
2237 "See file COPYRIGHT that came with " PACKAGE_NAME " for details.\n",
2238 "\n",
2239 };
2240 var const char * const * ptr = license;
2241 var uintC count = sizeof(license)/sizeof(license[0]);
2242 pushSTACK(var_stream(S(standard_output),strmflags_wr_ch_B));
2243 fresh_line(&STACK_0); /* The *INIT-HOOKS* might have done output. */
2244 while (count--)
2245 write_sstring(&STACK_0,asciz_to_string(*ptr++,O(internal_encoding)));
2246 skipSTACK(1);
2247 quit_instantly(0);
2248 }
2249
2250 #include "spvw_calendar.c"
2251
2252 /* print the banner */
print_banner(void)2253 local void print_banner (void)
2254 { const char * const banner0[] = { /* some lines above 66 characters */
2255 /*|Column 0 |Column 20 |Col 66
2256 "012345678901234567890123456789012345678901234567890123456789012345678901"*/
2257 " i i i i i i i ooooo o ooooooo ooooo ooooo\n",
2258 " I I I I I I I 8 8 8 8 8 o 8 8\n",
2259 " I \\ `+' / I 8 8 8 8 8 8\n",
2260 " \\ `-+-' / 8 8 8 ooooo 8oooo\n",
2261 " `-__|__-' 8 8 8 8 8\n",
2262 " | 8 o 8 8 o 8 8\n",
2263 " ------+------ ooooo 8oooooo ooo8ooo ooooo 8\n",
2264 };
2265 const char * banner0_hanukka[] = { /* some lines above 66 characters */
2266 /*|Column 0 |Column 20 |Col 66
2267 "012345678901234567890123456789012345678901234567890123456789012345678901" */
2268 " .\n",
2269 ". . . . I . . . . ooooo o ooooooo ooooo ooooo\n",
2270 "I I I I I I I I I 8 8 8 8 8 o 8 8\n",
2271 "I I \\ `+' / I I 8 8 8 8 8 8\n",
2272 "I \\ `-+-' / I 8 8 8 ooooo 8oooo\n",
2273 " \\ `-__|__-' / 8 8 8 8 8\n",
2274 " `--___|___--' 8 o 8 8 o 8 8\n",
2275 " | ooooo 8oooooo ooo8ooo ooooo 8\n",
2276 "--------+--------\n",
2277 };
2278 char banner0_line0[100];
2279 char banner0_line1[100];
2280 const char * const banner1[] = {
2281 "Copyright (c) Bruno Haible, Michael Stoll 1992-1993\n",
2282 "Copyright (c) Bruno Haible, Marcus Daniels 1994-1997\n",
2283 "Copyright (c) Bruno Haible, Pierpaolo Bernardi, Sam Steingold 1998\n",
2284 "Copyright (c) Bruno Haible, Sam Steingold 1999-2000\n",
2285 "Copyright (c) Sam Steingold, Bruno Haible 2001-2018\n",
2286 };
2287 var int candles = 0;
2288 var uintL offset = (posfixnum_to_V(Symbol_value(S(prin_linelength))) >= 65 ? 0 : 20);
2289 if (offset == 0) {
2290 begin_system_call();
2291 strcpy(banner0_line0,banner0_hanukka[0]);
2292 strcpy(banner0_line1,banner0_hanukka[1]);
2293 var time_t now = time(NULL);
2294 var struct tm now_local;
2295 var struct tm now_gm;
2296 now_local = *(localtime(&now));
2297 now_gm = *(gmtime(&now));
2298 end_system_call();
2299 var sintL dayswest = /* Tage-Differenz, kann als 0,1,-1 angenommen werden */
2300 (now_gm.tm_year < now_local.tm_year ? -1 :
2301 now_gm.tm_year > now_local.tm_year ? 1 :
2302 (now_gm.tm_mon < now_local.tm_mon ? -1 :
2303 now_gm.tm_mon > now_local.tm_mon ? 1 :
2304 (now_gm.tm_mday < now_local.tm_mday ? -1 :
2305 now_gm.tm_mday > now_local.tm_mday ? 1 :
2306 0)));
2307 var sintL hourswest = 24*dayswest
2308 + (sintL)(now_gm.tm_hour - now_local.tm_hour);
2309 var uintL hours_since_1900 = ((unsigned long)now / 3600) - hourswest + 613608;
2310 /* Add 6 because Hebrew days begin in the evening. */
2311 var uintL days_since_1900 = (hours_since_1900 + 6) / 24;
2312 candles = hebrew_calendar_hanukka_candles(days_since_1900);
2313 if (candles > 0) {
2314 banner0_line0[8] = 'i';
2315 if (candles >= 1) {
2316 banner0_line1[16] = 'i';
2317 if (candles >= 2) {
2318 banner0_line1[14] = 'i';
2319 if (candles >= 3) {
2320 banner0_line1[12] = 'i';
2321 if (candles >= 4) {
2322 banner0_line1[10] = 'i';
2323 if (candles >= 5) {
2324 banner0_line1[6] = 'i';
2325 if (candles >= 6) {
2326 banner0_line1[4] = 'i';
2327 if (candles >= 7) {
2328 banner0_line1[2] = 'i';
2329 if (candles >= 8) {
2330 banner0_line1[0] = 'i';
2331 }
2332 }
2333 }
2334 }
2335 }
2336 }
2337 }
2338 }
2339 }
2340 banner0_hanukka[0] = banner0_line0;
2341 banner0_hanukka[1] = banner0_line1;
2342 }
2343 var const char * const * ptr;
2344 var uintC count;
2345 pushSTACK(var_stream(S(standard_output),strmflags_wr_ch_B)); /* to *STANDARD-OUTPUT* */
2346 fresh_line(&STACK_0); /* The *INIT-HOOKS* might have done output. */
2347 if (candles > 0) {
2348 ptr = banner0_hanukka; count = sizeof(banner0_hanukka)/sizeof(banner0_hanukka[0]);
2349 } else {
2350 ptr = banner0; count = sizeof(banner0)/sizeof(banner0[0]);
2351 }
2352 while (count--)
2353 write_sstring(&STACK_0,asciz_to_string((*ptr++)+offset,O(internal_encoding)));
2354 terpri(&STACK_0);
2355 write_sstring(&STACK_0,asciz_to_string(GETTEXT("Welcome to"),O(internal_encoding)));
2356 write_sstring(&STACK_0,asciz_to_string(" " PACKAGE_STRING " <" PACKAGE_BUGREPORT ">\n\n",O(internal_encoding)));
2357 ptr = banner1; count = sizeof(banner1)/sizeof(banner1[0]);
2358 while (count--)
2359 write_sstring(&STACK_0,asciz_to_string(*ptr++,O(internal_encoding)));
2360 terpri(&STACK_0);
2361 write_sstring(&STACK_0,asciz_to_string(GETTEXT("Type :h and hit Enter for context help."),O(internal_encoding)));
2362 terpri(&STACK_0); terpri(&STACK_0);
2363 finish_output(STACK_0);
2364 skipSTACK(1);
2365 }
2366
2367 typedef enum {
2368 ON_ERROR_DEFAULT,
2369 ON_ERROR_DEBUG,
2370 ON_ERROR_ABORT,
2371 ON_ERROR_APPEASE,
2372 ON_ERROR_EXIT
2373 } on_error_t;
2374
2375 /* install the appropriate global handglers
2376 can trigger GC */
install_global_handlers(on_error_t on_error)2377 local maygc void install_global_handlers (on_error_t on_error)
2378 {
2379 /* do nothing if there is no memory image */
2380 if (!boundp(Symbol_function(S(set_global_handler)))) return;
2381 switch (on_error) {
2382 case ON_ERROR_EXIT: {
2383 pushSTACK(S(interrupt_condition));
2384 pushSTACK(Symbol_function(S(exitunconditionally)));
2385 funcall(S(set_global_handler),2);
2386 pushSTACK(S(serious_condition));
2387 pushSTACK(Symbol_function(S(exitonerror)));
2388 funcall(S(set_global_handler),2);
2389 } goto appease;
2390 case ON_ERROR_ABORT: {
2391 pushSTACK(S(serious_condition));
2392 pushSTACK(Symbol_function(S(abortonerror)));
2393 funcall(S(set_global_handler),2);
2394 } /*FALLTHROUGH*/
2395 case ON_ERROR_APPEASE: appease: {
2396 pushSTACK(S(error)); pushSTACK(Symbol_function(S(appease_cerror)));
2397 funcall(S(set_global_handler),2); return;
2398 }
2399 case ON_ERROR_DEBUG: return;
2400 default: NOTREACHED;
2401 }
2402 }
2403
2404 /* Very early initializations. */
init_lowest_level(char * argv[])2405 local inline void init_lowest_level (char* argv[]) {
2406 #ifdef WIN32_NATIVE
2407 init_win32();
2408 #endif
2409 begin_system_call();
2410 find_executable(argv[0]);
2411 end_system_call();
2412 }
2413
2414 #if defined(GNU_READLINE) && HAVE_DECL_RL_DEPREP_TERM_FUNCTION
2415 #include <readline/readline.h>
2416 #endif
2417
2418 /* Very late de-initializations, */
fini_lowest_level(void)2419 local inline void fini_lowest_level (void) {
2420 #ifdef WIN32_NATIVE
2421 done_win32();
2422 #endif
2423 #if defined(UNIX)
2424 terminal_sane(); /* switch terminal again in normal mode */
2425 #endif
2426 #if defined(GNU_READLINE) && HAVE_DECL_RL_DEPREP_TERM_FUNCTION
2427 if (rl_deprep_term_function)
2428 (*rl_deprep_term_function) ();
2429 #endif
2430 }
2431
2432 /* There are three type of command-line options:
2433 - Those which set global variables,
2434 - Those which set parameters needed to initialize C I/O.
2435 - Those which set parameters needed to initialize Lisp memory,
2436 - Those which set parameters that determine the actions to be executed. */
2437
2438 /* Global variables. */
2439 global const char* locale_encoding = NULL; /* GNU canonical name of locale encoding */
2440 global const char* argv_encoding_misc = NULL; /* override for *misc-encoding* */
2441 global const char* argv_encoding_file = NULL; /* ... for *default-file-encoding* */
2442 #ifndef CONSTANT_PATHNAME_ENCODING
2443 global const char* argv_encoding_pathname = NULL; /* ... for *pathname-encoding* */
2444 #endif
2445 global const char* argv_encoding_terminal = NULL; /* ... for *terminal-encoding* */
2446 global const char* argv_encoding_foreign = NULL; /* ... for *foreign-encoding* */
2447
2448 /* Parameters needed to initialize C I/O. */
2449 struct argv_init_c {
2450 const char* argv_language;
2451 const char* argv_localedir;
2452 };
2453
2454 /* Parameters needed to initialize Lisp memory. */
2455 struct argv_initparams {
2456 uintM argv_memneed;
2457 double argv_nextgc_factor;
2458 const char* argv_memfile;
2459 };
2460
2461 /* Parameters that determine the actions to be executed. */
2462 typedef enum {
2463 action_normal, /* normal processing: load mem-file etc. */
2464 action_mfihash, /* option -memfile-hash */
2465 action_mfihash_of, /* option -memfile-hash-of */
2466 action_mfcompat /* option -memfile-compatible */
2467 } main_action_t;
2468 typedef struct { const char* input_file; const char* output_file; } argv_compile_file_t;
2469 struct argv_actions {
2470 main_action_t argv_main_action;
2471 const char* argv_memfile;
2472 int argv_verbose; /* verbosity level */
2473 const char* argv_lisplibdir;
2474 bool argv_developer;
2475 bool argv_load_compiling;
2476 uintL argv_load_paths_count;
2477 argv_compile_file_t* argv_load_paths; /* share space with -c args */
2478 uintL argv_init_filecount;
2479 const char **argv_init_files;
2480 bool argv_compile;
2481 bool argv_compile_listing;
2482 bool argv_norc;
2483 on_error_t argv_on_error;
2484 uintL argv_compile_filecount;
2485 argv_compile_file_t* argv_compile_files;
2486 const char* argv_package;
2487 int argv_ansi; /* 0: default; 1: ANSI; 2: traditional */
2488 bool argv_modern;
2489 bool argv_repl;
2490 uintL argv_expr_count;
2491 const char **argv_exprs; /* stored backwards! */
2492 const char* argv_execute_file;
2493 const char* const* argv_execute_args;
2494 uintL argv_execute_arg_count;
2495 bool argv_batchmode_p;
2496 bool argv_license;
2497 bool argv_wait_keypress;
2498 bool argv_help_image;
2499 };
2500
2501 /* parses the rest of an option, that specifies a byte-size.
2502 also checks, if certain boundaries are obeyed. */
size_arg(const char * arg,const char * docstring,uintM * ret,uintM limit_low,uintM limit_high)2503 local inline int size_arg (const char *arg, const char *docstring, uintM *ret,
2504 uintM limit_low, uintM limit_high) {
2505 /* arg should consist of a few decimal places, then
2506 maybe K/M/G/T/P, then maybe B or W: [0-9]+[KMGTP]?[BW]? */
2507 uintM val = 0;
2508 while ((*arg >= '0') && (*arg <= '9'))
2509 val = 10*val + (uintM)(*arg++ - '0');
2510 switch (*arg) {
2511 case 'k': case 'K': /* in kilobytes */
2512 val <<= 10; arg++; break; /* *= 1024 */
2513 case 'm': case 'M': /* in megabytes */
2514 val <<= 20; arg++; break; /* *= 1024*1024 */
2515 case 'g': case 'G': /* in gigabytes */
2516 val <<= 30; arg++; break; /* *= 1024*1024*1024 */
2517 #if intMsize > 32 /* 64-bit platforms only */
2518 case 't': case 'T': /* in terabytes */
2519 val <<= 40; arg++; break; /* *= 1024*1024*1024*1024 */
2520 case 'p': case 'P': /* in petabytes */
2521 val <<= 50; arg++; break; /* *= 1024*1024*1024*1024*1024 */
2522 #endif
2523 }
2524 switch (*arg) {
2525 case 'w': case 'W': /* in words */
2526 val *= sizeof(gcv_object_t); /*FALLTHROUGH*/
2527 case 'b': case 'B': /* in bytes */
2528 arg++; break;
2529 }
2530 if (*arg != '\0') { /* argument finished? */
2531 fprintf(stderr,GETTEXTL("Syntax for %s: nnnnnnn or nnnnKB or nMB"),
2532 docstring);
2533 fprint(stderr,"\n");
2534 return 1;
2535 }
2536 if (val < limit_low) {
2537 fprintf(stderr,GETTEXTL("warning: %s %lu too small, using %lu instead"),
2538 docstring, val, limit_low);
2539 fprint(stderr,"\n");
2540 val = limit_low;
2541 }
2542 if (val > limit_high) {
2543 fprintf(stderr,GETTEXTL("warning: %s %lu too large, using %lu instead"),
2544 docstring, val, limit_high);
2545 fprint(stderr,"\n");
2546 val = limit_high;
2547 }
2548 /* For multiple -m arguments, only the last counts. */
2549 *ret = val;
2550 return 0;
2551 }
2552
2553 local const char* delegating_cookie =
2554 "should clisp delegate non --clisp args? N";
2555 local int delegating_cookie_length = -1;
delegating_p(void)2556 local bool delegating_p (void) {
2557 if (delegating_cookie_length == -1)
2558 delegating_cookie_length = asciz_length(delegating_cookie);
2559 return delegating_cookie[delegating_cookie_length-1] == 'Y';
2560 }
2561
2562 #if defined(UNIX)
2563 #define DROP_PRIVILEGES drop_privileges()
2564 #else
2565 #define DROP_PRIVILEGES do { /*noop*/ } while(0)
2566 #endif
2567
2568 /* Parse the command-line options.
2569 Returns -1 on normal termination, or an exit code >= 0 for immediate exit. */
parse_options(int argc,const char * const * argv,struct argv_init_c * p0,struct argv_initparams * p1,struct argv_actions * p2)2570 local inline int parse_options (int argc, const char* const* argv,
2571 struct argv_init_c* p0,
2572 struct argv_initparams* p1,
2573 struct argv_actions* p2) {
2574 var const bool delegating = delegating_p();
2575 p0->argv_language = NULL;
2576 p0->argv_localedir = NULL;
2577 p1->argv_memneed = 0;
2578 p1->argv_nextgc_factor = 1.0;
2579 p1->argv_memfile = NULL;
2580 p2->argv_main_action = action_normal;
2581 p2->argv_memfile = NULL;
2582 p2->argv_verbose = 2;
2583 p2->argv_lisplibdir = NULL;
2584 p2->argv_developer = false;
2585 p2->argv_load_compiling = false;
2586 p2->argv_init_filecount = 0;
2587 p2->argv_init_files = (const char**) malloc((uintL)argc*sizeof(const char*)); /* max argc -x/-i options */
2588 p2->argv_compile = false;
2589 p2->argv_compile_listing = false;
2590 p2->argv_norc = delegating; /* application should have its own RC file */
2591 p2->argv_on_error = ON_ERROR_DEFAULT;
2592 p2->argv_compile_filecount = 0;
2593 p2->argv_compile_files = (argv_compile_file_t*) malloc((uintL)argc*sizeof(argv_compile_file_t)); /* max argc file-arguments + -lp arguments */
2594 p2->argv_load_paths_count = 0;
2595 p2->argv_load_paths = p2->argv_compile_files + argc; /* share space with -c */
2596 p2->argv_package = NULL;
2597 p2->argv_ansi = 0;
2598 p2->argv_modern = false;
2599 p2->argv_repl = false;
2600 p2->argv_expr_count = 0;
2601 p2->argv_exprs = p2->argv_init_files + argc; /* put -x and -i arguments into the same array */
2602 p2->argv_execute_file = NULL;
2603 p2->argv_execute_args = NULL;
2604 p2->argv_execute_arg_count = 0;
2605 p2->argv_batchmode_p = false;
2606 p2->argv_license = false;
2607 p2->argv_wait_keypress = false;
2608 p2->argv_help_image = false;
2609
2610 /* process arguments argv[0..argc-1] :
2611 -h Help
2612 -m size Memory size (size = nB or nKB or nMB)
2613 -t directory temporary directory
2614 -B directory set lisplibdir
2615 -K linkingset specify executable and mem file
2616 -M file load MEM-file
2617 -L language set the user language
2618 -N directory NLS catalog directory
2619 -Edomain encoding set encoding
2620 -q/-v verbosity level:
2621 3: banner, VERBOSE=T, PRINT=T
2622 * 2: banner, VERBOSE=T, PRINT=NIL ======= default
2623 1: no banner, VERBOSE=T, PRINT=NIL
2624 0: no banner, VERBOSE=NIL, PRINT=NIL
2625 -norc do not load the user ~/.clisprc file
2626 -I ILISP-friendly
2627 -C set *LOAD-COMPILING* to T
2628 -i file ... load LISP-file for initialization
2629 -c file ... compile LISP-files, then leave LISP
2630 -l At compilation: create listings
2631 -p package set *PACKAGE*
2632 -ansi more ANSI CL Compliance
2633 -traditional traditional (undoes -ansi)
2634 -modern modern (set *PACKAGE* and *PRINT-CASE*)
2635 -x expr execute LISP-expressions, then leave LISP
2636 -on-error debug override batch-mode for -c, -x and file
2637 -repl enter REPL after -c, -x and file
2638 -w wait for keypress after termination
2639 -memfile-hash Print the hash code of the mem file binary interface
2640 -memfile-hash-of mem-file Print the hash code of the mem file binary
2641 interface that was used to create this mem-file
2642 -memfile-compatible mem-file Return 0 or 1, depending whether this mem-file is
2643 compatible with this executable
2644 --help print usage and exit (should be the only option)
2645 --version print version and exit (should be the only option)
2646 file [arg ...] load LISP-file in batch-mode and execute, then leave LISP
2647 or put all positional arguments into *ARGS* and run DRIVER
2648 -help-image print what this image does
2649 -d -- developer mode -- undocumented, unsupported &c
2650 - unlock all packages.
2651
2652 Newly added options have to be listed:
2653 - in the above table,
2654 - in the usage-message here,
2655 - in the options parser,
2656 - in the options parser in _clisp.c,
2657 - in the manual page doc/clisp.xml.in. */
2658
2659 program_name = argv[0]; /* argv[0] is the program name */
2660 {
2661 var const char* const* argptr = &argv[1];
2662 var const char* const* argptr_limit = &argv[argc];
2663 var enum { for_exec, for_init, for_compile, for_expr, for_load_path }
2664 argv_for = for_exec;
2665 var bool clisp_superarg_used = false;
2666 /* loop and process options, replace processed options with NULL: */
2667 while (argptr < argptr_limit) {
2668 var const char* arg = *argptr++; /* next argument */
2669 if (0 == strncmp(arg,"--clisp",7)) {
2670 arg += 7; clisp_superarg_used = true;
2671 } else if (delegating) goto non_option;
2672 if ((arg[0] == '-') && !(arg[1] == '\0')) {
2673 switch (arg[1]) {
2674 case 'h': /* help */
2675 if (asciz_equal(arg,"-help-image")) {
2676 p2->argv_help_image = true;
2677 break;
2678 } else if (arg[2] != 0)
2679 INVALID_ARG(arg);
2680 else {
2681 usage(delegating);
2682 return 0;
2683 }
2684 /* returns after a one-character token the rest of the
2685 option in arg. poss. space is skipped. */
2686 #define OPTION_ARG \
2687 if (arg[2] == '\0') { \
2688 if (argptr < argptr_limit) \
2689 arg = *argptr++; \
2690 else INVALID_ARG(arg); \
2691 } else arg += 2
2692 case 'm': /* memory size */
2693 if (arg[2]=='m' && arg[3]=='\0') { /* "-mm" -> print a memory map */
2694 #if defined(WIN32_NATIVE)
2695 DumpProcessMemoryMap(stdout);
2696 #elif VMA_ITERATE_SUPPORTED
2697 dump_process_memory_map(stdout);
2698 #endif
2699 return 1;
2700 }
2701 if (asciz_equal(arg,"-marc")) { /* "-marc" -> MAPPABLE_ADDRESS_RANGE_* check */
2702 return mappable_address_range_check();
2703 }
2704 if (asciz_equal(arg,"-memfile-hash")) {
2705 p2->argv_main_action = action_mfihash;
2706 } else if (asciz_equal(arg,"-memfile-hash-of")) {
2707 if (argptr < argptr_limit)
2708 arg = *argptr++;
2709 else
2710 INVALID_ARG(arg);
2711 p2->argv_main_action = action_mfihash_of;
2712 p2->argv_memfile = arg;
2713 } else if (asciz_equal(arg,"-memfile-compatible")) {
2714 if (argptr < argptr_limit)
2715 arg = *argptr++;
2716 else
2717 INVALID_ARG(arg);
2718 p2->argv_main_action = action_mfcompat;
2719 p2->argv_memfile = arg;
2720 } else if (asciz_equal(arg,"-modern")) {
2721 p2->argv_modern = true;
2722 } else {
2723 OPTION_ARG;
2724 if (size_arg(arg,GETTEXTL("memory size"),&(p1->argv_memneed),
2725 (MINIMUM_SPACE + RESERVE) * 8 /*teile/teile_STACK*/,
2726 (oint_addr_len+addr_shift < intLsize-1
2727 /* address space in oint_addr_len+addr_shift bits */
2728 ? vbitm(oint_addr_len+addr_shift)
2729 /* (resp. big dummy-limit) */
2730 : vbitm(oint_addr_len+addr_shift)-1)))
2731 return 1;
2732 } break;
2733 case 't': /* traditional, temporary directory */
2734 if (asciz_equal(arg,"-traditional"))
2735 p2->argv_ansi = 2; /* traditional */
2736 else
2737 INVALID_ARG(arg);
2738 break;
2739 case 'd': /* -d (developer mode) or -disable-readline */
2740 if (asciz_equal(arg,"-disable-readline"))
2741 disable_readline = true;
2742 else if (arg[2] == '\0')
2743 p2->argv_developer = true;
2744 else
2745 INVALID_ARG(arg);
2746 break;
2747 case 'B': /* lisplibdir */
2748 OPTION_ARG;
2749 if (!(p2->argv_lisplibdir == NULL)) {
2750 arg_error(GETTEXTL("multiple -B"),arg);
2751 return 1;
2752 }
2753 p2->argv_lisplibdir = arg;
2754 break;
2755 case 'n':
2756 if (asciz_equal(arg,"-nextgc-factor")) {
2757 if (!(argptr < argptr_limit)) {
2758 arg_error(GETTEXTL("This option requires an argument"),arg);
2759 return 1;
2760 }
2761 arg = *argptr++;
2762 var char* arg_endptr;
2763 var double arg_value = c_strtod(arg,&arg_endptr);
2764 if (arg_value > 0.0 && arg_value < 1.0e10)
2765 p1->argv_nextgc_factor = arg_value;
2766 else
2767 arg_error("invalid 'nextgc-factor' value",arg);
2768 } else if (asciz_equal(arg,"-norc"))
2769 p2->argv_norc = true;
2770 else
2771 INVALID_ARG(arg);
2772 break;
2773 #if defined(UNIX) || defined(WIN32_NATIVE)
2774 case 'K': /* linKing set */
2775 OPTION_ARG;
2776 /* This option has already been digested by clisp.c.
2777 We can ignore it. */
2778 break;
2779 #endif
2780 case 'M': /* MEM-file: when repeated, only the last one counts. */
2781 OPTION_ARG;
2782 p1->argv_memfile = arg;
2783 p2->argv_memfile = arg;
2784 break;
2785 case 'L': /* Language: when repeated, only the last one counts. */
2786 OPTION_ARG;
2787 p0->argv_language = arg;
2788 break;
2789 case 'N': /* NLS-directory: when repeated, only the last one counts. */
2790 OPTION_ARG;
2791 p0->argv_localedir = arg;
2792 break;
2793 case 'E': /* encoding */
2794 if (!(argptr < argptr_limit)) {
2795 arg_error(GETTEXTL("-E requires an argument"),arg);
2796 return 1;
2797 }
2798 if (asciz_equal(&arg[2],"file"))
2799 argv_encoding_file = *argptr++;
2800 #ifndef CONSTANT_PATHNAME_ENCODING
2801 else if (asciz_equal(&arg[2],"pathname"))
2802 argv_encoding_pathname = *argptr++;
2803 #endif
2804 else if (asciz_equal(&arg[2],"terminal"))
2805 argv_encoding_terminal = *argptr++;
2806 else if (asciz_equal(&arg[2],"foreign"))
2807 argv_encoding_foreign = *argptr++;
2808 else if (asciz_equal(&arg[2],"misc"))
2809 argv_encoding_misc = *argptr++;
2810 else if (arg[2] == '\0') /* unspecified => all */
2811 #ifndef CONSTANT_PATHNAME_ENCODING
2812 argv_encoding_pathname =
2813 #endif
2814 argv_encoding_file = argv_encoding_terminal =
2815 argv_encoding_foreign = argv_encoding_misc = *argptr++;
2816 else
2817 INVALID_ARG(arg);
2818 break;
2819 case 'q': /* verbosity level */
2820 p2->argv_verbose--;
2821 if (arg[2] != '\0')
2822 INVALID_ARG(arg);
2823 break;
2824 case 'v': /* verbosity level */
2825 p2->argv_verbose++;
2826 if (arg[2] != '\0')
2827 INVALID_ARG(arg);
2828 break;
2829 case 'I': /* ILISP-friendly */
2830 ilisp_mode = true;
2831 if (arg[2] != '\0')
2832 INVALID_ARG(arg);
2833 break;
2834 case 'C': /* set *LOAD-COMPILING* */
2835 p2->argv_load_compiling = true;
2836 if (arg[2] != '\0')
2837 INVALID_ARG(arg);
2838 break;
2839 case 'r': /* -repl */
2840 if (asciz_equal(&arg[1],"repl"))
2841 p2->argv_repl = true;
2842 else
2843 INVALID_ARG(arg);
2844 break;
2845 case 'i': /* initialization files */
2846 if (arg[2] == '\0')
2847 argv_for = for_init;
2848 else
2849 INVALID_ARG(arg);
2850 break;
2851 case 'c': /* files to be compiled */
2852 p2->argv_compile = true;
2853 argv_for = for_compile;
2854 if (arg[2] == 'l') {
2855 p2->argv_compile_listing = true;
2856 if (arg[3] != '\0')
2857 INVALID_ARG(arg);
2858 } else {
2859 if (arg[2] != '\0')
2860 INVALID_ARG(arg);
2861 }
2862 break;
2863 case 'l': /* compilation listings */
2864 if (arg[2] == 0)
2865 p2->argv_compile_listing = true;
2866 else if (arg[2] == 'p' && arg[3] == 0) {
2867 argv_for = for_load_path;
2868 } else
2869 INVALID_ARG(arg);
2870 break;
2871 case 'o':
2872 if (asciz_equal(&arg[1],"on-error")) {
2873 if (argptr < argptr_limit)
2874 arg = *argptr++;
2875 else
2876 INVALID_ARG(arg);
2877 if (asciz_equal(arg,"default"))
2878 p2->argv_on_error = ON_ERROR_DEFAULT;
2879 else if (asciz_equal(arg,"debug"))
2880 p2->argv_on_error = ON_ERROR_DEBUG;
2881 else if (asciz_equal(arg,"abort"))
2882 p2->argv_on_error = ON_ERROR_ABORT;
2883 else if (asciz_equal(arg,"appease"))
2884 p2->argv_on_error = ON_ERROR_APPEASE;
2885 else if (asciz_equal(arg,"exit"))
2886 p2->argv_on_error = ON_ERROR_EXIT;
2887 else {
2888 arg_error("invalid `on-error' action",arg);
2889 return 1;
2890 }
2891 } else if (arg[2] == '\0') { /* target for files to be compiled */
2892 OPTION_ARG;
2893 if (!((p2->argv_compile_filecount > 0)
2894 && (p2->argv_compile_files[p2->argv_compile_filecount-1].output_file==NULL)))
2895 INVALID_ARG(arg);
2896 p2->argv_compile_files[p2->argv_compile_filecount-1].output_file = arg;
2897 } else
2898 INVALID_ARG(arg);
2899 break;
2900 case 'p': /* package: when repeated, only the last one counts. */
2901 OPTION_ARG;
2902 p2->argv_package = arg;
2903 break;
2904 case 'a': /* ANSI CL Compliance */
2905 if (asciz_equal(arg,"-ansi"))
2906 p2->argv_ansi = 1; /* ANSI */
2907 else
2908 INVALID_ARG(arg);
2909 break;
2910 case 'x': /* execute LISP-expression */
2911 if (arg[2] != '\0')
2912 INVALID_ARG(arg);
2913 argv_for = for_expr;
2914 break;
2915 case 'w': /* wait for keypress after termination */
2916 p2->argv_wait_keypress = true;
2917 if (arg[2] != '\0')
2918 INVALID_ARG(arg);
2919 break;
2920 case '-': /* -- GNU-style long options */
2921 if (arg[2] == 0) /* "--" ==> end of options */
2922 goto done_with_argv;
2923 else if (asciz_equal(&arg[2],"help")) {
2924 usage(delegating);
2925 return 0;
2926 } else if (asciz_equal(&arg[2],"version")) {
2927 p2->argv_expr_count = 0; /* discard previous -x */
2928 p2->argv_verbose = 1;
2929 p2->argv_norc = true;
2930 p2->argv_repl = false;
2931 p2->argv_exprs[-1-(sintP)(p2->argv_expr_count++)] =
2932 /* FIXME: i18n */
2933 "(PROGN (PRINC \"" PACKAGE_NAME " \")"
2934 "(PRINC (LISP-IMPLEMENTATION-VERSION)) (TERPRI)"
2935 "(PRINC \"Software: \") (PRINC (SOFTWARE-VERSION))"
2936 "(PRINC \" \") (PRINC (SOFTWARE-TYPE)) (TERPRI)"
2937 "(PRINC \"Features: \") (PRINC *FEATURES*) (TERPRI)"
2938 /* Each module should augment *FEATURES*, so this should
2939 not be necessary.
2940 Unfortunately, we have no control over the user code,
2941 thus we cannot enforce this requirement.
2942 Since the "--version" output is used for bug reporting,
2943 we must make it as complete and accurate as possible,
2944 so we prefer to err on the side of verbosity. */
2945 "(PRINC \"C Modules: \") (PRINC (EXT::MODULE-INFO)) (TERPRI)"
2946 "(PRINC \"Installation directory: \")"
2947 "(PRINC (SYS::LIB-DIRECTORY)) (TERPRI)"
2948 "(PRINC \"User language: \")"
2949 "(PRINC (SYS::CURRENT-LANGUAGE)) (TERPRI)"
2950 "(PRINC \"Machine: \") (PRINC (MACHINE-TYPE))"
2951 "(PRINC \" (\") (PRINC (MACHINE-VERSION))"
2952 "(PRINC \") \") (PRINC (MACHINE-INSTANCE)) (TERPRI)"
2953 /*"(PRINC \"Arguments: \") (PRIN1 (EXT::ARGV)) (TERPRI)"*/
2954 "(SYS::%EXIT))";
2955 break;
2956 } else if (asciz_equal(&arg[2],"quiet")
2957 || asciz_equal(&arg[2],"silent")) {
2958 p2->argv_verbose--;
2959 break;
2960 } else if (asciz_equal(&arg[2],"verbose")) {
2961 p2->argv_verbose++;
2962 break;
2963 } else if (asciz_equal(&arg[2],"license")) {
2964 p2->argv_license = true;
2965 break;
2966 } else /* unknown option */
2967 INVALID_ARG(arg);
2968 break;
2969 default: /* unknown option */
2970 INVALID_ARG(arg);
2971 }
2972 } else if (arg[0] == 0) { /* done with the arguments */
2973 done_with_argv:
2974 p2->argv_execute_args = argptr;
2975 p2->argv_execute_arg_count = argptr_limit - argptr;
2976 argptr = argptr_limit; /* abort loop */
2977 } else { /* non option -> interpreted as file to be */
2978 non_option: /* loaded / compiled / executed */
2979 switch (argv_for) {
2980 case for_init:
2981 p2->argv_init_files[p2->argv_init_filecount++] = arg;
2982 break;
2983 case for_compile:
2984 p2->argv_compile_files[p2->argv_compile_filecount].input_file = arg;
2985 p2->argv_compile_files[p2->argv_compile_filecount].output_file = NULL;
2986 p2->argv_compile_filecount++;
2987 break;
2988 case for_exec:
2989 p2->argv_execute_file = arg;
2990 /* All further arguments are arguments for argv_execute_file. */
2991 p2->argv_execute_args = argptr;
2992 p2->argv_execute_arg_count = argptr_limit - argptr;
2993 /* Simulate -norc. Batch scripts should be executed in an
2994 environment which does not depend on files in $HOME, for
2995 maximum portability. */
2996 p2->argv_norc = true;
2997 argptr = argptr_limit; /* abort loop */
2998 break;
2999 case for_expr:
3000 p2->argv_exprs[-1-(sintP)(p2->argv_expr_count++)] = arg;
3001 break;
3002 case for_load_path:
3003 p2->argv_load_paths[-1-(sintP)(p2->argv_load_paths_count)].input_file = arg;
3004 p2->argv_load_paths[-1-(sintP)(p2->argv_load_paths_count++)].output_file = NULL;
3005 break;
3006 default: NOTREACHED;
3007 }
3008 argv_for = for_exec;
3009 }
3010 }
3011 if (clisp_superarg_used) DROP_PRIVILEGES;
3012 p2->argv_batchmode_p = /* '-c' or '-x' or file => batch-mode: */
3013 ((p2->argv_compile || p2->argv_expr_count || p2->argv_execute_file != NULL)
3014 && p2->argv_on_error != ON_ERROR_DEBUG
3015 && p2->argv_on_error != ON_ERROR_APPEASE
3016 && !p2->argv_repl);
3017 /* check options semantically and store defaults: */
3018 if (p1->argv_memneed == 0) {
3019 #if defined(SPVW_MIXED_BLOCKS_OPPOSITE) && defined(GENERATIONAL_GC)
3020 /* Because of GENERATIONAL_GC the memory region is hardly exhausted. */
3021 p1->argv_memneed = 3584*1024*sizeof(gcv_object_t); /* 3584 KW = 14 MB Default */
3022 #else
3023 /* normal */
3024 p1->argv_memneed = 768*1024*sizeof(gcv_object_t); /* 768 KW = 3 MB Default */
3025 #endif
3026 }
3027 if (!p2->argv_compile) {
3028 /* Some options are useful only together with '-c' : */
3029 if (p2->argv_compile_listing) {
3030 arg_error(GETTEXTL("-l without -c is invalid"),NULL);
3031 return 1;
3032 }
3033 } else {
3034 /* Other options are useful only without '-c' : */
3035 if (p2->argv_expr_count) {
3036 arg_error(GETTEXTL("-x with -c is invalid"),NULL);
3037 return 1;
3038 }
3039 }
3040 if (p2->argv_expr_count && p2->argv_execute_file) {
3041 arg_error(GETTEXTL("-x with lisp-file is invalid"),p2->argv_execute_file);
3042 return 1;
3043 }
3044 }
3045 return -1;
3046 }
3047
3048 /* Delete command-line options. */
free_argv_initparams(struct argv_initparams * p)3049 local inline void free_argv_initparams (struct argv_initparams *p) {
3050 unused(p);
3051 }
free_argv_actions(struct argv_actions * p)3052 local inline void free_argv_actions (struct argv_actions *p) {
3053 free(p->argv_init_files);
3054 free(p->argv_compile_files);
3055 }
3056
3057 /* Saving and Loading of MEM-Files */
3058 #include "spvw_memfile.c"
3059
3060 /* Initialize memory and load the specified memory image.
3061 Returns 0 if successful, -1 upon error (after printing an error message
3062 to stderr). */
3063 #if 0
3064 #define VAROUT(v) printf("[%s:%d] %s=%ld\n",__FILE__,__LINE__,STRING(v),v)
3065 #else
3066 #define VAROUT(v)
3067 #endif
init_memory(struct argv_initparams * p)3068 local inline int init_memory (struct argv_initparams *p) {
3069 /* Initialize the table of relocatable pointers: */
3070 {
3071 var object* ptr2 = &pseudofun_tab.pointer[0];
3072 { local const char* pseudocode_name_tab[] = {
3073 #define PSEUDO PSEUDO_F
3074 #include "pseudofun.c"
3075 #undef PSEUDO
3076 };
3077 var const Pseudofun* ptr1 = (const Pseudofun*)&pseudocode_tab;
3078 var const char* const* nameptr = &pseudocode_name_tab[0];
3079 var uintC count = pseudocode_count;
3080 while (count--) {
3081 verify_pseudocode_alignment(*ptr1,*nameptr);
3082 *ptr2++ = make_machine_code(*ptr1); ptr1++; nameptr++;
3083 }
3084 }
3085 { local const char* pseudodata_name_tab[] = {
3086 #define PSEUDO PSEUDO_G
3087 #include "pseudofun.c"
3088 #undef PSEUDO
3089 };
3090 var const Pseudofun* ptr1 = (const Pseudofun*)&pseudodata_tab;
3091 var const char* const* nameptr = &pseudodata_name_tab[0];
3092 var uintC count = pseudodata_count;
3093 while(count--) {
3094 verify_pseudodata_alignment(*ptr1,*nameptr);
3095 *ptr2++ = make_machine(*ptr1); ptr1++; nameptr++;
3096 }
3097 }
3098 }
3099 /* fetch memory: */
3100 begin_system_call();
3101 #if (defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY) || defined(MULTITHREAD)) && (defined(HAVE_MMAP_ANON) || defined(HAVE_MMAP_DEVZERO) || defined(HAVE_MACH_VM) || defined(HAVE_WIN32_VM))
3102 mmap_init_pagesize();
3103 #endif
3104 #if defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY)
3105 init_map_pagesize();
3106 #endif
3107 #if defined(KERNELVOID32A_HEAPCODES) && defined(HAVE_MMAP_ANON)
3108 /* On machines on which the address space extends up to 0xFFFFFFFF,
3109 disable the address range 0xC0000000..0xDFFFFFFF,
3110 so that we can use it for immediate objects. */
3111 mmap((void*)0xC0000000,0x20000000,PROT_NONE,MAP_ANON|MAP_PRIVATE|MAP_FIXED,-1,0);
3112 #endif
3113 #if defined(KERNELVOID32B_HEAPCODES) && defined(HAVE_MMAP_ANON)
3114 /* On machines on which the address space extends up to 0xFFFFFFFF,
3115 disable the address range 0xE0000000..0xFFFFFFFF,
3116 so that we can use it for immediate objects. */
3117 mmap((void*)0xE0000000,0x20000000,PROT_NONE,MAP_ANON|MAP_PRIVATE|MAP_FIXED,-1,0);
3118 #endif
3119 #if (defined(GENERIC64A_HEAPCODES) || defined(GENERIC64B_HEAPCODES)) && defined(HAVE_MMAP_ANON)
3120 /* On machines on which the address space extends up to 0xFFFFFFFFFFFFFFFF,
3121 disable the address range 0xC000000000000000..0xDFFFFFFFFFFFFFFF,
3122 so that we can use it for immediate objects. */
3123 mmap((void*)0xC000000000000000UL,0x2000000000000000UL,PROT_NONE,MAP_ANON|MAP_PRIVATE|MAP_FIXED,-1,0);
3124 #endif
3125 #ifdef SPVW_PURE
3126 init_mem_heaptypes();
3127 init_objsize_table();
3128 #endif
3129 init_modules_0(); /* assemble the list of modules */
3130 end_system_call();
3131
3132 back_trace = NULL;
3133 #ifdef MAP_MEMORY_TABLES
3134 { /* calculate total_subr_count: */
3135 var uintC total = 0;
3136 var module_t* module;
3137 for_modules(all_modules, { total += *module->stab_size; } );
3138 total_subr_count = total;
3139 }
3140 #endif
3141 { /* partitioning of the total memory: */
3142 #define teile 16 /* 16/16 */
3143 #define teile_STACK 2 /* 2/16 */
3144 #ifdef SPVW_MIXED_BLOCKS
3145 #define teile_objects (teile - teile_STACK) /* rest */
3146 #else
3147 #define teile_objects 0
3148 #endif
3149 var uintL pagesize = /* size of a page */
3150 #if defined(GENERATIONAL_GC)
3151 mmap_pagesize
3152 #else /* if the system-pagesize does not play a role */
3153 teile*varobject_alignment
3154 #endif
3155 ;
3156 VAROUT(pagesize);
3157 var uintM memneed = p->argv_memneed; /* needed memory */
3158 VAROUT(memneed);
3159 var aint memblock; /* lower address of the provided memory block */
3160 #if !(defined(SPVW_MIXED_BLOCKS_OPPOSITE) && !defined(TRIVIALMAP_MEMORY))
3161 memneed = teile_STACK*floor(memneed,teile); /* do not yet calculate memory for objects */
3162 VAROUT(memneed);
3163 #undef teile
3164 #define teile teile_STACK
3165 #endif
3166 #if defined(TRIVIALMAP_MEMORY) && defined(WIN32_NATIVE)
3167 /* Somehow the RESERVE_FOR_MALLOC limit for mallocs after prepare_zeromap()
3168 seems also to encompass the mallocs before prepare_zeromap().
3169 Do not know why. */
3170 if (memneed > RESERVE_FOR_MALLOC*3/4) { memneed = RESERVE_FOR_MALLOC*3/4; }
3171 VAROUT(memneed);
3172 #endif
3173 #if (defined(SINGLEMAP_MEMORY) && defined(SINGLEMAP_MEMORY_STACK)) || (defined(TRIVIALMAP_MEMORY) && defined(TRIVIALMAP_MEMORY_STACK))
3174 /* No need to call mymalloc at all. */
3175 memblock = 0;
3176 #else
3177 while (1) {
3178 /* Try to allocate memory. */
3179 memblock = (aint)mymalloc(memneed);
3180 VAROUT(memneed); VAROUT(memblock);
3181 if (!((void*)memblock == NULL)) break; /* successful -> OK */
3182 memneed = floor(memneed,8)*7; /* else try again with 7/8 thereof */
3183 if (memneed == 0) break;
3184 }
3185 if (memneed == 0) {
3186 begin_system_call();
3187 memblock = (aint)malloc(1);
3188 end_system_call();
3189 fprint_mymalloc_diagnostic(stderr,memblock);
3190 fprint(stderr,"\n");
3191 return -1;
3192 }
3193 if (memneed < MINIMUM_SPACE+RESERVE) { /* but with less than MINIMUM_SPACE */
3194 /* we will not be satisfied: */
3195 fprintf(stderr,GETTEXTL("Only %ld bytes available."),memneed);
3196 fprint(stderr,"\n");
3197 return -1;
3198 }
3199 { /* round to the next lower page boundary: */
3200 var uintL unaligned = (uintL)(-memblock) % pagesize;
3201 memblock += unaligned; memneed -= unaligned;
3202 VAROUT(unaligned); VAROUT(memneed);
3203 }
3204 { /* round off to the last page boundary: */
3205 var uintL unaligned = memneed % pagesize;
3206 memneed -= unaligned;
3207 VAROUT(unaligned); VAROUT(memneed);
3208 }
3209 /* the memory region [memblock,memblock+memneed-1] is now free,
3210 and its boundaries are located on page boundaries. */
3211 #endif
3212 #if defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY) /* <==> SPVW_PURE_BLOCKS || TRIVIALMAP_MEMORY */
3213 if ( initmap() <0) return -1;
3214 #ifdef SINGLEMAP_MEMORY
3215 #ifndef IGNORE_MAPPABLE_ADDRESS_RANGE
3216 /* Verify that all heaps lie in the mappable address range. */
3217 {
3218 var uintL heapnr;
3219 for (heapnr=0; heapnr<heapcount; heapnr++) {
3220 if (mem.heaptype[heapnr] >= -1) {
3221 var uintP heap_start_addr = (uintP)(type_zero_oint(heapnr)+SINGLEMAP_ADDRESS_BASE);
3222 var uintP heap_end_addr = (uintP)(type_zero_oint(heapnr+1)+SINGLEMAP_ADDRESS_BASE);
3223 if (!(heap_start_addr >= MAPPABLE_ADDRESS_RANGE_START
3224 && heap_end_addr-1 <= MAPPABLE_ADDRESS_RANGE_END)) {
3225 fprintf(stderr,"Invalid values of SINGLEMAP_ADDRESS_BASE and oint_type_shift: Heap %d = [%p,%p] does not lie in MAPPABLE_ADDRESS_RANGE.\n",
3226 heapnr,(void*)heap_start_addr,(void*)(heap_end_addr-1));
3227 return -1;
3228 }
3229 }
3230 }
3231 }
3232 #endif
3233 /* Pre-initialize all heaps. */
3234 {
3235 var uintL heapnr;
3236 for (heapnr=0; heapnr<heapcount; heapnr++) {
3237 var Heap* heapptr = &mem.heaps[heapnr];
3238 var uintP heap_start_addr = (uintP)(type_zero_oint(heapnr)+SINGLEMAP_ADDRESS_BASE);
3239 var uintP heap_end_addr = (uintP)(type_zero_oint(heapnr+1)+SINGLEMAP_ADDRESS_BASE);
3240 #if defined(UNIX_IRIX) && (defined(MIPS) || defined(MIPS64))
3241 /* Avoid "Warning: reserving address range 0x5f000000...0x5fffffff that contains memory mappings."
3242 and "Warning: reserving address range 0x5e000000...0x5effffff that contains memory mappings." */
3243 if (heap_end_addr == 0x60000000UL || heap_end_addr == 0x5F000000UL) {
3244 heap_end_addr -= 0x800000UL;
3245 }
3246 #endif
3247 heapptr->heap_limit = heap_start_addr;
3248 heapptr->heap_hardlimit = heap_end_addr;
3249 if (mem.heaptype[heapnr] >= -1) {
3250 if (prepare_zeromap(&heapptr->heap_limit,&heapptr->heap_hardlimit,true) <0)
3251 return -1;
3252 }
3253 }
3254 }
3255 /* Set symbol_tab, subr_tab to address SINGLEMAP_ADDRESS_BASE:
3256 (for this purpose case_symbolflagged must be equivalent to case_symbol!) */
3257 #define map_tab(tab,size) \
3258 do { var uintM map_len = round_up(size,map_pagesize); \
3259 if ( zeromap(&tab,map_len) <0) return -1; \
3260 mem.heaps[typecode(as_object((oint)&tab))].heap_limit += map_len; \
3261 } while(0)
3262 map_tab(symbol_tab,sizeof(symbol_tab));
3263 map_tab(subr_tab,varobjects_misaligned+total_subr_count*sizeof(subr_t));
3264 #endif
3265 #ifdef TRIVIALMAP_MEMORY
3266 /* Initialize all heaps as empty.
3267 Obey the MAPPABLE_ADDRESS_RANGE_START and MAPPABLE_ADDRESS_RANGE_END
3268 values, since this is the only way to make mmap with MAP_FIXED work
3269 reliably. */
3270 var uintP start = MAPPABLE_ADDRESS_RANGE_START;
3271 var uintP end = MAPPABLE_ADDRESS_RANGE_END;
3272 if (!(start < end)) {
3273 fprint(stderr,"Invalid values of MAPPABLE_ADDRESS_RANGE_START and MAPPABLE_ADDRESS_RANGE_END\n");
3274 return -1;
3275 }
3276 #if defined(HEAPCODES)
3277 var uintL bit_to_avoid = garcol_bit_o-oint_addr_shift;
3278 /* Distinguish between ONE_FREE_BIT_HEAPCODES and the other HEAPCODES schemes. */
3279 if (bit_to_avoid >= 16) {
3280 /* Modify the range so that its endpoints don't contain bit_to_avoid. */
3281 if (start & bit(bit_to_avoid)) {
3282 start |= bit(bit_to_avoid)-1;
3283 start++;
3284 }
3285 if (end & bit(bit_to_avoid)) {
3286 end &= minus_bit(bit_to_avoid);
3287 end--;
3288 }
3289 if (!(start < end)) {
3290 fprintf(stderr,"Wrong choice of garcol_bit: %d. It is not consistent with MAPPABLE_ADDRESS_RANGE.\n",bit_to_avoid);
3291 return -1;
3292 }
3293 /* Modify the range so that it does not contain addresses with bit_to_avoid
3294 in its interior. */
3295 if (bit_to_avoid < pointer_bitsize-1) {
3296 var uintP difference = (end >> (bit_to_avoid+1)) - (start >> (bit_to_avoid+1));
3297 if (difference > 0) {
3298 if (difference == 1) {
3299 /* Use the larger of the two available intervals. */
3300 var uintP length1 = (start | (bit(bit_to_avoid)-1)) - start;
3301 var uintP length2 = end - (end & minus_bit(bit_to_avoid));
3302 if (length1 >= length2) {
3303 end = start | (bit(bit_to_avoid)-1);
3304 } else {
3305 start = end & minus_bit(bit_to_avoid);
3306 }
3307 } else {
3308 /* The largest available interval has length 2^bit_to_avoid. */
3309 start |= bit(bit_to_avoid+1)-1;
3310 start++;
3311 end = start | (bit(bit_to_avoid)-1);
3312 }
3313 }
3314 }
3315 }
3316 #if defined(KERNELVOID32_HEAPCODES) || defined(GENERIC64A_HEAPCODES) || defined(GENERIC64B_HEAPCODES)
3317 /* Avoid the address range that we reserve for immediate objects. */
3318 #if defined(KERNELVOID32A_HEAPCODES)
3319 var uintP avoid_start = 0xC0000000;
3320 var uintP avoid_end = avoid_start + 0x20000000 - 1;
3321 #endif
3322 #if defined(KERNELVOID32B_HEAPCODES)
3323 var uintP avoid_start = 0xE0000000;
3324 var uintP avoid_end = avoid_start + 0x20000000 - 1;
3325 #endif
3326 #if defined(GENERIC64A_HEAPCODES) || defined(GENERIC64B_HEAPCODES)
3327 var uintP avoid_start = 0xC000000000000000UL;
3328 var uintP avoid_end = avoid_start + 0x2000000000000000UL - 1;
3329 #endif
3330 /* Compute [start,end] \ [avoid_start,avoid_end]. */
3331 if (!(avoid_end < start || end < avoid_start)) {
3332 /* Need to trim the [start,end] interval. */
3333 if (avoid_start <= start) {
3334 if (end <= avoid_end) {
3335 /* [start,end] \ [avoid_start,avoid_end] is empty. */
3336 fprint(stderr,"The range from MAPPABLE_ADDRESS_RANGE_START and MAPPABLE_ADDRESS_RANGE_END is entirely reserved for immediate objects.\n");
3337 return -1;
3338 } else {
3339 /* [start,end] \ [avoid_start,avoid_end] is a single interval
3340 [avoid_end+1,end]. */
3341 start = avoid_end+1;
3342 }
3343 } else {
3344 if (end <= avoid_end) {
3345 /* [start,end] \ [avoid_start,avoid_end] is a single interval
3346 [start,avoid_start-1]. */
3347 end = avoid_start-1;
3348 } else {
3349 /* [start,end] \ [avoid_start,avoid_end] consists of two intervals
3350 [start,avoid_start-1] ∪ [avoid_end+1,end]. Choose the larger one. */
3351 if (avoid_start-start < end-avoid_end)
3352 start = avoid_end+1;
3353 else
3354 end = avoid_start-1;
3355 }
3356 }
3357 }
3358 #endif
3359 #else /* TYPECODES */
3360 /* Verify that the interval [start,end] is covered by oint_addr_mask. */
3361 var uintP range_mask = bits_used_by_range(start,end);
3362 if ((range_mask & ~(oint_addr_mask>>oint_addr_shift)) != 0) {
3363 fprintf(stderr,"Wrong choice of oint_addr_mask: %p. It is not consistent with MAPPABLE_ADDRESS_RANGE's bits: %p.\n",
3364 (void*)(uintP)(oint_addr_mask>>oint_addr_shift),(void*)range_mask);
3365 return -1;
3366 }
3367 #endif
3368 /* Verify that the alignment is guaranteed to be a multiple of physpagesize. */
3369 if (!((0xFFFF & start) == 0)) {
3370 fprintf(stderr,"Misaligned MAPPABLE_ADDRESS_RANGE_START: %p\n",(void*)start);
3371 return -1;
3372 }
3373 if (!((0xFFFF & ~end) == 0)) {
3374 fprintf(stderr,"Misaligned MAPPABLE_ADDRESS_RANGE_END: %p\n",(void*)end);
3375 return -1;
3376 }
3377 #ifdef TRIVIALMAP_MEMORY_STACK
3378 /* Allocate at most 1/8, but at most 100000 words, for the STACK. */
3379 {
3380 var uintP size_for_STACK = (end - start) / 8;
3381 if (size_for_STACK > 100000*sizeof(gcv_object_t)) {
3382 size_for_STACK = 100000*sizeof(gcv_object_t);
3383 }
3384 size_for_STACK &= ~(uintP)0xFFFF; /* start must remain a multiple of physpagesize */
3385 var aint low = start;
3386 start += size_for_STACK;
3387 var aint high = start;
3388 if ( prepare_zeromap(&low,&high,true) <0) return -1;
3389 if ( zeromap((void*)low,size_for_STACK) <0) return -1;
3390 #ifdef STACK_DOWN
3391 STACK_bound = (gcv_object_t*)low + 0x40; /* 64 pointers additionally safety margin */
3392 setSTACK(STACK = (gcv_object_t*)high); /* initialize STACK */
3393 #endif
3394 #ifdef STACK_UP
3395 setSTACK(STACK = (gcv_object_t*)low); /* initialize STACK */
3396 STACK_bound = (gcv_object_t*)high - 0x40; /* 64 pointers additionally safety margin */
3397 #endif
3398 STACK_start = STACK;
3399 }
3400 #undef teile_STACK
3401 #define teile_STACK 0 /* need no more room for the STACK */
3402 #if (teile==0)
3403 #undef teile
3404 #define teile 1 /* avoid division by 0 */
3405 #endif
3406 #endif
3407 #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
3408 mem.heaps[0].heap_limit = start;
3409 mem.heaps[1].heap_limit = end+1;
3410 if ( prepare_zeromap(&mem.heaps[0].heap_limit,&mem.heaps[1].heap_limit,true) <0)
3411 return -1;
3412 #else /* SPVW_MIXED_BLOCKS_STAGGERED */
3413 /* Allocate 2/3 for the varobjects heap, 1/3 for the conses heap. */
3414 var uintP mid = (start / 3) * 2 + (end / 3);
3415 #ifdef GENERATIONAL_GC
3416 mid &= -physpagesize;
3417 #else
3418 mid &= -map_pagesize;
3419 #endif
3420 mem.heaps[0].heap_limit = start;
3421 mem.heaps[0].heap_hardlimit =
3422 mem.heaps[1].heap_limit = mid;
3423 mem.heaps[1].heap_hardlimit = end+1;
3424 if ( prepare_zeromap(&mem.heaps[0].heap_limit,&mem.heaps[1].heap_hardlimit,true) <0)
3425 return -1;
3426 #endif
3427 #endif /* TRIVIALMAP_MEMORY */
3428 { /* initialize all heaps as empty: */
3429 var uintL heapnr;
3430 for (heapnr=0; heapnr<heapcount; heapnr++) {
3431 var Heap* heapptr = &mem.heaps[heapnr];
3432 heapptr->heap_start = heapptr->heap_limit;
3433 #if varobjects_misaligned
3434 if (is_varobject_heap(heapnr)) {
3435 heapptr->heap_start += varobjects_misaligned;
3436 heapptr->heap_limit = heapptr->heap_start;
3437 }
3438 #endif
3439 heapptr->heap_end = heapptr->heap_start;
3440 #ifdef GENERATIONAL_GC
3441 heapptr->heap_gen0_start = heapptr->heap_gen0_end =
3442 heapptr->heap_gen1_start = heapptr->heap_start;
3443 heapptr->physpages = NULL;
3444 #endif
3445 }
3446 }
3447 #ifdef SINGLEMAP_MEMORY_STACK
3448 { /* initialize STACK: */
3449 var uintM map_len = round_up(memneed * teile_STACK/teile, map_pagesize);
3450 /* The stack occupies the interval between 0 and map_len
3451 for typecode = system_type: */
3452 var aint low = (aint)(type_zero_oint(system_type)+SINGLEMAP_ADDRESS_BASE);
3453 var aint high = low + map_len;
3454 #ifndef IGNORE_MAPPABLE_ADDRESS_RANGE
3455 if (!(low >= MAPPABLE_ADDRESS_RANGE_START && high-1 <= MAPPABLE_ADDRESS_RANGE_END)) {
3456 fprint(stderr,"Invalid values of SINGLEMAP_ADDRESS_BASE and oint_type_shift: STACK area does not lie in MAPPABLE_ADDRESS_RANGE.\n");
3457 return -1;
3458 }
3459 #endif
3460 if ( prepare_zeromap(&low,&high,true) <0) return -1;
3461 if ( zeromap((void*)low,map_len) <0) return -1;
3462 #ifdef STACK_DOWN
3463 STACK_bound = (gcv_object_t*)low + 0x40; /* 64 pointers additionally safety margin */
3464 setSTACK(STACK = (gcv_object_t*)high); /* initialize STACK */
3465 #endif
3466 #ifdef STACK_UP
3467 setSTACK(STACK = (gcv_object_t*)low); /* initialize STACK */
3468 STACK_bound = (gcv_object_t*)high - 0x40; /* 64 pointers additionally safety margin */
3469 #endif
3470 STACK_start = STACK;
3471 }
3472 #undef teile_STACK
3473 #define teile_STACK 0 /* need no more room for the STACK */
3474 #if (teile==0)
3475 #undef teile
3476 #define teile 1 /* avoid division by 0 */
3477 #endif
3478 #endif /* SINGLEMAP_MEMORY_STACK */
3479 #endif /* SINGLEMAP_MEMORY || TRIVIALMAP_MEMORY */
3480 #if defined(GENERATIONAL_GC)
3481 init_physpagesize();
3482 #endif
3483 { /* divide memory block: */
3484 var uintM free_reserved; /* number of reserved bytes */
3485 var uintM for_STACK; /* number of bytes for Lisp-stack */
3486 var uintM for_objects; /* number of bytes for Lisp-objects */
3487 /* the STACK needs alignment, because for frame-pointers
3488 the last Bit must be =0: */
3489 #define STACK_alignment bit(addr_shift+1)
3490 #define alignment (varobject_alignment>STACK_alignment ? varobject_alignment : STACK_alignment)
3491 free_reserved = memneed;
3492 /* make divisible by teile*alignment, so that each 1/16 is aligned: */
3493 free_reserved = round_down(free_reserved,teile*alignment);
3494 free_reserved = free_reserved - RESERVE;
3495 {
3496 var uintM teil = free_reserved/teile; /* a sub block, a 1/16 of the room */
3497 var aint ptr = memblock;
3498 mem.MEMBOT = ptr;
3499 #if defined(WIN32_NATIVE) && !defined(NO_SP_CHECK)
3500 /* Even if the NOCOST_SP_CHECK stack overflow detection (using a
3501 guard page) works, we set SP_bound.
3502 Normally, the stack's `AllocationBase' is = 0x30000, the guard
3503 page is 0x32000-0x32FFF, hence we can set SP_bound = 0x34000. */
3504 { var MEMORY_BASIC_INFORMATION info;
3505 if (!(VirtualQuery((void*)SP(),&info,sizeof(info)) == sizeof(info))) {
3506 fprint(stderr,GETTEXTL("Could not determine the end of the SP stack!"));
3507 fprint(stderr,"\n");
3508 SP_bound = 0;
3509 } else { /* 0x4000 might be enough, but 0x8000 will be better. */
3510 SP_bound = (void*)((aint)info.AllocationBase + 0x8000);
3511 }
3512 }
3513 #endif
3514 /* allocate STACK: */
3515 #if defined(SINGLEMAP_MEMORY_STACK) || defined(TRIVIALMAP_MEMORY_STACK)
3516 for_STACK = 0; /* STACK is already allocated elsewhere. */
3517 #else
3518 #ifdef STACK_DOWN
3519 STACK_bound = (gcv_object_t*)ptr + 0x40; /* 64 pointer safety margin */
3520 ptr += for_STACK = teile_STACK*teil; /* 2/16 for Lisp-stack */
3521 setSTACK(STACK = (gcv_object_t*)ptr); /* initialize STACK */
3522 #endif
3523 #ifdef STACK_UP
3524 setSTACK(STACK = (gcv_object_t*)ptr); /* initialize STACK */
3525 ptr += for_STACK = teile_STACK*teil; /* 2/16 for Lisp-stack */
3526 STACK_bound = (gcv_object_t*)ptr - 0x40; /* 64 pointer safety margin */
3527 #endif
3528 STACK_start = STACK;
3529 #endif
3530 #if defined(SPVW_MIXED_BLOCKS_OPPOSITE) && !defined(TRIVIALMAP_MEMORY)
3531 /* now, the lisp-objects start: */
3532 #ifdef GENERATIONAL_GC
3533 mem.varobjects.heap_gen0_start = mem.varobjects.heap_gen0_end =
3534 mem.varobjects.heap_gen1_start = mem.varobjects.heap_start =
3535 ((ptr + (physpagesize-1)) & -physpagesize) + varobjects_misaligned;
3536 #else
3537 mem.varobjects.heap_start = ptr + varobjects_misaligned;
3538 #endif
3539 mem.varobjects.heap_end = mem.varobjects.heap_start; /* there are no objects of variable length, yet */
3540 /* rest (14/16 or a little less) for lisp-objects: */
3541 for_objects = memblock+free_reserved - ptr; /* about = teile_objects*teil */
3542 ptr += for_objects;
3543 #ifdef GENERATIONAL_GC
3544 mem.conses.heap_gen0_start = mem.conses.heap_gen0_end =
3545 mem.conses.heap_gen1_end = mem.conses.heap_end =
3546 ptr & -physpagesize;
3547 #else
3548 mem.conses.heap_end = ptr;
3549 #endif
3550 mem.conses.heap_start = mem.conses.heap_end; /* there are no conses yet */
3551 /* ptr = memblock+free_reserved, because 2/16 + 14/16 = 1
3552 allocate memory reserve: */
3553 ptr += RESERVE;
3554 /* upper memory limit reached. */
3555 mem.MEMTOP = ptr;
3556 /* above (far away) the machine stack. */
3557 #endif
3558 mem.nextgc_trigger_factor = p->argv_nextgc_factor;
3559 #if defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY) || defined(GENERATIONAL_GC)
3560 mem.total_room = 0;
3561 #ifdef GENERATIONAL_GC
3562 mem.last_gcend_space0 = 0;
3563 mem.last_gcend_space1 = 0;
3564 #endif
3565 #endif
3566 #ifdef SPVW_PAGES
3567 for_each_heap(heap, { heap->inuse = EMPTY; } );
3568 for_each_cons_heap(heap, { heap->lastused = dummy_lastused; } );
3569 dummy_lastused->page_room = 0;
3570 for_each_varobject_heap(heap, { heap->misaligned = varobjects_misaligned; } );
3571 for_each_cons_heap(heap, { heap->misaligned = conses_misaligned; } );
3572 mem.free_pages = NULL;
3573 mem.total_space = 0;
3574 mem.used_space = 0;
3575 mem.last_gcend_space = 0;
3576 mem.gctrigger_space = 0;
3577 #endif
3578 /* Verify that the range used for STACK is adequate.
3579 Pointers into the stack are
3580 (1) used as Lisp objects, via make_framepointer, and stored e.g.
3581 in aktenv.var_env,
3582 (2) taken from there, they are also stored in the STACK (in
3583 variable-binding frames), see e.g. make_variable_frame.
3584 Therefore:
3585 - because of (2), the frame_bit_o (= garcol_bit_o) must be zero
3586 in STACK pointers, and
3587 - because of (1), in TYPECODES model, the typecode must be
3588 system_type.
3589 This verification must be consistent with the implementation of
3590 make_framepointer! */
3591 #if !defined(SINGLEMAP_MEMORY_STACK)
3592 var uintP STACK_range_mask = bits_used_by_range((uintP)STACK,(uintP)STACK_bound);
3593 #if defined(TYPECODES) && !defined(WIDE_SOFT)
3594 if ((((oint)(STACK_range_mask >> addr_shift) << oint_addr_shift) & oint_type_mask) != 0) {
3595 fprintf(stderr,"STACK range (around %p) contains some bits that are reserved as type bits (bit mask %p).\n",
3596 (void*)STACK,(void*)((oint_type_mask >> oint_addr_shift) << addr_shift));
3597 return -1;
3598 }
3599 #endif
3600 #if (frame_bit_o >= 16)
3601 if ((((oint)(STACK_range_mask >> addr_shift) << oint_addr_shift) & wbit(frame_bit_o)) != 0) {
3602 fprintf(stderr,"STACK range (around %p) contains the bit used to identify frames (bit %d).\n",
3603 (void*)STACK,(int)(frame_bit_o-oint_addr_shift+addr_shift));
3604 return -1;
3605 }
3606 #endif
3607 #endif
3608 /* initialize stack: */
3609 pushSTACK(nullobj); pushSTACK(nullobj); /* two nullpointer as STACK end marker */
3610 }
3611 }
3612 }
3613 #ifdef DEBUG_SPVW
3614 { /* STACK & SP are settled - check that we have enough STACK */
3615 var uintM stack_size =
3616 STACK_item_count((gcv_object_t*)STACK_bound,STACK);
3617 fprintf(stderr,"STACK size: %lu [0x%lx 0x%lx]\n",stack_size,
3618 (aint)STACK_bound,(aint)STACK);
3619 #ifndef NO_SP_CHECK
3620 if (SP_bound != 0) {
3621 fprintf(stderr,"SP depth: %lu\n",(uintM)
3622 #ifdef SP_UP
3623 ((SPint*)SP_bound - (SPint*)SP())
3624 #else
3625 ((SPint*)SP() - (SPint*)SP_bound)
3626 #endif
3627 );
3628 }
3629 #endif
3630 if (stack_size < ca_limit_1) {
3631 fprintf(stderr,"STACK size is less than CALL-ARGUMENTS-LIMIT (%lu)\n",
3632 (unsigned long)ca_limit_1);
3633 abort();
3634 }
3635 fflush(stderr); /* make sure the debug output comes out first thing */
3636 }
3637 #endif
3638 init_subr_tab_1(); /* initialize subr_tab */
3639 markwatchset = NULL; markwatchset_allocated = markwatchset_size = 0;
3640 #if defined(GENERATIONAL_GC)
3641 /* install Page-Fault-Handler: */
3642 install_segv_handler();
3643 #endif
3644 #if defined(MULTITHREAD)
3645 /* initialize the THREAD:*DEFAULT-VALUE-STACK-SIZE* based on the
3646 calculated STACK size */
3647 Symbol_value(S(default_value_stack_size)) =
3648 uint32_to_I(STACK_item_count(STACK_bound,STACK_start));
3649 #endif
3650 if (p->argv_memfile)
3651 loadmem(p->argv_memfile); /* load memory file */
3652 else if (!loadmem_from_executable())
3653 p->argv_memfile = get_executable_name();
3654 else initmem(); /* manual initialization */
3655 #if defined(MULTITHREAD)
3656 /* clear the list of threads. the one that we have loaded contains
3657 single thread record which is invalid.*/
3658 O(all_threads) = NIL;
3659 /* initialize again THREAD:*DEFAULT-VALUE-STACK-SIZE* based on the
3660 calculated STACK size, since the memory image may change it */
3661 Symbol_value(S(default_value_stack_size)) =
3662 uint32_to_I(STACK_item_count(STACK_bound,STACK_start));
3663 #endif
3664 /* init O(current_language) */
3665 O(current_language) = current_language_o();
3666 /* set current evaluator-environments to the toplevel-value: */
3667 aktenv.var_env = NIL;
3668 aktenv.fun_env = NIL;
3669 aktenv.block_env = NIL;
3670 aktenv.go_env = NIL;
3671 aktenv.decl_env = O(top_decl_env);
3672 /* That's it. */
3673 return 0;
3674 }
3675
3676 /* Output the hash code of the mem file binary interface. */
output_mfih(const uintB mfihash[MFIH_LEN])3677 local void output_mfih (const uintB mfihash[MFIH_LEN])
3678 {
3679 /* Convert to hexadecimal. */
3680 static char hex[16] = {'0','1','2','3','4','5','6','7','8','9','a','b','c','d','e','f'};
3681 var char mfihash_asciz[2*MFIH_LEN+1];
3682 { var const uintB* p = &mfihash[0];
3683 var char* q = mfihash_asciz;
3684 var uintC count;
3685 dotimespC(count,MFIH_LEN, {
3686 var uintB x = *p++;
3687 *q++ = hex[x >> 4];
3688 *q++ = hex[x & 0x0f];
3689 });
3690 *q = '\0';
3691 }
3692 /* Output it. */
3693 printf("%s\n",mfihash_asciz);
3694 }
3695
3696 /* run all functions in the list
3697 can trigger GC */
run_hooks(object hooks)3698 local void maygc run_hooks (object hooks) {
3699 var gcv_object_t* top_of_frame = STACK; /* pointer over frame */
3700 var sp_jmp_buf returner; /* return point */
3701 finish_entry_frame(DRIVER,returner,,goto done_driver_run_hooks;);
3702 pushSTACK(hooks);
3703 while (mconsp(STACK_0)) { /* process */
3704 var object obj = STACK_0;
3705 STACK_0 = Cdr(obj); funcall(Car(obj),0);
3706 }
3707 done_driver_run_hooks:
3708 setSTACK(STACK = top_of_frame); /* drop hooks & skip driver-frame */
3709 }
3710
3711 /* (push arg *args*)
3712 can trigger GC */
push_to_args(const char * s)3713 local void maygc push_to_args(const char *s) {
3714 pushSTACK(asciz_to_string(s,O(misc_encoding)));
3715 var object new_cons = allocate_cons();
3716 Car(new_cons) = popSTACK();
3717 Cdr(new_cons) = Symbol_value(S(args));
3718 Symbol_value(S(args)) = new_cons;
3719 }
3720
3721 /* Perform the main actions as specified by the command-line arguments. */
main_actions(struct argv_actions * p)3722 local inline void main_actions (struct argv_actions *p) {
3723 /* print greeting: */
3724 if (!nullpSv(quiet) /* SYS::*QUIET* /= NIL ? */
3725 || p->argv_execute_file != NULL) { /* batch-mode ? */
3726 /* Prevents the greeting.
3727 One might argue for argv_verbose-- instead of capping it at 1
3728 for the sake of script debugging with "clisp -v -v -v script.lisp".
3729 However, one can debug with "clisp -v -v -v -i script.lisp" even better
3730 because you get the REPL at the end in addition to verbosity. */
3731 if (p->argv_verbose > 1)
3732 p->argv_verbose = 1;
3733 }
3734 if (p->argv_verbose>=2 || p->argv_license)
3735 print_banner();
3736 if (p->argv_license)
3737 print_license();
3738 if (p->argv_execute_arg_count > 0) {
3739 var const char* const* execute_arg_ptr = p->argv_execute_args;
3740 var uintL count = p->argv_execute_arg_count;
3741 do { pushSTACK(asciz_to_string(*execute_arg_ptr++,O(misc_encoding))); }
3742 while (--count);
3743 Symbol_value(S(args)) = listof(p->argv_execute_arg_count);
3744 } else Symbol_value(S(args)) = NIL;
3745 if (p->argv_execute_file != NULL && p->argv_compile) {
3746 push_to_args(p->argv_execute_file); /* compiling: (push exec-file *args*) */
3747 }
3748 if ((p->argv_memfile == NULL) && (p->argv_expr_count == 0)) {
3749 /* warning for beginners */
3750 pushSTACK(var_stream(S(standard_output),strmflags_wr_ch_B)); /* auf *STANDARD-OUTPUT* */
3751 terpri(&STACK_0);
3752 write_sstring(&STACK_0,CLSTEXT("WARNING: No initialization file specified."));
3753 terpri(&STACK_0);
3754 write_sstring(&STACK_0,CLSTEXT("Please try: "));
3755 write_string(&STACK_0,asciz_to_string(program_name,O(pathname_encoding)));
3756 write_string(&STACK_0,ascii_to_string(" -M lispinit.mem\n"));
3757 skipSTACK(1);
3758 }
3759 if (p->argv_lisplibdir == NULL) {
3760 if (nullp(O(lib_dir))) {
3761 /* warning for beginners and careless developers */
3762 pushSTACK(var_stream(S(standard_output),strmflags_wr_ch_B)); /* on *STANDARD-OUTPUT* */
3763 terpri(&STACK_0);
3764 write_sstring(&STACK_0,CLSTEXT("WARNING: No installation directory specified."));
3765 terpri(&STACK_0);
3766 write_sstring(&STACK_0,CLSTEXT("Please try: "));
3767 write_string(&STACK_0,asciz_to_string(program_name,O(pathname_encoding)));
3768 write_string(&STACK_0,ascii_to_string(" -B /usr/local/lib/clisp\n"));
3769 skipSTACK(1);
3770 }
3771 } else { /* set it */
3772 pushSTACK(asciz_to_string(p->argv_lisplibdir,O(pathname_encoding)));
3773 funcall(L(set_lib_directory),1);
3774 }
3775 /* if the options suggest that user input will not be available,
3776 reset *DEBUG-IO* so that READ-CHAR on it results in an immediate EOF
3777 to avoid infinite loops on error. */
3778 if (p->argv_batchmode_p) {
3779 /* (setq *debug-io*
3780 (make-two-way-stream (make-concatenated-stream) *query-io*)) */
3781 funcall(L(make_concatenated_stream),0); /* (MAKE-CONCATENATED-STREAM) */
3782 pushSTACK(value1); /* empty input-stream */
3783 var object stream = var_stream(S(query_io),strmflags_wr_ch_B);
3784 Symbol_value(S(debug_io)) = make_twoway_stream(popSTACK(),stream);
3785 }
3786 if (p->argv_on_error == ON_ERROR_DEFAULT)
3787 p->argv_on_error =
3788 (!p->argv_repl
3789 && (p->argv_compile || p->argv_execute_file || p->argv_expr_count))
3790 ? ON_ERROR_EXIT : ON_ERROR_DEBUG;
3791 install_global_handlers(p->argv_on_error);
3792 switch (p->argv_ansi) {
3793 case 1: /* Maximum ANSI CL compliance */
3794 { pushSTACK(T); funcall(L(set_ansi),1); break; }
3795 case 2: /* The traditional CLISP behavior */
3796 { pushSTACK(NIL); funcall(L(set_ansi),1); break; }
3797 default: /* use the settings from the memory image */
3798 break;
3799 }
3800 if (p->argv_modern) {
3801 /* (IN-PACKAGE "CS-COMMON-LISP-USER") */
3802 Symbol_value(S(packagestar)) = O(modern_user_package);
3803 /* (SETQ *PRINT-CASE* :DOWNCASE) */
3804 Symbol_value(S(print_case)) = S(Kdowncase);
3805 }
3806 if (p->argv_load_compiling) /* (SETQ *LOAD-COMPILING* T) : */
3807 { Symbol_value(S(load_compiling)) = T; }
3808 if (p->argv_verbose < 1) /* (setq *load-verbose* nil *compile-verbose* nil
3809 *saveinitmem-verbose* nil) */
3810 Symbol_value(S(load_verbose)) = Symbol_value(S(compile_verbose)) =
3811 Symbol_value(S(saveinitmem_verbose)) = NIL;
3812 if (p->argv_verbose > 2) /* (setq *load-print* t *compile-print* t
3813 *report-error-print-backtrace* t) */
3814 Symbol_value(S(report_error_print_backtrace)) =
3815 Symbol_value(S(load_print)) = Symbol_value(S(compile_print)) = T;
3816 if (p->argv_verbose > 3) /* (setq *load-echo* t) */
3817 Symbol_value(S(load_echo)) = T;
3818 if (p->argv_developer) { /* developer mode */
3819 /* unlock all packages */
3820 var object packlist = O(all_packages);
3821 while (consp(packlist)) {
3822 mark_pack_unlocked(Car(packlist));
3823 packlist = Cdr(packlist);
3824 }
3825 }
3826 if (p->argv_help_image) { /* -help-image */
3827 if (p->argv_memfile == NULL) return;
3828 pushSTACK(var_stream(S(standard_output),strmflags_wr_ch_B));
3829 if (nullpSv(script))
3830 write_sstring(&STACK_0,CLSTEXT("All positional arguments are put into "));
3831 else
3832 write_sstring(&STACK_0,CLSTEXT("The first positional argument is the script name,\nthe rest are put into "));
3833 prin1(&STACK_0,S(args));
3834 terpri(&STACK_0);
3835 var object image_doc = Symbol_value(S(image_doc));
3836 if (stringp(image_doc))
3837 write_string(&STACK_0,image_doc);
3838 fresh_line(&STACK_0);
3839 skipSTACK(1);
3840 return;
3841 }
3842 /* set *user-lib-directory* */
3843 pushSTACK(ascii_to_string(".clisp/")); pushSTACK(O(user_homedir));
3844 funcall(L(merge_pathnames),2); pushSTACK(value1); /* ~/.clisp/ */
3845 pushSTACK(S(Kerror)); pushSTACK(NIL); /* ignore errors */
3846 funcall(L(probe_pathname),3);
3847 if (pathnamep(value1)
3848 && nullp(ThePathname(value1)->pathname_name)
3849 && nullp(ThePathname(value1)->pathname_type))
3850 /* ~/.clisp/ exists and is a directory */
3851 Symbol_value(S(user_lib_directory)) = value1;
3852 else Symbol_value(S(user_lib_directory)) = NIL;
3853 /* load RC file ~/.clisprc */
3854 if (nullpSv(norc) && !p->argv_norc && p->argv_memfile) {
3855 var gcv_object_t* top_of_frame = STACK; /* pointer over frame */
3856 var sp_jmp_buf returner; /* return point */
3857 finish_entry_frame(DRIVER,returner,,goto done_driver_rc;);
3858 { /* If no memfile is given, LOAD cannot be called with 3 arguments.
3859 (LOAD (MAKE-PATHNAME :NAME ".clisprc"
3860 :DEFAULTS (USER-HOMEDIR-PATHNAME))
3861 :IF-DOES-NOT-EXIST NIL) */
3862 pushSTACK(S(Kname));
3863 pushSTACK(ascii_to_string(".clisprc"));
3864 pushSTACK(S(Kdefaults));
3865 pushSTACK(O(user_homedir)); /* (user-homedir-pathname) */
3866 funcall(L(make_pathname),4);
3867 pushSTACK(value1);
3868 pushSTACK(S(Kif_does_not_exist));
3869 pushSTACK(S(nil));
3870 funcall(S(load),3);
3871 }
3872 done_driver_rc:
3873 setSTACK(STACK = top_of_frame); /* skip driver-frame */
3874 }
3875 /* augment *LOAD-PATHS* from -lp - after loading RC so that setting
3876 *LOAD-PATHS* in ~/.clisprc does not override the command line */
3877 if (p->argv_load_paths_count > 0) {
3878 var const argv_compile_file_t* fileptr = &p->argv_load_paths[-1];
3879 var uintL count = p->argv_load_paths_count;
3880 do { pushSTACK(asciz_to_string((fileptr--)->input_file,O(misc_encoding))); }
3881 while (--count);
3882 pushSTACK(Symbol_value(S(load_paths)));
3883 funcall(L(liststar),p->argv_load_paths_count+1);
3884 Symbol_value(S(load_paths)) = value1;
3885 }
3886 /* execute (LOAD initfile) for each initfile: */
3887 if (p->argv_init_filecount > 0) {
3888 var gcv_object_t* top_of_frame = STACK; /* pointer over frame */
3889 var sp_jmp_buf returner; /* return point */
3890 var const char* const* fileptr = &p->argv_init_files[0];
3891 var uintL count = p->argv_init_filecount;
3892 finish_entry_frame(DRIVER,returner,,goto done_driver_init_files;);
3893 do {
3894 pushSTACK(asciz_to_string(*fileptr++,O(misc_encoding)));
3895 funcall(S(load),1);
3896 } while (--count);
3897 done_driver_init_files:
3898 setSTACK(STACK = top_of_frame); /* skip driver-frame */
3899 }
3900 if (p->argv_compile) {
3901 /* execute
3902 (COMPILE-FILE (setq file (MERGE-PATHNAMES file (MERGE-PATHNAMES #".lisp" (CD))))
3903 [:OUTPUT-FILE (setq output-file (MERGE-PATHNAMES (MERGE-PATHNAMES output-file (MERGE-PATHNAMES #".fas" (CD))) file))]
3904 [:LISTING (MERGE-PATHNAMES #".lis" (or output-file file))])
3905 for each file: */
3906 if (p->argv_compile_filecount > 0) {
3907 var gcv_object_t* top_of_frame = STACK; /* pointer over frame */
3908 var sp_jmp_buf returner; /* return point */
3909 var const argv_compile_file_t* fileptr = &p->argv_compile_files[0];
3910 var uintL count = p->argv_compile_filecount;
3911 finish_entry_frame(DRIVER,returner,,goto done_driver_compile_files;);
3912 do {
3913 var uintC argcount = 1;
3914 var object filename = asciz_to_string(fileptr->input_file,O(misc_encoding));
3915 pushSTACK(filename);
3916 pushSTACK(O(source_file_type)); /* #".lisp" */
3917 funcall(L(cd),0); pushSTACK(value1); /* (CD) */
3918 funcall(L(merge_pathnames),2); /* (MERGE-PATHNAMES '#".lisp" (CD)) */
3919 pushSTACK(value1);
3920 funcall(L(merge_pathnames),2); /* (MERGE-PATHNAMES file ...) */
3921 pushSTACK(value1);
3922 if (fileptr->output_file) {
3923 filename = asciz_to_string(fileptr->output_file,O(misc_encoding));
3924 pushSTACK(S(Koutput_file));
3925 pushSTACK(filename);
3926 pushSTACK(O(compiled_file_type)); /* #".fas" */
3927 funcall(L(cd),0); pushSTACK(value1); /* (CD) */
3928 funcall(L(merge_pathnames),2); /* (MERGE-PATHNAMES '#".fas" (CD)) */
3929 pushSTACK(value1);
3930 funcall(L(merge_pathnames),2); /* (MERGE-PATHNAMES output-file ...) */
3931 pushSTACK(value1);
3932 pushSTACK(STACK_2); /* file */
3933 funcall(L(merge_pathnames),2); /* (MERGE-PATHNAMES ... file) */
3934 pushSTACK(value1);
3935 argcount += 2;
3936 }
3937 if (p->argv_compile_listing) {
3938 pushSTACK(S(Klisting));
3939 pushSTACK(O(listing_file_type)); /* #".lis" */
3940 pushSTACK(STACK_2); /* (or output-file file) */
3941 funcall(L(merge_pathnames),2); /* (MERGE-PATHNAMES '#".lis" ...) */
3942 pushSTACK(value1);
3943 argcount += 2;
3944 }
3945 funcall(S(compile_file),argcount);
3946 fileptr++;
3947 } while (--count);
3948 done_driver_compile_files:
3949 setSTACK(STACK = top_of_frame); /* skip driver-frame */
3950 }
3951 if (!p->argv_repl)
3952 return;
3953 }
3954 if (p->argv_package != NULL) { /* (IN-PACKAGE packagename) */
3955 var object packname = asciz_to_string(p->argv_package,O(misc_encoding));
3956 pushSTACK(packname);
3957 var object package = find_package(packname);
3958 if (!nullp(package)) {
3959 Symbol_value(S(packagestar)) = package;
3960 } else {
3961 pushSTACK(var_stream(S(standard_output),strmflags_wr_ch_B));
3962 terpri(&STACK_0);
3963 write_sstring(&STACK_0,CLSTEXT("WARNING: no such package: "));
3964 write_sstring(&STACK_0,STACK_1);
3965 terpri(&STACK_0);
3966 skipSTACK(1);
3967 }
3968 skipSTACK(1);
3969 }
3970 if (p->argv_execute_file != NULL && !nullpSv(script)) {
3971 var gcv_object_t* top_of_frame = STACK; /* pointer over frame */
3972 var sp_jmp_buf returner; /* return point */
3973 finish_entry_frame(DRIVER,returner,,goto done_driver_execute_file;);
3974 { /* execute:
3975 (PROGN
3976 #+UNIX (SET-DISPATCH-MACRO-CHARACTER #\##\!
3977 (FUNCTION SYS::UNIX-EXECUTABLE-READER))
3978 (SETQ *LOAD-VERBOSE* NIL)
3979 (LOAD argv_execute_file :EXTRA-FILE-TYPES ...)
3980 (UNLESS argv_repl (EXIT))) */
3981 #if defined(UNIX) || defined(WIN32_NATIVE)
3982 /* Make clisp ignore the leading #! line. */
3983 pushSTACK(ascii_char('#')); pushSTACK(ascii_char('!'));
3984 pushSTACK(L(unix_executable_reader));
3985 funcall(L(set_dispatch_macro_character),3);
3986 #endif
3987 Symbol_value(S(load_verbose)) = NIL;
3988 if (asciz_equal(p->argv_execute_file,"-")) {
3989 pushSTACK(Symbol_value(S(standard_input))); /* *STANDARD-INPUT* */
3990 } else {
3991 pushSTACK(asciz_to_string(p->argv_execute_file,O(misc_encoding)));
3992 }
3993 #ifdef WIN32_NATIVE
3994 pushSTACK(S(Kextra_file_types));
3995 pushSTACK(O(load_extra_file_types));
3996 funcall(S(load),3);
3997 #else
3998 funcall(S(load),1);
3999 #endif
4000 }
4001 done_driver_execute_file:
4002 setSTACK(STACK = top_of_frame); /* skip driver-frame */
4003 if (!p->argv_repl)
4004 return;
4005 } else if (p->argv_execute_file) { /* !scripting => (push exec-file *args*) */
4006 push_to_args(p->argv_execute_file);
4007 }
4008 if (p->argv_expr_count) {
4009 /* set *STANDARD-INPUT* to a stream, that produces argv_exprs: */
4010 var const char* const* exprs = &p->argv_exprs[-1];
4011 if (p->argv_expr_count > 1) {
4012 var uintL count = p->argv_expr_count;
4013 do { pushSTACK(asciz_to_string(*exprs--,O(misc_encoding))); }
4014 while (--count);
4015 var object total = string_concat(p->argv_expr_count);
4016 pushSTACK(total);
4017 } else
4018 pushSTACK(asciz_to_string(*exprs--,O(misc_encoding)));
4019 funcall(L(make_string_input_stream),1);
4020 /* During bootstrapping, *DRIVER* has no value and SYS::BATCHMODE-ERRORS
4021 is undefined. Do not set an error handler in that case.
4022 we use SYS::MAIN-LOOP instead of the image-specific user-defined
4023 SYS::*DRIVER* so that the users can always get to the repl using
4024 -x '(saveinitmem ...)'
4025 SYS::MAIN-LOOP calls DRIVER, so we do not need to do
4026 finish_entry_frame(DRIVER,returner,,;);
4027 here */
4028 var object main_loop_function = Symbol_function(S(main_loop));
4029 if (closurep(main_loop_function)) { /* see reploop.lisp:main-loop ! */
4030 dynamic_bind(S(standard_input),value1);
4031 /* (MAIN-LOOP !p->argv_repl) */
4032 pushSTACK(p->argv_repl ? NIL : T);
4033 funcall(main_loop_function,1);
4034 dynamic_unbind(S(standard_input));
4035 } else /* no *DRIVER* => bootstrap, no -repl */
4036 Symbol_value(S(standard_input)) = value1;
4037 }
4038 /* call read-eval-print-loop: */
4039 driver();
4040 }
4041
4042 #if defined(MULTITHREAD)
4043 /* UP: main_actions() replacement in MT.
4044 > param: clisp_thread_t structure of the first lisp thread */
mt_main_actions(void * param)4045 local THREADPROC_SIGNATURE mt_main_actions (void *param)
4046 {
4047 #if USE_CUSTOM_TLS == 2
4048 tse __tse_entry;
4049 tse *__thread_tse_entry=&__tse_entry;
4050 #endif
4051 clisp_thread_t *me=(clisp_thread_t *)param;
4052 /* dummy way to pass arguments :(*/
4053 struct argv_actions *args = (struct argv_actions *)me->_SP_anchor;
4054 set_current_thread(me); /* initialize TLS */
4055 me->_SP_anchor=(void*)SP();
4056 /* reinitialize the system thread id */
4057 TheThread(me->_lthread)->xth_system = xthread_self();
4058 /* initialize thread special varaible bindings */
4059 pushSTACK(Symbol_value(S(default_special_bindings)));
4060 initialize_thread_bindings(&STACK_0);
4061 skipSTACK(1);
4062 /* create a CATCH frame here for thread exit */
4063 pushSTACK(O(thread_exit_tag));
4064 var gcv_object_t* top_of_frame = STACK STACKop 1;
4065 var sp_jmp_buf returner; /* return point */
4066 finish_entry_frame(CATCH,returner,,{
4067 skipSTACK(2); STACK_0=value1; goto thread_killed;});
4068 init_time(); /* initialize thread time variables */
4069 init_reader_low(me); /* initialize the low level i/o for this thread*/
4070 /* now we are ready to start main_actions()*/
4071 main_actions(args);
4072 skipSTACK(3); /* unwind CATCH-frame */
4073 mv_to_list(); /* store thread exit values on STACK */
4074 /* mark that thread will exit normally */
4075 TheThread(me->_lthread)->xth_flags |= thread_flag_normal_exit;
4076 thread_killed:
4077 thread_cleanup();
4078 delete_thread(me); /* just delete ourselves */
4079 /* NB: the LISP stack is "leaked" - in a sense nobody will
4080 ever use it anymore !!!*/
4081 xthread_exit(0);
4082 return NULL; /* keep compiler happy */
4083 }
4084 #endif
4085
4086 static struct argv_initparams argv1;
4087 static struct argv_actions argv2;
4088
4089 /* main program stores the name 'main'. */
4090 #ifndef argc_t
4091 #define argc_t int /* Type of argc is mostly 'int'. */
4092 #endif
main(argc_t argc,char * argv[])4093 global int main (argc_t argc, char* argv[]) {
4094 /* initialization of memory management.
4095 overall procedure:
4096 process command-line-options.
4097 determine memory partitioning.
4098 look at command string and either load LISP-data from .MEM-file
4099 or create manually and initialize static LISP-data.
4100 build up interrupt-handler.
4101 print banner.
4102 jump into the driver.
4103 This is also described in <doc/impext.xml#cradle-grave>! */
4104 #if defined(MULTITHREAD)
4105 /* if on 32 bit machine, no per_thread and asked by the user*/
4106 #if USE_CUSTOM_TLS == 2
4107 tse __tse_entry;
4108 tse *__thread_tse_entry=&__tse_entry;
4109 #endif
4110 /* initialize main thread */
4111 {
4112 init_multithread();
4113 init_heaps_mt();
4114 set_current_thread(create_thread(0));
4115 #ifdef DEBUG_GCSAFETY
4116 use_dummy_alloccount=false; /* now we have threads */
4117 current_thread()->_alloccount=1;
4118 #endif
4119 }
4120 #endif
4121 init_lowest_level(argv);
4122 init_stream_osdeps();
4123 var struct argv_init_c argv0;
4124 {
4125 var int parse_result =
4126 parse_options(argc,(const char**)argv,&argv0,&argv1,&argv2);
4127 if (parse_result >= 0)
4128 quit_instantly(parse_result);
4129 }
4130 /* The argv_* variables now have their final values.
4131 Analyze the environment variables determining the locale.
4132 Deal with LC_CTYPE. */
4133 init_ctype();
4134 /* Deal with LC_MESSAGE.
4135 (This must come last, because it may unset environment variable LC_ALL) */
4136 #ifdef GNU_GETTEXT
4137 init_language(argv0.argv_language,argv0.argv_localedir,false);
4138 #endif
4139
4140 /* Initialize memory and load a memory image (if specified). */
4141 if (init_memory(&argv1) < 0) goto no_mem;
4142 switch (argv2.argv_main_action) {
4143 case action_mfihash:
4144 { var uintB mfihash[MFIH_LEN];
4145 get_mem_file_interface_hash(&mfihash[0]);
4146 output_mfih(&mfihash[0]);
4147 return 0;
4148 }
4149 case action_mfihash_of:
4150 { var uintB mfihash[MFIH_LEN];
4151 extract_mem_file_interface_hash(&mfihash[0],argv2.argv_memfile);
4152 output_mfih(&mfihash[0]);
4153 return 0;
4154 }
4155 case action_mfcompat:
4156 { var bool compatible = is_mem_file_compatible(argv2.argv_memfile);
4157 return (compatible ? 0 : 1);
4158 }
4159 default: ;
4160 }
4161 SP_anchor = (void*)SP(); /* VTZ: in MT current_thread() should be initialized */
4162 #if defined(MULTITHREAD)
4163 /* after heap is initialized - allocate thread record for main thread.
4164 no locking is needed here*/
4165 {
4166 /* VTZ:TODO when we are loaded from mem file - we should restore the
4167 threads from there.
4168 Currently we just register our main thread and do not care what we have in
4169 mem file!!! Threads do not survive mem file save/restore - just create
4170 garbage in it :( */
4171 /* TODO: give better name :)*/
4172 var object thr_name = coerce_imm_ss(ascii_to_string(GETTEXT("main thread")));
4173 pushSTACK(thr_name);
4174 pushSTACK(allocate_thread(&STACK_0));
4175 var object new_cons=allocate_cons();
4176 var object lthr;
4177 /* add to all_threads global */
4178 Car(new_cons) = lthr = popSTACK();
4179 Cdr(new_cons) = O(all_threads);
4180 O(all_threads) = new_cons;
4181 /* initialize the thread references */
4182 current_thread()->_lthread=lthr;
4183 TheThread(lthr)->xth_globals=current_thread();
4184 TheThread(lthr)->xth_system=xthread_self();
4185 skipSTACK(1);
4186 }
4187 #endif
4188 /* if the image was read from the executable, argv1.argv_memfile was
4189 set to exec name and now it has to be propagated to argv2.argv_memfile
4190 to avoid the beginner warning */
4191 argv2.argv_memfile = argv1.argv_memfile; /* propagate exec name */
4192 /* Prepare for catching SP overflow. */
4193 install_stackoverflow_handler(0x4000); /* 16 KB reserve should be enough */
4194 /* everything completely initialized. */
4195 {var struct backtrace_t bt;
4196 bt.bt_next = NULL;
4197 bt.bt_function = L(driver);
4198 bt.bt_stack = STACK STACKop -1;
4199 bt.bt_num_arg = -1;
4200 back_trace = &bt;
4201 clear_break_sems(); set_break_sem_1();
4202 begin_system_call();
4203
4204 #if defined(WIN32_NATIVE)
4205 /* cannot do it in init_win32 - too early */
4206 if (isatty(stdout_handle)) {
4207 var HANDLE handle = GetStdHandle(STD_OUTPUT_HANDLE);
4208 if (handle!=INVALID_HANDLE_VALUE) {
4209 var CONSOLE_SCREEN_BUFFER_INFO info;
4210 if (GetConsoleScreenBufferInfo(handle,&info))
4211 Symbol_value(S(prin_linelength)) = fixnum(info.dwSize.X - 1);
4212 }
4213 }
4214 #endif
4215 /* Establish signal handler for SIGWINCH and query the size of the
4216 terminal window also now on program start: */
4217 #if defined(HAVE_SIGNALS)
4218 #if defined(SIGWINCH) && !defined(NO_ASYNC_INTERRUPTS) && !defined(MULTITHREAD)
4219 install_sigwinch_handler();
4220 #endif
4221 update_linelength();
4222 #endif
4223 /* handling of async interrupts with single thread */
4224 #if !defined(MULTITHREAD)
4225 /* establish interrupt-handler: */
4226 #if (defined(HAVE_SIGNALS) && defined(UNIX)) || defined(WIN32_NATIVE)
4227 /* install Ctrl-C-Handler: */
4228 install_sigint_handler();
4229 #endif
4230 #ifdef HAVE_SIGNALS
4231 install_sigcld_handler();
4232 install_sigterm_handler(); /* install SIGTERM &c handlers */
4233 #endif
4234 #else
4235 #ifdef HAVE_SIGNALS
4236 install_sigcld_handler();
4237 #endif
4238 install_async_signal_handlers();
4239 #endif
4240 #if defined(HAVE_SIGNALS) && defined(SIGPIPE)
4241 install_sigpipe_handler();
4242 #endif
4243 /* initialize global time variables: */
4244 init_time();
4245 /* Initialize locale dependent encodings: */
4246 init_dependent_encodings();
4247 /* initialize stream-variables: */
4248 init_streamvars(argv2.argv_batchmode_p);
4249 INIT_READER_LOW(); /* token buffers */
4250 #ifdef MULTITHREAD
4251 /* now we can initialize all per thread special variables. till now
4252 we did this in initmem() and we missed the streams specials. */
4253 /* NB: currently *FEATURES* is not treated differently */
4254 if (num_symvalues == FIRST_SYMVALUE_INDEX) {
4255 /* only if we did not already loaded from image */
4256 init_multithread_special_symbols();
4257 }
4258 #endif
4259 /* make break possible: */
4260 end_system_call();
4261 clr_break_sem_1();
4262 /* initialize pathnames: */
4263 init_pathnames();
4264 #ifdef DYNAMIC_FFI
4265 /* initialize FFI: */
4266 init_ffi();
4267 #endif
4268 init_other_modules_2(); /* initialize modules yet uninitialized */
4269 { /* final module initializations: */
4270 var module_t* module; /* loop over modules */
4271 for_modules(all_other_modules,{
4272 if (module->initfunction2)
4273 /* call initialization function: */
4274 (*module->initfunction2)(module);
4275 });
4276 }
4277 /* do this before O(argv) is ready so that applications cannot
4278 detect and thus disable "--clisp-" superarg
4279 http://clisp.org/impnotes/image.html#image-exec */
4280 run_hooks(Symbol_value(S(init_hooks)));
4281 { /* Init O(argv). */
4282 O(argv) = allocate_vector(argc);
4283 var argc_t count;
4284 for (count = 0; count < argc; count++) {
4285 var object arg = asciz_to_string(argv[count],O(misc_encoding));
4286 TheSvector(O(argv))->data[count] = arg;
4287 }
4288 }
4289 /* Perform the desired actions (compilations, read-eval-print loop etc.): */
4290 #if defined(MULTITHREAD)
4291 /* may be set it as command line parameter - it should be big enough */
4292 #define MAIN_THREAD_C_STACK (1024*1024*16)
4293 SP_anchor=(void *)&argv2;
4294 {
4295 var xthread_t thr;
4296 var clisp_thread_t *param = current_thread();
4297 /* Remove the current thread from threads map */
4298 #if USE_CUSTOM_TLS == 3
4299 /* Since initial thread stack is growable (at least on linux), the
4300 stack range mapped when thread was registered is maximum possible one.
4301 Now pthread_attr_getstack will return (most probably) different range
4302 (smaller) and if we try to unmap it - there will be some mappings left.
4303 This is not a problem in general but it helps for debugging to clear
4304 the whole map.*/
4305 memset(threads_map, 0, sizeof(threads_map));
4306 #elif USE_CUSTOM_TLS == 2
4307 /* we can use set_current_thread(NULL) as well but this will leave
4308 a dummy bucket in the hash table and may slow down the lookups.
4309 better - remove entirely */
4310 tsd_remove_specific();
4311 #else
4312 set_current_thread(NULL); /* no associated lisp thread */
4313 #endif
4314 xthread_create(&thr, mt_main_actions, param, MAIN_THREAD_C_STACK);
4315 }
4316 thr_signal_handler = xthread_self();
4317 /* let's handle signals now :)*/
4318 signal_handler_thread(0);
4319 /* NOTREACHED */
4320 #else
4321 main_actions(&argv2);
4322 quit();
4323 #endif
4324 /*NOTREACHED*/
4325 } /* end var bt */
4326 /* if the memory does not suffice: */
4327 no_mem:
4328 fprintf(stderr,GETTEXTL("%s: Not enough memory for Lisp."),program_name);
4329 fprint(stderr,"\n");
4330 quit_instantly(1);
4331 /*NOTREACHED*/
4332 /* termination of program via quit_instantly(): */
4333 return 0; /* we should never reach here anyway */
4334 }
4335
4336 /* UP: leave LISP immediately: quit_instantly(exitcode);
4337 > exitcode: 0 for normal, 1 for abnormal end of program, -signum for signal
4338 we must set the SP to the original value.
4339 (On some operating systems, the memory occupied by the program is
4340 returned with free() , before control is withdrawn from it.
4341 For this short span the SP has to be set reasonably.)
4342 In threads builds it is not good to make longjmp() across
4343 threads. Since argv1 and argv2 are global now - it's ok to
4344 have quit_instantly() as function */
quit_instantly(int exitcode)4345 local _Noreturn void quit_instantly (int exitcode)
4346 {
4347 free_argv_initparams(&argv1);
4348 free_argv_actions(&argv2);
4349 fini_lowest_level();
4350 if (exitcode < 0) {
4351 var int sig = -exitcode;
4352 #ifdef HAVE_SIGNALS
4353 /* Reset the signal handler. */
4354 SIGNAL(sig,SIG_DFL);
4355 /* Unblock the signal. */
4356 #if defined(SIGNALBLOCK_POSIX)
4357 {
4358 var sigset_t sigblock_mask;
4359 sigemptyset(&sigblock_mask); sigaddset(&sigblock_mask,sig);
4360 sigprocmask(SIG_UNBLOCK,&sigblock_mask,NULL);
4361 }
4362 #endif
4363 /* Raise the signal. */
4364 raise(sig);
4365 #endif
4366 /* If that did not help: use a fake exit code that encodes the signal. */
4367 exitcode = 128 + sig;
4368 }
4369 #ifdef UNIX
4370 exit(exitcode); /* Calling exit(), not _exit(), allows profiling to work. */
4371 #endif
4372 #ifdef WIN32_NATIVE
4373 _exit(exitcode);
4374 #endif
4375 }
4376
4377 /* leave LISP-interpreter
4378 quit();
4379 > final_exitcode: 0 for normal, 1 for abnormal end of program, -signum for signal */
4380 global int final_exitcode = 0;
4381 global bool quit_on_signal_in_progress = false;
4382 local int quit_retry = 0;
quit(void)4383 global _GL_NORETURN_FUNC void quit (void) {
4384 /* first "unwind" the STACK downto STACK-end: */
4385 VALUES0; /* do not save values for UNWIND-PROTECT-frames */
4386 unwind_protect_to_save.fun = (restartf_t)&quit;
4387 while (!(eq(STACK_0,nullobj) && eq(STACK_1,nullobj)))
4388 if (framecode(STACK_0) & bit(frame_bit_t))
4389 /* At STACK_0 a frame starts */
4390 { unwind(); } /* unwind frame */
4391 else
4392 /* STACK_0 contains a normal LISP-object */
4393 { skipSTACK(1); }
4394 run_hooks(Symbol_value(S(fini_hooks)));
4395 /* Then, a farewell message: */
4396 if (quit_retry==0) {
4397 quit_retry++; /* If this fails, do not retry it. For robustness. */
4398 /* when running as a script, i.e. "clisp lisp-file",
4399 *standard-input* is /dev/fd/0
4400 *standard-output* is /dev/fd/1
4401 *error-output* is /dev/fd/2
4402 and *terminal-io* is an #<IO TERMINAL-STREAM>,
4403 so they all need to be terminated individually */
4404 funcall(L(fresh_line),0); /* (FRESH-LINE [*standard-output*]) */
4405 funcall(L(finish_output),0); /* (FINISH-OUTPUT [*standard-output*]) */
4406 pushSTACK(var_stream(S(error_output),strmflags_wr_ch_B));pushSTACK(STACK_0);
4407 funcall(L(fresh_line),1); /* (FRESH-LINE *error-output*) */
4408 funcall(L(finish_output),1); /* (FINISH-OUTPUT *error-output*) */
4409 pushSTACK(Symbol_value(S(terminal_io))); pushSTACK(STACK_0);
4410 funcall(L(fresh_line),1); /* (FRESH-LINE *terminal-io*) */
4411 funcall(L(finish_output),1); /* (FINISH-OUTPUT *terminal-io*) */
4412 if (argv2.argv_verbose >= 2) {
4413 pushSTACK(CLSTEXT("Bye.")); funcall(L(write_line),1);
4414 }
4415 }
4416 /* Then wait for a keypress: */
4417 if (argv2.argv_wait_keypress) {
4418 argv2.argv_wait_keypress = false; /* If this fails, do not retry it (robustness) */
4419 pushSTACK(CLSTEXT("Press a key to terminate..."));
4420 funcall(L(write_line),1);
4421 funcall(S(wait_keypress),0); /* (SYS::WAIT-KEYPRESS) */
4422 }
4423 close_all_files(); /* close all files */
4424 { /* module finalization: */
4425 var module_t* module; /* loop over modules */
4426 for_modules(all_other_modules,{
4427 if (module->finifunction) /* call exit function: */
4428 (*module->finifunction)(module);
4429 });
4430 }
4431 #ifdef DYNAMIC_FFI
4432 exit_ffi(); /* close FFI */
4433 #endif
4434 quit_instantly(final_exitcode); /* leave program */
4435 }
4436
4437 /* ------------------------ dll loading ----------------------------------- */
4438 #if defined(WIN32_NATIVE) || defined(HAVE_DLOPEN)
4439
4440 #if defined(HAVE_DLFCN_H)
4441 #include <dlfcn.h>
4442 #endif
4443
4444 /* open the dynamic library
4445 libname is the name of the library
4446 returns a handle suitable for find_name()
4447 calls dlopen() or LoadLibrary() */
libopen(const char * libname)4448 global void * libopen (const char* libname)
4449 {
4450 #if defined(WIN32_NATIVE)
4451 return (void*)LoadLibrary(libname);
4452 #else
4453 /* FIXME: On UNIX_MACOSX, need to search for the library in /usr/lib */
4454 return dlopen(libname,RTLD_NOW|RTLD_GLOBAL);
4455 #endif
4456 }
4457
4458 #if defined(WIN32_NATIVE)
4459 /* #include <psapi.h> */
4460 /* support older woe32 incarnations:
4461 fEnumProcessModules is 1 until the first call,
4462 it is NULL if this woe32 does not have EnumProcessModules(),
4463 and it points to EnumProcessModules() when it is present */
4464 typedef BOOL (WINAPI * EnumProcessModules_t)
4465 (HANDLE hProcess,HMODULE* lphModule,DWORD cb,LPDWORD lpcbNeeded);
4466 static EnumProcessModules_t fEnumProcessModules = (EnumProcessModules_t)1;
4467 #endif
4468
4469 /* find the name in the dynamic library handle
4470 calls dlsym() or GetProcAddress()
4471 handle is an object returned by libopen()
4472 or NULL, which means emulate RTLD_DEFAULT on older FreeBSD and AIX
4473 and WIN32_NATIVE by searching through all libraries
4474 name is the name of the function (or variable) in the library */
find_name(void * handle,const char * name)4475 global void* find_name (void *handle, const char *name)
4476 {
4477 var void *ret = NULL;
4478 #if defined(WIN32_NATIVE)
4479 if (handle == NULL) { /* RTLD_DEFAULT -- search all modules */
4480 HANDLE cur_proc;
4481 HMODULE *modules;
4482 DWORD needed, i;
4483 if ((EnumProcessModules_t)1 == fEnumProcessModules) {
4484 /* first call: try to load EnumProcessModules */
4485 HMODULE psapi = LoadLibrary("psapi.dll");
4486 if (psapi == NULL) fEnumProcessModules = NULL;
4487 else fEnumProcessModules =
4488 (EnumProcessModules_t)GetProcAddress(psapi,"EnumProcessModules");
4489 }
4490 if (NULL != fEnumProcessModules) {
4491 cur_proc = GetCurrentProcess();
4492 if (!fEnumProcessModules(cur_proc,NULL,0,&needed)) OS_error();
4493 var DYNAMIC_ARRAY(modules_mem,char,needed);
4494 modules = (HMODULE*)modules_mem;
4495 if (!fEnumProcessModules(cur_proc,modules,needed,&needed)) OS_error();
4496 for (i=0; i < needed/sizeof(HMODULE); i++)
4497 if ((ret = (void*)GetProcAddress(modules[i],name)))
4498 break;
4499 FREE_DYNAMIC_ARRAY(modules_mem);
4500 }
4501 } else ret = (void*)GetProcAddress((HMODULE)handle,name);
4502 #elif !defined(RTLD_DEFAULT)
4503 /* FreeBSD 4.0 and AIX 5.1 do not support RTLD_DEFAULT, so we emulate it by
4504 searching the executable and the libc. */
4505 if (handle == NULL) {
4506 /* Search the executable. */
4507 ret = dlsym(NULL,name);
4508 if (ret == NULL) {
4509 /* Search the libc. */
4510 static void* libc_handle;
4511 if (libc_handle == NULL)
4512 libc_handle = dlopen("libc.so",RTLD_LAZY);
4513 if (libc_handle != NULL)
4514 ret = dlsym(libc_handle,name);
4515 }
4516 } else
4517 ret = dlsym(handle,name);
4518 #else
4519 ret = dlsym(handle,name);
4520 #endif
4521 return ret;
4522 }
4523
4524 #endif /* defined(WIN32_NATIVE) || defined(HAVE_DLOPEN) */
4525
4526 /* --------------------------------------------------------------------------
4527 Dynamic Loading of Modules */
4528
4529 #ifdef DYNAMIC_MODULES
4530
4531 /* Attaches a shared library to this process' memory, and attempts to load
4532 a number of clisp modules from it. */
error_dlerror(const char * func,const char * symbol,object errstring)4533 local _Noreturn void error_dlerror (const char* func, const char* symbol,
4534 object errstring) {
4535 end_system_call();
4536 pushSTACK(errstring);
4537 if (symbol != NULL)
4538 pushSTACK(asciz_to_string(symbol,O(internal_encoding)));
4539 pushSTACK(asciz_to_string(func,O(internal_encoding)));
4540 pushSTACK(TheSubr(subr_self)->name);
4541 error(error_condition,(symbol == NULL ? "~S: ~S -> ~S" : "~S: ~S(~S) -> ~S"));
4542 }
4543
dlerror_message(void)4544 local object dlerror_message (void) {
4545 end_system_call();
4546 #if defined(HAVE_DLERROR)
4547 var char * e = dlerror();
4548 /* g++ needs explicit cast here */
4549 return e == NULL ? (object)O(unknown_error) : asciz_to_string(e,O(misc_encoding));
4550 #elif defined(WIN32_NATIVE)
4551 var char* buf;
4552 /* note that this message is likely to be less informative
4553 than the pop-up error window enabled by SetErrorMode(0);
4554 http://groups.google.com/group/microsoft.public.win32.programmer.kernel/browse_thread/thread/e720d92269df1398/b2381f02f3bfc8a3 */
4555 FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM
4556 | FORMAT_MESSAGE_IGNORE_INSERTS,
4557 NULL, GetLastError(), 0, (char*)&buf, 0, NULL);
4558 var object ret = asciz_to_string(buf,O(misc_encoding));
4559 LocalFree(buf);
4560 return ret;
4561 #else
4562 return O(unknown_error);
4563 #endif
4564 }
4565
4566 /* find the symbol, signal an error if not found
4567 format: a format string with a single %s, substituted with ...
4568 modname: the name of the module
4569 libhandle: the dll handle, returned by libopen()
4570 returns: non-NULL pointer to the symbol in the library */
get_module_symbol(const char * format,const char * modname,void * libhandle)4571 local void* get_module_symbol (const char* format, const char* modname,
4572 void* libhandle) {
4573 var DYNAMIC_ARRAY(symbolbuf,char,strlen(format)+strlen(modname));
4574 sprintf(symbolbuf,format,modname);
4575 var void * ret = find_name(libhandle,symbolbuf);
4576 if (ret == NULL) error_dlerror("dlsym",symbolbuf,dlerror_message());
4577 FREE_DYNAMIC_ARRAY(symbolbuf);
4578 return ret;
4579 }
4580
dynload_modules(const char * library,uintC modcount,const char * const * modnames)4581 global maygc void dynload_modules (const char * library, uintC modcount,
4582 const char * const * modnames) {
4583 var void* libhandle;
4584 /* Open the library. */
4585 begin_blocking_system_call();
4586 libhandle = libopen(library);
4587 end_blocking_system_call();
4588 if (libhandle == NULL) error_dlerror("dlopen",NULL,dlerror_message());
4589 if (modcount > 0) {
4590 /* What's the longest module name? What's their total size? */
4591 var uintL total_modname_length = 0;
4592 begin_system_call();
4593 {
4594 var const char * const * modnameptr = modnames;
4595 var uintC count = modcount;
4596 do {
4597 var uintL len = asciz_length(*modnameptr);
4598 total_modname_length += len+1;
4599 modnameptr++;
4600 } while (--count);
4601 }
4602 { /* Make room for the module descriptors. */
4603 var module_t* modules = (module_t*)clisp_malloc(modcount*sizeof(module_t)+total_modname_length);
4604 {
4605 var char* modnamebuf = (char*)(&modules[modcount]);
4606 var const char * const * modnameptr = modnames;
4607 var module_t* module = modules;
4608 var uintC count = modcount;
4609 do {
4610 var const char * modname = *modnameptr;
4611 var uintL len = asciz_length(modname);
4612 var const char * err;
4613 /* Copy modname into modnamebuf: */
4614 module->name = modnamebuf;
4615 {
4616 var const char * ptr = modname;
4617 while ((*modnamebuf++ = *ptr++) != '\0') {}
4618 }
4619 /* Find the addresses of some C data in the shared library: */
4620 module->stab = (subr_t*) ((char*) get_module_symbol("module__%s__subr_tab",modname,libhandle) + varobjects_misaligned);
4621 module->stab_size = (const uintC*) get_module_symbol("module__%s__subr_tab_size",modname,libhandle);
4622 module->otab = (gcv_object_t*) get_module_symbol("module__%s__object_tab",modname,libhandle);
4623 module->otab_size = (const uintC*) get_module_symbol("module__%s__object_tab_size",modname,libhandle);
4624 module->initialized = false;
4625 module->stab_initdata = (const subr_initdata_t*) get_module_symbol("module__%s__subr_tab_initdata",modname,libhandle);
4626 module->otab_initdata = (const object_initdata_t*) get_module_symbol("module__%s__object_tab_initdata",modname,libhandle);
4627 /* Find the addresses of some C functions in the shared library: */
4628 module->initfunction1 = (void (*) (module_t*)) get_module_symbol("module__%s__init_function_1",modname,libhandle);
4629 module->initfunction2 = (void (*) (module_t*)) get_module_symbol("module__%s__init_function_2",modname,libhandle);
4630 module->finifunction = (void (*) (module_t*)) get_module_symbol("module__%s__fini_function",modname,libhandle);
4631 module->next = NULL;
4632 modnameptr++; module++;
4633 } while (--count);
4634 }
4635 end_system_call();
4636 { /* We found all the necessary symbols. Now register the modules. */
4637 var module_t* module = modules;
4638 var uintC mcount = modcount;
4639 while (mcount-- > 0) {
4640 add_module(module);
4641 /* pre-initialization, cf. init_subr_tab_1. */
4642 if (*module->stab_size > 0) module_set_argtypes(module);
4643 #if defined(SINGLEMAP_MEMORY) && defined(MAP_MEMORY_TABLES)
4644 {
4645 var subr_t* newptr = (subr_t*)((char*)&subr_tab+varobjects_misaligned) + total_subr_count;
4646 var uintC count = *module->stab_size;
4647 if (count > 0) {
4648 {
4649 var uintM old_map_len = round_up(varobjects_misaligned+total_subr_count*sizeof(subr_t),map_pagesize);
4650 var uintM new_map_len = round_up(varobjects_misaligned+(total_subr_count+count)*sizeof(subr_t),map_pagesize);
4651 if (old_map_len < new_map_len) {
4652 if (zeromap((void*)((aint)&subr_tab+old_map_len),new_map_len-old_map_len) <0)
4653 error_dlerror("zeromap",NULL,O(oomst_error));
4654 }
4655 }
4656 {
4657 var subr_t* oldptr = module->stab;
4658 module->stab = newptr;
4659 do {
4660 *newptr = *oldptr++;
4661 newptr->GCself = subr_tab_ptr_as_object(newptr);
4662 newptr->name = NIL; newptr->keywords = NIL; /* GC stays possible with it */
4663 newptr++;
4664 } while (--count);
4665 }
4666 total_subr_count += *module->stab_size;
4667 }
4668 }
4669 #endif
4670 /* main initialization. */
4671 init_module_2(module);
4672 module++;
4673 }
4674 }
4675 { /* Now start the modules' life. */
4676 var module_t* module = modules;
4677 var uintC count = modcount;
4678 do {
4679 if (module->initfunction2) /* call initialization function: */
4680 (*module->initfunction2)(module);
4681 module++;
4682 } while (--count);
4683 }
4684 }
4685 }
4686 }
4687
4688 #endif
4689
4690 /* --------------------------------------------------------------------------
4691 Multithreading signal handling */
4692 #if defined(MULTITHREAD)
4693 /* UP: acquires both heap and threads lock from signal handler thread
4694 without causing deadlock with the GC in the lisp world. */
lock_heap_from_signal()4695 local void lock_heap_from_signal()
4696 {
4697 while (1) {
4698 while (!spinlock_tryacquire(&mem.alloc_lock))
4699 xthread_yield();
4700 /* we got the heap lock, let's check that there is no GC in progress */
4701 if (!gc_suspend_count)
4702 break; /* no GC in progress */
4703 /* give chance to GC to finish */
4704 spinlock_release(&mem.alloc_lock);
4705 xthread_yield();
4706 }
4707 }
4708
4709 /* UP: Subtract the `struct timeval' values.
4710 > x: first value
4711 > y: second value
4712 < result: result of substraction.
4713 < returns 1 if the difference is negative, otherwise 0.*/
timeval_subtract(struct timeval * result,struct timeval * x,struct timeval * y)4714 local int timeval_subtract(struct timeval *result,
4715 struct timeval *x,struct timeval *y)
4716 {
4717 /* Perform the carry for the later subtraction by updating y. */
4718 if (x->tv_usec < y->tv_usec) {
4719 int nsec = (y->tv_usec - x->tv_usec) / 1000000 + 1;
4720 y->tv_usec -= 1000000 * nsec;
4721 y->tv_sec += nsec;
4722 }
4723 if (x->tv_usec - y->tv_usec > 1000000) {
4724 int nsec = (x->tv_usec - y->tv_usec) / 1000000;
4725 y->tv_usec += 1000000 * nsec;
4726 y->tv_sec -= nsec;
4727 }
4728 /* Compute the time remaining to wait.
4729 tv_usec is certainly positive. */
4730 result->tv_sec = x->tv_sec - y->tv_sec;
4731 result->tv_usec = x->tv_usec - y->tv_usec;
4732 /* Return 1 if result is negative. */
4733 return x->tv_sec < y->tv_sec;
4734 }
4735
4736 /* POSIX_THREADS have signals - the other case is WIN32_NATIVE and
4737 WIN32_THREADS*/
4738 #ifdef HAVE_SIGNALS
4739
4740 /* SIGUSR1 is used for thread interrupt */
4741 #define SIG_THREAD_INTERRUPT SIGUSR1
4742 /* SIGUSR2 WILL BE used for CALL-WITH-TIMEOUT */
4743 #define SIG_TIMEOUT_CALL SIGUSR2
4744
4745 /* UP: adds to sigset_t mask all terminating signals we handle
4746 > mask: sigset_t mask to add to */
fill_terminating_signals_mask(sigset_t * mask)4747 local void fill_terminating_signals_mask(sigset_t *mask)
4748 {
4749 #ifdef SIGHUP
4750 sigaddset(mask,SIGHUP);
4751 #endif
4752 #ifdef SIGQUIT
4753 sigaddset(mask,SIGQUIT);
4754 #endif
4755 #ifdef SIGKILL
4756 sigaddset(mask,SIGKILL);
4757 #endif
4758 #ifdef SIGTERM
4759 sigaddset(mask,SIGTERM);
4760 #endif
4761 #ifdef SIGTTOU
4762 /* always ignored */
4763 sigaddset(mask,SIGTTOU);
4764 #endif
4765 }
4766
4767 /* UP: creates mask of signals that we do not want to be delivered
4768 directly to threads. The same signals are handled by special non
4769 lisp thread */
async_signal_mask()4770 local sigset_t async_signal_mask()
4771 {
4772 var sigset_t sigblock_mask;
4773 sigemptyset(&sigblock_mask);
4774 sigaddset(&sigblock_mask,SIGINT);
4775 sigaddset(&sigblock_mask,SIGALRM);
4776 sigaddset(&sigblock_mask,SIG_TIMEOUT_CALL);
4777 #if defined(SIGWINCH)
4778 sigaddset(&sigblock_mask,SIGWINCH);
4779 #endif
4780 if (!quit_on_signal_in_progress) {
4781 /* add terminating signals */
4782 fill_terminating_signals_mask(&sigblock_mask);
4783 } else {
4784 /* till now terminating signals were blocked so we can retrieve
4785 them synchronously via sigwait(). Now after we got one - unblock
4786 them so on next such the process will be terminated immediately. */
4787 var sigset_t term_mask;
4788 sigemptyset(&term_mask);
4789 fill_terminating_signals_mask(&term_mask);
4790 sigprocmask(SIG_UNBLOCK,&term_mask,NULL);
4791 }
4792 return sigblock_mask;
4793 }
4794
4795 /* UP: waits for a signal and returns it
4796 < returns signal number */
signal_wait()4797 local int signal_wait()
4798 {
4799 var int sig = 0; /* initialize it with invalid value */
4800 var sigset_t sig_mask=async_signal_mask();
4801 while (sigwait(&sig_mask, &sig) ||
4802 !sigismember(&sig_mask,sig)) {
4803 /* Strange - no way to have bad mask but it happens sometimes
4804 (observed on 32 bit debian during (disassemble 'car) and
4805 CTRL-Z and "fg" later).
4806 Also on osx was observed success from sigwait() without setting any
4807 value in &sig.
4808 Ignore both cases (sigwait() failure and signal not in the waited set)*/
4809 }
4810 return sig;
4811 }
4812
4813 /* UP: signals that new CALL-WITH-TIMEOUT has been issued
4814 and it is the first to expire
4815 < returns 0 on success */
signal_timeout_call()4816 global int signal_timeout_call()
4817 {
4818 return xthread_signal(thr_signal_handler,SIG_TIMEOUT_CALL);
4819 }
4820
4821 /* UP: schedules the next SIGALRM - for the timeout call that is in the
4822 beginning of timeout_call_chain. Called from signal handler thread.
4823 > useconds: duration after which we want SIGARLM */
schedule_alarm(uintL useconds)4824 local useconds_t schedule_alarm(uintL useconds)
4825 {
4826 return ualarm(useconds,0);
4827 }
4828
4829 /* UP: SIG_THREAD_INTERRUPT handler
4830 > sig: always equals to SIG_THREAD_INTERRUPT */
interrupt_thread_signal_handler(int sig)4831 local void interrupt_thread_signal_handler (int sig) {
4832 signal_acknowledge(SIG_THREAD_INTERRUPT,&interrupt_thread_signal_handler);
4833 /* have to unblock SIG_THREAD_INTERRUPT since
4834 our funcall may exit non-locally with longjmp(). */
4835 var sigset_t mask;
4836 sigemptyset(&mask);
4837 sigaddset(&mask,SIG_THREAD_INTERRUPT);
4838 xthread_sigmask(SIG_UNBLOCK,&mask,NULL);
4839 clisp_thread_t *thr=current_thread();
4840 spinlock_release(&thr->_signal_reenter_ok); /* release the signal reentry */
4841 /* when we are here - we either wait on the thread suspend lock or we are
4842 blocked in re-entrant system call. In latter case - it is safe to
4843 execute what we have on the stack. In the former - do nothing - just
4844 return - we will get executed shortly when the thread is "resumed" */
4845 if (!thr->_raw_wait_mutex) {
4846 GC_SAFE_REGION_END_WITHOUT_INTERRUPTS();
4847 handle_pending_interrupts();
4848 GC_SAFE_REGION_BEGIN(); /* restore GC safe region */
4849 }
4850 }
4851
install_async_signal_handlers()4852 local void install_async_signal_handlers()
4853 {
4854 /* 1. disable all async signals
4855 2. install SIG_THREAD_INTERRUPT handler */
4856 var sigset_t sigblock_mask=async_signal_mask();
4857 /* since we are called from the main thread - all threads
4858 in the process will inherit this mask !!*/
4859 sigprocmask(SIG_BLOCK,&sigblock_mask,NULL);
4860 /* install SIG_THREAD_INTERRUPT */
4861 SIGNAL(SIG_THREAD_INTERRUPT,&interrupt_thread_signal_handler);
4862 }
4863
4864 #else /* WIN32_THREADS */
4865
4866 /* define missing signals IDs - since we use the same
4867 signal handler code fot both POSIX and WIN32*/
4868 #define SIGALRM 1
4869 #define SIGINT 2
4870 #define SIG_TIMEOUT_CALL 3
4871 #define SIGBREAK 4
4872
4873 local DWORD wait_timeout=INFINITE;
4874 local HANDLE sigint_semaphore, sigbreak_event;
4875 local HANDLE timeout_call_semaphore;
4876
4877 /* UP: ConsoleCtrlHandler for Win32 */
console_handler(DWORD CtrlType)4878 local BOOL WINAPI console_handler(DWORD CtrlType)
4879 {
4880 if (CtrlType == CTRL_C_EVENT || CtrlType == CTRL_BREAK_EVENT) {
4881 /* Send an event to the sigint_thread. */
4882 if (CtrlType == CTRL_C_EVENT)
4883 ReleaseSemaphore(sigint_semaphore,2,NULL);
4884 else if (CtrlType == CTRL_BREAK_EVENT)
4885 SetEvent(sigbreak_event);
4886 /* Don't invoke the other handlers */
4887 return TRUE;
4888 } else /* Do invoke the other handlers. */
4889 return FALSE;
4890 }
4891
4892 /* UP: installs "async" signal handler on Win32 */
install_async_signal_handlers()4893 local void install_async_signal_handlers()
4894 {
4895 wait_timeout=INFINITE;
4896 sigint_semaphore=CreateSemaphore(NULL,0,MAX_SEMAPHORE_COUNT,NULL);
4897 sigbreak_event=CreateEvent(NULL,TRUE,FALSE,NULL);
4898 timeout_call_semaphore=CreateSemaphore(NULL,0,MAX_SEMAPHORE_COUNT,NULL);
4899 SetConsoleCtrlHandler((PHANDLER_ROUTINE)console_handler,true);
4900 }
4901
4902 /* UP: waits for a signal and returns it
4903 < returns signal number */
signal_wait()4904 local int signal_wait()
4905 {
4906 var HANDLE sems[]={sigint_semaphore, timeout_call_semaphore, sigbreak_event};
4907 retry:
4908 /* TODO: have to update the wait_timeout !!! */
4909 wait_timeout = INFINITE;
4910 switch (WaitForMultipleObjects(3,sems,FALSE,wait_timeout)) {
4911 case WAIT_OBJECT_0:
4912 return SIGINT;
4913 case WAIT_TIMEOUT:
4914 case WAIT_OBJECT_0 + 1:
4915 wait_timeout=INFINITE; /* in any case */
4916 return SIG_TIMEOUT_CALL;
4917 case WAIT_OBJECT_0 + 2:
4918 return SIGBREAK;
4919 default:
4920 /* hmm, not good ?? */
4921 goto retry;
4922 }
4923 }
4924 /* UP: signals that new CALL-WITH-TIMEOUT has been issued
4925 and it is the first to expire
4926 < returns 0 on success. */
signal_timeout_call()4927 global int signal_timeout_call()
4928 {
4929 ReleaseSemaphore(timeout_call_semaphore,1,NULL);
4930 return 0;
4931 }
4932
4933 /* UP: schedules the next SIGALRM - for the timeout call that is in the
4934 beginning of timeout_call_chain. Called from signal handler thread.
4935 > useconds: duration after which we want SIGARLM
4936 should be called only from signal_handler_thread() */
schedule_alarm(uintL useconds)4937 local useconds_t schedule_alarm(uintL useconds)
4938 {
4939 wait_timeout = useconds / 1000; /* in milliseconds */
4940 return 0;
4941 }
4942
4943 #endif
4944
4945 /* UP: handles any pending interrupt (currently just one).
4946 arguments are on the STACK
4947 It is always called in the context of the thread that has to handle the
4948 interrupt and it is safe to do whatever we want here */
handle_pending_interrupts(void)4949 modexp maygc void handle_pending_interrupts(void)
4950 {
4951 var clisp_thread_t *thr = current_thread();
4952 var uintC pend = thr->_pending_interrupts;
4953 thr->_pending_interrupts = 0; /* we got all of them */
4954 /* it's possible interrupt to come before per-thread
4955 *DEFER-INTERRUPTS* is initialized (while evaluating initial bindings) -
4956 check this case as well */
4957 if (eq(Symbol_thread_value(S(defer_interrupts)), NIL) ||
4958 eq(Symbol_thread_value(S(defer_interrupts)), SYMVALUE_EMPTY)) {
4959 while (pend--) {
4960 skipSTACK(1); /* do not care whether we should defer it */
4961 var uintC argc=posfixnum_to_V(popSTACK()); /* arguments count */
4962 var object intrfun=popSTACK(); /* interrupt function */
4963 /* on non-local exit from the interrupt function and nested
4964 pending interrupts - some of them will not be handled.
4965 In most implementations such non-local exits have undefined
4966 behavior and should not be used (actually thread-interrupt is
4967 discouraged). */
4968 funcall(intrfun,argc);
4969 }
4970 } else { /* we should defer interrupts */
4971 while (pend--) {
4972 var bool force = eq(T,popSTACK());
4973 var uintC argc=posfixnum_to_V(popSTACK()); /* arguments count */
4974 if (force) { /* if asked to ignore *defer-interrupts* */
4975 var object intrfun=popSTACK(); /* interrupt function */
4976 funcall(intrfun,argc);
4977 } else {
4978 pushSTACK(nreverse(listof(argc+1)));
4979 var object kons = allocate_cons();
4980 Car(kons) = popSTACK();
4981 Cdr(kons) = Symbol_thread_value(S(deferred_interrupts));
4982 Symbol_thread_value(S(deferred_interrupts)) = kons;
4983 }
4984 }
4985 }
4986 }
4987
4988 /* UP: interrupts thread "safely"
4989 > thr: the thread
4990 The thread should be suspended (safe for GC).
4991 Caller should hold the thread _signal_reenter_ok. On failure
4992 (or when the thread will not be signalled) it will be released here*/
interrupt_thread(clisp_thread_t * thr)4993 global bool interrupt_thread(clisp_thread_t *thr)
4994 {
4995 var xcondition_t *condition;
4996 var xmutex_t *mutex;
4997 /* first check whether the thread is dying. no need to interrupt it.*/
4998 if (thr->_thread_is_dying) {
4999 spinlock_release(&thr->_signal_reenter_ok);
5000 return false;
5001 }
5002 thr->_pending_interrupts++;
5003 if (condition = thr->_wait_condition) {
5004 /* release the lock - we are not going to send signal really */
5005 spinlock_release(&thr->_signal_reenter_ok);
5006 mutex = thr->_wait_mutex;
5007 if (mutex) { /* if not exited from xcondition_wait() */
5008 /* wait to be sure control is inside pthread_cond_wait or already
5009 have returned from it. Loop below may look strange but it will never
5010 perform more than few iterations (and THREAD-INTERRUPT is not meant
5011 to be efficient). */
5012 var xthread_t xthr = TheThread(thr->_lthread)->xth_system;
5013 while (thr->_wait_mutex && xthread_equal(mutex->xl_owner, xthr)) {
5014 if (!mutex->xl_owned) {
5015 /* thr has released the ownership of the mutex - check that
5016 pthread_cond_wait has done the same */
5017 if (0 == xmutex_raw_trylock(&mutex->xl_mutex)) {
5018 xmutex_raw_unlock(&mutex->xl_mutex);
5019 break;
5020 }
5021 }
5022 xthread_yield();
5023 }
5024 /* if the control is still in xcondition_wait() - signal the condition
5025 (nb: there is race here - we may be just exiting from xcondition_wait -
5026 in this case other waiters on this condition variable will experience
5027 "spurious" wake up. the interrupt itself will be handled shortly in
5028 EXEMPTION-WAIT) */
5029 if (thr->_wait_mutex)
5030 xcondition_broadcast(condition);
5031 }
5032 } else if (mutex = thr->_wait_mutex) {
5033 /* release the lock - we are not going to send signal really */
5034 spinlock_release(&thr->_signal_reenter_ok);
5035 /* waiting on mutex i.e. xlock_t */
5036 /* wake up all threads on this condition */
5037 xmutex_raw_lock(&(mutex->xl_internal_mutex));
5038 xcondition_broadcast(&(mutex->xl_wait_cv));
5039 xmutex_raw_unlock(&(mutex->xl_internal_mutex));
5040 } else {
5041 #ifdef POSIX_THREADS
5042 /* the thread may wait on it's gc_suspend_lock or in system
5043 re-entrant call*/
5044 if (xthread_signal(TheThread(thr->_lthread)->xth_system,
5045 SIG_THREAD_INTERRUPT)) {
5046 thr->_pending_interrupts--;
5047 spinlock_release(&thr->_signal_reenter_ok);
5048 return false;
5049 }
5050 #else /* WIN32_THREADS */
5051 /* TODO: implement it. for now - very trivial - wait for the end of the
5052 blocked called */
5053 /* in all cases - release the re-enter spinlock */
5054 spinlock_release(&thr->_signal_reenter_ok);
5055 #endif
5056 }
5057 return true;
5058 }
5059
5060 #ifdef DEBUG_GCSAFETY
5061 #define ENABLE_DUMMY_ALLOCCOUNT(enable) { use_dummy_alloccount=enable; }
5062 #else
5063 #define ENABLE_DUMMY_ALLOCCOUNT(enable)
5064 #endif
5065
5066 /* UP: The signal handler in MT build.
5067 > arg: not used. */
signal_handler_thread(void * arg)5068 local void *signal_handler_thread(void *arg)
5069 {
5070 while (1) {
5071 var int sig = signal_wait();
5072 /* before proceeding we have to be sure that there is no GC
5073 in progress at the moment. This is the only situation in
5074 which we have to delay the signal. */
5075 lock_heap_from_signal();
5076 switch (sig) {
5077 case SIGALRM:
5078 case SIG_TIMEOUT_CALL:
5079 /* we got and alarm or just a new CALL-WITH-TIMEOUT call has been
5080 inserrted in the front of the chain. */
5081 spinlock_acquire(&timeout_call_chain_lock);
5082 {
5083 timeout_call *chain=timeout_call_chain;
5084 var struct timeval now;
5085 gettimeofday(&now,NULL);
5086 /* let's "timeout" first threads if needed */
5087 /* with DEBUG_GCSAFETY we stop all threads and use the dummy
5088 alloccount. Generally with DEBUG_GCSAFETY we cannot suspend
5089 single thread from signal handler without interfering with
5090 other threads alloccounts */
5091 #ifdef DEBUG_GCSAFETY
5092 gc_suspend_all_threads(false);
5093 ENABLE_DUMMY_ALLOCCOUNT(true);
5094 #endif
5095 for(;chain && timeval_less(chain->expire,&now); chain=chain->next) {
5096 #ifndef DEBUG_GCSAFETY
5097 suspend_thread(chain->thread->_lthread,true);
5098 #endif
5099 spinlock_acquire(&chain->thread->_signal_reenter_ok);
5100 gcv_object_t *saved_stack=chain->thread->_STACK;
5101 NC_pushSTACK(chain->thread->_STACK,*chain->throw_tag);
5102 NC_pushSTACK(chain->thread->_STACK,S(thread_throw_tag));
5103 NC_pushSTACK(chain->thread->_STACK,posfixnum(1));
5104 NC_pushSTACK(chain->thread->_STACK,NIL); /* defer if needed */
5105 if (!interrupt_thread(chain->thread)) {
5106 /* hmm - signal send failed. restore the stack and mark the timeout
5107 as failed. The next time when we come here we will retry it - if
5108 not reported as warning to the user. The user will always get a
5109 warning. */
5110 chain->failed=true;
5111 chain->thread->_STACK=saved_stack;
5112 }
5113 #ifndef DEBUG_GCSAFETY
5114 resume_thread(chain->thread->_lthread,false);
5115 #endif
5116 }
5117 #ifdef DEBUG_GCSAFETY
5118 ENABLE_DUMMY_ALLOCCOUNT(false);
5119 gc_resume_all_threads(false);
5120 #endif
5121 /* should we set new alarm ? */
5122 if (chain) {
5123 var struct timeval diff;
5124 timeval_subtract(&diff, chain->expire, &now);
5125 useconds_t wait =
5126 diff.tv_sec > 10 ? 10000000 : diff.tv_sec*1000000 + diff.tv_usec;
5127 /* Under virtualization (tested on vmware and virtualbox) passing
5128 more than a second causes ualarm() to return -1 and signal is
5129 never delivered !!!. This is strange since according to POSIX no
5130 errors are defined for ualarm. If this is the case - just ask for
5131 something less than a second */
5132 if (schedule_alarm(wait) == (useconds_t)-1)
5133 schedule_alarm(999999);
5134 }
5135 /* release the chain spinlock */
5136 spinlock_release(&timeout_call_chain_lock);
5137 }
5138 break;
5139 case SIGINT:
5140 WITH_STOPPED_WORLD(false,{
5141 var bool signal_sent=false;
5142 ENABLE_DUMMY_ALLOCCOUNT(true);
5143 for_all_threads({
5144 spinlock_acquire(&thread->_signal_reenter_ok);
5145 gcv_object_t *saved_stack=thread->_STACK;
5146 /* line below is not needed but detects bugs */
5147 NC_pushSTACK(thread->_STACK,O(thread_break_description));
5148 NC_pushSTACK(thread->_STACK,S(interrupt_condition)); /* arg */
5149 NC_pushSTACK(thread->_STACK,S(cerror)); /* function */
5150 NC_pushSTACK(thread->_STACK,posfixnum(2)); /* two arguments */
5151 NC_pushSTACK(thread->_STACK,T); /* do not defer the interrupt */
5152 if (!(signal_sent = interrupt_thread(thread))) {
5153 thread->_STACK=saved_stack;
5154 } else
5155 break;
5156 });
5157 if (!signal_sent) {
5158 fprint(stderr,"*** SIGINT will be missed.\n"); abort();
5159 }
5160 ENABLE_DUMMY_ALLOCCOUNT(false);
5161 });
5162 break;
5163 #if defined(SIGWINCH)
5164 case SIGWINCH:
5165 sigwinch_handler(SIGWINCH);
5166 break;
5167 #endif
5168 #ifdef SIGTTOU
5169 case SIGTTOU:
5170 break; /* just ignore it */
5171 #endif
5172 #ifdef UNIX_MACOSX
5173 case SIGHUP:
5174 case SIGCONT:
5175 /* TODO: ignore these two - fix later.
5176 we get them after fork-ed process exits. */
5177 break;
5178 #endif
5179 default:
5180 /* just terminate all threads - the last one will
5181 kill the process from delete_thread */
5182 fprintf(stderr, "Exiting on signal %d\n", sig);
5183 WITH_STOPPED_WORLD(false,{
5184 var bool all_succeeded = true;
5185 ENABLE_DUMMY_ALLOCCOUNT(true);
5186 quit_on_signal_in_progress = true;
5187 final_exitcode = -sig; /* set process exit code */
5188 for_all_threads({
5189 /* be sure the signal handler can be reentered */
5190 spinlock_acquire(&thread->_signal_reenter_ok);
5191 NC_pushSTACK(thread->_STACK,O(thread_exit_tag)); /* thread exit tag */
5192 NC_pushSTACK(thread->_STACK,S(thread_throw_tag)); /* %THROW-TAG */
5193 NC_pushSTACK(thread->_STACK,posfixnum(1)); /* 1 argument */
5194 NC_pushSTACK(thread->_STACK,T); /* do not defer the interrupt */
5195 all_succeeded &= interrupt_thread(thread);
5196 });
5197 fini_lowest_level();
5198 if (!all_succeeded) {
5199 fprint(stderr,"*** some threads were not signaled to terminate.");
5200 exit(-sig); /* nothing we can do - exit immediately (cannot call quit
5201 from here) */
5202 }
5203 ENABLE_DUMMY_ALLOCCOUNT(false);
5204 });
5205 break;
5206 }
5207 spinlock_release(&mem.alloc_lock);
5208 }
5209 return NULL;
5210 }
5211
5212 #undef ENABLE_DUMMY_ALLOCCOUNT
5213
5214 #endif /* MULTITHREAD */
5215