1 /* restart.c Copyright (C) 1989-2010 Codemist Ltd */
2
3 /*
4 * Code needed to start off Lisp when no initial heap image is available,
5 * or to re-instate links between heap and C-coded core if there IS a
6 * heap loaded. This code is run in a state that is in effect (in-package
7 * "lisp").
8 */
9
10 /**************************************************************************
11 * Copyright (C) 2010, Codemist Ltd. A C Norman *
12 * *
13 * Redistribution and use in source and binary forms, with or without *
14 * modification, are permitted provided that the following conditions are *
15 * met: *
16 * *
17 * * Redistributions of source code must retain the relevant *
18 * copyright notice, this list of conditions and the following *
19 * disclaimer. *
20 * * Redistributions in binary form must reproduce the above *
21 * copyright notice, this list of conditions and the following *
22 * disclaimer in the documentation and/or other materials provided *
23 * with the distribution. *
24 * *
25 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS *
26 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT *
27 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS *
28 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE *
29 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, *
30 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, *
31 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS *
32 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
33 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR *
34 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF *
35 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH *
36 * DAMAGE. *
37 *************************************************************************/
38
39
40
41 /* Signature: 0ebe04d3 18-Aug-2010 */
42
43 #include "headers.h"
44
45 #ifdef WIN32
46 #include <windows.h>
47 #else
48 #ifndef EMBEDDED
49 #include <dlfcn.h>
50 #endif
51 #endif
52
53 #ifdef HAVE_UNISTD_H
54 #include <unistd.h>
55 #endif
56
57 #include <sys/stat.h>
58 #include <sys/types.h>
59
60 #ifdef HAVE_FWIN
61 extern int showmathInitialised;
62 #endif
63
64 #ifndef S_IRUSR
65 #ifdef __S_IRUSR
66 #define S_IRUSR __S_IRUSR
67 #endif
68 #endif
69
70 #ifndef S_IWUSR
71 #ifdef __S_IWUSR
72 #define S_IWUSR __S_IWUSR
73 #endif
74 #endif
75
76 #ifndef S_IXUSR
77 #ifdef __S_IXUSR
78 #define S_IXUSR __S_IXUSR
79 #endif
80 #endif
81
82 /*
83 * jit
84 */
85 #ifdef JIT
86 #ifndef WIN32
87 #include <sys/mman.h>
88 #endif
89 #endif
90
91 extern int load_count, load_limit;
92
93 /*
94 * machineid.c is a dynamically-created file that contains
95 * (a) Identification of the type of object file used by this system.
96 * In many cases this is the ELF magic code for the machine.
97 * (b) Information about the command used to compile C code.
98 * (c) Header files relating to the Lisp-to-C compilation process.
99 */
100 #include "machineid.c"
101
102 Lisp_Object address_sign;
103
104 /*
105 * OK, so I will write a short essay here about the issues of converting
106 * between 32 and 64-bit formats. Let me deal with the easier case first.
107 * If the image file I wish to reload had been made on a 64-bit computer
108 * but now I am just a 32-bit one I can take every item
109 * | abcdabcdabcdabcd | efghefghefghefgh |
110 * and convert it in memory to
111 * | abcdabcd | efghefgh | pad_pad_ | pad_pad_ |
112 * where the start address of the object is the same and my image encoding
113 * means that truncating the data does not hurt. I must be careful that
114 * strings, bignums and other types of stuff that contain raw binary do
115 * not end up squashed, and as a matter of caution (if only while I debug
116 * this) I will fill vacated space with tidy padding. Actually I now see
117 * that I MUST fill up the gaps that are left with validly structured
118 * material that has correct length codes in it if I shrink/compact the
119 * data before I relocate pointers in it, since if I do not the attempt to
120 * relocate pointers etc will fail.
121 * The cost to a person with a 32-bit machine will be that there is a
122 * little more time spent loading the image file, and the image file
123 * will be a bit bulkier (with all that padding) so the first garbage
124 * collection will need to happen sooner.
125 *
126 * Things are less pleasant if the image file had been made on a 32-bit
127 * machine but is now being loaded on a 64-bit one. The reason this is
128 * messier is that data must be expanded and moved, not just compacted with
129 * gaps left.
130 *
131 * The basic idea is that when an object made out of 32-bit values is
132 * seen it gets expanded out into 64-bit items. The image file format is
133 * such that mere sign-extension should suffice for this. Then when addresses
134 * are adjusted later during the reload process all offsets need to be
135 * doubled. So the expansion must place each expanded object starting at
136 * twice the offset from its page-start as it originally was. This is not
137 * too bad. But what is nastier is that this means that the page it is put
138 * into has to be a double-sized one. Normally all CSL heap is built within
139 * fixed size (at present 4 Mbyte) pages. So when a 32-bit heap is to be
140 * reloaded on a 64-bit machine it must be put in 8 Mbyte pages to allow for
141 * the expansion. Trying to use a pair of normal sized pages seems really hard
142 * because there may be a big object spanning the middle of the original
143 * page - ie the place where one wanted to split it. There is an insuperable
144 * problem if a 32-bit image contains a vector that would fit on that
145 * architecture but not on a 64-bit one, so on 32-bit machine to allow for
146 * conversion I may need to here. I also need to tune my internal
147 * representation for hash tables to allow for this.
148 *
149 * So when reloading a 32-bit image on a 64-bit machine I must make double-
150 * sized pages to reload into. That is not too bad. But then I must consider
151 * their subsequent usage. There are three major concerns - the garbage
152 * collector, the code that creates a new image file and freeing memory at
153 * the end of a run. Before creating a new image file garbage collection is
154 * performed, so if AFTER garbage collection all pages are the correct size
155 * all will be well. I will ensure that that is the case.
156 *
157 * The sliding garbage collector leaves data in the page it started in, and
158 * has no guaranteed way to shrink a page to become single size. But in the
159 * case I am considering I am on a 64-bit machine and I can perhaps assume
160 * that I have "plenty" of free memory - in that case I can force the first
161 * garbage collection of the run to be a copying one, and fail if there is
162 * insufficient memory for that to be possible. That is OK if I can
163 * ensure that the total memory available is at least three the size of the
164 * image that I am loading. The need for this size is to cope with a 32-bit
165 * vector page that is 1/4 full of small vectors, then has a single vector
166 * of maximum size and finally fills up to its top. When expanded to
167 * 64-bit form and copied the copy can need 3 pages because the big vector in
168 * the middle must all end up within one page.
169 *
170 * An initial heap image for the bootstrap version of Reduce is larger than
171 * the one for the release version, but both easily fit within 1 page of
172 * each of cons-heap, vector-heap and bps-heap. So loading the image in a
173 * simple way requires 12 Mbytes of allocated memory. When I load into
174 * double-sized pages I need 24 Mbytes of contiguous memory. To be certain
175 * that I can manage a copying garbage collection even in worst case
176 * situations that will not arise, I should have 2 pages of cons heap and
177 * 3 for each of vector- and bps-heap available, ie 8 more pages. That is
178 * 11 pages in all, and in fact I will allocate a further page for a stack,
179 * so I need at least 12 pages, 48 Mbytes available at the start of a run.
180 * On a 64-bit machine I will take the view that this is reasonable. Obviously
181 * larger initial heap images will put more severe strains on everything!
182 *
183 * When expanding a page vectors that contain pointers will often double in
184 * size, but if they hold an even number of items the padder word needed in
185 * the 32-bit world will become superfluous. Vectors containing non-pointer
186 * data (eg strings and bignums) will only expand by 4 bytes. In each case
187 * if space is left unoccupied it must be filled with some form of valid
188 * padding so that subsequent linear scans of the heap can succeed.
189 *
190 * There was an apparent pan as regards BPS pointers and refereces into
191 * double-sized pages, but I found a solution to it (albeit a slightly
192 * grungy one).
193 *
194 * I need to review the copying GC to verify that it will not be hurt
195 * by having a few oversize pages, but my expectation is that it only looks
196 * at the size of NEW pages that it allocates.
197 *
198 * At the end of a run I go "free()" on all the pages I allocated. If in
199 * the copying collector I detect when I have copied out from an oversized
200 * page and I return it to the pool as a pair of regular pages (a good thing
201 * to do!) then if I tried to free the upper such page disaster could ensue.
202 * A way to avoid that pain is to demand that the double size pages all
203 * reside within an initial single block that I already allocate at the
204 * start of a run and that gets freed wholesale. I will need a way to detect
205 * when the garbage collector is discarding a big page.
206 *
207 * Note that I have a plan to introduce a conservative garbage collector
208 * at some stage, and that would lead to some old pages needing to be
209 * retained across a mostly-copying collection. In consequence over-sized
210 * pages would live for some longer time. But my plans in that direction
211 * are that the conservative system can be replaced by a precise copying
212 * collector in at least the key case that a new heap image is about to
213 * be created, and so at least some of the isssues can be side-stepped.
214 * Detecting valid references might well need information about the size
215 * of pages - but I can record that somehow when I get to that point.
216 * See the file "conservative.txt" for elaboration on my plans. In the
217 * very worst case I could instantly do a first precise compacting garbage
218 * collection immediately after a restart so as to normalise the heap. The
219 * cost effect would be that the restart took longer, but probably not by
220 * very much!
221 *
222 * Hmm that is all a bit of a business, but I hope I have covered
223 * everything that will matter!
224 */
225
226
227 static int converting_to_32 = 0, converting_to_64 = 0;
228
229 Lisp_Object C_nil;
230 Lisp_Object *stackbase;
231 Lisp_Object * volatile stacklimit;
232
233 Lisp_Object *nilsegment;
234 Lisp_Object *stacksegment;
235 int32_t stack_segsize = 1;
236
237 char *exit_charvec = NULL;
238 intptr_t exit_reason;
239
240 #ifdef NILSEG_EXTERNS
241
242 intptr_t byteflip;
243 Lisp_Object codefringe;
244 Lisp_Object volatile codelimit;
245 Lisp_Object fringe;
246 Lisp_Object volatile heaplimit;
247 Lisp_Object volatile vheaplimit;
248 Lisp_Object vfringe;
249 intptr_t nwork;
250 intptr_t exit_count;
251 intptr_t gensym_ser, print_precision, miscflags;
252 intptr_t current_modulus, fastget_size, package_bits;
253 Lisp_Object lisp_true, lambda, funarg, unset_var, opt_key, rest_key;
254 Lisp_Object quote_symbol, function_symbol, comma_symbol, comma_at_symbol;
255 Lisp_Object cons_symbol, eval_symbol, work_symbol, evalhook, applyhook;
256 Lisp_Object macroexpand_hook, append_symbol, exit_tag;
257 Lisp_Object exit_value, catch_tags;
258 #ifdef COMMON
259 Lisp_Object keyword_package;
260 #endif
261 Lisp_Object current_package;
262 Lisp_Object startfn;
263 #ifdef COMMON
264 Lisp_Object all_packages, package_symbol, internal_symbol;
265 Lisp_Object external_symbol, inherited_symbol;
266 #endif
267 Lisp_Object gensym_base, string_char_sym, boffo;
268 #ifdef COMMON
269 Lisp_Object key_key, allow_other_keys, aux_key;
270 #endif
271 Lisp_Object err_table;
272 #ifdef COMMON
273 Lisp_Object format_symbol;
274 #endif
275 Lisp_Object progn_symbol;
276 #ifdef COMMON
277 Lisp_Object expand_def_symbol, allow_key_key;
278 #endif
279 Lisp_Object declare_symbol, special_symbol;
280 Lisp_Object lisp_work_stream, charvec, raise_symbol, lower_symbol, echo_symbol;
281 Lisp_Object codevec, litvec, supervisor, B_reg, savedef, comp_symbol;
282 Lisp_Object compiler_symbol, faslvec, tracedfn, lisp_terminal_io;
283 Lisp_Object lisp_standard_output, lisp_standard_input, lisp_error_output;
284 Lisp_Object lisp_trace_output, lisp_debug_io, lisp_query_io;
285 Lisp_Object prompt_thing, faslgensyms, prinl_symbol, emsg_star, redef_msg;
286 Lisp_Object expr_symbol, fexpr_symbol, macro_symbol;
287 Lisp_Object cl_symbols, active_stream, current_module;
288 Lisp_Object native_defs, features_symbol, lisp_package, sys_hash_table;
289 Lisp_Object help_index, cfunarg, lex_words, get_counts, fastget_names;
290 Lisp_Object input_libraries, output_library, current_file, break_function;
291 Lisp_Object standard_output, standard_input, debug_io;
292 Lisp_Object error_output, query_io, terminal_io, trace_output, fasl_stream;
293 Lisp_Object native_code, native_symbol, traceprint_symbol, loadsource_symbol;
294 Lisp_Object hankaku_symbol, bytecoded_symbol, nativecoded_symbol;
295 Lisp_Object gchook, resources, callstack, procstack, procmem;
296 Lisp_Object workbase[51];
297
298
299 #endif
300
301 Lisp_Object user_base_0, user_base_1, user_base_2, user_base_3, user_base_4;
302 Lisp_Object user_base_5, user_base_6, user_base_7, user_base_8, user_base_9;
303
304 Lisp_Object eq_hash_tables, equal_hash_tables;
305
306 /*
307 * On an Intel 80x86 (because I am almost forced to) and on other machines
308 * (much more cheerfully, and for choice!) I will arrange my memory as
309 * a number of pages. A general pool of these pages gets used
310 * to satisfy requests for heap, vector heap and BPS space.
311 *
312 * Since this code was first written it has become silly to even consider
313 * computers with 16-bit segmented addressing! It is still convenient to
314 * allocate memory in chunks, although that does set an upper limit to the
315 * size of any individual object: this may hurt if a user wants a big vector
316 * and it does constrain the range of big-numbers supported by the
317 * artithmetic.
318 */
319
320 void **pages,
321 **heap_pages,
322 **vheap_pages,
323 **bps_pages,
324 **native_pages;
325 void **new_heap_pages,
326 **new_vheap_pages,
327 **new_bps_pages,
328 **new_native_pages;
329
330 #ifdef CONSERVATIVE
331
332 page_map_t *page_map;
333
334 #endif
335
336 /*
337 * Used for allocating jit functions executable space
338 */
339
340 #ifdef JIT
341 void *jit_space,
342 *jit_space_p;
343 unsigned long jit_size;
344 #endif
345
346 int32_t pages_count,
347 heap_pages_count,
348 vheap_pages_count,
349 bps_pages_count,
350 native_pages_count;
351 int32_t new_heap_pages_count,
352 new_vheap_pages_count,
353 new_bps_pages_count,
354 new_native_pages_count;
355
356 char program_name[64] = {0};
357
358 #ifndef COMMON
359 #ifdef HAVE_FWIN
360 char **loadable_packages = NULL, **switches = NULL;
361 #endif
362 #endif
363
364 int native_code_tag;
365 int32_t native_pages_changed;
366 int32_t native_fringe;
367 int current_fp_rep;
368 static int old_fp_rep;
369 static CSLbool flip_needed;
370 static int old_page_bits;
371
372 int procstackp;
373
374 /*
375 * The next function is handed a page
376 * of hard code that has just been loaded into memory and it must scan it
377 * performing all relevant relocation. fringe give the offset within the
378 * page that is the first byte not in use. The first 4 bytes of the page
379 * are reserved for storing fringe from one run to the next. The exact
380 * format of the rest must be sufficient to allow this code to scan
381 * and correct the code, but thus far I have not defined it, and it will
382 * anyway tend to need extension each time a new target architecture is
383 * incorporated (to support the new and curious relocation modes tha the
384 * new machine requires).
385 */
386
relocate_native_code(unsigned char * p,int32_t n)387 static void relocate_native_code(unsigned char *p, int32_t n)
388 {
389 /*
390 * One helpful observation here. In pretty well all other parts of CSL
391 * there is a possibility that an image file created on one computer will
392 * be reloaded on another and so all the code is ultra-careful to avoid
393 * sensitivity to byte order etc etc issues. But here the native code that
394 * is being loaded MUST have been created using the conventions of the
395 * current computer (otherwise I should not be loading it and I will be
396 * in huge trouble when I try to execute code from it). So direct and
397 * simple access to data is legitimate.
398 */
399 int32_t k = 8;
400 term_printf("Native code page type %d size %d to be relocated\n",
401 native_code_tag, n);
402 while (k <= n)
403 { unsigned char *block = p + k;
404 int32_t len = car32(block);
405 term_printf("Block of %d bytes found\n", len);
406 if (len == 0)
407 { term_printf("End of native page reached\n");
408 break;
409 }
410 relocate_native_function(block);
411 k += len;
412 }
413 }
414
relocate_native_function(unsigned char * bps)415 void relocate_native_function(unsigned char *bps)
416 {
417 /*
418 * Just for now I will not support native code on 64-bit machines.
419 * This is just to save me some hassle re-working this relocation mess!
420 */
421 unsigned char *r, *next;
422 int32_t n;
423 int code;
424 if (SIXTY_FOUR_BIT) return; /* No native for 64-bit architectures yet */
425 /*
426 * Each chunk of memory allocated by make-native will have its length (in
427 * bytes) in its first 32-bit word. Next comes the offset of the
428 * start of real code in the block. Just after that there will be a
429 * hunk of relocation information. The code proper must not start until
430 * after the relocation records. Relocation information is stored in the
431 * following format as a sequence of bytes:
432 * 0 end of relocation information.
433 * 1 to 170/xx encode a value 0 to 169
434 * 171 to 255/xx/yy extra byte yy extends following offset xx, and
435 * its top bit is used to extend opcode to range
436 * 0 to 169.
437 * The opcode now in the range 0 to 169 is interpreted as
438 * 169 no operation
439 * otherwise (0-12)*(0-12) as target*mode
440 */
441 r = bps + 4;
442 n = *r++; /* code start offset in LSB format */
443 n |= (*r++) << 8;
444 n |= (*r++) << 16;
445 n |= (*r++) << 24;
446 next = bps + n;
447 #define RELOC_END 0
448 while ((code = *r++) != RELOC_END)
449 { int32_t off = *r++;
450 unsigned char *target;
451 /*
452 * A native compiler will have to generate a sequence of bytes that adhere to
453 * the contorted format used here.
454 */
455 if (code <= 170) code--;
456 else
457 { int off1 = *r++;
458 code = 2*(code-171) + (off1 >> 7);
459 off = off | ((off1 & 0x7f) << 8);
460 }
461 next += off; /* address where next relocation is to be applied */
462 #define RELOC_NOP 169
463 /*
464 * One might like to note that with a long offset the NOP opcode turns into
465 * an opcode byte 0xff. And if it then has the longest possible offset one]
466 * gets the 3-byte sequence 0xff/0xff/0xff.
467 */
468 if (code == RELOC_NOP) continue;
469
470 #define RELOC_0_ARGS 0
471 #define RELOC_1_ARGS 1
472 #define RELOC_2_ARGS 2
473 #define RELOC_3_ARGS 3
474 #define RELOC_DIRECT_ENTRY 4
475 #define RELOC_VAR 5
476 #define RELOC_SELF_1 6
477 #define RELOC_SELF_2 7
478 switch (code % 13)
479 {
480 default:
481 term_printf("Illegal relocation byte %.2x\n", code);
482 my_exit(EXIT_FAILURE);
483 case RELOC_SELF_1:
484 /*
485 * base of current native code block with an 8-bit offset.
486 */
487 target = bps + *r++;
488 break;
489 case RELOC_SELF_2:
490 /*
491 * base of current native code block with 15 or 23-bit offset. The first byte
492 * is the low 8-bits of the offset. The next is the next 7 bits, with its
493 * 0x80 bit selecting whether a third byte is needed (which it will hardly
494 * ever be).
495 */
496 off = *r++;
497 off = off + (*r++ << 8);
498 if (off & 0x8000) off = (off & 0x7fff) + (*r++ << 15);
499 target = bps + off;
500 break;
501 case RELOC_0_ARGS:
502 /*
503 * The next few relocation modes provide access to the C entrypoints
504 * associated with a medium number of Lisp functions. The tables and
505 * offsets used are documented in file "eval4.c" and are as used with the
506 * byte-code compiler.
507 */
508 target = (unsigned char *)zero_arg_functions[*r++];
509 break;
510 case RELOC_1_ARGS:
511 target = (unsigned char *)one_arg_functions[*r++];
512 break;
513 case RELOC_2_ARGS:
514 target = (unsigned char *)two_arg_functions[*r++];
515 break;
516 case RELOC_3_ARGS:
517 target = (unsigned char *)three_arg_functions[*r++];
518 break;
519 case RELOC_DIRECT_ENTRY:
520 /*
521 * There are some entrypoints into the CSL kernel that are not
522 * called using the usual Lisp conventions but are at a lower-level.
523 * A selection of these are visible via the table "useful_functions"
524 * in file fns3.c. This table can be extended if a native-mode compiler
525 * needs access to any other speciality.
526 */
527 target = (unsigned char *)useful_functions[*r++];
528 break;
529 case RELOC_VAR:
530 /*
531 * The function address_f_var (in fns3.c) returns the address of a Lisp
532 * internal variable. See there for the numeric encoding used and what can
533 * be accessed.
534 */
535 target = (unsigned char *)address_of_var(*r++);
536 break;
537 }
538
539 #define RELMODE_ABSOLUTE 0
540 #define RELMODE_RELATIVE 1
541 #define RELMODE_REL_PLUS_4 2
542 #define RELMODE_REL_MINUS_2 3
543 #define RELMODE_REL_MINUS_4 4
544 #define RELMODE_REL_OFFSET 5
545 #define RELMODE_SPARE1 6
546 #define RELMODE_SPARE2 7
547
548 switch (code/13)
549 {
550 default:
551 term_printf("Illegal relocation byte %.2x\n", code);
552 my_exit(EXIT_FAILURE);
553 case RELMODE_ABSOLUTE:
554 /*
555 * relocate by pointing a 32-bit value directly at the absolute address
556 * of the target.
557 */
558 /*
559 * In this general section of the code there are a bunch of cases where I
560 * cast to intptr_t and after that to int32_t. Well at present this section
561 * of code can only even possibly get executed if these two types are the
562 * same width! But on a 64-bit machine I would need to take extra care
563 * relocating references to 64-bit addresses.
564 */
565 *(int32_t *)next = (int32_t)(intptr_t)target;
566 break;
567 case RELMODE_RELATIVE:
568 /*
569 * relocate by setting a 32-bit value of the offset from its own first
570 * byte to the target.
571 */
572 *(int32_t *)next = (int32_t)((intptr_t)target - (intptr_t)next);
573 break;
574 case RELMODE_REL_PLUS_4:
575 /*
576 * relocate by setting a 32-bit value of the offset from the start of the
577 * word after it.
578 */
579 *(int32_t *)next = (int32_t)((intptr_t)target - ((intptr_t)next + 4));
580 break;
581 case RELMODE_REL_MINUS_2:
582 /*
583 * relocate by setting a 32-bit value of the offset from the address 2 bytes
584 * before its start. This may be used on machines where the relative address
585 * is computed based on the start of the instruction rather than the start of
586 * the field within the instruction that contains the offset.
587 */
588 *(int32_t *)next = (int32_t)((intptr_t)target - ((intptr_t)next - 2));
589 break;
590 case RELMODE_REL_MINUS_4:
591 /*
592 * relocate by setting a 32-bit value of the offset from the address 4 bytes
593 * before its start. This may be used on machines where the relative address
594 * is computed based on the start of the instruction rather than the start of
595 * the field within the instruction that contains the offset.
596 */
597 *(int32_t *)next = (int32_t)((intptr_t)target - ((intptr_t)next - 4));
598 break;
599 case RELMODE_REL_OFFSET:
600 /*
601 * relocate by setting a 32-bit value of the offset from some place
602 * offset using an 8-bit signed value from the start of the address. The
603 * offset represents the number of bytes after the start of the address
604 * that is to be used in the calculation. Note that the special values
605 * -4, -2, 0 and 4 need never be used here because there are special
606 * relocation modes for those common cases.
607 */
608 code = *r++;
609 if (code & 0x80) code |= ~0xff; /* Sign extend */
610 *(int32_t *)next = (int32_t)((intptr_t)target - ((intptr_t)next + code));
611 break;
612 }
613 }
614 }
615
616 static int32_t fread_count;
617 static unsigned char *fread_ptr;
618
619 #define FREAD_BUFFER_SIZE ((CSL_PAGE_SIZE - 1) & ~0xfff)
620
621 static unsigned char *pair_c, *char_stack;
622 static unsigned short int *pair_prev;
623
Cfread(char * p,int32_t n)624 static void Cfread(char *p, int32_t n)
625 {
626 /*
627 * The decompression process does not need hashed access to see if
628 * character-pairs have been seen before, but it can need a stack to
629 * unwind codes that have very lengthy expansions.
630 */
631 int c1, k;
632 unsigned int prev, c, next_code;
633 int32_t count = fread_count;
634 unsigned char *ptr = fread_ptr;
635 if (n < compression_worth_while)
636 {
637 while (n > count)
638 { memcpy(p, ptr, (size_t)count);
639 p += count;
640 n -= count;
641 ptr = (unsigned char *)stack;
642 count = Iread(ptr, FREAD_BUFFER_SIZE);
643 }
644 if (n != 0)
645 { memcpy(p, ptr, (size_t)n);
646 ptr += n;
647 count -= n;
648 }
649 fread_count = count;
650 fread_ptr = ptr;
651 return;
652 }
653
654 next_code = 256;
655
656 if (count == 0)
657 { ptr = (unsigned char *)stack;
658 count = Iread(ptr, FREAD_BUFFER_SIZE);
659 }
660 c = *ptr++;
661 count--;
662
663 if (count == 0)
664 { ptr = (unsigned char *)stack;
665 count = Iread(ptr, FREAD_BUFFER_SIZE);
666 }
667 c = (c << 8) | *ptr++;
668 count--;
669
670 prev = c >> 4;
671 *p++ = (char)prev; /* The first character is not compressed */
672 n--;
673
674 while (n > 0)
675 { if (count == 0)
676 { ptr = (unsigned char *)stack;
677 count = Iread(ptr, FREAD_BUFFER_SIZE);
678 }
679 c = ((c & 0xf) << 8) | *ptr++;
680 count--;
681 /*
682 * Decode the next 12 bit character
683 */
684 c1 = c;
685 k = 1;
686 while (c1 >= 256)
687 { char_stack[k++] = pair_c[c1];
688 if (pair_prev[c1] > CODESIZE || k >= CODESIZE)
689 { term_printf("Bad decoded char %x -> %x, k=%d\n", c1, pair_prev[c1], k);
690 my_exit(EXIT_FAILURE);
691 }
692 c1 = pair_prev[c1];
693 }
694 /*
695 * Write the decoded stuff into the output array.
696 */
697 n -= k;
698 *p++ = (char)c1;
699 while (k != 1)
700 { *p++ = char_stack[--k];
701 }
702 /*
703 * ... then build up the decoding tables ready for next time. Of course
704 * the table building in this decoder MUST exactly match the behaviour of
705 * the compression code above.
706 */
707 if (next_code >= CODESIZE) next_code = 256;
708 else
709 { pair_prev[next_code] = (unsigned short int)prev;
710 pair_c[next_code] = (unsigned char)c1;
711 next_code++;
712 }
713 prev = c;
714
715 if (n <= 0) break;
716
717 /*
718 * read the next 12 bit character.
719 */
720 if (count == 0)
721 { ptr = (unsigned char *)stack;
722 count = Iread(ptr, FREAD_BUFFER_SIZE);
723 }
724 c = *ptr++;
725 count--;
726 if (count == 0)
727 { ptr = (unsigned char *)stack;
728 count = Iread(ptr, FREAD_BUFFER_SIZE);
729 }
730 c = (c << 8) | *ptr++;
731 count--;
732 /*
733 * Decode it...
734 */
735 c1 = c >> 4;
736 k = 1;
737 while (c1 >= 256)
738 { char_stack[k++] = pair_c[c1];
739 if (pair_prev[c1] > CODESIZE || k >= CODESIZE)
740 { term_printf("Bad decoded char %x -> %x, k=%d\n", c1, pair_prev[c1], k);
741 my_exit(EXIT_FAILURE);
742 }
743 c1 = pair_prev[c1];
744 }
745 /*
746 * Write the decoded stuff into the output array.
747 */
748 n -= k;
749 *p++ = (char)c1;
750 while (k != 1)
751 { *p++ = char_stack[--k];
752 }
753 /*
754 * ... then build up the decoding tables ready for next time. Of course
755 * the table building in this decoder MUST exactly match the behaviour of
756 * the compression code above.
757 */
758 if (next_code >= CODESIZE) next_code = 256;
759 else
760 { pair_prev[next_code] = (unsigned short int)prev;
761 pair_c[next_code] = (unsigned char)c1;
762 next_code++;
763 }
764 prev = c >> 4;
765 }
766 fread_count = count;
767 fread_ptr = ptr;
768 }
769
770 /*
771 * There is a misery here in that the width of a Lisp_Object on the
772 * current architecture can not be a compile-time constant and so I can
773 * not parameterise how to swap bytes based on "#ifdef". Hence I need to
774 * write things as run-time checks. But then the version of the code I
775 * will not execute has weird types - so I put in explicit casts so that
776 * there is at last some local consistency and expack the compiler to
777 * optimise away the code that is not wanted.
778 */
779
780 #define flip_bytes(a) \
781 (!flip_needed ? (a) : \
782 SIXTY_FOUR_BIT ? (Lisp_Object)flip_64bits((uint64_t)(a)) : \
783 (Lisp_Object)flip_32bits((uint32_t)(a)))
784
785 /*
786 * If I know a value is just 32-bits but it may need flipping I can use this
787 */
788
789 #define flip_32(a) \
790 (!flip_needed ? (a) : \
791 flip_32bits(a))
792
flip_32bits(uint32_t x)793 static uint32_t flip_32bits(uint32_t x)
794 {
795 uint32_t b0, b1, b2, b3;
796 b0 = (x >> 24) & 0xffU;
797 b1 = (x >> 8) & 0xff00U;
798 b2 = (x << 8) & 0xff0000U;
799 b3 = (x << 24) & 0xff000000U;
800 return b0 | b1 | b2 | b3;
801 }
802
803 #define flip_64(a) \
804 (!flip_needed ? (a) : \
805 flip_64bits(a))
806
flip_64bits(uint64_t x)807 static uint64_t flip_64bits(uint64_t x)
808 {
809 uint64_t b0, b1, b2, b3, b4, b5, b6, b7;
810 b0 = (x >> 56) & ((uint64_t)0xff);
811 b1 = (x >> 40) & (((uint64_t)0xff)<<8);
812 b2 = (x >> 24) & (((uint64_t)0xff)<<16);
813 b3 = (x >> 8) & (((uint64_t)0xff)<<24);
814 b4 = (x << 8) & (((uint64_t)0xff)<<32);
815 b5 = (x << 24) & (((uint64_t)0xff)<<40);
816 b6 = (x << 40) & (((uint64_t)0xff)<<48);
817 b7 = (x << 56) & (((uint64_t)0xff)<<56);
818 return b0 | b1 | b2 | b3 | b4 | b5 | b6 | b7;
819 }
820
821 #define flip_halfwords(a) \
822 (flip_needed ? flip_halfwords_fn(a) : (a))
823
flip_halfwords_fn(uint32_t x)824 static uint32_t flip_halfwords_fn(uint32_t x)
825 {
826 uint32_t b0, b1, b2, b3;
827 b0 = (x >> 8) & 0xffU;
828 b1 = (x << 8) & 0xff00U;
829 b2 = (x >> 8) & 0xff0000U;
830 b3 = (x << 8) & 0xff000000U;
831 return b0 | b1 | b2 | b3;
832 }
833
834
convert_fp_rep(void * p,int old_rep,int new_rep,int type)835 void convert_fp_rep(void *p, int old_rep, int new_rep, int type)
836 {
837 uint32_t *f = (uint32_t *)p;
838 if (old_rep == new_rep) return;
839 /*
840 * type == 0 for sfloat, 1 for single float, 2 for double and 3 for extended.
841 * in CSL mode only case 2 can arise. If I ever implement "long floats"
842 * (ie 80-bit values) I will need to re-visit this code.
843 */
844 if (type >= 2 && ((old_rep ^ new_rep) & FP_WORD_ORDER))
845 { uint32_t w = f[0];
846 f[0] = f[1];
847 f[1] = w;
848 }
849 /*
850 * Note that I flip the bytes in each word and ALSO flip the order of the
851 * words to achieve a full 64-bit flip here.
852 */
853 if ((old_rep ^ new_rep) & FP_BYTE_ORDER)
854 { f[0] = flip_32bits(f[0]);
855 if (type >= 2) f[1] = flip_32bits(f[1]);
856 }
857 return;
858 }
859
adjust(Lisp_Object * cp)860 static void adjust(Lisp_Object *cp)
861 /*
862 * If p is a pointer to an object that has moved, adjust it.
863 */
864 {
865 Lisp_Object nil = C_nil, p = flip_bytes(*cp);
866 /*
867 * The value 0 ought not to occur, but to be conservative I detect it and
868 * treat it as signalling NIL.
869 */
870 if (p == SPID_NIL || p == 0) *cp = nil;
871 else if (is_cons(p))
872 { intptr_t h = (intptr_t)heap_pages[(p>>PAGE_BITS) & PAGE_MASK];
873 /* If I am expanding a 32-bit image onto a 64-bit computer then I will
874 * have allocated double-sized pages (on a temporary basis) and placed
875 * all items at exactly twice their original offset from the page
876 * start. But note that OFFSET_MASK only allows for offsets up to the
877 * normal page size.
878 */
879 p &= OFFSET_MASK;
880 /*
881 * In a bunch of places that I check for converting_to_64 I only do so if
882 * SIXTY_FOUR_BIT is set. That is because SIXTY_FOUR_BIT is something that
883 * (while not a constant at preprocessor time) is a constant by the stage
884 * that compiler optimisation should be being done, and so on 32-bit
885 * machines the extra work should be removed totally... at least of the
886 * compiler is up to scratch.
887 * Note that TAG_CONS=0 so merely doubling the offset field here is OK.
888 */
889 if (SIXTY_FOUR_BIT && converting_to_64) p *= 2;
890 *cp = (Lisp_Object)((char *)quadword_align_up(h) + p);
891 }
892 else if (is_immed_or_cons(p))
893 {
894 #ifdef COMMON
895 if (is_sfloat(p))
896 { intptr_t w = flip_32(p); /* delicate here!! */
897 convert_fp_rep((void *)&w, old_fp_rep, current_fp_rep, 0);
898 *cp = w;
899 continue;
900 }
901 #endif
902 /*
903 * A further messiness here! If I am remapping from a 64 bit image to a
904 * 32-bit one I will move all bps items down one word (leaving their
905 * headers starting doubleword aligned as before). So I need to change
906 * all references to them.
907 */
908 if (converting_to_32 && is_bps(p)) p -= 0x100;
909 else if (SIXTY_FOUR_BIT && converting_to_64 && is_bps(p))
910 { uint32_t page = ((uint32_t)p)>>(PAGE_BITS+6);
911 /*
912 * Here I want to double the offset within the page. The key complication
913 * is that the 32-bit packed value here only has room to cope with a
914 * reference into a normal-sized page, but I need to double all offsets.
915 * I deal with that by using the bottom bit of the upper 32-bits as an
916 * extension of the offset. So all NORMAL references will have their top
917 * half all zero, while special ones that arise only when expanding an
918 * image will have non-zerop top half.
919 */
920 uint32_t offset = (((uint32_t)p) >> 5) & (2*PAGE_POWER_OF_TWO-8);
921 uint64_t x = (offset >> PAGE_BITS) & 1;
922 offset &= (PAGE_POWER_OF_TWO-8);
923 p = (x<<32) | (page<<(PAGE_BITS+6)) | (offset<<6) | TAG_BPS;
924 }
925 *cp = p; /* Immediate data here */
926 }
927 else
928 { intptr_t h = (intptr_t)vheap_pages[(p>>PAGE_BITS) & PAGE_MASK];
929 p &= OFFSET_MASK;
930 /* Here I must double the offset but preserve the tag information */
931 if (SIXTY_FOUR_BIT && converting_to_64) p += (p & ~TAG_BITS);
932 *cp = (Lisp_Object)((char *)doubleword_align_up(h) + p);
933 }
934 }
935
936 /*
937 * expand_to_64() must take a 32-bit value that is in potentially flipped
938 * byte order and convert it into a (potentially byte flipped) 64-bit value
939 * by sign extending it. So the cast to int32_t here is to ensure that it is
940 * signed so that the cast to int64_t sign extends (this is vital for
941 * fixnums). Similarly shrink_to_32 must understand that it is working on
942 * possibly flipped values.
943 * Observe that if byte-flipping is not required then things become a little
944 * easier and hence faster, so I specialize on that case.
945 */
946
947 #define expand_to_64(x) \
948 (flip_needed ? (Lisp_Object)flip_64bits((int64_t)(int32_t)flip_32bits(x)) : \
949 ((Lisp_Object)(int64_t)(int32_t)(x)))
950
951 #define shrink_to_32(x) \
952 (flip_needed ? (Lisp_Object)flip_32bits((int32_t)flip_64bits(x)) : \
953 (Lisp_Object)(x))
954
adjust_consheap(void)955 static void adjust_consheap(void)
956 {
957 /*
958 * layout of CONS heap:
959 *
960 * The lowest 32-bit of the heap contains a value "low" that is the offset
961 * (in bytes) of the lowest active data in the heap. From there up to
962 * CSL_PAGE_SIZE the page is just full on pairs of Lisp_Objects.
963 * when allocating within the heap I create new cells downwards, and I
964 * stop as I approach the bottom of the page. I leave SPARE bytes free
965 * in simple cases so that I can overrun that limit a bit in functions that
966 * want to perform up to around 3 cons operations but with only one overflow
967 * test.
968 *
969 * On a temporary basis when loading a 64-bit image into a 32-bit system I
970 * can create a double-sized page where the top limit is 2*CSL_PAGE_SIZE
971 * and I will need some way to identify that when I come to garbage collect.
972 */
973 nil_as_base
974 int32_t page_number;
975 for (page_number = 0; page_number < heap_pages_count; page_number++)
976 { void *page = heap_pages[page_number];
977 char *low = (char *)quadword_align_up((intptr_t)page);
978 char *start = low +
979 (converting_to_64 ? 2*CSL_PAGE_SIZE : CSL_PAGE_SIZE);
980 int32_t len = flip_32((uint32_t)car32(low));
981 char *fr;
982 if (SIXTY_FOUR_BIT && converting_to_64)
983 {
984 /* If I am converting from a 32-bit image to a 64-bit one I need to
985 * expand each cell into one that is double its width. And when I do so
986 * here I will need to reflect that the items stored have not yet had
987 * any byte-order corrections applied.
988 */
989 char *oldp = low + CSL_PAGE_SIZE;
990 char *newp = low + 2*CSL_PAGE_SIZE;
991 fr = low + len;
992 /*
993 * The "-8" and "-16" above reflect the size of Cons cells in the new and
994 * old heap. So oldp points to the top existing 32-bit cell, and newp to
995 * where it must be copied to. fr points to the lowest cell in use in the
996 * 32-bit world. Note that each cell is copied to a location that has
997 * exactly twice the offset from the start of page that it originally had.
998 */
999 while (oldp >= fr)
1000 { oldp -= 4;
1001 newp -= 8;
1002 *(Lisp_Object *)newp = expand_to_64(*(int32_t *)oldp);
1003 oldp -= 4;
1004 newp -= 8;
1005 *(Lisp_Object *)newp = expand_to_64(*(int32_t *)oldp);
1006 }
1007 /*
1008 * Done! By copying from the top downwards I will never overwrite what I
1009 * am reading from. Now the low point of the new heap should be just
1010 * twice the original value.
1011 */
1012 len *= 2;
1013 }
1014 else if (converting_to_32)
1015 {
1016 /*
1017 * If the original image was a 64-bit one but the new one is 32-bits I just
1018 * need to truncate every cell to 32-bits and fill in the gaps that are
1019 * left with something safe. Well the gaps should in fact never get inspected
1020 * and so leaving mess in them ought to be OK - but of I look forward to
1021 * a future potential conservative garbage collectoe that may change at
1022 * least slightly, so I will try to be tidy here. The bit-pattern I use
1023 * to fill, 0x01000001 remains unchanged when byte-flipped and denotes
1024 * a fixnum either way.
1025 */
1026 fr = low + len;
1027 while (fr < start)
1028 { *(Lisp_Object *)fr = shrink_to_32(*(int64_t *)fr);
1029 *(Lisp_Object *)(fr+4) = shrink_to_32(*(int64_t *)(fr+8));
1030 *(Lisp_Object *)(fr+8) =
1031 *(Lisp_Object *)(fr+12) = 0x01000001;
1032 fr += 16;
1033 }
1034 }
1035 car32(low) = len;
1036 fr = low + len;
1037 fringe = (Lisp_Object)fr;
1038 heaplimit = (Lisp_Object)(low + SPARE);
1039 #ifdef DEBUG_WIDTH
1040 { int32_t *w = (int32_t *)fringe;
1041 printf("Consheap\n");
1042 while ((char *)w < start)
1043 { printf("%p %.8x: %.8x%.8x %.8x%.8x\n",
1044 w, (int)((char *)w-low), w[1], w[0], w[3], w[2]);
1045 w += 4;
1046 }
1047 printf("\n");
1048 }
1049 #endif
1050 while (fr < start)
1051 { adjust((Lisp_Object *)fr);
1052 fr += sizeof(Lisp_Object);
1053 }
1054 #ifdef DEBUG_WIDTH
1055 { int32_t *w = (int32_t *)fringe;
1056 printf("Adjusted Consheap\n");
1057 while ((char *)w < start)
1058 { printf("%p %.8x: %.8x%.8x %.8x%.8x\n",
1059 w, (int)((char *)w-low), w[1], w[0], w[3], w[2]);
1060 w += 4;
1061 }
1062 printf("\n");
1063 }
1064 #endif
1065 }
1066 }
1067
1068 entry_point1 entries_table1[] =
1069 {
1070 /*
1071 * All values that can go in the function cells of symbols to stand for
1072 * special interpreter activity are kept here. In most cases where there
1073 * is an entrypoint there is a corresponding one that behaves just the
1074 * same except that it has tracing enabled.
1075 */
1076 {0, "illegal"},
1077 {undefined1, "undefined1"},
1078 {autoload1, "autoload1"},
1079 {interpreted1, "interpreted1"},
1080 {traceinterpreted1, "traceinterpreted1"},
1081 {double_interpreted1, "double_interpreted1"},
1082 {funarged1, "funarged1"},
1083 {tracefunarged1, "tracefunarged1"},
1084 {double_funarged1, "double_funarged1"},
1085 {bytecoded1, "bytecoded1"},
1086 {tracebytecoded1, "tracebytecoded1"},
1087 {double_bytecoded1, "double_bytecoded1"},
1088 {byteopt1, "byteopt1"},
1089 {tracebyteopt1, "tracebyteopt1"},
1090 {double_byteopt1, "double_byteopt1"},
1091 {hardopt1, "hardopt1"},
1092 {tracehardopt1, "tracehardopt1"},
1093 {double_hardopt1, "double_hardopt1"},
1094 {byteoptrest1, "byteoptrest1"},
1095 {tracebyteoptrest1, "tracebyteoptrest1"},
1096 {double_byteoptrest1, "double_byteoptrest1"},
1097 {hardoptrest1, "hardoptrest1"},
1098 {tracehardoptrest1, "tracehardoptrest1"},
1099 {double_hardoptrest1, "double_hardoptrest1"},
1100 {too_few_2, "too_few_2"},
1101 {wrong_no_0a, "wrong_no_0a"},
1102 {wrong_no_3a, "wrong_no_3a"},
1103 {wrong_no_na, "wrong_no_na"},
1104
1105 /*
1106 * The batch here relate to function re-work that discards unwanted
1107 * extra arguments.
1108 */
1109 {f1_as_0, "1->0"},
1110 {f1_as_1, "1->1"},
1111 #ifdef JIT
1112 {jitcompileme1, "jitcompileme1"},
1113 #endif
1114 #ifdef CJAVA
1115 {java1, "java1"},
1116 #endif
1117 {NULL, "dummy"}
1118 };
1119
1120 #define entry_table_size1 (sizeof(entries_table1)/sizeof(entries_table1[0]))
1121
1122 entry_point2 entries_table2[] =
1123 {
1124 {0, "illegal"},
1125 {undefined2, "undefined2"},
1126 {autoload2, "autoload2"},
1127 {interpreted2, "interpreted2"},
1128 {traceinterpreted2, "traceinterpreted2"},
1129 {double_interpreted2, "double_interpreted2"},
1130 {funarged2, "funarged2"},
1131 {tracefunarged2, "tracefunarged2"},
1132 {double_funarged2, "double_funarged2"},
1133 {bytecoded2, "bytecoded2"},
1134 {tracebytecoded2, "tracebytecoded2"},
1135 {double_bytecoded2, "double_bytecoded2"},
1136 {byteopt2, "byteopt2"},
1137 {tracebyteopt2, "tracebyteopt2"},
1138 {double_byteopt2, "double_byteopt2"},
1139 {hardopt2, "hardopt2"},
1140 {tracehardopt2, "tracehardopt2"},
1141 {double_hardopt2, "double_hardopt2"},
1142 {byteoptrest2, "byteoptrest2"},
1143 {tracebyteoptrest2, "tracebyteoptrest2"},
1144 {double_byteoptrest2, "double_byteoptrest2"},
1145 {hardoptrest2, "hardoptrest2"},
1146 {tracehardoptrest2, "tracehardoptrest2"},
1147 {double_hardoptrest2, "double_hardoptrest2"},
1148 {too_many_1, "too_many_1"},
1149 {wrong_no_0b, "wrong_no_0b"},
1150 {wrong_no_3b, "wrong_no_3b"},
1151 {wrong_no_nb, "wrong_no_nb"},
1152 /*
1153 * The batch here relate to function re-work that discards unwanted
1154 * extra arguments.
1155 */
1156 {f2_as_0, "2->0"},
1157 {f2_as_1, "2->1"},
1158 {f2_as_2, "2->2"},
1159 #ifdef JIT
1160 {jitcompileme2, "jitcompileme2"},
1161 #endif
1162 #ifdef CJAVA
1163 {java2, "java2"},
1164 #endif
1165 {NULL, "dummy"}
1166 };
1167
1168 #define entry_table_size2 (sizeof(entries_table2)/sizeof(entries_table2[0]))
1169
1170 entry_pointn entries_tablen[] =
1171 {
1172 {0, "illegal"},
1173 {undefinedn, "undefinedn"},
1174 {autoloadn, "autoloadn"},
1175 {interpretedn, "interpretedn"},
1176 {traceinterpretedn, "traceinterpretedn"},
1177 {double_interpretedn, "double_interpretedn"},
1178 {funargedn, "funargedn"},
1179 {tracefunargedn, "tracefunargedn"},
1180 {double_funargedn, "double_funargedn"},
1181 {bytecoded0, "bytecoded0"},
1182 {tracebytecoded0, "tracebytecoded0"},
1183 {double_bytecoded0, "double_bytecoded0"},
1184 {bytecoded3, "bytecoded3"},
1185 {tracebytecoded3, "tracebytecoded3"},
1186 {double_bytecoded3, "double_bytecoded3"},
1187 {bytecodedn, "bytecodedn"},
1188 {tracebytecodedn, "tracebytecodedn"},
1189 {double_bytecodedn, "double_bytecodedn"},
1190 {byteoptn, "byteoptn"},
1191 {tracebyteoptn, "tracebyteoptn"},
1192 {double_byteoptn, "double_byteoptn"},
1193 {hardoptn, "hardoptn"},
1194 {tracehardoptn, "tracehardoptn"},
1195 {double_hardoptn, "double_hardoptn"},
1196 {byteoptrestn, "byteoptrestn"},
1197 {tracebyteoptrestn, "tracebyteoptrestn"},
1198 {double_byteoptrestn, "double_byteoptrestn"},
1199 {hardoptrestn, "hardoptrestn"},
1200 {tracehardoptrestn, "tracehardoptrestn"},
1201 {double_hardoptrestn, "double_hardoptrestn"},
1202 {wrong_no_1, "wrong_no_1"},
1203 {wrong_no_2, "wrong_no_2"},
1204 /*
1205 * The batch here relate to function variants that discard unwanted
1206 * extra arguments and call something else.
1207 */
1208 {f0_as_0, "0->0"},
1209 {f3_as_0, "3->0"},
1210 {f3_as_1, "3->1"},
1211 {f3_as_2, "3->2"},
1212 {f3_as_3, "3->3"},
1213 #ifdef JIT
1214 {jitcompileme0, "jitcompileme0"},
1215 {jitcompileme3, "jitcompileme3"},
1216 {jitcompilemen, "jitcompilemen"},
1217 #endif
1218 #ifdef CJAVA
1219 {java0, "java0"},
1220 {java3, "java3"},
1221 {javan, "javan"},
1222 #endif
1223 {NULL, "dummy"}
1224 };
1225
1226 #define entry_table_sizen (sizeof(entries_tablen)/sizeof(entries_tablen[0]))
1227
1228 entry_pointn entries_tableio[] =
1229 {
1230 {0, "illegal"},
1231 {(void *)char_from_illegal, "char_from_illegal"},
1232 {(void *)char_to_illegal, "char_to_illegal"},
1233 {(void *)read_action_illegal, "read_action_illegal"},
1234 {(void *)write_action_illegal, "write_action_illegal"},
1235 {(void *)char_from_terminal, "char_from_terminal"},
1236 {(void *)char_to_terminal, "char_to_terminal"},
1237 {(void *)read_action_terminal, "read_action_terminal"},
1238 {(void *)write_action_terminal, "write_action_terminal"},
1239 {(void *)char_from_file, "char_from_file"},
1240 {(void *)char_to_file, "char_to_file"},
1241 {(void *)read_action_file, "read_action_file"},
1242 {(void *)read_action_output_file, "read_action_output_file"},
1243 {(void *)write_action_file, "write_action_file"},
1244 {(void *)binary_outchar, "binary_outchar"},
1245 {(void *)char_from_list, "char_from_list"},
1246 {(void *)char_to_list, "char_to_list"},
1247 {(void *)code_to_list, "code_to_list"},
1248 {(void *)read_action_list, "read_action_list"},
1249 {(void *)write_action_list, "write_action_list"},
1250 {(void *)count_character, "count_character"},
1251 {(void *)char_to_pipeout, "char_to_pipeout"},
1252 {(void *)write_action_pipe, "write_action_pipe"},
1253 {(void *)char_from_synonym, "char_from_synonym"},
1254 {(void *)char_to_synonym, "char_to_synonym"},
1255 {(void *)read_action_synonym, "read_action_synonym"},
1256 {(void *)write_action_synonym, "write_action_synonym"},
1257 {(void *)char_from_concatenated, "char_from_concatenated"},
1258 {(void *)char_to_broadcast, "char_to_broadcast"},
1259 {(void *)read_action_concatenated, "read_action_concatenated"},
1260 {(void *)write_action_broadcast, "write_action_broadcast"},
1261 {(void *)char_from_echo, "char_from_echo"},
1262 {NULL, "dummy"}
1263 };
1264
1265 #define entry_table_sizeio (sizeof(entries_tableio)/sizeof(entries_tableio[0]))
1266
1267
1268
1269 static struct entry_lookup1
1270 { int32_t code;
1271 one_args *entry;
1272 char *s;
1273 } entry_lookup1[entry_table_size1];
1274
1275 static struct entry_lookup2
1276 { int32_t code;
1277 two_args *entry;
1278 char *s;
1279 } entry_lookup2[entry_table_size2];
1280
1281 static struct entry_lookupn
1282 { int32_t code;
1283 n_args *entry;
1284 char *s;
1285 } entry_lookupn[entry_table_sizen];
1286
order_lookup_entries(void const * aa,void const * bb)1287 static int MS_CDECL order_lookup_entries(void const *aa, void const *bb)
1288 {
1289 /*
1290 * I rely here on having entry_lookup[1,2,n] all the same shape so that
1291 * when I want to sort I only use one comparison function.
1292 */
1293 struct entry_lookup1 *a = (struct entry_lookup1 *)aa,
1294 *b = (struct entry_lookup1 *)bb;
1295 intptr_t ap = (intptr_t)a->entry, bp = (intptr_t)b->entry;
1296 if (ap < bp) return -1;
1297 else if (ap > bp) return 1;
1298 else return 0;
1299 }
1300
set_up_entry_lookup(void)1301 void set_up_entry_lookup(void)
1302 /*
1303 * This makes a sorted version of entries_table. Since the table is
1304 * only a few dozen words long it hardly seems worth being too clever,
1305 * but the C library provides qsort() for me so I use it.
1306 */
1307 {
1308 int i;
1309 for (i=0; i<entry_table_size1; i++)
1310 { entry_lookup1[i].code = i;
1311 entry_lookup1[i].entry = entries_table1[i].p;
1312 entry_lookup1[i].s = entries_table1[i].s;
1313 }
1314 qsort((void *)entry_lookup1,
1315 entry_table_size1, sizeof(struct entry_lookup1),
1316 order_lookup_entries);
1317 for (i=0; i<entry_table_size2; i++)
1318 { entry_lookup2[i].code = i;
1319 entry_lookup2[i].entry = entries_table2[i].p;
1320 entry_lookup2[i].s = entries_table2[i].s;
1321 }
1322 qsort((void *)entry_lookup2,
1323 entry_table_size2, sizeof(struct entry_lookup2),
1324 order_lookup_entries);
1325 for (i=0; i<entry_table_sizen; i++)
1326 { entry_lookupn[i].code = i;
1327 entry_lookupn[i].entry = entries_tablen[i].p;
1328 entry_lookupn[i].s = entries_tablen[i].s;
1329 }
1330 qsort((void *)entry_lookupn,
1331 entry_table_sizen, sizeof(struct entry_lookupn),
1332 order_lookup_entries);
1333 }
1334
code_up_fn1(one_args * e)1335 int32_t code_up_fn1(one_args *e)
1336 {
1337 int low = 0, high = entry_table_size1-1;
1338 while (low < high)
1339 { int mid = (high + low)/2;
1340 intptr_t s = (intptr_t)entry_lookup1[mid].entry;
1341 if (s == (intptr_t)e) return entry_lookup1[mid].code;
1342 if ((intptr_t)s < (intptr_t)e) low = mid + 1;
1343 else high = mid - 1;
1344 }
1345 if (low == high &&
1346 entry_lookup1[low].entry == e) return entry_lookup1[low].code;
1347 else return 0;
1348 }
1349
code_up_fn2(two_args * e)1350 int32_t code_up_fn2(two_args *e)
1351 {
1352 int low = 0, high = entry_table_size2-1;
1353 while (low < high)
1354 { int mid = (high + low)/2;
1355 intptr_t s = (intptr_t)entry_lookup2[mid].entry;
1356 if (s == (intptr_t)e) return entry_lookup2[mid].code;
1357 if ((intptr_t)s < (intptr_t)e) low = mid + 1;
1358 else high = mid - 1;
1359 }
1360 if (low == high &&
1361 entry_lookup2[low].entry == e) return entry_lookup2[low].code;
1362 else return 0;
1363 }
1364
code_up_fnn(n_args * e)1365 int32_t code_up_fnn(n_args *e)
1366 {
1367 int low = 0, high = entry_table_sizen-1;
1368 while (low < high)
1369 { int mid = (high + low)/2;
1370 intptr_t s = (intptr_t)entry_lookupn[mid].entry;
1371 if (s == (intptr_t)e) return entry_lookupn[mid].code;
1372 if ((intptr_t)s < (intptr_t)e) low = mid + 1;
1373 else high = mid - 1;
1374 }
1375 if (low == high &&
1376 entry_lookupn[low].entry == e) return entry_lookupn[low].code;
1377 else return 0;
1378 }
1379
code_up_io(void * e)1380 int32_t code_up_io(void *e)
1381 {
1382 int i;
1383 for (i=0; i<entry_table_sizen; i++)
1384 { if (entries_tableio[i].p == e) return i;
1385 }
1386 return 0;
1387 }
1388
1389 #define make_padder(n) (TYPE_VEC8 + ((n)<<10) + TAG_ODDS)
1390
shrink_vecheap_page_to_32(char * p,char * fr)1391 static void shrink_vecheap_page_to_32(char *p, char *fr)
1392 {
1393 if (!SIXTY_FOUR_BIT)
1394 { int32_t *newp; /* specific widths used here */
1395 int64_t *oldp;
1396 int i, len;
1397 while (p < fr)
1398 {
1399 /* Fetch header as a 64-bit value, truncate to 32-bit */
1400 Header h = (Header)flip_64(*(int64_t *)p), h1;
1401 #ifdef DEBUG_WIDTH
1402 /*
1403 * I use printf() not term_printf() here because at the stage I run this
1404 * code I can not be confident that Lisp-style streams are fully set up.
1405 * And the debug display here is only DEBUG display and so I do not feel
1406 * to bad if it is generated in a way that could conflict with use of a
1407 * windowed application.
1408 */
1409 printf("p=%p Header = %.16llx = %.16llx (is_sym=%d)\n",
1410 p, *(long long *)p, (long long)h, (int)is_symbol_header(h));
1411 printf("Length = %d\n", (int)length_of_header(h));
1412 for(i=-32; i<=32; i+=4)
1413 { if (i == 0) printf("\n%p: ", p);
1414 printf("%.8x ", *(int32_t *)(p+i));
1415 if (i==0) printf("\n");
1416 }
1417 printf("\n");
1418 fflush(stdout);
1419 if (!is_symbol_header(h) && length_of_header(h) == 0) exit(8);
1420 #endif
1421 if (is_symbol_header(h))
1422 {
1423 /*
1424 * Symbol headers do not contain any explicit length info and so do not
1425 * need to be changed at all here.
1426 */
1427 #ifdef DEBUG_WIDTH
1428 for (i=0; i<80; i+=4)
1429 { printf("%.8x ", *(int32_t *)(p+i));
1430 if (((i/4)%8) == 7) printf("\n");
1431 }
1432 printf("\n");
1433 #endif
1434 *(Lisp_Object *)p = flip_32(h); /* write back header */
1435 /*
1436 * I do not know if I police it anywhere, but if one tried to mix images from
1437 * COMMON and plain mode the result would be a crash, if only because symbols
1438 * are represented as a different length. That is because in Common Lisp mode
1439 * there has to be an extra field to hold the identity of the package that
1440 * a symbol lives in.
1441 */
1442 for (i=1; i<(symhdr_length/4); i++)
1443 { ((Lisp_Object *)p)[i] =
1444 shrink_to_32(((int64_t *)p)[i]);
1445 }
1446 /*
1447 * Insert a padding vector - a byte-vector should be a safe case to use. I
1448 * provide myself with a "make_padder" macro to create the relevant header.
1449 * I do not tidy up the contents of the padder block, but since the block is
1450 * tagged as a vector of 8 bit bytes this does not matter.
1451 */
1452 *(Lisp_Object *)(p+symhdr_length) =
1453 flip_32(make_padder(symhdr_length));
1454 #ifdef DEBUG_WIDTH
1455 for (i=0; i<80; i+=4)
1456 { printf("%.8x ", *(int32_t *)(p+i));
1457 if (((i/4)%8) == 7) printf("\n");
1458 }
1459 printf("\n");
1460 #endif
1461 p += 2*symhdr_length;
1462 }
1463 else switch (type_of_header(h))
1464 {
1465 /*
1466 * If I do not have a symbol then I have some sort of vector where the
1467 * header word contains length information. I need to discriminate here
1468 * between all the cases where the following data is in 64-bit fields
1469 * (and so needs truncating to fit in 32) as against cases where the
1470 * follow-on data is in 8, 16 or 32-bit chunks in a format that does not
1471 * depend on the word-length of the host machine. It seems fairly important
1472 * that I cover every possible sort of tag that could ever exist.
1473 */
1474 #ifdef COMMON
1475 case TYPE_RATNUM:
1476 case TYPE_COMPLEX_NUM:
1477 #endif
1478 case TYPE_HASH:
1479 case TYPE_SIMPLE_VEC:
1480 case TYPE_ARRAY:
1481 case TYPE_STRUCTURE:
1482 case TYPE_MIXED1:
1483 case TYPE_MIXED2:
1484 case TYPE_MIXED3:
1485 case TYPE_STREAM:
1486 /* case TYPE_LITVEC: */
1487 /*
1488 * "len" will be the length of the old 64-bit version, and in the 64-bit
1489 * world there will never be a padding word at the end of a vector.
1490 */
1491 len = doubleword_align_up(length_of_header(h));
1492 #ifdef DEBUG_WIDTH
1493 printf("Shrinking vec to 32 bits:\n");
1494 for (i=0; i<len; i+=4)
1495 { printf("%.8x ", *(int32_t *)(p+i));
1496 if (((i/4) % 8) == 7) printf("\n");
1497 }
1498 printf("\n");
1499 #endif
1500 newp = (int32_t *)p;
1501 oldp = (int64_t *)p;
1502 for (i=8; i<len; i+=8)
1503 { ++newp;
1504 ++oldp;
1505 *newp = shrink_to_32(*oldp);
1506 }
1507 /*
1508 * Now the length needed in the new header will be (newp-p+4)
1509 */
1510 h1 = (h & 0x3ff) | ((((char *)newp)-p+4)<<10);
1511 #ifdef DEBUG_WIDTH
1512 printf("new object length = %d, h=%.8x\n",
1513 (int)(((char *)newp)-p+4), (int)h1);
1514 #endif
1515 *(Lisp_Object *)p = flip_32(h1); /* write back header */
1516 if ((4 & (intptr_t)newp) == 0)
1517 *++newp = SPID_NIL; /* fill to doubleword */
1518 p += len;
1519 /*
1520 * Now I must put in a padding object if needed to fill any gap left.
1521 * There would be no gap if the original vector had length zero, otherwise
1522 * I put in something that looks like a vector of bytes or like BPS.
1523 */
1524 newp++;
1525 if (p != (char *)newp)
1526 *newp = flip_32(make_padder(p - (char *)newp));
1527 #ifdef DEBUG_WIDTH
1528 printf("AFTER shrinking vec to 32 bits:\n");
1529 for (i=0; i<len; i+=4)
1530 { printf("%.8x ", *(int32_t *)(p-len+i));
1531 if (((i/4) % 8) == 7) printf("\n");
1532 }
1533 printf("\n");
1534 #endif
1535 break;
1536 case TYPE_STRING:
1537 #ifdef DEBUG_WIDTH
1538 printf("String: %p: \"%s\"\n", p, ((char *)p)+2*CELL);
1539 #endif
1540 case TYPE_BIGNUM:
1541 case TYPE_VEC32:
1542 case TYPE_VEC16:
1543 /* case TYPE_VEC8: same as TYPE_BPS */
1544 case TYPE_BPS:
1545 case TYPE_SPARE:
1546 case TYPE_SP:
1547 #ifdef COMMON
1548 case TYPE_BITVEC1:
1549 case TYPE_BITVEC2:
1550 case TYPE_BITVEC3:
1551 case TYPE_BITVEC4:
1552 case TYPE_BITVEC5:
1553 case TYPE_BITVEC6:
1554 case TYPE_BITVEC7:
1555 case TYPE_BITVEC8:
1556 case TYPE_SINGLE_FLOAT:
1557 case TYPE_LONG_FLOAT:
1558 #endif
1559 case TYPE_DOUBLE_FLOAT:
1560 case TYPE_FLOAT32:
1561 case TYPE_FLOAT64:
1562 len = doubleword_align_up(length_of_header(h));
1563 /* I copy all the stuff that will go into the 32-bit version */
1564 #ifdef DEBUG_WIDTH
1565 for (i=-16; i<=8; i+=4) printf("%.8x ", *(int32_t *)(p+len+i)); printf("\n");
1566 #endif
1567 for (i=4; i<len-4; i+=4)
1568 *(uint32_t *)(p+i) =
1569 *(uint32_t *)(p+i+4);
1570 /*
1571 * These all shrink by one word because their header word has become
1572 * 4 bytes rather than 8 bytes wide. This certainly means that there is
1573 * a 32-bit word beyond the stuff that I copy that I can and should fill
1574 * with zero. Sometimes this will end up counting as part of the new
1575 * 32-bit representation, sometimes it will be part of a gap left over.
1576 * If I were very keen I could put in a zero as required when it is the
1577 * word used to round up a vector size of an even number of words, and
1578 * make_padder(8) when it represents a gap between real items.
1579 */
1580 *(uint32_t *)(p+len-4) = 0;
1581 #ifdef DEBUG_WIDTH
1582 for (i=-16; i<=8; i+=4) printf("%.8x ", *(int32_t *)(p+len+i)); printf("\n");
1583 #endif
1584 /*
1585 * Here I write the header word back into memory shortening things by
1586 * 4 bytes because the header has changed from a 64 to a 32-bit value.
1587 * But I then expect to find the next item the distance on that the
1588 * 64-bit header indicated.
1589 */
1590 #ifdef DEBUG_WIDTH
1591 printf("h=%.8x h1=%.8x\n", (int)h, (int)h - (4<<10));
1592 #endif
1593 *(Lisp_Object *)p = flip_32(h - (4<<10)); /* write back header */
1594 #ifdef DEBUG_WIDTH
1595 printf("move on after binary stuff by %d\n", len);
1596 printf("len=%d len-4=%d\n", (int)len, (int)doubleword_align_up(length_of_header(h)-4));
1597 #endif
1598 /* Test if the vector has shrunk in memory - if so insert padding */
1599 if (len != doubleword_align_up(length_of_header(h)-4))
1600 *(int32_t *)(p + len - 8) = flip_32(make_padder(8));
1601 #ifdef DEBUG_WIDTH
1602 for (i=-16; i<=8; i+=4) printf("%.8x ", *(int32_t *)(p+len+i)); printf("\n");
1603 #endif
1604 p += len;
1605 break;
1606 default:
1607 printf("Unrecognized type info in vector header %.8x\n", (int32_t)h);
1608 fflush(stdout);
1609 my_exit(4);
1610 }
1611 }
1612 }
1613 }
1614
1615 /*
1616 * In what follows low will point to the 64-bit vector to be filled in
1617 * and olow to the 32-bit one being copied. fr is the fringe in the
1618 * 64-bit world. Much of the logic here is closely related to that in
1619 * shrink_vecheap_page. If SIXTY_FOUR_BIT could be a compile-time
1620 * constant I could use #ifdef to avoid compiling one or the other
1621 * of these. As things are I can get most of the benefit of that if
1622 * I have a good optimising compiler.
1623 */
1624
expand_vecheap_page(char * low,char * olow,char * fr)1625 static void expand_vecheap_page(char *low, char *olow, char *fr)
1626 {
1627 if (SIXTY_FOUR_BIT)
1628 {
1629 int64_t *newp = (int64_t *)low; /* specific widths used here */
1630 int32_t *oldp = (int32_t *)olow;
1631 int i, len;
1632 while ((char *)newp < fr)
1633 {
1634 /* Fetch header as a 32-bit value, widen to 64-bit */
1635 Header h = (Header)flip_32(*oldp), h1;
1636 #ifdef DEBUG_WIDTH
1637 /*
1638 * I use printf() not term_printf() here because at the stage I run this
1639 * code I can not be confident that Lisp-style streams are fully set up.
1640 * And the debug display here is only DEBUG display and so I do not feel
1641 * to bad if it is generated in a way that could conflict with use of a
1642 * windowed application.
1643 */
1644 printf("oldp=%p Header = %.16llx (%d)\n", oldp, (long long)h, (int)is_symbol_header(h));
1645 printf("Length = %d\n", (int)length_of_header(h));
1646 for(i=-32; i<=32; i+=4)
1647 { if (i == 0) printf("\n%p: ", oldp);
1648 printf("%.8x ", *(int32_t *)(((char *)oldp)+i));
1649 if (i == 0) printf("\n");
1650 }
1651 printf("\n");
1652 fflush(stdout);
1653 if (!is_symbol_header(h) && length_of_header(h) == 0) exit(8);
1654 #endif
1655 if (is_symbol_header(h))
1656 {
1657 /*
1658 * Symbol headers do not contain any explicit length info and so do not
1659 * need to be changed at all here.
1660 */
1661 #ifdef DEBUG_WIDTH
1662 for (i=0; i<80; i+=4)
1663 { printf("%.8x ", *(int32_t *)((char *)oldp+i));
1664 if (((i/4)%8) == 7) printf("\n");
1665 }
1666 printf("\n");
1667 #endif
1668 *newp = flip_64(h); /* write back header */
1669 /*
1670 * I do not know if I police it anywhere, but if one tried to mix images from
1671 * COMMON and plain mode the result would be a crash, if only because symbols
1672 * are represented as a different length. That is because in Common Lisp mode
1673 * there has to be an extra field to hold the identity of the package that
1674 * a symbol lives in.
1675 */
1676 for (i=1; i<(symhdr_length/8); i++)
1677 { newp[i] = expand_to_64(oldp[i]);
1678 }
1679 oldp = (int32_t *)((char *)oldp + symhdr_length/2);
1680 newp = (int64_t *)((char *)newp + symhdr_length);
1681 }
1682 else switch (type_of_header(h))
1683 {
1684 /*
1685 * If I do not have a symbol then I have some sort of vector where the
1686 * header word contains length information. I need to discriminate here
1687 * between all the cases where the following data is in 64-bit fields
1688 * (and so needs truncating to fit in 32) as against cases where the
1689 * follow-on data is in 8, 16 or 32-bit chunks in a format that does not
1690 * depend on the word-length of the host machine. It seems fairly important
1691 * that I cover every possible sort of tag that could ever exist.
1692 */
1693 #ifdef COMMON
1694 case TYPE_RATNUM:
1695 case TYPE_COMPLEX_NUM:
1696 #endif
1697 case TYPE_HASH:
1698 case TYPE_SIMPLE_VEC:
1699 case TYPE_ARRAY:
1700 case TYPE_STRUCTURE:
1701 case TYPE_MIXED1:
1702 case TYPE_MIXED2:
1703 case TYPE_MIXED3:
1704 case TYPE_STREAM:
1705 /* case TYPE_LITVEC: */
1706 /*
1707 * "len" will be the length of the old 32-bit version, and the data in
1708 * memory may have a padder word after that. However the 64-bit version I
1709 * copy this into never needs a padder word as part of the vector itself,
1710 * but to preserve layout it may need one after it. Note that for all
1711 * these sorts of vector the length should already be a multiple of 4. I
1712 * remind myself of that because strings (for instance) can have odd lengths
1713 * recorded in the header.
1714 */
1715 len = length_of_header(h);
1716 *newp++ = flip_64((h & 0x3ff) + (len<<11)); /* double length */
1717 oldp++;
1718 for (i=4; i<len; i+=4)
1719 { *newp++ = expand_to_64(*oldp);
1720 oldp++;
1721 }
1722 /*
1723 * Now if the 32-bit vector has a length that corresponded to an even
1724 * number of cells of data (so with the header that makes an odd number
1725 * in all) I need to skip over the padder word in the 32-bit space and
1726 * write in something safe in the 64-bit one.
1727 */
1728 if ((len & 4) != 0)
1729 { *newp++ = flip_64(make_padder(8));
1730 oldp++;
1731 }
1732 break;
1733 case TYPE_STRING:
1734 #ifdef DEBUG_WIDTH
1735 printf("String: %p: \"%s\"\n", oldp, ((char *)oldp)+4);
1736 #endif
1737 case TYPE_BIGNUM:
1738 case TYPE_VEC32:
1739 case TYPE_VEC16:
1740 /* case TYPE_VEC8: same as TYPE_BPS */
1741 case TYPE_BPS:
1742 case TYPE_SPARE:
1743 case TYPE_SP:
1744 #ifdef COMMON
1745 case TYPE_BITVEC1:
1746 case TYPE_BITVEC2:
1747 case TYPE_BITVEC3:
1748 case TYPE_BITVEC4:
1749 case TYPE_BITVEC5:
1750 case TYPE_BITVEC6:
1751 case TYPE_BITVEC7:
1752 case TYPE_BITVEC8:
1753 case TYPE_SINGLE_FLOAT:
1754 case TYPE_LONG_FLOAT:
1755 #endif
1756 case TYPE_DOUBLE_FLOAT:
1757 case TYPE_FLOAT32:
1758 case TYPE_FLOAT64:
1759 /*
1760 * The effects of alignment and passing here are distinctly odd. A 32-bit
1761 * item can be in one of two forms
1762 * || header | d0 || d1 | - || length 4 mod 8
1763 * or || header | d0 || d1 | d2 || length 8 mod 8
1764 * where the double vertical bars denote doubleword boundaries and the "-"
1765 * is padder data.
1766 *
1767 * In the 64-bit world these two cases map onto
1768 * || h e a d e r || d0 | d1 ||
1769 * and || h e a d e r || d0 | d1 || d2 | - ||
1770 * in each case a dummy item must be places after to fill up space to where
1771 * the next new item will fall. Well actually there is a special case
1772 * || header | d0 ||
1773 * -> || h e a d e r || d0 | - ||
1774 * does not need that filler.
1775 * An item in the 32-bit world may sometimes only partly fill its final
1776 * 32-bit word. In this part of the code I can copy data as raw 32-bit
1777 * values - any byte-order adjustments get done later.
1778 */
1779 len = word_align_up(length_of_header(h));
1780 /*
1781 * The vector increases in size of 4 bytes because the header-word is
1782 * twice as wide.
1783 */
1784 *newp++ = flip_64(h + (4<<10));
1785 oldp++;
1786 /* Now newp, oldp point at the raw data. Copy it down */
1787 for (i=4; i<len; i+=4)
1788 { *((int32_t *)newp) = *oldp;
1789 newp = (int64_t *)(((char *)newp)+4);
1790 oldp++;
1791 }
1792 /*
1793 * Sometimes I need to pad out the new version to be a whole number of
1794 * doublewords.
1795 */
1796 if ((len & 4) == 0)
1797 { *((int32_t *)newp) = 0;
1798 newp = (int64_t *)(((char *)newp)+4);
1799 }
1800 else oldp++;
1801 /*
1802 * Now I have oldp and newp both doubleword aligned again. In many
1803 * cases I now need to insert a dummy header at newp so that items in the
1804 * new space all end up at twice the address they had in the old.
1805 */
1806 len = 2*doubleword_align_up(len) -
1807 doubleword_align_up(len+4);
1808 /* len is now the amount of gap to fill */
1809 if (len != 0)
1810 { *newp = flip_64(make_padder(len));
1811 newp = (int64_t *)(((char *)newp) + len);
1812 }
1813 #ifdef DEBUG_WIDTH
1814 for (i=-16; i<=8; i+=4) printf("%.8x ", *(int32_t *)(newp+len+i)); printf("\n");
1815 #endif
1816 break;
1817 default:
1818 printf("Unrecognized type info in vector header %.8x\n", (int32_t)h);
1819 fflush(stdout);
1820 my_exit(4);
1821 }
1822 }
1823 }
1824 }
1825
1826
adjust_vecheap(void)1827 static void adjust_vecheap(void)
1828 {
1829 nil_as_base
1830 int32_t page_number;
1831 intptr_t iw;
1832 for (page_number = 0; page_number < vheap_pages_count; page_number++)
1833 { void *page = vheap_pages[page_number];
1834 char *low = (char *)doubleword_align_up((intptr_t)page);
1835 int32_t len = flip_32((uint32_t)car32(low));
1836 char *fr;
1837 int i;
1838 #ifdef DEBUG_WIDTH
1839 printf("len = %d = %x (%d:%.8x)\n", len, len, car32(low), car32(low));
1840 for (i=0; i<4*32; i+=4)
1841 { printf("%.8x ", *(int32_t *)(low+i));
1842 if ((i/4)%8 == 7) printf("\n");
1843 }
1844 fflush(stdout);
1845 #endif
1846 if (SIXTY_FOUR_BIT && converting_to_64) len *= 2;
1847 car32(low) = len;
1848 fr = low + len;
1849 vfringe = (Lisp_Object)fr;
1850 if (SIXTY_FOUR_BIT && converting_to_64)
1851 vheaplimit = (Lisp_Object)(low + 2*(CSL_PAGE_SIZE - 8));
1852 else vheaplimit = (Lisp_Object)(low + (CSL_PAGE_SIZE - 8));
1853 if (SIXTY_FOUR_BIT && converting_to_64)
1854 { *(Header *)(low+8) = make_padder(8);
1855 /*
1856 * I want all expanded vectors to fall at an address exactly twice
1857 * as far from the page base as they started. Hence the first one must start
1858 * at offset 16 not 8. I put a padder in at 8 to fill the gap.
1859 */
1860 low += 16;
1861 }
1862 else low += 8;
1863 if (converting_to_64)
1864 {
1865 /*
1866 * vecheap allocation is from the low end of the heap upwards, and
1867 * because I have to parse the heap to perform the correct expansion
1868 * I must start from the bottom. To cope with that I have loaded
1869 * my 32-bit heap CSL_PAGE_SIZE bytes up into the double sized page.
1870 * Now when I copy stuff downwards the last item comes from
1871 * low+CSL_PAGE_SIZE+len and it gets written back to low+2*len. So since
1872 * len is at worst CSL_PAGE_SIZE-8 I will not trip over myself - just.
1873 */
1874 expand_vecheap_page(low, low+CSL_PAGE_SIZE-8, fr);
1875 /*
1876 * Well in principle I know how to do this. The actual data is at present in
1877 * the top half of a double-sized page and I need to copy it down towards
1878 * the bottom sign-extended each Lisp_Object and (for tidiness) putting in
1879 * padding when items had been full of binary stuff that did not expand.
1880 */
1881 }
1882 else if (converting_to_32) shrink_vecheap_page_to_32(low, fr);
1883 /*
1884 * Now the data is at least arranged to be the correct width.
1885 */
1886 while (low < fr)
1887 { Header h = flip_bytes(*(Header *)low);
1888 *(Header *)low = h;
1889 if (is_symbol_header(h))
1890 { Lisp_Object ss = (Lisp_Object)(low + TAG_SYMBOL);
1891 adjust(&qvalue(ss));
1892 adjust(&qenv(ss));
1893 adjust(&qpname(ss));
1894 adjust(&qplist(ss));
1895 adjust(&qfastgets(ss));
1896 #ifdef COMMON
1897 adjust(&qpackage(ss));
1898 #endif
1899 /*
1900 * The mess here is because when CSL is re-loaded the position of all
1901 * C-coded entrypoints will very probably have changed since the
1902 * previous run - the set of entrypoints tested for here has to be
1903 * a complete list, except for ones established via "restart.c". Note
1904 * that setup establishes entrypoints later on, so I can afford to leave
1905 * junk in the function cells of things that will be initialised then.
1906 * Thus if a "real" function pointer left over from last time happens
1907 * to look like one of the small integers used here to stand for special
1908 * built-in cases the false-hit I get here is not important.
1909 */
1910 iw = flip_bytes(ifn1(ss));
1911 if (0 < iw && iw < entry_table_size1)
1912 ifn1(ss) = (intptr_t)entries_table1[iw].p;
1913 else ifn1(ss) = (intptr_t)undefined1;
1914 iw = flip_bytes(ifn2(ss));
1915 if (0 < iw && iw < entry_table_size2)
1916 ifn2(ss) = (intptr_t)entries_table2[iw].p;
1917 else ifn2(ss) = (intptr_t)undefined2;
1918 iw = flip_bytes(ifnn(ss));
1919 if (0 < iw && iw < entry_table_sizen)
1920 ifnn(ss) = (intptr_t)entries_tablen[iw].p;
1921 else ifnn(ss) = (intptr_t)undefinedn;
1922 qcount(ss) = flip_bytes(qcount(ss));
1923 low += symhdr_length;
1924 continue;
1925 }
1926 else switch (type_of_header(h))
1927 {
1928 #ifdef COMMON
1929 case TYPE_RATNUM:
1930 case TYPE_COMPLEX_NUM:
1931 adjust((Lisp_Object *)(low+CELL));
1932 adjust((Lisp_Object *)(low+2*CELL));
1933 break;
1934 #endif
1935 case TYPE_HASH:
1936 case TYPE_SIMPLE_VEC:
1937 case TYPE_ARRAY:
1938 case TYPE_STRUCTURE:
1939 for (i=CELL; i<doubleword_align_up(length_of_header(h)); i+=CELL)
1940 adjust((Lisp_Object *)(low+i));
1941 break;
1942 case TYPE_MIXED1:
1943 case TYPE_MIXED2:
1944 case TYPE_MIXED3:
1945 case TYPE_STREAM:
1946 for (i=CELL; i<4*CELL; i+=CELL) adjust((Lisp_Object *)(low+i));
1947 if (!SIXTY_FOUR_BIT)
1948 { for (; i<doubleword_align_up(length_of_header(h)); i+=4)
1949 *(uint32_t *)(low+i) =
1950 flip_bytes(*(uint32_t *)(low+i));
1951 }
1952 if (type_of_header(h) == TYPE_STREAM)
1953 { Lisp_Object ss = (Lisp_Object)(low + TAG_VECTOR);
1954 iw = elt(ss, 4);
1955 if (0 < iw && iw < entry_table_sizeio)
1956 elt(ss, 4) = (intptr_t)entries_tableio[iw].p;
1957 else elt(ss, 4) = (intptr_t)char_to_illegal;
1958 iw = elt(ss, 5);
1959 if (0 < iw && iw < entry_table_sizeio)
1960 elt(ss, 5) = (intptr_t)entries_tableio[iw].p;
1961 else elt(ss, 5) = (intptr_t)write_action_illegal;
1962 iw = elt(ss, 8);
1963 if (0 < iw && iw < entry_table_sizeio)
1964 elt(ss, 8) = (intptr_t)entries_tableio[iw].p;
1965 else elt(ss, 8) = (intptr_t)char_from_illegal;
1966 iw = elt(ss, 9);
1967 if (0 < iw && iw < entry_table_sizeio)
1968 elt(ss, 9) = (intptr_t)entries_tableio[iw].p;
1969 else elt(ss, 9) = (intptr_t)read_action_illegal;
1970 }
1971 break;
1972 case TYPE_BIGNUM:
1973 case TYPE_VEC32:
1974 for (i=CELL; i<doubleword_align_up(length_of_header(h)); i+=4)
1975 *(uint32_t *)(low+i) =
1976 flip_32(*(uint32_t *)(low+i));
1977 break;
1978 case TYPE_VEC16:
1979 for (i=CELL; i<doubleword_align_up(length_of_header(h)); i+=4)
1980 *(uint32_t *)(low+i) =
1981 flip_halfwords(*(uint32_t *)(low+i));
1982 break;
1983 case TYPE_DOUBLE_FLOAT:
1984 /*
1985 * note that this conversion is triggered by the vector header, not by
1986 * the pointer to the object, so punning associated with the pnames of
1987 * un-printed gensyms will not cause any confusion.
1988 */
1989 convert_fp_rep((void *)(low + 8),
1990 old_fp_rep, current_fp_rep, 2);
1991 break;
1992 #ifdef COMMON
1993 case TYPE_SINGLE_FLOAT:
1994 convert_fp_rep((void *)(low + CELL),
1995 old_fp_rep, current_fp_rep, 1);
1996 break;
1997 case TYPE_LONG_FLOAT:
1998 /* Beware - if long floats move up to 3-word values the +8 here will change */
1999 convert_fp_rep((void *)(low + 8),
2000 old_fp_rep, current_fp_rep, 3);
2001 break;
2002 #endif
2003 case TYPE_FLOAT32:
2004 for (i=CELL; i<doubleword_align_up(length_of_header(h)); i+=4)
2005 convert_fp_rep((void *)(low+i),
2006 old_fp_rep, current_fp_rep, 1);
2007 break;
2008 case TYPE_FLOAT64:
2009 for (i=8; i<doubleword_align_up(length_of_header(h)); i+=8)
2010 convert_fp_rep((void *)(low+i),
2011 old_fp_rep, current_fp_rep, 2);
2012 break;
2013 default:
2014 break;
2015 }
2016 low += doubleword_align_up(length_of_header(h));
2017 }
2018 }
2019 }
2020
adjust_bpsheap(void)2021 static void adjust_bpsheap(void)
2022 /*
2023 * This is needed so that (e.g.) headers in the code here get byte-flipped
2024 * if necessary. Also to set codefringe.
2025 * The bpsheap has space allocated in it from the top downwards (for some
2026 * stray historical reason) and so the locic here is not at all the
2027 * same as that used when expanding or squashing the vector heap when
2028 * allowing for word length changes. What a shame!
2029 */
2030 {
2031 nil_as_base
2032 int32_t page_number;
2033 int32_t i;
2034 codelimit = codefringe = 0;
2035 for (page_number = 0; page_number < bps_pages_count; page_number++)
2036 { void *page = bps_pages[page_number];
2037 char *low = (char *)doubleword_align_up((intptr_t)page);
2038 int32_t len = flip_32((uint32_t)car32(low));
2039 char *fr;
2040 /*
2041 * The BPS heap also has to double its size if I am converting to a 64-bit
2042 * machine, ONLY because all the header words in it get larger. The data
2043 * in it is all bytes so remains unaltered.
2044 */
2045 if (SIXTY_FOUR_BIT && converting_to_64) len *= 2;
2046 car32(low) = len;
2047 fr = low + len;
2048 codefringe = (Lisp_Object)fr;
2049 codelimit = (Lisp_Object)(low + 8);
2050 /*
2051 * If the computer that created the image file has the same word length and
2052 * byte order and if I am not keeping environment vectors in the BPS
2053 * heap (and indeed at present I am not) then the page contains only
2054 * BPS vectors which contain binary and do not need any adjustment at all.
2055 * If in the future I do put environment vectors here then I will need to
2056 * scan to adjust all the reference values within them.
2057 */
2058 #ifndef ENVIRONMENT_VECTORS_IN_BPS_HEAP
2059 if (!converting_to_32 && !converting_to_64 && !flip_needed) continue;
2060 #endif
2061 if (SIXTY_FOUR_BIT && converting_to_64)
2062 { char *oldfr = (low + (fr - low)/2 + CSL_PAGE_SIZE);
2063 /*
2064 * Here I will just move the data from where it had to be in the 32-bit world
2065 * to where it will end up in a 64-bit one. I will leave it in whatever byte
2066 * order it is in to start with (and that makes the sign extension process
2067 * a bit odd!). I do things this way so that the subsequent pass can correct
2068 * for byte-order without worrying about much need to move things.
2069 */
2070 while (oldfr < low + 2*CSL_PAGE_SIZE)
2071 { Header h = (Header)flip_32(*(uint32_t *)oldfr);
2072 int32_t len, len32, len64, gap;
2073 len = length_of_header(h); /* 32 bit hdr + actual data */
2074 /*
2075 * Now establish the amount of space that will be used in both 32 and 64
2076 * bit layouts and the size of any padding that will be called for.
2077 */
2078 len32 = doubleword_align_up(len);
2079 len64 = doubleword_align_up(len + 4);
2080 gap = 2*len32 - len64;
2081 *(int64_t *)fr = flip_64(h + (4<<10)); /* write new header */
2082 /*
2083 * Now copy the data down as raw 32-bit words with no byte-flipping.
2084 * This will NOT be sufficient if I were ever to implement the
2085 * ENVIRONMENT_VECTORS_IN_BPS_HEAP idea, because in that case my lengths
2086 * as suggested above will be wrong and I would need to sign-extend all the
2087 * 32-bit data in the old vector into 64-bit values in the new. I am NOT
2088 * going to do that for now.
2089 */
2090 for (i=4; i<len; i+=4)
2091 { *(int32_t *)(fr + i + 4) = *(int32_t *)(oldfr + i);
2092 }
2093 if (gap != 0)
2094 *(int64_t *)(fr + len64) = flip_64(make_padder(gap));
2095 oldfr += len32;
2096 fr += 2*len32;
2097 }
2098 /* And put fr back where it is needed for what follows... */
2099 fr = (char *)codefringe;
2100 }
2101
2102 while (fr < low + (converting_to_64 ? 2*CSL_PAGE_SIZE : CSL_PAGE_SIZE))
2103 { Header h;
2104 int32_t len, llen;
2105 if (converting_to_32) h = (Header)flip_64(*(int64_t *)fr);
2106 else h = flip_bytes(*(Header *)fr);
2107 len = length_of_header(h);
2108 llen = doubleword_align_up(len);
2109 switch (type_of_header(h))
2110 {
2111 case TYPE_SIMPLE_VEC: /* This option not used at present */
2112 if (converting_to_32)
2113 { /* Since this is not used yet I will not put any code
2114 * here to deal with it! */
2115 }
2116 for (i=CELL; i<llen; i+=CELL)
2117 adjust((Lisp_Object *)(fr+i));
2118 *(Header *)fr = h;
2119 break;
2120 case TYPE_BPS:
2121 #ifdef DEBUG_WIDTH
2122 printf("BPS item length %d\n", len);
2123 #endif
2124 if (!SIXTY_FOUR_BIT && converting_to_32)
2125 { for (i=4; i<llen-4; i+=4)
2126 *(int32_t *)(fr+i) = *(int32_t *)(fr+i+4);
2127 *(int32_t *)(fr+llen-4) = 0;
2128 if (doubleword_align_up(len-4) != llen)
2129 *(Header *)(fr+llen-8) = make_padder(8);
2130 h -= (4<<10); /* reduce length of the BPS object */
2131 }
2132 *(Header *)fr = h;
2133 break;
2134 default:
2135 /* This case should NEVER happen */
2136 printf("Illegal header %.8x in BPS heap\n", (int32_t)h);
2137 fflush(stdout);
2138 my_exit(4);
2139 }
2140 fr += llen;
2141 }
2142 }
2143 /*
2144 * Now the code that allocates fresh binary code space (eg for the compiler
2145 * or for loading pre-compiled modules) does not know about oversized
2146 * pages of the form that can arise when I convert a 32 bit image to make it
2147 * work in a 64-bit world. The effect is that I would run into trouble if
2148 * I allocated a new bit of code space and it lived in the upper half of
2149 * such a page. Specifically the bit marking it as belonging in the top
2150 * half-space could be missed off to very bad effect, including crashes within
2151 * the garbage collector. So if necessary I allocate a big padder block of
2152 * BPS here so that all subsequent allocations end up in the lower (and hence
2153 * standrard( part of the page. I prefer to do this here rather than to spread
2154 * support for double-sized pages into other parts of the code.
2155 */
2156 if (SIXTY_FOUR_BIT && converting_to_64)
2157 { intptr_t w = codefringe - codelimit - CSL_PAGE_SIZE - 0x100;
2158 if (w > 0) getcodevector(TYPE_BPS, w);
2159 }
2160 }
2161
adjust_all(void)2162 void adjust_all(void)
2163 {
2164 int32_t i;
2165 Lisp_Object nil = C_nil;
2166 qheader(nil) = TAG_ODDS+TYPE_SYMBOL+SYM_SPECIAL_VAR;
2167 #ifdef COMMON
2168 qheader(nil) |= SYM_EXTERN_IN_HOME;
2169 #endif
2170 qvalue(nil) = nil;
2171 qenv(nil) = nil;
2172 ifn1(nil) = (intptr_t)undefined1;
2173 ifn2(nil) = (intptr_t)undefined2;
2174 ifnn(nil) = (intptr_t)undefinedn;
2175 adjust(&(qpname(nil))); /* not a gensym */
2176 adjust(&(qplist(nil)));
2177 adjust(&(qfastgets(nil)));
2178 #ifdef COMMON
2179 adjust(&(qpackage(nil)));
2180 #endif
2181
2182 copy_into_nilseg(NO);
2183 for (i = first_nil_offset; i<last_nil_offset; i++)
2184 adjust(&BASE[i]);
2185 copy_out_of_nilseg(NO);
2186
2187 adjust_consheap();
2188 adjust_vecheap();
2189 adjust_bpsheap();
2190 }
2191
allocate_page(char * why)2192 static void *allocate_page(char *why)
2193 {
2194 if (pages_count == 0) fatal_error(err_no_store);
2195 return pages[--pages_count];
2196 }
2197
2198 #ifdef MEMORY_TRACE
2199 #ifndef CHECK_ONLY
2200 intptr_t memory_base, memory_size, memory_count, memory_records = 0;
2201 unsigned char *memory_map = NULL;
2202 static intptr_t memory_lowest = 0x7fffffff, memory_highest = -1;
2203 FILE *memory_file = NULL;
2204
memory_comment(int n)2205 void memory_comment(int n)
2206 {
2207 if (memory_map != NULL)
2208 { putc(0xc0 + (n & 0x3f), memory_file);
2209 putc(0, memory_file);
2210 putc(0, memory_file);
2211 }
2212 }
2213
2214 int kk = 0;
2215
identify_one(void * p,intptr_t size,int type)2216 static void identify_one(void *p, intptr_t size, int type)
2217 {
2218 int32_t i, j;
2219 intptr_t base = (intptr_t)p;
2220 int32_t a = 0, b = 0;
2221 intptr_t da = 1, db = 1;
2222 intptr_t click = size/0x400;
2223 switch (type)
2224 {
2225 case 0: b = click; break;
2226 case 1: db = -1; break;
2227 case 2: b = click; da = db = 2; break;
2228 case 3: da = 2; db = -2; break;
2229 case 4: db = 0; break;
2230 case 5: da = -1; db = 0; break;
2231 default: b = click; da = db = 0; break;
2232 }
2233 if (size > 256)
2234 { da *= (size/256);
2235 db *= (size/256);
2236 }
2237 memory_count |= 0x3ff;
2238 cmemory_reference(base);
2239 memory_comment(kk ? 3 : 5);
2240 kk = !kk;
2241 for (i=0; i<32; i++)
2242 { int x;
2243 memory_count |= 0x3ff;
2244 cmemory_reference(base);
2245 for (j=0; j<0x400; j++)
2246 { x = a + j*(size/8);
2247 while (x > size) x -= size;
2248 while (x < 0) x += size;
2249 cmemory_reference(base+x);
2250 x = b + j*(size/8);
2251 while (x > size) x -= size;
2252 while (x < 0) x += size;
2253 cmemory_reference(base+x);
2254 }
2255 a += da;
2256 b += db;
2257 }
2258 }
2259
identify_page(void * p[],int32_t n,int type)2260 static void identify_page(void *p[], int32_t n, int type)
2261 {
2262 while (n != 0)
2263 { void *w = p[--n];
2264 if (w != NULL) identify_one(w, CSL_PAGE_SIZE, type);
2265 }
2266 }
2267
identify_page_types()2268 void identify_page_types()
2269 {
2270 identify_page(pages, pages_count, 0);
2271 identify_page(heap_pages, heap_pages_count, 1);
2272 identify_page(vheap_pages, vheap_pages_count, 2);
2273 identify_page(bps_pages, bps_pages_count, 3);
2274 identify_page(native_pages, native_pages_count, 4);
2275 identify_one((void *)stacksegment, CSL_PAGE_SIZE, 5);
2276 identify_one((void *)nilsegment, NIL_SEGMENT_SIZE, 6);
2277 }
2278
2279 #endif /* CHECK_ONLY */
2280
2281 long int car_counter;
2282 unsigned long int car_low, car_high;
2283
memory_reference(intptr_t p)2284 Cons_Cell *memory_reference(intptr_t p)
2285 {
2286 if (p & 0x7)
2287 { term_printf("Access to mis-aligned address %.8x\n", (int)p);
2288 ensure_screen();
2289 abort();
2290 }
2291 return (Cons_Cell *)cmemory_reference(p);
2292 }
2293
cmemory_reference(intptr_t p)2294 char *cmemory_reference(intptr_t p)
2295 {
2296 #ifdef CHECK_ONLY
2297 return (char *)p;
2298 #else
2299 intptr_t a = p - memory_base;
2300 if (memory_map != NULL && a >= 0 && a < memory_size)
2301 { int bit;
2302 a = a >> 2; /* Get a word address */
2303 a = a >> 2; /* reduce to 4-word resolution */
2304 if (memory_count >= car_counter &&
2305 (unsigned long int)a >= car_low &&
2306 (unsigned long int)a <= car_high)
2307 { Lisp_Object nil = C_nil;
2308 if (exception_pending()) nil = (Lisp_Object)((intptr_t)nil ^ 1);
2309 interrupt_pending = 1;
2310 miscflags |= HEADLINE_FLAG | MESSAGES_FLAG;
2311 car_counter = 0x7fffffff; /* Do not interrupt again */
2312 }
2313 bit = 1 << (a & 7);
2314 a = a >> 3;
2315 if (a < memory_lowest) memory_lowest = a;
2316 if (a > memory_highest) memory_highest = a;
2317 memory_map[a] |= bit;
2318 if ((++memory_count & 0x3ff) == 0) /* Every 1024 references... */
2319 { unsigned char *pp;
2320 int c;
2321 int32_t run = 0, i;
2322 /*
2323 * I use a run-length encoded representation for the file that I write out.
2324 * Each scan-line is stored as a collection of bytes each of which indicates
2325 * the number of '0' items before the next '1' in the bit-vector. The encoding
2326 * of individual lengths is as follows:
2327 * 0 - 127 1 byte
2328 * 128 - 16K First byte has 0x80 plus 6 bits of data (+ 1 more)
2329 * 16K - 4M First byte has 0xc0 plus 6 bits of data (+ 2 more)
2330 * The byte pair (0x8n, 0x00) stands for n times 4M as a a prefix to
2331 * one of the above. This gives up to 2^28 as the max span.
2332 * The byte pair (0x80, 0x00) can be used to terminate a line.
2333 * Codes (0xcn, 0x00, 0x00) give 64 special codes that can be used
2334 * to interveave comments and annotations within the stream.
2335 */
2336 pp = memory_map + memory_lowest;
2337 run = 8*memory_lowest;
2338 for (i=memory_lowest; i<=memory_highest; i++)
2339 { c = *pp++;
2340 if (c != 0)
2341 { bit = 1;
2342 while ((c & bit) == 0) run++, bit = bit << 1;
2343 if (run >= 0x400000)
2344 { putc(0x80 + ((run >> 22) & 0x3f), memory_file);
2345 putc(0x00, memory_file);
2346 run &= 0x3fffff;
2347 }
2348 if (run < 0x80) putc(run, memory_file);
2349 else if (run < 0x4000)
2350 { putc(0x80 + (run & 0x3f), memory_file);
2351 putc((run >> 6) & 0xff, memory_file);
2352 }
2353 else
2354 { putc(0xc0 + (run & 0x3f), memory_file);
2355 putc((run >> 6) & 0xff, memory_file);
2356 putc((run >> 14) & 0xff, memory_file);
2357 }
2358 c &= ~bit;
2359 run = 0;
2360 bit = bit << 1;
2361 while (c != 0)
2362 { while ((c & bit) == 0) run++, bit = bit << 1;
2363 putc(run, memory_file);
2364 c &= ~bit;
2365 run = 0;
2366 bit = bit << 1;
2367 }
2368 while (bit != 0x100) run++, bit = bit << 1;
2369 }
2370 else run += 8;
2371 }
2372 putc(0x80, memory_file);
2373 putc(0x00, memory_file);
2374 memory_lowest = 0x7fffffff;
2375 memory_highest = -1;
2376 memset(memory_map, 0, memory_size/32+8);
2377 memory_records++;
2378 }
2379 }
2380 return (char *)p;
2381 #endif /* CHECK_ONLY */
2382 }
2383
2384 #endif
2385
2386 static char *global_handle;
2387
my_malloc(size_t n)2388 void *my_malloc(size_t n)
2389 {
2390 #ifdef NO_WORRY_ABOUT_MEMORY_PROBLEMS
2391 return (*malloc_hook)(n);
2392 #else
2393 /*
2394 * The idea here is INTENDED to provide a small amount of extra checking and
2395 * robustness about use of malloc and free. It is very probable these days
2396 * that I would do MUCH better to use a well-developed separate package
2397 * to help me out here - eg I understand that "valgrind" is useful for
2398 * detecting memory leaks...
2399 */
2400 #define EXPLICIT_FREE_AT_END_OF_RUN 1
2401 char *r = (char *)(*malloc_hook)(n+64);
2402 int32_t *p = (int32_t *)quadword_align_up(r);
2403 /*
2404 * | ... | : | | | | | | | to user | | |
2405 * r p <-r-> n 55aa 1234 3456 1234 3456 8765 cba9
2406 * where p is quadword aligned whatever r is.
2407 *
2408 */
2409 if (r == NULL) return NULL;
2410 n = quadword_align_up(n);
2411 inject_randomness((int)(intptr_t)r);
2412 if (!SIXTY_FOUR_BIT) p[1] = 0;
2413 *(void **)(p) = r; /* base address for free() */
2414 *(int64_t *)(&p[2]) = (int64_t)n; /* allow for 64-bit size */
2415 p[4] = 0x12345678; /* Marker words for security */
2416 p[5] = 0x3456789a;
2417 p[6] = 0x12345678;
2418 p[7] = 0x3456789a;
2419 r = (char *)&p[8];
2420 car32(r+n) = 0x87654321;
2421 car32(r+n+4) = 0xcba98765;
2422 return (void *)r;
2423 #endif
2424 }
2425
2426 char *big_chunk_start, *big_chunk_end;
2427
2428 #ifdef EXPLICIT_FREE_AT_END_OF_RUN
2429
my_free(void * r)2430 static void my_free(void *r)
2431 {
2432 #ifdef NO_WORRY_ABOUT_MEMORY_PROBLEMS
2433 char *rr = (char *)r;
2434 /*
2435 * I will not free it if the pointer is strictly inside the single big
2436 * chunk that I grabbed at the start of the run.
2437 */
2438 if (rr > big_chunk_start && rr <= big_chunk_end) return;
2439 int32_t *p, *q, n;
2440 *(free_hook)(r);
2441 #else /* NO_WORRY... */
2442 int32_t *p, *q;
2443 size_t n;
2444 char *rr = (char *)r;
2445 /*
2446 * I will not free it if the pointer is strictly inside the single big
2447 * chunk that I grabbed at the start of the run.
2448 */
2449 if (rr > big_chunk_start && rr <= big_chunk_end) return;
2450 p = (int32_t *)r - 8;
2451 n = (size_t)*(int64_t *)(&p[2]);
2452 if (p[4] != 0x12345678 ||
2453 p[5] != 0x3456789a)
2454 { term_printf("Corruption at start of memory block %p: %.8x %.8x\n",
2455 r, p[4], p[5]);
2456 ensure_screen();
2457 my_exit(0);
2458 }
2459 q = (int32_t *)((char *)r + n);
2460 if (q[0] != 0x87654321 ||
2461 q[1] != 0xcba98765)
2462 { term_printf("Corruption at end of memory block %p: %.8x %.8x\n",
2463 r, q[0], q[1]);
2464 ensure_screen();
2465 my_exit(0);
2466 }
2467 (*free_hook)((void *)((void **)p)[0]);
2468 #endif
2469 }
2470
2471 #endif
2472
my_malloc_1(size_t n)2473 static void *my_malloc_1(size_t n)
2474 /*
2475 * This is a pretty silly function - it gobbles up 24Kbytes of
2476 * stack and then just calls malloc - it stuffs a pointer to the
2477 * stack-chunk into a static variable so that compilers can not
2478 * detect (I hope!) that the array remains unused. The purpose of this
2479 * is to make malloc fail if it is about to encroach on space that
2480 * should be used for stack. This is relevant on small systems where
2481 * stack and heap grow towards one another and where one space has been
2482 * grabbed by malloc it is unavailable for stack (even if it is FREEd).
2483 * The number 24000 is pretty arbitrary - but if I have 24K bytes of stack
2484 * I will be able to do at least something.
2485 * Also this code verifies that the memory addresses returned have the
2486 * correct most significant bit. I allocate just a bit more memory than
2487 * is really needed to leave a one-word (or so) guard-band between
2488 * allocated blocks. This is necessary on some releases of an SGI C
2489 * compiler (library) where blocks of memory that are word but not
2490 * doubleword aligned can be returned.
2491 */
2492 {
2493 char gobble_stack[24000];
2494 char *r;
2495 intptr_t pun, pun1;
2496 global_handle = gobble_stack;
2497 r = (char *)my_malloc(n+16);
2498 pun = (intptr_t)r;
2499 pun1 = (intptr_t)(r + n);
2500 /*
2501 * I will moan if the block of memory allocated spans zero.
2502 * Note that if this does happen then something very funny is happening
2503 * about 0 cast to a pointer (i.e. a NULL pointer) since NULL is supposed
2504 * not to be valid as an address (?) but appears to be within the address
2505 * range of the block of store just allocated.
2506 */
2507 if ((pun ^ pun1) < 0) fatal_error(err_mem_spans_zero);
2508 /*
2509 * Now if I get a block with the "wrong" top bit I will just return NULL
2510 * to suggest that no more memory was available - CSL can then proceed
2511 * or fail as it sees fit.
2512 */
2513 /*
2514 * For dynamic address sign I should not test the address sign on the
2515 * first call - instead I just remember what it was. On subsequent calls
2516 * I will check it.
2517 */
2518 if (nilsegment != NULL)
2519 { if ((pun + address_sign) < 0) return NULL;
2520 /* fatal_error(err_top_bit); */
2521 }
2522 else address_sign = pun & GC_BIT_P;
2523 return (void *)r;
2524 }
2525
my_malloc_2(size_t n)2526 static void *my_malloc_2(size_t n)
2527 /*
2528 * Rather like my_malloc_1(), but does NOT check the sign bit of the
2529 * returned pointer. Provided as a place to put hooks to check memory
2530 * allocation problems.
2531 */
2532 {
2533 char gobble_stack[24000];
2534 char *r;
2535 global_handle = gobble_stack;
2536 r = (char *)my_malloc(n+16);
2537 return (void *)r;
2538 }
2539
init_heap_segments(double store_size)2540 static void init_heap_segments(double store_size)
2541 /*
2542 * This function just makes nil and the pool of page-frames available.
2543 * The store-size is passed in units of Kilobyte, and as a double not
2544 * an integer so that overflow is not an issue.
2545 */
2546 {
2547 char *memfile = "memory.use"; /* For memory statistics etc */
2548 pages = (void **)my_malloc_2(MAX_PAGES*sizeof(void *));
2549 #ifdef CONSERVATIVE
2550 page_map = (page_map_t *)my_malloc_2(MAX_PAGES*sizeof(page_map_t));
2551 #endif
2552 heap_pages = (void **)my_malloc_2(MAX_PAGES*sizeof(void *));
2553 vheap_pages = (void **)my_malloc_2(MAX_PAGES*sizeof(void *));
2554 bps_pages = (void **)my_malloc_2(MAX_BPS_PAGES*sizeof(void *));
2555 native_pages = (void **)my_malloc_2(MAX_NATIVE_PAGES*sizeof(void *));
2556 new_heap_pages = (void **)my_malloc_2(MAX_PAGES*sizeof(void *));
2557 new_vheap_pages = (void **)my_malloc_2(MAX_PAGES*sizeof(void *));
2558 new_bps_pages = (void **)my_malloc_2(MAX_BPS_PAGES*sizeof(void *));
2559 new_native_pages = (void **)my_malloc_2(MAX_NATIVE_PAGES*sizeof(void *));
2560 pair_c = (unsigned char *)my_malloc_2(CODESIZE);
2561 /*
2562 * Sets up codebuffer for jit functions
2563 */
2564 #ifdef JIT
2565 jit_size = JIT_INIT_SIZE;
2566 #ifdef WIN32
2567 DWORD old_protection_status;
2568 printf("About to VirtualAlloc\n");
2569 fflush(stdout);
2570 jit_space = VirtualAlloc(
2571 NULL, /* system selects address */
2572 jit_size, /* size to allocate */
2573 MEM_RESERVE | MEM_COMMIT,/* allocate reserved pages */
2574 PAGE_EXECUTE_READWRITE); /* Execute, Read and Write access */
2575 printf("VirtualAlloc = %p\n", jit_space);
2576 fflush(stdout);
2577
2578 /*
2579 * Now just to show that I know how to I will change the protection of
2580 * the dynamic page to "read-only" so that nobody else can clobber it by
2581 * accident (or in malice).
2582 */
2583 /*
2584 VirtualProtect(
2585 shell,
2586 8192,
2587 PAGE_READONLY,
2588 &old_protection_status);
2589 */
2590 #else
2591 jit_space = mmap(NULL, jit_size,
2592 PROT_WRITE|PROT_EXEC,MAP_PRIVATE|MAP_ANONYMOUS,
2593 0,0);
2594 if (jit_space==(caddr_t)-1)
2595 {
2596 perror("mmap failed");
2597 }
2598 #endif
2599 jit_space_p = jit_space;
2600 #endif
2601
2602 /*
2603 * The next line is utterly unsatisfactory at present
2604 */
2605 char_stack = (unsigned char *)my_malloc_2(CSL_PAGE_SIZE+16 /*CODESIZE*/);
2606 pair_prev = (unsigned short int *)
2607 my_malloc_2(CODESIZE*sizeof(unsigned short int));
2608 if (pages == NULL ||
2609 #ifdef CONSERVATIVE
2610 page_map == NULL ||
2611 #endif
2612 new_heap_pages == NULL ||
2613 new_vheap_pages == NULL ||
2614 new_bps_pages == NULL ||
2615 new_native_pages == NULL ||
2616 heap_pages == NULL ||
2617 vheap_pages == NULL ||
2618 bps_pages == NULL ||
2619 native_pages == NULL ||
2620 pair_c == NULL ||
2621 char_stack == NULL ||
2622 pair_prev == NULL)
2623 {
2624 fatal_error(err_no_store);
2625 }
2626
2627 {
2628 /*
2629 * Using an int32_t here was about to get embarassing as I move to 64-bit
2630 * machines and the amount of memory I ought to use grows to be over
2631 * 2 or over 4 Gbytes... so I use an intrpr_t.
2632 * This just sets up a DEFAULT allocation, which is 128 Mbytes on
2633 * 64-bit machines and 32 Mbytes on 32-bit ones. Later on I override this
2634 * in one of two ways. On a TINY machine with a smaller page size I
2635 * give myself just 16 Mbytes, and then if the user indicated a desire
2636 * for a particular initial heap-size using the "-Knnn" command line option
2637 * I will use that.
2638 */
2639 intptr_t free_space = SIXTY_FOUR_BIT ? 128000000 : 32000000;
2640 intptr_t request;
2641 /*
2642 * There are two special cases where I will override the default, both
2643 * of which relate to "trick" builds for small machines. The two cases I
2644 * have most recently used these were
2645 * (a) Building for an HP Ipaq 4700 PDA
2646 * (b) Building to run on a Linksys router (!)
2647 */
2648 #if defined UNDER_CE || PAGE_BITS < 20
2649 free_space = 16000000;
2650 #endif
2651 request = (intptr_t)store_size;
2652 /* By doing this in intptr_t I should avoid overflow */
2653 if (request != 0) free_space = 1024*request;
2654 free_space = free_space/(CSL_PAGE_SIZE+4);
2655 if (free_space > MAX_PAGES) free_space = MAX_PAGES;
2656 pages_count = heap_pages_count = vheap_pages_count =
2657 bps_pages_count = native_pages_count = 0;
2658 native_fringe = 0;
2659 /*
2660 * I grab memory using a function called my_malloc_1(), which verifies that
2661 * all addresses used in the heap have the same top bit. The very first time
2662 * it is called nilsegment will be NULL - that time it does less checking.
2663 */
2664 nilsegment = NULL;
2665 { size_t n = (size_t)(NIL_SEGMENT_SIZE+free_space*(CSL_PAGE_SIZE+16));
2666 /*
2667 * I try to get the whole of the initial hunk of memory that I need in
2668 * one gulp since that (maybe) gives me the best chance to obtain all
2669 * the memory in just one half of my address space.
2670 */
2671 char *pool = (char *)my_malloc_1(n);
2672 /*
2673 * I get 8 bytes more than seems necessary because I will need to
2674 * align my page frames up to a doubleword boundary, and that can
2675 * potentially waste 7 bytes.
2676 */
2677 if (pool != NULL)
2678 { big_chunk_start = (char *)pool;
2679 big_chunk_end = big_chunk_start + (n-1);
2680 #ifdef MEMORY_TRACE
2681 #ifndef CHECK_ONLY
2682 memory_base = (intptr_t)pool;
2683 memory_size = n;
2684 memory_count = 0;
2685 memory_map = (unsigned char *)(*malloc_hook)(n/32 + 16);
2686 if (memory_map != 0)
2687 { memset(memory_map, 0, n/32+8);
2688 memory_file = fopen(memfile, "wb");
2689 if (memory_file == NULL)
2690 { (*free_hook)(memory_map);
2691 memory_map = 0;
2692 }
2693 else
2694 { n = n/32 + 8;
2695 putc(0, memory_file);
2696 putc(0, memory_file);
2697 putc(0, memory_file); /* 3 bytes to overwrite later on */
2698 putc(n, memory_file);
2699 putc(n>>8, memory_file);
2700 putc(n>>16, memory_file);
2701 memory_comment(2); /* startup code */
2702 init_flags &= ~INIT_EXPANDABLE;
2703 }
2704 }
2705 #endif
2706 #endif
2707 nilsegment = (Lisp_Object *)pool;
2708 pool = pool + NIL_SEGMENT_SIZE;
2709 #ifdef COMMON
2710 /* NB here that NIL is tagged as a CONS not as a symbol */
2711 C_nil = doubleword_align_up(nilsegment) + TAG_CONS + 8;
2712 #else
2713 C_nil = doubleword_align_up(nilsegment) + TAG_SYMBOL;
2714 #endif
2715 /*
2716 * If at the end of the run I am going to free some space I had better not
2717 * free these pages. When I free the nilsegment they all get discarded at
2718 * once. Observe here that the page that will be at the top of the list of
2719 * pages will be the one with the higher address, and pages here will
2720 * all be contiguous. So if I merely grab two pages from here I may
2721 * view them as a single double-sized one. Since I will normally grab
2722 * from the top of the pile it will be the second one that I grab that
2723 * is the base of the double-page. This feels close to cheating!
2724 */
2725 while (pages_count < free_space)
2726 { void *page = (void *)&pool[pages_count*(CSL_PAGE_SIZE+16)];
2727 pages[pages_count++] = page;
2728 }
2729 }
2730 }
2731 }
2732
2733 /*
2734 * I allocate a stack segment first because I will use it as buffer space for
2735 * decompressing the contents of an image file. It will come out of the
2736 * initial contiguous block in general, however to give myself the best
2737 * chance when converting a 32-bit image to 64-bits I allocate it afresh
2738 * when I am on a 64-bit machine. If the user had asked for an oversize stack
2739 * it has to be allocated independently here anyway.
2740 */
2741 if (nilsegment != NULL && pages_count > 0)
2742 { if (stack_segsize != 1 || SIXTY_FOUR_BIT)
2743 { stacksegment =
2744 (Lisp_Object *)my_malloc(stack_segsize*CSL_PAGE_SIZE + 16);
2745 if (stacksegment == NULL)
2746 fatal_error(err_no_store);
2747 }
2748 else stacksegment = (Lisp_Object *)pages[--pages_count];
2749 }
2750 else
2751 {
2752 printf("pages_count <= 0 = %d\n", pages_count);
2753 fatal_error(err_no_store);
2754 }
2755 CSL_MD5_Update((unsigned char *)memfile, 8);
2756 /*
2757 * The stack does not need to be doubleword aligned, but it does need
2758 * to be word aligned (otherwise certain back-pointers in the garbage
2759 * collector give trouble), so I fix it up here. Note that stacksegment
2760 * remains pointing at the original base so that I can free() it later.
2761 */
2762 stackbase = (Lisp_Object *)doubleword_align_up((intptr_t)stacksegment);
2763 }
2764
2765 #ifdef EXPLICIT_FREE_AT_END_OF_RUN
2766 /*
2767 * In general I will let CSL exit without bothering to free up all the
2768 * memory that it allocated - that job can be left (to the extent that
2769 * it is needed at all) to the run-time system. But if for some reason
2770 * you really mind about such things here is some code to do it for you...
2771 */
2772
abandon(void * p[],int32_t n)2773 static void abandon(void *p[], int32_t n)
2774 {
2775 while (n != 0)
2776 { void *w = p[--n];
2777 /*
2778 * The test here that avoids calling free on a NULL pointer is
2779 * certainly not needed with an ANSI compliant library - but
2780 * rumour has it that many Unix libraries are unkind in this
2781 * respect, and the test is pretty cheap...
2782 */
2783 if (w != NULL) my_free(w);
2784 }
2785 }
2786
2787 #endif
2788
drop_heap_segments(void)2789 void drop_heap_segments(void)
2790 {
2791 #ifdef MEMORY_TRACE
2792 #ifndef CHECK_ONLY
2793 identify_page_types();
2794 #endif
2795 #endif
2796 #ifdef EXPLICIT_FREE_AT_END_OF_RUN
2797 abandon(pages, pages_count);
2798 abandon(heap_pages, heap_pages_count);
2799 abandon(vheap_pages, vheap_pages_count);
2800 abandon(bps_pages, bps_pages_count);
2801 abandon(native_pages, native_pages_count);
2802 my_free(stacksegment);
2803 my_free(nilsegment);
2804 #endif
2805 #ifdef MEMORY_TRACE
2806 #ifndef CHECK_ONLY
2807 fseek(memory_file, 0L, SEEK_SET);
2808 putc(memory_records & 0xff, memory_file);
2809 putc((memory_records>>8) & 0xff, memory_file);
2810 putc((memory_records>>16) & 0xff, memory_file);
2811 fclose(memory_file);
2812 memory_file = NULL;
2813 memory_map = NULL;
2814 #endif
2815 #endif
2816 }
2817
find_checksum(char * name,int32_t len,const setup_type * p)2818 static char *find_checksum(char *name, int32_t len, const setup_type *p)
2819 {
2820 char *n;
2821 while (p->name != NULL) p++;
2822 n = (char *)p->one;
2823 if (strlen(n) == (size_t)len && memcmp(name, n, len) == 0)
2824 return (char *)p->two;
2825 else return NULL;
2826 }
2827
2828 setup_type const *setup_tables[] =
2829 {
2830 u01_setup, u02_setup, u03_setup, u04_setup,
2831 u05_setup, u06_setup, u07_setup, u08_setup, u09_setup,
2832 u10_setup, u11_setup, u12_setup, u13_setup, u14_setup,
2833 u15_setup, u16_setup, u17_setup, u18_setup, u19_setup,
2834 u20_setup, u21_setup, u22_setup, u23_setup, u24_setup,
2835 u25_setup, u26_setup, u27_setup, u28_setup, u29_setup,
2836 u30_setup, u31_setup, u32_setup, u33_setup, u34_setup,
2837 u35_setup, u36_setup, u37_setup, u38_setup, u39_setup,
2838 u40_setup, u41_setup, u42_setup, u43_setup, u44_setup,
2839 u45_setup, u46_setup, u47_setup, u48_setup, u49_setup,
2840 u50_setup, u51_setup, u52_setup, u53_setup, u54_setup,
2841 u55_setup, u56_setup, u57_setup, u58_setup, u59_setup,
2842 u60_setup,
2843 /*
2844 * I also include the kernel setup tables, but I put a NULL in this
2845 * table so it is easy to see where they start.
2846 */
2847 NULL,
2848 arith06_setup, arith08_setup, arith10_setup, arith12_setup,
2849 char_setup, eval1_setup, eval2_setup, eval3_setup,
2850 funcs1_setup, funcs2_setup, funcs3_setup, print_setup,
2851 read_setup, mpi_setup,
2852 NULL
2853 };
2854
2855 /*
2856 * If C code is to be instated (via c!:install calls in u01.lsp etc) there
2857 * needs to be a verification that the file u01.c and the file u01.lsp (etc)
2858 * are in step. So once for each such file this does the check. It should
2859 * only happen when the system is being built and ought not to be a bit
2860 * performance issue.
2861 */
2862
Lcheck_c_code(Lisp_Object nil,int nargs,...)2863 static Lisp_Object MS_CDECL Lcheck_c_code(Lisp_Object nil, int nargs, ...)
2864 {
2865 Lisp_Object name, lc1, lc2, lc3;
2866 int32_t c1=-1, c2=-1, c3=-1;
2867 long int x1=-2, x2=-2, x3=-2;
2868 int32_t len;
2869 va_list a;
2870 char *p;
2871 char *sname;
2872 int i;
2873 argcheck(nargs, 4, "check-c-code");
2874 va_start(a, nargs);
2875 name = va_arg(a, Lisp_Object);
2876 lc1 = va_arg(a, Lisp_Object);
2877 lc2 = va_arg(a, Lisp_Object);
2878 lc3 = va_arg(a, Lisp_Object);
2879 va_end(a);
2880 if (!is_vector(name) ||
2881 type_of_header(vechdr(name)) != TYPE_STRING ||
2882 !is_fixnum(lc1) ||
2883 !is_fixnum(lc2) ||
2884 !is_fixnum(lc3)) return aerror1("check-c-code", name);
2885 c1 = int_of_fixnum(lc1);
2886 c2 = int_of_fixnum(lc2);
2887 c3 = int_of_fixnum(lc3);
2888 sname = &celt(name, 0);
2889 len = length_of_header(vechdr(name)) - CELL;
2890
2891 p = NULL;
2892 for (i=0; setup_tables[i]!=NULL; i++)
2893 { if ((p = find_checksum(sname, len, setup_tables[i])) != NULL) break;
2894 }
2895 if (p == NULL) return aerror1("check-c-code", name);
2896
2897 if (sscanf(p, "%ld %ld %ld", &x1, &x2, &x3) != 3)
2898 return aerror("check-c-code");
2899 if (c1 == x1 && c2 == x2 && c3 == x3) return onevalue(nil);
2900 err_printf("\n+++++ C code and environment files not compatible\n");
2901 err_printf("please check, re-compile and try again\n");
2902 return aerror("check-c-code");
2903 }
2904
2905 static setup_type const restart_setup[] =
2906 /*
2907 * things that are in modules that do not define enough Lisp entrypoints
2908 * to be worth giving separate entry-tables.
2909 */
2910 {
2911 {"check-c-code", wrong_no_na, wrong_no_nb, Lcheck_c_code},
2912 {"define-in-module", Ldefine_in_module, too_many_1, wrong_no_1},
2913 {"modulep", Lmodule_exists, too_many_1, wrong_no_1},
2914 {"start-module", Lstart_module, too_many_1, wrong_no_1},
2915 {"write-module", Lwrite_module, too_many_1, wrong_no_1},
2916 {"copy-module", Lcopy_module, too_many_1, wrong_no_1},
2917 {"copy-native", too_few_2, Lcopy_native, wrong_no_2},
2918 {"delete-module", Ldelete_module, too_many_1, wrong_no_1},
2919 {"load-module", Lload_module, too_many_1, wrong_no_1},
2920 {"list-modules", wrong_no_na, wrong_no_nb, Llist_modules},
2921 {"writable-libraryp", Lwritable_libraryp, too_many_1, wrong_no_1},
2922 {"library-members", Llibrary_members, too_many_1, Llibrary_members0},
2923 {"startup-banner", Lbanner, too_many_1, wrong_no_1},
2924 {"instate-c-code", too_few_2, Linstate_c_code, wrong_no_2},
2925 /* An embedded help system that used to exist has now been disabled */
2926 #if 0
2927 {"write-help-module", too_few_2, Lwrite_help_module, wrong_no_2},
2928 {"help", Lhelp, Lhelp_2, Lhelp_n},
2929 {"?", Lhelp, too_many_1, wrong_no_1},
2930 #endif
2931 {"set-help-file", too_few_2, Lset_help_file, wrong_no_2},
2932 {"mapstore", Lmapstore, too_many_1, Lmapstore0},
2933 {"verbos", Lverbos, too_many_1, wrong_no_1},
2934 #ifdef COMMON
2935 {"errorset", Lerrorset1, Lerrorset2, Lerrorsetn},
2936 {"gc", Lgc, too_many_1, Lgc0},
2937 #else
2938 {"errorset", Lerrorset1, Lerrorset2, Lerrorsetn},
2939 {"reclaim", Lgc, too_many_1, Lgc0},
2940 #endif
2941 {"resource-limit", too_few_2, Lresource_limit2, Lresource_limitn},
2942 {NULL, 0, 0, 0}
2943 };
2944
2945
create_symbols(setup_type const s[],CSLbool restartp)2946 static void create_symbols(setup_type const s[], CSLbool restartp)
2947 {
2948 int i;
2949 for (i=0; s[i].name != NULL; i++)
2950 make_symbol(s[i].name, restartp, s[i].one, s[i].two, s[i].n);
2951 }
2952
2953 static int32_t defined_symbols;
2954
count_symbols(setup_type const s[])2955 static void count_symbols(setup_type const s[])
2956 {
2957 int i;
2958 for (i=0; s[i].name != NULL; i++) defined_symbols++;
2959 }
2960
2961 static void set_up_variables(CSLbool restartp);
2962 static setup_type_1 *find_def_table(Lisp_Object mod, Lisp_Object checksum);
2963
2964 typedef struct dynamic_modules
2965 {
2966 char *name;
2967 setup_type_1 *entries;
2968 } dynamic_modules;
2969
2970 static dynamic_modules *loaded_dynamic_modules = NULL;
2971 static unsigned int loaded_dynamic_count = 0 , loaded_dynamic_size = 0;
2972
2973 /*
2974 * A real curiosity of my implementation is that find_dynamic_module
2975 * takes a char * and a length. The "string" it is given need not be
2976 * properly terminated with a "\0". The string data might be transient.
2977 * in contrase, record_dynamic_module takes a normal-style C string (which
2978 * of course is terminated with '\0', and it requires that the string
2979 * data is non-transient. BEWARE if you try to use these at some stage in the
2980 * future.
2981 */
find_dynamic_module(char * name,int32_t len)2982 static setup_type_1 *find_dynamic_module(char *name, int32_t len)
2983 {
2984 unsigned int hash = 0;
2985 int i;
2986 char *p = name;
2987 if (loaded_dynamic_size == 0) return NULL;
2988 for (i=0; i<len; i++) hash=169*hash+(*p++ & 0xff);
2989 hash %= loaded_dynamic_size;
2990 for (;;)
2991 { if (loaded_dynamic_modules[hash].name == NULL) return NULL;
2992 if (strncmp(name, loaded_dynamic_modules[hash].name, len) == 0 &&
2993 strlen(loaded_dynamic_modules[hash].name) == len)
2994 return loaded_dynamic_modules[hash].entries;
2995 hash = (hash + 1) % loaded_dynamic_size;
2996 }
2997 }
2998
2999 /*
3000 * The constant here must be a prime number.
3001 */
3002 #define INITIAL_DYNAMIC_MODULE_HASH_SIZE 1009
3003
record_dynamic_module(char * name,setup_type_1 * entries)3004 static void record_dynamic_module(char *name, setup_type_1 *entries)
3005 {
3006 unsigned int hash;
3007 char *p;
3008 loaded_dynamic_count++;
3009 if (3*loaded_dynamic_count >= 2*loaded_dynamic_size)
3010 { dynamic_modules *newtable;
3011 unsigned int newsize;
3012 unsigned int i;
3013 if (loaded_dynamic_size == 0)
3014 newsize = INITIAL_DYNAMIC_MODULE_HASH_SIZE;
3015 else
3016 { newsize = 2*loaded_dynamic_size-1;
3017 while (!primep(newsize)) newsize+=2;
3018 }
3019 #ifdef TRACE_NATIVE
3020 trace_printf("Hash needs to grow from %d to %d\n", loaded_dynamic_size, newsize);
3021 ensure_screen();
3022 #endif
3023 newtable = (dynamic_modules *)
3024 malloc(newsize*sizeof(dynamic_modules));
3025 for (i=0; i<newsize; i++) newtable[i].name = NULL;
3026 for (i=0; i<loaded_dynamic_size; i++)
3027 { if ((p = loaded_dynamic_modules[i].name) == NULL) continue;
3028 hash = 0;
3029 while (*p != 0) hash=169*hash+(*p++ & 0xff);
3030 /*
3031 * I will leave the trace print here when I rehash so that I spot cases of
3032 * rehashing in case to increase the chance of spotting associated bugs.
3033 * I will also start with a small hash table so that repeated rehashing is
3034 * provoked.
3035 */
3036 #ifdef TRACE_NATIVE
3037 trace_printf("Hash for %s is %x in REHASH\n", loaded_dynamic_modules[i].name, hash);
3038 ensure_screen();
3039 #endif
3040 hash %= newsize;
3041 for (;;)
3042 { if (newtable[hash].name == NULL)
3043 { newtable[hash].name = loaded_dynamic_modules[i].name;
3044 newtable[hash].entries = loaded_dynamic_modules[i].entries;
3045 break;
3046 }
3047 hash = (hash + 1) % newsize;
3048 }
3049 }
3050 if (loaded_dynamic_size != 0) free(loaded_dynamic_modules);
3051 loaded_dynamic_modules = newtable;
3052 loaded_dynamic_size = newsize;
3053 }
3054 p = name;
3055 hash = 0;
3056 while (*p != 0) hash=169*hash+(*p++ & 0xff);
3057 hash %= loaded_dynamic_size;
3058 for (;;)
3059 { if (loaded_dynamic_modules[hash].name == NULL)
3060 { loaded_dynamic_modules[hash].name = name;
3061 loaded_dynamic_modules[hash].entries = entries;
3062 return;
3063 }
3064 if (strcmp(name, loaded_dynamic_modules[hash].name) == 0)
3065 { loaded_dynamic_modules[hash].entries = entries;
3066 return;
3067 }
3068 hash = (hash + 1) % loaded_dynamic_size;
3069 }
3070 }
3071
3072 static void warm_setup();
3073
warm_setup()3074 static void warm_setup()
3075 {
3076 /*
3077 * Here I need to read in the bulk of the checkpoint file.
3078 */
3079 Lisp_Object nil = C_nil;
3080 int32_t i;
3081 /*
3082 * NOTE that I have made these variable of type int32_t so that
3083 * their size is the same (ie 4) whether I am on a 32 or 64-bit machine
3084 */
3085 Cfread((char *)&heap_pages_count, sizeof(heap_pages_count));
3086 Cfread((char *)&vheap_pages_count, sizeof(vheap_pages_count));
3087 Cfread((char *)&bps_pages_count, sizeof(bps_pages_count));
3088
3089 heap_pages_count = flip_32(heap_pages_count);
3090 vheap_pages_count = flip_32(vheap_pages_count);
3091 bps_pages_count = flip_32(bps_pages_count);
3092
3093 /*
3094 * Here I want to arrange to have at least one free page after re-loading
3095 * an image. If malloc can give me enough I grab it here. Note that I do
3096 * not yet know how many pages will be needed for hard code, which is a
3097 * bit of a nuisance!
3098 * And if I am loading a 32-bit image on a 64-bit machine I will arrange that
3099 * all the pages that I reload stuff into here are (temporarily) double
3100 * the usual size. Because the 32-bit image was created on a 32-bit system (!)
3101 * it can have a total heap of at most 2Gb, ie 512 pages (for so long as my
3102 * page size is 4Mb, ie PAGE_BITS=22). So I could have a bitmap that
3103 * indicated which of the first up to 512 pages was oversized if I was
3104 * worried. Right now I will just allocate the memory large and on a 64-bit
3105 * machine not worry about the waste if later on I do not use half of it!
3106 *
3107 * When I look at a Reduce image I find that the (compressed) main heap image
3108 * is around 0.5Mb for a normal Reduce and just over 1Mb for the bulkier
3109 * bootstrap version. That is just the heap image part of the full image file.
3110 * A consequence of this is that if my pages are 4Mb each even after
3111 * decompression I will use just one page each of cons, vector and bps heap
3112 * here. However potentially somebody could use "preserve" to capture the
3113 * state in the middle of a huge calculation, in which case life would
3114 * end up messier... with LOTS of oversized pages.
3115 */
3116 i = heap_pages_count+vheap_pages_count+
3117 bps_pages_count+1 - pages_count;
3118 #ifdef MEMORY_TRACE
3119 /*
3120 * The MEMORY_TRACE options requires that all store be in a single
3121 * contiguous chunk, and hence can not cope with any piecemeal allocation
3122 * in the form that follows. That means it is incompatible with loading
3123 * 32-bit images on a 64-bit machine! So if I find anybody trying I
3124 * abort. OK so the message merely says "not enough memory" but that is better
3125 * than trying to continue and then crashing messily!
3126 */
3127 if (i > 0 || converting_to_64) fatal_error(err_no_store);
3128 #else
3129 /*
3130 * If I am converting to 64-bits I need all my memory here to be
3131 * contiguous. So rather than check I have enough here I will do
3132 * that later,,,
3133 */
3134 if (i>0 && converting_to_64) fatal_error(err_no_store);
3135 while (i-- > 0)
3136 { void *page = my_malloc_1((size_t)(CSL_PAGE_SIZE + 16));
3137 if (page == NULL)
3138 {
3139 fatal_error(err_no_store);
3140 }
3141 else pages[pages_count++] = page;
3142 }
3143 /*
3144 * Now I have at least just enough pages to load op the heap image. Well I
3145 * really hope I have a fair amount in hand or else garbage collection will
3146 * be a pain! But at least we can get started. Depending on how full memory
3147 * looks I will select the type for the first garbage collection. See
3148 * comments in gc.c for further thoughts about this.
3149 */
3150 gc_method_is_copying = (pages_count >
3151 3*(heap_pages_count +
3152 (3*(vheap_pages_count +
3153 bps_pages_count +
3154 native_pages_count))/2));
3155 #endif
3156 { char dummy[16];
3157 Cfread(dummy, 8);
3158 }
3159 #ifdef MEMORY_TRACE
3160 #ifndef CHECK_ONLY
3161 memory_comment(6); /* vector heap */
3162 #endif
3163 #endif
3164 for (i=0; i<vheap_pages_count; i++)
3165 { intptr_t p;
3166 /* When I want to make the page double size I do TWO allocations here. */
3167 if (converting_to_64) allocate_page("vheap 64-bit padder");
3168 vheap_pages[i] = allocate_page("vheap reload");
3169 p = doubleword_align_up((intptr_t)vheap_pages[i]);
3170 /*
3171 * Vheap pages that need expanding to 64-bits will most easily by copied
3172 * in an order that goes best if I put the initial raw 32-bit data in the
3173 * top half of the double-sized page.
3174 */
3175 if (converting_to_64)
3176 { Cfread(CSL_PAGE_SIZE+(char *)p, CSL_PAGE_SIZE);
3177 /* For convenience later I copy the length field down to the bottom now */
3178 car32(p) = car32(CSL_PAGE_SIZE+(char *)p);
3179 }
3180 else Cfread((char *)p, CSL_PAGE_SIZE);
3181 }
3182
3183 { char dummy[16];
3184 Cfread(dummy, 8);
3185 }
3186 #ifdef MEMORY_TRACE
3187 #ifndef CHECK_ONLY
3188 memory_comment(5); /* cons heap */
3189 #endif
3190 #endif
3191 for (i=0; i<heap_pages_count; i++)
3192 { intptr_t p;
3193 /* When I want to make the page double size I do TWO allocations here. */
3194 if (converting_to_64) allocate_page("heap 64-bit padder");
3195 heap_pages[i] = allocate_page("heap reload");
3196 p = quadword_align_up((intptr_t)heap_pages[i]);
3197 Cfread((char *)p, CSL_PAGE_SIZE);
3198 }
3199
3200 { char dummy[16];
3201 Cfread(dummy, 8);
3202 }
3203 #ifdef MEMORY_TRACE
3204 #ifndef CHECK_ONLY
3205 memory_comment(14); /* BPS heap */
3206 #endif
3207 #endif
3208 for (i=0; i<bps_pages_count; i++)
3209 { intptr_t p;
3210 /* When I want to make the page double size I do TWO allocations here. */
3211 if (converting_to_64) allocate_page("bps 64-bit padder");
3212 bps_pages[i] = allocate_page("bps reload");
3213 p = doubleword_align_up((intptr_t)bps_pages[i]);
3214 /* Same issue as for Vheap pages */
3215 if (converting_to_64)
3216 { Cfread(CSL_PAGE_SIZE+(char *)p, CSL_PAGE_SIZE);
3217 car32(p) = car32(CSL_PAGE_SIZE+(char *)p);
3218 }
3219 else Cfread((char *)p, CSL_PAGE_SIZE);
3220 }
3221
3222 { char endmsg[32];
3223 Cfread(endmsg, 24); /* the termination record */
3224 /*
3225 * Although I check here I will not make the system crash if I see an
3226 * error - at least until I have tested things and found this test
3227 * properly reliable.
3228 */
3229 #ifdef COMMON
3230 if (strncmp(endmsg, "\n\nEnd of CCL dump file\n\n", 24) != 0)
3231 #else
3232 if (strncmp(endmsg, "\n\nEnd of CSL dump file\n\n", 24) != 0)
3233 #endif
3234 { term_printf("\n+++ Bad end record |%s|\n", endmsg);
3235 }
3236 }
3237 /*
3238 * There is a delicacy here - Cfread uses Iread to read chunks of
3239 * data from the real input file, but it never goes beyond the recorded
3240 * end of file mark. This buffering ensures that at this stage any
3241 * pending part-word of data will have been read - this because the
3242 * read buffer used is a multiple of 4 bytes long. This point matters
3243 * with regard to checksum validation on these files. For an image in a native
3244 * directory I must have set up the initial read_bytes_remaining allowing for
3245 * the final checksum...
3246 */
3247 { Lisp_Object w = error_output;
3248 error_output = 0;
3249 if (IcloseInput(YES))
3250 {
3251 /*
3252 * I write a moan to stderr, even though in some cases this will not be
3253 * visible, because the general-purpose Lisp print streams have not yet been
3254 * fully set up. So on some windowed platforms this message, if it appears
3255 * at all, may show up in an unusual way. Sorry!
3256 */
3257 fprintf(stderr, "\n+++ Initial Image file checksum failure\n");
3258 }
3259 error_output = w;
3260 }
3261
3262 #ifndef MEMORY_TRACE
3263 if (converting_to_64)
3264 {
3265 /*
3266 * Now if the heap image was a 32-bit one but I am now on a 64-bit machine
3267 * I will allocate more pages (if necessary) to ensure that a copying
3268 * garbage collection will be possible.
3269 */
3270 i = 2*heap_pages_count+3*vheap_pages_count+
3271 3*bps_pages_count - pages_count;
3272 while (i-- > 0)
3273 { void *page = my_malloc_1((size_t)(CSL_PAGE_SIZE + 16));
3274 if (page == NULL)
3275 {
3276 fatal_error(err_no_store);
3277 }
3278 else pages[pages_count++] = page;
3279 }
3280 gc_method_is_copying = 1;
3281 }
3282 #endif /* MEMORY_TRACE */
3283
3284 #ifdef MEMORY_TRACE
3285 #ifndef CHECK_ONLY
3286 memory_comment(9); /* adjusting */
3287 #endif
3288 #endif
3289 inject_randomness((int)clock());
3290 adjust_all();
3291
3292 #ifdef MEMORY_TRACE
3293 #ifndef CHECK_ONLY
3294 memory_comment(12); /* remainder of setup */
3295 #endif
3296 #endif
3297 /*
3298 * An explanation is needed here. Hash tables can be really odd things in
3299 * that if they are keyed on the EQ test they are based on memory addresses
3300 * that objects lie at. So the garbage collector has to do magic things with
3301 * them! I therefore keep a list of all hash tables, but it must not be
3302 * processed in a naive way. I keep it in a variable that is NOT in the range
3303 * of places where the garbage collector normally looks. But when it comes
3304 * to preserve and restart I need to save the information, so I have the two
3305 * lists I need saved in the nilseg under the aliass eq_hash_table_list and
3306 * equal_hash_table_list. As soon as I can I extract them and put them
3307 * back in the magic special places they need to live.
3308 */
3309 eq_hash_tables = eq_hash_table_list;
3310 equal_hash_tables = equal_hash_table_list;
3311 eq_hash_table_list = equal_hash_table_list = nil;
3312 { Lisp_Object qq;
3313 for (qq = eq_hash_tables; qq!=nil; qq=qcdr(qq))
3314 { if (!is_vector(qcar(qq)))
3315 { printf("qq=%p should be a vector\n", (void *)qcar(qq));
3316 exit(4);
3317 }
3318 rehash_this_table(qcar(qq));
3319 }
3320 for (qq = equal_hash_tables; qq!=nil; qq=qcdr(qq))
3321 { if (!is_vector(qcar(qq)))
3322 { printf("qq=%p should be a vector\n", (void *)qcar(qq));
3323 exit(4);
3324 }
3325 rehash_this_table(qcar(qq));
3326 }
3327 }
3328
3329 /*
3330 * The following few lines allude to a historical oddity from before the time
3331 * when 32 bit and 64-bit images could be used interchangably. The fields
3332 * stored used to be explicitly 32-bit ones even on a 64-bit machine. Now they
3333 * are 64-bit values in that case. When they were 32-bit values on a 64-bit
3334 * machine they lived in the low memory address of that (double)word. Now
3335 * where they live depends on the byte order of the machine that wrote them!
3336 * this all really messes up conversion between different word lengths and
3337 * different byte orderings. Part of the hack to unwind that is that if I am
3338 * NOW on a 64-bit machine I may end up after flipping with data in the
3339 * top not the low part of the 64-bit words, so I patch that.
3340 */
3341 gensym_ser = flip_bytes(gensym_ser);
3342 print_precision = flip_bytes(print_precision);
3343 miscflags = flip_bytes(miscflags);
3344 current_modulus = flip_bytes(current_modulus);
3345 fastget_size = flip_bytes(fastget_size);
3346 package_bits = flip_bytes(package_bits);
3347 /*
3348 * The adjustments used here can arise when I have read a 32-bit image in
3349 * on a 64-bit machine, but may possibly arise if I load an ancient 64-bit
3350 * image on a computer with the opposite byte order. I think one might say
3351 * that this sort of trouble relates to my breaching various rules related
3352 * to strict aliasing! Observe that I expect and indeed demand that the
3353 * quantities stored here are really just 31-bits - that is to reduce pain
3354 * associated with sign extension into the high 32-bits of a 64-bit value.
3355 * So you see it seems best to do this even if I am not converting from
3356 * 32 to 64 bits.
3357 */
3358 if (SIXTY_FOUR_BIT)
3359 { if ((int32_t)gensym_ser==0)
3360 gensym_ser =
3361 (Lisp_Object)(((int64_t)gensym_ser)>>32) & 0x7fffffff;
3362 if ((int32_t)print_precision==0)
3363 print_precision =
3364 (Lisp_Object)(((int64_t)print_precision)>>32) & 0x7fffffff;
3365 if ((int32_t)miscflags==0)
3366 miscflags =
3367 (Lisp_Object)(((int64_t)miscflags)>>32) & 0x7fffffff;
3368 if ((int32_t)current_modulus==0)
3369 current_modulus =
3370 (Lisp_Object)(((int64_t)current_modulus)>>32) & 0x7fffffff;
3371 if ((int32_t)fastget_size==0)
3372 fastget_size =
3373 (Lisp_Object)(((int64_t)fastget_size)>>32) & 0x7fffffff;
3374 if ((int32_t)package_bits==0)
3375 package_bits =
3376 (Lisp_Object)(((int64_t)package_bits)>>32) & 0x7fffffff;
3377 }
3378
3379 set_up_functions(1);
3380 set_up_variables(1);
3381 /*
3382 * Now I have closed the main heap image, but if there is any hard machine
3383 * code available for this architecture I should load it. When I do this
3384 * the main heap has been loaded and relocated and all the entrypoints
3385 * in it that relate to kernel code have been inserted.
3386 */
3387 if (native_code_tag != 0) /* Not worth trying if none available */
3388 { if (!IopenRoot(NULL, -native_code_tag, 0))
3389 { int32_t nn = Igetc() & 0xff;
3390 nn = nn + ((Igetc() & 0xff) << 8);
3391 native_pages_count = nn;
3392 for (i=0; i<native_pages_count; i++)
3393 { intptr_t p;
3394 /*
3395 * Because I did not know earlier how many pages would be needed here I
3396 * may not have overall enough. So I expand my heap (if possible)
3397 * when things start to look tight here.
3398 */
3399 if (pages_count <= 1)
3400 { void *page = my_malloc_1((size_t)(CSL_PAGE_SIZE + 16));
3401 if (page == NULL)
3402 {
3403 fatal_error(err_no_store);
3404 }
3405 else pages[pages_count++] = page;
3406 }
3407 native_pages[i] = allocate_page("native code");
3408 p = (intptr_t)native_pages[i];
3409 p = doubleword_align_up(p);
3410 fread_count = 0;
3411 Cfread((char *)p, CSL_PAGE_SIZE);
3412 native_fringe = car32(p);
3413 relocate_native_code((unsigned char *)p, native_fringe);
3414 }
3415 IcloseInput(YES);
3416 }
3417 }
3418 /*
3419 * With a warm start I must instate the definitions of all functions
3420 * that may have been compiled into hard code on this platform. Functions that
3421 * may be hard-coded on SOME platform may also be in a mess and will have
3422 * a byte-coded definition put back in place at this point. Observe that this
3423 * happens AFTER the system has otherwise been loaded and relocated.
3424 */
3425 { Lisp_Object f_list = native_code, byte_code_def;
3426 do_not_kill_native_code = 1;
3427 while (f_list != nil)
3428 { Lisp_Object w, fn, defs;
3429 int32_t nargs;
3430 int instated_something = 0;
3431 byte_code_def = nil;
3432 w = qcar(f_list);
3433 f_list = qcdr(f_list);
3434 fn = qcar(w); w = qcdr(w);
3435 nargs = int_of_fixnum(qcar(w));
3436 defs = qcdr(w);
3437 while (defs != nil)
3438 { int32_t n, tag, type, off;
3439 intptr_t page;
3440 void *e;
3441 w = qcar(defs);
3442 defs = qcdr(defs);
3443 n = int_of_fixnum(qcar(w));
3444 w = qcdr(w);
3445 tag = (n >> 20) & 0xff;
3446 type = (n >> 18) & 0x3;
3447 page = n & 0x3ffff;
3448 if (tag == 0)
3449 { byte_code_def = qcdr(w);
3450 continue;
3451 }
3452 if (tag != native_code_tag) continue; /* Not for me today */
3453 instated_something = 1;
3454 off = int_of_fixnum(qcar(w));
3455 w = qcdr(w);
3456 /*
3457 * Now fn should be a symbol, the function to be defined. w is the thing to go
3458 * into its environment cell. page and off define a location in the hard
3459 * code space and type tells me which of the 3 function cells to put that in.
3460 *
3461 * I will not (yet) mess around with the removal of C definition
3462 * flags and all the other delicacies. Note that this means attempts to
3463 * redefine built-in functions with user-provided native code varients
3464 * may cause all sorts of muddle! Please do not try it, but when you
3465 * do (!) tell me and I will attempt to work out what ought to happen.
3466 * Maybe it will all be OK provided that a consistent byte-code definition
3467 * is in place before any native code gets generated.
3468 */
3469 page = (intptr_t)native_pages[page];
3470 page = doubleword_align_up(page);
3471 e = (void *)((char *)page + off);
3472 switch (type)
3473 {
3474 /*
3475 * Warning - I just support nargs being a simple integer here, with no
3476 * fancy encoding for variable numbers of args or &rest args etc. I think
3477 * that for native code all such cases need to be dealt with via non-zero
3478 * type code so that the 3 individual function cells get filled in one
3479 * by 1.
3480 */
3481 case 0: switch (nargs)
3482 {
3483 case 0: set_fns(fn, wrong_no_0a, wrong_no_0b, (n_args *)e);
3484 break;
3485 case 1: set_fns(fn, (one_args *)e, too_many_1, wrong_no_1);
3486 break;
3487 case 2: set_fns(fn, too_few_2, (two_args *)e, wrong_no_2);
3488 break;
3489 case 3: set_fns(fn, wrong_no_3a, wrong_no_3b, (n_args *)e);
3490 break;
3491 default:set_fns(fn, wrong_no_na, wrong_no_nb, (n_args *)e);
3492 break;
3493 }
3494 break;
3495 /*
3496 * A non-zero type field allows me to fill in just one of the function cells.
3497 * Note that I ought to arrange to get ALL of them filled in somehow, either
3498 * by using type=0 or by using all three of type = 1,2,3.
3499 */
3500 case 1: ifn1(fn) = (intptr_t)e;
3501 break;
3502 case 2: ifn2(fn) = (intptr_t)e;
3503 break;
3504 case 3: ifnn(fn) = (intptr_t)e;
3505 break;
3506 }
3507 qenv(fn) = w;
3508 }
3509 if (!instated_something && byte_code_def != nil)
3510 { w = cons(fixnum_of_int(nargs), byte_code_def);
3511 /*
3512 * You can look at this bit of code and moan, saying "What happens if
3513 * the call to CONS causes a garbage collection?". Well I have this policy
3514 * that garbage collection attempts during startup should be thought of
3515 * as fatal, and that the user should give enough memory to make it possible
3516 * to get at least started. I hope that I do not generate much litter here
3517 * and in other places within the startup code. Not thinking about GC
3518 * safety leaves the code neater and easier to work with.
3519 */
3520 Lsymbol_set_definition(nil, fn, w);
3521 }
3522 }
3523 do_not_kill_native_code = 0;
3524 }
3525 /*
3526 * The stuff above is about the internal native compilation that I am no
3527 * longer pursuing. Well I may look back at it some day, but it would
3528 * involve CSL itselh having compiler back-ends for all relevant architectures
3529 * and now I am moving to using a local C compiler to do that stuff.
3530 */
3531 { Lisp_Object n = native_defs;
3532 char *p;
3533 while (n != nil)
3534 { Lisp_Object w, name, mod, fname, env, env1, checksum;
3535 setup_type_1 *table, *tp;
3536 uint32_t *pp;
3537 int32_t len;
3538 name = qcar(n);
3539 n = qcdr(n);
3540 w = get(name, nativecoded_symbol);
3541 if (consp(w))
3542 { mod = qcar(w);
3543 w = qcdr(w);
3544 if (consp(w))
3545 { fname = qcar(w);
3546 w = qcdr(w);
3547 if (consp(w))
3548 { checksum = qcar(w);
3549 env = qcdr(w);
3550 }
3551 else continue;
3552 }
3553 else continue;
3554 }
3555 else continue;
3556 /*
3557 * If I get here I have
3558 * name the Lisp symbol that may get a native definition
3559 * mod a string that names the module it lives in
3560 * fname the name of the function in the native code to load
3561 * env an environment to give the native definition
3562 * checksum module checksum
3563 * name and fname may differ, for instance fname is the name that the
3564 * function had when it was compiled, but a copy of the definition may
3565 * have been copied to name...
3566 */
3567 #ifdef TRACE_NATIVE
3568 trace_printf("Possible native def: ");
3569 prin_to_trace(name);
3570 trace_printf("\nmodule: ");
3571 prin_to_trace(mod);
3572 trace_printf("\nfname: ");
3573 prin_to_trace(fname);
3574 trace_printf("\nEnv: ");
3575 prin_to_trace(env);
3576 trace_printf("\nChecksum: ");
3577 prin_to_trace(checksum);
3578 trace_printf("\n");
3579 #endif
3580 /*
3581 * First I will try to ensure that the module concerned gets loaded. It
3582 * may have been already, in which case I just need its handle.
3583 */
3584 push4(name, fname, env, n);
3585 table = find_def_table(mod, checksum);
3586 pop4(n, env, fname, name);
3587 if (table == NULL) continue; /* This module is not available */
3588 #ifdef TRACE_NATIVE
3589 trace_printf("setup table at %p\n", table);
3590 #endif
3591 /* Now seek for fname in there... */
3592 tp = table;
3593 while (tp->name != NULL) tp++;
3594 #ifdef SOON
3595 modname = "???";
3596 if (strcmp(modname, (char *)tp->one) != 0)
3597 { trace_printf("Module name %s disagrees with %s\n",
3598 modname, (char *)tp->one);
3599 continue;
3600 }
3601 #else
3602 #ifdef DEBUG_NATIVE
3603 modname = "???";
3604 trace_printf("module itself says it is called %s, wants to be %s\n", (char *)tp->one, modname);
3605 #endif
3606 #endif
3607 push4(name, fname, env, n);
3608 p = get_string_data(fname, "restart:native_code", &len);
3609 pop4(n, env, fname, name);
3610 nil = C_nil;
3611 if (exception_pending()) continue;
3612 while (tp!=table)
3613 { tp--;
3614 if (strncmp(p, tp->name, len) == 0 &&
3615 strlen(tp->name)==len)
3616 { p = NULL;
3617 break;
3618 }
3619 }
3620 if (p != NULL) continue;
3621 /*
3622 * I will ONLY install native code if I have a bytecoded version in place
3623 * already. Note that I will require the function now about to be
3624 * redefined to have a bytecoded form that agrees wrt a checksum with the
3625 * native code version from the dynamically loaded module.
3626 * WELL there is an issue about the tail-call specials. They have a
3627 * symbol in the env cell and no checksum for me to look at at all. I
3628 * think I will just trust things in those cases.
3629 */
3630 env1 = qenv(name);
3631 #ifdef TRACE_NATIVE
3632 prin_to_trace(env1);
3633 trace_printf(" is the bytecoded version\n");
3634 #endif
3635 if (!is_symbol(env))
3636 { if (!consp(env1) || !is_bps(qcar(env1))) continue;
3637 env1 = qcdr(env1);
3638 if (!is_vector(env1)) continue;
3639 env1 = Lgetv(nil, env1, Lupbv(nil, env1));
3640 #ifdef TRACE_NATIVE
3641 prin_to_trace(env1); trace_printf(" should be checksum again\n");
3642 #endif
3643 if (!is_numbers(env1) || !is_bignum(env1)) continue;
3644 pp = bignum_digits(env1);
3645 #ifdef TRACE_NATIVE
3646 trace_printf("%u %u vs %u %u\n", pp[0], pp[1], tp->c2, tp->c1);
3647 #endif
3648 if (pp[0] != tp->c2 || pp[1] != tp->c1) continue;
3649 }
3650 if (load_limit != 0x7fffffff)
3651 { if (load_count >= load_limit) continue;
3652 prin_to_trace(name);
3653 trace_printf(" : %d\n", load_count++);
3654 }
3655 /*
3656 * Gosh: now I can actually make the function available to users!
3657 */
3658 #ifdef TRACE_NATIVE
3659 trace_printf("actually set up native function\n");
3660 #endif
3661 /*
3662 * The symbol I am about to define is already on native_defs and
3663 * has all the property-list info that it needs, so I am in the
3664 * happy situation of not needing to do much here.
3665 */
3666 ifn1(name) = (intptr_t)tp->one;
3667 ifn2(name) = (intptr_t)tp->two;
3668 ifnn(name) = (intptr_t)tp->n;
3669 qenv(name) = env;
3670 }
3671 }
3672 inject_randomness((int)clock());
3673 }
3674
3675 static char dll_cache_directory[LONGEST_LEGAL_FILENAME] = {0};
3676
find_dll_cache_directory()3677 static void find_dll_cache_directory()
3678 {
3679 unsigned char md[16];
3680 char userinfo[80], counts[8];
3681 int i;
3682 #ifdef WIN32
3683 DWORD n;
3684 #endif
3685 char *p;
3686 struct stat stbuf;
3687 int count;
3688 if (dll_cache_directory[0] != 0) return;
3689 /*
3690 * This does its real work just once. But I may need to re-try
3691 * if the first choice directory name does not work well.
3692 */
3693 for (count=0; count<100; count++)
3694 { CSL_MD5_Init();
3695 sprintf(counts, "%d:", count);
3696 CSL_MD5_Update((unsigned char *)counts, strlen(counts));
3697 CSL_MD5_Update((unsigned char *)fwin_full_program_name,
3698 strlen(fwin_full_program_name));
3699 #ifdef WIN32
3700 userinfo[0] = ';';
3701 n = sizeof(userinfo) - 1;
3702 if (!GetUserName(userinfo+1, &n)) strcpy(userinfo, ";UnknownUser;");
3703 else strcat(userinfo, ";");
3704 if (GetTempPath(LONGEST_LEGAL_FILENAME, dll_cache_directory) == 0)
3705 strcpy(dll_cache_directory, ".\\");
3706 #else
3707 sprintf(userinfo, ";%d;", geteuid());
3708 strcpy(dll_cache_directory, "/tmp/");
3709 #endif
3710 CSL_MD5_Update((unsigned char *)userinfo, strlen(userinfo));
3711 CSL_MD5_Update((unsigned char *)linker_type, strlen(linker_type));
3712 CSL_MD5_Final(md);
3713 #ifdef TRACE_NATIVE
3714 trace_printf("Base cache name on %s %s %s\n",
3715 fwin_full_program_name, userinfo, linker_type);
3716 #endif
3717 p = dll_cache_directory + strlen(dll_cache_directory);
3718 /*
3719 * The name of the directory that I invent will be the letters
3720 * CSL followed by 25 characters (0-9, a-t) (ie 25*5-125 bits derived
3721 * from an MD5 checksum).
3722 */
3723 *p++ = 'C'; *p++ = 'S'; *p++ = 'L';
3724 for (i=0; i<25; i++)
3725 { int j, w = 0;
3726 for (j=15; j>=0; j--)
3727 { int w1 = (md[j] >> 5) | (w << 3);
3728 w = md[j] & 0x1f;
3729 md[j] = w1;
3730 }
3731 if (w < 10) *p++ = '0' + w;
3732 else *p++ = 'a' + w - 10;
3733 }
3734 *p = 0;
3735 #ifdef TRACE_NATIVE
3736 trace_printf("DLL cache directory will be %s\n", dll_cache_directory);
3737 #endif
3738 /*
3739 * I should now verify that that directory exists and is readable and
3740 * writable! If it is I am done. If not I will try to create it as
3741 * a directory - if that works I can return. If that still does not help
3742 * I will loop to try a second-choice name. If the "temporary directory"
3743 * that I obtained did not exist this might loop I suppose, so anybody
3744 * who sets the shell variable TEMP to something silly might get hurt? To
3745 * avoid infinite pain I will just declare disaster if I do not succeed in
3746 * a fair number of tries.
3747 */
3748 if (stat(dll_cache_directory, &stbuf) == 0 &&
3749 #ifdef S_IRUSR
3750 stbuf.st_mode & S_IRUSR &&
3751 #endif
3752 #ifdef S_IWUSR
3753 stbuf.st_mode & S_IWUSR &&
3754 #endif
3755 (stbuf.st_mode & S_IFMT) == S_IFDIR) return;
3756 Cmkdir(dll_cache_directory);
3757 if (stat(dll_cache_directory, &stbuf) == 0 &&
3758 #ifdef S_IRUSR
3759 stbuf.st_mode & S_IRUSR &&
3760 #endif
3761 #ifdef S_IWUSR
3762 stbuf.st_mode & S_IWUSR &&
3763 #endif
3764 (stbuf.st_mode & S_IFMT) == S_IFDIR) return;
3765 }
3766 /*
3767 * here 100 different attempts to find a suitable directory have all
3768 * failed. I just give up!
3769 */
3770 fatal_error(err_no_tempdir);
3771 }
3772
3773 static char objname[LONGEST_LEGAL_FILENAME];
3774
tidy_up_old_dlls(const char * name,int why,long int size)3775 static void tidy_up_old_dlls(const char *name, int why, long int size)
3776 {
3777 const char *p = name, *q = objname;
3778 /*
3779 * If the file I have found has a name rather like objname then I will delete
3780 * it. So I will start to scanning past initial equal parts in the names.
3781 */
3782 while ((*p)==(*q) && (*p)!=0)
3783 { p++;
3784 q++;
3785 }
3786 /*
3787 * Now if p is of the form (where nnn is numeric)
3788 * nnn-nnn-nnn.dll or nnn-nnn-nnn.so
3789 * it is an old DLL for the same module so it should go. I have
3790 * some fairly grotty code here that is intended to detect this
3791 * pattern. Well it is a bit messier than that - the first few chars of the
3792 * checksum info may have matched...
3793 */
3794 while (*p != 0 && isdigit(*p)) p++;
3795 if (*p == '-') p++;
3796 while (*p != 0 && isdigit(*p)) p++;
3797 if (*p == '-') p++;
3798 while (*p != 0 && isdigit(*p)) p++;
3799 if (strcmp(p, ".dll") != 0 &&
3800 strcmp(p, ".so") != 0) return;
3801 #ifdef TRACE_NATIVE
3802 trace_printf("Deleting old DLL file %s\n", name);
3803 #endif
3804 remove(name);
3805 }
3806
find_def_table(Lisp_Object mod,Lisp_Object checksum)3807 static setup_type_1 *find_def_table(Lisp_Object mod, Lisp_Object checksum)
3808 {
3809 int32_t len, checklen;
3810 char *sname, *checkname;
3811 char modname[80], xmodname[LONGEST_LEGAL_FILENAME];
3812 char sname1[LONGEST_LEGAL_FILENAME];
3813 Ihandle save;
3814 FILE *dest;
3815 int c;
3816 Lisp_Object nil = C_nil;
3817 char setupname[80];
3818 char *p;
3819 setup_type_1 *dll;
3820 initfn *init;
3821 #ifdef WIN32
3822 HANDLE a;
3823 UINT ww;
3824 #else
3825 void *a;
3826 #endif
3827 #ifdef TRACE_NATIVE
3828 trace_printf("find_def_table ");
3829 prin_to_trace(mod);
3830 trace_printf("\n");
3831 ensure_screen();
3832 #endif
3833
3834 sname = get_string_data(mod, "find_def_table", &len);
3835 nil = C_nil;
3836 if (exception_pending()) return NULL;
3837 checkname = get_string_data(checksum, "find_def_table", &checklen);
3838 nil = C_nil;
3839 if (exception_pending()) return NULL;
3840 #ifdef TRACE_NATIVE
3841 trace_printf("Checksum given as \"%.*s\"\n", checklen, checkname);
3842 #endif
3843 sprintf(sname1, "%.*s-%.*s", (int)len, sname, (int)checklen, checkname);
3844 p = sname1;
3845 while (*p!=0)
3846 { if (*p == ' ') *p = '-';
3847 p++;
3848 }
3849 dll = find_dynamic_module(sname1, strlen(sname1));
3850 if (dll != NULL) return dll;
3851 /*
3852 * I keep dynamically-loadable read code in the image where a module
3853 * whose portable version is called foo.fasl might have a machine-specific
3854 * variant foo.win32.fasl.
3855 */
3856 sprintf(modname, "%.*s.%s", (int)len, sname, linker_type);
3857
3858 /*
3859 * Here I will do some more cache-style activity. I will hold a
3860 * dirctory typically called /tmp/nnnnnn (where nnnnn is a checksum
3861 * on fwin_full_program_name and the linker type and the curren user)
3862 * and put extracted DLL files there.
3863 * If I find one present there I will use it. Otherwise I
3864 * will extract it from the image file. This may give me trouble
3865 * with regard to versioning, and so when I initially create or update
3866 * a file in the image I should delete any cached version as outdated.
3867 * (that last bit not done to start with)
3868 */
3869 find_dll_cache_directory();
3870
3871 #ifdef TRACE_NATIVE
3872 trace_printf("Attempt to load module %s\n", modname);
3873 #endif
3874 /*
3875 * Now if dll_cache_directory/sname.[so/dll] exists I will use it.
3876 * otherwise I will create it by copying from the image file.
3877 * The name I use here will include checksum information. At some stage
3878 * I should possibly try to delete any files in the cache that match in
3879 * their root but disagree in the checksum portion, since they are liable
3880 * to be old.
3881 */
3882 #ifdef WIN32
3883 sprintf(objname, "%s\\%s.dll", dll_cache_directory, sname1);
3884 #else
3885 sprintf(objname, "%s/%s.so", dll_cache_directory, sname1);
3886 #endif
3887 #ifdef TRACE_NATIVE
3888 trace_printf("Invented name %s for temp location of module\n", objname);
3889 #endif
3890 { struct stat stbuf;
3891 /*
3892 * Check if the module exists in the cache - if not try to create it...
3893 * I count the DLL as unavailable if either stat fails (which may indicate
3894 * that the file does not exist) or if it is not readable by its owner
3895 * (who ought to be me!). Not if it is not readable it may not be writable
3896 * either, and in that case the attempt here to create it will fail.
3897 */
3898 if (stat(objname, &stbuf) != 0
3899 #ifdef S_IRUSR
3900 || (stbuf.st_mode & S_IRUSR) == 0
3901 #endif
3902 )
3903 { Icontext(&save);
3904 if (Iopen(modname, strlen(modname), IOPEN_UNCHECKED, xmodname))
3905 { Irestore_context(save);
3906 trace_printf("module not found\n");
3907 return NULL;
3908 }
3909
3910 #ifdef TRACE_NATIVE
3911 trace_printf("Will now copy %s to the DLL cache\n", modname);
3912 #endif
3913 /*
3914 * Here I can tidy up the cache directory. I want to DELETE any files in
3915 * it whose names are somewhat similar to the one I am about to create.
3916 * Just for now I will just print a message ratherthan actually do anything.
3917 */
3918 set_hostcase(1);
3919 scan_files(dll_cache_directory, tidy_up_old_dlls);
3920 /*
3921 * Here I can read and process the module...
3922 */
3923 dest = fopen(objname, "wb");
3924 if (dest == NULL) /* failed to write to temp file */
3925 { IcloseInput(0);
3926 Irestore_context(save);
3927 return NULL;
3928 }
3929 while ((c = Igetc()) != EOF)
3930 putc(c, dest);
3931 IcloseInput(0);
3932 Irestore_context(save);
3933 if (fclose(dest) != 0)
3934 { trace_printf("failed to write DLL to temp directory\n");
3935 return NULL;
3936 }
3937 }
3938 }
3939 /*
3940 * Now I have copied the object file data to a "real" but temporary file.
3941 */
3942 sprintf(modname, "%.*s", (int)len, sname);
3943
3944 #ifdef TRACE_NATIVE
3945 trace_printf("load_dynamic for find_def_table %s %s\n", objname, modname);
3946 #endif
3947 sprintf(setupname, "%s_setup", modname);
3948 for (p=setupname; *p!=0; p++)
3949 if (*p=='-') *p='_';
3950 #ifdef TRACE_NATIVE
3951 trace_printf("Look for \"%s\"\n", setupname);
3952 #endif
3953 #ifdef WIN32
3954 /*
3955 * In various cases of failure Windows has a default behaviour of popping
3956 * up a dialog box when a DLL can not be loaded. I do not want that, since
3957 * I intend to recover graciously if the module can not be located or
3958 * loaded.
3959 */
3960 ww = SetErrorMode(SEM_FAILCRITICALERRORS);
3961 #ifdef TRACE_NATIVE
3962 trace_printf("Loading DLL called %s for %s\n", objname, modname);
3963 #endif
3964 a = LoadLibrary(objname);
3965 if (a == 0)
3966 { DWORD err = GetLastError(), err1;
3967 LPTSTR errbuf = NULL;
3968 /*
3969 * If I let Windows pop up its message box I still seem to get more info
3970 * than FormatMessage presents me with... Specifically if the module I tried
3971 * to load refused to because of a symbol that it needed to load, the
3972 * pop up tells me the name of that symbol.
3973 */
3974 err1 = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |
3975 FORMAT_MESSAGE_ALLOCATE_BUFFER |
3976 FORMAT_MESSAGE_IGNORE_INSERTS,
3977 NULL,
3978 err,
3979 MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
3980 (LPTSTR)&errbuf,
3981 0,
3982 NULL);
3983 if (err1 == 0 || errbuf==NULL)
3984 trace_printf("FormatMessage on code %d failed with %d\n",
3985 (int)err, (int)GetLastError());
3986 else
3987 { trace_printf("%s", errbuf);
3988 LocalFree(errbuf);
3989 }
3990 }
3991 SetErrorMode(ww);
3992 #ifdef TRACE_NATIVE
3993 trace_printf("Dynamic loading of test code\na = %p\n", (void *)a);
3994 #endif
3995 if (a == 0) return 0;
3996 dll = (setup_type_1 *)GetProcAddress(a, setupname);
3997 /*
3998 * The dynamic module that I create should always have a function called
3999 * "init" that I must call to tell it where nil, stack and stacklimit are.
4000 */
4001 init = (initfn *)GetProcAddress(a, "init");
4002 #else
4003 #ifdef EMBEDDED
4004 return 0;
4005 #else
4006 a = dlopen(objname, RTLD_NOW | RTLD_GLOBAL);
4007 #ifdef TRACE_NATIVE
4008 trace_printf("a = %p\n", a);
4009 #endif
4010 if (a == NULL)
4011 { trace_printf("Err = <%s>\n", dlerror()); fflush(stdout);
4012 return 0;
4013 }
4014 dll = (setup_type_1 *)dlsym(a, setupname);
4015 init = (initfn *)dlsym(a, "init");
4016 #endif
4017 #ifdef TRACE_NATIVE
4018 trace_printf("setup table is %p, init fn is %p\n", dll, init);
4019 #endif
4020 if (dll == NULL || init == NULL)
4021 {
4022 #ifdef WIN32
4023 FreeLibrary(a);
4024 #endif
4025 return NULL;
4026 }
4027 (*init)(&C_nil, &C_stack, &stacklimit);
4028 /*
4029 * Wheee - I have now loaded and initialised the module.
4030 */
4031 #ifdef TRACE_NATIVE
4032 { setup_type_1 *b = dll;
4033 while (b->name != NULL)
4034 { trace_printf("%s %p %p %p %u %u\n",
4035 b->name, b->one, b->two, b->n, b->c1, b->c2);
4036 b++;
4037 }
4038 trace_printf("%s %s\n", (char *)(b->one), (char *)(b->two));
4039 }
4040 #endif
4041 /*
4042 * remove(objname);
4043 * At one stage I wanted to count the DLL files as temporary - but now I keep
4044 * them all in a cache directory, so I really do NOT want to delete them
4045 * here... If the user deletes them that will not be a problem - they will get
4046 * re-created if necessary.
4047 */
4048
4049 /*
4050 * Update the cache...
4051 */
4052 p = (char *)malloc(strlen(sname1)+1);
4053 strcpy(p, sname1);
4054 p[len] = 0;
4055 record_dynamic_module(p, dll);
4056 return dll;
4057 #endif /* EMBEDDED */
4058 }
4059
setup_dynamic(setup_type_1 * dll,char * modname,Lisp_Object name,Lisp_Object fns)4060 int setup_dynamic(setup_type_1 *dll, char *modname,
4061 Lisp_Object name, Lisp_Object fns)
4062 {
4063 char *p;
4064 setup_type_1 *b;
4065 int32_t len;
4066 Lisp_Object nil = C_nil, xchecksum;
4067 int32_t all_ok = 1;
4068 #ifdef TRACE_NATIVE
4069 trace_printf("setup_dynamic %s\n", modname);
4070 /* prin_to_trace(fns); */ trace_printf("\n");
4071 #endif
4072 if (!consp(fns)) return 0;
4073 #ifdef TRACE_NATIVE
4074 b = dll;
4075 while (b->name != NULL)
4076 { trace_printf("%s %p %p %p %u %u\n",
4077 b->name, b->one, b->two, b->n, b->c1, b->c2);
4078 b++;
4079 }
4080 trace_printf("%s %s\n", (char *)(b->one), (char *)(b->two));
4081 #endif
4082 /*
4083 * First I will check if the module loaded appears to match against the set
4084 * of functions I am expecting from it...
4085 */
4086 b = dll;
4087 while (b->name != NULL) b++;
4088 /*
4089 * now b->one is expected to match modname, and b->two is expected
4090 * to match the string that is the first item in fns.
4091 */
4092 if (strcmp(modname, (char *)b->one) != 0)
4093 { trace_printf("Module name %s disagrees with %s\n",
4094 modname, (char *)b->one);
4095 return 0;
4096 }
4097 p = get_string_data(qcar(fns), "instate_c_code", &len);
4098 nil = C_nil;
4099 if (exception_pending()) return 0;
4100 if (strncmp(p, (char *)b->two, len) != 0)
4101 { trace_printf("Module signature %.*s disagrees with %s\n",
4102 (int)len, p, (char *)b->two);
4103 return 0;
4104 }
4105 xchecksum = qcar(fns);
4106 fns = qcdr(fns);
4107 b = dll;
4108 /*
4109 * Now the table b and the list fns ought to match up. The list will have
4110 * entries
4111 * (name (e1 e2 ... en) . check)
4112 * where the name is the name of a Lisp function and the list needs
4113 * turning into a vector to go into its environment cell.
4114 * The table has columns
4115 * name f1 f2 n2 c1 c2
4116 * where the name ought to match what is seen in the list, and then the
4117 * three functions go in the f1, f2 and fn cells. I will stop if I get
4118 * any mismatch at all - just to be cautious!
4119 */
4120 while (consp(fns))
4121 { Lisp_Object fname, env, env1, ww;
4122 if (b->name == NULL)
4123 {
4124 #ifdef TRACE_NATIVE
4125 trace_printf("Failed: setup table length problem\n");
4126 #endif
4127 return 0; /* lengths of lists differ */
4128 }
4129 env = qcar(fns);
4130 if (consp(env))
4131 { fname = qcar(env);
4132 env = qcdr(env);
4133 if (consp(env))
4134 { Lisp_Object chk = qcdr(env);
4135 uint32_t *pp;
4136 env = qcar(env);
4137 p = get_string_data(fname, "instate_c_code", &len);
4138 nil = C_nil;
4139 if (exception_pending())
4140 {
4141 #ifdef TRACE_NATIVE
4142 trace_printf("Failed: get_string_data\n");
4143 #endif
4144 return 0;
4145 }
4146 #ifdef TRACE_NATIVE
4147 trace_printf("instate next function %.*s vs %s\n", len, p, b->name);
4148 prin_to_trace(chk); trace_printf(" vs %u %u\n", b->c1, b->c2);
4149 #endif
4150 if (strncmp(p, b->name, len) != 0)
4151 {
4152 #ifdef TRACE_NATIVE
4153 trace_printf("Failed: name in setup table and env list differ\n");
4154 #endif
4155 return 0;
4156 }
4157 /*
4158 * There is a small chance of misery here. The checksum MIGHT happen to
4159 * be a 1-word bignum or even a fixnum. If that happens the tests here will
4160 * reject it and the native code will not get instated. If this happens
4161 * the result can be a performance loss but it ought not to lead to
4162 * incorrect results, and if the checksum scheme is good it is only
4163 * expected to hit for around 1 in 10^9 functions that are processed, so
4164 * I will (for now) accept it. If I ever feel twitchy I will respond by
4165 * ensuring that md60 always returns a 2-word bignum result. Hmm I AM twitchy
4166 * and I have now done just that!
4167 */
4168 if (!is_numbers(chk) || !is_bignum(chk))
4169 {
4170 #ifdef TRACE_NATIVE
4171 trace_printf("Failed: checksum not a number or not big\n");
4172 #endif
4173 return 0;
4174 }
4175 pp = bignum_digits(chk);
4176 #ifdef TRACE_NATIVE
4177 trace_printf("%u %u vs %u %u\n", pp[0], pp[1], b->c2, b->c1);
4178 #endif
4179 if (pp[0] != b->c2 || pp[1] != b->c1)
4180 { all_ok = 0; /* function's definition has changed? */
4181 #ifdef TRACE_NATIVE
4182 trace_printf("Failed on a function: checksum discrepancy\n");
4183 #endif
4184 goto next_def;
4185 }
4186 /*
4187 * I will ONLY install native code if I have a bytecoded version in place
4188 * already. I apply that rule to ensure that image files can be used across
4189 * different architectures. Well I will want to count tailcall magic as
4190 * OK.
4191 */
4192 env1 = qenv(fname);
4193 #ifdef TRACE_NATIVE
4194 prin_to_trace(env1);
4195 trace_printf(" is the bytecoded version\n");
4196 #endif
4197 if (qfn1(fname) == f1_as_0 ||
4198 qfn1(fname) == f1_as_1 ||
4199 qfn2(fname) == f2_as_0 ||
4200 qfn2(fname) == f2_as_1 ||
4201 qfn2(fname) == f2_as_2 ||
4202 qfnn(fname) == f0_as_0 ||
4203 qfnn(fname) == f3_as_0 ||
4204 qfnn(fname) == f3_as_1 ||
4205 qfnn(fname) == f3_as_2 ||
4206 qfnn(fname) == f3_as_3)
4207 { if (!is_symbol(env1))
4208 { all_ok = 0; /* malformed */
4209 #ifdef TRACE_NATIVE
4210 prin_to_trace(fname);
4211 trace_printf(" Failed on a function: tailcall with env malformed\n");
4212 #endif
4213 goto next_def;
4214 }
4215 }
4216 else
4217 { if (!consp(env1) || !is_bps(qcar(env1)))
4218 { all_ok = 0; /* no bytecoded version available */
4219 #ifdef TRACE_NATIVE
4220 prin_to_trace(fname);
4221 trace_printf(" Failed on a function: no bytecoded version\n");
4222 #endif
4223 goto next_def;
4224 }
4225 env1 = qcdr(env1);
4226 if (!is_vector(env1)) return nil;
4227 env1 = Lgetv(nil, env1, Lupbv(nil, env1));
4228 #ifdef TRACE_NATIVE
4229 prin_to_trace(env1); trace_printf(" should be checksum again\n");
4230 #endif
4231 if (!equal(env1, chk))
4232 { all_ok = 0; /* bytecoded definition differs */
4233 #ifdef TRACE_NATIVE
4234 trace_printf("Failed: bytecoded version checksum differs\n");
4235 #endif
4236 goto next_def;
4237 }
4238 }
4239 nil = C_nil;
4240 if (exception_pending()) return 0;
4241 push2(name, fname);
4242 env = Llist_to_vector(nil, env);
4243 pop2(fname, name);
4244 nil = C_nil;
4245 if (exception_pending()) return 0;
4246 if (load_limit != 0x7fffffff)
4247 { if (load_count >= load_limit)
4248 { all_ok = 0;
4249 goto next_def;
4250 }
4251 prin_to_trace(fname);
4252 trace_printf(" :: %d\n", load_count++);
4253 }
4254 /*
4255 * Gosh: now I can actually make the function available to users!
4256 */
4257 #ifdef TRACE_NATIVE
4258 trace_printf("actually set up native function\n");
4259 #endif
4260 /*
4261 * I want to do a few things in addition to filling in the function and
4262 * environment cells...
4263 * (a) ensure that this symbol is in the list "native_defs";
4264 * (b) give it a "bytecoded_symbol" property that captures all info about
4265 * the bytecode definition that I am displacing;
4266 * (c) give it a "nativecoded_symbol" property that should let me
4267 * re-instate this fast version of the code on subsequent runs when
4268 * the module loading must be repeated following a preserve/restart.
4269 */
4270 ww = native_defs;
4271 while (consp(ww))
4272 { if (qcar(ww) == fname) goto already_native;
4273 ww = qcdr(ww);
4274 }
4275 push4(name, fname, env, xchecksum);
4276 ww = cons(fname, native_defs);
4277 pop4(xchecksum, env, fname, name);
4278 nil = C_nil;
4279 if (exception_pending()) return 0;
4280 native_defs = ww;
4281 already_native:
4282 ww = Lsymbol_argcode(nil, fname);
4283 if (ww == nil) return 0;
4284 push4(name, fname, env, xchecksum);
4285 ww = cons(ww, qenv(fname));
4286 pop4(xchecksum, env, fname, name);
4287 nil = C_nil;
4288 if (exception_pending()) return 0;
4289 push4(name, fname, env, xchecksum);
4290 putprop(fname, bytecoded_symbol, ww);
4291 pop4(xchecksum, env, fname, name);
4292 nil = C_nil;
4293 if (exception_pending()) return 0;
4294 push4(name, fname, env, xchecksum);
4295 ww = list3star(name, fname, xchecksum, env);
4296 pop4(xchecksum, env, fname, name);
4297 nil = C_nil;
4298 if (exception_pending()) return 0;
4299 push4(name, fname, env, xchecksum);
4300 putprop(fname, nativecoded_symbol, ww);
4301 pop4(xchecksum, env, fname, name);
4302 nil = C_nil;
4303 if (exception_pending()) return 0;
4304 ifn1(fname) = (intptr_t)b->one;
4305 ifn2(fname) = (intptr_t)b->two;
4306 ifnn(fname) = (intptr_t)b->n;
4307 qenv(fname) = env;
4308 }
4309 }
4310 next_def:
4311 fns = qcdr(fns);
4312 b++;
4313 }
4314 /*
4315 * At present I take the view that when a module has been loaded it will
4316 * be wanted for the rest of the Lisp run, and so I do not unload it...
4317 */
4318 return 1;
4319 }
4320
4321 /*
4322 * The next function is to do with compiling modules into machine
4323 * code (via C) and tben dynamically loading them. The first argument is
4324 * the name given to the module, which is the same as the name of the
4325 * FASL file I believe I am loading now. Furthermore the module
4326 * should (when loaded) define an external symbol called
4327 * <name>_setup
4328 * that is its table of functions that it defines.
4329 *
4330 * The second argument will be a
4331 * header string "int int int" followed by a list of triples
4332 * (name env . checksum)
4333 * where each name should be in the setup table from the file, and the
4334 * corresponding env is a list that needs to be converted to a vector and
4335 * placed in the symbol's environment cell.
4336 *
4337 * Note that the final entry in the setup table is of the form
4338 * NULL, "name", "int int int", 0
4339 * and the name and triple of integers are expected to match the
4340 * information passed to instate_c_code. If they do not then the
4341 * modules concerned have somehow got out of step...
4342 */
4343
Linstate_c_code(Lisp_Object nil,Lisp_Object name,Lisp_Object fns)4344 Lisp_Object Linstate_c_code(Lisp_Object nil, Lisp_Object name, Lisp_Object fns)
4345 {
4346 /*
4347 * See if there is a module in the image file with the given name and
4348 * with its linker-tag matching the one for the current executable. If so
4349 * copy it to a temporary file called say t1.dll or t1.so. Dynamically load
4350 * it into memory. Keep the temporary file in a temporary directory but
4351 * where I might find it again next time I need it. Access a
4352 * symbol name_setup in it. The style of binary found should match the
4353 * information in the variable "linker_type". This version is to be called
4354 * by Lisp from a fasl-file as a module is loaded. The checksum information at
4355 * the start of "fns" will used in names for the .dll files and will be
4356 * recorded associated with the module name.
4357 */
4358 int32_t len;
4359 char *sname;
4360 char modname[80];
4361 int c;
4362 setup_type_1 *dll;
4363
4364 #ifdef TRACE_NATIVE
4365 trace_printf("instate_c_code ");
4366 prin_to_trace(name);
4367 trace_printf("\n");
4368 #endif
4369
4370 if (!consp(fns)) return onevalue(nil);
4371
4372 sname = get_string_data(name, "instate-c-code", &len);
4373 nil = C_nil;
4374 if (exception_pending()) return nil;
4375
4376 dll = find_def_table(name, qcar(fns));
4377 if (dll == NULL) return onevalue(nil);
4378
4379 sprintf(modname, "%.*s", (int)len, sname);
4380 c = setup_dynamic(dll, modname, name, fns);
4381 return onevalue(c ? lisp_true : nil);
4382 }
4383
4384 static void cold_setup();
4385
cold_setup()4386 static void cold_setup()
4387 {
4388 Lisp_Object nil = C_nil;
4389 void *p;
4390 int i;
4391 p = vheap_pages[vheap_pages_count++] = allocate_page("vheap cold setup");
4392 vfringe = (Lisp_Object)(8 + (char *)doubleword_align_up((intptr_t)p));
4393 vheaplimit = (Lisp_Object)((char *)vfringe + (CSL_PAGE_SIZE - 16));
4394
4395 p = heap_pages[heap_pages_count++] = allocate_page("heap cold setup");
4396 heaplimit = quadword_align_up((intptr_t)p);
4397 fringe = (Lisp_Object)((char *)heaplimit + CSL_PAGE_SIZE);
4398 heaplimit = (Lisp_Object)((char *)heaplimit + SPARE);
4399
4400 codelimit = codefringe = 0; /* no BPS to start with */
4401
4402 miscflags = 3;
4403 qplist(nil) = nil;
4404 qfastgets(nil) = nil;
4405 qenv(nil) = nil; /* points to self in undefined case */
4406 ifn1(nil) = (intptr_t)undefined1;
4407 ifn2(nil) = (intptr_t)undefined2;
4408 ifnn(nil) = (intptr_t)undefinedn;
4409 qheader(nil) = TAG_ODDS+TYPE_SYMBOL+SYM_SPECIAL_VAR;
4410 qvalue(nil) = nil;
4411 /*
4412 * When I am debugging CSL I can validate the heap, for instance whenever
4413 * I allocate vector. The call to make_string here does that, and so I MUST
4414 * have a tidy world in place here.
4415 */
4416 qpname(nil) = nil;
4417 for (i=first_nil_offset; i<last_nil_offset; i++)
4418 BASE[i] = nil;
4419 eq_hash_tables = equal_hash_tables = nil;
4420 #ifdef COMMON
4421 qpackage(nil) = nil;
4422 qpname(nil) = make_string("NIL");
4423 #else
4424 qpname(nil) = make_string("nil");
4425 #endif
4426 qcount(nil) = 0;
4427 exit_tag = exit_value = nil;
4428 exit_reason = UNWIND_NULL;
4429 eq_hash_tables = equal_hash_tables = nil;
4430
4431 current_package = nil;
4432 /*
4433 * The code here is generally coded on the supposition that there will NEVER
4434 * be a garbage collection here, so all the "fun" about push/pop and errexit
4435 * tests can be omitted. That makes this code much cleaner! It means that
4436 * during a cold start that there is enough space (well for a COLD start that
4437 * hardly likely to be an issue!) and in a warm start that none of the
4438 * calls that make strings or symbols etc here trigger a genuine garbage
4439 * collection - that can probably be assured by ensuring that on restart there
4440 * is at least a little bit of space in hand.
4441 */
4442 qvalue(nil) = getvector_init(sizeof(Package), nil);
4443 #ifdef COMMON
4444 qpackage(nil) = qvalue(nil); /* For sake of restart code */
4445 all_packages = ncons(qvalue(nil));
4446 #endif
4447
4448 packhdr_(CP) = TYPE_STRUCTURE + (packhdr_(CP) & ~header_mask);
4449 #ifdef COMMON
4450 packname_(CP) = make_string("LISP");
4451 #endif
4452 /*
4453 * The size chosen here is only an initial size - the hash table in a package
4454 * can grow later on if needbe - but I ought to ensure that the initial
4455 * size is big enough for the built-in symbols that Lisp creates in
4456 * this restart code. The size must be a power of 2. I want the object
4457 * table to have the same number of entries regardless of whether I am on
4458 * a 32 or 64-bit machine to make cross-loading of images possible.
4459 */
4460 packint_(CP) = getvector_init(CELL*(1+INIT_OBVECI_SIZE), fixnum_of_int(0));
4461 packvint_(CP) = fixnum_of_int(1);
4462 packflags_(CP) = fixnum_of_int(++package_bits);
4463 #ifdef COMMON
4464 /*
4465 * Common Lisp also has "external" symbols to allow for...
4466 */
4467 packnint_(CP) = fixnum_of_int(0);
4468 packext_(CP) = getvector_init(CELL*(1+INIT_OBVECX_SIZE), fixnum_of_int(0));
4469 packvext_(CP) = fixnum_of_int(1);
4470 packnext_(CP) = fixnum_of_int(1); /* Allow for nil */
4471 { int i = (int)(hash_lisp_string(qpname(nil)) &
4472 (INIT_OBVECX_SIZE - 1));
4473 elt(packext_(CP), i) = nil;
4474 }
4475 #else
4476 packnint_(CP) = fixnum_of_int(1); /* Allow for nil */
4477 { int i = (int)(hash_lisp_string(qpname(nil)) &
4478 (INIT_OBVECI_SIZE - 1));
4479 elt(packint_(CP), i) = nil;
4480 }
4481 #endif
4482 gensym_ser = 0;
4483 print_precision = 15;
4484 current_modulus = 1;
4485 fastget_size = 8*sizeof(Lisp_Object);
4486 package_bits = 0;
4487 unset_var = nil;
4488 /*
4489 * there had better not be a need for garbage collection here...
4490 * ... or elsewhere in setup, since the world is not yet put together.
4491 * Ditto interrupts.
4492 */
4493 #define boffo_size 256
4494 boffo = getvector(TAG_VECTOR, TYPE_STRING, CELL+boffo_size);
4495 memset((void *)((char *)boffo + (CELL - TAG_VECTOR)), '@', boffo_size);
4496 #ifndef COMMON
4497 if (current_package == nil)
4498 { current_package = make_undefined_symbol("*package*");
4499 qheader(current_package) |= SYM_SPECIAL_VAR;
4500 lisp_package = qvalue(current_package) = qvalue(nil);
4501 qvalue(nil) = nil;
4502 }
4503 #else
4504 /*
4505 * The next line has hidden depths. When it is obeyed during cold start
4506 * the C variable current_package has the value nil, hence make_symbol
4507 * looks in the value cell of nil to find the package to intern wrt. Once
4508 * this has been done I can put nil back how it ought to have been!
4509 */
4510 current_package = make_undefined_symbol("*package*");
4511 qheader(current_package)|= SYM_SPECIAL_VAR;
4512 lisp_package = qvalue(current_package) = qpackage(nil);
4513 qvalue(nil) = nil; /* Whew! */
4514 #endif
4515
4516 B_reg = nil; /* safe for GC */
4517 unset_var = make_undefined_symbol("~indefinite-value~");
4518 qheader(unset_var) |= SYM_SPECIAL_VAR;
4519 qvalue(unset_var) = unset_var;
4520 Lunintern(nil, unset_var);
4521 /*
4522 * Now in some minor sense the world is in a self-consistent state
4523 */
4524 lisp_true = make_undefined_symbol("t");
4525 qheader(lisp_true) |= SYM_SPECIAL_VAR;
4526 qvalue(lisp_true) = lisp_true;
4527 savedef = make_undefined_symbol("*savedef");
4528 comma_symbol = make_undefined_symbol("~comma");
4529 comma_at_symbol = make_undefined_symbol("~comma-at");
4530 lambda = make_undefined_symbol("lambda");
4531 funarg = make_undefined_symbol("funarg");
4532 cfunarg = make_undefined_symbol("cfunarg");
4533 opt_key = make_undefined_symbol("&optional");
4534 rest_key = make_undefined_symbol("&rest");
4535 #ifdef COMMON
4536 key_key = make_undefined_symbol("&key");
4537 allow_other_keys = make_undefined_symbol("&allow-other-keys");
4538 aux_key = make_undefined_symbol("&aux");
4539 #endif
4540 work_symbol = make_undefined_symbol("~magic-internal-symbol~");
4541 Lunintern(nil, work_symbol);
4542 #ifndef COMMON
4543 packid_(CP) = make_undefined_symbol("package");
4544 #else
4545 package_symbol = make_undefined_symbol("package");
4546 packid_(CP) = package_symbol;
4547 #endif
4548
4549 macroexpand_hook = make_undefined_symbol("*macroexpand-hook*");
4550 qheader(macroexpand_hook) |= SYM_SPECIAL_VAR;
4551 evalhook = make_undefined_symbol("*evalhook*");
4552 qheader(evalhook) |= SYM_SPECIAL_VAR;
4553 qvalue(evalhook) = nil;
4554 applyhook = make_undefined_symbol("*applyhook*");
4555 qheader(applyhook) |= SYM_SPECIAL_VAR;
4556 qvalue(applyhook) = nil;
4557 #ifdef COMMON
4558 keyword_package = make_undefined_symbol("*keyword-package*");
4559 qheader(keyword_package) |= SYM_SPECIAL_VAR;
4560 qvalue(keyword_package) = make_package(make_string("KEYWORD"));
4561 err_table = make_undefined_symbol("*ERROR-MESSAGE*");
4562 #else
4563 err_table = make_undefined_symbol("*error-messages*");
4564 #endif
4565 qheader(err_table) |= SYM_SPECIAL_VAR;
4566 qvalue(err_table) = nil;
4567 #ifdef COMMON
4568 #define make_keyword(name) \
4569 Lintern_2(nil, make_string(name), qvalue(keyword_package))
4570 internal_symbol = make_keyword("INTERNAL");
4571 external_symbol = make_keyword("EXTERNAL");
4572 inherited_symbol = make_keyword("INHERITED");
4573 allow_key_key = make_keyword("ALLOW-OTHER-KEYS");
4574 #else
4575 #define make_keyword(name) make_undefined_symbol(name)
4576 #endif
4577 gensym_base = make_string("G");
4578 #ifdef COMMON
4579 expand_def_symbol = make_undefined_symbol("expand-definer");
4580 format_symbol = make_undefined_symbol("format");
4581 string_char_sym = make_undefined_symbol("string-char");
4582 cl_symbols = make_undefined_symbol("*cl-symbols*");
4583 /*
4584 * cl_symbols has to be at least a vector or else I can not
4585 * read in the Lisp file that sets its proper value...
4586 */
4587 qvalue(cl_symbols) = getvector_init(8*CELL, nil);
4588 features_symbol = make_undefined_symbol("*features*");
4589 qheader(cl_symbols) |= SYM_SPECIAL_VAR;
4590 qheader(features_symbol) |= SYM_SPECIAL_VAR;
4591 { Lisp_Object w;
4592 #define make_constant(name, value) \
4593 w = make_undefined_symbol(name); \
4594 qheader(w) |= SYM_SPECIAL_VAR; \
4595 qvalue(w) = value;
4596 make_constant("most-positive-fixnum", fixnum_of_int(0x07ffffff));
4597 make_constant("most-negative-fixnum", fixnum_of_int(0xf8000000));
4598 /* #undef TYPE_LONG_FLOAT */
4599 /* #define TYPE_LONG_FLOAT TYPE_DOUBLE_FLOAT */
4600 make_constant("pi",
4601 make_boxfloat(3.141592653589793238, TYPE_LONG_FLOAT));
4602 }
4603 #endif
4604 append_symbol = make_undefined_symbol("append");
4605 raise_symbol = make_undefined_symbol("*raise");
4606 lower_symbol = make_undefined_symbol("*lower");
4607 echo_symbol = make_undefined_symbol("*echo");
4608 /*
4609 * I think that having a built-in symbol called *hankaku even if Kanji support
4610 * is not otherwise present is not too severe a problem, and making the
4611 * symbol present always will help keep image files re-usable from one
4612 * version of CSL to another.
4613 */
4614 hankaku_symbol = make_undefined_symbol("*hankaku");
4615 comp_symbol = make_undefined_symbol("*comp");
4616 compiler_symbol = make_undefined_symbol("compile");
4617 native_symbol = make_undefined_symbol("native-compile");
4618 bytecoded_symbol = make_undefined_symbol("bytecoded-definition");
4619 nativecoded_symbol = make_undefined_symbol("native-code-definition");
4620 traceprint_symbol = make_undefined_symbol("trace-print");
4621 loadsource_symbol = make_symbol("load-source", 0, Lload_source, too_many_1, wrong_no_1);
4622 prinl_symbol = make_symbol("prinl", 0, Lprin, too_many_1, wrong_no_1);
4623 emsg_star = make_undefined_symbol("emsg*");
4624 redef_msg = make_undefined_symbol("*redefmsg");
4625 expr_symbol = make_undefined_symbol("expr");
4626 fexpr_symbol = make_undefined_symbol("fexpr");
4627 macro_symbol = make_undefined_symbol("macro");
4628 break_function = make_undefined_symbol("*break-loop*");
4629 gchook = make_undefined_symbol("*gc-hook*");
4630 resources = make_undefined_symbol("*resources*");
4631 qheader(raise_symbol) |= SYM_SPECIAL_VAR;
4632 qheader(lower_symbol) |= SYM_SPECIAL_VAR;
4633 qheader(echo_symbol) |= SYM_SPECIAL_VAR;
4634 qheader(hankaku_symbol) |= SYM_SPECIAL_VAR;
4635 qheader(comp_symbol) |= SYM_SPECIAL_VAR;
4636 qheader(emsg_star) |= SYM_SPECIAL_VAR;
4637 qheader(redef_msg) |= SYM_SPECIAL_VAR;
4638 qheader(break_function) |= SYM_SPECIAL_VAR;
4639 qvalue(break_function) = nil;
4640 qheader(loadsource_symbol) |= SYM_SPECIAL_VAR;
4641 qvalue(loadsource_symbol) = nil;
4642 qheader(gchook) |= SYM_SPECIAL_VAR;
4643 qvalue(gchook) = nil;
4644 qheader(resources) |= SYM_SPECIAL_VAR;
4645 qvalue(resources) = nil;
4646 { Lisp_Object common = make_undefined_symbol("common-lisp-mode");
4647 qheader(common) |= SYM_SPECIAL_VAR;
4648 #ifdef COMMON
4649 qvalue(common) = lisp_true;
4650 qvalue(raise_symbol) = lisp_true;
4651 qvalue(lower_symbol) = nil;
4652 #else
4653 qvalue(common) = nil;
4654 qvalue(raise_symbol) = nil;
4655 qvalue(lower_symbol) = lisp_true;
4656 #endif
4657 }
4658 qvalue(echo_symbol) = nil;
4659 qvalue(hankaku_symbol) = nil;
4660 qvalue(comp_symbol) = nil;
4661 qvalue(emsg_star) = nil;
4662 qvalue(redef_msg) = lisp_true;
4663
4664 sys_hash_table = Lmkhash(nil, 3, fixnum_of_int(5), fixnum_of_int(2), nil);
4665 get_counts = Lmkhash(nil, 3, fixnum_of_int(5), fixnum_of_int(0), nil);
4666 /*
4667 * I make the vector that can hold the names used for "fast" get tags big
4668 * enough for the largest possible number.
4669 */
4670 fastget_names = getvector_init((MAX_FASTGET_SIZE+2)*CELL, SPID_NOPROP);
4671 /*
4672 * The next bit is a horrid fudge, used in read.c (function orderp) to
4673 * support REDUCE. It ensures that the flag 'noncom is subject to an
4674 * optimisation for flag/flagp that allows it to be tested for using a
4675 * simple bit-test. This MUST use entry zero (coded as 1 here!).
4676 * Also I insist that 'lose be the second fastget thing!
4677 */
4678 { Lisp_Object nc = make_undefined_symbol("noncom");
4679 qheader(nc) |= (1L << SYM_FASTGET_SHIFT);
4680 elt(fastget_names, 0) = nc;
4681 nc = make_undefined_symbol("lose");
4682 qheader(nc) |= (2L << SYM_FASTGET_SHIFT);
4683 elt(fastget_names, 1) = nc;
4684 }
4685 /*
4686 * I create the stream objects just once at cold-start time, but every time I
4687 * restart I will fill in their components in the standard way again.
4688 */
4689 lisp_work_stream = make_stream_handle();
4690 lisp_terminal_io = make_stream_handle();
4691 lisp_standard_output = make_stream_handle();
4692 lisp_standard_input = make_stream_handle();
4693 lisp_error_output = make_stream_handle();
4694 lisp_trace_output = make_stream_handle();
4695 lisp_debug_io = make_stream_handle();
4696 lisp_query_io = make_stream_handle();
4697 inject_randomness((int)clock());
4698 set_up_functions(0);
4699 set_up_variables(0);
4700 procstack = nil;
4701 procmem = getvector_init(CELL*100, nil); /* 0 to 99 */
4702 procstackp = 0;
4703 }
4704
set_up_functions(CSLbool restartp)4705 void set_up_functions(CSLbool restartp)
4706 {
4707 /*
4708 * All symbols that have a pointer to C code in their function cell must
4709 * be set up whether we are in a warm OR a cold start state, because the
4710 * actual addresses associated with C entrypoints will vary from version
4711 * to version of the binary of the system.
4712 */
4713 int i;
4714 nil_as_base
4715 #ifdef COMMON
4716 /*
4717 * In Common Lisp mode it could be that the user had something other than the
4718 * LISP package active when the image was saved. But I want all the symbols
4719 * that I create or restore here to be in the LISP (or sometimes keyword)
4720 * package. So I temporarily reset the package here...
4721 */
4722 Lisp_Object saved_package = CP;
4723 CP = find_package("LISP", 4);
4724 #endif
4725 function_symbol = make_symbol("function", restartp, function_fn, bad_special2, bad_specialn);
4726 qheader(function_symbol)|= SYM_SPECIAL_FORM;
4727 quote_symbol = make_symbol("quote", restartp, quote_fn, bad_special2, bad_specialn);
4728 qheader(quote_symbol) |= SYM_SPECIAL_FORM;
4729 progn_symbol = make_symbol("progn", restartp, progn_fn, bad_special2, bad_specialn);
4730 qheader(progn_symbol) |= SYM_SPECIAL_FORM;
4731 declare_symbol = make_symbol("declare", restartp, declare_fn, bad_special2, bad_specialn);
4732 qheader(declare_symbol) |= SYM_SPECIAL_FORM;
4733 special_symbol = make_undefined_symbol("special");
4734 cons_symbol = make_symbol("cons", restartp, too_few_2, Lcons, wrong_no_2);
4735 eval_symbol = make_symbol("eval", restartp, Leval, too_many_1, wrong_no_1);
4736 loadsource_symbol = make_symbol("load-source", restartp, Lload_source, too_many_1, wrong_no_1);
4737 /*
4738 * The main bunch of symbols can be handed using a table that
4739 * gives names and values.
4740 */
4741 for (i=0; eval2_setup[i].name != NULL; i++)
4742 qheader(make_symbol(eval2_setup[i].name,
4743 restartp,
4744 eval2_setup[i].one,
4745 eval2_setup[i].two,
4746 eval2_setup[i].n)) |= SYM_SPECIAL_FORM;
4747 for (i=0; eval3_setup[i].name != NULL; i++)
4748 qheader(make_symbol(eval3_setup[i].name,
4749 restartp,
4750 eval3_setup[i].one,
4751 eval3_setup[i].two,
4752 eval3_setup[i].n)) |= SYM_SPECIAL_FORM;
4753
4754 create_symbols(arith06_setup, restartp);
4755 create_symbols(arith08_setup, restartp);
4756 create_symbols(arith10_setup, restartp);
4757 create_symbols(arith12_setup, restartp);
4758 create_symbols(char_setup, restartp);
4759 create_symbols(eval1_setup, restartp);
4760 create_symbols(funcs1_setup, restartp);
4761 create_symbols(funcs2_setup, restartp);
4762 create_symbols(funcs3_setup, restartp);
4763 create_symbols(print_setup, restartp);
4764 create_symbols(read_setup, restartp);
4765 create_symbols(restart_setup, restartp);
4766 create_symbols(mpi_setup, restartp);
4767 /*
4768 * Although almost everything is mapped into upper case in a Common Lisp
4769 * world I will preserve the case of symbols defined in u01 to u60.
4770 */
4771 for (i=0; setup_tables[i]!=NULL; i++)
4772 create_symbols(setup_tables[i], restartp | 2);
4773
4774 #ifdef NAG
4775 create_symbols(asp_setup, restartp);
4776 create_symbols(nag_setup, restartp);
4777 create_symbols(socket_setup, restartp);
4778 create_symbols(xdr_setup, restartp);
4779 create_symbols(grep_setup, restartp);
4780 create_symbols(axfns_setup, restartp);
4781 create_symbols(gr_setup, restartp);
4782 #endif
4783
4784 #ifdef OPENMATH
4785 create_symbols(om_setup, restartp);
4786 create_symbols(om_parse_setup, restartp);
4787 #endif
4788
4789 #ifdef MEMORY_TRACE
4790 #ifndef CHECK_ONLY
4791 memory_comment(13); /* tail end of setup */
4792 #endif
4793 #endif
4794
4795 #ifdef COMMON
4796 CP = saved_package;
4797 #endif
4798 }
4799
4800 #ifndef COMMON
4801 #ifdef HAVE_FWIN
4802
alpha1(const void * a,const void * b)4803 static int MS_CDECL alpha1(const void *a, const void *b)
4804 {
4805 return strcmp(1+*(const char **)a, 1+*(const char **)b);
4806 }
4807
4808 #else
4809
alpha0(const void * a,const void * b)4810 static int MS_CDECL alpha0(const void *a, const void *b)
4811 {
4812 return strcmp(*(const char **)a, *(const char **)b);
4813 }
4814
4815 #endif
4816 #endif
4817
set_up_variables(CSLbool restartp)4818 static void set_up_variables(CSLbool restartp)
4819 {
4820 Lisp_Object nil = C_nil;
4821 int i;
4822 #ifdef COMMON
4823 Lisp_Object saved_package = CP;
4824 CP = find_package("LISP", 4);
4825 #endif
4826 qvalue(macroexpand_hook) = make_symbol("funcall", restartp, Lfuncall1, Lfuncall2, Lfuncalln);
4827 input_libraries = make_undefined_symbol("input-libraries");
4828 qheader(input_libraries) |= SYM_SPECIAL_VAR;
4829 qvalue(input_libraries) = nil;
4830 for (i=number_of_fasl_paths-1; i>=0; i--)
4831 qvalue(input_libraries) = cons(SPID_LIBRARY + (((int32_t)i)<<20),
4832 qvalue(input_libraries));
4833 output_library = make_undefined_symbol("output-library");
4834 qvalue(output_library) = output_directory < 0 ? nil :
4835 SPID_LIBRARY + (((int32_t)output_directory)<<20);
4836 /*
4837 * The Lisp variable lispsystem* gets set here. (in COMMON mode it is
4838 * the variable *features*)
4839 * Its value is a list.
4840 * csl says I am a CSL Lisp
4841 * (executable . "string") name of current executable (if available)
4842 * (shortname . "string") executable wuithout path or extension
4843 * pipes do I support open-pipe?
4844 * (version . "string") eg "2.11"
4845 * (name . "string") eg "MSDOS/386"
4846 * (opsys . id) unix/msdos/riscos/win32/finder/riscos/...
4847 * id unix/msdos etc again...
4848 * help help mechanism provided within Lisp
4849 * debug Lisp built with debug options
4850 * (native . number) native code tag
4851 * (c-code . number) u01.c through u60.c define n functions
4852 * sixty-four 64-bit address version
4853 * texmacs "--texmacs" option on command line
4854 *
4855 * In COMMON mode the tags on the *features* list are generally in the
4856 * keyword package. Otherwise they are just regular symbols. This makes it
4857 * slightly hard to use code that tests this list in a generic environment!
4858 */
4859 {
4860 #ifdef COMMON
4861 Lisp_Object n = features_symbol;
4862 Lisp_Object w;
4863 char opsys[32];
4864 char *p1 = opsys, *p2 = OPSYS;
4865 int ii;
4866 while ((*p1++ = toupper(*p2++)) != 0);
4867 *p1 = 0;
4868 w = cons(make_keyword(opsys), nil);
4869 #if defined WIN64 || defined __WIN64__ || defined WIN32
4870 w = cons(make_keyword("WIN32"), w);
4871 #endif
4872 #if defined WIN64 || defined __WIN64__
4873 w = cons(make_keyword("WIN64"), w);
4874 #endif
4875 w = acons(make_keyword("LINKER"),
4876 make_undefined_symbol(linker_type), w);
4877 w1 = nil;
4878 for (ii=sizeof(compiler_command)/sizeof(compiler_command[0])-1;
4879 ii>=0;
4880 ii--)
4881 w1 = cons(make_undefined_symbol(compiler_command[ii]), w1);
4882 w = acons(make_keyword("COMPILER-COMMAND"), w1, w);
4883 #else
4884 Lisp_Object n = make_undefined_symbol("lispsystem*");
4885 Lisp_Object w = cons(make_keyword(OPSYS), nil), w1;
4886 int ii;
4887 #if defined WIN64 || defined __WIN64__ || defined WIN32
4888 /*
4889 * In the WIN64 case I will ALSO tell the user than I am "win32". This is
4890 * a curious thing to do maybe, but is because historically win32 may have
4891 * been used as a "windows" test, and win64 is in general terms a
4892 * compatible extension so all win32 options ought still to be available.
4893 */
4894 w = cons(make_keyword("win32"), w);
4895 #endif
4896 #if defined WIN64 || defined __WIN64__
4897 w = cons(make_keyword("win64"), w);
4898 #endif
4899 qheader(n) |= SYM_SPECIAL_VAR;
4900 w = acons(make_keyword("linker"),
4901 make_undefined_symbol(linker_type), w);
4902 w1 = nil;
4903 for (ii=sizeof(compiler_command)/sizeof(compiler_command[0])-1;
4904 ii>=0;
4905 ii--)
4906 w1 = cons(make_undefined_symbol(compiler_command[ii]), w1);
4907 w = acons(make_keyword("compiler-command"), w1, w);
4908 #endif
4909 defined_symbols = 0;
4910 for (i=0; setup_tables[i]!=NULL; i++) count_symbols(setup_tables[i]);
4911 #ifdef COMMON
4912 /*
4913 * A gratuitous misery here is the need to make COMMON words
4914 * upper case.
4915 */
4916 w = acons(make_keyword("OPSYS"),
4917 make_undefined_symbol(OPSYS), w);
4918 w = acons(make_keyword("NATIVE"),
4919 fixnum_of_int(native_code_tag), w);
4920 w = acons(make_keyword("C-CODE"),
4921 fixnum_of_int(defined_symbols), w);
4922 if (SIXTY_FOUR_BIT) w = cons(make_keyword("SIXTY-FOUR"), w);
4923 #if defined HAVE_POPEN || defined HAVE_FWIN
4924 w = cons(make_keyword("PIPES"), w);
4925 #endif
4926 #ifdef DEBUG
4927 w = cons(make_keyword("DEBUG"), w);
4928 #endif
4929 w = cons(make_keyword("RECORD_GET"), w);
4930 #ifdef HAVE_FWIN
4931 w = acons(make_keyword("EXECUTABLE"),
4932 make_string(fwin_full_program_name), w);
4933 #else
4934 if (program_name[0] != 0)
4935 w = acons(make_keyword("EXECUTABLE"),
4936 make_string(program_name), w);
4937 #endif
4938 w = acons(make_keyword("NAME"), make_string(IMPNAME), w);
4939 w = acons(make_keyword("VERSION"), make_string(VERSION), w);
4940 w = cons(make_keyword("CCL"), w);
4941 w = cons(make_keyword("COMMON-LISP"), w);
4942 #else /* !COMMON */
4943 w = acons(make_keyword("opsys"),
4944 make_undefined_symbol(OPSYS), w);
4945 w = acons(make_keyword("native"),
4946 fixnum_of_int(native_code_tag), w);
4947 w = acons(make_keyword("c-code"),
4948 fixnum_of_int(defined_symbols), w);
4949 #ifdef HAVE_FWIN
4950 if (texmacs_mode)
4951 w = cons(make_keyword("texmacs"), w);
4952 #endif
4953 if (SIXTY_FOUR_BIT) w = cons(make_keyword("sixty-four"), w);
4954 #if defined HAVE_POPEN || defined HAVE_FWIN
4955 w = cons(make_keyword("pipes"), w);
4956 #endif
4957 #ifdef DEBUG
4958 w = cons(make_keyword("debug"), w);
4959 #endif
4960 #ifdef HAVE_FWIN
4961 if (fwin_windowmode() & FWIN_WITH_TERMED)
4962 w = cons(make_keyword("termed"), w);
4963 #ifdef HAVE_LIBFOX
4964 // if (fwin_windowmode() & FWIN_WITH_FOX) REINSTATE SOON PLEASE
4965 // w = cons(make_keyword("fox"), w);
4966 if (fwin_windowmode() & FWIN_IN_WINDOW)
4967 { w = cons(make_keyword("windowed"), w);
4968 // It could be the case that SHOWMATH is compiled in but the necessary
4969 // fonts were not located. Or if they were there but "--" has been used to
4970 // redirect standard output to a file.
4971 if (showmathInitialised &&
4972 alternative_stdout == NULL)
4973 w = cons(make_keyword("showmath"), w);
4974 }
4975 #endif
4976 #endif
4977 #ifdef RECORD_GET
4978 w = cons(make_keyword("record_get"), w);
4979 #endif
4980 #ifdef HAVE_FWIN
4981 w = acons(make_keyword("executable"),
4982 make_string(fwin_full_program_name), w);
4983 w = acons(make_keyword("shortname"),
4984 make_string(programName), w);
4985 #else
4986 if (program_name[0] != 0)
4987 w = acons(make_keyword("executable"),
4988 make_string(program_name), w);
4989 #endif
4990 w = acons(make_keyword("name"), make_string(IMPNAME), w);
4991 w = acons(make_keyword("version"), make_string(VERSION), w);
4992 w = cons(make_keyword("csl"), w);
4993 /*
4994 * Ha Ha a trick here - if a symbol ADDSQ is defined I view this image
4995 * as being one for REDUCE and push that information onto lispsystem*,
4996 * and I also reset the "about box" information (if using fwin).
4997 */
4998 w1 = make_undefined_symbol("addsq");
4999 if (qfn1(w1) != undefined1)
5000 { w = cons(make_keyword("reduce"), w);
5001 w1 = qvalue(make_undefined_symbol("version*"));
5002 if (is_vector(w1) &&
5003 type_of_header(vechdr(w1)) == TYPE_STRING)
5004 {
5005 #if defined HAVE_FWIN && !defined EMBEDDED
5006 int n = length_of_header(vechdr(w1))-CELL;
5007 sprintf(about_box_title, "About %.*s",
5008 (n > 31-(int)strlen("About ") ?
5009 31-(int)strlen("About ") : n),
5010 &celt(w1, 0));
5011 sprintf(about_box_description, "%.*s",
5012 (n > 31 ? 31 : n),
5013 &celt(w1, 0));
5014 /*
5015 * The provision here is that if variables called "author!*" and
5016 * "author2!*" exist with strings as values then those values will
5017 * appear in the "about box". See a commentary in the file fwin.c about
5018 * possibly non-obvious constraints on what text you may properly place
5019 * in these strings.
5020 */
5021 w1 = qvalue(make_undefined_symbol("author1*"));
5022 if (is_vector(w1) &&
5023 type_of_header(vechdr(w1)) == TYPE_STRING)
5024 { n = length_of_header(vechdr(w1))-CELL;
5025 sprintf(about_box_rights_1, "%.*s",
5026 n > 31 ? 31 : n, &celt(w1, 0));
5027 }
5028 else strcpy(about_box_rights_1, "A C Hearn/RAND");
5029 w1 = qvalue(make_undefined_symbol("author2*"));
5030 if (is_vector(w1) &&
5031 type_of_header(vechdr(w1)) == TYPE_STRING)
5032 { n = length_of_header(vechdr(w1))-CELL;
5033 sprintf(about_box_rights_2, "%.*s",
5034 n > 31 ? 31 : n, &celt(w1, 0));
5035 }
5036 else strcpy(about_box_rights_2, "Codemist Ltd");
5037 #endif
5038 }
5039 else
5040 {
5041 #ifdef HAVE_FWIN
5042 strcpy(about_box_title, "About REDUCE");
5043 strcpy(about_box_description, "REDUCE");
5044 strcpy(about_box_rights_1, "A C Hearn/RAND");
5045 strcpy(about_box_rights_2, "Codemist Ltd");
5046 #endif
5047 }
5048 }
5049 #endif
5050 qheader(n) |= SYM_SPECIAL_VAR;
5051 qvalue(n) = w;
5052 }
5053 #ifdef COMMON
5054 /*
5055 * Floating point characteristics are taken from <float.h> where it is
5056 * supposed that the C compiler involved has got the values correct.
5057 * I do this every time the system is loaded rather than just when an
5058 * image is cold-created. This is because an image file may have been created
5059 * on a system differing from the one on which it is used. Mayve in fact
5060 * IEEE arithmetic is ALMOST universal and I am being too cautious here?
5061 */
5062 { Lisp_Object w;
5063 make_constant("short-float-epsilon",
5064 make_sfloat(16.0*FLT_EPSILON));
5065 make_constant("single-float-epsilon",
5066 make_boxfloat(FLT_EPSILON, TYPE_SINGLE_FLOAT));
5067 make_constant("double-float-epsilon",
5068 make_boxfloat(DBL_EPSILON, TYPE_DOUBLE_FLOAT));
5069 /* For now "long" = "double" */
5070 make_constant("long-float-epsilon",
5071 make_boxfloat(DBL_EPSILON, TYPE_LONG_FLOAT));
5072 /*
5073 * I assume that I have a radix 2 representation, and float-negative-epsilon
5074 * is just half float-epsilon. Correct me if I am wrong...
5075 */
5076 make_constant("short-float-negative-epsilon",
5077 make_sfloat(16.0*FLT_EPSILON/2.0));
5078 make_constant("single-float-negative-epsilon",
5079 make_boxfloat(FLT_EPSILON/2.0, TYPE_SINGLE_FLOAT));
5080 make_constant("double-float-negative-epsilon",
5081 make_boxfloat(DBL_EPSILON/2.0, TYPE_DOUBLE_FLOAT));
5082 /* For now "long" = "double" */
5083 make_constant("long-float-negative-epsilon",
5084 make_boxfloat(DBL_EPSILON/2.0, TYPE_LONG_FLOAT));
5085 /*
5086 * I hope that the C header file gets extremal values correct. Note that
5087 * because make_sfloat() truncates (rather than rounding) it should give
5088 * correct values for most-positive-short-float etc
5089 */
5090 make_constant("most-positive-short-float",
5091 make_sfloat(FLT_MAX));
5092 make_constant("most-positive-single-float",
5093 make_boxfloat(FLT_MAX, TYPE_SINGLE_FLOAT));
5094 make_constant("most-positive-double-float",
5095 make_boxfloat(DBL_MAX, TYPE_DOUBLE_FLOAT));
5096 make_constant("most-positive-long-float",
5097 make_boxfloat(DBL_MAX, TYPE_LONG_FLOAT));
5098 /*
5099 * Here I assume that the floating point representation is sign-and-magnitude
5100 * and hence symmetric about zero.
5101 */
5102 make_constant("most-negative-short-float",
5103 make_sfloat(-FLT_MAX));
5104 make_constant("most-negative-single-float",
5105 make_boxfloat(-FLT_MAX, TYPE_SINGLE_FLOAT));
5106 make_constant("most-negative-double-float",
5107 make_boxfloat(-DBL_MAX, TYPE_DOUBLE_FLOAT));
5108 make_constant("most-negative-long-float",
5109 make_boxfloat(-DBL_MAX, TYPE_LONG_FLOAT));
5110 /*
5111 * The "least-xxx" set of values did not consider the case of denormalised
5112 * numbers too carefully in ClTl-1, so in ClTl-2 there are elaborations. I
5113 * believe that a proper C header file <float.h> will make the macros that
5114 * I use here refer to NORMALISED values, so the numeric results I use
5115 * here will not be quite proper (ie there are smaller floats that are
5116 * un-normalised). But I will ignore that worry just for now.
5117 */
5118 make_constant("least-positive-short-float",
5119 make_sfloat(FLT_MIN));
5120 make_constant("least-positive-single-float",
5121 make_boxfloat(FLT_MIN, TYPE_SINGLE_FLOAT));
5122 make_constant("least-positive-double-float",
5123 make_boxfloat(DBL_MIN, TYPE_DOUBLE_FLOAT));
5124 make_constant("least-positive-long-float",
5125 make_boxfloat(DBL_MIN, TYPE_LONG_FLOAT));
5126 make_constant("least-negative-short-float",
5127 make_sfloat(-FLT_MIN));
5128 make_constant("least-negative-single-float",
5129 make_boxfloat(-FLT_MIN, TYPE_SINGLE_FLOAT));
5130 make_constant("least-negative-double-float",
5131 make_boxfloat(-DBL_MIN, TYPE_DOUBLE_FLOAT));
5132 make_constant("least-negative-long-float",
5133 make_boxfloat(-DBL_MIN, TYPE_LONG_FLOAT));
5134 /*
5135 * The bunch here are intended to be NORMALISED numbers, while the unqualified
5136 * ones above may not be.
5137 */
5138 make_constant("least-positive-normalized-short-float",
5139 make_sfloat(FLT_MIN));
5140 make_constant("least-positive-normalized-single-float",
5141 make_boxfloat(FLT_MIN, TYPE_SINGLE_FLOAT));
5142 make_constant("least-positive-normalized-double-float",
5143 make_boxfloat(DBL_MIN, TYPE_DOUBLE_FLOAT));
5144 make_constant("least-positive-normalized-long-float",
5145 make_boxfloat(DBL_MIN, TYPE_LONG_FLOAT));
5146 make_constant("least-negative-normalized-short-float",
5147 make_sfloat(-FLT_MIN));
5148 make_constant("least-negative-normalized-single-float",
5149 make_boxfloat(-FLT_MIN, TYPE_SINGLE_FLOAT));
5150 make_constant("least-negative-normalized-double-float",
5151 make_boxfloat(-DBL_MIN, TYPE_DOUBLE_FLOAT));
5152 make_constant("least-negative-normalized-long-float",
5153 make_boxfloat(-DBL_MIN, TYPE_LONG_FLOAT));
5154 #endif
5155 #ifdef UNIX_TIMES
5156 /* /*
5157 * ACN believes that the following is misguided, since the time-reading
5158 * function (defined in fns1.c) that CCL provides always returns its answer
5159 * in milliseconds. This the 1000 below is NOT as arbitrary as all that, it
5160 * represents the unit that CCL (across all platforms) returns time
5161 * measurements in. The UNIX_TIMES macro is set on Unix systems to
5162 * influence whether the times() function or clock() is used to read
5163 * time, where in the former case Unix makes it possible to separate
5164 * user and system time.
5165 */
5166 /* UNIX_TIMES is set in machine.h and will usually be HZ. */
5167 make_constant("internal-time-units-per-second",
5168 #ifdef UNIX_TIMES
5169 fixnum_of_int(UNIX_TIMES));
5170 #else
5171 fixnum_of_int(1000));
5172 #endif
5173 }
5174 #endif
5175 #ifdef MEMORY_TRACE
5176 #ifndef CHECK_ONLY
5177 memory_comment(3); /* creating symbols */
5178 #endif
5179 #endif
5180 charvec = getvector_init(257*CELL, nil);
5181 faslvec = nil;
5182 faslgensyms = nil;
5183
5184 qheader(terminal_io = make_undefined_symbol("*terminal-io*"))
5185 |= SYM_SPECIAL_VAR;
5186 qheader(standard_input = make_undefined_symbol("*standard-input*"))
5187 |= SYM_SPECIAL_VAR;
5188 qheader(standard_output = make_undefined_symbol("*standard-output*"))
5189 |= SYM_SPECIAL_VAR;
5190 qheader(error_output = make_undefined_symbol("*error-output*"))
5191 |= SYM_SPECIAL_VAR;
5192 qheader(trace_output = make_undefined_symbol("*trace-output*"))
5193 |= SYM_SPECIAL_VAR;
5194 qheader(debug_io = make_undefined_symbol("*debug-io*"))
5195 |= SYM_SPECIAL_VAR;
5196 qheader(query_io = make_undefined_symbol("*query-io*"))
5197 |= SYM_SPECIAL_VAR;
5198
5199 stream_type(lisp_work_stream) = make_undefined_symbol("work-stream");
5200
5201 { Lisp_Object f = lisp_terminal_io;
5202 stream_type(f) = make_undefined_symbol("terminal-stream");
5203 set_stream_read_fn(f, char_from_terminal);
5204 set_stream_read_other(f, read_action_terminal);
5205 set_stream_write_fn(f, char_to_terminal);
5206 set_stream_write_other(f, write_action_terminal);
5207 qvalue(terminal_io) = f;
5208
5209 f = lisp_standard_input;
5210 stream_type(f) = make_undefined_symbol("synonym-stream");
5211 #ifdef COMMON
5212 /*
5213 * If I do not have COMMON defined I will take a slight short cut here and
5214 * make reading from *standard-input* read directly from the terminal. For
5215 * full Common Lisp compatibility I think *standard-input* is required to
5216 * be a synonym stream that will dynamically look at the value of the variable
5217 * *terminal-io* every time it does anything. Ugh, since people who assign to
5218 * or re-bind *terminal-io* seem to me to be asking for terrible trouble!
5219 */
5220 set_stream_read_fn(f, char_from_synonym);
5221 #else
5222 set_stream_read_fn(f, char_from_terminal);
5223 #endif
5224 set_stream_read_other(f, read_action_synonym);
5225 stream_read_data(f) = terminal_io;
5226 qvalue(standard_input) = f;
5227
5228 f = lisp_standard_output;
5229 stream_type(f) = make_undefined_symbol("synonym-stream");
5230 #ifdef COMMON
5231 set_stream_write_fn(f, char_to_synonym);
5232 #else
5233 set_stream_write_fn(f, char_to_terminal);
5234 #endif
5235 set_stream_write_other(f, write_action_synonym);
5236 stream_write_data(f) = terminal_io;
5237 qvalue(standard_output) = f;
5238
5239 f = lisp_error_output;
5240 stream_type(f) = make_undefined_symbol("synonym-stream");
5241 #ifdef COMMON
5242 set_stream_write_fn(f, char_to_synonym);
5243 #else
5244 set_stream_write_fn(f, char_to_terminal);
5245 #endif
5246 set_stream_write_other(f, write_action_synonym);
5247 stream_write_data(f) = terminal_io;
5248 qvalue(error_output) = f;
5249
5250 f = lisp_trace_output;
5251 stream_type(f) = make_undefined_symbol("synonym-stream");
5252 #ifdef COMMON
5253 set_stream_write_fn(f, char_to_synonym);
5254 #else
5255 set_stream_write_fn(f, char_to_terminal);
5256 #endif
5257 set_stream_write_other(f, write_action_synonym);
5258 stream_write_data(f) = terminal_io;
5259 qvalue(trace_output) = f;
5260
5261 f = lisp_debug_io;
5262 stream_type(f) = make_undefined_symbol("synonym-stream");
5263 #ifdef COMMON
5264 set_stream_read_fn(f, char_from_synonym);
5265 #else
5266 set_stream_read_fn(f, char_from_terminal);
5267 #endif
5268 set_stream_read_other(f, read_action_synonym);
5269 stream_read_data(f) = terminal_io;
5270 #ifdef COMMON
5271 set_stream_write_fn(f, char_to_synonym);
5272 #else
5273 set_stream_write_fn(f, char_to_terminal);
5274 #endif
5275 set_stream_write_other(f, write_action_synonym);
5276 stream_write_data(f) = terminal_io;
5277 qvalue(debug_io) = f;
5278
5279 f = lisp_query_io;
5280 stream_type(f) = make_undefined_symbol("synonym-stream");
5281 #ifdef COMMON
5282 set_stream_read_fn(f, char_from_synonym);
5283 #else
5284 set_stream_read_fn(f, char_from_terminal);
5285 #endif
5286 set_stream_read_other(f, read_action_synonym);
5287 stream_read_data(f) = terminal_io;
5288 #ifdef COMMON
5289 set_stream_write_fn(f, char_to_synonym);
5290 #else
5291 set_stream_write_fn(f, char_to_terminal);
5292 #endif
5293 set_stream_write_other(f, write_action_synonym);
5294 stream_write_data(f) = terminal_io;
5295 qvalue(query_io) = f;
5296 }
5297
5298 #ifdef HAVE_LIBFOX
5299 { Lisp_Object stream = make_undefined_symbol("*math-output*");
5300 Lisp_Object f = make_stream_handle();
5301 qheader(stream) |= SYM_SPECIAL_VAR;
5302 stream_type(f) = make_undefined_symbol("math-output");
5303 set_stream_write_fn(f, char_to_math);
5304 set_stream_write_other(f, write_action_math);
5305 qvalue(stream) = f;
5306 stream = make_undefined_symbol("*spool-output*");
5307 qheader(stream) |= SYM_SPECIAL_VAR;
5308 f = make_stream_handle();
5309 stream_type(f) = make_undefined_symbol("spool-output");
5310 set_stream_write_fn(f, char_to_spool);
5311 set_stream_write_other(f, write_action_spool);
5312 qvalue(stream) = f;
5313 }
5314 #endif
5315
5316 /*
5317 * I can not handle boffo overflow very well here, but I do really hope that
5318 * symbols spelt out on the command line will always be fairly short.
5319 */
5320 for (i=0; i<number_of_symbols_to_define; i++)
5321 { CSLbool undef = undefine_this_one[i];
5322 char *s = symbols_to_define[i];
5323 if (undef)
5324 { Lisp_Object n = make_undefined_symbol(s);
5325 qvalue(n) = unset_var;
5326 }
5327 else
5328 { char buffer[256];
5329 char *p = buffer;
5330 int c;
5331 Lisp_Object n, v;
5332 while ((c = *s++) != 0 && c != '=') *p++ = (char)c;
5333 *p = 0;
5334 n = make_undefined_symbol(buffer);
5335 push(n);
5336 if (c == 0) v = lisp_true;
5337 else
5338 {
5339 /*
5340 * I have been having a big difficulty here, caused by the inconsistent and
5341 * awkward behaviours of various shells and "make" utilities. In a tidy
5342 * and simple world I might like a command-line option -Dxx=yyy to allow
5343 * arbitrary text for yyy terminating it at the next whitespace. Then yyy
5344 * could be processed by the Lisp reader so that numbers, symbols, strings
5345 * etc could be specified. However I find that things I often want to
5346 * use involve characters such as "\" and ":" (as components of file-names
5347 * on some machines), and sometimes "make" treats these as terminators, or
5348 * wants to do something magic with "\". If I put things within quote marks
5349 * then sometimes the quotes get passed through to Lisp and sometimes not.
5350 * This is all a BIG misery in a multi-platform situation! As a fresh
5351 * attempt to inject sanity I will always convert yyy to a Lisp string. If
5352 * it is specified with leading and trailing '"' marks I will strip them. Thus
5353 * both -Dxxx=yyy and -Dxxx="yyy" will leave the variable xxx set to the
5354 * string "yyy". Then as a Lisp user I can parse the string if I need to
5355 * interpret it as something else.
5356 */
5357 #ifndef PASS_PREDEFINES_THROUGH_READER
5358 if (*s == '"') /* Convert "yyy" to just yyy */
5359 { p = ++s;
5360 while (*p != 0) p++;
5361 if (*--p == '"') *p = 0;
5362 }
5363 #endif
5364 v = make_string(s);
5365 #ifdef PASS_PREDEFINES_THROUGH_READER
5366 v = Lexplodec(nil, v);
5367 v = Lcompress(nil, v);
5368 /*
5369 * The above will first make the value in -Dname=value into a string,
5370 * then explode it into a list, and compress back - the effect is as if the
5371 * original value had been passed through the regular Lisp READ function,
5372 * so symbols, numbers and even s-expressions can be parsed. If the
5373 * parsing fails I (silently) treat the value as just NIL.
5374 */
5375 #endif
5376 nil = C_nil;
5377 if (exception_pending()) v = flip_exception();
5378 }
5379 pop(n);
5380 qheader(n) |= SYM_SPECIAL_VAR;
5381 qvalue(n) = v;
5382 }
5383 }
5384 #ifndef COMMON
5385 #ifdef HAVE_FWIN
5386 /*
5387 * Now if I have the FWIN windowed system I look in the Lisp variables
5388 * loadable-packages!*
5389 * switches!*
5390 * (both expected to be lists of symbols) and copy info into a couple of
5391 * C vectors, whence it can go to the window manager and be used to create
5392 * suitable menus. I might get in a mess if I try to set and reset menus
5393 * multiple times, and so to avoid possible confusion I do this step
5394 * JUST ONCE. This may be limiting (in particular it means that menus get
5395 * set at the very start of a run ONLY) but should only be visible to those
5396 * who call restart!-csl.
5397 */
5398 if (loadable_packages == NULL && switches==NULL)
5399 { Lisp_Object w1 = qvalue(make_undefined_symbol("loadable-packages*"));
5400 Lisp_Object w2;
5401 int n;
5402 char *v;
5403 n = 0;
5404 for (w2=w1; consp(w2); w2=qcdr(w2)) n++; /* How many? */
5405 #ifdef HAVE_FWIN
5406 n = 2*n;
5407 #endif
5408 loadable_packages = (char **)(*malloc_hook)((n+1)*sizeof(char *));
5409 if (loadable_packages != NULL)
5410 { n = 0;
5411 for (w2=w1; consp(w2); w2=qcdr(w2))
5412 { Lisp_Object w3 = qcar(w2);
5413 int n1;
5414 if (is_symbol(w3)) w3 = qpname(w3);
5415 if (!is_vector(w3) ||
5416 type_of_header(vechdr(w3)) != TYPE_STRING) break;
5417 n1 = length_of_header(vechdr(w3))-CELL;
5418 #ifdef HAVE_FWIN
5419 v = (char *)(*malloc_hook)(n1+2);
5420 if (v == NULL) break;
5421 v[0] = ' ';
5422 memcpy(v+1, &celt(w3, 0), n1);
5423 v[n1+1] = 0;
5424 #else
5425 v = (char *)(*malloc_hook)(n1+1);
5426 if (v == NULL) break;
5427 memcpy(v, &celt(w3, 0), n1);
5428 v[n1] = 0;
5429 #endif
5430 loadable_packages[n++] = v;
5431 #ifdef HAVE_FWIN
5432 loadable_packages[n++] = NULL;
5433 #endif
5434 }
5435 #ifdef HAVE_FWIN
5436 qsort(loadable_packages, n/2, 2*sizeof(char *), alpha1);
5437 #else
5438 qsort(loadable_packages, n, sizeof(char *), alpha0);
5439 #endif
5440 loadable_packages[n] = NULL; /* NULL-terminate the list */
5441 }
5442 w1 = qvalue(make_undefined_symbol("switches*"));
5443 n = 0;
5444 for (w2=w1; consp(w2); w2=qcdr(w2)) n++; /* How many? */
5445 n = (n+1)*sizeof(char *);
5446 #ifdef HAVE_FWIN
5447 n = 2*n;
5448 #endif
5449 switches = (char **)(*malloc_hook)(n);
5450 if (switches != NULL)
5451 { n = 0;
5452 for (w2=w1; consp(w2); w2=qcdr(w2))
5453 { Lisp_Object w3 = qcar(w2), w4;
5454 char sname[64];
5455 int n1;
5456 if (is_symbol(w3)) w3 = qpname(w3);
5457 if (!is_vector(w3) ||
5458 type_of_header(vechdr(w3)) != TYPE_STRING) break;
5459 n1 = length_of_header(vechdr(w3))-CELL;
5460 if (n1 > 60) break;
5461 sprintf(sname, "*%.*s", n1, &celt(w3, 0));
5462 w4 = make_undefined_symbol(sname);
5463 v = (char *)(*malloc_hook)(n1+2);
5464 if (v == NULL) break;
5465 /*
5466 * The first character records the current state of the switch. With FWIN
5467 * I have entries that say "x" for "I am not at present active" which copes
5468 * with switches that will become relevant only when a package of code is
5469 * loaded. I will scan from time to time to update my information - I guess
5470 * that I can put in a hook that triggers review after any module has been
5471 * loaded. See the function review_switch_settings() the follows...
5472 */
5473 if (qvalue(w4) == nil) v[0] = 'n';
5474 #ifdef HAVE_FWIN
5475 else if (qvalue(w4) == unset_var) v[0] = 'x';
5476 #endif
5477 else v[0] = 'y';
5478 memcpy(v+1, &celt(w3, 0), n1);
5479 v[n1+1] = 0;
5480 switches[n++] = v;
5481 #ifdef HAVE_FWIN
5482 switches[n++] = NULL;
5483 #endif
5484 }
5485 #ifdef HAVE_FWIN
5486 qsort(switches, n/2, 2*sizeof(char *), alpha1);
5487 #else
5488 qsort(switches, n, sizeof(char *), alpha1);
5489 #endif
5490 switches[n] = NULL;
5491 }
5492 }
5493
5494 #endif /* HAVE_FWIN */
5495 #endif /* COMMON */
5496 #ifdef COMMON
5497 CP = saved_package;
5498 #endif
5499 }
5500
5501 #ifndef COMMON
5502 #ifdef HAVE_FWIN
5503
5504 /*
5505 * This alse reviews the list of loaded packages...
5506 */
review_switch_settings()5507 void review_switch_settings()
5508 {
5509 Lisp_Object sw = qvalue(make_undefined_symbol("switches*"));
5510 while (consp(sw))
5511 { Lisp_Object s = qcar(sw);
5512 char sname[64];
5513 int n1;
5514 char *v, **p;
5515 Lisp_Object nil, starsw;
5516 sw = qcdr(sw);
5517 if (is_symbol(s)) s = qpname(s);
5518 if (!is_vector(s) ||
5519 type_of_header(vechdr(s)) != TYPE_STRING) continue;
5520 n1 = length_of_header(vechdr(s))-CELL;
5521 if (n1 > 60) continue;
5522 sprintf(sname, "*%.*s", n1, &celt(s, 0));
5523 for (p=switches; *p!=NULL; p+=2)
5524 { if (strcmp(1+*p, &sname[1]) == 0) break;
5525 }
5526 if ((v=*p) == NULL) continue;
5527 starsw = make_undefined_symbol(sname);
5528 nil = C_nil;
5529 if (exception_pending())
5530 { flip_exception();
5531 continue;
5532 }
5533 if (qvalue(starsw) == nil) switch(*v)
5534 {
5535 case 'y': *v = 0x3f&'N'; break;
5536 case 'n': break;
5537 case 'x': *v = 'N'; break;
5538 }
5539 else if (qvalue(starsw) == unset_var) switch(*v)
5540 {
5541 case 'y': *v = 'X'; break;
5542 case 'n': *v = 'X'; break;
5543 case 'x': break;
5544 }
5545 else switch(*v)
5546 {
5547 case 'y': break;
5548 case 'n': *v = 0x3f&'Y'; break;
5549 case 'x': *v = 'Y'; break;
5550 }
5551 }
5552 sw = qvalue(make_undefined_symbol("loaded-packages*"));
5553 while (consp(sw))
5554 { Lisp_Object s = qcar(sw);
5555 char sname[64];
5556 int n1;
5557 char *v, **p;
5558 sw = qcdr(sw);
5559 if (is_symbol(s)) s = qpname(s);
5560 if (!is_vector(s) ||
5561 type_of_header(vechdr(s)) != TYPE_STRING) continue;
5562 n1 = length_of_header(vechdr(s))-CELL;
5563 if (n1 > 60) continue;
5564 sprintf(sname, "%.*s", n1, &celt(s, 0));
5565 for (p=loadable_packages; *p!=NULL; p+=2)
5566 { if (strcmp(1+*p, sname) == 0) break;
5567 }
5568 if ((v=*p) == NULL) continue;
5569 if (*v == ' ') *v = 'X'; /* X here says "update the info" */
5570 }
5571 fwin_refresh_switches(switches, loadable_packages);
5572 }
5573
5574 #endif
5575 #endif
5576
5577 CSLbool CSL_MD5_busy;
5578 unsigned char unpredictable[256];
5579 static int n_unpredictable = 0;
5580 static CSLbool unpredictable_pending = 0;
5581
inject_randomness(int n)5582 void inject_randomness(int n)
5583 {
5584 unpredictable[n_unpredictable++] ^= (n % 255);
5585 if (n_unpredictable >= 256)
5586 { n_unpredictable = 0;
5587 unpredictable_pending = YES;
5588 }
5589 if (unpredictable_pending & !CSL_MD5_busy)
5590 { CSL_MD5_Init();
5591 CSL_MD5_Update(unpredictable, sizeof(unpredictable));
5592 CSL_MD5_Final(unpredictable);
5593 unpredictable_pending = NO;
5594 }
5595 }
5596
5597 /*
5598 * Used to ensure that an image file matches up with the C code compiled
5599 * into the main executable. The linear search here for the place the
5600 * checksum lives is a bit crummy. But the total cost is linear in the
5601 * number of things that have been compiled into C.
5602 */
get_checksum(const setup_type * p)5603 static void get_checksum(const setup_type *p)
5604 {
5605 while (p->name!=NULL) p++;
5606 if (p->one != NULL && p->two != NULL)
5607 { unsigned char *w = (unsigned char *)p->two;
5608 CSL_MD5_Update(w, strlen((char *)w));
5609 }
5610 }
5611
get_user_files_checksum(unsigned char * b)5612 void get_user_files_checksum(unsigned char *b)
5613 {
5614 int i;
5615 CSL_MD5_Init();
5616 for (i=0; setup_tables[i]!=NULL; i++)
5617 get_checksum(setup_tables[i]);
5618 CSL_MD5_Final(b);
5619 }
5620
setup(int restartp,double store_size)5621 void setup(int restartp, double store_size)
5622 {
5623 int i;
5624 Lisp_Object nil;
5625 if (restartp & 2) init_heap_segments(store_size);
5626 garbage_collection_permitted = 0;
5627 nil = C_nil;
5628 #ifdef TIDY_UP_MEMORY_AT_START
5629 /*
5630 * The following feature, which should not be neded, is liable to be
5631 * expensive on big machines because it touches all memory.
5632 * The code is left in case it helps with repeatability in the face
5633 * of accesses to uninitialised locations (ie BUGS).
5634 */
5635 for (i=0; i<pages_count; i++)
5636 memset(pages[i], 0, (size_t)CSL_PAGE_SIZE+16);
5637 memset(stacksegment, 0, (size_t)stack_segsize*CSL_PAGE_SIZE+16);
5638 memset(nilsegment, 0, (size_t)NIL_SEGMENT_SIZE);
5639 #endif
5640 stack = stackbase;
5641 exit_tag = exit_value = nil;
5642 exit_reason = UNWIND_NULL;
5643
5644 if (restartp & 1)
5645 { char junkbuf[120];
5646 char filename[LONGEST_LEGAL_FILENAME];
5647 if (IopenRoot(filename, 0, 0))
5648 { term_printf("\n+++ Image file \"%s\" can not be read\n",
5649 filename);
5650 my_exit(EXIT_FAILURE);
5651 }
5652 /*
5653 * I read input via a buffer of size FREAD_BUFFER_SIZE, which I pre-fill
5654 * at this stage before I even try to read anything
5655 */
5656 fread_ptr = (unsigned char *)stack;
5657 fread_count = Iread(fread_ptr, FREAD_BUFFER_SIZE);
5658 /*
5659 * I can adjust here (automatically) for whatever compression threshold
5660 * had been active when the image file was created.
5661 */
5662 compression_worth_while = 128;
5663 Cfread(junkbuf, 112);
5664 { int fg = junkbuf[111];
5665 while (fg != 0) compression_worth_while <<= 1, fg--;
5666 }
5667 if (init_flags & INIT_VERBOSE)
5668 { term_printf("Created: %.25s\n", &junkbuf[64]);
5669 /* Time dump was taken */
5670 }
5671 { unsigned char chk[16];
5672 get_user_files_checksum(chk);
5673 for (i=0; i<16; i++)
5674 { if (chk[i] != (junkbuf[90+i] & 0xff))
5675 { term_printf(
5676 "\n+++ Image file belongs with a different version\n");
5677 term_printf(
5678 " of the executable file (incompatible code\n");
5679 term_printf(
5680 " has been optimised into C and incorporated)\n");
5681 term_printf(
5682 " Unable to use this image file, so stopping\n");
5683 my_exit(EXIT_FAILURE);
5684 }
5685 }
5686 }
5687 /*
5688 * To make things more responsive for the user I will display a
5689 * banner rather early (before reading the bulk of the image file).
5690 * The banner that I will display is one provided to be by PRESERVE.
5691 */
5692 { Ihandle save;
5693 char b[64];
5694 Icontext(&save);
5695 #define BANNER_CODE (-1002)
5696 if (IopenRoot(filename, BANNER_CODE, 0)) b[0] = 0;
5697 else
5698 { for (i=0; i<64; i++) b[i] = (char)Igetc();
5699 IcloseInput(NO);
5700 }
5701 Irestore_context(save);
5702 /*
5703 * A banner set via startup-banner takes precedence over one from preserve.
5704 * But as a very special hack I detect if --texmacs was on the command
5705 * line and in that case I stay quiet...
5706 */
5707 #ifdef HAVE_FWIN
5708 if (!texmacs_mode)
5709 #endif
5710 { if (b[0] != 0)
5711 { term_printf("%s\n", b);
5712 ensure_screen();
5713 }
5714 else if (junkbuf[0] != 0)
5715 { term_printf("%s\n", junkbuf);
5716 ensure_screen();
5717 }
5718 }
5719 }
5720 /*
5721 * Now I need to start worrying about 32 vs 64-bit image files.
5722 */
5723 if (SIXTY_FOUR_BIT)
5724 { converting_to_32 = 0;
5725 converting_to_64 = ((rootDirectory->h.version & 0x80) == 0);
5726 }
5727 else
5728 { converting_to_32 = ((rootDirectory->h.version & 0x80) != 0);
5729 converting_to_64 = 0;
5730 }
5731 /*
5732 * If if image file was made by a 32-bit system but I am now running in
5733 * 64-bit mode or vice versa things are tricky and at present may CRASH!!!
5734 * I BELIEVE that loading a 64-bit image on a 32-bit system may be OK but
5735 * conversion in the other direction is unambiguously not supported yet.
5736 * But there are comments and fragments of code that show the path I am
5737 * taking towards it.
5738 *
5739 * One thing I have not yet thought about properly is checking that if I
5740 * re-preserve to this image file the new image directory entry for the
5741 * freshly created heap image must have the correct information. I hope that
5742 * that happens naturally in preserve.c.
5743 *
5744 * Temporary alert while I develop code to support width conversion... This
5745 * should never appear unless you are loading a "different word width" image
5746 * and in that case I want you to have been warned that there may be glitches.
5747 */
5748 #ifdef DEBUG
5749 /*
5750 * If I am debugging a brief indication that I need to re-size the heap
5751 * is probably justifiable.
5752 */
5753 if (converting_to_32 || converting_to_64)
5754 { printf("->32 = %d ->64 = %d\n", converting_to_32, converting_to_64);
5755 fflush(stderr);
5756 }
5757 #endif
5758 Cfread(junkbuf, 8);
5759 /*
5760 * If the heap image had been made on a 64-bit machine but the current
5761 * system is running at 32-bits then the region in the file I need to
5762 * read here is twice as big as is needed. I must shrink it. I need
5763 * some temporary space while I do that. I will use the memory at
5764 * pages[0], which is a bit of a cheat, but I have allocated that already
5765 * but do not use it until later.
5766 */
5767 if (converting_to_32)
5768 { int64_t *p = (int64_t *)pages[0];
5769 int32_t *q = (int32_t *)BASE;
5770 /* read twice as much because it should be in 64-bit units */
5771 Cfread((char *)p, (2*sizeof(Lisp_Object))*last_nil_offset);
5772 /*
5773 * At present I just truncate the values in all the nil-segment to 32-bits.
5774 * I can imagine a further messy case if I ever introduce wide fixnums for
5775 * 64-bit machines. In that case I would need to detect when a value here
5776 * fell into that category and convert it to a reference to a newly created
5777 * bignum. But that should not arise at the moment!
5778 *
5779 * Now in fact here and in the conversion the other way I have a bit of
5780 * pain in that I can not merely truncate because it could be that I should
5781 * be adjusting the byte order. In that case I would need to preserve the
5782 * other 4 bytes of each 8-byte quantity. Unfortunately in the normal
5783 * pattern on things I load the nil-segment BEFORE I test to see if I need
5784 * to do a byte-order conversion! So here I put in an ad-hoc early check
5785 * on the byte-order signature... Ugh.
5786 */
5787 uint64_t temp_byteflip = p[12];
5788 /*
5789 * The test here will only be needed in the case that the image was made on
5790 * a 64-bit system, in which case the value of byteflip is 00000000xxxxxxxx
5791 * if no flip is needed, and xxxxxxxx00000000 if it is. Note that the
5792 * fact that the 32-bit part never has its top bit set removes risk of
5793 * sign-extension ever having propagated ffffffff into where I want 00000000.
5794 * Note also that these days I will ensure that EVERY item in the nil-segment
5795 * is an intprt_t so I can handle all of them uniformly.
5796 */
5797 flip_needed = (temp_byteflip & 0x7fffffffU) == 0;
5798 for (i=0; i<last_nil_offset; i++)
5799 { int64_t w = *p++;
5800 int32_t r;
5801 /*
5802 * Items 24-31 are handled in a very odd way here because once they were
5803 * 32-bit values stashed in the lower 4 bytes of the field regardless of
5804 * byte-order. I keep any non-zero part of a 64-bit word in that case.
5805 */
5806 if (i<24 || i>31) r = (int32_t)(flip_needed ? (w>>32) : w);
5807 else if ((int32_t)w == 0) r = (int32_t)(w>>32);
5808 else r = (int32_t)w;
5809 *q++ = r;
5810 }
5811 }
5812 else if (converting_to_64)
5813 {
5814 /*
5815 * The heap image was made by a 32-bit system but I am a 64-bit one. So
5816 * when I read in the nilseg it will need to be expanded out to 64-bit
5817 * values. I will sign extend in each case.. that will cope with the
5818 * packed representation of Lisp_Objects (because immediate data is
5819 * all naturally signed, and pointer data is really only 31 bits wide to
5820 * leave room for a GC bit).
5821 * As in the case of narrowing the data I will need to cope with possible
5822 * byte-order effects. In the normal case I will expand abcdefgh into
5823 * ssssssssabcdefgh where s is the sign bit I propagate. If I am
5824 * flipping bytes it will need to turn into abcdefghssssssss where s comes
5825 * from the top bit of h. That is because later on I will turn that back
5826 * into sssssssshgfedcba.
5827 * Note also that the amount I read will be based on 32-bit data not 64
5828 * hence the odd-looking "/2" in the next line.
5829 */
5830 Cfread((char *)BASE, (sizeof(Lisp_Object)/2)*last_nil_offset);
5831 /*
5832 * Copying from the top downwards avoids clobbering stuff here. As with the
5833 * conversion in the other direction I coull have extra work to do if I
5834 * introduced 64-bit fixnums. I would need to detect fixnums that fitted in
5835 * 64-bits but not 32 and convert them into bignums...
5836 */
5837 /*
5838 * Beware here that I want to sign extend data but it may at present be
5839 * in the wrong byte order for the current machine - but to know that I
5840 * must first establish if flipping is required!
5841 */
5842 i = ((int32_t *)BASE)[12]; /* 32-bit value of byteflip */
5843 if (((i >> 16) & 0xffffU) == 0x5678U) flip_needed = NO;
5844 else if ((i & 0xffffU) == 0x7856U) flip_needed = YES;
5845 else
5846 { term_printf("\n+++ The checkpoint file is corrupt\n");
5847 my_exit(EXIT_FAILURE);
5848 }
5849 for (i=last_nil_offset-1; i>=0; i--)
5850 { *(int64_t *)((char *)BASE+8*i) =
5851 expand_to_64(*(int32_t *)((char *)BASE+4*i));
5852 }
5853 }
5854 else Cfread((char *)BASE, sizeof(Lisp_Object)*last_nil_offset);
5855 copy_out_of_nilseg(YES);
5856 #ifndef COMMON
5857 qheader(nil) = TAG_ODDS+TYPE_SYMBOL+SYM_SPECIAL_VAR;/* BEFORE nil... */
5858 #endif
5859 /*
5860 * Now the value in byteflip is really a 32-bit value saved an intptr_t,
5861 * and if my bytes are in a funny order because the 64-bit values had been
5862 * saved on a machine with the other byte-order it may be that the 32-bits
5863 * that I want are in fact in the top half of the 64-bit word. So if I am on
5864 * a 64-bit machine I adjust for that. I do not take the mere fact of the
5865 * low half being zero as full evidence that I am flipped, since I would
5866 * like to check for the 0x5678 pattern as an extra consistency check.
5867 */
5868 if (SIXTY_FOUR_BIT)
5869 { if ((byteflip & 0x7fffffff) == 0)
5870 byteflip = (Lisp_Object)((int64_t)byteflip >> 32);
5871 }
5872 if (((byteflip >> 16) & 0xffffU) == 0x5678U)
5873 {
5874 flip_needed = NO;
5875 old_fp_rep = (int)(byteflip & FP_MASK);
5876 old_page_bits = (int)((byteflip >> 8) & 0x1f);
5877 }
5878 else if ((byteflip & 0xffffU) == 0x7856U)
5879 {
5880 flip_needed = YES;
5881 old_fp_rep = (int)(flip_32bits(byteflip) & FP_MASK);
5882 old_page_bits = (int)((flip_32bits(byteflip) >> 8) & 0x1f);
5883 }
5884 else
5885 { term_printf("\n+++ The checkpoint file is corrupt\n");
5886 /*
5887 * Note: I use different numbers to check byte-ordering on segmented feature
5888 * non-segmented systems, since the heap image formats are not compatible.
5889 * A result will be that use of the wrong sort of image will lead to a
5890 * "checkpoint file corrupt" message rather than a more serious shambles.
5891 */
5892 my_exit(EXIT_FAILURE);
5893 }
5894 if (old_page_bits == 0) old_page_bits = 16; /* Old default value */
5895 /*
5896 * I could in fact recover in the case that old_page_bits < PAGE_BITS, since
5897 * I could just map the old small pages into the new big ones with a little
5898 * padding where needed. I will not do that JUST yet. In general it will
5899 * not be possible to load an image with large pages into a CSL that only
5900 * has small ones - eg there might be some vector that just would not fit
5901 * in the small page size. Even discounting that worry rearranging the
5902 * heap to allow for the discontinuities at the smaller page granularity would
5903 * be pretty painful. Again in the limit something very much akin to the
5904 * normal garbage collector could probably do it if it ever became really
5905 * necessary.
5906 */
5907 if (old_page_bits != PAGE_BITS)
5908 { term_printf("\n+++ The checkpoint file was made on a machine\n");
5909 term_printf("where CSL had been configured with a different page\n");
5910 term_printf("size. It is not usable with this version.\n");
5911 my_exit(EXIT_FAILURE);
5912 }
5913 /* The saved value of NIL is not needed in this case */
5914 }
5915 else
5916 {
5917 for (i=first_nil_offset; i<last_nil_offset; i++)
5918 BASE[i] = nil;
5919 copy_out_of_nilseg(NO);
5920 }
5921
5922 savestacklimit = stacklimit = &stack[stack_segsize*CSL_PAGE_SIZE/4-200];
5923 /* allow some slop at end */
5924 /*
5925 * Note that the value of byteflip on 1 32-bit machine will look like
5926 * 0x5678nm0b where nm is certainly less than 64 and b is just a few
5927 * bits. If the byte order is reversed this becomes
5928 * 0x0bnm7856
5929 * On a 64-bit system it is
5930 * 0x000000005678nm0b
5931 * or 0x0bnm785600000000
5932 * and in ALL cases it is positive, so whether it is represented as a
5933 * signed or unsigned value is immaterial.
5934 */
5935 byteflip = 0x56780000 |
5936 ((int32_t)current_fp_rep & ~FP_WORD_ORDER) |
5937 (((int32_t)PAGE_BITS) << 8);
5938 native_pages_changed = 0;
5939 if ((restartp & 1) != 0) warm_setup((restartp & 4) != 0);
5940 else cold_setup((restartp & 4) != 0);
5941
5942 if (init_flags & INIT_QUIET) Lverbos(nil, fixnum_of_int(1));
5943 if (init_flags & INIT_VERBOSE) Lverbos(nil, fixnum_of_int(3));
5944 /*
5945 * Here I grab more memory (if I am allowed to) until the proportion of the
5946 * heap active at the end of garbage collection is less than 1/2. If the
5947 * attempt to grab more memory fails I clear the bit in init_flags that
5948 * allows me to try to expand, so I will not waste time again.
5949 * The aim of keeping the heap less than half full is an heuristic and
5950 * could be adjusted on the basis of experience with this code.
5951 */
5952 if (init_flags & INIT_EXPANDABLE)
5953 { int32_t more = heap_pages_count + vheap_pages_count +
5954 bps_pages_count + native_pages_count;
5955 more = 3 *more - pages_count;
5956 while (more-- > 0)
5957 { void *page = (void *)my_malloc_1((size_t)(CSL_PAGE_SIZE + 16));
5958 /*
5959 * CF the code in gc.c -- I can still use my_malloc_1 here, which makes this
5960 * code just a tiny bit safer.
5961 */
5962 intptr_t pun = (intptr_t)page;
5963 intptr_t pun1 = (intptr_t)((char *)page + CSL_PAGE_SIZE + 16);
5964 if ((pun ^ pun1) < 0) page = NULL;
5965 if ((pun + address_sign) < 0) page = NULL;
5966 if (page == NULL)
5967 { init_flags &= ~INIT_EXPANDABLE;
5968 break;
5969 }
5970 else pages[pages_count++] = page;
5971 }
5972 }
5973 {
5974 int32_t w = 0;
5975 /*
5976 * The total store allocated is that used plus that free, including the
5977 * page set aside for the Lisp stack. I had better report this in Kbytes
5978 * which should then be sort of OK up to a total of 4000 Gbytes before the
5979 * unsigned long overflows on me.
5980 */
5981 if (init_flags & INIT_VERBOSE)
5982 { unsigned long m =
5983 ((unsigned long)(CSL_PAGE_SIZE/1000))*(pages_count+w+1);
5984 if (m > 4000)
5985 term_printf("Memory allocation: %lu Mbytes\n", m/1000);
5986 else term_printf("Memory allocation: %lu Kbytes\n", m);
5987 }
5988 }
5989 #ifdef MEMORY_TRACE
5990 #ifndef CHECK_ONLY
5991 memory_comment(15);
5992 #endif
5993 #endif
5994 if (init_flags & INIT_VERBOSE)
5995 { int n = number_of_processors();
5996 if (n > 1)
5997 term_printf("There are %d processors available\n", n);
5998 }
5999 #ifdef DEBUG
6000 copy_into_nilseg(NO);
6001 validate_all("restarting", __LINE__, __FILE__);
6002 #endif
6003 garbage_collection_permitted = 1;
6004 return;
6005 }
6006
copy_into_nilseg(int fg)6007 void copy_into_nilseg(int fg)
6008 {
6009 Lisp_Object nil = C_nil;
6010
6011 #ifdef NILSEG_EXTERNS
6012 int i;
6013 if (fg) /* move non list bases too */
6014 { BASE[12] = byteflip;
6015 BASE[13] = codefringe;
6016 *(Lisp_Object volatile *)&BASE[14] = codelimit;
6017 /*
6018 * The messing around here is to ensure that on 64-bit architectures
6019 * stacklimit is kept properly aligned.
6020 */
6021 #ifdef COMMON
6022 *(Lisp_Object * volatile *)&BASE[16] = stacklimit;
6023 #else
6024 *(Lisp_Object * volatile *)&BASE[15] = stacklimit;
6025 #endif
6026 BASE[18] = fringe;
6027 *(Lisp_Object volatile *)&BASE[19] = heaplimit;
6028 *(Lisp_Object volatile *)&BASE[20] = vheaplimit;
6029 BASE[21] = vfringe;
6030 BASE[22] = miscflags;
6031
6032 BASE[24] = nwork;
6033 /* BASE[25] = exit_reason; */
6034 BASE[26] = exit_count;
6035 BASE[27] = gensym_ser;
6036 BASE[28] = print_precision;
6037 BASE[29] = current_modulus;
6038 BASE[30] = fastget_size;
6039 BASE[31] = package_bits;
6040 }
6041 /*
6042 * Entries 50 and 51 are used for chains of hash tables, and so get
6043 * very special individual treatment. See comments elsewhere.
6044 */
6045 BASE[52] = current_package;
6046 BASE[53] = B_reg;
6047 BASE[54] = codevec;
6048 BASE[55] = litvec;
6049 BASE[56] = exit_tag;
6050 BASE[57] = exit_value;
6051 BASE[58] = catch_tags;
6052 BASE[59] = lisp_package;
6053 BASE[60] = boffo;
6054 BASE[61] = charvec;
6055 BASE[62] = sys_hash_table;
6056 BASE[63] = help_index;
6057 BASE[64] = gensym_base;
6058 BASE[65] = err_table;
6059 BASE[66] = supervisor;
6060 BASE[67] = startfn;
6061 BASE[68] = faslvec;
6062 BASE[69] = tracedfn;
6063 BASE[70] = prompt_thing;
6064 BASE[71] = faslgensyms;
6065 BASE[72] = cl_symbols;
6066 BASE[73] = active_stream;
6067 BASE[74] = current_module;
6068 BASE[75] = native_defs;
6069
6070 BASE[90] = append_symbol;
6071 BASE[91] = applyhook;
6072 BASE[92] = cfunarg;
6073 BASE[93] = comma_at_symbol;
6074 BASE[94] = comma_symbol;
6075 BASE[95] = compiler_symbol;
6076 BASE[96] = comp_symbol;
6077 BASE[97] = cons_symbol;
6078 BASE[98] = echo_symbol;
6079 BASE[99] = emsg_star;
6080 BASE[100] = evalhook;
6081 BASE[101] = eval_symbol;
6082 BASE[102] = expr_symbol;
6083 BASE[103] = features_symbol;
6084 BASE[104] = fexpr_symbol;
6085 BASE[105] = funarg;
6086 BASE[106] = function_symbol;
6087 BASE[107] = lambda;
6088 BASE[108] = lisp_true;
6089 BASE[109] = lower_symbol;
6090 BASE[110] = macroexpand_hook;
6091 BASE[111] = macro_symbol;
6092 BASE[112] = opt_key;
6093 BASE[113] = prinl_symbol;
6094 BASE[114] = progn_symbol;
6095 BASE[115] = quote_symbol;
6096 BASE[116] = raise_symbol;
6097 BASE[117] = redef_msg;
6098 BASE[118] = rest_key;
6099 BASE[119] = savedef;
6100 BASE[120] = string_char_sym;
6101 BASE[121] = unset_var;
6102 BASE[122] = work_symbol;
6103 BASE[123] = lex_words;
6104 BASE[124] = get_counts;
6105 BASE[125] = fastget_names;
6106 BASE[126] = input_libraries;
6107 BASE[127] = output_library;
6108 BASE[128] = current_file;
6109 BASE[129] = break_function;
6110
6111 BASE[130] = lisp_work_stream;
6112 BASE[131] = lisp_standard_output;
6113 BASE[132] = lisp_standard_input;
6114 BASE[133] = lisp_debug_io;
6115 BASE[134] = lisp_error_output;
6116 BASE[135] = lisp_query_io;
6117 BASE[136] = lisp_terminal_io;
6118 BASE[137] = lisp_trace_output;
6119 BASE[138] = standard_output;
6120 BASE[139] = standard_input;
6121 BASE[140] = debug_io;
6122 BASE[141] = error_output;
6123 BASE[142] = query_io;
6124 BASE[143] = terminal_io;
6125 BASE[144] = trace_output;
6126 BASE[145] = fasl_stream;
6127 BASE[146] = native_code;
6128 BASE[147] = native_symbol;
6129 BASE[148] = traceprint_symbol;
6130 BASE[149] = loadsource_symbol;
6131 BASE[150] = hankaku_symbol;
6132 BASE[151] = bytecoded_symbol;
6133 BASE[152] = nativecoded_symbol;
6134 BASE[153] = gchook;
6135 BASE[154] = resources;
6136 BASE[155] = callstack;
6137 BASE[156] = procstack;
6138 BASE[157] = procmem;
6139
6140 #ifdef COMMON
6141 BASE[170] = keyword_package;
6142 BASE[171] = all_packages;
6143 BASE[172] = package_symbol;
6144 BASE[173] = internal_symbol;
6145 BASE[174] = external_symbol;
6146 BASE[175] = inherited_symbol;
6147 BASE[176] = key_key;
6148 BASE[177] = allow_other_keys;
6149 BASE[178] = aux_key;
6150 BASE[179] = format_symbol;
6151 BASE[180] = expand_def_symbol;
6152 BASE[181] = allow_key_key;
6153 #endif
6154 /*
6155 * I USED to support these only in Common Lisp mode but now I find I need
6156 * them even in Standard Lisp mode...
6157 */
6158 BASE[182] = declare_symbol;
6159 BASE[183] = special_symbol;
6160
6161 for (i=0; i<=50; i++)
6162 BASE[work_0_offset+i] = workbase[i];
6163 #endif /* NILSEG_EXTERNS */
6164
6165 if (fg)
6166 {
6167 #ifdef COMMON
6168 *(Lisp_Object * volatile *)&BASE[16] = stacklimit;
6169 #else
6170 *(Lisp_Object * volatile *)&BASE[15] = stacklimit;
6171 #endif
6172 }
6173 BASE[190] = user_base_0;
6174 BASE[191] = user_base_1;
6175 BASE[192] = user_base_2;
6176 BASE[193] = user_base_3;
6177 BASE[194] = user_base_4;
6178 BASE[195] = user_base_5;
6179 BASE[196] = user_base_6;
6180 BASE[197] = user_base_7;
6181 BASE[198] = user_base_8;
6182 BASE[199] = user_base_9;
6183
6184 }
6185
copy_out_of_nilseg(int fg)6186 void copy_out_of_nilseg(int fg)
6187 {
6188 Lisp_Object nil = C_nil;
6189
6190 #ifdef NILSEG_EXTERNS
6191 int i;
6192 if (fg)
6193 {
6194 byteflip = BASE[12];
6195 codefringe = BASE[13];
6196 codelimit = *(Lisp_Object volatile *)&BASE[14];
6197 fringe = BASE[18];
6198 heaplimit = *(Lisp_Object volatile *)&BASE[19];
6199 vheaplimit = *(Lisp_Object volatile *)&BASE[20];
6200 vfringe = BASE[21];
6201 miscflags = BASE[22];
6202
6203 nwork = BASE[24];
6204 /* exit_reason = BASE[25]; */
6205 exit_count = BASE[26];
6206 gensym_ser = BASE[27];
6207 print_precision = BASE[28];
6208 current_modulus = BASE[29];
6209 fastget_size = BASE[30];
6210 package_bits = BASE[31];
6211 }
6212
6213 current_package = BASE[52];
6214 B_reg = BASE[53];
6215 codevec = BASE[54];
6216 litvec = BASE[55];
6217 exit_tag = BASE[56];
6218 exit_value = BASE[57];
6219 catch_tags = BASE[58];
6220 lisp_package = BASE[59];
6221 boffo = BASE[60];
6222 charvec = BASE[61];
6223 sys_hash_table = BASE[62];
6224 help_index = BASE[63];
6225 gensym_base = BASE[64];
6226 err_table = BASE[65];
6227 supervisor = BASE[66];
6228 startfn = BASE[67];
6229 faslvec = BASE[68];
6230 tracedfn = BASE[69];
6231 prompt_thing = BASE[70];
6232 faslgensyms = BASE[71];
6233 cl_symbols = BASE[72];
6234 active_stream = BASE[73];
6235 current_module = BASE[74];
6236 native_defs = BASE[75];
6237
6238 append_symbol = BASE[90];
6239 applyhook = BASE[91];
6240 cfunarg = BASE[92];
6241 comma_at_symbol = BASE[93];
6242 comma_symbol = BASE[94];
6243 compiler_symbol = BASE[95];
6244 comp_symbol = BASE[96];
6245 cons_symbol = BASE[97];
6246 echo_symbol = BASE[98];
6247 emsg_star = BASE[99];
6248 evalhook = BASE[100];
6249 eval_symbol = BASE[101];
6250 expr_symbol = BASE[102];
6251 features_symbol = BASE[103];
6252 fexpr_symbol = BASE[104];
6253 funarg = BASE[105];
6254 function_symbol = BASE[106];
6255 lambda = BASE[107];
6256 lisp_true = BASE[108];
6257 lower_symbol = BASE[109];
6258 macroexpand_hook = BASE[110];
6259 macro_symbol = BASE[111];
6260 opt_key = BASE[112];
6261 prinl_symbol = BASE[113];
6262 progn_symbol = BASE[114];
6263 quote_symbol = BASE[115];
6264 raise_symbol = BASE[116];
6265 redef_msg = BASE[117];
6266 rest_key = BASE[118];
6267 savedef = BASE[119];
6268 string_char_sym = BASE[120];
6269 unset_var = BASE[121];
6270 work_symbol = BASE[122];
6271 lex_words = BASE[123];
6272 get_counts = BASE[124];
6273 fastget_names = BASE[125];
6274 input_libraries = BASE[126];
6275 output_library = BASE[127];
6276 current_file = BASE[128];
6277 break_function = BASE[129];
6278
6279 lisp_work_stream = BASE[130];
6280 lisp_standard_output = BASE[131];
6281 lisp_standard_input = BASE[132];
6282 lisp_debug_io = BASE[133];
6283 lisp_error_output = BASE[134];
6284 lisp_query_io = BASE[135];
6285 lisp_terminal_io = BASE[136];
6286 lisp_trace_output = BASE[137];
6287 standard_output = BASE[138];
6288 standard_input = BASE[139];
6289 debug_io = BASE[140];
6290 error_output = BASE[141];
6291 query_io = BASE[142];
6292 terminal_io = BASE[143];
6293 trace_output = BASE[144];
6294 fasl_stream = BASE[145];
6295 native_code = BASE[146];
6296 native_symbol = BASE[147];
6297 traceprint_symbol = BASE[148];
6298 loadsource_symbol = BASE[149];
6299 hankaku_symbol = BASE[150];
6300 bytecoded_symbol = BASE[151];
6301 nativecoded_symbol = BASE[152];
6302 gchook = BASE[153];
6303 resources = BASE[154];
6304 callstack = BASE[155];
6305 procstack = BASE[156];
6306 procmem = BASE[157];
6307
6308 #ifdef COMMON
6309
6310 keyword_package = BASE[170];
6311 all_packages = BASE[171];
6312 package_symbol = BASE[172];
6313 internal_symbol = BASE[173];
6314 external_symbol = BASE[174];
6315 inherited_symbol = BASE[175];
6316 key_key = BASE[176];
6317 allow_other_keys = BASE[177];
6318 aux_key = BASE[178];
6319 format_symbol = BASE[179];
6320 expand_def_symbol = BASE[180];
6321 allow_key_key = BASE[181];
6322
6323 #endif
6324
6325 declare_symbol = BASE[182];
6326 special_symbol = BASE[183];
6327
6328 for (i = 0; i<=50; i++)
6329 workbase[i] = BASE[work_0_offset+i];
6330 #endif /* NILSEG_EXTERNS */
6331
6332 if (fg)
6333 {
6334 #ifdef COMMON
6335 stacklimit = *(Lisp_Object *volatile *)&BASE[16];
6336 #else
6337 stacklimit = *(Lisp_Object *volatile *)&BASE[15];
6338 #endif
6339 }
6340
6341 user_base_0 = BASE[190];
6342 user_base_1 = BASE[191];
6343 user_base_2 = BASE[192];
6344 user_base_3 = BASE[193];
6345 user_base_4 = BASE[194];
6346 user_base_5 = BASE[195];
6347 user_base_6 = BASE[196];
6348 user_base_7 = BASE[197];
6349 user_base_8 = BASE[198];
6350 user_base_9 = BASE[199];
6351 }
6352
6353 /*
6354 * For some of what follows I think I need to show that I have considered
6355 * the issue of export regulations.
6356 *
6357 * What I have here is MD5 (and when and if I feel keen SHA-1). I observe
6358 * that MD5, SHA-1 and DSA are made available as part of Sun's Java
6359 * Development Kit in the version that can be downloade freely from their
6360 * servers. They have a separate Java Cryptography Extension within which
6361 * they keep things that are subject to USA export regulations. I take this
6362 * as encouragement to believe that these three algorithms are not subject
6363 * to USA export limits. I believe such limits to be supersets (ie more
6364 * restrictive) than ones that apply in the UK and so feel happy about
6365 * including the implementations that I do here. Specifically, although I
6366 * have extracts from the SSL code which as a whole might give trouble if
6367 * importen to the USA and the re-exported I only have the message digest
6368 * bits that should not be so encumbered. I am aware that MD5 is now
6369 * considered weakish with SHA-1 the improved replacement, but will take the
6370 * view that I was not aiming for real security on anything anyway!
6371 */
6372
6373 /*
6374 * MD5 message digest code, adapted from Eric Young's version,
6375 * for which the copyright and disclaimer notices follow. Observe that
6376 * this code can be adapted and re-used subject to these terms being
6377 * retained.
6378 *
6379 * NOTE that I have stuck "CSL_" on the front of names since in some cases
6380 * a crypto library may find itself getting linked in with bits of CSL code
6381 * and names could otehrwise clash. Specifically this could happen on
6382 * Mac/Darwin when CSL is built with a flat namespace ready for dynamically
6383 * loading modules.
6384 */
6385
6386
6387 /* crypto/md/md5.c and support files */
6388 /* Copyright (C) 1995-1997 Eric Young (eay@mincom.oz.au)
6389 * All rights reserved.
6390 *
6391 * This package is an SSL implementation written
6392 * by Eric Young (eay@mincom.oz.au).
6393 * The implementation was written so as to conform with Netscapes SSL.
6394 *
6395 * This library is free for commercial and non-commercial use as long as
6396 * the following conditions are aheared to. The following conditions
6397 * apply to all code found in this distribution, be it the RC4, RSA,
6398 * lhash, DES, etc., code; not just the SSL code. The SSL documentation
6399 * included with this distribution is covered by the same copyright terms
6400 * except that the holder is Tim Hudson (tjh@mincom.oz.au).
6401 *
6402 * Copyright remains Eric Young's, and as such any Copyright notices in
6403 * the code are not to be removed.
6404 * If this package is used in a product, Eric Young should be given attribution
6405 * as the author of the parts of the library used.
6406 * This can be in the form of a textual message at program startup or
6407 * in documentation (online or textual) provided with the package.
6408 *
6409 * Redistribution and use in source and binary forms, with or without
6410 * modification, are permitted provided that the following conditions
6411 * are met:
6412 * 1. Redistributions of source code must retain the copyright
6413 * notice, this list of conditions and the following disclaimer.
6414 * 2. Redistributions in binary form must reproduce the above copyright
6415 * notice, this list of conditions and the following disclaimer in the
6416 * documentation and/or other materials provided with the distribution.
6417 * 3. All advertising materials mentioning features or use of this software
6418 * must display the following acknowledgement:
6419 * "This product includes cryptographic software written by
6420 * Eric Young (eay@mincom.oz.au)"
6421 * The word 'cryptographic' can be left out if the routines from the library
6422 * being used are not cryptographic related :-).
6423 * 4. If you include any Windows specific code (or a derivative thereof) from
6424 * the apps directory (application code) you must include an acknowledgement:
6425 * "This product includes software written by Tim Hudson (tjh@mincom.oz.au)"
6426 *
6427 * THIS SOFTWARE IS PROVIDED BY ERIC YOUNG ``AS IS'' AND
6428 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
6429 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
6430 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
6431 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
6432 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
6433 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
6434 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
6435 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
6436 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
6437 * SUCH DAMAGE.
6438 *
6439 * The licence and distribution terms for any publically available version or
6440 * derivative of this code cannot be changed. i.e. this code cannot simply be
6441 * copied and put under another distribution licence
6442 * [including the GNU Public Licence.]
6443 */
6444
6445 /*
6446 * End of Eric Young's copyright and disclaimer notice.
6447 *
6448 * The changes made by A C Norman remove some optimisation to leave shorter
6449 * code (I will not be using this in speed-critical applications) and
6450 * adjusting the style and layout to agree with other Codemist utilities.
6451 */
6452
6453 #define MD5_CBLOCK 64
6454 #define MD5_LBLOCK 16
6455
6456 static uint32_t MD5_A, MD5_B, MD5_C, MD5_D;
6457 static uint32_t MD5_Nl;
6458 static int MD5_num;
6459 static uint32_t MD5_data[MD5_CBLOCK];
6460
6461 #define F(x,y,z) ((((y) ^ (z)) & (x)) ^ (z))
6462 #define G(x,y,z) ((((x) ^ (y)) & (z)) ^ (y))
6463 #define H(x,y,z) ((x) ^ (y) ^ (z))
6464 #define I(x,y,z) (((x) | (~(z))) ^ (y))
6465
6466 #define ROTATE(a,n) (((a)<<(n))|((a)>>(32-(n))))
6467
6468
6469 #define R0(a,b,c,d,k,s,t) { \
6470 a+=((k)+(t)+F((b),(c),(d))); \
6471 a=ROTATE(a,s); \
6472 a+=b; }
6473
6474 #define R1(a,b,c,d,k,s,t) { \
6475 a+=((k)+(t)+G((b),(c),(d))); \
6476 a=ROTATE(a,s); \
6477 a+=b; }
6478
6479 #define R2(a,b,c,d,k,s,t) { \
6480 a+=((k)+(t)+H((b),(c),(d))); \
6481 a=ROTATE(a,s); \
6482 a+=b; }
6483
6484 #define R3(a,b,c,d,k,s,t) { \
6485 a+=((k)+(t)+I((b),(c),(d))); \
6486 a=ROTATE(a,s); \
6487 a+=b; }
6488
6489
6490 /*
6491 * Implemented from RFC1321 The MD5 Message-Digest Algorithm
6492 */
6493
CSL_MD5_Init(void)6494 void CSL_MD5_Init(void)
6495 {
6496 CSL_MD5_busy = YES;
6497 MD5_A = 0x67452301;
6498 MD5_B = 0xefcdab89;
6499 MD5_C = 0x98badcfe;
6500 MD5_D = 0x10325476;
6501 MD5_Nl = 0;
6502 MD5_num = 0;
6503 }
6504
6505 /*
6506 * Use of "D" as a variable name clashes with a debugging-macro that I have!
6507 */
6508
6509 #undef D
6510
6511 static unsigned char byte_order_test[4] = {1, 0, 0, 0};
6512
md5_block(void)6513 static void md5_block(void)
6514 {
6515 uint32_t A=MD5_A, B=MD5_B, C=MD5_C, D=MD5_D;
6516 int i;
6517 /*
6518 * Here I re-write the buffer so that it now behaves as if it is
6519 * an array of 32-bit words in native computer representation. On
6520 * many machines the code here will have no effect at all apart from
6521 * consuming a little time. I do a little test first to see if
6522 * it is really needed.
6523 */
6524 uint32_t *p = MD5_data;
6525 unsigned char *q = (unsigned char *)p;
6526 if (((uint32_t *)byte_order_test)[0] != 1)
6527 { for (i=0; i<MD5_LBLOCK; i++)
6528 { uint32_t w = *q++;
6529 w |= *q++ << 8;
6530 w |= *q++ << 16;
6531 w |= *q++ << 24;
6532 *p++ = w;
6533 }
6534 }
6535 p = MD5_data;
6536 /* Round 0 */
6537 R0(A,B,C,D,p[ 0], 7,0xd76aa478); R0(D,A,B,C,p[ 1],12,0xe8c7b756);
6538 R0(C,D,A,B,p[ 2],17,0x242070db); R0(B,C,D,A,p[ 3],22,0xc1bdceee);
6539 R0(A,B,C,D,p[ 4], 7,0xf57c0faf); R0(D,A,B,C,p[ 5],12,0x4787c62a);
6540 R0(C,D,A,B,p[ 6],17,0xa8304613); R0(B,C,D,A,p[ 7],22,0xfd469501);
6541 R0(A,B,C,D,p[ 8], 7,0x698098d8); R0(D,A,B,C,p[ 9],12,0x8b44f7af);
6542 R0(C,D,A,B,p[10],17,0xffff5bb1); R0(B,C,D,A,p[11],22,0x895cd7be);
6543 R0(A,B,C,D,p[12], 7,0x6b901122); R0(D,A,B,C,p[13],12,0xfd987193);
6544 R0(C,D,A,B,p[14],17,0xa679438e); R0(B,C,D,A,p[15],22,0x49b40821);
6545 /* Round 1 */
6546 R1(A,B,C,D,p[ 1], 5,0xf61e2562); R1(D,A,B,C,p[ 6], 9,0xc040b340);
6547 R1(C,D,A,B,p[11],14,0x265e5a51); R1(B,C,D,A,p[ 0],20,0xe9b6c7aa);
6548 R1(A,B,C,D,p[ 5], 5,0xd62f105d); R1(D,A,B,C,p[10], 9,0x02441453);
6549 R1(C,D,A,B,p[15],14,0xd8a1e681); R1(B,C,D,A,p[ 4],20,0xe7d3fbc8);
6550 R1(A,B,C,D,p[ 9], 5,0x21e1cde6); R1(D,A,B,C,p[14], 9,0xc33707d6);
6551 R1(C,D,A,B,p[ 3],14,0xf4d50d87); R1(B,C,D,A,p[ 8],20,0x455a14ed);
6552 R1(A,B,C,D,p[13], 5,0xa9e3e905); R1(D,A,B,C,p[ 2], 9,0xfcefa3f8);
6553 R1(C,D,A,B,p[ 7],14,0x676f02d9); R1(B,C,D,A,p[12],20,0x8d2a4c8a);
6554 /* Round 2 */
6555 R2(A,B,C,D,p[ 5], 4,0xfffa3942); R2(D,A,B,C,p[ 8],11,0x8771f681);
6556 R2(C,D,A,B,p[11],16,0x6d9d6122); R2(B,C,D,A,p[14],23,0xfde5380c);
6557 R2(A,B,C,D,p[ 1], 4,0xa4beea44); R2(D,A,B,C,p[ 4],11,0x4bdecfa9);
6558 R2(C,D,A,B,p[ 7],16,0xf6bb4b60); R2(B,C,D,A,p[10],23,0xbebfbc70);
6559 R2(A,B,C,D,p[13], 4,0x289b7ec6); R2(D,A,B,C,p[ 0],11,0xeaa127fa);
6560 R2(C,D,A,B,p[ 3],16,0xd4ef3085); R2(B,C,D,A,p[ 6],23,0x04881d05);
6561 R2(A,B,C,D,p[ 9], 4,0xd9d4d039); R2(D,A,B,C,p[12],11,0xe6db99e5);
6562 R2(C,D,A,B,p[15],16,0x1fa27cf8); R2(B,C,D,A,p[ 2],23,0xc4ac5665);
6563 /* Round 3 */
6564 R3(A,B,C,D,p[ 0], 6,0xf4292244); R3(D,A,B,C,p[ 7],10,0x432aff97);
6565 R3(C,D,A,B,p[14],15,0xab9423a7); R3(B,C,D,A,p[ 5],21,0xfc93a039);
6566 R3(A,B,C,D,p[12], 6,0x655b59c3); R3(D,A,B,C,p[ 3],10,0x8f0ccc92);
6567 R3(C,D,A,B,p[10],15,0xffeff47d); R3(B,C,D,A,p[ 1],21,0x85845dd1);
6568 R3(A,B,C,D,p[ 8], 6,0x6fa87e4f); R3(D,A,B,C,p[15],10,0xfe2ce6e0);
6569 R3(C,D,A,B,p[ 6],15,0xa3014314); R3(B,C,D,A,p[13],21,0x4e0811a1);
6570 R3(A,B,C,D,p[ 4], 6,0xf7537e82); R3(D,A,B,C,p[11],10,0xbd3af235);
6571 R3(C,D,A,B,p[ 2],15,0x2ad7d2bb); R3(B,C,D,A,p[ 9],21,0xeb86d391);
6572
6573 MD5_A += A;
6574 MD5_B += B;
6575 MD5_C += C;
6576 MD5_D += D;
6577 }
6578
CSL_MD5_Update(unsigned char * data,int len)6579 void CSL_MD5_Update(unsigned char *data, int len)
6580 {
6581 unsigned char *p = (unsigned char *)MD5_data;
6582 /*
6583 * The full MD5 procedure allows for encoding strings of up to
6584 * around 2^64 bits. I will restrict myself to 2^32 so I can just ignore
6585 * the high word of the bit-count.
6586 */
6587 MD5_Nl += len<<3; /* Counts in BITS not BYTES here */
6588 while (len != 0)
6589 { p[MD5_num++] = *data++;
6590 len--;
6591 if (MD5_num == MD5_CBLOCK)
6592 { md5_block();
6593 MD5_num = 0;
6594 }
6595 }
6596 }
6597
CSL_MD5_Final(unsigned char * md)6598 void CSL_MD5_Final(unsigned char *md)
6599 {
6600 uint32_t l = MD5_Nl;
6601 unsigned char *p = (unsigned char *)MD5_data;
6602
6603 p[MD5_num++] = 0x80;
6604 if (MD5_num >= MD5_CBLOCK-8)
6605 { while (MD5_num < MD5_CBLOCK) p[MD5_num++] = 0;
6606 md5_block();
6607 MD5_num = 0;
6608 }
6609 while (MD5_num < MD5_CBLOCK-8) p[MD5_num++] = 0;
6610 p[MD5_num++] = (unsigned char)l;
6611 p[MD5_num++] = (unsigned char)(l>>8);
6612 p[MD5_num++] = (unsigned char)(l>>16);
6613 p[MD5_num++] = (unsigned char)(l>>24);
6614 p[MD5_num++] = 0;
6615 p[MD5_num++] = 0;
6616 p[MD5_num++] = 0;
6617 p[MD5_num++] = 0;
6618 md5_block();
6619 p = md;
6620 l = MD5_A;
6621 *p++ = (unsigned char)l;
6622 *p++ = (unsigned char)(l>>8);
6623 *p++ = (unsigned char)(l>>16);
6624 *p++ = (unsigned char)(l>>24);
6625 l = MD5_B;
6626 *p++ = (unsigned char)l;
6627 *p++ = (unsigned char)(l>>8);
6628 *p++ = (unsigned char)(l>>16);
6629 *p++ = (unsigned char)(l>>24);
6630 l = MD5_C;
6631 *p++ = (unsigned char)l;
6632 *p++ = (unsigned char)(l>>8);
6633 *p++ = (unsigned char)(l>>16);
6634 *p++ = (unsigned char)(l>>24);
6635 l = MD5_D;
6636 *p++ = (unsigned char)l;
6637 *p++ = (unsigned char)(l>>8);
6638 *p++ = (unsigned char)(l>>16);
6639 *p++ = (unsigned char)(l>>24);
6640 CSL_MD5_busy = NO;
6641 }
6642
CSL_MD5(unsigned char * d,int n,unsigned char * md)6643 unsigned char *CSL_MD5(unsigned char *d, int n, unsigned char *md)
6644 {
6645 if (n < 0) n = strlen((char *)d);
6646 CSL_MD5_Init();
6647 CSL_MD5_Update(d, n);
6648 CSL_MD5_Final(md);
6649 return md;
6650 }
6651
6652 #ifdef STAND_ALONE_TESTING_OF_MD5_CODE
6653
main(int argc,char * argv[])6654 int main(int argc, char *argv[])
6655 {
6656 int i;
6657 unsigned char mm[16];
6658 CSL_MD5("", 0, mm);
6659 for (i=0; i<16; i++) printf("%.2x", mm[i] & 0xff);
6660 printf("\n");
6661 CSL_MD5("a", 1, mm);
6662 for (i=0; i<16; i++) printf("%.2x", mm[i] & 0xff);
6663 printf("\n");
6664 CSL_MD5("abc", 3, mm);
6665 for (i=0; i<16; i++) printf("%.2x", mm[i] & 0xff);
6666 printf("\n");
6667 CSL_MD5("message digest", -1, mm);
6668 for (i=0; i<16; i++) printf("%.2x", mm[i] & 0xff);
6669 printf("\n");
6670 CSL_MD5("abcdefghijklmnopqrstuvwxyz", -1, mm);
6671 for (i=0; i<16; i++) printf("%.2x", mm[i] & 0xff);
6672 printf("\n");
6673 CSL_MD5("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789", -1, mm);
6674 for (i=0; i<16; i++) printf("%.2x", mm[i] & 0xff);
6675 printf("\n");
6676 CSL_MD5("12345678901234567890123456789012345678901234567890123456789012345678901234567890", -1, mm);
6677 for (i=0; i<16; i++) printf("%.2x", mm[i] & 0xff);
6678 printf("\n");
6679 return 0;
6680 }
6681
6682 #endif
6683
6684 /*
6685 * This is the end of the Eric Young code - what follows is Codemist
6686 * original code again.
6687 */
6688
6689
6690 /* end of restart.c */
6691
6692