sync with https://github.com/cisco/ChezScheme on fasl compression
Merge changes in the way that fasl streams are compressed. The new approach makes compression explicit in the fasl representation, which means that tricks like uzing zcat on a fasl file will no longer work (at least not efficiently). original commit: 167ac7294a2dc400821e4336f0cfc4de621efe97
This commit is contained in:
Matthew Flatt
commit
fd3b903c1c
4
.github/scripts/build.sh
vendored
4
.github/scripts/build.sh
vendored
|
|
@ -5,9 +5,9 @@ echo Building Chez Scheme...
|
|||
make
|
||||
case $MACH in
|
||||
*a6nt)
|
||||
curl -Ls https://github.com/burgerrg/win-iconv/releases/download/v0.0.9/iconv-x64.dll > $TARGET_MACHINE/bin/$TARGET_MACHINE/iconv.dll
|
||||
curl -Ls https://github.com/burgerrg/win-iconv/releases/download/v0.0.9/iconv-x64.dll > "$TARGET_MACHINE"/bin/"$TARGET_MACHINE"/iconv.dll
|
||||
;;
|
||||
*i3nt)
|
||||
curl -Ls https://github.com/burgerrg/win-iconv/releases/download/v0.0.9/iconv-x86.dll > $TARGET_MACHINE/bin/$TARGET_MACHINE/iconv.dll
|
||||
curl -Ls https://github.com/burgerrg/win-iconv/releases/download/v0.0.9/iconv-x86.dll > "$TARGET_MACHINE"/bin/"$TARGET_MACHINE"/iconv.dll
|
||||
;;
|
||||
esac
|
||||
|
|
|
|||
12
.github/scripts/matting.sh
vendored
Executable file
12
.github/scripts/matting.sh
vendored
Executable file
|
|
@ -0,0 +1,12 @@
|
|||
#!/bin/bash
|
||||
# We don't use grep because on Windows, it doesn't flush its output.
|
||||
live=no
|
||||
while read -r line; do
|
||||
echo "$line" >> mats.out
|
||||
if [[ "$line" = matting* ]]; then
|
||||
echo "$line"
|
||||
live=yes
|
||||
elif [[ "$live" = no ]]; then
|
||||
echo "$line"
|
||||
fi
|
||||
done
|
||||
49
LOG
49
LOG
|
|
@ -1990,3 +1990,52 @@
|
|||
compress_io.c, new_io.c, externs.h,
|
||||
bytevector.ms, mats/Mf-base, root-experr*
|
||||
io.stex, objects.stex, release_notes.stex
|
||||
- fix fasl-read signature
|
||||
primdata.ss
|
||||
- console I/O on Windows now supports Unicode characters in the BMP
|
||||
expeditor.c, new-io.c, release_notes.stex
|
||||
- the collector now releases bignum temporaries in the collector
|
||||
rather than relocating them so we don't keep around huge bignum
|
||||
temporaries forever.
|
||||
gc.c
|
||||
- removed the presumably useless vector-handling code from load()
|
||||
which used to be required to handle fasl groups.
|
||||
scheme.c
|
||||
- object files are no longer compressed as a whole, and the parameter
|
||||
compile-compressed is no longer defined. instead, the individual
|
||||
fasl objects within an object file are compressed whenever the
|
||||
new parameter fasl-compressed is set to its default value, #t.
|
||||
this allows the fasl reader to seek past portions of an object
|
||||
file that are not of interest, i.e., visit-only code and data
|
||||
when "revisiting" an object file and revisit-only code and data
|
||||
when "visiting" an object file. the compressed portions are
|
||||
compressed using the format and level specified by the compress-format
|
||||
and compress-level parameters. the C-coded fasl reader and
|
||||
boot-file loader no longer handle compressed files; these are
|
||||
handled, less efficiently, by the Scheme entry point (fasl-read).
|
||||
a warning exception is raised the first time a program attempts
|
||||
to create or read a compressed fasl file.
|
||||
7.ss, s/Mf-base, back.ss, bytevector.ss, cmacros.ss, compile.ss,
|
||||
fasl-helpers.ss, fasl.ss, primdata.ss, strip.ss, syntax.ss,
|
||||
externs.h, fasl.c, gc.c, scheme.c, thread.c,
|
||||
mats/6.ms, mats/7.ms, mats/bytevector.ms, mats/misc.ms, patch*,
|
||||
root-experr*,
|
||||
intro.stex, use.stex, io.stex, system.stex,
|
||||
release_notes.stex
|
||||
- added begin wrappers around many of the Scheme source files that
|
||||
contained multiple expressions to cut down the number of top-level
|
||||
fasl objects and increase compressibility. also removed the
|
||||
string filenames for debugging at the start of each file that had
|
||||
one---these are best inserted universally by a modified compile-file
|
||||
during a debugging session when desired. also removed unnecessary
|
||||
top-level placeholder definitions for the assignments that follow.
|
||||
4.ss, 5_1.ss, 5_2.ss, 5_3.ss, 5_7.ss, 6.ss, 7.ss, bytevector.ss,
|
||||
cafe.ss, cback.ss, compile.ss, cp0.ss, cpcommonize.ss, cpletrec.ss,
|
||||
cpnanopass.ss, cprep.ss, cpvalid.ss, date.ss, engine.ss, enum.ss,
|
||||
env.ss, event.ss, exceptions.ss, expeditor.ss, fasl.ss, foreign.ss,
|
||||
format.ss, front.ss, ftype.ss, inspect.ss, interpret.ss, io.ss,
|
||||
library.ss, mathprims.ss, newhash.ss, pdhtml.ss, pretty.ss,
|
||||
prims.ss, primvars.ss, print.ss, read.ss, record.ss, reloc.ss,
|
||||
strnum.ss, syntax.ss, trace.ss
|
||||
- updated bullyx patches
|
||||
patch*
|
||||
|
|
|
|||
|
|
@ -77,7 +77,7 @@ static ptr s_ee_read_char(IBOOL blockp) {
|
|||
ptr tc;
|
||||
#endif /* PTHREADS */
|
||||
BOOL succ;
|
||||
static char buf[10];
|
||||
static wchar_t buf[10];
|
||||
static int bufidx = 0;
|
||||
static int buflen = 0;
|
||||
static int rptcnt = 0;
|
||||
|
|
@ -95,7 +95,7 @@ static ptr s_ee_read_char(IBOOL blockp) {
|
|||
if (!blockp) {
|
||||
DWORD NumberOfEvents;
|
||||
if (!GetNumberOfConsoleInputEvents(hStdin, &NumberOfEvents))
|
||||
S_error1("expeditor", "error getting console info: ~a",
|
||||
S_error1("expeditor", "error getting console input: ~a",
|
||||
S_LastErrorString());
|
||||
if (NumberOfEvents == 0) return Sfalse;
|
||||
}
|
||||
|
|
@ -104,13 +104,13 @@ static ptr s_ee_read_char(IBOOL blockp) {
|
|||
tc = get_thread_context();
|
||||
if (DISABLECOUNT(tc) == FIX(0)) {
|
||||
deactivate_thread(tc);
|
||||
succ = ReadConsoleInput(hStdin, irInBuf, 1, &cNumRead);
|
||||
succ = ReadConsoleInputW(hStdin, irInBuf, 1, &cNumRead);
|
||||
reactivate_thread(tc);
|
||||
} else {
|
||||
succ = ReadConsoleInput(hStdin, irInBuf, 1, &cNumRead);
|
||||
succ = ReadConsoleInputW(hStdin, irInBuf, 1, &cNumRead);
|
||||
}
|
||||
#else /* PTHREADS */
|
||||
succ = ReadConsoleInput(hStdin, irInBuf, 1, &cNumRead);
|
||||
succ = ReadConsoleInputW(hStdin, irInBuf, 1, &cNumRead);
|
||||
#endif /* PTHREADS */
|
||||
|
||||
|
||||
|
|
@ -125,10 +125,10 @@ static ptr s_ee_read_char(IBOOL blockp) {
|
|||
KEY_EVENT_RECORD ker = irInBuf[0].Event.KeyEvent;
|
||||
rptcnt = ker.wRepeatCount;
|
||||
if (ker.bKeyDown) {
|
||||
char c;
|
||||
wchar_t c;
|
||||
|
||||
if (c = ker.uChar.AsciiChar) {
|
||||
/* translate ^@ 2) and ^<space> to nul */
|
||||
if (c = ker.uChar.UnicodeChar) {
|
||||
/* translate ^<space> to nul */
|
||||
if (c == 0x20 && (ker.dwControlKeyState & (LEFT_CTRL_PRESSED|RIGHT_CTRL_PRESSED)))
|
||||
buf[0] = 0;
|
||||
else
|
||||
|
|
@ -508,12 +508,15 @@ static ptr s_ee_get_clipboard(void) {
|
|||
ptr x = S_G.null_string;
|
||||
|
||||
if (OpenClipboard((HWND)0)) {
|
||||
HANDLE h = GetClipboardData(CF_TEXT);
|
||||
|
||||
if (h != (HANDLE *)0) {
|
||||
char *s = (char *)GlobalLock(h);
|
||||
if (s != (char *)0) x = Sstring(s);
|
||||
GlobalUnlock(h);
|
||||
HANDLE h = GetClipboardData(CF_UNICODETEXT);
|
||||
if (h != NULL) {
|
||||
wchar_t *w = (wchar_t*)GlobalLock(h);
|
||||
if (w != NULL) {
|
||||
char *s = Swide_to_utf8(w);
|
||||
x = Sstring_utf8(s, -1);
|
||||
free(s);
|
||||
GlobalUnlock(h);
|
||||
}
|
||||
}
|
||||
CloseClipboard();
|
||||
}
|
||||
|
|
@ -522,8 +525,8 @@ static ptr s_ee_get_clipboard(void) {
|
|||
}
|
||||
|
||||
static void s_ee_write_char(wchar_t c) {
|
||||
if (c > 255) c = '?';
|
||||
putchar(c);
|
||||
DWORD n;
|
||||
WriteConsoleW(hStdout, &c, 1, &n, NULL);
|
||||
}
|
||||
|
||||
#else /* WIN32 */
|
||||
|
|
|
|||
|
|
@ -107,10 +107,9 @@ extern void S_phantom_bytevector_adjust PROTO((ptr ph, uptr new_sz));
|
|||
|
||||
/* fasl.c */
|
||||
extern void S_fasl_init PROTO((void));
|
||||
ptr S_fasl_read PROTO((ptr file, IBOOL gzflag, IFASLCODE situation, ptr path));
|
||||
ptr S_fasl_read PROTO((INT fd, IFASLCODE situation, ptr path));
|
||||
ptr S_bv_fasl_read PROTO((ptr bv, int ty, uptr offset, uptr len, ptr path));
|
||||
/* S_boot_read's f argument is really gzFile, but zlib.h is not included everywhere */
|
||||
ptr S_boot_read PROTO((glzFile file, const char *path));
|
||||
ptr S_boot_read PROTO((INT fd, const char *path));
|
||||
char *S_format_scheme_version PROTO((uptr n));
|
||||
char *S_lookup_machine_type PROTO((uptr n));
|
||||
extern void S_set_code_obj PROTO((char *who, IFASLCODE typ, ptr p, iptr n,
|
||||
|
|
|
|||
152
c/fasl.c
152
c/fasl.c
|
|
@ -18,15 +18,19 @@
|
|||
*
|
||||
* <fasl-file> -> <fasl-group>*
|
||||
*
|
||||
* <fasl-group> -> <fasl header><fasl-object>*
|
||||
* <fasl-group> -> <fasl-header><fasl-object>*
|
||||
*
|
||||
* <fasl-header> -> {header}\0\0\0chez<uptr version><uptr machine-type>(<bootfile-name> ...)
|
||||
*
|
||||
* <bootfile-name> -> <octet char>*
|
||||
*
|
||||
* <fasl-object> -> <situation>{fasl-size}<uptr size><fasl> # size is the size in bytes of the following <fasl>
|
||||
* <fasl-object> -> <situation><uptr size><pcfasl> # size is the size in bytes of <pcfasl>
|
||||
*
|
||||
* <situation> -> {visit}{revisit}{visit-revisit}
|
||||
* <situation> -> {visit} | {revisit} | {visit-revisit}
|
||||
*
|
||||
* <pcfasl> -> <compressed><uptr uncompressed-size><compressed fasl> | {uncompressed}<fasl>
|
||||
*
|
||||
* <compressed> -> {gzip} | {lz4}
|
||||
*
|
||||
* <fasl> -> {pair}<uptr n><fasl elt1>...<fasl eltn><fasl last-cdr>
|
||||
*
|
||||
|
|
@ -191,16 +195,15 @@
|
|||
#include NAN_INCLUDE
|
||||
#endif
|
||||
|
||||
#define UFFO_TYPE_GZ 1
|
||||
#define UFFO_TYPE_FD 2
|
||||
#define UFFO_TYPE_BV 3
|
||||
|
||||
/* we do our own buffering size gzgetc is slow */
|
||||
#define PREPARE_BYTEVECTOR(bv,n) {if (bv == Sfalse || Sbytevector_length(bv) < (n)) bv = S_bytevector(n);}
|
||||
|
||||
typedef struct unbufFaslFileObj {
|
||||
ptr path;
|
||||
INT type;
|
||||
INT fd;
|
||||
glzFile file;
|
||||
} *unbufFaslFile;
|
||||
|
||||
typedef struct faslFileObj {
|
||||
|
|
@ -214,7 +217,7 @@ typedef struct faslFileObj {
|
|||
/* locally defined functions */
|
||||
static INT uf_read PROTO((unbufFaslFile uf, octet *s, iptr n));
|
||||
static octet uf_bytein PROTO((unbufFaslFile uf));
|
||||
static uptr uf_uptrin PROTO((unbufFaslFile uf));
|
||||
static uptr uf_uptrin PROTO((unbufFaslFile uf, INT *bytes_consumed));
|
||||
static ptr fasl_entry PROTO((ptr tc, IFASLCODE situation, unbufFaslFile uf));
|
||||
static ptr bv_fasl_entry PROTO((ptr tc, ptr bv, IFASLCODE ty, uptr offset, uptr len, unbufFaslFile uf));
|
||||
static void fillFaslFile PROTO((faslFile f));
|
||||
|
|
@ -295,20 +298,15 @@ void S_fasl_init() {
|
|||
#endif
|
||||
}
|
||||
|
||||
ptr S_fasl_read(ptr file, IBOOL gzflag, IFASLCODE situation, ptr path) {
|
||||
ptr S_fasl_read(INT fd, IFASLCODE situation, ptr path) {
|
||||
ptr tc = get_thread_context();
|
||||
ptr x; struct unbufFaslFileObj uffo;
|
||||
|
||||
/* acquire mutex in case we modify code pages */
|
||||
tc_mutex_acquire()
|
||||
uffo.path = path;
|
||||
if (gzflag) {
|
||||
uffo.type = UFFO_TYPE_GZ;
|
||||
uffo.file = S_gzxfile_gzfile(file);
|
||||
} else {
|
||||
uffo.type = UFFO_TYPE_FD;
|
||||
uffo.fd = GET_FD(file);
|
||||
}
|
||||
uffo.type = UFFO_TYPE_FD;
|
||||
uffo.fd = fd;
|
||||
x = fasl_entry(tc, situation, &uffo);
|
||||
tc_mutex_release()
|
||||
return x;
|
||||
|
|
@ -327,18 +325,16 @@ ptr S_bv_fasl_read(ptr bv, int ty, uptr offset, uptr len, ptr path) {
|
|||
return x;
|
||||
}
|
||||
|
||||
ptr S_boot_read(glzFile file, const char *path) {
|
||||
ptr S_boot_read(INT fd, const char *path) {
|
||||
ptr tc = get_thread_context();
|
||||
struct unbufFaslFileObj uffo;
|
||||
|
||||
uffo.path = Sstring_utf8(path, -1);
|
||||
uffo.type = UFFO_TYPE_GZ;
|
||||
uffo.file = file;
|
||||
uffo.type = UFFO_TYPE_FD;
|
||||
uffo.fd = fd;
|
||||
return fasl_entry(tc, fasl_type_visit_revisit, &uffo);
|
||||
}
|
||||
|
||||
#define GZ_IO_SIZE_T unsigned int
|
||||
|
||||
#ifdef WIN32
|
||||
#define IO_SIZE_T unsigned int
|
||||
#else /* WIN32 */
|
||||
|
|
@ -346,28 +342,15 @@ ptr S_boot_read(glzFile file, const char *path) {
|
|||
#endif /* WIN32 */
|
||||
|
||||
static INT uf_read(unbufFaslFile uf, octet *s, iptr n) {
|
||||
iptr k; INT errnum;
|
||||
iptr k;
|
||||
while (n > 0) {
|
||||
uptr nx = n;
|
||||
|
||||
#if (iptr_bits > 32)
|
||||
if ((WIN32 || gzflag) && (unsigned int)nx != nx) nx = 0xffffffff;
|
||||
if (WIN32 && (unsigned int)nx != nx) nx = 0xffffffff;
|
||||
#endif
|
||||
|
||||
switch (uf->type) {
|
||||
case UFFO_TYPE_GZ:
|
||||
k = S_glzread(uf->file, s, (GZ_IO_SIZE_T)nx);
|
||||
if (k > 0)
|
||||
n -= k;
|
||||
else if (k == 0)
|
||||
return -1;
|
||||
else {
|
||||
S_glzerror(uf->file, &errnum);
|
||||
S_glzclearerr(uf->file);
|
||||
if (errnum != Z_ERRNO || errno != EINTR)
|
||||
S_error1("", "error reading from ~a", uf->path);
|
||||
}
|
||||
break;
|
||||
case UFFO_TYPE_FD:
|
||||
k = READ(uf->fd, s, (IO_SIZE_T)nx);
|
||||
if (k > 0)
|
||||
|
|
@ -394,11 +377,6 @@ int S_fasl_stream_read(void *stream, octet *dest, iptr n)
|
|||
|
||||
static void uf_skipbytes(unbufFaslFile uf, iptr n) {
|
||||
switch (uf->type) {
|
||||
case UFFO_TYPE_GZ:
|
||||
if (S_glzseek(uf->file, (long)n, SEEK_CUR) == -1) {
|
||||
S_error1("", "error seeking ~a", uf->path);
|
||||
}
|
||||
break;
|
||||
case UFFO_TYPE_FD:
|
||||
if (LSEEK(uf->fd, n, SEEK_CUR) == -1) {
|
||||
S_error1("", "error seeking ~a", uf->path);
|
||||
|
|
@ -414,12 +392,14 @@ static octet uf_bytein(unbufFaslFile uf) {
|
|||
return buf[0];
|
||||
}
|
||||
|
||||
static uptr uf_uptrin(unbufFaslFile uf) {
|
||||
static uptr uf_uptrin(unbufFaslFile uf, INT *bytes_consumed) {
|
||||
uptr n, m; octet k;
|
||||
|
||||
if (bytes_consumed) *bytes_consumed = 1;
|
||||
k = uf_bytein(uf);
|
||||
n = k & 0x7F;
|
||||
while (k & 0x80) {
|
||||
if (bytes_consumed) *bytes_consumed += 1;
|
||||
k = uf_bytein(uf);
|
||||
m = n << 7;
|
||||
if (m >> 7 != n) toolarge(uf->path);
|
||||
|
|
@ -454,7 +434,9 @@ char *S_lookup_machine_type(uptr n) {
|
|||
|
||||
static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf) {
|
||||
ptr x; ptr strbuf = S_G.null_string;
|
||||
octet tybuf[1]; IFASLCODE ty, fmt; iptr size;
|
||||
octet tybuf[1]; IFASLCODE ty; iptr size;
|
||||
/* gcc (GCC) 4.8.5 20150623 (Red Hat 4.8.5-28) co-locates buf and x if we put the declaration of buf down where we use it */
|
||||
octet buf[SBUFSIZ];
|
||||
|
||||
for (;;) {
|
||||
if (uf_read(uf, tybuf, 1) < 0) return Seof_object;
|
||||
|
|
@ -473,10 +455,10 @@ static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf) {
|
|||
uf_bytein(uf) != 'z')
|
||||
S_error1("", "malformed fasl-object header (missing magic word) found in ~a", uf->path);
|
||||
|
||||
if ((n = uf_uptrin(uf)) != scheme_version)
|
||||
if ((n = uf_uptrin(uf, (INT *)0)) != scheme_version)
|
||||
S_error2("", "incompatible fasl-object version ~a found in ~a", S_string(S_format_scheme_version(n), -1), uf->path);
|
||||
|
||||
if ((n = uf_uptrin(uf)) != machine_type_any && n != machine_type)
|
||||
if ((n = uf_uptrin(uf, (INT *)0)) != machine_type_any && n != machine_type)
|
||||
S_error2("", "incompatible fasl-object machine-type ~a found in ~a", S_string(S_lookup_machine_type(n), -1), uf->path);
|
||||
|
||||
if (uf_bytein(uf) != '(')
|
||||
|
|
@ -500,30 +482,66 @@ static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf) {
|
|||
return (ptr)0;
|
||||
}
|
||||
|
||||
fmt = uf_bytein(uf);
|
||||
if ((fmt != fasl_type_fasl_size) && (fmt != fasl_type_vfasl_size))
|
||||
S_error1("", "malformed fasl-object header (missing fasl-size) found in ~a", uf->path);
|
||||
|
||||
size = uf_uptrin(uf);
|
||||
size = uf_uptrin(uf, (INT *)0);
|
||||
|
||||
if (ty == situation || situation == fasl_type_visit_revisit || ty == fasl_type_visit_revisit) {
|
||||
struct faslFileObj ffo; octet buf[SBUFSIZ];
|
||||
struct faslFileObj ffo;
|
||||
ptr bv; IFASLCODE kind;
|
||||
|
||||
ffo.size = size;
|
||||
|
||||
if (fmt == fasl_type_vfasl_size) {
|
||||
if (S_vfasl_boot_mode) {
|
||||
/* compact every time, because running previously loaded
|
||||
boot code may have interned symbols, for example */
|
||||
S_vfasl_boot_mode = 1;
|
||||
Scompact_heap();
|
||||
ty = uf_bytein(uf);
|
||||
kind = uf_bytein(uf); /* fasl or vfasl */
|
||||
|
||||
if ((kind == fasl_type_vfasl) && S_vfasl_boot_mode) {
|
||||
/* compact every time, because running previously loaded
|
||||
boot code may have interned symbols, for example */
|
||||
Scompact_heap();
|
||||
}
|
||||
|
||||
switch (ty) {
|
||||
case fasl_type_gzip:
|
||||
case fasl_type_lz4: {
|
||||
ptr result; INT bytes_consumed;
|
||||
iptr dest_size = uf_uptrin(uf, &bytes_consumed);
|
||||
iptr src_size = size - (2 + bytes_consumed); /* adjust for u8 compression type, u8 fasl type, and uptr dest_size */
|
||||
|
||||
PREPARE_BYTEVECTOR(SRCBV(tc), src_size);
|
||||
PREPARE_BYTEVECTOR(DSTBV(tc), dest_size);
|
||||
if (uf_read(uf, &BVIT(SRCBV(tc),0), src_size) < 0)
|
||||
S_error1("", "unexpected eof in fasl file ~a", uf->path);
|
||||
result = S_bytevector_uncompress(DSTBV(tc), 0, dest_size, SRCBV(tc), 0, src_size,
|
||||
(ty == fasl_type_gzip ? COMPRESS_GZIP : COMPRESS_LZ4));
|
||||
if (result != FIX(dest_size)) {
|
||||
if (Sstringp(result)) S_error2("fasl-read", "~@?", result, SRCBV(tc));
|
||||
S_error3("fasl-read", "uncompressed size ~s for ~s is smaller than expected size ~s", result, SRCBV(tc), FIX(dest_size));
|
||||
}
|
||||
ffo.size = dest_size;
|
||||
ffo.next = ffo.buf = &BVIT(DSTBV(tc),0);
|
||||
ffo.end = &BVIT(DSTBV(tc),dest_size);
|
||||
ffo.uf = uf;
|
||||
bv = DSTBV(tc);
|
||||
break;
|
||||
}
|
||||
x = S_vfasl((ptr)0, uf, 0, ffo.size);
|
||||
} else {
|
||||
ffo.buf = buf;
|
||||
ffo.next = ffo.end = ffo.buf;
|
||||
ffo.uf = uf;
|
||||
faslin(tc, &x, S_G.null_vector, &strbuf, &ffo);
|
||||
case fasl_type_uncompressed: {
|
||||
ffo.size = size - 2; /* adjust for u8 compression type and u8 fasl type */
|
||||
ffo.next = ffo.end = ffo.buf = buf;
|
||||
bv = (ptr)0;
|
||||
ffo.uf = uf;
|
||||
break;
|
||||
}
|
||||
default:
|
||||
S_error2("", "malformed fasl-object header (missing possibly-compressed, got ~s) found in ~a", FIX(ty), uf->path);
|
||||
return (ptr)0;
|
||||
}
|
||||
switch (kind) {
|
||||
case fasl_type_fasl:
|
||||
faslin(tc, &x, S_G.null_vector, &strbuf, &ffo);
|
||||
break;
|
||||
case fasl_type_vfasl:
|
||||
x = S_vfasl(bv, uf, 0, ffo.size);
|
||||
break;
|
||||
default:
|
||||
S_error2("", "malformed fasl-object header (got ~s) found in ~a", FIX(ty), uf->path);
|
||||
return (ptr)0;
|
||||
}
|
||||
S_flush_instruction_cache(tc);
|
||||
return x;
|
||||
|
|
@ -537,15 +555,17 @@ static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, uptr offset, uptr len, unbufFas
|
|||
ptr x; ptr strbuf = S_G.null_string;
|
||||
struct faslFileObj ffo;
|
||||
|
||||
if (ty == fasl_type_vfasl_size) {
|
||||
if (ty == fasl_type_vfasl) {
|
||||
x = S_vfasl(bv, (ptr)0, offset, len);
|
||||
} else {
|
||||
} else if (ty == fasl_type_fasl) {
|
||||
ffo.size = len;
|
||||
ffo.next = ffo.buf = &BVIT(bv, offset);
|
||||
ffo.end = &BVIT(bv, offset + len);
|
||||
ffo.uf = uf;
|
||||
|
||||
faslin(tc, &x, S_G.null_vector, &strbuf, &ffo);
|
||||
} else {
|
||||
S_error1("", "bad entry type (got ~s)", FIX(ty));
|
||||
}
|
||||
|
||||
S_flush_instruction_cache(tc);
|
||||
|
|
|
|||
46
c/new-io.c
46
c/new-io.c
|
|
@ -413,6 +413,26 @@ ptr S_close_fd(ptr file, IBOOL gzflag) {
|
|||
|
||||
#ifdef WIN32
|
||||
#define IO_SIZE_T unsigned int
|
||||
static HANDLE hStdin = NULL;
|
||||
static iptr read_console(char* buf, unsigned size) {
|
||||
static char u8buf[1024];
|
||||
static int u8i = 0;
|
||||
static int u8n = 0;
|
||||
iptr n = 0;
|
||||
do {
|
||||
for (; size > 0 && u8n > 0; size--, u8n--, n++)
|
||||
*buf++ = u8buf[u8i++];
|
||||
if (n == 0 && size > 0) {
|
||||
wchar_t wbuf[256];
|
||||
DWORD wn;
|
||||
if (!ReadConsoleW(hStdin, wbuf, 256, &wn, NULL) || wn == 0)
|
||||
return 0;
|
||||
u8n = WideCharToMultiByte(CP_UTF8, 0, wbuf, wn, u8buf, 1024, NULL, NULL);
|
||||
u8i = 0;
|
||||
}
|
||||
} while (n == 0);
|
||||
return n;
|
||||
}
|
||||
#else /* WIN32 */
|
||||
#define IO_SIZE_T size_t
|
||||
#endif /* WIN32 */
|
||||
|
|
@ -434,17 +454,28 @@ ptr S_bytevector_read(ptr file, ptr bv, iptr start, iptr count, IBOOL gzflag) {
|
|||
|
||||
LOCKandDEACTIVATE(tc, bv)
|
||||
#ifdef WIN32
|
||||
if (!gzflag && fd == 0) {
|
||||
if (!gzflag && fd == 0 && hStdin != NULL) {
|
||||
DWORD error_code;
|
||||
SetConsoleCtrlHandler(NULL, TRUE);
|
||||
SetLastError(0);
|
||||
m = _read(0, &BVIT(bv,start), (IO_SIZE_T)count);
|
||||
m = read_console(&BVIT(bv,start), (IO_SIZE_T)count);
|
||||
error_code = GetLastError();
|
||||
SetConsoleCtrlHandler(NULL, FALSE);
|
||||
if (m == 0 && error_code == 0x3e3) {
|
||||
/* Guard against Windows calling the ConsoleCtrlHandler after we
|
||||
* turn it back on by waiting a bit. */
|
||||
Sleep(1);
|
||||
#ifdef PTHREADS
|
||||
/* threaded io.ss doesn't handle interrupts because
|
||||
* with-tc-mutex disables them, so bail out. */
|
||||
SetConsoleCtrlHandler(NULL, FALSE);
|
||||
REACTIVATEandUNLOCK(tc, bv)
|
||||
S_noncontinuable_interrupt();
|
||||
#else
|
||||
KEYBOARDINTERRUPTPENDING(tc) = Strue;
|
||||
SOMETHINGPENDING(tc) = Strue;
|
||||
#endif
|
||||
}
|
||||
SetConsoleCtrlHandler(NULL, FALSE);
|
||||
} else
|
||||
#endif /* WIN32 */
|
||||
{
|
||||
|
|
@ -770,10 +801,19 @@ void S_new_io_init() {
|
|||
S_set_symbol_value(S_intern((const unsigned char *)"$c-bufsiz"), Sinteger(SBUFSIZ));
|
||||
}
|
||||
#ifdef WIN32
|
||||
{ /* Get the console input handle for reading Unicode characters */
|
||||
HANDLE h;
|
||||
DWORD mode;
|
||||
if ((h = GetStdHandle(STD_INPUT_HANDLE)) != INVALID_HANDLE_VALUE
|
||||
&& GetConsoleMode(h, &mode))
|
||||
hStdin = h;
|
||||
}
|
||||
/* transcoder, if any, does its own cr, lf translations */
|
||||
_setmode(_fileno(stdin), O_BINARY);
|
||||
_setmode(_fileno(stdout), O_BINARY);
|
||||
_setmode(_fileno(stderr), O_BINARY);
|
||||
/* Set the console output to handle UTF-8 */
|
||||
SetConsoleOutputCP(CP_UTF8);
|
||||
#endif /* WIN32 */
|
||||
}
|
||||
|
||||
|
|
|
|||
228
c/scheme.c
228
c/scheme.c
|
|
@ -19,15 +19,17 @@
|
|||
#include <setjmp.h>
|
||||
#include <limits.h>
|
||||
#ifdef WIN32
|
||||
#include <io.h>
|
||||
#include <time.h>
|
||||
#else
|
||||
#include <sys/time.h>
|
||||
#endif
|
||||
#include <fcntl.h>
|
||||
#include <stddef.h>
|
||||
|
||||
extern iptr vfasl_load_time;
|
||||
extern iptr vfasl_fix_time;
|
||||
extern iptr vfasl_relocs;
|
||||
#ifndef O_BINARY
|
||||
#define O_BINARY 0
|
||||
#endif /* O_BINARY */
|
||||
|
||||
static INT boot_count;
|
||||
static IBOOL verbose;
|
||||
|
|
@ -44,7 +46,7 @@ static void idiot_checks PROTO((void));
|
|||
static INT run_script PROTO((const char *who, const char *scriptfile, INT argc, const char *argv[], IBOOL programp));
|
||||
|
||||
extern void scheme_include(void);
|
||||
|
||||
|
||||
static void main_init() {
|
||||
ptr tc = get_thread_context();
|
||||
ptr p;
|
||||
|
|
@ -560,7 +562,7 @@ static IBOOL next_path(path, name, ext, sp, dsp) char *path; const char *name, *
|
|||
/* BOOT FILES */
|
||||
|
||||
typedef struct {
|
||||
glzFile file;
|
||||
INT fd;
|
||||
char path[PATH_MAX];
|
||||
} boot_desc;
|
||||
|
||||
|
|
@ -568,8 +570,9 @@ typedef struct {
|
|||
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 octet get_u8 PROTO((INT fd));
|
||||
static uptr get_uptr PROTO((INT fd, uptr *pn));
|
||||
static INT get_string PROTO((INT fd, char *s, iptr max, INT *c));
|
||||
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));
|
||||
|
|
@ -579,12 +582,7 @@ static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IB
|
|||
uptr n = 0;
|
||||
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) {
|
||||
|
|
@ -594,22 +592,13 @@ static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IB
|
|||
|
||||
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
|
||||
if (fd == -1) {
|
||||
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. */
|
||||
fd = OPEN(expandedpath, O_BINARY|O_RDONLY, 0);
|
||||
free(expandedpath);
|
||||
}
|
||||
|
||||
if (!file) {
|
||||
if (fd == -1) {
|
||||
if (errorp) {
|
||||
fprintf(stderr, "cannot open boot file %s\n", path);
|
||||
S_abnormal_exit();
|
||||
|
|
@ -621,22 +610,22 @@ static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IB
|
|||
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 (get_u8(fd) != fasl_type_header ||
|
||||
get_u8(fd) != 0 ||
|
||||
get_u8(fd) != 0 ||
|
||||
get_u8(fd) != 0 ||
|
||||
get_u8(fd) != 'c' ||
|
||||
get_u8(fd) != 'h' ||
|
||||
get_u8(fd) != 'e' ||
|
||||
get_u8(fd) != 'z') {
|
||||
fprintf(stderr, "malformed fasl-object header in %s\n", path);
|
||||
S_abnormal_exit();
|
||||
}
|
||||
|
||||
/* check version */
|
||||
if (zget_uptr(file, &n) != 0) {
|
||||
if (get_uptr(fd, &n) != 0) {
|
||||
fprintf(stderr, "unexpected end of file on %s\n", path);
|
||||
S_glzclose(file);
|
||||
CLOSE(fd);
|
||||
S_abnormal_exit();
|
||||
}
|
||||
|
||||
|
|
@ -644,21 +633,21 @@ static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IB
|
|||
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);
|
||||
CLOSE(fd);
|
||||
S_abnormal_exit();
|
||||
}
|
||||
|
||||
/* check machine type */
|
||||
if (zget_uptr(file, &n) != 0) {
|
||||
if (get_uptr(fd, &n) != 0) {
|
||||
fprintf(stderr, "unexpected end of file on %s\n", path);
|
||||
S_glzclose(file);
|
||||
CLOSE(fd);
|
||||
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);
|
||||
CLOSE(fd);
|
||||
S_abnormal_exit();
|
||||
}
|
||||
} else {
|
||||
|
|
@ -679,17 +668,10 @@ static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IB
|
|||
}
|
||||
}
|
||||
|
||||
#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. */
|
||||
fd = OPEN(expandedpath, O_BINARY|O_RDONLY, 0);
|
||||
free(expandedpath);
|
||||
if (!file) {
|
||||
if (fd == -1) {
|
||||
if (verbose) fprintf(stderr, "trying %s...cannot open\n", path);
|
||||
continue;
|
||||
}
|
||||
|
|
@ -697,23 +679,23 @@ static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IB
|
|||
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 (get_u8(fd) != fasl_type_header ||
|
||||
get_u8(fd) != 0 ||
|
||||
get_u8(fd) != 0 ||
|
||||
get_u8(fd) != 0 ||
|
||||
get_u8(fd) != 'c' ||
|
||||
get_u8(fd) != 'h' ||
|
||||
get_u8(fd) != 'e' ||
|
||||
get_u8(fd) != 'z') {
|
||||
if (verbose) fprintf(stderr, "malformed fasl-object header in %s\n", path);
|
||||
S_glzclose(file);
|
||||
CLOSE(fd);
|
||||
continue;
|
||||
}
|
||||
|
||||
/* check version */
|
||||
if (zget_uptr(file, &n) != 0) {
|
||||
if (get_uptr(fd, &n) != 0) {
|
||||
if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path);
|
||||
S_glzclose(file);
|
||||
CLOSE(fd);
|
||||
continue;
|
||||
}
|
||||
|
||||
|
|
@ -723,14 +705,14 @@ static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IB
|
|||
/* 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);
|
||||
CLOSE(fd);
|
||||
continue;
|
||||
}
|
||||
|
||||
/* check machine type */
|
||||
if (zget_uptr(file, &n) != 0) {
|
||||
if (get_uptr(fd, &n) != 0) {
|
||||
if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path);
|
||||
S_glzclose(file);
|
||||
CLOSE(fd);
|
||||
continue;
|
||||
}
|
||||
|
||||
|
|
@ -738,7 +720,7 @@ static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IB
|
|||
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);
|
||||
CLOSE(fd);
|
||||
continue;
|
||||
}
|
||||
|
||||
|
|
@ -748,58 +730,61 @@ static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IB
|
|||
|
||||
if (verbose) fprintf(stderr, "version and machine type check\n");
|
||||
|
||||
if (S_glzgetc(file) != '(') { /* ) */
|
||||
if (get_u8(fd) != '(') { /* ) */
|
||||
fprintf(stderr, "malformed boot file %s\n", path);
|
||||
S_glzclose(file);
|
||||
CLOSE(fd);
|
||||
S_abnormal_exit();
|
||||
}
|
||||
|
||||
/* ( */
|
||||
if ((c = S_glzgetc(file)) == ')') {
|
||||
if ((c = get_u8(fd)) == ')') {
|
||||
if (boot_count != 0) {
|
||||
fprintf(stderr, "base boot file %s must come before other boot files\n", path);
|
||||
S_glzclose(file);
|
||||
CLOSE(fd);
|
||||
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) {
|
||||
if (get_string(fd, buf, PATH_MAX, &c) != 0) {
|
||||
fprintf(stderr, "unexpected end of file on %s\n", path);
|
||||
S_glzclose(file);
|
||||
CLOSE(fd);
|
||||
S_abnormal_exit();
|
||||
}
|
||||
if (find_boot(buf, ".boot", -1, 0)) break;
|
||||
if ((c = S_glzgetc(file)) == ')') {
|
||||
if (c == ')') {
|
||||
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, "cannot find subordinate boot file");
|
||||
if (LSEEK(fd, 0, SEEK_SET) != 0 || READ(fd, wastebuf, 8) != 8) { /* attempt to rewind and read magic number */
|
||||
fprintf(stderr, "---retry with verbose flag for more information\n");
|
||||
CLOSE(fd);
|
||||
S_abnormal_exit();
|
||||
}
|
||||
(void) get_uptr(fd, &n); /* version */
|
||||
(void) get_uptr(fd, &n); /* machine type */
|
||||
(void) get_u8(fd); /* open paren */
|
||||
c = get_u8(fd);
|
||||
for (sep = " "; ; sep = "or ") {
|
||||
if (c == ')') break;
|
||||
(void) get_string(fd, buf, PATH_MAX, &c);
|
||||
fprintf(stderr, "%s%s.boot ", sep, buf);
|
||||
}
|
||||
fprintf(stderr, "required by %s\n", path);
|
||||
S_glzclose(file);
|
||||
CLOSE(fd);
|
||||
S_abnormal_exit();
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/* skip to end of header */
|
||||
while ((c = S_glzgetc(file)) != ')') {
|
||||
while (c != ')') {
|
||||
if (c < 0) {
|
||||
fprintf(stderr, "malformed boot file %s\n", path);
|
||||
S_glzclose(file);
|
||||
CLOSE(fd);
|
||||
S_abnormal_exit();
|
||||
}
|
||||
c = get_u8(fd);
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -808,21 +793,27 @@ static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IB
|
|||
S_abnormal_exit();
|
||||
}
|
||||
|
||||
bd[boot_count].file = file;
|
||||
bd[boot_count].fd = fd;
|
||||
strcpy(bd[boot_count].path, path);
|
||||
boot_count += 1;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
static uptr zget_uptr(glzFile file, uptr *pn) {
|
||||
static octet get_u8(INT fd) {
|
||||
octet buf[1];
|
||||
if (READ(fd, &buf, 1) != 1) return -1;
|
||||
return buf[0];
|
||||
}
|
||||
|
||||
static uptr get_uptr(INT fd, uptr *pn) {
|
||||
uptr n, m; int c; octet k;
|
||||
|
||||
if ((c = S_glzgetc(file)) < 0) return -1;
|
||||
if ((c = get_u8(fd)) < 0) return -1;
|
||||
k = (octet)c;
|
||||
n = k & 0x7F;
|
||||
while (k & 128) {
|
||||
if ((c = S_glzgetc(file)) < 0) return -1;
|
||||
if ((c = get_u8(fd)) < 0) return -1;
|
||||
k = (octet)c;
|
||||
m = n << 7;
|
||||
if (m >> 7 != n) return -1;
|
||||
|
|
@ -832,19 +823,17 @@ static uptr zget_uptr(glzFile file, uptr *pn) {
|
|||
return 0;
|
||||
}
|
||||
|
||||
static INT zgetstr(file, s, max) glzFile file; char *s; iptr max; {
|
||||
ICHAR c;
|
||||
|
||||
static INT get_string(fd, s, max, c) INT fd; char *s; iptr max; INT *c; {
|
||||
while (max-- > 0) {
|
||||
if ((c = S_glzgetc(file)) < 0) return -1;
|
||||
if (c == ' ' || c == ')') {
|
||||
if (c == ')') S_glzungetc(c, file);
|
||||
if (*c < 0) return -1;
|
||||
if (*c == ' ' || *c == ')') {
|
||||
if (*c == ' ') *c = get_u8(fd);
|
||||
*s = 0;
|
||||
return 0;
|
||||
}
|
||||
*s++ = c;
|
||||
*s++ = *c;
|
||||
*c = get_u8(fd);
|
||||
}
|
||||
|
||||
return -1;
|
||||
}
|
||||
|
||||
|
|
@ -861,53 +850,52 @@ static int set_load_binary(iptr n) {
|
|||
return 0;
|
||||
}
|
||||
|
||||
static void boot_element(ptr tc, ptr x, iptr n) {
|
||||
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)) {
|
||||
/* sequence combination by vfasl, where vectors are not nested */
|
||||
iptr i;
|
||||
for (i = 0; i < Svector_length(x); i++)
|
||||
boot_element(tc, Svector_ref(x, i), n);
|
||||
}
|
||||
}
|
||||
|
||||
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);
|
||||
S_G.error_invoke_code_object = S_boot_read(bd[n].fd, 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);
|
||||
S_G.invoke_code_object = S_boot_read(bd[n].fd, 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);
|
||||
S_G.base_rtd = S_boot_read(bd[n].fd, 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 (i++ < LOADSKIP && S_boot_read(bd[n].fd, bd[n].path) != Seof_object);
|
||||
|
||||
while ((x = S_boot_read(bd[n].file, bd[n].path)) != Seof_object) {
|
||||
while ((x = S_boot_read(bd[n].fd, 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);
|
||||
}
|
||||
}
|
||||
}
|
||||
boot_element(tc, x, n);
|
||||
if (loadecho) {
|
||||
S_prin1(x);
|
||||
putchar('\n');
|
||||
|
|
@ -917,7 +905,7 @@ static void load(tc, n, base) ptr tc; iptr n; IBOOL base; {
|
|||
}
|
||||
|
||||
S_G.load_binary = Sfalse;
|
||||
S_glzclose(bd[n].file);
|
||||
CLOSE(bd[n].fd);
|
||||
}
|
||||
|
||||
/***************************************************************************/
|
||||
|
|
@ -1113,7 +1101,7 @@ extern void Sbuild_heap(kernel, custom_init) const char *kernel; void (*custom_i
|
|||
}
|
||||
}
|
||||
|
||||
S_vfasl_boot_mode = -1; /* to static generation after compacting initial */
|
||||
S_vfasl_boot_mode = 1; /* to static generation after compacting */
|
||||
|
||||
if (boot_count != 0) {
|
||||
INT i = 0;
|
||||
|
|
|
|||
|
|
@ -591,7 +591,7 @@ static void forward_signal_to_scheme PROTO((INT sig));
|
|||
sigprocmask(SIG_UNBLOCK,&set,(sigset_t *)0);\
|
||||
}
|
||||
|
||||
/* we buffer up to SIGNALQUEUESIZE - 1 unhandled signals, the start dropping them. */
|
||||
/* we buffer up to SIGNALQUEUESIZE - 1 unhandled signals, then start dropping them. */
|
||||
#define SIGNALQUEUESIZE 64
|
||||
static IBOOL scheme_signals_registered;
|
||||
|
||||
|
|
|
|||
|
|
@ -108,6 +108,8 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; {
|
|||
VIRTREG(tc, i) = FIX(0);
|
||||
}
|
||||
|
||||
DSTBV(tc) = SRCBV(tc) = Sfalse;
|
||||
|
||||
/* S_thread had better not do thread-local allocation */
|
||||
thread = S_thread(tc);
|
||||
|
||||
|
|
|
|||
|
|
@ -416,9 +416,9 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len)
|
|||
/* The symbol was already interned, so point to the existing one */
|
||||
INITSYMVAL(sym) = isym;
|
||||
if (S_vfasl_boot_mode > 0) {
|
||||
IGEN gen = SegInfo(addr_get_segment(isym))->generation;
|
||||
IGEN gen = SegInfo(ptr_get_segment(isym))->generation;
|
||||
if (gen < static_generation) {
|
||||
printf("new %d!\n", gen);
|
||||
printf("WARNING: vfasl symbol already interned, but at generation %d: %p ", gen, isym);
|
||||
S_prin1(isym);
|
||||
printf("\n");
|
||||
}
|
||||
|
|
|
|||
|
|
@ -97,7 +97,8 @@ Daniel, George Davidson, Matthew Flatt, Aziz Ghuloum, Bob Hieb, Andy Keep, and O
|
|||
contributed substantially to the development of {\ChezScheme}.
|
||||
{\ChezScheme}'s expression editor is based on a command-line editor for
|
||||
Scheme developed from 1989 through 1994 by C.~David Boyer.
|
||||
File compression is performed with the use of the zlib compression library
|
||||
File compression is performed with the use of the lz4 compression
|
||||
library developed by Yann Collet or the zlib compression library
|
||||
developed by Jean-loup Gailly and Mark Adler.
|
||||
Implementations of the list and vector sorting routines are based on
|
||||
Olin Shiver's opportunistic merge-sort algorithm and implementation.
|
||||
|
|
|
|||
34
csug/io.stex
34
csug/io.stex
|
|
@ -3390,6 +3390,15 @@ An exception is raised with condition-type \scheme{&assertion} if
|
|||
\var{obj} or any portion of \var{obj} has no external fasl representation,
|
||||
e.g., if \var{obj} is or contains a procedure.
|
||||
|
||||
The fasl representation of \var{obj} is compressed if the parameter
|
||||
\scheme{fasl-compressed}, described below, is set to \scheme{#t},
|
||||
its default value.
|
||||
For this reason, \var{binary-output-port} generally should not be opened
|
||||
with the compressed option.
|
||||
A warning is issued (an exception with condition type \scheme{&warning}
|
||||
is raised) on the first attempt to write fasl objects to or read
|
||||
fasl objects from a compressed file.
|
||||
|
||||
\schemedisplay
|
||||
(define bop (open-file-output-port "tmp.fsl"))
|
||||
(fasl-write '(a b c) bop)
|
||||
|
|
@ -3430,6 +3439,14 @@ corresponding to source code within an \scheme{eval-when} form with
|
|||
situation \scheme{load} or situations \scheme{visit} and \scheme{revisit})
|
||||
are never skipped.
|
||||
|
||||
\scheme{fasl-read} automatically decompresses the representation
|
||||
of each fasl object written in compressed format by \scheme{fasl-write}.
|
||||
Thus, \var{binary-input-port} generally should not be opened with
|
||||
the compressed option.
|
||||
A warning is issued (an exception with condition type \scheme{&warning}
|
||||
is raised) on the first attempt to write fasl objects to or read
|
||||
fasl objects from a compressed file.
|
||||
|
||||
\schemedisplay
|
||||
(define bop (open-file-output-port "tmp.fsl"))
|
||||
(fasl-write '(a b c) bop)
|
||||
|
|
@ -3441,6 +3458,23 @@ are never skipped.
|
|||
(close-port bip)
|
||||
\endschemedisplay
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
\formdef{fasl-compressed}{\categorythreadparameter}{fasl-compressed}
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
||||
\noindent
|
||||
When this parameter is set to its default value, \scheme{#t},
|
||||
\scheme{fasl-write} compresses the representation of each object
|
||||
as it writes it, often resulting in substantially smaller output
|
||||
but possibly taking more time to write and read.
|
||||
The compression format and level are determined by the
|
||||
\index{\scheme{compress-format}}\scheme{compress-format}
|
||||
and
|
||||
\index{\scheme{compress-level}}\scheme{compress-level}
|
||||
parameters.
|
||||
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
|
|
|
|||
|
|
@ -1251,11 +1251,6 @@ to 3 just while the remainder of file is compiled.
|
|||
\scheme{compile-script} is like \scheme{compile-file} but differs in
|
||||
that it copies the leading \scheme{#!} line from the
|
||||
source-file script into the object file.
|
||||
When the \scheme{#!} line is present it is uncompressed in the output
|
||||
file even when the parameter
|
||||
\index{\scheme{compile-compressed}}\scheme{compile-compressed} is
|
||||
set to \scheme{#t}, causing the remainder of the file to be compressed.
|
||||
This allows it to be interpreted properly by the operating system.
|
||||
|
||||
\scheme{compile-script} permits compiled script files to be created from
|
||||
source script to reduce script load time.
|
||||
|
|
@ -1518,9 +1513,6 @@ If \var{covop} is supplied, \scheme{compile-port} sends coverage information to
|
|||
The ports are closed automatically after compilation under the assumption
|
||||
the program that opens the ports and invokes \scheme{compile-port}
|
||||
will take care of closing the ports.
|
||||
Output will be compressed only if an output port is already set up to be
|
||||
compressed, e.g., if it was opened with the \scheme{compressed}
|
||||
file option.
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
|
|
@ -1556,9 +1548,6 @@ If \var{covop} is present, \var{compile-to-port} sends coverage information to
|
|||
The ports are not closed automatically after compilation under the assumption
|
||||
the program that opens the port and invokes \scheme{compile-to-port}
|
||||
will take care of closing the port.
|
||||
Output will be compressed only if an output port is already set up to be
|
||||
compressed, e.g., if it was opened with the \scheme{compressed}
|
||||
file option.
|
||||
|
||||
When \var{obj-list} contains a single list-structured element whose
|
||||
first-element is the symbol \scheme{top-level-program},
|
||||
|
|
@ -2781,25 +2770,6 @@ name by replacing the object-file extension (normally \scheme{.so})
|
|||
with \scheme{.wpo}, or adding the extension \scheme{.wpo} if the
|
||||
object filename has no extension or has the extension \scheme{.wpo}.
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
\formdef{compile-compressed}{\categorythreadparameter}{compile-compressed}
|
||||
\listlibraries
|
||||
\endentryheader
|
||||
|
||||
\noindent
|
||||
When this parameter is \scheme{#t}, the default, \scheme{compile-file},
|
||||
\scheme{compile-library}, \scheme{compile-script},
|
||||
\scheme{compile-program}, \scheme{compile-to-file},
|
||||
\scheme{compile-whole-program}, and \scheme{strip-fasl-file} compress
|
||||
the object files they create.
|
||||
The compression format and level are determined by the
|
||||
\index{\scheme{compress-format}}\scheme{compress-format}
|
||||
and
|
||||
\index{\scheme{compress-level}}\scheme{compress-level}
|
||||
parameters.
|
||||
|
||||
|
||||
%----------------------------------------------------------------------------
|
||||
\entryheader
|
||||
\formdef{compile-file-message}{\categorythreadparameter}{compile-file-message}
|
||||
|
|
@ -3397,10 +3367,9 @@ set of tests.
|
|||
One covin file is created for each object file, with the object-file
|
||||
extension replaced by the extension \scheme{.covin}.
|
||||
Each covin file contains the printed representation of a source table
|
||||
(Section~\ref{SECTSYNTAXSOURCETABLES}), compressed when the parameter
|
||||
\scheme{compile-compressed} is true, mapping each profiled source
|
||||
expression found during the compilation of the corresponding source
|
||||
file to a count of zero.
|
||||
(Section~\ref{SECTSYNTAXSOURCETABLES}), compressed using the compression
|
||||
format and level specified by \scheme{compress-format} and
|
||||
\scheme{compress-level}.
|
||||
This information can be read via
|
||||
\index{\scheme{get-source-table!}}\scheme{get-source-table!} and used
|
||||
as a universe of source expressions to identify source expressions
|
||||
|
|
|
|||
|
|
@ -1011,11 +1011,9 @@ command.
|
|||
\endschemedisplay
|
||||
|
||||
Scripts may be compiled using \index{\scheme{compile-script}}\scheme{compile-script}, which is like
|
||||
\scheme{compile-file} but differs in two ways:
|
||||
(1) it copies the leading \scheme{#!} line from the source-file script
|
||||
into the object file, and (2) when the \scheme{#!} line is present,
|
||||
it disables the default compression of the resulting file, which would
|
||||
otherwise prevent it from being recognized as a script file.
|
||||
\scheme{compile-file} but differs in that it
|
||||
copies the leading \scheme{#!} line from the source-file script
|
||||
into the object file.
|
||||
|
||||
If {\PetiteChezScheme} is installed, but not {\ChezScheme},
|
||||
\scheme{/usr/bin/scheme} may be
|
||||
|
|
|
|||
|
|
@ -62,7 +62,7 @@ InstallLZ4Target=
|
|||
# no changes should be needed below this point #
|
||||
###############################################################################
|
||||
|
||||
Version=csv9.5.3.32
|
||||
Version=csv9.5.3.33
|
||||
Include=boot/$m
|
||||
PetiteBoot=boot/$m/petite.boot
|
||||
SchemeBoot=boot/$m/scheme.boot
|
||||
|
|
|
|||
24
mats/6.ms
24
mats/6.ms
|
|
@ -887,6 +887,26 @@
|
|||
)
|
||||
|
||||
(mat fasl
|
||||
(error?
|
||||
(separate-eval '(let ([op (open-file-output-port "testfile.ss" (file-options compressed replace))])
|
||||
(fasl-write 3 op))))
|
||||
(error?
|
||||
(separate-eval '(let ([ip (open-file-input-port "testfile.ss" (file-options compressed))])
|
||||
(fasl-read ip))))
|
||||
(equal?
|
||||
(separate-eval '(with-exception-handler
|
||||
(lambda (c) (unless (warning? c) (raise-continuable c)))
|
||||
(lambda ()
|
||||
(let ([op (open-file-output-port "testfile.ss" (file-options compressed replace))])
|
||||
(fasl-write 3 op)))))
|
||||
"")
|
||||
(equal?
|
||||
(separate-eval `(with-exception-handler
|
||||
(lambda (c) (unless (warning? c) (raise-continuable c)))
|
||||
(lambda ()
|
||||
(let ([ip (open-file-input-port "testfile.ss" (file-options compressed))])
|
||||
(fasl-read ip)))))
|
||||
"3\n")
|
||||
(pretty-equal?
|
||||
(begin
|
||||
(call-with-port
|
||||
|
|
@ -926,10 +946,10 @@
|
|||
(open-file-input-port "testfile.ss")
|
||||
(get-stuff fasl-read))
|
||||
(call-with-port
|
||||
(open-file-input-port "testfile.ss" (file-options compressed))
|
||||
(open-file-input-port "testfile.ss" (file-options #;compressed))
|
||||
(get-stuff fasl-read))
|
||||
(call-with-port
|
||||
(open-file-input-port "testfile.ss" (file-options compressed))
|
||||
(open-file-input-port "testfile.ss" (file-options #;compressed))
|
||||
(get-stuff (lambda (p)
|
||||
(when (eof-object? (lookahead-u8 p)) (printf "done\n"))
|
||||
(fasl-read p))))
|
||||
|
|
|
|||
20
mats/7.ms
20
mats/7.ms
|
|
@ -47,7 +47,7 @@
|
|||
(set! aaaaa 0)
|
||||
(load "testfile.so")
|
||||
(eqv? aaaaa 7))
|
||||
(parameterize ([compile-compressed #f])
|
||||
(parameterize ([fasl-compressed #f])
|
||||
(printf "***** expect \"compile-file\" message:~%")
|
||||
(compile-file "testfile")
|
||||
(set! aaaaa 0)
|
||||
|
|
@ -62,7 +62,7 @@
|
|||
(load "testfile.so")
|
||||
(eqv? aaaaa -7))
|
||||
(let ((ip (open-input-string "(let ((x -3) (y -4)) (set! aaaaa (+ x y)))"))
|
||||
(op (open-file-output-port "testfile.so" (file-options replace compressed))))
|
||||
(op (open-file-output-port "testfile.so" (file-options replace #;compressed))))
|
||||
(compile-port ip op)
|
||||
(close-input-port ip)
|
||||
(close-port op)
|
||||
|
|
@ -98,7 +98,7 @@
|
|||
'replace)
|
||||
#t)
|
||||
(equal?
|
||||
(call-with-port (open-file-output-port "testfile.so" (file-options replace compressed))
|
||||
(call-with-port (open-file-output-port "testfile.so" (file-options replace #;compressed))
|
||||
(lambda (op)
|
||||
(parameterize ([compile-imported-libraries #t])
|
||||
(compile-to-port
|
||||
|
|
@ -861,19 +861,19 @@
|
|||
'(printf "qq => ~a\n" qq))
|
||||
(delete-file "testfile-mc-2a.so")
|
||||
(delete-file "testfile-mc-2.so")
|
||||
(display-string (separate-compile '(lambda (x) (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [compile-compressed #f]) (maybe-compile-program x))) 'mc-2))
|
||||
(display-string (separate-compile '(lambda (x) (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [fasl-compressed #f]) (maybe-compile-program x))) 'mc-2))
|
||||
#t)
|
||||
(begin
|
||||
(let ([p (open-file-input/output-port "testfile-mc-2a.so" (file-options no-create no-fail no-truncate))])
|
||||
(set-port-length! p 73)
|
||||
(close-port p))
|
||||
(display-string (separate-compile '(lambda (x) (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [compile-compressed #f] [import-notify #t]) (maybe-compile-program x))) 'mc-2))
|
||||
(display-string (separate-compile '(lambda (x) (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [fasl-compressed #f] [import-notify #t]) (maybe-compile-program x))) 'mc-2))
|
||||
#t)
|
||||
(begin
|
||||
(let ([p (open-file-input/output-port "testfile-mc-2.so" (file-options no-create no-fail no-truncate))])
|
||||
(set-port-length! p 87)
|
||||
(close-port p))
|
||||
(display-string (separate-compile '(lambda (x) (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [compile-compressed #f] [import-notify #t]) (maybe-compile-program x))) 'mc-2))
|
||||
(display-string (separate-compile '(lambda (x) (parameterize ([compile-file-message #f] [compile-imported-libraries #t] [fasl-compressed #f] [import-notify #t]) (maybe-compile-program x))) 'mc-2))
|
||||
#t)
|
||||
; make sure maybe-compile-file handles missing include files gracefully
|
||||
(begin
|
||||
|
|
@ -1174,10 +1174,10 @@
|
|||
(separate-compile
|
||||
`(lambda (x)
|
||||
(call-with-port
|
||||
(open-file-output-port (format "~a.so" x) (file-options compressed replace))
|
||||
(open-file-output-port (format "~a.so" x) (file-options #;compressed replace))
|
||||
(lambda (op)
|
||||
(call-with-port
|
||||
(open-file-output-port (format "~a.host" x) (file-options compressed replace))
|
||||
(open-file-output-port (format "~a.host" x) (file-options #;compressed replace))
|
||||
(lambda (hostop)
|
||||
(compile-to-port
|
||||
'((library (testfile-hop1)
|
||||
|
|
@ -5191,12 +5191,12 @@ evaluating module init
|
|||
(let ()
|
||||
(define fake-concatenate-object-files
|
||||
(lambda (outfn infn . infn*)
|
||||
(call-with-port (open-file-output-port outfn (file-options compressed replace))
|
||||
(call-with-port (open-file-output-port outfn (file-options #;compressed replace))
|
||||
(lambda (op)
|
||||
(for-each
|
||||
(lambda (infn)
|
||||
(put-bytevector op
|
||||
(call-with-port (open-file-input-port infn (file-options compressed)) get-bytevector-all)))
|
||||
(call-with-port (open-file-input-port infn (file-options #;compressed)) get-bytevector-all)))
|
||||
(cons infn infn*))))))
|
||||
(fake-concatenate-object-files "testfile-cof1fooP.so" "testfile-cof1foo.so" "testfile-cof1P.so")
|
||||
(fake-concatenate-object-files "testfile-cof1barB.so" "testfile-cof1bar.so" "testfile-cof1B.so"))
|
||||
|
|
|
|||
|
|
@ -21,6 +21,8 @@ mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj for
|
|||
|
||||
include Mf-base
|
||||
|
||||
export MSYS_NO_PATHCONV=1
|
||||
|
||||
foreign1.so: $(fsrc)
|
||||
cmd.exe /c "vs.bat amd64 && cl /DWIN32 /DX86_64 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv953.lib $(fsrc)"
|
||||
|
||||
|
|
|
|||
|
|
@ -21,6 +21,8 @@ mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj for
|
|||
|
||||
include Mf-base
|
||||
|
||||
export MSYS_NO_PATHCONV=1
|
||||
|
||||
foreign1.so: $(fsrc)
|
||||
cmd.exe /c "vs.bat x86 && cl /DWIN32 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv953.lib $(fsrc)"
|
||||
|
||||
|
|
|
|||
|
|
@ -21,6 +21,8 @@ mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj for
|
|||
|
||||
include Mf-base
|
||||
|
||||
export MSYS_NO_PATHCONV=1
|
||||
|
||||
foreign1.so: $(fsrc)
|
||||
cmd.exe /c "vs.bat amd64 && cl /DWIN32 /DX86_64 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv953.lib $(fsrc)"
|
||||
|
||||
|
|
|
|||
|
|
@ -21,6 +21,8 @@ mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj for
|
|||
|
||||
include Mf-base
|
||||
|
||||
export MSYS_NO_PATHCONV=1
|
||||
|
||||
foreign1.so: $(fsrc)
|
||||
cmd.exe /c "vs.bat x86 && cl /DWIN32 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv953.lib $(fsrc)"
|
||||
|
||||
|
|
|
|||
|
|
@ -11286,8 +11286,11 @@
|
|||
(error? (bytevector-uncompress "hello"))
|
||||
(begin
|
||||
(define (round-trip-bytevector-compress bv)
|
||||
(equal? (bytevector-uncompress (bytevector-compress bv))
|
||||
bv))
|
||||
(and
|
||||
(equal? (let ([c-bv (#%$bytevector-compress bv 0)])
|
||||
(#%$bytevector-uncompress c-bv 0 (bytevector-length c-bv) (bytevector-length bv) 0))
|
||||
bv)
|
||||
(equal? (bytevector-uncompress (bytevector-compress bv)) bv)))
|
||||
(round-trip-bytevector-compress (string->utf8 "hello")))
|
||||
(round-trip-bytevector-compress '#vu8())
|
||||
(round-trip-bytevector-compress (apply bytevector
|
||||
|
|
@ -11296,6 +11299,8 @@
|
|||
'()
|
||||
(cons (bitwise-and i 255)
|
||||
(loop (+ i 1)))))))
|
||||
(round-trip-bytevector-compress
|
||||
(call-with-port (open-file-input-port "prettytest.ss") get-bytevector-all))
|
||||
(error?
|
||||
;; Need at least 8 bytes for result size
|
||||
(bytevector-uncompress '#vu8()))
|
||||
|
|
|
|||
|
|
@ -1784,6 +1784,9 @@
|
|||
(pretty-print '(pretty-print (not (((inspect/object sff-1a-x) 'code) 'source))))
|
||||
(pretty-print '(pretty-print (= (length (profile-dump)) preexisting-entries))))
|
||||
'replace)
|
||||
(delete-file "testfile-sff-1a.so")
|
||||
(delete-file "testfile-sff-1b.so")
|
||||
(delete-file "testfile-sff-1c.so")
|
||||
(separate-compile
|
||||
'(lambda (x)
|
||||
(parameterize ([generate-inspector-information #t]
|
||||
|
|
|
|||
|
|
@ -4450,6 +4450,8 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
|
|||
6.mo:Expected error in mat pretty-print: "incorrect argument count in call (pretty-format (quote foo) (quote x) (quote x))".
|
||||
6.mo:Expected error in mat pretty-print: "pretty-format: 3 is not a symbol".
|
||||
6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)".
|
||||
6.mo:Expected error in mat fasl: "separate-eval: Warning in fasl-write: fasl file content is compressed internally; compressing the file (#<binary output port testfile.ss>) is redundant and can slow fasl writing and reading significantly
|
||||
6.mo:Expected error in mat fasl: "separate-eval: Warning in fasl-read: fasl file content is compressed internally; compressing the file (#<binary input port testfile.ss>) is redundant and can slow fasl writing and reading significantly
|
||||
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "~a~~~s" in call to format".
|
||||
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~a~a~a~s" in call to format".
|
||||
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "~a~~~s" in call to format at line 1, char 28 of testfile.ss".
|
||||
|
|
|
|||
|
|
@ -4100,6 +4100,8 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
|
|||
6.mo:Expected error in mat pretty-print: "incorrect argument count in call (pretty-format (quote foo) (quote x) (quote x))".
|
||||
6.mo:Expected error in mat pretty-print: "pretty-format: 3 is not a symbol".
|
||||
6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)".
|
||||
6.mo:Expected error in mat fasl: "separate-eval: Warning in fasl-write: fasl file content is compressed internally; compressing the file (#<binary output port testfile.ss>) is redundant and can slow fasl writing and reading significantly
|
||||
6.mo:Expected error in mat fasl: "separate-eval: Warning in fasl-read: fasl file content is compressed internally; compressing the file (#<binary input port testfile.ss>) is redundant and can slow fasl writing and reading significantly
|
||||
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "~a~~~s" in call to format".
|
||||
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~a~a~a~s" in call to format".
|
||||
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "~a~~~s" in call to format at line 1, char 28 of testfile.ss".
|
||||
|
|
|
|||
|
|
@ -129,7 +129,7 @@
|
|||
(lambda (start stop target)
|
||||
(let ([t (time-difference stop start)])
|
||||
(<= (abs (- (+ (time-second t) (* (time-nanosecond t) 1e-9)) target))
|
||||
0.1))))
|
||||
0.2))))
|
||||
(andmap procedure? (list $threads $fib $thread-check $time-in-range?)))
|
||||
($thread-check)
|
||||
(not (= (let ([n #f])
|
||||
|
|
|
|||
|
|
@ -112,6 +112,47 @@ unordered by default. An ordered guardian's objects are classified as
|
|||
inaccessible only when they are not reachable from the represetative
|
||||
of any inaccessible object in any other guardian.
|
||||
|
||||
\subsection{Unicode Basic Multilingual Plane console I/O in Windows (9.5.3)}
|
||||
|
||||
Console I/O now supports characters from the Unicode Basic
|
||||
Multilingual Plane in Windows. Windows consoles do not yet support the
|
||||
supplementary planes.
|
||||
|
||||
\subsection{Incompatible fasl-format and compiled-file compression changes (9.5.3)}
|
||||
|
||||
The fasl (fast-load) format now supports per-object compression.
|
||||
Whether the fasl writer actually performs compression is determined
|
||||
by the new \scheme{fasl-compressed} parameter, whose value defaults
|
||||
to \scheme{#t}.
|
||||
The compression format and level are determined by the
|
||||
\scheme{compress-format} and \scheme{compress-level}
|
||||
parameters.
|
||||
|
||||
The \scheme{compile-compressed} parameter has been eliminated.
|
||||
Since compiled files are written in fasl format, the
|
||||
\scheme{fasl-compressed} parameter also now controls whether compiled
|
||||
files are compressed.
|
||||
|
||||
Because individual portions of a fasl file are already compressed
|
||||
by default, attempting to compress a fasl file as a whole is often
|
||||
ineffective as well as inefficient both when writing and reading
|
||||
fasl objects.
|
||||
Thus, in particular, the \var{output-port} and \scheme{wpo-port}
|
||||
supplied to \scheme{compile-port} and \scheme{compile-to-port}
|
||||
should not be opened for compression.
|
||||
Similarly, external tools should not expect compiled files to be
|
||||
compressed as a whole, nor should they compress compiled files.
|
||||
|
||||
Because compression of fasl files was previously encouraged and is
|
||||
now discouraged, the first attempt to write fasl data to or read
|
||||
fasl data from a compressed port will cause a warning to be issued,
|
||||
i.e., an exception with condition type \scheme{&warning} to be
|
||||
raised.
|
||||
|
||||
The rationale for this change is to allow the fasl reader to seek
|
||||
past, without reading, portions of an object file that contain
|
||||
compile-time code at run time and run-time code at compile time.
|
||||
|
||||
\subsection{Bytevector compression and compression level (9.5.3)}
|
||||
|
||||
The procedure \scheme{bytevector-compress} now selects the level of
|
||||
|
|
|
|||
9
s/4.ss
9
s/4.ss
|
|
@ -1,4 +1,3 @@
|
|||
"4.ss"
|
||||
;;; 4.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -14,6 +13,7 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(define-who apply
|
||||
(let ()
|
||||
(define-syntax build-apply
|
||||
|
|
@ -55,12 +55,6 @@
|
|||
cl ...))])))
|
||||
(build-apply (x1 x2 x3 x4))))
|
||||
|
||||
(define ormap)
|
||||
(define andmap)
|
||||
(define map)
|
||||
(define for-each)
|
||||
(define fold-left)
|
||||
(define fold-right)
|
||||
(let ()
|
||||
(define length-error
|
||||
(lambda (who l1 l2)
|
||||
|
|
@ -440,3 +434,4 @@
|
|||
(unless (procedure? promise)
|
||||
($oops who "~s is not a procedure" promise))
|
||||
(promise)))
|
||||
)
|
||||
|
|
|
|||
3
s/5_1.ss
3
s/5_1.ss
|
|
@ -1,4 +1,3 @@
|
|||
"5_1.ss"
|
||||
;;; 5_1.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -16,6 +15,7 @@
|
|||
|
||||
;;; type and generic predicates
|
||||
|
||||
(begin
|
||||
(define boolean?
|
||||
(lambda (x)
|
||||
(or (eq? x #t) (eq? x #f))))
|
||||
|
|
@ -364,3 +364,4 @@
|
|||
(or (null? s*)
|
||||
(and (#3%symbol=? (car s*) s1)
|
||||
(f (cdr s*))))))]))
|
||||
)
|
||||
|
|
|
|||
4
s/5_2.ss
4
s/5_2.ss
|
|
@ -1,4 +1,3 @@
|
|||
"5_2.ss"
|
||||
;;; 5_2.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -16,6 +15,7 @@
|
|||
|
||||
;;; list and pair functions
|
||||
|
||||
(begin
|
||||
(define atom?
|
||||
(lambda (x)
|
||||
(not (pair? x))))
|
||||
|
|
@ -820,3 +820,5 @@
|
|||
(loop (cdr fast) slow #t))]
|
||||
[else
|
||||
(return bits)]))])))))))
|
||||
|
||||
)
|
||||
|
|
|
|||
3
s/5_3.ss
3
s/5_3.ss
|
|
@ -1,4 +1,3 @@
|
|||
"5_3.ss"
|
||||
;;; 5_3.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -24,6 +23,7 @@
|
|||
;;; dangerous: -0.0, +inf.0, -inf.0, 1e100, 1e-100, 0.1
|
||||
;;; safe: 0.0, +nan.0, 1.0, 2.0, 0.5
|
||||
|
||||
(begin
|
||||
(eval-when (compile)
|
||||
|
||||
(define-constant max-float-exponent
|
||||
|
|
@ -3281,3 +3281,4 @@
|
|||
[k (- end start) (- k w-1)])
|
||||
((<= k w-1) (logor (sll m^ k) ($fxreverse m k))))))))
|
||||
)))))))
|
||||
)
|
||||
|
|
|
|||
3
s/5_4.ss
3
s/5_4.ss
|
|
@ -1,4 +1,3 @@
|
|||
"5_4.ss"
|
||||
;;; 5_4.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -16,6 +15,7 @@
|
|||
|
||||
;;; character and string functions
|
||||
|
||||
(begin
|
||||
(define substring
|
||||
(lambda (s1 m n)
|
||||
(unless (string? s1)
|
||||
|
|
@ -849,3 +849,4 @@
|
|||
($compose ($decompose s #f))))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
|
|
|||
1
s/5_6.ss
1
s/5_6.ss
|
|
@ -1,4 +1,3 @@
|
|||
"5_6.ss"
|
||||
;;; 5_6.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
|
|||
8
s/5_7.ss
8
s/5_7.ss
|
|
@ -1,4 +1,3 @@
|
|||
"5_7.ss"
|
||||
;;; 5_7.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -16,6 +15,7 @@
|
|||
|
||||
;;; symbol functions
|
||||
|
||||
(begin
|
||||
(define property-list
|
||||
(lambda (s)
|
||||
(unless (symbol? s)
|
||||
|
|
@ -79,14 +79,10 @@
|
|||
(set-cdr! prev (cdr (cdr pl)))
|
||||
($set-system-property-list! s (cdr (cdr pl))))
|
||||
(rp (cdr (cdr pl)) (cdr pl)))))))
|
||||
)
|
||||
|
||||
(eval-when (compile) (optimize-level 3))
|
||||
|
||||
(define $gensym->pretty-name)
|
||||
(define gensym-prefix)
|
||||
(define gensym-count)
|
||||
(define gensym->unique-string)
|
||||
(define gensym)
|
||||
(let ([prefix "g"] [count 0])
|
||||
(define generate-unique-name
|
||||
; a-z must come first in alphabet. separator must not be in alphabet.
|
||||
|
|
|
|||
3
s/6.ss
3
s/6.ss
|
|
@ -1,4 +1,3 @@
|
|||
"6.ss"
|
||||
;;; 6.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -14,6 +13,7 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(define with-output-to-string
|
||||
(lambda (th)
|
||||
(unless (procedure? th)
|
||||
|
|
@ -502,3 +502,4 @@
|
|||
[else (loop (fx+ i 1))]))
|
||||
(substring s (skip-sep s base n) n)))))
|
||||
)
|
||||
)
|
||||
|
|
|
|||
115
s/7.ss
115
s/7.ss
|
|
@ -1,4 +1,3 @@
|
|||
"7.ss"
|
||||
;;; 7.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -16,6 +15,7 @@
|
|||
|
||||
;;; system operations
|
||||
|
||||
(begin
|
||||
(define scheme-start
|
||||
(make-parameter
|
||||
(lambda fns (for-each load fns) (new-cafe))
|
||||
|
|
@ -125,9 +125,16 @@
|
|||
(p path)
|
||||
(loop (cdr ls))))))))))
|
||||
|
||||
(set! $compressed-warning
|
||||
(let ([warned? #f])
|
||||
(lambda (who p)
|
||||
(unless warned?
|
||||
(set! warned? #t)
|
||||
(warningf who "fasl file content is compressed internally; compressing the file (~s) is redundant and can slow fasl writing and reading significantly" p)))))
|
||||
|
||||
(set-who! fasl-read
|
||||
(let ()
|
||||
(define $fasl-read (foreign-procedure "(cs)fasl_read" (ptr boolean fixnum ptr) ptr))
|
||||
(define $fasl-read (foreign-procedure "(cs)fasl_read" (int fixnum ptr) ptr))
|
||||
(define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr int uptr uptr ptr) ptr))
|
||||
(define (get-uptr p)
|
||||
(let ([k (get-u8 p)])
|
||||
|
|
@ -136,12 +143,19 @@
|
|||
(let ([k (get-u8 p)])
|
||||
(f k (logor (ash n 7) (fxand k #x7F))))
|
||||
n))))
|
||||
(define (malformed p) ($oops who "malformed fasl-object header found in ~s" p))
|
||||
(define (get-uptr/bytes p)
|
||||
(let ([k (get-u8 p)])
|
||||
(let f ([k k] [n (fxand k #x7F)] [bytes 1])
|
||||
(if (fxlogbit? 7 k)
|
||||
(let ([k (get-u8 p)])
|
||||
(f k (logor (ash n 7) (fxand k #x7F)) (fx+ bytes 1)))
|
||||
(values n bytes)))))
|
||||
(define (malformed p what) ($oops who "malformed fasl-object found in ~s (~a)" p what))
|
||||
(define (check-header p)
|
||||
(let ([bv (make-bytevector 8 (constant fasl-type-header))])
|
||||
(unless (and (eqv? (get-bytevector-n! p bv 1 7) 7)
|
||||
(bytevector=? bv (constant fasl-header)))
|
||||
(malformed p)))
|
||||
(malformed p "invalid header")))
|
||||
(let ([n (get-uptr p)])
|
||||
(unless (= n (constant scheme-version))
|
||||
($oops who "incompatible fasl-object version ~a found in ~s"
|
||||
|
|
@ -153,21 +167,36 @@
|
|||
(lambda (a)
|
||||
($oops who "incompatible fasl-object machine-type ~s found in ~s"
|
||||
(cdr a) p))]
|
||||
[else (malformed p)])))
|
||||
[else (malformed p "unrecognized machine type")])))
|
||||
(unless (and (eqv? (get-u8 p) (char->integer #\()) ;)
|
||||
(let f ()
|
||||
(let ([n (get-u8 p)])
|
||||
(and (not (eof-object? n)) ;(
|
||||
(or (eqv? n (char->integer #\))) (f))))))
|
||||
(malformed p)))
|
||||
(malformed p "invalid list of base boot files")))
|
||||
(define (call-with-bytevector-and-offset p len proc)
|
||||
;; fasl-read directly from the port buffer if it has `len`
|
||||
;; bytes ready, which works for a bytevector port; disable
|
||||
;; interrupt to make sure the bytes stay available (and
|
||||
;; `$bv-fasl-read` take tc-mutex, anyway)
|
||||
((with-interrupts-disabled
|
||||
(let ([idx (binary-port-input-index p)])
|
||||
(cond
|
||||
[(<= len (fx- (binary-port-input-size p) idx))
|
||||
(let ([result (proc (binary-port-input-buffer p) idx)])
|
||||
(set-binary-port-input-index! p (fx+ idx len))
|
||||
(lambda () result))]
|
||||
[else
|
||||
;; Call `get-bytevector-n`, etc. with interrupts reenabled
|
||||
(lambda ()
|
||||
(proc (get-bytevector-n p len) 0))])))))
|
||||
(define (go p situation)
|
||||
(define (go1)
|
||||
(if (and ($port-flags-set? p (constant port-flag-file))
|
||||
(or (not ($port-flags-set? p (constant port-flag-compressed)))
|
||||
(begin ($compressed-warning who p) #f))
|
||||
(eqv? (binary-port-input-count p) 0))
|
||||
($fasl-read ($port-info p)
|
||||
($port-flags-set? p (constant port-flag-compressed))
|
||||
situation
|
||||
(port-name p))
|
||||
($fasl-read ($port-info p) situation (port-name p))
|
||||
(let fasl-entry ()
|
||||
(let ([ty (get-u8 p)])
|
||||
(cond
|
||||
|
|
@ -181,37 +210,36 @@
|
|||
(go2 (eqv? situation (constant fasl-type-visit)))]
|
||||
[(eqv? ty (constant fasl-type-visit-revisit))
|
||||
(go2 #f)]
|
||||
[else (malformed p)])))))
|
||||
[else (malformed p "invalid situation")])))))
|
||||
(define (go2 skip?)
|
||||
(let ([ty (get-u8 p)])
|
||||
(cond
|
||||
[(or (eqv? ty (constant fasl-type-fasl-size))
|
||||
(eqv? ty (constant fasl-type-vfasl-size)))
|
||||
(let ([len (get-uptr p)])
|
||||
(if skip?
|
||||
(begin
|
||||
(if (and (port-has-port-position? p) (port-has-set-port-position!? p))
|
||||
(set-port-position! p (+ (port-position p) len))
|
||||
(get-bytevector-n p len))
|
||||
(go1))
|
||||
(let ([name (port-name p)])
|
||||
;; fasl-read directly from the port buffer if it has `len`
|
||||
;; bytes ready, which works for a bytevector port; disable
|
||||
;; interrupt to make sure the bytes stay available (and
|
||||
;; `$bv-fasl-read` takes tc-mutex, anyway)
|
||||
((with-interrupts-disabled
|
||||
(let ([idx (binary-port-input-index p)])
|
||||
(cond
|
||||
[(<= len (fx- (binary-port-input-size p) idx))
|
||||
(let ([result ($bv-fasl-read (binary-port-input-buffer p) ty
|
||||
idx len name)])
|
||||
(set-binary-port-input-index! p (+ idx len))
|
||||
(lambda () result))]
|
||||
[else
|
||||
;; Call `get-bytevector-n`, etc. with interrupts reenabled
|
||||
(lambda ()
|
||||
($bv-fasl-read (get-bytevector-n p len) ty 0 len name))])))))))]
|
||||
[else (malformed p)])))
|
||||
(let ([n (get-uptr p)])
|
||||
(if skip?
|
||||
(begin
|
||||
(if (and (port-has-port-position? p) (port-has-set-port-position!? p))
|
||||
(set-port-position! p (+ (port-position p) n))
|
||||
(get-bytevector-n p n))
|
||||
(go1))
|
||||
(let* ([compressed-flag (get-u8 p)]
|
||||
[kind (get-u8 p)])
|
||||
(cond
|
||||
[(or (eqv? compressed-flag (constant fasl-type-gzip)) (eqv? compressed-flag (constant fasl-type-lz4)))
|
||||
(let-values ([(dest-size dest-size-bytes) (get-uptr/bytes p)])
|
||||
(let* ([src-size (- n 2 dest-size-bytes)]
|
||||
[bv (call-with-bytevector-and-offset
|
||||
p src-size
|
||||
(lambda (bv offset)
|
||||
($bytevector-uncompress bv offset src-size dest-size
|
||||
(if (eqv? compressed-flag (constant fasl-type-gzip))
|
||||
(constant COMPRESS-GZIP)
|
||||
(constant COMPRESS-LZ4)))))])
|
||||
($bv-fasl-read bv kind 0 dest-size (port-name p))))]
|
||||
[(eqv? compressed-flag (constant fasl-type-uncompressed))
|
||||
(let ([len (- n 2)])
|
||||
(call-with-bytevector-and-offset
|
||||
p len
|
||||
(lambda (bv offset)
|
||||
($bv-fasl-read bv kind offset len (port-name p)))))]
|
||||
[else (malformed p "invalid compression")])))))
|
||||
(unless (and (input-port? p) (binary-port? p))
|
||||
($oops who "~s is not a binary input port" p))
|
||||
(go1))
|
||||
|
|
@ -270,7 +298,7 @@
|
|||
[(program-info? x) ($install-program-desc x)]
|
||||
[(recompile-info? x) (void)]
|
||||
[(Lexpand? x) ($interpret-backend x situation for-import? importer fn)]
|
||||
; NB: this is here to support the #t inserted by compile-file-help2 after header information
|
||||
; NB: this is here to support the #t inserted by compile-file-help2 after header information
|
||||
[(eq? x #t) (void)]
|
||||
;; for vfasl combinations:
|
||||
[(vector? x) (run-vector x)]
|
||||
|
|
@ -293,15 +321,11 @@
|
|||
fp
|
||||
(loop fp))))))
|
||||
(begin (set-port-position! ip start-pos) 0)))])
|
||||
(port-file-compressed! ip)
|
||||
(if ($compiled-file-header? ip)
|
||||
(begin
|
||||
(do-load-binary who fn ip situation for-import? importer)
|
||||
(close-port ip))
|
||||
(begin
|
||||
(when ($port-flags-set? ip (constant port-flag-compressed))
|
||||
(close-port ip)
|
||||
($oops who "missing header for compiled file ~s" fn))
|
||||
(unless ksrc
|
||||
(close-port ip)
|
||||
($oops who "~a is not a compiled file" fn))
|
||||
|
|
@ -1563,3 +1587,4 @@
|
|||
[() (print-pass-stats #f ($pass-stats))]
|
||||
[(key) (print-pass-stats key ($pass-stats))]
|
||||
[(key psl*) (print-pass-stats key psl*)]))))
|
||||
)
|
||||
|
|
|
|||
28
s/Mf-base
28
s/Mf-base
|
|
@ -33,8 +33,8 @@ i = f
|
|||
# cp0 determines the number of cp0 (source optimizer) iterations run
|
||||
cp0 = 2
|
||||
|
||||
# cc determines whether compiled files are compressed
|
||||
cc = t
|
||||
# fc determines whether fasl objects are compressed
|
||||
fc = t
|
||||
|
||||
# xf determines the compression foramt
|
||||
xf = (compress-format)
|
||||
|
|
@ -228,7 +228,7 @@ clean: profileclean
|
|||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(compile-compressed #$(cc))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(when #$p (compile-profile (quote source)))'\
|
||||
|
|
@ -257,7 +257,7 @@ clean: profileclean
|
|||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(compile-compressed #$(cc))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(when #$p (compile-profile (quote source)))'\
|
||||
|
|
@ -289,7 +289,7 @@ clean: profileclean
|
|||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(compile-compressed #$(cc))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(generate-inspector-information #$i)'\
|
||||
|
|
@ -302,7 +302,7 @@ clean: profileclean
|
|||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(compile-compressed #$(cc))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(when #$(xp) (compile-profile (quote source)))'\
|
||||
|
|
@ -378,7 +378,7 @@ cmacros.so: cmacros.ss machine.def layout.ss
|
|||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(compile-compressed #$(cc))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(generate-inspector-information #$i)'\
|
||||
|
|
@ -393,7 +393,7 @@ priminfo.so: priminfo.ss primdata.ss cmacros.so
|
|||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(compile-compressed #$(cc))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(generate-inspector-information #$i)'\
|
||||
|
|
@ -409,7 +409,7 @@ mkheader.so: mkheader.ss cmacros.so primvars.so env.so
|
|||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(compile-compressed #$(cc))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(generate-inspector-information #$i)'\
|
||||
|
|
@ -424,7 +424,7 @@ mkgc.so: mkgc.ss mkheader.so cmacros.so primvars.so env.so
|
|||
'(optimize-level 0)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(compile-compressed #$(cc))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(generate-inspector-information #$i)'\
|
||||
|
|
@ -439,7 +439,7 @@ nanopass.so: $(shell echo ../nanopass/nanopass/*) ../nanopass/nanopass.ss
|
|||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(compile-compressed #$(cc))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(generate-inspector-information #$i)'\
|
||||
|
|
@ -465,7 +465,7 @@ script.all makescript:
|
|||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(compile-compressed #$(cc))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(when #$p (compile-profile (quote source)))'\
|
||||
|
|
@ -508,7 +508,7 @@ script-static.all:
|
|||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(compile-compressed #$(cc))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(when #$p (compile-profile (quote source)))'\
|
||||
|
|
@ -537,7 +537,7 @@ script-dynamic.all:
|
|||
'(optimize-level $o)'\
|
||||
'(debug-level $d)'\
|
||||
'(commonization-level $(cl))'\
|
||||
'(compile-compressed #$(cc))'\
|
||||
'(fasl-compressed #$(fc))'\
|
||||
'(compress-format $(xf))'\
|
||||
'(compress-level $(xl))'\
|
||||
'(when #$p (compile-profile (quote source)))'\
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"back.ss"
|
||||
;;; back.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -14,6 +13,7 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(define-who trace-output-port
|
||||
($make-thread-parameter
|
||||
(console-output-port)
|
||||
|
|
@ -155,7 +155,7 @@
|
|||
($oops who "~s is not a procedure" x))
|
||||
x)))
|
||||
|
||||
(define compile-compressed
|
||||
(define fasl-compressed
|
||||
($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
(define compile-file-message
|
||||
|
|
@ -226,3 +226,4 @@
|
|||
($make-thread-parameter #t (lambda (x) (and x #t))))
|
||||
|
||||
(set! $scheme-version (string->symbol ($format-scheme-version (constant scheme-version))))
|
||||
)
|
||||
|
|
|
|||
100
s/bytevector.ss
100
s/bytevector.ss
|
|
@ -1,4 +1,3 @@
|
|||
"bytevector.ss"
|
||||
;;; bytevector.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -1464,62 +1463,59 @@
|
|||
;; Always big-endian, so that compressed data is portable.
|
||||
(define uncompressed-length-endianness (endianness big))
|
||||
|
||||
(define $bytevector-compress-size
|
||||
(define fp-bytevector-compress-size
|
||||
(foreign-procedure "(cs)bytevector_compress_size" (iptr int) uptr))
|
||||
(define $bytevector-compress
|
||||
(define fp-bytevector-compress
|
||||
(foreign-procedure "(cs)bytevector_compress" (scheme-object iptr iptr scheme-object iptr iptr int) scheme-object))
|
||||
(define $bytevector-uncompress
|
||||
(define fp-bytevector-uncompress
|
||||
(foreign-procedure "(cs)bytevector_uncompress" (scheme-object iptr iptr scheme-object iptr iptr int) scheme-object))
|
||||
|
||||
(set-who! bytevector-compress
|
||||
(lambda (bv)
|
||||
(unless (bytevector? bv) (not-a-bytevector who bv))
|
||||
(let* ([fmt ($tc-field 'compress-format ($tc))]
|
||||
[dest-max-len ($bytevector-compress-size (bytevector-length bv) fmt)]
|
||||
[dest-alloc-len (min (+ dest-max-len uncompressed-length-length)
|
||||
;; In the unlikely event of a non-fixnum requested size...
|
||||
(constant maximum-bytevector-length))]
|
||||
(let ()
|
||||
(define (compress who bv fmt offset)
|
||||
(let* ([dest-max-len (fp-bytevector-compress-size (bytevector-length bv) fmt)]
|
||||
[dest-alloc-len (min (+ dest-max-len offset) (constant maximum-bytevector-length))]
|
||||
[dest-bv (make-bytevector dest-alloc-len)])
|
||||
(let ([r ($bytevector-compress dest-bv
|
||||
uncompressed-length-length
|
||||
(fx- dest-alloc-len uncompressed-length-length)
|
||||
bv
|
||||
0
|
||||
(bytevector-length bv)
|
||||
fmt)])
|
||||
(cond
|
||||
[(string? r)
|
||||
($oops who r bv)]
|
||||
[else
|
||||
(let ([tag (bitwise-ior
|
||||
(bitwise-arithmetic-shift-left (bytevector-length bv) (constant COMPRESS-FORMAT-BITS))
|
||||
fmt)])
|
||||
($bytevector-u64-set! dest-bv 0 tag uncompressed-length-endianness who)
|
||||
(bytevector-truncate! dest-bv (fx+ r uncompressed-length-length)))])))))
|
||||
(let ([r (fp-bytevector-compress dest-bv offset (fx- dest-alloc-len offset) bv 0 (bytevector-length bv) fmt)])
|
||||
(if (string? r)
|
||||
($oops who r bv)
|
||||
(bytevector-truncate! dest-bv (fx+ r offset))))))
|
||||
|
||||
(set-who! bytevector-uncompress
|
||||
(lambda (bv)
|
||||
(unless (bytevector? bv) (not-a-bytevector who bv))
|
||||
(unless (>= (bytevector-length bv) uncompressed-length-length)
|
||||
($oops who "invalid data in source bytevector ~s" bv))
|
||||
(let* ([tag ($bytevector-u64-ref bv 0 uncompressed-length-endianness who)]
|
||||
[fmt (logand tag (fx- (fxsll 1 (constant COMPRESS-FORMAT-BITS)) 1))]
|
||||
[dest-length (bitwise-arithmetic-shift-right tag (constant COMPRESS-FORMAT-BITS))])
|
||||
(unless (and (fixnum? dest-length)
|
||||
($fxu< dest-length (constant maximum-bytevector-length)))
|
||||
($oops who "bytevector ~s claims invalid uncompressed size ~s" bv dest-length))
|
||||
(let* ([dest-bv (make-bytevector dest-length)]
|
||||
[r ($bytevector-uncompress dest-bv
|
||||
0
|
||||
dest-length
|
||||
bv
|
||||
uncompressed-length-length
|
||||
(fx- (bytevector-length bv) uncompressed-length-length)
|
||||
fmt)])
|
||||
(cond
|
||||
[(string? r) ($oops who r bv)]
|
||||
[(fx= r dest-length) dest-bv]
|
||||
[else
|
||||
($oops who "uncompressed size ~s for ~s is smaller than expected size ~a" r bv dest-length)]))))))
|
||||
(set-who! $bytevector-compress
|
||||
(lambda (bv fmt)
|
||||
(compress who bv fmt 0)))
|
||||
|
||||
(set-who! bytevector-compress
|
||||
(lambda (bv)
|
||||
(unless (bytevector? bv) (not-a-bytevector who bv))
|
||||
(let* ([fmt ($tc-field 'compress-format ($tc))]
|
||||
[dest-bv (compress who bv fmt uncompressed-length-length)])
|
||||
(let ([tag (bitwise-ior
|
||||
(bitwise-arithmetic-shift-left (bytevector-length bv) (constant COMPRESS-FORMAT-BITS))
|
||||
fmt)])
|
||||
($bytevector-u64-set! dest-bv 0 tag uncompressed-length-endianness who)
|
||||
dest-bv)))))
|
||||
|
||||
(let ()
|
||||
(define (uncompress who bv dest-length fmt offset src-length)
|
||||
(unless (and (fixnum? dest-length) ($fxu< dest-length (constant maximum-bytevector-length)))
|
||||
($oops who "bytevector ~s claims invalid uncompressed size ~s" bv dest-length))
|
||||
(let ([dest-bv (make-bytevector dest-length)])
|
||||
(let ([r (fp-bytevector-uncompress dest-bv 0 dest-length bv offset src-length fmt)])
|
||||
(cond
|
||||
[(string? r) ($oops who r bv)]
|
||||
[(fx= r dest-length) dest-bv]
|
||||
[else ($oops who "uncompressed size ~s for ~s is smaller than expected size ~s" r bv dest-length)]))))
|
||||
|
||||
(set-who! $bytevector-uncompress
|
||||
(lambda (bv offset len dest-length fmt)
|
||||
(uncompress who bv dest-length fmt offset len)))
|
||||
|
||||
(set-who! bytevector-uncompress
|
||||
(lambda (bv)
|
||||
(unless (bytevector? bv) (not-a-bytevector who bv))
|
||||
(unless (>= (bytevector-length bv) uncompressed-length-length) ($oops who "invalid data in source bytevector ~s" bv))
|
||||
(let* ([tag ($bytevector-u64-ref bv 0 uncompressed-length-endianness who)]
|
||||
[fmt (logand tag (fx- (fxsll 1 (constant COMPRESS-FORMAT-BITS)) 1))]
|
||||
[dest-length (bitwise-arithmetic-shift-right tag (constant COMPRESS-FORMAT-BITS))])
|
||||
(uncompress who bv dest-length fmt uncompressed-length-length (fx- (bytevector-length bv) uncompressed-length-length)))))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"cafe.ss"
|
||||
;;; cafe.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -14,6 +13,7 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(define default-prompt-and-read
|
||||
(lambda (n)
|
||||
(unless (and (integer? n) (>= n 0))
|
||||
|
|
@ -214,3 +214,4 @@ Type e to exit interrupt handler and continue
|
|||
(lambda ()
|
||||
(waiter ($cafe) eval))))))))]))))
|
||||
)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"cback.ss"
|
||||
;;; cback.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -14,5 +13,7 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(current-eval compile)
|
||||
(define $compiler-is-loaded? #t)
|
||||
)
|
||||
|
|
|
|||
21
s/cmacros.ss
21
s/cmacros.ss
|
|
@ -348,7 +348,7 @@
|
|||
;; ---------------------------------------------------------------------
|
||||
;; Version and machine types:
|
||||
|
||||
(define-constant scheme-version #x09050320)
|
||||
(define-constant scheme-version #x09050321)
|
||||
|
||||
(define-syntax define-machine-types
|
||||
(lambda (x)
|
||||
|
|
@ -470,8 +470,8 @@
|
|||
(define-constant fasl-type-graph-ref 18)
|
||||
(define-constant fasl-type-gensym 19)
|
||||
(define-constant fasl-type-exactnum 20)
|
||||
(define-constant fasl-type-vfasl-size 21)
|
||||
(define-constant fasl-type-fasl-size 22)
|
||||
(define-constant fasl-type-uninterned-symbol 21)
|
||||
(define-constant fasl-type-stencil-vector 22)
|
||||
(define-constant fasl-type-record 23)
|
||||
(define-constant fasl-type-rtd 24)
|
||||
(define-constant fasl-type-small-integer 25)
|
||||
|
|
@ -482,7 +482,7 @@
|
|||
(define-constant fasl-type-weak-pair 30)
|
||||
(define-constant fasl-type-eq-hashtable 31)
|
||||
(define-constant fasl-type-symbol-hashtable 32)
|
||||
; 33
|
||||
(define-constant fasl-type-phantom 33)
|
||||
(define-constant fasl-type-visit 34)
|
||||
(define-constant fasl-type-revisit 35)
|
||||
(define-constant fasl-type-visit-revisit 36)
|
||||
|
|
@ -493,11 +493,14 @@
|
|||
(define-constant fasl-type-immutable-bytevector 40)
|
||||
(define-constant fasl-type-immutable-box 41)
|
||||
|
||||
(define-constant fasl-type-stencil-vector 42)
|
||||
(define-constant fasl-type-begin 42)
|
||||
|
||||
(define-constant fasl-type-begin 43)
|
||||
(define-constant fasl-type-phantom 44)
|
||||
(define-constant fasl-type-uninterned-symbol 45)
|
||||
(define-constant fasl-type-uncompressed 43)
|
||||
(define-constant fasl-type-gzip 44)
|
||||
(define-constant fasl-type-lz4 45)
|
||||
|
||||
(define-constant fasl-type-fasl 100)
|
||||
(define-constant fasl-type-vfasl 101)
|
||||
|
||||
(define-constant fasl-type-terminator 127)
|
||||
|
||||
|
|
@ -1532,6 +1535,8 @@
|
|||
[U64 instr-counter]
|
||||
[U64 alloc-counter]
|
||||
[ptr parameters]
|
||||
[ptr DSTBV]
|
||||
[ptr SRCBV]
|
||||
[double fpregs (constant asm-fpreg-max)]))
|
||||
|
||||
(define tc-field-list
|
||||
|
|
|
|||
157
s/compile.ss
157
s/compile.ss
|
|
@ -1,4 +1,3 @@
|
|||
"compile.ss"
|
||||
;;; compile.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -16,14 +15,6 @@
|
|||
|
||||
;;; use fixnum arithmetic in code building & output routines
|
||||
|
||||
(define compile)
|
||||
(define $compile-backend)
|
||||
(define compile-file)
|
||||
(define $c-make-code)
|
||||
(define make-boot-header)
|
||||
(define make-boot-file)
|
||||
(define vfasl-convert-file)
|
||||
|
||||
(let ()
|
||||
(import (nanopass))
|
||||
(include "types.ss")
|
||||
|
|
@ -551,9 +542,9 @@
|
|||
[enable-error-source-expression (enable-error-source-expression)]
|
||||
[enable-unsafe-application (enable-unsafe-application)]
|
||||
[enable-type-recovery (enable-type-recovery)])
|
||||
(emit-header op (constant machine-type))
|
||||
(when hostop (emit-header hostop (host-machine-type)))
|
||||
(when wpoop (emit-header wpoop (host-machine-type)))
|
||||
(emit-header op (constant scheme-version) (constant machine-type))
|
||||
(when hostop (emit-header hostop (constant scheme-version) (host-machine-type)))
|
||||
(when wpoop (emit-header wpoop (constant scheme-version) (host-machine-type)))
|
||||
(let cfh0 ([n 1] [rrcinfo** '()] [rlpinfo** '()] [rfinal** '()])
|
||||
(let ([x0 ($pass-time 'read do-read)])
|
||||
(if (eof-object? x0)
|
||||
|
|
@ -807,40 +798,30 @@
|
|||
(close-port op))))
|
||||
|
||||
(define with-object-file
|
||||
(case-lambda
|
||||
[(who ofn p) (with-object-file who ofn #t p)]
|
||||
[(who ofn compressed-okay? p)
|
||||
(call-with-port/cleanup ofn
|
||||
($open-file-output-port who ofn
|
||||
(if (and compressed-okay? (compile-compressed))
|
||||
(file-options replace compressed)
|
||||
(file-options replace)))
|
||||
p)]))
|
||||
(lambda (who ofn p)
|
||||
(call-with-port/cleanup ofn
|
||||
($open-file-output-port who ofn
|
||||
(file-options replace))
|
||||
p)))
|
||||
|
||||
(define with-host-file
|
||||
(lambda (who ofn p)
|
||||
(if ofn
|
||||
(call-with-port/cleanup ofn
|
||||
($open-file-output-port who ofn
|
||||
(if (compile-compressed)
|
||||
(file-options replace compressed)
|
||||
(file-options replace)))
|
||||
(file-options replace))
|
||||
p)
|
||||
(p #f))))
|
||||
|
||||
(define with-wpo-file
|
||||
(case-lambda
|
||||
[(who ofn p) (with-wpo-file who ofn #t p)]
|
||||
[(who ofn compressed-okay? p)
|
||||
(if (generate-wpo-files)
|
||||
(let ([ofn (new-extension "wpo" ofn)])
|
||||
(call-with-port/cleanup ofn
|
||||
($open-file-output-port who ofn
|
||||
(if (and compressed-okay? (compile-compressed))
|
||||
(file-options replace compressed)
|
||||
(file-options replace)))
|
||||
p))
|
||||
(p #f))]))
|
||||
(lambda (who ofn p)
|
||||
(if (generate-wpo-files)
|
||||
(let ([ofn (new-extension "wpo" ofn)])
|
||||
(call-with-port/cleanup ofn
|
||||
($open-file-output-port who ofn
|
||||
(file-options replace))
|
||||
p))
|
||||
(p #f))))
|
||||
|
||||
(define with-coverage-file
|
||||
(lambda (who ofn p)
|
||||
|
|
@ -859,7 +840,7 @@
|
|||
|
||||
(set! $compile-host-library
|
||||
(lambda (who iofn)
|
||||
(let ([ip ($open-file-input-port who iofn (file-options compressed))])
|
||||
(let ([ip ($open-file-input-port who iofn)])
|
||||
(on-reset (close-port ip)
|
||||
(let loop ([rx1* '()] [rcinfo* '()] [rother* '()])
|
||||
(let ([x1 (fasl-read ip)])
|
||||
|
|
@ -870,7 +851,7 @@
|
|||
(unless (null? rother*) ($oops 'compile-library "unexpected value ~s read from file ~s that also contains ~s" (car rother*) iofn (car rx1*)))
|
||||
(with-object-file who iofn
|
||||
(lambda (op)
|
||||
(emit-header op (constant machine-type))
|
||||
(emit-header op (constant scheme-version) (constant machine-type))
|
||||
(let loop ([x1* (reverse rx1*)] [rrcinfo** (list rcinfo*)] [rlpinfo** '()] [rfinal** '()])
|
||||
(if (null? x1*)
|
||||
(compile-file-help2 op (reverse rrcinfo**) (reverse rlpinfo**) (reverse rfinal**))
|
||||
|
|
@ -950,7 +931,6 @@
|
|||
(loop)))))
|
||||
(get-bv))
|
||||
(begin (set-port-position! ip start-pos) #f)))])
|
||||
(port-file-compressed! ip)
|
||||
(if ($compiled-file-header? ip)
|
||||
(let loop ([rls '()])
|
||||
(let ([x (fasl-read ip)])
|
||||
|
|
@ -993,7 +973,7 @@
|
|||
[else ($oops who "unable to locate expanded library file for library ~s" path)])))
|
||||
(define read-binary-file
|
||||
(lambda (path fn libs-visible?)
|
||||
(call-with-port ($open-file-input-port who fn (file-options compressed))
|
||||
(call-with-port ($open-file-input-port who fn)
|
||||
(lambda (ip)
|
||||
(on-reset (close-port ip)
|
||||
(if ($compiled-file-header? ip)
|
||||
|
|
@ -1570,18 +1550,17 @@
|
|||
|
||||
(define finish-compile
|
||||
(lambda (who msg ifn ofn hash-bang-line x1)
|
||||
(with-object-file who ofn #f
|
||||
(with-object-file who ofn
|
||||
(lambda (op)
|
||||
(with-coverage-file who ofn
|
||||
(lambda (source-table)
|
||||
(when hash-bang-line (put-bytevector op hash-bang-line))
|
||||
(when (compile-compressed) (port-file-compressed! op))
|
||||
(parameterize ([$target-machine (constant machine-type-name)]
|
||||
; dummy sfd for block-profile optimization
|
||||
[$sfd (make-source-file-descriptor ifn #xc7 #xc7c7)]
|
||||
[$block-counter 0])
|
||||
(when source-table ($insert-profile-src! source-table x1))
|
||||
(emit-header op (constant machine-type))
|
||||
(emit-header op (constant scheme-version) (constant machine-type))
|
||||
(let-values ([(rcinfo* lpinfo* final*) (compile-file-help1 x1 msg)])
|
||||
(compile-file-help2 op (list rcinfo*) (list lpinfo*) (list final*))))))))))
|
||||
|
||||
|
|
@ -1590,7 +1569,7 @@
|
|||
(with-wpo-file who ofn
|
||||
(lambda (wpoop)
|
||||
(when wpoop
|
||||
(emit-header wpoop (host-machine-type))
|
||||
(emit-header wpoop (constant scheme-version) (host-machine-type))
|
||||
($with-fasl-target (host-machine-type)
|
||||
(lambda ()
|
||||
(parameterize ([$target-machine (machine-type)])
|
||||
|
|
@ -1732,7 +1711,7 @@
|
|||
(let ()
|
||||
(define emit-boot-header
|
||||
(lambda (op machine bootfiles)
|
||||
(emit-header op (constant machine-type) (map path-root (map path-last bootfiles)))
|
||||
(emit-header op (constant scheme-version) (constant machine-type) (map path-root (map path-last bootfiles)))
|
||||
(when (null? bootfiles)
|
||||
(parameterize ([$target-machine machine] [$sfd #f])
|
||||
(c-print-fasl ($np-boot-code 'error-invoke) op (constant fasl-type-visit-revisit))
|
||||
|
|
@ -1758,7 +1737,7 @@
|
|||
(emit-boot-header op machine bootfile*))
|
||||
(for-each
|
||||
(lambda (infn)
|
||||
(let ([ip ($open-file-input-port who infn (file-options compressed))])
|
||||
(let ([ip ($open-file-input-port who infn)])
|
||||
(on-reset (close-port ip)
|
||||
(if ($compiled-file-header? ip)
|
||||
(begin
|
||||
|
|
@ -1822,26 +1801,23 @@
|
|||
(let ([->vfasl (foreign-procedure "(cs)to_vfasl" (scheme-object) scheme-object)]
|
||||
[vfasl-can-combine? (foreign-procedure "(cs)vfasl_can_combinep" (scheme-object) boolean)])
|
||||
(lambda (in-file out-file bootfile*)
|
||||
(let ([op ($open-file-output-port who out-file
|
||||
(if (compile-compressed)
|
||||
(file-options replace compressed)
|
||||
(file-options replace)))])
|
||||
(let ([op ($open-file-output-port who out-file (file-options replace))])
|
||||
(on-reset (delete-file out-file #f)
|
||||
(on-reset (close-port op)
|
||||
(when bootfile*
|
||||
(emit-boot-header op (constant machine-type-name) bootfile*))
|
||||
(emit-header op (constant scheme-version) (constant machine-type))
|
||||
(let ([ip ($open-file-input-port who in-file (file-options compressed))])
|
||||
(on-reset (close-port ip)
|
||||
(let* ([write-out (lambda (x)
|
||||
(emit-header op (constant machine-type))
|
||||
(let ([bv (->vfasl x)])
|
||||
(put-u8 op (constant fasl-type-visit-revisit))
|
||||
(put-u8 op (constant fasl-type-vfasl-size))
|
||||
(put-uptr op (bytevector-length bv))
|
||||
(put-bytevector op bv)))]
|
||||
($write-fasl-bytevectors op (list bv) (bytevector-length bv)
|
||||
(constant fasl-type-visit-revisit) (constant fasl-type-vfasl))))]
|
||||
[write-out-accum (lambda (accum)
|
||||
(unless (null? accum)
|
||||
(write-out (list->vector (reverse accum)))))])
|
||||
(if (null? (cdr accum))
|
||||
(write-out (car accum))
|
||||
(write-out (list->vector (reverse accum))))))])
|
||||
(let loop ([accum '()])
|
||||
(let ([x (fasl-read ip)])
|
||||
(cond
|
||||
|
|
@ -1856,7 +1832,45 @@
|
|||
[else
|
||||
(loop (cons x accum))]))))
|
||||
(close-port ip)))
|
||||
(close-port op))))))))
|
||||
(close-port op)))))))
|
||||
)
|
||||
|
||||
(set-who! $write-fasl-bytevectors
|
||||
(lambda (p bv* size situation kind)
|
||||
(define (append-bvs bv*)
|
||||
(if (and (pair? bv*)
|
||||
(null? (cdr bv*)))
|
||||
(car bv*)
|
||||
(let f ([bv* bv*] [n 0])
|
||||
(if (null? bv*)
|
||||
(if (fixnum? n)
|
||||
(make-bytevector n)
|
||||
($oops 'fasl-write "fasl output is too large to compress"))
|
||||
(let ([bv1 (car bv*)])
|
||||
(let ([m (bytevector-length bv1)])
|
||||
(let ([bv2 (f (cdr bv*) (+ n m))])
|
||||
(bytevector-copy! bv1 0 bv2 n m)
|
||||
bv2)))))))
|
||||
(put-u8 p situation)
|
||||
(if (and (>= size 100) (fasl-compressed))
|
||||
(let* ([fmt ($tc-field 'compress-format ($tc))]
|
||||
[bv (append-bvs bv*)]
|
||||
[uncompressed-size-bv (call-with-bytevector-output-port (lambda (bvp) (put-uptr bvp (bytevector-length bv))))]
|
||||
[bv ($bytevector-compress bv fmt)])
|
||||
(put-uptr p (+ 2 (bytevector-length uncompressed-size-bv) (bytevector-length bv)))
|
||||
(put-u8 p
|
||||
(cond
|
||||
[(eqv? fmt (constant COMPRESS-GZIP)) (constant fasl-type-gzip)]
|
||||
[(eqv? fmt (constant COMPRESS-LZ4)) (constant fasl-type-lz4)]
|
||||
[else ($oops 'fasl-write "unexpected $compress-format value ~s" fmt)]))
|
||||
(put-u8 p kind)
|
||||
(put-bytevector p uncompressed-size-bv)
|
||||
(put-bytevector p bv))
|
||||
(begin
|
||||
(put-uptr p (+ size 2))
|
||||
(put-u8 p (constant fasl-type-uncompressed))
|
||||
(put-u8 p kind)
|
||||
(for-each (lambda (bv) (put-bytevector p bv)) bv*)))))
|
||||
|
||||
(let ()
|
||||
(define (libreq-hash x) (symbol-hash (libreq-uid x)))
|
||||
|
|
@ -1872,7 +1886,7 @@
|
|||
(let ([ip* (reverse rip*)])
|
||||
(with-object-file who outfn
|
||||
(lambda (op)
|
||||
(emit-header op (constant machine-type))
|
||||
(emit-header op (constant scheme-version) (constant machine-type))
|
||||
(c-print-fasl `(object ,(make-recompile-info
|
||||
(vector->list (hashtable-keys import-ht))
|
||||
(vector->list (hashtable-keys include-ht))))
|
||||
|
|
@ -1903,7 +1917,6 @@
|
|||
[ip ($open-file-input-port who fn)])
|
||||
(on-reset (close-port ip)
|
||||
;; NB: Does not currently support files beginning with a #! line. Add that here if desired.
|
||||
(port-file-compressed! ip)
|
||||
(unless ($compiled-file-header? ip) ($oops who "missing header for compiled file ~s" fn))
|
||||
(let ([rcinfo (fasl-read ip)])
|
||||
(unless (recompile-info? rcinfo) ($oops who "expected recompile info at start of ~s, found ~a" fn rcinfo))
|
||||
|
|
@ -1936,12 +1949,14 @@
|
|||
($oops who "~s is not a textual input port" ip))
|
||||
(unless (and (output-port? op) (binary-port? op))
|
||||
($oops who "~s is not a binary output port" op))
|
||||
(when ($port-flags-set? op (constant port-flag-compressed)) ($compressed-warning who op))
|
||||
(when sfd
|
||||
(unless (source-file-descriptor? sfd)
|
||||
($oops who "~s is not a source-file descriptor or #f" sfd)))
|
||||
(when wpoop
|
||||
(unless (and (output-port? wpoop) (binary-port? wpoop))
|
||||
($oops who "~s is not a binary output port or #f" wpoop)))
|
||||
($oops who "~s is not a binary output port or #f" wpoop))
|
||||
(when ($port-flags-set? wpoop (constant port-flag-compressed)) ($compressed-warning who wpoop)))
|
||||
(when covop
|
||||
(unless (and (output-port? covop) (textual-port? covop))
|
||||
($oops who "~s is not a textual output port or #f" covop)))
|
||||
|
|
@ -1950,7 +1965,8 @@
|
|||
($oops who "compiler for ~s is not loaded" machine))
|
||||
(when hostop
|
||||
(unless (and (output-port? hostop) (binary-port? hostop))
|
||||
($oops who "~s is not a binary output port or #f" hostop)))
|
||||
($oops who "~s is not a binary output port or #f" hostop))
|
||||
(when ($port-flags-set? hostop (constant port-flag-compressed)) ($compressed-warning who hostop)))
|
||||
(let ([source-table (and covop (make-source-table))])
|
||||
(let ([fp (and (port-has-port-position? ip)
|
||||
(let ([fp (port-position ip)])
|
||||
|
|
@ -1985,12 +2001,14 @@
|
|||
($oops who "~s is not a proper list" sexpr*))
|
||||
(unless (and (output-port? op) (binary-port? op))
|
||||
($oops who "~s is not a binary output port" op))
|
||||
(when ($port-flags-set? op (constant port-flag-compressed)) ($compressed-warning who op))
|
||||
(when sfd
|
||||
(unless (source-file-descriptor? sfd)
|
||||
($oops who "~s is not a source-file descriptor or #f" sfd)))
|
||||
(when wpoop
|
||||
(unless (and (output-port? wpoop) (binary-port? wpoop))
|
||||
($oops who "~s is not a binary output port or #f" wpoop)))
|
||||
($oops who "~s is not a binary output port or #f" wpoop))
|
||||
(when ($port-flags-set? wpoop (constant port-flag-compressed)) ($compressed-warning who wpoop)))
|
||||
(when covop
|
||||
(unless (and (output-port? covop) (textual-port? covop))
|
||||
($oops who "~s is not a textual output port or #f" covop)))
|
||||
|
|
@ -1999,7 +2017,8 @@
|
|||
($oops who "compiler for ~s is not loaded" machine))
|
||||
(when hostop
|
||||
(unless (and (output-port? hostop) (binary-port? hostop))
|
||||
($oops who "~s is not a binary output port or #f" hostop)))
|
||||
($oops who "~s is not a binary output port or #f" hostop))
|
||||
(when ($port-flags-set? hostop (constant port-flag-compressed)) ($compressed-warning who hostop)))
|
||||
(if (and (= (length sexpr*) 1) (pair? (car sexpr*)) (eq? (caar sexpr*) 'top-level-program))
|
||||
(let ([library-collector (make-parameter '())])
|
||||
(parameterize ([$require-libraries library-collector])
|
||||
|
|
@ -2080,10 +2099,10 @@
|
|||
(if (and (eqv? (read-char ip) #\#)
|
||||
(eqv? (read-char ip) #\!)
|
||||
(memv (lookahead-char ip) '(#\space #\/)))
|
||||
; copy #! line. open output file w/o compression
|
||||
(with-object-file who out #f
|
||||
; copy #! line
|
||||
(with-object-file who out
|
||||
(lambda (op)
|
||||
(with-wpo-file who out #f
|
||||
(with-wpo-file who out
|
||||
(lambda (wpoop)
|
||||
(with-coverage-file who out
|
||||
(lambda (source-table)
|
||||
|
|
@ -2104,12 +2123,8 @@
|
|||
(when wpoop (put-u8 wpoop n)))
|
||||
(let ([fp (+ fp 1)])
|
||||
(if (char=? c #\newline) fp (loop fp)))))])
|
||||
; compress remainder of file if requeseted
|
||||
(when (compile-compressed)
|
||||
(port-file-compressed! op)
|
||||
(when wpoop (port-file-compressed! wpoop)))
|
||||
(compile-file-help op #f wpoop source-table machine sfd ((if r6rs? $make-read-program $make-read) ip sfd fp) out))))))))
|
||||
; no #! line. open output file w/ compression, if so directed
|
||||
; no #! line
|
||||
(with-object-file who out
|
||||
(lambda (op)
|
||||
(set-port-position! ip start-pos)
|
||||
|
|
|
|||
1
s/cp0.ss
1
s/cp0.ss
|
|
@ -1,4 +1,3 @@
|
|||
"cp0"
|
||||
;;; cp0.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"cpcommonize.ss"
|
||||
;;; cpcommonize.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -14,6 +13,7 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(define-who commonization-level
|
||||
($make-thread-parameter
|
||||
0
|
||||
|
|
@ -576,3 +576,4 @@
|
|||
x
|
||||
(let ([worthwhile-size (expt 2 (fx- 10 level))])
|
||||
(cpcommonize2 (cpcommonize1 (cpcommonize0 x) worthwhile-size))))))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"cpletrec.ss"
|
||||
;;; cpletrec.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"cpnanopass.ss"
|
||||
;;; cpnanopass.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -18201,6 +18200,6 @@
|
|||
(set! $track-dynamic-closure-counts track-dynamic-closure-counts)
|
||||
|
||||
(set! $track-static-closure-counts track-static-closure-counts)
|
||||
)
|
||||
|
||||
(define $optimize-closures (make-parameter #t (lambda (x) (and x #t))))
|
||||
(set! $optimize-closures (make-parameter #t (lambda (x) (and x #t))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"cprep.ss"
|
||||
;;; cprep.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"cpvalid.ss"
|
||||
;;; cpvalid.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -17,10 +16,10 @@
|
|||
;;; see comments relating to both cpvalid and cpletrec at front of
|
||||
;;; cpletrec.ss
|
||||
|
||||
(begin
|
||||
(define undefined-variable-warnings
|
||||
($make-thread-parameter #f (lambda (x) (and x #t))))
|
||||
|
||||
(define $cpvalid)
|
||||
(let ()
|
||||
(import (nanopass))
|
||||
(include "base-lang.ss")
|
||||
|
|
@ -572,3 +571,4 @@
|
|||
(enable-unsafe-variable-reference))
|
||||
x
|
||||
(cpvalid x)))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"date.ss"
|
||||
;;; date.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"engine.ss"
|
||||
;;; engine.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -29,10 +28,6 @@
|
|||
;;; *timer* the saved timer interrupt handler
|
||||
|
||||
|
||||
(define make-engine)
|
||||
(define engine-block)
|
||||
(define engine-return)
|
||||
|
||||
(let ()
|
||||
|
||||
(define-threaded *exit*)
|
||||
|
|
|
|||
19
s/enum.ss
19
s/enum.ss
|
|
@ -1,4 +1,3 @@
|
|||
"enum.ss"
|
||||
;;; enum.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -27,24 +26,6 @@
|
|||
;; should throw an error if its argument is not a symbol. We have chosen to
|
||||
;; not include that check, but if the standard is updated, this may need to be changed.
|
||||
|
||||
(define $enum-set-members)
|
||||
|
||||
(define enum-set?)
|
||||
(define make-enumeration)
|
||||
(define enum-set-universe)
|
||||
(define enum-set-indexer)
|
||||
(define enum-set-constructor)
|
||||
(define enum-set->list)
|
||||
(define enum-set-member?)
|
||||
(define enum-set-subset?)
|
||||
(define enum-set=?)
|
||||
(define enum-set-union)
|
||||
(define enum-set-intersection)
|
||||
(define enum-set-difference)
|
||||
(define enum-set-complement)
|
||||
(define enum-set-projection)
|
||||
|
||||
|
||||
(let ()
|
||||
|
||||
;;;;;;;;
|
||||
|
|
|
|||
3
s/env.ss
3
s/env.ss
|
|
@ -1,4 +1,3 @@
|
|||
"env.ss"
|
||||
;;; env.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -14,5 +13,7 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
($make-base-modules)
|
||||
($make-rnrs-libraries)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"event.ss"
|
||||
;;; event.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -14,10 +13,6 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(define set-timer)
|
||||
(define enable-interrupts)
|
||||
(define disable-interrupts)
|
||||
|
||||
(let ()
|
||||
(define stop-event-timer
|
||||
(lambda ()
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"exceptions.ss"
|
||||
;;; exceptions.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -29,6 +28,7 @@ TODO:
|
|||
- deal with error? and warning? mats
|
||||
|#
|
||||
|
||||
(begin
|
||||
(let ()
|
||||
(define (warning-only? c)
|
||||
(and (warning? c) (not (serious-condition? c))))
|
||||
|
|
@ -739,3 +739,4 @@ TODO:
|
|||
(condition fwcond ($make-src-condition src start?))
|
||||
fwcond))))
|
||||
)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"expeditor.ss"
|
||||
;;; expeditor.ss
|
||||
;;; R. Kent Dybvig
|
||||
;;; August 2007
|
||||
|
|
|
|||
|
|
@ -135,8 +135,8 @@
|
|||
|
||||
(define emit-header
|
||||
(case-lambda
|
||||
[(p mtype) (emit-header p mtype '())]
|
||||
[(p mtype bootfiles)
|
||||
[(p version mtype) (emit-header p version mtype '())]
|
||||
[(p version mtype bootfiles)
|
||||
(define (put-str p s)
|
||||
(let ([n (string-length s)])
|
||||
(do ([i 0 (fx+ i 1)])
|
||||
|
|
@ -146,7 +146,7 @@
|
|||
($oops #f "cannot handle bootfile name character ~s whose integer code exceeds 255" c))
|
||||
(put-u8 p k)))))
|
||||
(put-bytevector p (constant fasl-header))
|
||||
(put-uptr p (constant scheme-version))
|
||||
(put-uptr p version)
|
||||
(put-uptr p mtype)
|
||||
(put-u8 p (char->integer #\()) ; )
|
||||
(let f ([bootfiles bootfiles] [sep? #f])
|
||||
|
|
|
|||
15
s/fasl.ss
15
s/fasl.ss
|
|
@ -1,4 +1,3 @@
|
|||
"fasl.ss"
|
||||
;;; fasl.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -659,10 +658,7 @@
|
|||
begins)))
|
||||
(proc p)
|
||||
(extractor))])
|
||||
(put-u8 p situation)
|
||||
(put-u8 p (constant fasl-type-fasl-size))
|
||||
(put-uptr p size)
|
||||
(for-each (lambda (bv) (put-bytevector p bv)) bv*))))
|
||||
($write-fasl-bytevectors p bv* size situation (constant fasl-type-fasl)))))
|
||||
|
||||
(define (extract-begins t)
|
||||
(let ([ht (table-hash t)])
|
||||
|
|
@ -700,7 +696,8 @@
|
|||
(lambda (x p)
|
||||
(unless (and (output-port? p) (binary-port? p))
|
||||
($oops who "~s is not a binary output port" p))
|
||||
(emit-header p (constant machine-type-any))
|
||||
(when ($port-flags-set? p (constant port-flag-compressed)) ($compressed-warning who p))
|
||||
(emit-header p (constant scheme-version) (constant machine-type-any))
|
||||
(fasl-one x p)))
|
||||
|
||||
(define-who fasl-file
|
||||
|
|
@ -716,7 +713,7 @@
|
|||
(delete-file out #f))
|
||||
(on-reset
|
||||
(close-port op)
|
||||
(emit-header op (constant machine-type-any))
|
||||
(emit-header op (constant scheme-version) (constant machine-type-any))
|
||||
(let fasl-loop ()
|
||||
(let ([x (read ip)])
|
||||
(unless (eof-object? x)
|
||||
|
|
@ -727,7 +724,7 @@
|
|||
|
||||
(define fasl-base-rtd
|
||||
(lambda (x p)
|
||||
(emit-header p (constant machine-type-any))
|
||||
(emit-header p (constant scheme-version) (constant machine-type-any))
|
||||
(let ([t (make-table)])
|
||||
(bld-graph x t #f 0 #t really-bld-record)
|
||||
(start p t (constant fasl-type-visit-revisit) (lambda (p) (wrf-graph x p t #f really-wrf-record))))))
|
||||
|
|
@ -750,7 +747,6 @@
|
|||
(set! $fasl-base-rtd (lambda (x p) ((target-fasl-base-rtd (fasl-target)) x p)))
|
||||
(set! fasl-write (lambda (x p) ((target-fasl-write (fasl-target)) x p)))
|
||||
(set! fasl-file (lambda (in out) ((target-fasl-file (fasl-target)) in out))))
|
||||
)
|
||||
|
||||
(when ($unbound-object? (#%$top-level-value '$capture-fasl-target))
|
||||
(let ([ht (make-hashtable values =)])
|
||||
|
|
@ -767,3 +763,4 @@
|
|||
[else ($oops who "unrecognized machine type ~s" mt)])))))
|
||||
|
||||
($capture-fasl-target (constant machine-type))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"foreign.ss"
|
||||
;;; foreign.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -14,10 +13,6 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
"foreign.ss"
|
||||
(define remove-foreign-entry)
|
||||
(define load-shared-object)
|
||||
(define foreign-entry?)
|
||||
(let ()
|
||||
(define $foreign-address-name
|
||||
(foreign-procedure "(cs)foreign_address_name" (void*)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"format.ss"
|
||||
;;; format.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"front.ss"
|
||||
;;; front.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -14,6 +13,7 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(define-who make-parameter
|
||||
(case-lambda
|
||||
[(init guard) (#2%make-parameter init guard)]
|
||||
|
|
@ -269,3 +269,4 @@
|
|||
[(x env-spec records? compiling-a-file outfn) ((current-expand) x env-spec records? compiling-a-file outfn)]))
|
||||
|
||||
(define $compiler-is-loaded? #f)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"ftype.ss"
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
|
|
@ -228,6 +227,7 @@ ftype operators:
|
|||
appropriate size for int and unsigned.
|
||||
|#
|
||||
|
||||
(begin
|
||||
(let ()
|
||||
(include "types.ss")
|
||||
(define-syntax rtd/fptr
|
||||
|
|
@ -2057,3 +2057,4 @@ ftype operators:
|
|||
(define-syntax ftype-spin-lock! (lambda (x) ($trans-ftype-locked-op! #'ftype-spin-lock! x #'$fptr-spin-lock!)))
|
||||
(define-syntax ftype-unlock! (lambda (x) ($trans-ftype-locked-op! #'ftype-unlock! x #'$fptr-unlock!)))
|
||||
(define-syntax ftype-set! (lambda (x) ($trans-ftype-set! x)))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"inspect.ss"
|
||||
;;; inspect.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -29,8 +28,7 @@
|
|||
; ---port info should include file descriptor, perhaps provide access
|
||||
; location in file
|
||||
|
||||
(define inspect)
|
||||
|
||||
(begin
|
||||
(let ()
|
||||
|
||||
(define-syntax make-dispatch-table
|
||||
|
|
@ -3074,3 +3072,5 @@
|
|||
(define object-counts (foreign-procedure "(cs)object_counts" () ptr))
|
||||
|
||||
(define object-backreferences (foreign-procedure "(cs)object_backreferences" () ptr))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"interpret.ss"
|
||||
;;; interpret.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -730,6 +729,6 @@
|
|||
(set! $interpret-backend
|
||||
(lambda (x situation for-import? importer ofn)
|
||||
(interpret-Lexpand x situation for-import? importer ofn (expand/optimize-output))))
|
||||
(current-eval interpret)
|
||||
)
|
||||
|
||||
(current-eval interpret)
|
||||
|
|
|
|||
3
s/io.ss
3
s/io.ss
|
|
@ -1,4 +1,3 @@
|
|||
"io.ss"
|
||||
;;; io.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -80,6 +79,7 @@ implementation notes:
|
|||
so we instead use an input-mode flag in the port header.
|
||||
|#
|
||||
|
||||
(begin
|
||||
(set-who! file-buffer-size
|
||||
($make-thread-parameter $c-bufsiz
|
||||
(lambda (x)
|
||||
|
|
@ -6307,3 +6307,4 @@ implementation notes:
|
|||
; utf8->string, etc., are in prims.ss, since they are used by
|
||||
; foreign procedures argument and return values
|
||||
)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -27,8 +27,6 @@
|
|||
(generate-interrupt-trap #f)
|
||||
($track-dynamic-closure-counts #f))
|
||||
|
||||
"library.ss (includes #<void> just before)"
|
||||
|
||||
(eval-when (compile)
|
||||
(define-syntax define-library-entry
|
||||
(lambda (x)
|
||||
|
|
@ -142,8 +140,6 @@
|
|||
;;; set up $nuate for overflow
|
||||
(define $nuate ($closure-code (call/1cc (lambda (k) k))))
|
||||
|
||||
"making closure counters!"
|
||||
|
||||
(set! #{raw-ref-count bhowt6w0coxl0s2y-1} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0])
|
||||
(set! #{raw-create-count bhowt6w0coxl0s2y-2} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0])
|
||||
(set! #{raw-alloc-count bhowt6w0coxl0s2y-3} '#[#{profile-counter b5vnnom9h4o4uny0-2} 0])
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"mathprims.ss"
|
||||
;;; mathprims.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -14,6 +13,7 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(eval-when (compile)
|
||||
|
||||
(define-syntax define-relop
|
||||
|
|
@ -771,3 +771,4 @@
|
|||
[else (noncflonum-error 'cfl-conjugate x)])))
|
||||
|
||||
)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -953,6 +953,11 @@
|
|||
(trace (tc-compress-format tc))
|
||||
(trace (tc-compress-level tc))
|
||||
(trace (tc-parameters tc))
|
||||
(case-mode
|
||||
[(sweep)
|
||||
(set! (tc-DSTBV tc) Sfalse)
|
||||
(set! (tc-SRCBV tc) Sfalse)]
|
||||
[else])
|
||||
(let* ([i : INT 0])
|
||||
(while
|
||||
:? (< i virtual_register_count)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"newhash.ss"
|
||||
;;; newhash.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"pdhtml.ss"
|
||||
;;; pdhtml.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -56,6 +55,7 @@
|
|||
;;; source annotation around the transformer output so that the source info for t>
|
||||
;;; when expression is transferred to the generated if expression.
|
||||
|
||||
(begin
|
||||
(let ()
|
||||
(include "types.ss")
|
||||
(module (make-tracker tracker-profile-ct)
|
||||
|
|
@ -1535,3 +1535,4 @@
|
|||
(unless (or (eq? color #f) (string? color)) ($oops who "~s is not a string or #f" color))
|
||||
color)))
|
||||
)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"pretty.ss"
|
||||
;;; pretty.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -24,6 +23,7 @@
|
|||
;;;; EXPORTED VARIABLES
|
||||
|
||||
;;; pretty tries to fit things within line length
|
||||
(begin
|
||||
(define pretty-line-length
|
||||
($make-thread-parameter
|
||||
75
|
||||
|
|
@ -797,3 +797,4 @@
|
|||
(wr (prty-obj x) p)
|
||||
(write-char #\> p)))
|
||||
)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -921,7 +921,6 @@
|
|||
(command-line [sig [() -> (list)] [(sub-list) -> (void)]] [flags]) ; not restricted to 1 argument
|
||||
(command-line-arguments [sig [() -> (list)] [(sub-list) -> (void)]] [flags])
|
||||
(commonization-level [sig [() -> (ufixnum)] [(sub-ufixnum) -> (void)]] [flags])
|
||||
(compile-compressed [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
|
||||
(compile-file-message [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
|
||||
(compile-interpret-simple [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
|
||||
(compile-imported-libraries [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
|
||||
|
|
@ -966,6 +965,7 @@
|
|||
(expand-output [sig [() -> (maybe-textual-output-port)] [(maybe-textual-output-port) -> (void)]] [flags])
|
||||
(expand/optimize-output [sig [() -> (maybe-textual-output-port)] [(maybe-textual-output-port) -> (void)]] [flags])
|
||||
(exit-handler [sig [() -> (procedure)] [(procedure) -> (void)]] [flags])
|
||||
(fasl-compressed [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
|
||||
(file-buffer-size [sig [() -> (ufixnum)] [(sub-fixnum) -> (void)]] [flags])
|
||||
(generate-allocation-counts [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
|
||||
(generate-covin-files [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
|
||||
|
|
@ -1831,10 +1831,12 @@
|
|||
($build-invoke-program [flags single-valued])
|
||||
($build-library-exts [flags single-valued])
|
||||
($byte-copy! [flags single-valued])
|
||||
($bytevector-compress [flags])
|
||||
($bytevector-ref-check? [sig [(sub-uint ptr ptr) -> (boolean)]] [flags pure])
|
||||
($bytevector-set!-check? [sig [(sub-uint ptr ptr) -> (boolean)]] [flags discard])
|
||||
($bytevector-set! [flags single-valued])
|
||||
($bytevector-set-immutable! [sig [(bytevector) -> (void)]] [flags true])
|
||||
($bytevector-uncompress [flags])
|
||||
($capture-fasl-target [flags single-valued])
|
||||
($c-error [flags])
|
||||
($check-heap-errors [flags single-valued])
|
||||
|
|
@ -1865,6 +1867,7 @@
|
|||
($compile-host-library [flags single-valued])
|
||||
($compound-condition-components [flags discard true])
|
||||
($compound-condition? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
|
||||
($compressed-warning [flags])
|
||||
($compute-composition [flags single-valued])
|
||||
($compute-size [flags single-valued])
|
||||
($constituent? [sig [(char) -> (boolean)]] [flags pure mifoldable safeongoodargs])
|
||||
|
|
@ -2394,6 +2397,7 @@
|
|||
($visit [flags single-valued])
|
||||
($visit-library [flags single-valued])
|
||||
($with-fasl-target [flags single-valued])
|
||||
($write-fasl-bytevectors [flags single-valued])
|
||||
($write-pretty-quick [flags single-valued])
|
||||
($xscript-port? [sig [(port) -> (boolean)]] [flags discard])
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"prims.ss"
|
||||
;;; prims.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -19,6 +18,7 @@
|
|||
(run-cp0 (default-run-cp0))
|
||||
(generate-interrupt-trap #f))
|
||||
|
||||
(begin
|
||||
;;; hand-coded primitives
|
||||
|
||||
(define-who $hand-coded
|
||||
|
|
@ -2679,3 +2679,5 @@
|
|||
(lambda (x v)
|
||||
(unless (wrapper-procedure? x) ($oops who "~s is not a wrapper procedure" x))
|
||||
($closure-set! x 2 v)))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"primvars.ss"
|
||||
;;; primvars.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"print.ss"
|
||||
;;; print.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -14,6 +13,7 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(eval-when (compile)
|
||||
(define-constant cycle-node-max 1000)
|
||||
|
||||
|
|
@ -611,7 +611,7 @@ floating point returns with (1 0 -1 ...).
|
|||
(define wrhelp
|
||||
(lambda (x r lev len d? env p)
|
||||
(define void? (lambda (x) (eq? x (void))))
|
||||
(define black-hole? (lambda (x) (eq? x '#0=#0#)))
|
||||
(define black-hole? (lambda (x) (eq? x '#3=#3#)))
|
||||
(define base-rtd? (lambda (x) (eq? x #!base-rtd)))
|
||||
(if-feature pthreads
|
||||
(begin
|
||||
|
|
@ -1383,3 +1383,4 @@ floating point returns with (1 0 -1 ...).
|
|||
(unless (or (not x) (and (fixnum? x) (fx> x 0)) (and (bignum? x) ($bigpositive? x)))
|
||||
($oops 'print-precision "~s is not a positive exact integer or #f" x))
|
||||
x)))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"read.ss"
|
||||
;;; read.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -18,6 +17,7 @@
|
|||
;(define read)
|
||||
;(define $read)
|
||||
|
||||
(begin
|
||||
(let ()
|
||||
(include "types.ss")
|
||||
|
||||
|
|
@ -1872,3 +1872,4 @@
|
|||
(char-name 'alarm #\bel)
|
||||
(char-name 'nel #\nel)
|
||||
(char-name 'ls #\ls))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"record.ss"
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"reloc.ss"
|
||||
;;; reloc.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -14,6 +13,7 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
(begin
|
||||
(define $reloc
|
||||
(lambda (type item-offset code-offset)
|
||||
(make-reloc type item-offset code-offset
|
||||
|
|
@ -57,8 +57,6 @@
|
|||
(bitwise-arithmetic-shift-left (reloc-item-offset r) (constant reloc-item-offset-offset))))
|
||||
(mkc1 r* (fx+ n 1))))))))))
|
||||
|
||||
(define $make-cinst)
|
||||
(define $make-vtable)
|
||||
(let ()
|
||||
(set! $make-cinst
|
||||
(lambda (build-sinst vtable)
|
||||
|
|
@ -100,3 +98,4 @@
|
|||
r)
|
||||
(constant ptr-bytes)))))))
|
||||
)
|
||||
)
|
||||
|
|
|
|||
262
s/strip.ss
262
s/strip.ss
|
|
@ -89,6 +89,14 @@
|
|||
(let ([k (read-byte p)])
|
||||
(f k (logor (ash n 7) (fxand k #x7F))))
|
||||
n)))))
|
||||
(define read-uptr/bytes
|
||||
(lambda (p)
|
||||
(let ([k (read-byte p)])
|
||||
(let f ([k k] [n (fxand k #x7F)] [bytes 1])
|
||||
(if (fxlogbit? 7 k)
|
||||
(let ([k (read-byte p)])
|
||||
(f k (logor (ash n 7) (fxand k #x7F)) (fx+ bytes 1)))
|
||||
(values n bytes))))))
|
||||
(define read-byte-or-eof
|
||||
(lambda (p)
|
||||
(get-u8 p)))
|
||||
|
|
@ -101,6 +109,12 @@
|
|||
(let ([y (read-byte p)])
|
||||
(unless (eqv? y x)
|
||||
(bogus "expected byte ~s, got ~s from ~a" x y (port-name p)))))
|
||||
(define read-bytevector
|
||||
(lambda (p n)
|
||||
(let ([bv (make-bytevector n)])
|
||||
(do ([i 0 (fx+ i 1)])
|
||||
((fx= i n) bv)
|
||||
(bytevector-u8-set! bv i (read-byte p))))))
|
||||
(define read-string
|
||||
(lambda (p)
|
||||
(let ([n (read-uptr p)])
|
||||
|
|
@ -116,13 +130,24 @@
|
|||
(fasl-type-case ty
|
||||
[(fasl-type-header) (read-header p)]
|
||||
[(fasl-type-visit fasl-type-revisit fasl-type-visit-revisit)
|
||||
(let ([situation ty])
|
||||
(let ([ty (read-byte p)])
|
||||
(fasl-type-case ty
|
||||
[(fasl-type-fasl-size)
|
||||
(let ([size (read-uptr p)])
|
||||
(fasl-entry situation (read-fasl p #f)))]
|
||||
[else (bogus "expected fasl-size in ~a" (port-name p))])))]
|
||||
(let* ([situation ty]
|
||||
[size (read-uptr p)]
|
||||
[compressed-flag (read-byte p)]
|
||||
[kind (read-byte p)])
|
||||
(unless (eqv? kind (constant fasl-type-fasl))
|
||||
(bogus "unexpected fasl kind ~a" (port-name p)))
|
||||
(fasl-type-case compressed-flag
|
||||
[(fasl-type-gzip fasl-type-lz4)
|
||||
(let-values ([(dest-size dest-size-bytes) (read-uptr/bytes p)])
|
||||
(let* ([src-size (- size 2 dest-size-bytes)]
|
||||
[bv (read-bytevector p src-size)]
|
||||
[bv ($bytevector-uncompress bv 0 src-size dest-size
|
||||
(if (eqv? compressed-flag (constant fasl-type-gzip))
|
||||
(constant COMPRESS-GZIP)
|
||||
(constant COMPRESS-LZ4)))])
|
||||
(fasl-entry situation (read-fasl (open-bytevector-input-port bv) #f))))]
|
||||
[(fasl-type-uncompressed) (fasl-entry situation (read-fasl p #f))]
|
||||
[else (bogus "expected compression flag in ~a" (port-name p))]))]
|
||||
[else (bogus "expected header or situation in ~a" (port-name p))]))))
|
||||
(define (read-header p)
|
||||
(let* ([bv (constant fasl-header)] [n (bytevector-length bv)])
|
||||
|
|
@ -203,13 +228,7 @@
|
|||
((fx= i n) v)
|
||||
(vector-set! v i (read-iptr p))))))]
|
||||
[(fasl-type-bytevector fasl-type-immutable-bytevector)
|
||||
(fasl-bytevector
|
||||
ty
|
||||
(let ([n (read-uptr p)])
|
||||
(let ([bv (make-bytevector n)])
|
||||
(do ([i 0 (fx+ i 1)])
|
||||
((fx= i n) bv)
|
||||
(bytevector-u8-set! bv i (read-byte p))))))]
|
||||
(fasl-bytevector ty (read-bytevector p (read-uptr p)))]
|
||||
[(fasl-type-base-rtd) (fasl-tuple ty '#())]
|
||||
[(fasl-type-rtd) (read-record p g (read-fasl p g))]
|
||||
[(fasl-type-record) (read-record p g #f)]
|
||||
|
|
@ -446,52 +465,44 @@
|
|||
[reloc (type-etc code-offset item-offset fasl) (build! fasl t)]
|
||||
[indirect (g i) (build! (vector-ref g i) t)])))
|
||||
|
||||
(include "fasl-helpers.ss")
|
||||
|
||||
(define write-entry
|
||||
(lambda (p x)
|
||||
(define (append-bvs bv*)
|
||||
(let f ([bv* bv*] [n 0])
|
||||
(if (null? bv*)
|
||||
(if (fixnum? n)
|
||||
(make-bytevector n)
|
||||
($oops 'fasl-write "fasl output is too large to compress"))
|
||||
(let ([bv1 (car bv*)])
|
||||
(let ([m (bytevector-length bv1)])
|
||||
(let ([bv2 (f (cdr bv*) (+ n m))])
|
||||
(bytevector-copy! bv1 0 bv2 n m)
|
||||
bv2))))))
|
||||
(fasl-case x
|
||||
[header (version machine dependencies)
|
||||
(write-header p version machine dependencies)]
|
||||
(emit-header p version machine dependencies)]
|
||||
[entry (situation fasl)
|
||||
(let ([t (make-table)])
|
||||
(build! fasl t)
|
||||
(let ([bv (call-with-bytevector-output-port
|
||||
(lambda (p)
|
||||
(let ([n (table-count t)])
|
||||
(unless (fx= n 0)
|
||||
(write-byte p (constant fasl-type-graph))
|
||||
(write-uptr p n)))
|
||||
(write-fasl p t fasl)))])
|
||||
(write-byte p situation)
|
||||
(write-byte p (constant fasl-type-fasl-size))
|
||||
(write-uptr p (bytevector-length bv))
|
||||
(put-bytevector p bv)))]
|
||||
($fasl-start p t situation
|
||||
(lambda (p) (write-fasl p t fasl))))]
|
||||
[else (sorry! "unrecognized top-level fasl-record-type ~s" x)])))
|
||||
|
||||
(define write-header
|
||||
(lambda (p version machine dependencies)
|
||||
(put-bytevector p (constant fasl-header))
|
||||
(write-uptr p version)
|
||||
(write-uptr p machine)
|
||||
(write-byte p (char->integer #\())
|
||||
(let f ([dependencies dependencies])
|
||||
(unless (null? dependencies)
|
||||
(write-byte p (car dependencies))
|
||||
(f (cdr dependencies))))
|
||||
(write-byte p (char->integer #\)))))
|
||||
|
||||
(define write-graph
|
||||
(lambda (p t x th)
|
||||
(let ([a (eq-hashtable-ref (table-ht t) x #f)])
|
||||
(cond
|
||||
[(not a) (th)]
|
||||
[(cdr a)
|
||||
(write-byte p (constant fasl-type-graph-def))
|
||||
(write-uptr p (car a))
|
||||
(put-u8 p (constant fasl-type-graph-def))
|
||||
(put-uptr p (car a))
|
||||
(set-cdr! a #f)
|
||||
(th)]
|
||||
[else
|
||||
(write-byte p (constant fasl-type-graph-ref))
|
||||
(write-uptr p (car a))]))))
|
||||
(put-u8 p (constant fasl-type-graph-ref))
|
||||
(put-uptr p (car a))]))))
|
||||
|
||||
(define write-fasl
|
||||
(lambda (p t x)
|
||||
|
|
@ -501,42 +512,42 @@
|
|||
[pair (vfasl)
|
||||
(write-graph p t x
|
||||
(lambda ()
|
||||
(write-byte p (constant fasl-type-pair))
|
||||
(write-uptr p (fx- (vector-length vfasl) 1))
|
||||
(put-u8 p (constant fasl-type-pair))
|
||||
(put-uptr p (fx- (vector-length vfasl) 1))
|
||||
(vector-for-each (lambda (fasl) (write-fasl p t fasl)) vfasl)))]
|
||||
[tuple (ty vfasl)
|
||||
(write-graph p t x
|
||||
(lambda ()
|
||||
(write-byte p ty)
|
||||
(put-u8 p ty)
|
||||
(vector-for-each (lambda (fasl) (write-fasl p t fasl)) vfasl)))]
|
||||
[string (ty string)
|
||||
(write-graph p t x
|
||||
(lambda ()
|
||||
(write-byte p ty)
|
||||
(put-u8 p ty)
|
||||
(write-string p string)))]
|
||||
[gensym (pname uname)
|
||||
(write-graph p t x
|
||||
(lambda ()
|
||||
(write-byte p (constant fasl-type-gensym))
|
||||
(put-u8 p (constant fasl-type-gensym))
|
||||
(write-string p pname)
|
||||
(write-string p uname)))]
|
||||
[vector (ty vfasl)
|
||||
(write-graph p t x
|
||||
(lambda ()
|
||||
(write-byte p ty)
|
||||
(write-uptr p (vector-length vfasl))
|
||||
(put-u8 p ty)
|
||||
(put-uptr p (vector-length vfasl))
|
||||
(vector-for-each (lambda (fasl) (write-fasl p t fasl)) vfasl)))]
|
||||
[fxvector (ty viptr)
|
||||
(write-graph p t x
|
||||
(lambda ()
|
||||
(write-byte p ty)
|
||||
(write-uptr p (vector-length viptr))
|
||||
(vector-for-each (lambda (iptr) (write-iptr p iptr)) viptr)))]
|
||||
(put-u8 p ty)
|
||||
(put-uptr p (vector-length viptr))
|
||||
(vector-for-each (lambda (iptr) (put-iptr p iptr)) viptr)))]
|
||||
[bytevector (ty bv)
|
||||
(write-graph p t x
|
||||
(lambda ()
|
||||
(write-byte p ty)
|
||||
(write-uptr p (bytevector-length bv))
|
||||
(put-u8 p ty)
|
||||
(put-uptr p (bytevector-length bv))
|
||||
(put-bytevector p bv)))]
|
||||
[record (maybe-uid size nflds rtd pad-ty* fld*)
|
||||
(if (and strip-source-annotations? (fasl-annotation? x))
|
||||
|
|
@ -545,51 +556,51 @@
|
|||
(lambda ()
|
||||
(if maybe-uid
|
||||
(begin
|
||||
(write-byte p (constant fasl-type-rtd))
|
||||
(put-u8 p (constant fasl-type-rtd))
|
||||
(write-fasl p t maybe-uid))
|
||||
(write-byte p (constant fasl-type-record)))
|
||||
(write-uptr p size)
|
||||
(write-uptr p nflds)
|
||||
(put-u8 p (constant fasl-type-record)))
|
||||
(put-uptr p size)
|
||||
(put-uptr p nflds)
|
||||
(write-fasl p t rtd)
|
||||
(for-each (lambda (pad-ty fld)
|
||||
(write-byte p pad-ty)
|
||||
(put-u8 p pad-ty)
|
||||
(field-case fld
|
||||
[ptr (fasl) (write-fasl p t fasl)]
|
||||
[byte (n) (write-byte p n)]
|
||||
[iptr (n) (write-iptr p n)]
|
||||
[single (n) (write-uptr p n)]
|
||||
[byte (n) (put-u8 p n)]
|
||||
[iptr (n) (put-iptr p n)]
|
||||
[single (n) (put-uptr p n)]
|
||||
[double (high low)
|
||||
(write-uptr p high)
|
||||
(write-uptr p low)]))
|
||||
(put-uptr p high)
|
||||
(put-uptr p low)]))
|
||||
pad-ty* fld*))))]
|
||||
[closure (offset c)
|
||||
(write-graph p t x
|
||||
(lambda ()
|
||||
(write-byte p (constant fasl-type-closure))
|
||||
(write-uptr p offset)
|
||||
(put-u8 p (constant fasl-type-closure))
|
||||
(put-uptr p offset)
|
||||
(write-fasl p t c)))]
|
||||
[flonum (high low)
|
||||
(write-graph p t x
|
||||
(lambda ()
|
||||
(write-byte p (constant fasl-type-flonum))
|
||||
(write-uptr p high)
|
||||
(write-uptr p low)))]
|
||||
(put-u8 p (constant fasl-type-flonum))
|
||||
(put-uptr p high)
|
||||
(put-uptr p low)))]
|
||||
[large-integer (sign vuptr)
|
||||
(write-graph p t x
|
||||
(lambda ()
|
||||
(write-byte p (constant fasl-type-large-integer))
|
||||
(write-byte p sign)
|
||||
(write-uptr p (vector-length vuptr))
|
||||
(vector-for-each (lambda (uptr) (write-uptr p uptr)) vuptr)))]
|
||||
(put-u8 p (constant fasl-type-large-integer))
|
||||
(put-u8 p sign)
|
||||
(put-uptr p (vector-length vuptr))
|
||||
(vector-for-each (lambda (uptr) (put-uptr p uptr)) vuptr)))]
|
||||
[eq-hashtable (mutable? subtype minlen veclen vpfasl)
|
||||
(write-graph p t x
|
||||
(lambda ()
|
||||
(write-byte p (constant fasl-type-eq-hashtable))
|
||||
(write-byte p mutable?)
|
||||
(write-byte p subtype)
|
||||
(write-uptr p minlen)
|
||||
(write-uptr p veclen)
|
||||
(write-uptr p (vector-length vpfasl))
|
||||
(put-u8 p (constant fasl-type-eq-hashtable))
|
||||
(put-u8 p mutable?)
|
||||
(put-u8 p subtype)
|
||||
(put-uptr p minlen)
|
||||
(put-uptr p veclen)
|
||||
(put-uptr p (vector-length vpfasl))
|
||||
(vector-for-each
|
||||
(lambda (pfasl)
|
||||
(write-fasl p t (car pfasl))
|
||||
|
|
@ -598,12 +609,12 @@
|
|||
[symbol-hashtable (mutable? minlen equiv veclen vpfasl)
|
||||
(write-graph p t x
|
||||
(lambda ()
|
||||
(write-byte p (constant fasl-type-symbol-hashtable))
|
||||
(write-byte p mutable?)
|
||||
(write-uptr p minlen)
|
||||
(write-byte p equiv)
|
||||
(write-uptr p veclen)
|
||||
(write-uptr p (vector-length vpfasl))
|
||||
(put-u8 p (constant fasl-type-symbol-hashtable))
|
||||
(put-u8 p mutable?)
|
||||
(put-uptr p minlen)
|
||||
(put-u8 p equiv)
|
||||
(put-uptr p veclen)
|
||||
(put-uptr p (vector-length vpfasl))
|
||||
(vector-for-each
|
||||
(lambda (pfasl)
|
||||
(write-fasl p t (car pfasl))
|
||||
|
|
@ -612,10 +623,10 @@
|
|||
[code (flags free name arity-mask info pinfo* bytes m vreloc)
|
||||
(write-graph p t x
|
||||
(lambda ()
|
||||
(write-byte p (constant fasl-type-code))
|
||||
(write-byte p flags)
|
||||
(write-uptr p free)
|
||||
(write-uptr p (bytevector-length bytes))
|
||||
(put-u8 p (constant fasl-type-code))
|
||||
(put-u8 p flags)
|
||||
(put-uptr p free)
|
||||
(put-uptr p (bytevector-length bytes))
|
||||
(write-fasl p t name)
|
||||
(write-fasl p t arity-mask)
|
||||
(if strip-inspector-information?
|
||||
|
|
@ -625,52 +636,28 @@
|
|||
(write-fasl p t (fasl-atom (constant fasl-type-immediate) (constant snil)))
|
||||
(write-fasl p t pinfo*))
|
||||
(put-bytevector p bytes)
|
||||
(write-uptr p m)
|
||||
(put-uptr p m)
|
||||
(vector-for-each (lambda (reloc) (write-fasl p t reloc)) vreloc)))]
|
||||
[small-integer (iptr)
|
||||
(write-byte p (constant fasl-type-small-integer))
|
||||
(write-iptr p iptr)]
|
||||
(put-u8 p (constant fasl-type-small-integer))
|
||||
(put-iptr p iptr)]
|
||||
[atom (ty uptr)
|
||||
(write-byte p ty)
|
||||
(write-uptr p uptr)]
|
||||
(put-u8 p ty)
|
||||
(put-uptr p uptr)]
|
||||
[reloc (type-etc code-offset item-offset fasl)
|
||||
(write-byte p type-etc)
|
||||
(write-uptr p code-offset)
|
||||
(when (fxlogtest type-etc 2) (write-uptr p item-offset))
|
||||
(put-u8 p type-etc)
|
||||
(put-uptr p code-offset)
|
||||
(when (fxlogtest type-etc 2) (put-uptr p item-offset))
|
||||
(write-fasl p t fasl)]
|
||||
[indirect (g i) (write-fasl p t (vector-ref g i))])))
|
||||
|
||||
(define write-byte
|
||||
(lambda (p x)
|
||||
(put-u8 p x)))
|
||||
|
||||
(define-who write-uptr
|
||||
(lambda (p n)
|
||||
(unless (>= n 0)
|
||||
(sorry! "received negative input ~s" n))
|
||||
(let f ([n n] [cbit 0])
|
||||
(if (and (fixnum? n) (fx<= n 127))
|
||||
(write-byte p (fxlogor n cbit))
|
||||
(begin
|
||||
(f (ash n -7) 128)
|
||||
(write-byte p (fxlogor (logand n #x7f) cbit)))))))
|
||||
|
||||
(define write-iptr
|
||||
(lambda (p x)
|
||||
(let f ([n (if (< x 0) (- x) x)] [cbit 0])
|
||||
(if (and (fixnum? n) (fx<= n 63))
|
||||
(write-byte p (fxlogor (if (< x 0) #x80 0) (fxsll n 1) cbit))
|
||||
(begin
|
||||
(f (ash n -7) 1)
|
||||
(write-byte p (fxlogor (fxsll (logand n #x7f) 1) cbit)))))))
|
||||
|
||||
(define write-string
|
||||
(lambda (p x)
|
||||
(let ([n (string-length x)])
|
||||
(write-uptr p n)
|
||||
(put-uptr p n)
|
||||
(do ([i 0 (fx+ i 1)])
|
||||
((fx= i n))
|
||||
(write-uptr p (char->integer (string-ref x i)))))))
|
||||
(put-uptr p (char->integer (string-ref x i)))))))
|
||||
|
||||
(module (fasl-program-info? fasl-library/rt-info? fasl-recompile-info?)
|
||||
(import (nanopass))
|
||||
|
|
@ -700,7 +687,6 @@
|
|||
(on-reset (close-port ip)
|
||||
(let* ([script-header (read-script-header ip)]
|
||||
[mode (and script-header (unless-feature windows (get-mode ifn)))])
|
||||
(port-file-compressed! ip)
|
||||
(let loop ([rentry* '()])
|
||||
(set! fasl-count (fx+ fasl-count 1))
|
||||
(let ([entry (read-entry ip)])
|
||||
|
|
@ -728,7 +714,6 @@
|
|||
(on-reset (delete-file ofn #f)
|
||||
(on-reset (close-port op)
|
||||
(when script-header (put-bytevector op script-header))
|
||||
(when (compile-compressed) (port-file-compressed! op))
|
||||
(for-each (lambda (entry) (write-entry op entry)) entry*)
|
||||
(close-port op)
|
||||
(unless-feature windows (when mode (chmod ofn mode)))))))))))))
|
||||
|
|
@ -898,19 +883,16 @@
|
|||
(let ([script-header1 (read-script-header ip1)]
|
||||
[script-header2 (read-script-header ip2)])
|
||||
(if (equal? script-header1 script-header2)
|
||||
(begin
|
||||
(port-file-compressed! ip1)
|
||||
(port-file-compressed! ip2)
|
||||
(let loop ()
|
||||
(set! fasl-count (fx+ fasl-count 1))
|
||||
(let ([entry1 (read-entry ip1)] [entry2 (read-entry ip2)])
|
||||
(if (eof-object? entry1)
|
||||
(or (eof-object? entry2)
|
||||
(and error? (bogus "~a has fewer fasl entries than ~a" ifn1 ifn2)))
|
||||
(if (eof-object? entry2)
|
||||
(and error? (bogus "~a has fewer fasl entries than ~a" ifn2 ifn1))
|
||||
(and (fluid-let ([cmp-ht (make-eq-hashtable)]
|
||||
[gensym-table (make-hashtable string-hash string=?)])
|
||||
(fasl=? entry1 entry2))
|
||||
(loop)))))))
|
||||
(let loop ()
|
||||
(set! fasl-count (fx+ fasl-count 1))
|
||||
(let ([entry1 (read-entry ip1)] [entry2 (read-entry ip2)])
|
||||
(if (eof-object? entry1)
|
||||
(or (eof-object? entry2)
|
||||
(and error? (bogus "~a has fewer fasl entries than ~a" ifn1 ifn2)))
|
||||
(if (eof-object? entry2)
|
||||
(and error? (bogus "~a has fewer fasl entries than ~a" ifn2 ifn1))
|
||||
(and (fluid-let ([cmp-ht (make-eq-hashtable)]
|
||||
[gensym-table (make-hashtable string-hash string=?)])
|
||||
(fasl=? entry1 entry2))
|
||||
(loop))))))
|
||||
(and error? (bogus "script headers ~s and ~s differ" script-header1 script-header2)))))))))))])))))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"strnum.ss"
|
||||
;;; strnum.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -94,6 +93,7 @@ restriction, with string->number returning #f and the reader raising
|
|||
an exception.
|
||||
|#
|
||||
|
||||
(begin
|
||||
(let ()
|
||||
;; (mknum-state <state name>
|
||||
;; <expression if end of string found>
|
||||
|
|
@ -542,3 +542,4 @@ an exception.
|
|||
(unless (inexact? x)
|
||||
($oops who "a precision is specified and ~s is not inexact" x))
|
||||
(parameterize ([print-radix r] [print-precision m]) (format "~a" x))]))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"syntax.ss"
|
||||
;;; syntax.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
@ -4867,7 +4866,6 @@
|
|||
fp
|
||||
(loop fp))))))
|
||||
(begin (set-port-position! ip start-pos) 0)))])
|
||||
(port-file-compressed! ip)
|
||||
(if ($compiled-file-header? ip)
|
||||
(let ([x (fasl-read ip)])
|
||||
(close-port ip)
|
||||
|
|
@ -5210,7 +5208,6 @@
|
|||
fp
|
||||
(loop fp))))))
|
||||
(begin (set-port-position! ip start-pos) 0)))])
|
||||
(port-file-compressed! ip)
|
||||
(unless ($compiled-file-header? ip) ($oops who "missing header for compiled file ~s" fn))
|
||||
(let ([x (fasl-read ip)])
|
||||
(unless (recompile-info? x) ($oops who "expected recompile info at start of ~s, found ~a" fn x)))
|
||||
|
|
@ -7510,6 +7507,7 @@
|
|||
|
||||
(current-expand sc-expand)
|
||||
|
||||
(begin
|
||||
;;; syntax-rules/syntax-case aux keywords
|
||||
(define-syntax ...
|
||||
(lambda (x)
|
||||
|
|
@ -10344,3 +10342,4 @@
|
|||
|
||||
(set-who! $annotation-options (make-enumeration '(debug profile)))
|
||||
(set-who! $make-annotation-options (enum-set-constructor $annotation-options))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
"trace.ss"
|
||||
;;; trace.ss
|
||||
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||||
;;;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user