suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
21c7dd839d
racket/c/scheme.c
dyb 82b2cda639 compress-level parameter, improvement in lz4 compression, and various other related improvements 
- added compress-level parameter to select a compression level for
  file writing and changed the default for lz4 compression to do a
  better job compressing.  finished splitting glz input routines
  apart from glz output routines and did a bit of other restructuring.
  removed gzxfile struct-as-bytevector wrapper and moved its fd
  into glzFile.  moved DEACTIVATE to before glzdopen_input calls
  in S_new_open_input_fd and S_compress_input_fd, since glzdopen_input
  reads from the file and could block.  the compress format and now
  level are now recorded directly the thread context.  replaced
  as-gz? flag bit in compressed bytevector header word with a small
  number of bits recording the compression format at the bottom of
  the header word.  flushed a couple of bytevector compression mats
  that depended on the old representation.  (these last few changes
  should make adding new compression formats easier.)  added
  s-directory build options to choose whether to compress and, if
  so, the format and level.
    compress-io.h, compress-io.c, new-io.c, equates.h, system.h,
    scheme.c, gc.c,
    io.ss, cmacros.ss, back.ss, bytevector.ss, primdata.ss, s/Mf-base,
    io.ms, mat.ss, bytevector.ms, root-experr*,
    release_notes.stex, io.stex, system.stex, objects.stex
- improved the effectiveness of LZ4 boot-file compression to within
  15% of gzip by increasing the lz4 output-port in_buffer size to
  1<<18.  With the previous size (1<<14) LZ4-compressed boot files
  were about 50% larger.  set the lz4 input-port in_buffer and
  out_buffer sizes to 1<<12 and 1<<14.  there's no clear win at
  present for larger input-port buffer sizes.
    compress-io.c
- To reduce the memory hit for the increased output-port in_buffer
  size and the corresponding increase in computed out_buffer size,
  one output-side out_buffer is now allocated (lazily) per thread
  and stored in the thread context.  The other buffers are now
  directly a part of the lz4File_out and lz4File_in structures
  rather than allocated separately.
    compress-io.c, scheme.c, gc.c,
    cmacros.ss
- split out the buffer emit code from glzwrite_lz4 into a
  separate glzemit_lz4 helper that is now also used by gzclose
  so we can avoid dealing with a NULL buffer in glzwrite_lz4.
  glzwrite_lz4 also uses it to writing large buffers directly and
  avoid the memcpy.
    compress-io.c
- replaced lz4File_out and lz4File_in mode enumeration with the
  compress format and inputp boolean.  using switch to check and
  raising exceptions for unexpected values to further simplify
  adding new compression formats in the future.
    compress-io.c
- replaced the never-defined struct lz4File pointer in glzFile
  union with the more specific struct lz4File_in_r and Lz4File_out_r
  pointers.
    compress-io.h, compress-io.c
- added free of lz4 structures to gzclose.  also changed file-close
  logic generally so that (1) port is marked closed before anything is
  freed to avoid dangling pointers in the case of an interrupt or
  error, and (2) structures are freed even in the case of a write
  or close error, before the error is reported.  also now mallocing
  glz and lz4 structures after possibility of errors have passed where
  possible and freeing them when not.
    compress-io.c,
    io.ss
- added return-value checks to malloc calls and to a couple of other
  C-library calls.
    compress-io.c
- corrected EINTR checks to look at errno rather than return codes.
    compress-io.c
- added S_ prefixes to the glz* exports
    externs.h, compress-io.c, new-io.c, scheme.c, fasl.c
- added entries for mutex-name and mutex-thread
    threads.stex

original commit: 722ffabef4c938bc92c0fe07f789a9ba350dc6c6
2019-04-18 05:47:19 -07:00

1277 lines
37 KiB
C
Raw Blame History

/* scheme.c
* Copyright 1984-2017 Cisco Systems, Inc.
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
*/
#include "system.h"
#include "config.h"
#include <setjmp.h>
#include <limits.h>
#ifdef WIN32
#include <time.h>
#else
#include <sys/time.h>
#endif
#include <stddef.h>
static INT boot_count;
static IBOOL verbose;
typedef enum { UNINITIALIZED, BOOTING, RUNNING, DEINITIALIZED } heap_state;
static heap_state current_state = UNINITIALIZED;
/***************************************************************************/
/* INITIALIZATION SUPPORT */
/* locally defined functions */
static void main_init PROTO((void));
static void idiot_checks PROTO((void));
static INT run_script PROTO((const char *who, const char *scriptfile, INT argc, const char *argv[], IBOOL programp));
static void main_init() {
ptr tc = get_thread_context();
ptr p;
INT i;
/* force thread inline allocation to go through find_room until ready */
AP(tc) = (ptr)0;
EAP(tc) = (ptr)0;
REAL_EAP(tc) = (ptr)0;
/* set up dummy CP so locking in read/write/Scall won't choke */
CP(tc) = Svoid;
CODERANGESTOFLUSH(tc) = Snil;
if (S_boot_time) S_G.protect_next = 0;
S_segment_init();
S_alloc_init();
S_thread_init();
S_intern_init();
S_gc_init();
S_number_init();
S_schsig_init();
S_new_io_init();
S_print_init();
S_stats_init();
S_foreign_init();
S_prim_init();
S_prim5_init();
S_fasl_init();
S_machine_init();
S_flushcache_init(); /* must come after S_machine_init(); */
#ifdef FEATURE_EXPEDITOR
S_expeditor_init();
#endif /* FEATURE_EXPEDITOR */
if (!S_boot_time) return;
S_protect(&S_G.profile_counters);
S_G.profile_counters = Snil;
FXLENGTHBV(tc) = p = S_bytevector(256);
for (i = 0; i < 256; i += 1) {
BVIT(p, i) =
(iptr)FIX(i & 0x80 ? 8 : i & 0x40 ? 7 : i & 0x20 ? 6 : i & 0x10 ? 5 :
i & 0x08 ? 4 : i & 0x04 ? 3 : i & 0x02 ? 2 : i & 0x01 ? 1 : 0);
}
FXFIRSTBITSETBV(tc) = p = S_bytevector(256);
for (i = 0; i < 256; i += 1) {
BVIT(p, i) =
(iptr)FIX(i & 0x01 ? 0 : i & 0x02 ? 1 : i & 0x04 ? 2 : i & 0x08 ? 3 :
i & 0x10 ? 4 : i & 0x20 ? 5 : i & 0x40 ? 6 : i & 0x80 ? 7 : 0);
}
NULLIMMUTABLEVECTOR(tc) = S_null_immutable_vector();
NULLIMMUTABLEFXVECTOR(tc) = S_null_immutable_fxvector();
NULLIMMUTABLEBYTEVECTOR(tc) = S_null_immutable_bytevector();
NULLIMMUTABLESTRING(tc) = S_null_immutable_string();
PARAMETERS(tc) = S_G.null_vector;
for (i = 0 ; i < virtual_register_count ; i += 1) {
VIRTREG(tc, i) = FIX(0);
}
p = S_code(tc, type_code, size_rp_header);
CODERELOC(p) = S_relocation_table(0);
CODENAME(p) = Sfalse;
CODEARITYMASK(p) = FIX(0);
CODEFREE(p) = 0;
CODEINFO(p) = Sfalse;
CODEPINFOS(p) = Snil;
RPHEADERFRAMESIZE(&CODEIT(p, 0)) = 0;
RPHEADERLIVEMASK(&CODEIT(p, 0)) = 0;
RPHEADERTOPLINK(&CODEIT(p, 0)) =
(uptr)&RPHEADERTOPLINK(&CODEIT(p, 0)) - (uptr)p;
S_protect(&S_G.dummy_code_object);
S_G.dummy_code_object = p;
S_protect(&S_G.error_invoke_code_object);
S_G.error_invoke_code_object = Snil;
S_protect(&S_G.invoke_code_object);
S_G.invoke_code_object = Snil;
S_protect(&S_G.active_threads_id);
S_G.active_threads_id = S_intern((const unsigned char *)"$active-threads");
S_set_symbol_value(S_G.active_threads_id, FIX(0));
S_protect(&S_G.heap_reserve_ratio_id);
S_G.heap_reserve_ratio_id = S_intern((const unsigned char *)"$heap-reserve-ratio");
SETSYMVAL(S_G.heap_reserve_ratio_id, Sflonum(default_heap_reserve_ratio));
S_protect(&S_G.scheme_version_id);
S_G.scheme_version_id = S_intern((const unsigned char *)"$scheme-version");
S_protect(&S_G.make_load_binary_id);
S_G.make_load_binary_id = S_intern((const unsigned char *)"$make-load-binary");
S_protect(&S_G.load_binary);
S_G.load_binary = Sfalse;
}
static ptr fixtest = FIX(-1);
static void idiot_checks() {
IBOOL oops = 0;
if (bytes_per_segment < S_pagesize) {
fprintf(stderr, "bytes_per_segment (%x) < S_pagesize (%lx)\n",
bytes_per_segment, (long)S_pagesize);
oops = 1;
}
if (sizeof(iptr) != sizeof(ptr)) {
fprintf(stderr, "sizeof(iptr) [%ld] != sizeof(ptr) [%ld]\n",
(long)sizeof(iptr), (long)sizeof(ptr));
oops = 1;
}
if (sizeof(uptr) != sizeof(ptr)) {
fprintf(stderr, "sizeof(uptr) [%ld] != sizeof(ptr) [%ld]\n",
(long)sizeof(uptr), (long)sizeof(ptr));
oops = 1;
}
if (sizeof(ptr) * 8 != ptr_bits) {
fprintf(stderr, "sizeof(ptr) * 8 [%ld] != ptr_bits [%d]\n",
(long)sizeof(ptr), ptr_bits);
oops = 1;
}
if (sizeof(int) * 8 != int_bits) {
fprintf(stderr, "sizeof(int) * 8 [%ld] != int_bits [%d]\n",
(long)sizeof(int), int_bits);
oops = 1;
}
if (sizeof(short) * 8 != short_bits) {
fprintf(stderr, "sizeof(short) * 8 [%ld] != short_bits [%d]\n",
(long)sizeof(short), short_bits);
oops = 1;
}
if (sizeof(long) * 8 != long_bits) {
fprintf(stderr, "sizeof(long) * 8 [%ld] != long_bits [%d]\n",
(long)sizeof(long), long_bits);
oops = 1;
}
#ifndef WIN32
if (sizeof(long long) * 8 != long_long_bits) {
fprintf(stderr, "sizeof(long long) * 8 [%ld] != long_long_bits [%d]\n",
(long)sizeof(long long), long_long_bits);
oops = 1;
}
#endif
if (sizeof(wchar_t) * 8 != wchar_bits) {
fprintf(stderr, "sizeof(wchar_t) * 8 [%ld] != wchar_bits [%d]\n",
(long)sizeof(wchar_t), wchar_bits);
oops = 1;
}
if (sizeof(size_t) * 8 != size_t_bits) {
fprintf(stderr, "sizeof(size_t) * 8 [%ld] != size_t_bits [%d]\n",
(long)sizeof(size_t), size_t_bits);
oops = 1;
}
#ifndef WIN32
if (sizeof(ssize_t) * 8 != size_t_bits) {
fprintf(stderr, "sizeof(ssize_t) * 8 [%ld] != size_t_bits [%d]\n",
(long)sizeof(ssize_t), size_t_bits);
oops = 1;
}
#endif
if (sizeof(ptrdiff_t) * 8 != ptrdiff_t_bits) {
fprintf(stderr, "sizeof(ptrdiff_t) * 8 [%ld] != ptrdiff_t_bits [%d]\n",
(long)sizeof(ptrdiff_t), ptrdiff_t_bits);
oops = 1;
}
if (sizeof(time_t) * 8 != time_t_bits) {
fprintf(stderr, "sizeof(time_t) * 8 [%ld] != time_t_bits [%d]\n",
(long)sizeof(time_t), time_t_bits);
oops = 1;
}
if (sizeof(bigit) * 8 != bigit_bits) {
fprintf(stderr, "sizeof(bigit) * 8 [%ld] != bigit_bits [%d]\n",
(long)sizeof(bigit), bigit_bits);
oops = 1;
}
if (sizeof(bigitbigit) != 2 * sizeof(bigit)) {
fprintf(stderr, "sizeof(bigitbigit) [%ld] != sizeof(bigit) [%ld] * 2\n",
(long)sizeof(bigitbigit), (long)sizeof(bigit));
oops = 1;
}
if (sizeof(char) != 1) {
fprintf(stderr, "sizeof(char) [%ld] != 1\n", (long)sizeof(char));
oops = 1;
}
if (sizeof(I8) != 1) {
fprintf(stderr, "sizeof(I8) [%ld] != 1\n", (long)sizeof(I8));
oops = 1;
}
if (sizeof(U8) != 1) {
fprintf(stderr, "sizeof(U8) [%ld] != 1\n", (long)sizeof(U8));
oops = 1;
}
if (sizeof(I16) != 2) {
fprintf(stderr, "sizeof(I16) [%ld] != 2\n", (long)sizeof(I16));
oops = 1;
}
if (sizeof(U16) != 2) {
fprintf(stderr, "sizeof(U16) [%ld] != 2\n", (long)sizeof(U16));
oops = 1;
}
if (sizeof(I32) != 4) {
fprintf(stderr, "sizeof(I32) [%ld] != 4\n", (long)sizeof(I32));
oops = 1;
}
if (sizeof(U32) != 4) {
fprintf(stderr, "sizeof(U32) [%ld] != 4\n", (long)sizeof(U32));
oops = 1;
}
if (sizeof(I64) != 8) {
fprintf(stderr, "sizeof(I64) [%ld] != 8\n", (long)sizeof(I64));
oops = 1;
}
if (sizeof(U64) != 8) {
fprintf(stderr, "sizeof(U64) [%ld] != 8\n", (long)sizeof(U64));
oops = 1;
}
if (sizeof(string_char) != string_char_bytes) {
fprintf(stderr, "sizeof(string_char) [%ld] != string_char_bytes [%d]\n", (long)sizeof(string_char), string_char_bytes);
oops = 1;
}
if (UNFIX(fixtest) != -1) {
fprintf(stderr, "UNFIX operation failed\n");
oops = 1;
}
if (strlen(VERSION)+1 > HEAP_VERSION_LENGTH) {
fprintf(stderr, "insufficient space for version in heap header\n");
oops = 1;
}
if (strlen(MACHINE_TYPE)+1 > HEAP_MACHID_LENGTH) {
fprintf(stderr, "insufficient space for machine id in heap header\n");
oops = 1;
}
#define big 0
#define little 1
if (native_endianness == big) {
uptr x[1];
*x = 1;
if (*(char *)x != 0) {
fprintf(stderr, "endianness claimed to be big, appears to be little\n");
oops = 1;
}
} else {
uptr x[1];
*x = 1;
if (*(char *)x == 0) {
fprintf(stderr, "endianness claimed to be little, appears to be big\n");
oops = 1;
}
}
if (sizeof(bucket_pointer_list) != sizeof(bucket_list)) {
/* gc repurposes bucket_lists for bucket_pointer lists, so they'd better have the same size */
fprintf(stderr, "bucket_pointer_list and bucket_list have different sizes\n");
oops = 1;
}
if ((cards_per_segment & (sizeof(iptr) - 1)) != 0) {
/* gc sometimes processes dirty bytes sizeof(iptr) bytes at a time */
fprintf(stderr, "cards_per_segment is not a multiple of sizeof(iptr)\n");
oops = 1;
}
if (((uptr)(&((seginfo *)0)->dirty_bytes[0]) & (sizeof(iptr) - 1)) != 0) {
/* gc sometimes processes dirty bytes sizeof(iptr) bytes at a time */
fprintf(stderr, "dirty_bytes[0] is not iptr-aligned wrt to seginfo struct\n");
oops = 1;
}
if (!Sfixnump(type_vector | ~mask_vector)) {
/* gc counts on vector type/length looking like a fixnum, so it can put vectors in space_impure */
fprintf(stderr, "vector type/length field does not look like a fixnum\n");
oops = 1;
}
if (oops) S_abnormal_exit();
}
/***************************************************************************/
/* SUPPORT FOR CALLING INTO SCHEME */
/* locally defined functions */
static ptr boot_call PROTO((ptr tc, ptr p, INT n));
static void check_ap PROTO((ptr tc));
/* arguments and ac0 set up */
static ptr boot_call(tc, p, n) ptr tc; ptr p; INT n; {
AC1(tc) = p;
CP(tc) = Svoid; /* don't have calling code object */
AC0(tc) = (ptr)(uptr)n;
S_call_help(tc, 0, 0);
check_ap(tc);
CP(tc) = Svoid; /* leave clean so direct Scall won't choke */
switch ((iptr)AC1(tc)) {
case 1:
p = AC0(tc);
break;
case 0:
p = Svoid;
break;
default:
p = S_get_scheme_arg(tc, 1);
break;
}
return p;
}
static void check_ap(tc) ptr tc; {
if ((uptr)AP(tc) & (byte_alignment - 1)) {
(void) fprintf(stderr, "ap is not double word aligned\n");
S_abnormal_exit();
}
if ((ptr *)AP(tc) > (ptr *)EAP(tc)) {
(void) fprintf(stderr, "ap is greater than eap\n");
S_abnormal_exit();
}
}
void S_generic_invoke(tc, code) ptr tc; ptr code; {
#if defined(PPCAIX)
struct {caddr_t entry, toc, static_link;} hdr;
hdr.entry = (caddr_t)&CODEIT(code,0);
hdr.toc = (caddr_t)0;
hdr.static_link = (caddr_t)0;
(*((void (*) PROTO((ptr)))(void *)&hdr))(tc);
#elif defined(PPCNT)
/* under NT, function headers contain no static link */
struct {I32 entry, toc;} hdr;
typedef void (*ugly)(ptr);
ugly p;
hdr.entry = (I32)&CODEIT(code,0);
hdr.toc = (I32)0;
/* MSVC++ bombs with internal compiler error if we don't split this up */
p = (ugly)&hdr;
p(tc);
#elif defined(PARISC)
struct {I32 entry, env;} hdr;
typedef void (*ugly)(ptr);
ugly p;
hdr.entry = (I32)&CODEIT(code,0);
hdr.env = (I32)0;
p = (ugly)((I32)&hdr + 2);
p(tc);
#elif defined(WIN32)
__try {
(*((void (*) PROTO((ptr)))(void *)&CODEIT(code,0)))(tc);
}
__except(GetExceptionCode() == EXCEPTION_ACCESS_VIOLATION ?
EXCEPTION_EXECUTE_HANDLER : EXCEPTION_CONTINUE_SEARCH)
{
if (S_pants_down)
S_error_abort("nonrecoverable invalid memory reference");
else
S_error_reset("invalid memory reference");
}
#else
(*((void (*) PROTO((ptr)))(void *)&CODEIT(code,0)))(tc);
#endif
}
/***************************************************************************/
/* MISCELLANEOUS HELPERS */
/* locally defined functions */
static IBOOL next_path PROTO((char *path, const char *name, const char *ext, const char **sp, const char **dsp));
static const char *path_last PROTO((const char *path));
static char *get_defaultheapdirs PROTO((void));
static const char *path_last(p) const char *p; {
const char *s;
#ifdef WIN32
char c;
if ((c = *p) >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')
if (*(p + 1) == ':')
p += 2;
#endif
for (s = p; *s != 0; s += 1)
if (DIRMARKERP(*s)) p = ++s;
return p;
}
#ifdef WIN32
#ifndef DEFAULT_HEAP_PATH
/* by default, look in executable directory or in parallel boot directory */
#define DEFAULT_HEAP_PATH "%x;%x\\..\\..\\boot\\%m"
#endif
#define SEARCHPATHSEP ';'
#define PATHSEP '\\'
static char *get_defaultheapdirs() {
char *result;
wchar_t buf[PATH_MAX];
DWORD len = sizeof(buf);
if (ERROR_SUCCESS != RegGetValueW(HKEY_LOCAL_MACHINE, L"Software\\Chez Scheme\\csv" VERSION, L"HeapSearchPath", RRF_RT_REG_SZ, NULL, buf, &len))
return DEFAULT_HEAP_PATH;
else if ((result = Swide_to_utf8(buf)))
return result;
else
return DEFAULT_HEAP_PATH;
}
#else /* not WIN32: */
#define SEARCHPATHSEP ':'
#define PATHSEP '/'
#ifndef DEFAULT_HEAP_PATH
#define DEFAULT_HEAP_PATH "/usr/lib/csv%v/%m:/usr/local/lib/csv%v/%m"
#endif
static char *get_defaultheapdirs() {
return DEFAULT_HEAP_PATH;
}
#endif /* WIN32 */
/* next_path isolates the next entry in the two-part search path sp/dsp,
* leaving the full path with name affixed in path and *sp / *dsp pointing
* past the current entry. it returns 1 on success and 0 if at the end of
* the search path. path should be a pointer to an unoccupied buffer
* PATH_MAX characters long. either or both of sp/dsp may be empty,
* but neither may be null, i.e., (char *)0. */
static IBOOL next_path(path, name, ext, sp, dsp) char *path; const char *name, *ext, **sp, **dsp; {
char *p;
const char *s, *t;
#define setp(c) if (p >= path + PATH_MAX) { fprintf(stderr, "search path entry too long\n"); S_abnormal_exit(); } else *p++ = (c)
for (;;) {
s = *sp;
p = path;
/* copy first searchpath entry into path, substituting MACHINE_TYPE for %m,
* VERSION for %v, % for %%, and : (; windows) for %: (%; windows) */
while (*s != 0 && *s != SEARCHPATHSEP) {
switch (*s) {
case '%':
s += 1;
switch (*s) {
#ifdef WIN32
case 'x': {
wchar_t exepath[PATH_MAX]; DWORD n;
s += 1;
n = GetModuleFileNameW(NULL, exepath, PATH_MAX);
if (n == 0 || (n == PATH_MAX && GetLastError() == ERROR_INSUFFICIENT_BUFFER)) {
fprintf(stderr, "warning: executable path is too long; ignoring %%x\n");
} else {
char *tstart;
const char *tend;
tstart = Swide_to_utf8(exepath);
t = tstart;
tend = path_last(t);
if (tend != t) tend -= 1; /* back up to directory separator */
while (t != tend) setp(*t++);
free(tstart);
}
break;
}
#endif
case 'm':
s += 1;
t = MACHINE_TYPE;
while (*t != 0) setp(*t++);
break;
case 'v':
s += 1;
t = VERSION;
while (*t != 0) setp(*t++);
break;
case '%':
case SEARCHPATHSEP:
setp(*s++);
break;
default:
fprintf(stderr, "warning: ignoring extra %% in search path\n");
break;
}
break;
default:
setp(*s++);
break;
}
}
/* unless entry was null, append name and ext onto path and return true with
* updated path, sp, and possibly dsp */
if (s != *sp) {
if (!DIRMARKERP(*(p - 1))) { setp(PATHSEP); }
t = name;
while (*t != 0) setp(*t++);
t = ext;
while (*t != 0) setp(*t++);
setp(0);
*sp = s;
return 1;
}
/* if current segment is empty, move to next segment. if next segment
* is empty, return false */
if (*s == 0) {
if (*(*sp = *dsp) == 0) return 0;
*dsp = "";
} else {
*sp = s + 1;
}
}
#undef setp
}
/***************************************************************************/
/* BOOT FILES */
typedef struct {
glzFile file;
char path[PATH_MAX];
} boot_desc;
#define MAX_BOOT_FILES 10
static boot_desc bd[MAX_BOOT_FILES];
/* locally defined functions */
static uptr zget_uptr PROTO((glzFile file, uptr *pn));
static INT zgetstr PROTO((glzFile file, char *s, iptr max));
static IBOOL find_boot PROTO((const char *name, const char *ext, int fd, IBOOL errorp));
static void load PROTO((ptr tc, iptr n, IBOOL base));
static void check_boot_file_state PROTO((const char *who));
static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IBOOL errorp; {
char pathbuf[PATH_MAX], buf[PATH_MAX];
uptr n; INT c;
const char *path;
#ifdef WIN32
wchar_t *expandedpath;
#else
char *expandedpath;
#endif
glzFile file;
if ((fd != -1) || S_fixedpathp(name)) {
if (strlen(name) >= PATH_MAX) {
fprintf(stderr, "boot-file path is too long %s\n", name);
S_abnormal_exit();
}
path = name;
if (fd != -1) {
file = S_glzdopen_input(fd);
} else {
#ifdef WIN32
expandedpath = S_malloc_wide_pathname(path);
file = S_glzopen_input_w(expandedpath);
#else
expandedpath = S_malloc_pathname(path);
file = S_glzopen_input(expandedpath);
#endif
/* assumption (seemingly true based on a glance at the source code):
S_glzopen_input doesn't squirrel away a pointer to expandedpath. */
free(expandedpath);
}
if (!file) {
if (errorp) {
fprintf(stderr, "cannot open boot file %s\n", path);
S_abnormal_exit();
} else {
if (verbose) fprintf(stderr, "trying %s...cannot open\n", path);
return 0;
}
}
if (verbose) fprintf(stderr, "trying %s...opened\n", path);
/* check for magic number */
if (S_glzgetc(file) != fasl_type_header ||
S_glzgetc(file) != 0 ||
S_glzgetc(file) != 0 ||
S_glzgetc(file) != 0 ||
S_glzgetc(file) != 'c' ||
S_glzgetc(file) != 'h' ||
S_glzgetc(file) != 'e' ||
S_glzgetc(file) != 'z') {
fprintf(stderr, "malformed fasl-object header in %s\n", path);
S_abnormal_exit();
}
/* check version */
if (zget_uptr(file, &n) != 0) {
fprintf(stderr, "unexpected end of file on %s\n", path);
S_glzclose(file);
S_abnormal_exit();
}
if (n != scheme_version) {
fprintf(stderr, "%s is for Version %s; ", path, S_format_scheme_version(n));
/* use separate fprintf since S_format_scheme_version returns static string */
fprintf(stderr, "need Version %s\n", S_format_scheme_version(scheme_version));
S_glzclose(file);
S_abnormal_exit();
}
/* check machine type */
if (zget_uptr(file, &n) != 0) {
fprintf(stderr, "unexpected end of file on %s\n", path);
S_glzclose(file);
S_abnormal_exit();
}
if (n != machine_type) {
fprintf(stderr, "%s is for machine-type %s; need machine-type %s\n", path,
S_lookup_machine_type(n), S_lookup_machine_type(machine_type));
S_glzclose(file);
S_abnormal_exit();
}
} else {
const char *sp = Sschemeheapdirs;
const char *dsp = Sdefaultheapdirs;
path = pathbuf;
for (;;) {
if (!next_path(pathbuf, name, ext, &sp, &dsp)) {
if (errorp) {
fprintf(stderr, "cannot find compatible boot file %s%s in search path:\n \"%s%s\"\n",
name, ext,
Sschemeheapdirs, Sdefaultheapdirs);
S_abnormal_exit();
} else {
if (verbose) fprintf(stderr, "no compatible %s%s found\n", name, ext);
return 0;
}
}
#ifdef WIN32
expandedpath = S_malloc_wide_pathname(path);
file = S_glzopen_input_w(expandedpath);
#else
expandedpath = S_malloc_pathname(path);
file = S_glzopen_input(expandedpath);
#endif
/* assumption (seemingly true based on a glance at the source code):
S_glzopen_input doesn't squirrel away a pointer to expandedpath. */
free(expandedpath);
if (!file) {
if (verbose) fprintf(stderr, "trying %s...cannot open\n", path);
continue;
}
if (verbose) fprintf(stderr, "trying %s...opened\n", path);
/* check for magic number */
if (S_glzgetc(file) != fasl_type_header ||
S_glzgetc(file) != 0 ||
S_glzgetc(file) != 0 ||
S_glzgetc(file) != 0 ||
S_glzgetc(file) != 'c' ||
S_glzgetc(file) != 'h' ||
S_glzgetc(file) != 'e' ||
S_glzgetc(file) != 'z') {
if (verbose) fprintf(stderr, "malformed fasl-object header in %s\n", path);
S_glzclose(file);
continue;
}
/* check version */
if (zget_uptr(file, &n) != 0) {
if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path);
S_glzclose(file);
continue;
}
if (n != scheme_version) {
if (verbose) {
fprintf(stderr, "%s is for Version %s; ", path, S_format_scheme_version(n));
/* use separate fprintf since S_format_scheme_version returns static string */
fprintf(stderr, "need Version %s\n", S_format_scheme_version(scheme_version));
}
S_glzclose(file);
continue;
}
/* check machine type */
if (zget_uptr(file, &n) != 0) {
if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path);
S_glzclose(file);
continue;
}
if (n != machine_type) {
if (verbose)
fprintf(stderr, "%s is for machine-type %s; need machine-type %s\n", path,
S_lookup_machine_type(n), S_lookup_machine_type(machine_type));
S_glzclose(file);
continue;
}
break;
}
}
if (verbose) fprintf(stderr, "version and machine type check\n");
if (S_glzgetc(file) != '(') { /* ) */
fprintf(stderr, "malformed boot file %s\n", path);
S_glzclose(file);
S_abnormal_exit();
}
/* ( */
if ((c = S_glzgetc(file)) == ')') {
if (boot_count != 0) {
fprintf(stderr, "base boot file %s must come before other boot files\n", path);
S_glzclose(file);
S_abnormal_exit();
}
} else {
if (boot_count == 0) {
for (;;) {
S_glzungetc(c, file);
/* try to load heap or boot file this boot file requires */
if (zgetstr(file, buf, PATH_MAX) != 0) {
fprintf(stderr, "unexpected end of file on %s\n", path);
S_glzclose(file);
S_abnormal_exit();
}
if (find_boot(buf, ".boot", -1, 0)) break;
if ((c = S_glzgetc(file)) == ')') {
char *sep; char *wastebuf[8];
fprintf(stderr, "cannot find subordinate boot file ");
S_glzrewind(file);
(void) S_glzread(file, wastebuf, 8); /* magic number */
(void) zget_uptr(file, &n); /* version */
(void) zget_uptr(file, &n); /* machine type */
(void) S_glzgetc(file); /* open paren */
for (sep = ""; ; sep = "or ") {
if ((c = S_glzgetc(file)) == ')') break;
S_glzungetc(c, file);
(void) zgetstr(file, buf, PATH_MAX);
fprintf(stderr, "%s%s.boot ", sep, buf);
}
fprintf(stderr, "required by %s\n", path);
S_glzclose(file);
S_abnormal_exit();
}
}
}
/* skip to end of header */
while ((c = S_glzgetc(file)) != ')') {
if (c < 0) {
fprintf(stderr, "malformed boot file %s\n", path);
S_glzclose(file);
S_abnormal_exit();
}
}
}
if (boot_count >= MAX_BOOT_FILES) {
fprintf(stderr, "exceeded maximum number of boot files (%d)\n", MAX_BOOT_FILES);
S_abnormal_exit();
}
bd[boot_count].file = file;
strcpy(bd[boot_count].path, path);
boot_count += 1;
return 1;
}
static uptr zget_uptr(glzFile file, uptr *pn) {
uptr n, m; int c; octet k;
if ((c = S_glzgetc(file)) < 0) return -1;
k = (octet)c;
n = k >> 1;
while (k & 1) {
if ((c = S_glzgetc(file)) < 0) return -1;
k = (octet)c;
m = n << 7;
if (m >> 7 != n) return -1;
n = m | (k >> 1);
}
*pn = n;
return 0;
}
static INT zgetstr(file, s, max) glzFile file; char *s; iptr max; {
ICHAR c;
while (max-- > 0) {
if ((c = S_glzgetc(file)) < 0) return -1;
if (c == ' ' || c == ')') {
if (c == ')') S_glzungetc(c, file);
*s = 0;
return 0;
}
*s++ = c;
}
return -1;
}
static IBOOL loadecho = 0;
#define LOADSKIP 0
static void handle_visit_revisit(tc, p) ptr tc; ptr p; {
ptr a = Scar(p);
if (a == FIX(visit_tag) || a == FIX(revisit_tag)) {
ptr d = Scdr(p);
if (Sprocedurep(d)) {
S_initframe(tc, 0);
INITCDR(p) = boot_call(tc, d, 0);
}
}
}
static int set_load_binary(iptr n) {
if (SYMVAL(S_G.scheme_version_id) == sunbound) return 0; // set by back.ss
ptr make_load_binary = SYMVAL(S_G.make_load_binary_id);
if (Sprocedurep(make_load_binary)) {
S_G.load_binary = Scall3(make_load_binary, Sstring_utf8(bd[n].path, -1), Sstring_to_symbol("load"), Sfalse);
return 1;
}
return 0;
}
static void load(tc, n, base) ptr tc; iptr n; IBOOL base; {
ptr x; iptr i;
if (base) {
S_G.error_invoke_code_object = S_boot_read(bd[n].file, bd[n].path);
if (!Scodep(S_G.error_invoke_code_object)) {
(void) fprintf(stderr, "first object on boot file not code object\n");
S_abnormal_exit();
}
S_G.invoke_code_object = S_boot_read(bd[n].file, bd[n].path);
if (!Scodep(S_G.invoke_code_object)) {
(void) fprintf(stderr, "second object on boot file not code object\n");
S_abnormal_exit();
}
S_G.base_rtd = S_boot_read(bd[n].file, bd[n].path);
if (!Srecordp(S_G.base_rtd)) {
S_abnormal_exit();
}
}
i = 0;
while (i++ < LOADSKIP && S_boot_read(bd[n].file, bd[n].path) != Seof_object);
while ((x = S_boot_read(bd[n].file, bd[n].path)) != Seof_object) {
if (loadecho) {
printf("%ld: ", (long)i);
fflush(stdout);
}
if (Sprocedurep(x)) {
S_initframe(tc, 0);
x = boot_call(tc, x, 0);
} else if (Sprocedurep(S_G.load_binary) || set_load_binary(n)) {
S_initframe(tc, 1);
S_put_arg(tc, 1, x);
x = boot_call(tc, S_G.load_binary, 1);
} else if (Svectorp(x)) {
iptr j, n;
n = Svector_length(x);
for (j = 0; j < n; j += 1) {
ptr y = Svector_ref(x, j);
if (Sprocedurep(y)) {
S_initframe(tc, 0);
INITVECTIT(x, j) = boot_call(tc, y, 0);
} else if (Spairp(y)) {
handle_visit_revisit(tc, y);
}
}
} else if (Spairp(x)) {
handle_visit_revisit(tc, x);
}
if (loadecho) {
S_prin1(x);
putchar('\n');
fflush(stdout);
}
i += 1;
}
S_G.load_binary = Sfalse;
S_glzclose(bd[n].file);
}
/***************************************************************************/
/* HEAP FILES */
#ifdef DEBUG
#define debug(x) {x}
#else
#define debug(x)
#endif
#include <fcntl.h>
#include <sys/types.h>
#ifdef WIN32
#include <io.h>
#endif /* WIN32 */
#ifdef MMAP_HEAP
#include <sys/mman.h>
#endif
#ifndef O_BINARY
#define O_BINARY 0
#endif /* O_BINARY */
#define check(expr,path) {if ((INT)(expr) < 0) {perror(path); S_abnormal_exit();}}
/***************************************************************************/
/* EXPORTED ROUTINES */
const char *Skernel_version(void) {
return VERSION;
}
extern void Sset_verbose(v) INT v; {
verbose = v;
}
extern void Sretain_static_relocation(void) {
S_G.retain_static_relocation = 1;
}
#ifdef ITEST
#include "itest.c"
#endif
static void default_abnormal_exit(void) {
exit(1);
}
extern void Sscheme_init(abnormal_exit) void (*abnormal_exit) PROTO((void)); {
S_abnormal_exit_proc = abnormal_exit ? abnormal_exit : default_abnormal_exit;
S_errors_to_console = 1;
/* set before idiot checks */
S_pagesize = GETPAGESIZE();
idiot_checks();
switch (current_state) {
case RUNNING:
fprintf(stderr, "error (Sscheme_init): call Sscheme_deinit first to terminate\n");
S_abnormal_exit();
case BOOTING:
fprintf(stderr, "error (Sscheme_init): already initialized\n");
S_abnormal_exit();
case UNINITIALIZED:
case DEINITIALIZED:
break;
}
current_state = BOOTING;
S_G.retain_static_relocation = 0;
S_G.enable_object_counts = 0;
boot_count = 0;
#ifdef WIN32
Sschemeheapdirs = Sgetenv("SCHEMEHEAPDIRS");
#else
Sschemeheapdirs = getenv("SCHEMEHEAPDIRS");
#endif
if (Sschemeheapdirs == (char *)0) {
Sschemeheapdirs = "";
if ((Sdefaultheapdirs = get_defaultheapdirs()) == (char *)0) Sdefaultheapdirs = "";
} else if (*Sschemeheapdirs != 0 && Sschemeheapdirs[strlen(Sschemeheapdirs)-1] == SEARCHPATHSEP) {
if ((Sdefaultheapdirs = get_defaultheapdirs()) == (char *)0) Sdefaultheapdirs = "";
} else {
Sdefaultheapdirs = "";
}
#ifdef PTHREADS
{
int status;
if ((status = s_thread_key_create(&S_tc_key)) != 0)
S_error_abort(strerror(status));
s_thread_setspecific(S_tc_key, S_G.thread_context);
}
#endif
#ifdef ITEST
S_boot_time = 1;
main_init();
bignum_test();
exit(0);
#endif
}
static void check_boot_file_state(const char *who) {
switch (current_state) {
case UNINITIALIZED:
case DEINITIALIZED:
fprintf(stderr, "error (%s): uninitialized; call Sscheme_init first\n", who);
if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit();
case RUNNING:
fprintf(stderr, "error (%s): already running\n", who);
S_abnormal_exit();
case BOOTING:
break;
}
}
extern void Sregister_boot_file(name) const char *name; {
check_boot_file_state("Sregister_boot_file");
find_boot(name, "", -1, 1);
}
extern void Sregister_boot_file_fd(name, fd) const char *name; int fd; {
check_boot_file_state("Sregister_boot_file_fd");
find_boot(name, "", fd, 1);
}
extern void Sregister_heap_file(UNUSED const char *path) {
fprintf(stderr, "Sregister_heap_file: saved heap files are not presently supported\n");
S_abnormal_exit();
}
extern void Sbuild_heap(kernel, custom_init) const char *kernel; void (*custom_init) PROTO((void)); {
ptr tc = Svoid; /* initialize to make gcc happy */
ptr p;
switch (current_state) {
case UNINITIALIZED:
case DEINITIALIZED:
fprintf(stderr, "error (Sbuild_heap): uninitialized; call Sscheme_init first\n");
if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit();
case RUNNING:
fprintf(stderr, "error (Sbuild_heap): already running\n");
S_abnormal_exit();
case BOOTING:
break;
}
current_state = RUNNING;
S_boot_time = 1;
if (boot_count == 0) {
const char *name;
if (!kernel) {
fprintf(stderr, "no boot file or executable name specified\n");
S_abnormal_exit();
}
name = path_last(kernel);
if (strlen(name) >= PATH_MAX) {
fprintf(stderr, "executable name too long: %s\n", name);
S_abnormal_exit();
}
#ifdef WIN32
{ /* strip off trailing .exe, if any */
static char buf[PATH_MAX];
iptr n;
n = strlen(name) - 4;
if (n >= 0 && (strcmp(name + n, ".exe") == 0 || strcmp(name + n, ".EXE") == 0)) {
strcpy(buf, name);
buf[n] = 0;
name = buf;
}
}
#endif
if (!find_boot(name, ".boot", -1, 0)) {
fprintf(stderr, "cannot find compatible %s.boot in search path\n \"%s%s\"\n",
name,
Sschemeheapdirs, Sdefaultheapdirs);
S_abnormal_exit();
}
}
if (boot_count != 0) {
INT i = 0;
main_init();
if (custom_init) custom_init();
S_threads = Snil;
S_nthreads = 0;
S_set_symbol_value(S_G.active_threads_id, FIX(0));
/* pass a parent tc of Svoid, since this call establishes the initial
* thread context and hence there is no parent thread context. */
tc = (ptr)THREADTC(S_create_thread_object("startup", tc));
#ifdef PTHREADS
s_thread_setspecific(S_tc_key, tc);
#endif
/* #scheme-init enables interrupts */
TRAP(tc) = (ptr)most_positive_fixnum;
DISABLECOUNT(tc) = Sfixnum(1);
COMPRESSFORMAT(tc) = FIX(COMPRESS_LZ4);
COMPRESSLEVEL(tc) = FIX(COMPRESS_MEDIUM);
load(tc, i++, 1);
S_boot_time = 0;
while (i < boot_count) load(tc, i++, 0);
}
if (boot_count != 0) Scompact_heap();
/* complete the initialization on the Scheme side */
p = S_symbol_value(S_intern((const unsigned char *)"$scheme-init"));
if (!Sprocedurep(p)) {
(void) fprintf(stderr,"\n$scheme-init is not bound to a procedure\n");
S_abnormal_exit();
}
S_initframe(tc, 0);
(void)boot_call(tc, p, 0);
/* should be okay to invoke Scheme's error handler now */
S_errors_to_console = 0;
}
extern void Senable_expeditor(history_file) const char *history_file; {
Scall1(S_symbol_value(Sstring_to_symbol("$enable-expeditor")), Strue);
if (history_file != (const char *)0)
Scall1(S_symbol_value(Sstring_to_symbol("$expeditor-history-file")),
Sstring_utf8(history_file, -1));
}
extern INT Sscheme_start(argc, argv) INT argc; const char *argv[]; {
ptr tc = get_thread_context();
ptr arglist, p; INT i;
switch (current_state) {
case UNINITIALIZED:
case DEINITIALIZED:
fprintf(stderr, "error (Sscheme_start): uninitialized; call Sscheme_init and Sbuild_heap first\n");
if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit();
case BOOTING:
fprintf(stderr, "error (Sscheme_start): no heap built yet; call Sbuild_heap first\n");
S_abnormal_exit();
case RUNNING:
break;
}
arglist = Snil;
for (i = argc - 1; i > 0; i -= 1)
arglist = Scons(Sstring_utf8(argv[i], -1), arglist);
p = S_symbol_value(S_intern((const unsigned char *)"$scheme"));
if (!Sprocedurep(p)) {
(void) fprintf(stderr,"\n$scheme is not bound to a procedure\n");
S_abnormal_exit();
}
S_initframe(tc, 1);
S_put_arg(tc, 1, arglist);
p = boot_call(tc, p, 1);
if (S_integer_valuep(p)) return (INT)Sinteger_value(p);
return p == Svoid ? 0 : 1;
}
static INT run_script(const char *who, const char *scriptfile, INT argc, const char *argv[], IBOOL programp) {
ptr tc = get_thread_context();
ptr arglist, p; INT i;
switch (current_state) {
case UNINITIALIZED:
case DEINITIALIZED:
fprintf(stderr, "error (%s): uninitialized; call Sscheme_init and Sbuild_heap first\n", who);
if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit();
case BOOTING:
fprintf(stderr, "error (%s): no heap built yet; call Sbuild_heap first\n", who);
S_abnormal_exit();
case RUNNING:
break;
}
arglist = Snil;
for (i = argc - 1; i > 0; i -= 1)
arglist = Scons(Sstring_utf8(argv[i], -1), arglist);
p = S_symbol_value(S_intern((const unsigned char *)"$script"));
if (!Sprocedurep(p)) {
(void) fprintf(stderr,"\n$script is not bound to a procedure\n");
S_abnormal_exit();
}
S_initframe(tc, 3);
S_put_arg(tc, 1, Sboolean(programp));
S_put_arg(tc, 2, Sstring_utf8(scriptfile, -1));
S_put_arg(tc, 3, arglist);
p = boot_call(tc, p, 3);
if (S_integer_valuep(p)) return (INT)Sinteger_value(p);
return p == Svoid ? 0 : 1;
}
extern INT Sscheme_script(scriptfile, argc, argv) const char *scriptfile; INT argc; const char *argv[]; {
return run_script("Sscheme_script", scriptfile, argc, argv, 0);
}
extern INT Sscheme_program(programfile, argc, argv) const char *programfile; INT argc; const char *argv[]; {
return run_script("Sscheme_program", programfile, argc, argv, 1);
}
extern void Ssave_heap(UNUSED const char *path, UNUSED INT level) {
fprintf(stderr, "Ssave_heap: saved heap files are not presently supported\n");
S_abnormal_exit();
}
extern void Sscheme_deinit() {
ptr p, tc = get_thread_context();
switch (current_state) {
case UNINITIALIZED:
case DEINITIALIZED:
fprintf(stderr, "error (Sscheme_deinit): not yet initialized or running\n");
if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit();
case BOOTING:
fprintf(stderr, "error (Sscheme_deinit): not yet running\n");
S_abnormal_exit();
case RUNNING:
break;
}
p = S_symbol_value(S_intern((const unsigned char *)"$close-files"));
S_initframe(tc, 0);
boot_call(tc, p, 0);
S_errors_to_console = 1;
current_state = DEINITIALIZED;
}
Reference in New Issue View Git Blame Copy Permalink