suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request #418 from dybvig/compress-level

Browse Source 
Add a compress-level parameter
original commit: 3ea6f8e4b166b033f1cb33293090ca78b8986db9
This commit is contained in:
R. Kent Dybvig 2019-04-18 10:05:59 -07:00 committed by GitHub
commit 39c9f4d7f2
27 changed files with 1185 additions and 716 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
LOG
View File

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

618
c/compress-io.c
View File

@ -1,5 +1,5 @@
/* compress-io.c /* compress-io.c
* Copyright 1984-2017 Cisco Systems, Inc. * Copyright 1984-2019 Cisco Systems, Inc.
* *
* Licensed under the Apache License, Version 2.0 (the "License"); * Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License. * you may not use this file except in compliance with the License.
@ -17,8 +17,10 @@
/* Dispatch to zlib or LZ4 */ /* Dispatch to zlib or LZ4 */
#include "system.h" #include "system.h"
#include "zlib.h"
#include "lz4.h" #include "lz4.h"
#include "lz4frame.h" #include "lz4frame.h"
#include "lz4hc.h"
#include <fcntl.h> #include <fcntl.h>
#include <errno.h> #include <errno.h>
@ -31,56 +33,185 @@
# define GLZ_O_BINARY 0 # define GLZ_O_BINARY 0
#endif #endif
enum { /* the value of LZ4_OUTPUT_PORT_IN_BUFFER_SIZE was determined
is_gz, through experimentation on an intel linux server and an intel
is_lz4_write, osx laptop. smaller sizes result in significantly worse compression
is_lz4_read of object files, and larger sizes don't have much beneficial effect.
}; don't increase the output-port in-buffer size unless you're sure
it reduces object-file size or reduces compression time
significantly. don't decrease it unless you're sure it doesn't
increase object-file size significnatly. one buffer of size
LZ4_OUTPUT_PORT_IN_BUFFER_SIZE is allocated per lz4-compressed
output port. another buffer of a closely related size is allocated
per thread. */
#define LZ4_OUTPUT_PORT_IN_BUFFER_SIZE (1 << 18)
typedef struct lz4File_out { /* the values we choose for LZ4_INPUT_PORT_IN_BUFFER_SIZE and
int fd; LZ4_INPUT_PORT_OUT_BUFFER_SIZE don't seem to make much difference
void *in_buffer, *out_buffer; in decompression speed, so we keep them fairly small. one buffer
int in_pos, out_len, out_pos; of size LZ4_INPUT_PORT_IN_BUFFER_SIZE and one buffer of size
int err; LZ4_INPUT_PORT_OUT_BUFFER_SIZE are allocated per lz4-compressed
input port. */
#define LZ4_INPUT_PORT_IN_BUFFER_SIZE (1 << 12)
#define LZ4_INPUT_PORT_OUT_BUFFER_SIZE (1 << 14)
typedef struct lz4File_out_r {
LZ4F_preferences_t preferences;
INT fd;
INT out_buffer_size;
INT in_pos;
INT err;
size_t stream_pos; size_t stream_pos;
char in_buffer[LZ4_OUTPUT_PORT_IN_BUFFER_SIZE];
} lz4File_out; } lz4File_out;
typedef struct lz4File_in { typedef struct lz4File_in_r {
int fd; INT fd;
LZ4F_dctx *dctx; LZ4F_dctx *dctx;
void *in_buffer, *out_buffer; INT in_pos, in_len, out_pos, out_len;
int in_pos, in_len, out_pos, out_len; INT frame_ended;
int frame_ended; INT err;
int err;
size_t stream_pos; size_t stream_pos;
off_t init_pos; off_t init_pos;
char in_buffer[LZ4_INPUT_PORT_IN_BUFFER_SIZE];
char out_buffer[LZ4_INPUT_PORT_OUT_BUFFER_SIZE];
} lz4File_in; } lz4File_in;
#define USE_LZ4_BUFFER_SIZE (1 << 14) typedef struct sized_buffer_r {
INT size;
char buffer[0];
} sized_buffer;
static glzFile glzdopen_lz4_pos(int fd, const char *mode, off_t init_pos); /* local functions */
static glzFile glzdopen_output_gz(INT fd, INT compress_level);
static glzFile glzdopen_output_lz4(INT fd, INT compress_level);
static glzFile glzdopen_input_gz(INT fd);
static glzFile glzdopen_input_lz4(INT fd, off_t init_pos);
static INT glzread_lz4(lz4File_in *lz4, void *buffer, UINT count);
static INT glzemit_lz4(lz4File_out *lz4, void *buffer, UINT count);
static INT glzwrite_lz4(lz4File_out *lz4, void *buffer, UINT count);
glzFile glzdopen_gz(int fd, const char *mode) { static glzFile glzdopen_output_gz(INT fd, INT compress_level) {
gzFile gz; gzFile gz;
glzFile glz;
INT as_append;
INT level;
if ((gz = gzdopen(fd, mode)) == Z_NULL) { #ifdef WIN32
as_append = 0;
#else
as_append = fcntl(fd, F_GETFL) & O_APPEND;
#endif
if ((gz = gzdopen(fd, as_append ? "ab" : "wb")) == Z_NULL) return Z_NULL;
switch (compress_level) {
case COMPRESS_LOW:
level = Z_BEST_SPEED;
break;
case COMPRESS_MEDIUM:
level = (Z_BEST_SPEED + Z_BEST_COMPRESSION) / 2;
break;
case COMPRESS_HIGH:
level = (Z_BEST_SPEED + (3 * Z_BEST_COMPRESSION)) / 4;
break;
case COMPRESS_MAX:
level = Z_BEST_COMPRESSION;
break;
default:
S_error1("glzdopen_output_gz", "unexpected compress level ~s", Sinteger(compress_level));
level = 0;
break;
}
gzsetparams(gz, level, Z_DEFAULT_STRATEGY);
if ((glz = malloc(sizeof(struct glzFile_r))) == NULL) {
(void)gzclose(gz);
return Z_NULL; return Z_NULL;
} else { }
glzFile glz = malloc(sizeof(struct glzFile_r)); glz->fd = fd;
glz->mode = is_gz; glz->inputp = 0;
glz->format = COMPRESS_GZIP;
glz->gz = gz; glz->gz = gz;
return glz; return glz;
}
static glzFile glzdopen_output_lz4(INT fd, INT compress_level) {
glzFile glz;
lz4File_out *lz4;
INT level;
switch (compress_level) {
case COMPRESS_LOW:
level = 1;
break;
case COMPRESS_MEDIUM:
level = LZ4HC_CLEVEL_MIN;
break;
case COMPRESS_HIGH:
level = (LZ4HC_CLEVEL_MIN + LZ4HC_CLEVEL_MAX) / 2;
break;
case COMPRESS_MAX:
level = LZ4HC_CLEVEL_MAX;
break;
default:
S_error1("glzdopen_output_lz4", "unexpected compress level ~s", Sinteger(compress_level));
level = 0;
break;
}
if ((lz4 = malloc(sizeof(lz4File_out))) == NULL) return Z_NULL;
memset(&lz4->preferences, 0, sizeof(LZ4F_preferences_t));
lz4->preferences.compressionLevel = level;
lz4->fd = fd;
lz4->out_buffer_size = (INT)LZ4F_compressFrameBound(LZ4_OUTPUT_PORT_IN_BUFFER_SIZE, &lz4->preferences);
lz4->in_pos = 0;
lz4->err = 0;
lz4->stream_pos = 0;
if ((glz = malloc(sizeof(struct glzFile_r))) == NULL) {
free(lz4);
return Z_NULL;
}
glz->fd = fd;
glz->inputp = 0;
glz->format = COMPRESS_LZ4;
glz->lz4_out = lz4;
return glz;
}
glzFile S_glzdopen_output(INT fd, INT compress_format, INT compress_level) {
switch (compress_format) {
case COMPRESS_GZIP:
return glzdopen_output_gz(fd, compress_level);
case COMPRESS_LZ4:
return glzdopen_output_lz4(fd, compress_level);
default:
S_error1("glzdopen_output", "unexpected compress format ~s", Sinteger(compress_format));
return Z_NULL;
} }
} }
glzFile glzdopen_lz4(int fd, const char *mode) { static glzFile glzdopen_input_gz(INT fd) {
return glzdopen_lz4_pos(fd, mode, 0); gzFile gz;
glzFile glz;
if ((gz = gzdopen(fd, "rb")) == Z_NULL) return Z_NULL;
if ((glz = malloc(sizeof(struct glzFile_r))) == NULL) {
(void)gzclose(gz);
return Z_NULL;
}
glz->fd = fd;
glz->inputp = 1;
glz->format = COMPRESS_GZIP;
glz->gz = gz;
return glz;
} }
static glzFile glzdopen_lz4_pos(int fd, const char *mode, off_t init_pos) { static glzFile glzdopen_input_lz4(INT fd, off_t init_pos) {
glzFile glz = malloc(sizeof(struct glzFile_r)); glzFile glz;
if (mode[0] == 'r') {
LZ4F_dctx *dctx; LZ4F_dctx *dctx;
LZ4F_errorCode_t r; LZ4F_errorCode_t r;
lz4File_in *lz4; lz4File_in *lz4;
@ -89,11 +220,12 @@ static glzFile glzdopen_lz4_pos(int fd, const char *mode, off_t init_pos) {
if (LZ4F_isError(r)) if (LZ4F_isError(r))
return Z_NULL; return Z_NULL;
lz4 = malloc(sizeof(lz4File_in)); if ((lz4 = malloc(sizeof(lz4File_in))) == NULL) {
(void)LZ4F_freeDecompressionContext(dctx);
return Z_NULL;
}
lz4->fd = fd; lz4->fd = fd;
lz4->dctx = dctx; lz4->dctx = dctx;
lz4->in_buffer = malloc(USE_LZ4_BUFFER_SIZE);
lz4->out_buffer = malloc(USE_LZ4_BUFFER_SIZE);
lz4->in_pos = 0; lz4->in_pos = 0;
lz4->in_len = 0; lz4->in_len = 0;
lz4->out_len = 0; lz4->out_len = 0;
@ -103,36 +235,26 @@ static glzFile glzdopen_lz4_pos(int fd, const char *mode, off_t init_pos) {
lz4->stream_pos = 0; lz4->stream_pos = 0;
lz4->init_pos = init_pos; lz4->init_pos = init_pos;
glz->mode = is_lz4_read; if ((glz = malloc(sizeof(struct glzFile_r))) == NULL) {
glz->lz4 = (struct lz4File *)lz4; (void)LZ4F_freeDecompressionContext(lz4->dctx);
} else { free(lz4);
lz4File_out *lz4 = malloc(sizeof(lz4File_out)); return Z_NULL;
lz4->fd = fd;
lz4->in_buffer = malloc(USE_LZ4_BUFFER_SIZE);
lz4->out_buffer = malloc(LZ4F_compressFrameBound(USE_LZ4_BUFFER_SIZE, NULL));
lz4->in_pos = 0;
lz4->out_len = 0;
lz4->out_pos = 0;
lz4->err = 0;
lz4->stream_pos = 0;
glz->mode = is_lz4_write;
glz->lz4 = (struct lz4File *)lz4;
} }
glz->fd = fd;
glz->inputp = 1;
glz->format = COMPRESS_LZ4;
glz->lz4_in = lz4;
return glz; return glz;
} }
glzFile glzdopen(int fd, const char *mode) { glzFile S_glzdopen_input(INT fd) {
if (mode[0] == 'r') { INT r, pos = 0;
int r, pos = 0;
unsigned char buffer[4]; unsigned char buffer[4];
off_t init_pos; off_t init_pos;
/* check for LZ4 magic number, otherwise defer to gzdopen */ /* check for LZ4 magic number, otherwise defer to gzdopen */
init_pos = WIN32_IZE(lseek)(fd, 0, SEEK_CUR); if ((init_pos = WIN32_IZE(lseek)(fd, 0, SEEK_CUR)) == -1) return Z_NULL;
while (pos < 4) { while (pos < 4) {
r = WIN32_IZE(read)(fd, (char*)buffer + pos, 4 - pos); r = WIN32_IZE(read)(fd, (char*)buffer + pos, 4 - pos);
@ -141,181 +263,174 @@ glzFile glzdopen(int fd, const char *mode) {
else if (r > 0) else if (r > 0)
pos += r; pos += r;
#ifdef EINTR #ifdef EINTR
else if (r == EINTR) else if (errno == EINTR)
r = 0; continue;
#endif #endif
else else
break; /* error reading */ break; /* error reading */
} }
if (pos > 0) if (pos > 0) {
WIN32_IZE(lseek)(fd, init_pos, SEEK_SET); if (WIN32_IZE(lseek)(fd, init_pos, SEEK_SET) == -1) return Z_NULL;
}
if ((pos == 4) if ((pos == 4)
&& (buffer[0] == 0x04) && (buffer[0] == 0x04)
&& (buffer[1] == 0x22) && (buffer[1] == 0x22)
&& (buffer[2] == 0x4d) && (buffer[2] == 0x4d)
&& (buffer[3] == 0x18)) && (buffer[3] == 0x18))
return glzdopen_lz4_pos(fd, mode, init_pos); return glzdopen_input_lz4(fd, init_pos);
return glzdopen_gz(fd, mode); return glzdopen_input_gz(fd);
} else
return glzdopen_gz(fd, mode);
} }
/* currently assumes read mode: */ glzFile S_glzopen_input(const char *path) {
glzFile glzopen(const char *path, const char *mode) { INT fd;
int fd;
fd = WIN32_IZE(open)(path, O_RDONLY | GLZ_O_BINARY); fd = WIN32_IZE(open)(path, O_RDONLY | GLZ_O_BINARY);
if (fd == -1) if (fd == -1)
return Z_NULL; return Z_NULL;
else else
return glzdopen(fd, mode); return S_glzdopen_input(fd);
} }
#ifdef WIN32 #ifdef WIN32
/* currently assumes read mode: */ glzFile S_glzopen_input_w(const wchar_t *path) {
glzFile glzopen_w(wchar_t *path, const char *mode) { INT fd;
int fd;
fd = _wopen(path, O_RDONLY | GLZ_O_BINARY); fd = _wopen(path, O_RDONLY | GLZ_O_BINARY);
if (fd == -1) if (fd == -1)
return Z_NULL; return Z_NULL;
else else
return glzdopen(fd, mode); return S_glzdopen_input(fd);
} }
#endif #endif
int glzdirect(glzFile file) { IBOOL S_glzdirect(glzFile glz) {
if (file->mode == is_gz) if (glz->format == COMPRESS_GZIP)
return gzdirect(file->gz); return gzdirect(glz->gz);
else else
return 0; return 0;
} }
int glzclose(glzFile file) { INT S_glzclose(glzFile glz) {
if (file->mode == is_gz) { INT r = Z_OK, saved_errno = 0;
int r; switch (glz->format) {
r = gzclose(file->gz); case COMPRESS_GZIP:
if (r != Z_OK) r = gzclose(glz->gz);
return r;
} else if (file->mode == is_lz4_write) {
lz4File_out *lz4 = (lz4File_out *)file->lz4;
glzwrite(file, NULL /* => flush */, 0);
while (1) {
int r = WIN32_IZE(close)(lz4->fd);
if (r == 0)
break; break;
#ifdef EINTR case COMPRESS_LZ4:
else if (r == EINTR) if (glz->inputp) {
r = 0; lz4File_in *lz4 = glz->lz4_in;
#endif
else
return r;
}
free(lz4->in_buffer);
free(lz4->out_buffer);
} else {
lz4File_in *lz4 = (lz4File_in *)file->lz4;
while (1) { while (1) {
int r = WIN32_IZE(close)(lz4->fd); INT r = WIN32_IZE(close)(lz4->fd);
if (r == 0)
break;
#ifdef EINTR #ifdef EINTR
else if (r == EINTR) if (r < 0 && errno == EINTR) continue;
r = 0;
#endif #endif
else if (r == 0) { r = Z_ERRNO; saved_errno = errno; }
return r; break;
} }
(void)LZ4F_freeDecompressionContext(lz4->dctx); (void)LZ4F_freeDecompressionContext(lz4->dctx);
free(lz4->in_buffer); free(lz4);
free(lz4->out_buffer); } else {
lz4File_out *lz4 = glz->lz4_out;
if (lz4->in_pos != 0) {
r = glzemit_lz4(lz4, lz4->in_buffer, lz4->in_pos);
if (r >= 0) r = Z_OK; else { r = Z_ERRNO; saved_errno = errno; }
} }
free(file); while (1) {
return Z_OK; int r1 = WIN32_IZE(close)(lz4->fd);
#ifdef EINTR
if (r1 < 0 && errno == EINTR) continue;
#endif
if (r == Z_OK && r1 < 0) { r = Z_ERRNO; saved_errno = errno; }
break;
}
free(lz4);
}
break;
default:
S_error1("S_glzclose", "unexpected compress format ~s", Sinteger(glz->format));
}
free(glz);
if (saved_errno) errno = saved_errno;
return r;
} }
int glzread(glzFile file, void *buffer, unsigned int count) { static INT glzread_lz4(lz4File_in *lz4, void *buffer, UINT count) {
if (file->mode == is_gz) {
return gzread(file->gz, buffer, count);
} else {
lz4File_in *lz4 = (lz4File_in *)file->lz4;
while (lz4->out_pos == lz4->out_len) { while (lz4->out_pos == lz4->out_len) {
int in_avail; INT in_avail;
in_avail = lz4->in_len - lz4->in_pos; in_avail = lz4->in_len - lz4->in_pos;
if (!in_avail) { if (!in_avail) {
while (1) { while (1) {
in_avail = WIN32_IZE(read)(lz4->fd, (char*)lz4->in_buffer, USE_LZ4_BUFFER_SIZE); in_avail = WIN32_IZE(read)(lz4->fd, lz4->in_buffer, LZ4_INPUT_PORT_IN_BUFFER_SIZE);
if (in_avail >= 0) { if (in_avail >= 0) {
lz4->in_len = in_avail; lz4->in_len = in_avail;
lz4->in_pos = 0; lz4->in_pos = 0;
break; break;
#ifdef EINTR #ifdef EINTR
} else if (in_avail == EINTR) { } else if (errno == EINTR) {
/* try again */ /* try again */
#endif #endif
} else { } else {
lz4->err = errno; lz4->err = Z_ERRNO;
return -1; return -1;
} }
} }
} }
if (in_avail > 0) { if (in_avail > 0) {
size_t amt, out_len = USE_LZ4_BUFFER_SIZE, in_len = in_avail; size_t amt, out_len = LZ4_INPUT_PORT_OUT_BUFFER_SIZE, in_len = in_avail;
/* For a large enough result buffer, try to decompress directly /* For a large enough result buffer, try to decompress directly
to that buffer: */ to that buffer: */
if (count >= (out_len >> 1)) { if (count >= (out_len >> 1)) {
size_t direct_out_len = count; size_t direct_out_len = count;
if (lz4->frame_ended && ((char *)lz4->in_buffer)[lz4->in_pos] == 0) if (lz4->frame_ended && lz4->in_buffer[lz4->in_pos] == 0)
return 0; /* count 0 after frame as stream terminator */ return 0; /* count 0 after frame as stream terminator */
amt = LZ4F_decompress(lz4->dctx, amt = LZ4F_decompress(lz4->dctx,
buffer, &direct_out_len, buffer, &direct_out_len,
(char *)lz4->in_buffer + lz4->in_pos, &in_len, lz4->in_buffer + lz4->in_pos, &in_len,
NULL); NULL);
lz4->frame_ended = (amt == 0); lz4->frame_ended = (amt == 0);
if (LZ4F_isError(amt)) { if (LZ4F_isError(amt)) {
lz4->err = (int)amt; lz4->err = Z_STREAM_ERROR;
return -1; return -1;
} }
lz4->in_pos += (int)in_len; lz4->in_pos += (INT)in_len;
if (direct_out_len) { if (direct_out_len) {
lz4->stream_pos += direct_out_len; lz4->stream_pos += direct_out_len;
return (int)direct_out_len; return (INT)direct_out_len;
} }
in_len = in_avail - in_len; in_len = in_avail - in_len;
} }
if (in_len > 0) { if (in_len > 0) {
if (lz4->frame_ended && ((char *)lz4->in_buffer)[lz4->in_pos] == 0) if (lz4->frame_ended && lz4->in_buffer[lz4->in_pos] == 0)
return 0; /* count 0 after frame as stream terminator */ return 0; /* count 0 after frame as stream terminator */
amt = LZ4F_decompress(lz4->dctx, amt = LZ4F_decompress(lz4->dctx,
lz4->out_buffer, &out_len, lz4->out_buffer, &out_len,
(char *)lz4->in_buffer + lz4->in_pos, &in_len, lz4->in_buffer + lz4->in_pos, &in_len,
NULL); NULL);
lz4->frame_ended = (amt == 0); lz4->frame_ended = (amt == 0);
if (LZ4F_isError(amt)) { if (LZ4F_isError(amt)) {
lz4->err = (int)amt; lz4->err = Z_STREAM_ERROR;
return -1; return -1;
} }
lz4->in_pos += (int)in_len; lz4->in_pos += (INT)in_len;
lz4->out_len = (int)out_len; lz4->out_len = (INT)out_len;
lz4->out_pos = 0; lz4->out_pos = 0;
} }
} else { } else {
@ -325,88 +440,108 @@ int glzread(glzFile file, void *buffer, unsigned int count) {
} }
if (lz4->out_pos < lz4->out_len) { if (lz4->out_pos < lz4->out_len) {
unsigned int amt = lz4->out_len - lz4->out_pos; UINT amt = lz4->out_len - lz4->out_pos;
if (amt > count) amt = count; if (amt > count) amt = count;
memcpy(buffer, (char *)lz4->out_buffer + lz4->out_pos, amt); memcpy(buffer, lz4->out_buffer + lz4->out_pos, amt);
lz4->out_pos += amt; lz4->out_pos += amt;
lz4->stream_pos += amt; lz4->stream_pos += amt;
return amt; return amt;
} }
return 0; return 0;
}
INT S_glzread(glzFile glz, void *buffer, UINT count) {
switch (glz->format) {
case COMPRESS_GZIP:
return gzread(glz->gz, buffer, count);
case COMPRESS_LZ4:
return glzread_lz4(glz->lz4_in, buffer, count);
default:
S_error1("S_glzread", "unexpected compress format ~s", Sinteger(glz->format));
return -1;
} }
} }
int glzwrite(glzFile file, void *buffer, unsigned int count) { static INT glzemit_lz4(lz4File_out *lz4, void *buffer, UINT count) {
if (file->mode == is_gz) ptr tc = get_thread_context();
return gzwrite(file->gz, buffer, count); sized_buffer *cached_out_buffer;
else { char *out_buffer;
lz4File_out *lz4 = (lz4File_out *)file->lz4; INT out_len, out_pos;
INT r = 0;
if ((lz4->in_pos == USE_LZ4_BUFFER_SIZE) /* allocate one out_buffer (per thread) since we don't need one for each file.
|| ((lz4->in_pos > 0) && !buffer)) { the buffer is freed by destroy_thread. */
size_t out_len; if ((cached_out_buffer = LZ4OUTBUFFER(tc)) == NULL || cached_out_buffer->size < lz4->out_buffer_size) {
if (cached_out_buffer != NULL) free(cached_out_buffer);
if ((LZ4OUTBUFFER(tc) = cached_out_buffer = malloc(sizeof(sized_buffer) + lz4->out_buffer_size)) == NULL) return -1;
cached_out_buffer->size = lz4->out_buffer_size;
}
out_buffer = cached_out_buffer->buffer;
out_len = LZ4F_compressFrame(lz4->out_buffer, LZ4F_compressFrameBound(USE_LZ4_BUFFER_SIZE, NULL), out_len = (INT)LZ4F_compressFrame(out_buffer, lz4->out_buffer_size,
lz4->in_buffer, lz4->in_pos, buffer, count,
NULL); &lz4->preferences);
if (LZ4F_isError(out_len)) { if (LZ4F_isError(out_len)) {
lz4->err = (int)out_len; lz4->err = Z_STREAM_ERROR;
return -1; return -1;
} }
lz4->in_pos = 0; out_pos = 0;
lz4->out_len = (int)out_len; while (out_pos < out_len) {
lz4->out_pos = 0; r = WIN32_IZE(write)(lz4->fd, out_buffer + out_pos, out_len - out_pos);
}
while (lz4->out_pos < lz4->out_len) {
int r = WIN32_IZE(write)(lz4->fd, (char*)lz4->out_buffer + lz4->out_pos, lz4->out_len - lz4->out_pos);
if (r >= 0) if (r >= 0)
lz4->out_pos += r; out_pos += r;
#ifdef EINTR #ifdef EINTR
else if (r == EINTR) else if (errno == EINTR)
lz4->out_pos += 0; /* try again */ continue;
#endif #endif
else { else
lz4->err = errno; break;
}
return r; return r;
}
static INT glzwrite_lz4(lz4File_out *lz4, void *buffer, UINT count) {
UINT amt; INT r;
if ((amt = LZ4_OUTPUT_PORT_IN_BUFFER_SIZE - lz4->in_pos) > count) amt = count;
if (amt == LZ4_OUTPUT_PORT_IN_BUFFER_SIZE) {
/* full buffer coming from input...skip the memcpy */
if ((r = glzemit_lz4(lz4, buffer, LZ4_OUTPUT_PORT_IN_BUFFER_SIZE)) < 0) return 0;
} else {
memcpy(lz4->in_buffer + lz4->in_pos, buffer, amt);
if ((lz4->in_pos += amt) == LZ4_OUTPUT_PORT_IN_BUFFER_SIZE) {
lz4->in_pos = 0;
if ((r = glzemit_lz4(lz4, lz4->in_buffer, LZ4_OUTPUT_PORT_IN_BUFFER_SIZE)) < 0) return 0;
} }
} }
{
unsigned int amt = (USE_LZ4_BUFFER_SIZE - lz4->in_pos);
if (count < amt)
amt = count;
memcpy((char *)lz4->in_buffer + lz4->in_pos, buffer, amt);
lz4->in_pos += amt;
lz4->stream_pos += amt; lz4->stream_pos += amt;
return amt; return amt;
} }
INT S_glzwrite(glzFile glz, void *buffer, UINT count) {
switch (glz->format) {
case COMPRESS_GZIP:
return gzwrite(glz->gz, buffer, count);
case COMPRESS_LZ4:
return glzwrite_lz4(glz->lz4_out, buffer, count);
default:
S_error1("S_glzwrite", "unexpected compress format ~s", Sinteger(glz->format));
return -1;
} }
} }
long glzseek(glzFile file, long offset, int whence) { long S_glzseek(glzFile glz, long offset, INT whence) {
if (file->mode == is_gz) switch (glz->format) {
return gzseek(file->gz, offset, whence); case COMPRESS_GZIP:
else if (file->mode == is_lz4_write) { return gzseek(glz->gz, offset, whence);
lz4File_out *lz4 = (lz4File_out *)file->lz4; case COMPRESS_LZ4:
if (whence == SEEK_CUR) if (glz->inputp) {
offset += (long)lz4->stream_pos; lz4File_in *lz4 = glz->lz4_in;
if (offset >= 0) {
while ((size_t)offset > lz4->stream_pos) {
size_t amt = (size_t)offset - lz4->stream_pos;
if (amt > 8) amt = 8;
if (glzwrite(file, "\0\0\0\0\0\0\0\0", (unsigned int)amt) < 0)
return -1;
}
}
return (long)lz4->stream_pos;
} else if (file->mode == is_lz4_read) {
lz4File_in *lz4 = (lz4File_in *)file->lz4;
if (whence == SEEK_CUR) if (whence == SEEK_CUR)
offset += (long)lz4->stream_pos; offset += (long)lz4->stream_pos;
if (offset < 0) if (offset < 0)
@ -414,7 +549,7 @@ long glzseek(glzFile file, long offset, int whence) {
if ((size_t)offset < lz4->stream_pos) { if ((size_t)offset < lz4->stream_pos) {
/* rewind and read from start */ /* rewind and read from start */
if (WIN32_IZE(lseek)(lz4->fd, lz4->init_pos, SEEK_SET) < 0) { if (WIN32_IZE(lseek)(lz4->fd, lz4->init_pos, SEEK_SET) < 0) {
lz4->err = errno; lz4->err = Z_ERRNO;
return -1; return -1;
} }
LZ4F_resetDecompressionContext(lz4->dctx); LZ4F_resetDecompressionContext(lz4->dctx);
@ -429,37 +564,62 @@ long glzseek(glzFile file, long offset, int whence) {
char buffer[32]; char buffer[32];
size_t amt = (size_t)offset - lz4->stream_pos; size_t amt = (size_t)offset - lz4->stream_pos;
if (amt > sizeof(buffer)) amt = sizeof(buffer); if (amt > sizeof(buffer)) amt = sizeof(buffer);
if (glzread(file, buffer, (unsigned int)amt) < 0) if (glzread_lz4(lz4, buffer, (UINT)amt) < 0)
return -1; return -1;
} }
return (long)lz4->stream_pos; return (long)lz4->stream_pos;
} else } else {
return 0; lz4File_out *lz4 = glz->lz4_out;
} if (whence == SEEK_CUR)
offset += (long)lz4->stream_pos;
int glzgetc(glzFile file) { if (offset >= 0) {
if (file->mode == is_gz) while ((size_t)offset > lz4->stream_pos) {
return gzgetc(file->gz); size_t amt = (size_t)offset - lz4->stream_pos;
else { if (amt > 8) amt = 8;
unsigned char buffer[1]; if (glzwrite_lz4(lz4, "\0\0\0\0\0\0\0\0", (UINT)amt) < 0)
int r; return -1;
r = glzread(file, buffer, 1); }
if (r == 1) }
return buffer[0]; return (long)lz4->stream_pos;
}
default:
S_error1("S_glzseek", "unexpected compress format ~s", Sinteger(glz->format));
return -1; return -1;
} }
} }
int glzungetc(int c, glzFile file) { INT S_glzgetc(glzFile glz) {
if (file->mode == is_gz) switch (glz->format) {
return gzungetc(c, file->gz); case COMPRESS_GZIP:
else if (file->mode == is_lz4_read) { return gzgetc(glz->gz);
lz4File_in *lz4 = (lz4File_in *)file->lz4; case COMPRESS_LZ4:
{
unsigned char buffer[1];
INT r;
r = S_glzread(glz, buffer, 1);
if (r == 1)
return buffer[0];
else
return -1;
}
default:
S_error1("S_glzgetc", "unexpected compress format ~s", Sinteger(glz->format));
return -1;
}
}
INT S_glzungetc(INT c, glzFile glz) {
switch (glz->format) {
case COMPRESS_GZIP:
return gzungetc(c, glz->gz);
case COMPRESS_LZ4:
{
lz4File_in *lz4 = glz->lz4_in;
if (lz4->out_len == 0) if (lz4->out_len == 0)
lz4->out_len = lz4->out_pos = 1; lz4->out_len = lz4->out_pos = 1;
if (lz4->out_pos) { if (lz4->out_pos) {
lz4->out_pos--; lz4->out_pos--;
((unsigned char *)lz4->out_buffer)[lz4->out_pos] = c; lz4->out_buffer[lz4->out_pos] = c;
lz4->stream_pos--; lz4->stream_pos--;
return c; return c;
} else { } else {
@ -467,32 +627,46 @@ int glzungetc(int c, glzFile file) {
should have been room */ should have been room */
return -1; return -1;
} }
} else }
default:
S_error1("S_glzungetc", "unexpected compress format ~s", Sinteger(glz->format));
return -1; return -1;
}
} }
int glzrewind(glzFile file) { INT S_glzrewind(glzFile glz) {
return glzseek(file, 0, SEEK_SET); return S_glzseek(glz, 0, SEEK_SET);
} }
void glzerror(glzFile file, int *errnum) void S_glzerror(glzFile glz, INT *errnum) {
{ switch (glz->format) {
if (file->mode == is_gz) case COMPRESS_GZIP:
(void)gzerror(file->gz, errnum); (void)gzerror(glz->gz, errnum);
else if (file->mode == is_lz4_write) break;
*errnum = ((lz4File_out *)file->lz4)->err; case COMPRESS_LZ4:
else if (file->mode == is_lz4_read) if (glz->inputp)
*errnum = ((lz4File_in *)file->lz4)->err; *errnum = glz->lz4_in->err;
else else
*errnum = glz->lz4_out->err;
break;
default:
S_error1("S_glzerror", "unexpected compress format ~s", Sinteger(glz->format));
*errnum = 0; *errnum = 0;
}
} }
void glzclearerr(glzFile file) void S_glzclearerr(glzFile glz) {
{ switch (glz->format) {
if (file->mode == is_gz) case COMPRESS_GZIP:
gzclearerr(file->gz); gzclearerr(glz->gz);
else if (file->mode == is_lz4_write) break;
((lz4File_out *)file->lz4)->err = 0; case COMPRESS_LZ4:
else if (file->mode == is_lz4_read) if (glz->inputp)
((lz4File_in *)file->lz4)->err = 0; glz->lz4_in->err = 0;
else
glz->lz4_out->err = 0;
break;
default:
S_error1("S_glzerror", "unexpected compress format ~s", Sinteger(glz->format));
}
} }

35
c/compress-io.h
View File

@ -1,5 +1,5 @@
/* compress-io.h /* compress-io.h
* Copyright 1984-2017 Cisco Systems, Inc. * Copyright 1984-2019 Cisco Systems, Inc.
* *
* Licensed under the Apache License, Version 2.0 (the "License"); * Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License. * you may not use this file except in compliance with the License.
@ -14,34 +14,13 @@
* limitations under the License. * limitations under the License.
*/ */
#include "zlib.h"
struct lz4File;
typedef struct glzFile_r { typedef struct glzFile_r {
int mode; INT fd;
IBOOL inputp;
INT format;
union { union {
gzFile gz; struct gzFile_s *gz;
struct lz4File *lz4; struct lz4File_in_r *lz4_in;
struct lz4File_out_r *lz4_out;
}; };
} *glzFile; } *glzFile;
glzFile glzdopen_gz(int fd, const char *mode);
glzFile glzdopen_lz4(int fd, const char *mode);
glzFile glzdopen(int fd, const char *mode);
glzFile glzopen(const char *path, const char *mode);
#ifdef WIN32
glzFile glzopen_w(wchar_t *path, const char *mode);
#endif
int glzdirect(glzFile file);
int glzclose(glzFile file);
int glzread(glzFile file, void *buffer, unsigned int count);
int glzwrite(glzFile file, void *buffer, unsigned int count);
long glzseek(glzFile file, long offset, int whence);
int glzgetc(glzFile file);
int glzungetc(int c, glzFile file);
int glzrewind(glzFile file);
void glzerror(glzFile file, int *errnum);
void glzclearerr(glzFile fdfile);

31
c/externs.h
View File

@ -169,6 +169,27 @@ extern wchar_t *S_malloc_wide_pathname PROTO((const char *inpath));
#endif #endif
extern IBOOL S_fixedpathp PROTO((const char *inpath)); extern IBOOL S_fixedpathp PROTO((const char *inpath));
/* compress-io.c */
extern glzFile S_glzdopen_output PROTO((INT fd, INT compress_format, INT compress_level));
extern glzFile S_glzdopen_input PROTO((INT fd));
extern glzFile S_glzopen_input PROTO((const char *path));
#ifdef WIN32
extern glzFile S_glzopen_input_w PROTO((const wchar_t *path));
#endif
extern IBOOL S_glzdirect PROTO((glzFile file));
extern INT S_glzclose PROTO((glzFile file));
extern INT S_glzread PROTO((glzFile file, void *buffer, UINT count));
extern INT S_glzwrite PROTO((glzFile file, void *buffer, UINT count));
extern long S_glzseek PROTO((glzFile file, long offset, INT whence));
extern INT S_glzgetc PROTO((glzFile file));
extern INT S_glzungetc PROTO((INT c, glzFile file));
extern INT S_glzrewind PROTO((glzFile file));
extern void S_glzerror PROTO((glzFile file, INT *errnum));
extern void S_glzclearerr PROTO((glzFile fdfile));
/* new-io.c */ /* new-io.c */
extern INT S_gzxfile_fd PROTO((ptr x)); extern INT S_gzxfile_fd PROTO((ptr x));
extern glzFile S_gzxfile_gzfile PROTO((ptr x)); extern glzFile S_gzxfile_gzfile PROTO((ptr x));
@ -176,14 +197,14 @@ extern ptr S_new_open_input_fd PROTO((const char *filename, IBOOL compressed));
extern ptr S_new_open_output_fd PROTO(( extern ptr S_new_open_output_fd PROTO((
const char *filename, INT mode, const char *filename, INT mode,
IBOOL no_create, IBOOL no_fail, IBOOL no_truncate, IBOOL no_create, IBOOL no_fail, IBOOL no_truncate,
IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed, IBOOL as_gz)); IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed));
extern ptr S_new_open_input_output_fd PROTO(( extern ptr S_new_open_input_output_fd PROTO((
const char *filename, INT mode, const char *filename, INT mode,
IBOOL no_create, IBOOL no_fail, IBOOL no_truncate, IBOOL no_create, IBOOL no_fail, IBOOL no_truncate,
IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed)); IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed));
extern ptr S_close_fd PROTO((ptr file, IBOOL gzflag)); extern ptr S_close_fd PROTO((ptr file, IBOOL gzflag));
extern ptr S_compress_input_fd PROTO((INT fd, I64 fp)); extern ptr S_compress_input_fd PROTO((INT fd, I64 fp));
extern ptr S_compress_output_fd PROTO((INT fd, IBOOL as_gz)); extern ptr S_compress_output_fd PROTO((INT fd));
extern ptr S_bytevector_read PROTO((ptr file, ptr buffer, iptr start, iptr count, IBOOL gzflag)); extern ptr S_bytevector_read PROTO((ptr file, ptr buffer, iptr start, iptr count, IBOOL gzflag));
extern ptr S_bytevector_read_nb PROTO((ptr file, ptr buffer, iptr start, iptr count, IBOOL gzflag)); extern ptr S_bytevector_read_nb PROTO((ptr file, ptr buffer, iptr start, iptr count, IBOOL gzflag));
@ -198,13 +219,13 @@ extern ptr S_get_fd_length PROTO((ptr file, IBOOL gzflag));
extern ptr S_set_fd_length PROTO((ptr file, ptr length, IBOOL gzflag)); extern ptr S_set_fd_length PROTO((ptr file, ptr length, IBOOL gzflag));
extern void S_new_io_init PROTO((void)); extern void S_new_io_init PROTO((void));
extern uptr S_bytevector_compress_size PROTO((iptr s_count, IBOOL as_gz)); extern uptr S_bytevector_compress_size PROTO((iptr s_count, INT compress_format));
extern ptr S_bytevector_compress PROTO((ptr dest_bv, iptr d_start, iptr d_count, extern ptr S_bytevector_compress PROTO((ptr dest_bv, iptr d_start, iptr d_count,
ptr src_bv, iptr s_start, iptr s_count, ptr src_bv, iptr s_start, iptr s_count,
IBOOL as_gz)); INT compress_format));
extern ptr S_bytevector_uncompress PROTO((ptr dest_bv, iptr d_start, iptr d_count, extern ptr S_bytevector_uncompress PROTO((ptr dest_bv, iptr d_start, iptr d_count,
ptr src_bv, iptr s_start, iptr s_count, ptr src_bv, iptr s_start, iptr s_count,
IBOOL as_gz)); INT compress_format));
/* thread.c */ /* thread.c */
extern void S_thread_init PROTO((void)); extern void S_thread_init PROTO((void));

7
c/fasl.c
View File

@ -177,6 +177,7 @@
*/ */
#include "system.h" #include "system.h"
#include "zlib.h"
#ifdef WIN32 #ifdef WIN32
#include <io.h> #include <io.h>
@ -346,14 +347,14 @@ static INT uf_read(unbufFaslFile uf, octet *s, iptr n) {
switch (uf->type) { switch (uf->type) {
case UFFO_TYPE_GZ: case UFFO_TYPE_GZ:
k = glzread(uf->file, s, (GZ_IO_SIZE_T)nx); k = S_glzread(uf->file, s, (GZ_IO_SIZE_T)nx);
if (k > 0) if (k > 0)
n -= k; n -= k;
else if (k == 0) else if (k == 0)
return -1; return -1;
else { else {
glzerror(uf->file, &errnum); S_glzerror(uf->file, &errnum);
glzclearerr(uf->file); S_glzclearerr(uf->file);
if (errnum != Z_ERRNO || errno != EINTR) if (errnum != Z_ERRNO || errno != EINTR)
S_error1("", "error reading from ~a", uf->path); S_error1("", "error reading from ~a", uf->path);
} }

3
c/gc.c
View File

@ -1515,6 +1515,9 @@ static void sweep_thread(p) ptr p; {
/* immediate SUPPRESSPRIMITIVEINLINING */ /* immediate SUPPRESSPRIMITIVEINLINING */
relocate(&DEFAULTRECORDEQUALPROCEDURE(tc)) relocate(&DEFAULTRECORDEQUALPROCEDURE(tc))
relocate(&DEFAULTRECORDHASHPROCEDURE(tc)) relocate(&DEFAULTRECORDHASHPROCEDURE(tc))
relocate(&COMPRESSFORMAT(tc))
relocate(&COMPRESSLEVEL(tc))
/* void* LZ4OUTBUFFER(tc) */
/* U64 INSTRCOUNTER(tc) */ /* U64 INSTRCOUNTER(tc) */
/* U64 ALLOCCOUNTER(tc) */ /* U64 ALLOCCOUNTER(tc) */
relocate(&PARAMETERS(tc)) relocate(&PARAMETERS(tc))

155
c/new-io.c
View File

@ -52,9 +52,8 @@
/* locally defined functions */ /* locally defined functions */
static ptr new_open_output_fd_helper PROTO((const char *filename, INT mode, static ptr new_open_output_fd_helper PROTO((const char *filename, INT mode,
INT flags, INT no_create, INT no_fail, INT no_truncate, INT flags, INT no_create, INT no_fail, INT no_truncate,
INT append, INT lock, INT replace, INT compressed, INT as_gz)); INT append, INT lock, INT replace, INT compressed));
static INT lockfile PROTO((INT fd)); static INT lockfile PROTO((INT fd));
static ptr make_gzxfile PROTO((int fd, glzFile file));
static int is_valid_zlib_length(iptr count); static int is_valid_zlib_length(iptr count);
static int is_valid_lz4_length(iptr count); static int is_valid_lz4_length(iptr count);
@ -78,8 +77,8 @@ static int is_valid_lz4_length(iptr count);
if (ok) { flag = 0; } \ if (ok) { flag = 0; } \
else { \ else { \
INT errnum; \ INT errnum; \
glzerror((fd),&errnum); \ S_glzerror((fd),&errnum); \
glzclearerr((fd)); \ S_glzclearerr((fd)); \
if (errnum == Z_ERRNO) { \ if (errnum == Z_ERRNO) { \
flag = errno != EINTR; \ flag = errno != EINTR; \
} else { \ } else { \
@ -99,8 +98,8 @@ static int is_valid_lz4_length(iptr count);
if (ok) { flag = 0; break; } \ if (ok) { flag = 0; break; } \
else { \ else { \
INT errnum; \ INT errnum; \
glzerror((fd),&errnum); \ S_glzerror((fd),&errnum); \
glzclearerr((fd)); \ S_glzclearerr((fd)); \
if (errnum == Z_ERRNO) { \ if (errnum == Z_ERRNO) { \
if (errno != EINTR) { flag = 1; break; } \ if (errno != EINTR) { flag = 1; break; } \
} else { \ } else { \
@ -117,8 +116,8 @@ static int is_valid_lz4_length(iptr count);
if (ok) { flag = 0; } \ if (ok) { flag = 0; } \
else { \ else { \
INT errnum; \ INT errnum; \
glzerror((fd),&errnum); \ S_glzerror((fd),&errnum); \
glzclearerr((fd)); \ S_glzclearerr((fd)); \
if (errnum == Z_ERRNO) { flag = 1; } \ if (errnum == Z_ERRNO) { flag = 1; } \
else { \ else { \
flag = not_ok_is_fatal || errnum != Z_OK; \ flag = not_ok_is_fatal || errnum != Z_OK; \
@ -145,26 +144,15 @@ static INT lockfile(INT fd) { return FLOCK(fd, LOCK_EX); }
static INT lockfile(INT fd) { return lockf(fd, F_LOCK, (off_t)0); } static INT lockfile(INT fd) { return lockf(fd, F_LOCK, (off_t)0); }
#endif #endif
/* work around missing zlib API operation to extract a glzFile's fd */ #define MAKE_GZXFILE(x) Sinteger((iptr)x)
typedef struct { #define GZXFILE_GZFILE(x) ((glzFile)Sinteger_value(x))
int fd;
glzFile file;
} gzxfile;
#define gzxfile_fd(x) (((gzxfile *)&BVIT(x,0))->fd)
#define gzxfile_gzfile(x) (((gzxfile *)&BVIT(x,0))->file)
static ptr make_gzxfile(int fd, glzFile file) {
ptr bv;
bv = S_bytevector(sizeof(gzxfile));
gzxfile_fd(bv) = fd;
gzxfile_gzfile(bv) = file;
return bv;
}
INT S_gzxfile_fd(ptr x) { INT S_gzxfile_fd(ptr x) {
return gzxfile_fd(x); return GZXFILE_GZFILE(x)->fd;
} }
glzFile S_gzxfile_gzfile(ptr x) { glzFile S_gzxfile_gzfile(ptr x) {
return gzxfile_gzfile(x); return GZXFILE_GZFILE(x);
} }
ptr S_new_open_input_fd(const char *infilename, IBOOL compressed) { ptr S_new_open_input_fd(const char *infilename, IBOOL compressed) {
@ -209,25 +197,26 @@ ptr S_new_open_input_fd(const char *infilename, IBOOL compressed) {
return Scons(FIX(OPEN_ERROR_OTHER), str); return Scons(FIX(OPEN_ERROR_OTHER), str);
} }
if ((file = glzdopen(dupfd, "rb")) == Z_NULL) { DEACTIVATE(tc) /* glzdopen_input reads the magic word from the file */
if ((file = S_glzdopen_input(dupfd)) == Z_NULL) {
REACTIVATE(tc)
FD_GUARD(result == 0, error, result = CLOSE(fd)); FD_GUARD(result == 0, error, result = CLOSE(fd));
FD_GUARD(result == 0, error, result = CLOSE(dupfd)); FD_GUARD(result == 0, error, result = CLOSE(dupfd));
return Scons(FIX(OPEN_ERROR_OTHER), Sstring("unable to allocate compression state (too many open files?)")); return Scons(FIX(OPEN_ERROR_OTHER), Sstring("unable to allocate compression state (too many open files?)"));
} }
DEACTIVATE(tc) compressed = !S_glzdirect(file);
compressed = !glzdirect(file);
REACTIVATE(tc) REACTIVATE(tc)
if (compressed) { if (compressed) {
FD_GUARD(result == 0, error, result = CLOSE(fd)); FD_GUARD(result == 0, error, result = CLOSE(fd));
/* box indicates gzip'd */ /* box indicates compressed */
return Sbox(make_gzxfile(dupfd, file)); return Sbox(MAKE_GZXFILE(file));
} }
GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, file, ok = glzclose(file)); GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, file, ok = S_glzclose(file));
if (flag) {} /* make the compiler happy */ if (flag) {} /* make the compiler happy */
if (LSEEK(fd, 0, SEEK_SET) != 0) { /* glzdirect does not leave fd at position 0 */ if (LSEEK(fd, 0, SEEK_SET) != 0) { /* glzdopen and glzdirect might not leave fd at position 0 */
FD_GUARD(result == 0, error, result = CLOSE(fd)); FD_GUARD(result == 0, error, result = CLOSE(fd));
return Scons(FIX(OPEN_ERROR_OTHER),Sstring("unable to reset after reading header bytes")); return Scons(FIX(OPEN_ERROR_OTHER),Sstring("unable to reset after reading header bytes"));
} }
@ -245,22 +234,24 @@ ptr S_compress_input_fd(INT fd, I64 pos) {
return S_strerror(errno); return S_strerror(errno);
} }
if ((file = glzdopen(dupfd, "rb")) == Z_NULL) { DEACTIVATE(tc)
if ((file = S_glzdopen_input(dupfd)) == Z_NULL) {
REACTIVATE(tc)
FD_GUARD(result == 0, error, result = CLOSE(dupfd)); FD_GUARD(result == 0, error, result = CLOSE(dupfd));
return Sstring("unable to allocate compression state (too many open files?)"); return Sstring("unable to allocate compression state (too many open files?)");
} }
DEACTIVATE(tc) compressed = !S_glzdirect(file);
compressed = !glzdirect(file);
REACTIVATE(tc) REACTIVATE(tc)
if (compressed) { if (compressed) {
FD_GUARD(result == 0, error, result = CLOSE(fd)); FD_GUARD(result == 0, error, result = CLOSE(fd));
if (error) {} /* make the compiler happy */ if (error) {} /* make the compiler happy */
return Sbox(make_gzxfile(dupfd, file)); /* box indicates compressed */
return Sbox(MAKE_GZXFILE(file));
} }
GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, file, ok = glzclose(file)); GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, file, ok = S_glzclose(file));
if (flag) {} /* make the compiler happy */ if (flag) {} /* make the compiler happy */
if (LSEEK(fd, pos, SEEK_SET) != pos) { /* glzdirect does not leave fd at same position */ if (LSEEK(fd, pos, SEEK_SET) != pos) { /* glzdirect does not leave fd at same position */
return Sstring("unable to reset after reading header bytes"); return Sstring("unable to reset after reading header bytes");
@ -268,38 +259,28 @@ ptr S_compress_input_fd(INT fd, I64 pos) {
return MAKE_FD(fd); return MAKE_FD(fd);
} }
ptr S_compress_output_fd(INT fd, IBOOL as_gz) { ptr S_compress_output_fd(INT fd) {
glzFile file; glzFile file;
int as_append; ptr tc = get_thread_context();
#ifdef WIN32 file = S_glzdopen_output(fd, (INT)UNFIX(COMPRESSFORMAT(tc)), (INT)UNFIX(COMPRESSLEVEL(tc)));
as_append = 0;
#else
as_append = fcntl(fd, F_GETFL) & O_APPEND;
#endif
if (as_gz)
file = glzdopen_gz(fd, as_append ? "ab" : "wb");
else
file = glzdopen_lz4(fd, as_append ? "ab" : "wb");
if (file == Z_NULL) if (file == Z_NULL)
return Sstring("unable to allocate compression state (too many open files?)"); return Sstring("unable to allocate compression state (too many open files?)");
return Sbox(make_gzxfile(fd, file)); /* box indicates compressed */
return Sbox(MAKE_GZXFILE(file));
} }
static ptr new_open_output_fd_helper( static ptr new_open_output_fd_helper(
const char *infilename, INT mode, INT flags, const char *infilename, INT mode, INT flags,
IBOOL no_create, IBOOL no_fail, IBOOL no_truncate, IBOOL no_create, IBOOL no_fail, IBOOL no_truncate,
IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed, IBOOL as_gz) { IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed) {
char *filename; char *filename;
INT saved_errno = 0; INT saved_errno = 0;
iptr error; iptr error;
INT fd, result; INT fd, result;
#ifdef PTHREADS
ptr tc = get_thread_context(); ptr tc = get_thread_context();
#endif
flags |= flags |=
(no_create ? 0 : O_CREAT) | (no_create ? 0 : O_CREAT) |
@ -358,26 +339,23 @@ static ptr new_open_output_fd_helper(
} }
glzFile file; glzFile file;
if (as_gz) file = S_glzdopen_output(fd, (INT)UNFIX(COMPRESSFORMAT(tc)), (INT)UNFIX(COMPRESSLEVEL(tc)));
file = glzdopen_gz(fd, append ? "ab" : "wb");
else
file = glzdopen_lz4(fd, append ? "ab" : "wb");
if (file == Z_NULL) { if (file == Z_NULL) {
FD_GUARD(result == 0, error, result = CLOSE(fd)); FD_GUARD(result == 0, error, result = CLOSE(fd));
return Scons(FIX(OPEN_ERROR_OTHER), Sstring("unable to allocate compression state")); return Scons(FIX(OPEN_ERROR_OTHER), Sstring("unable to allocate compression state"));
} }
return make_gzxfile(fd, file); return MAKE_GZXFILE(file);
} }
ptr S_new_open_output_fd( ptr S_new_open_output_fd(
const char *filename, INT mode, const char *filename, INT mode,
IBOOL no_create, IBOOL no_fail, IBOOL no_truncate, IBOOL no_create, IBOOL no_fail, IBOOL no_truncate,
IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed, IBOOL as_gz) { IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed) {
return new_open_output_fd_helper( return new_open_output_fd_helper(
filename, mode, O_BINARY | O_WRONLY, filename, mode, O_BINARY | O_WRONLY,
no_create, no_fail, no_truncate, no_create, no_fail, no_truncate,
append, lock, replace, compressed, as_gz); append, lock, replace, compressed);
} }
ptr S_new_open_input_output_fd( ptr S_new_open_input_output_fd(
@ -390,14 +368,14 @@ ptr S_new_open_input_output_fd(
return new_open_output_fd_helper( return new_open_output_fd_helper(
filename, mode, O_BINARY | O_RDWR, filename, mode, O_BINARY | O_RDWR,
no_create, no_fail, no_truncate, no_create, no_fail, no_truncate,
append, lock, replace, compressed, 0); append, lock, replace, 0);
} }
ptr S_close_fd(ptr file, IBOOL gzflag) { ptr S_close_fd(ptr file, IBOOL gzflag) {
INT saved_errno = 0; INT saved_errno = 0;
INT ok, flag; INT ok, flag;
INT fd = gzflag ? 0 : GET_FD(file); INT fd = gzflag ? 0 : GET_FD(file);
glzFile gzfile = gzflag ? gzxfile_gzfile(file) : NULL; glzFile gzfile = gzflag ? GZXFILE_GZFILE(file) : NULL;
#ifdef PTHREADS #ifdef PTHREADS
ptr tc = get_thread_context(); ptr tc = get_thread_context();
#endif #endif
@ -414,7 +392,7 @@ ptr S_close_fd(ptr file, IBOOL gzflag) {
FD_GUARD(ok == 0, flag, ok = CLOSE(fd)); FD_GUARD(ok == 0, flag, ok = CLOSE(fd));
} else { } else {
/* zlib 1.2.1 returns Z_BUF_ERROR when closing an empty file opened for reading */ /* zlib 1.2.1 returns Z_BUF_ERROR when closing an empty file opened for reading */
GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, gzfile, ok = glzclose(gzfile)); GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, gzfile, ok = S_glzclose(gzfile));
} }
saved_errno = errno; saved_errno = errno;
REACTIVATE(tc) REACTIVATE(tc)
@ -444,7 +422,7 @@ ptr S_bytevector_read(ptr file, ptr bv, iptr start, iptr count, IBOOL gzflag) {
ptr tc = get_thread_context(); ptr tc = get_thread_context();
iptr m, flag = 0; iptr m, flag = 0;
INT fd = gzflag ? 0 : GET_FD(file); INT fd = gzflag ? 0 : GET_FD(file);
glzFile gzfile = gzflag ? gzxfile_gzfile(file) : NULL; glzFile gzfile = gzflag ? GZXFILE_GZFILE(file) : NULL;
/* file is not locked; do not reference after deactivating thread! */ /* file is not locked; do not reference after deactivating thread! */
file = (ptr)-1; file = (ptr)-1;
@ -477,7 +455,7 @@ ptr S_bytevector_read(ptr file, ptr bv, iptr start, iptr count, IBOOL gzflag) {
GZ_EINTR_GUARD( GZ_EINTR_GUARD(
1, m >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)), 1, m >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)),
flag, gzfile, flag, gzfile,
m = glzread(gzfile, &BVIT(bv,start), (GZ_IO_SIZE_T)count)); m = S_glzread(gzfile, &BVIT(bv,start), (GZ_IO_SIZE_T)count));
} }
} }
saved_errno = errno; saved_errno = errno;
@ -561,7 +539,7 @@ ptr S_bytevector_write(ptr file, ptr bv, iptr start, iptr count, IBOOL gzflag) {
ptr tc = get_thread_context(); ptr tc = get_thread_context();
INT flag = 0, saved_errno = 0; INT flag = 0, saved_errno = 0;
INT fd = gzflag ? 0 : GET_FD(file); INT fd = gzflag ? 0 : GET_FD(file);
glzFile gzfile = gzflag ? gzxfile_gzfile(file) : NULL; glzFile gzfile = gzflag ? GZXFILE_GZFILE(file) : NULL;
for (s = start, c = count; c > 0; s += i, c -= i) { for (s = start, c = count; c > 0; s += i, c -= i) {
iptr cx = c; iptr cx = c;
@ -579,7 +557,7 @@ ptr S_bytevector_write(ptr file, ptr bv, iptr start, iptr count, IBOOL gzflag) {
GZ_EINTR_GUARD( GZ_EINTR_GUARD(
i < 0, i > 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)), i < 0, i > 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)),
flag, gzfile, flag, gzfile,
i = glzwrite(gzfile, &BVIT(bv,s), (GZ_IO_SIZE_T)cx)); i = S_glzwrite(gzfile, &BVIT(bv,s), (GZ_IO_SIZE_T)cx));
} else { } else {
FD_EINTR_GUARD(i >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)), FD_EINTR_GUARD(i >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)),
flag, i = WRITE(fd, &BVIT(bv,s), (IO_SIZE_T)cx)); flag, i = WRITE(fd, &BVIT(bv,s), (IO_SIZE_T)cx));
@ -623,7 +601,7 @@ ptr S_put_byte(ptr file, INT byte, IBOOL gzflag) {
ptr tc = get_thread_context(); ptr tc = get_thread_context();
INT flag = 0, saved_errno = 0; INT flag = 0, saved_errno = 0;
INT fd = gzflag ? 0 : GET_FD(file); INT fd = gzflag ? 0 : GET_FD(file);
glzFile gzfile = gzflag ? gzxfile_gzfile(file) : NULL; glzFile gzfile = gzflag ? GZXFILE_GZFILE(file) : NULL;
octet buf[1]; octet buf[1];
buf[0] = (octet)byte; buf[0] = (octet)byte;
@ -634,7 +612,7 @@ ptr S_put_byte(ptr file, INT byte, IBOOL gzflag) {
GZ_EINTR_GUARD( GZ_EINTR_GUARD(
i < 0, i > 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)), i < 0, i > 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)),
flag, gzfile, flag, gzfile,
i = glzwrite(gzfile, buf, 1)); i = S_glzwrite(gzfile, buf, 1));
} else { } else {
FD_EINTR_GUARD(i >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)), FD_EINTR_GUARD(i >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)),
flag, i = WRITE(fd, buf, 1)); flag, i = WRITE(fd, buf, 1));
@ -664,7 +642,7 @@ ptr S_put_byte(ptr file, INT byte, IBOOL gzflag) {
ptr S_get_fd_pos(ptr file, IBOOL gzflag) { ptr S_get_fd_pos(ptr file, IBOOL gzflag) {
errno = 0; errno = 0;
if (gzflag) { if (gzflag) {
z_off_t offset = glzseek(gzxfile_gzfile(file), 0, SEEK_CUR); z_off_t offset = S_glzseek(GZXFILE_GZFILE(file), 0, SEEK_CUR);
if (offset != -1) return Sinteger64(offset); if (offset != -1) return Sinteger64(offset);
} else { } else {
OFF_T offset = LSEEK(GET_FD(file), 0, SEEK_CUR); OFF_T offset = LSEEK(GET_FD(file), 0, SEEK_CUR);
@ -683,7 +661,7 @@ ptr S_set_fd_pos(ptr file, ptr pos, IBOOL gzflag) {
if (sizeof(z_off_t) != sizeof(I64)) if (sizeof(z_off_t) != sizeof(I64))
if (offset != offset64) return Sstring("invalid position"); if (offset != offset64) return Sstring("invalid position");
errno = 0; errno = 0;
if (glzseek(gzxfile_gzfile(file),offset,SEEK_SET) == offset) return Strue; if (S_glzseek(GZXFILE_GZFILE(file),offset,SEEK_SET) == offset) return Strue;
if (errno == 0) return Sstring("compression failed"); if (errno == 0) return Sstring("compression failed");
return S_strerror(errno); return S_strerror(errno);
} else { } else {
@ -811,29 +789,35 @@ static int is_valid_lz4_length(iptr len) {
/* Accept `iptr` because we expect it to represent a bytevector size, /* Accept `iptr` because we expect it to represent a bytevector size,
which always fits in `iptr`. Return `uptr`, because the result might which always fits in `iptr`. Return `uptr`, because the result might
not fit in `iptr`. */ not fit in `iptr`. */
uptr S_bytevector_compress_size(iptr s_count, IBOOL as_gz) { uptr S_bytevector_compress_size(iptr s_count, INT compress_format) {
if (as_gz) { switch (compress_format) {
case COMPRESS_GZIP:
if (is_valid_zlib_length(s_count)) if (is_valid_zlib_length(s_count))
return compressBound((uLong)s_count); return compressBound((uLong)s_count);
else { else {
/* Compression will report "source too long" */ /* Compression will report "source too long" */
return 0; return 0;
} }
} else { case COMPRESS_LZ4:
if (is_valid_lz4_length(s_count)) if (is_valid_lz4_length(s_count))
return LZ4_compressBound((uLong)s_count); return LZ4_compressBound((uLong)s_count);
else { else {
/* Compression will report "source too long" */ /* Compression will report "source too long" */
return 0; return 0;
} }
default:
S_error1("S_bytevector_compress_size", "unexpected compress format ~s", FIX(compress_format));
return 0;
} }
} }
ptr S_bytevector_compress(ptr dest_bv, iptr d_start, iptr d_count, ptr S_bytevector_compress(ptr dest_bv, iptr d_start, iptr d_count,
ptr src_bv, iptr s_start, iptr s_count, ptr src_bv, iptr s_start, iptr s_count,
IBOOL as_gz) { INT compress_format) {
/* On error, an message-template string with ~s for the bytevector */ /* On error, an message-template string with ~s for the bytevector */
if (as_gz) { switch (compress_format) {
case COMPRESS_GZIP:
{
int r; int r;
uLong destLen; uLong destLen;
@ -850,7 +834,9 @@ ptr S_bytevector_compress(ptr dest_bv, iptr d_start, iptr d_count,
return Sstring("destination bytevector is too small for compressed form of ~s"); return Sstring("destination bytevector is too small for compressed form of ~s");
else else
return Sstring("internal error compressing ~s"); return Sstring("internal error compressing ~s");
} else { }
case COMPRESS_LZ4:
{
int destLen; int destLen;
if (!is_valid_lz4_length(s_count)) if (!is_valid_lz4_length(s_count))
@ -865,13 +851,19 @@ ptr S_bytevector_compress(ptr dest_bv, iptr d_start, iptr d_count,
else else
return Sstring("compression failed for ~s"); return Sstring("compression failed for ~s");
} }
default:
S_error1("S_bytevector_compress", "unexpected compress format ~s", FIX(compress_format));
return Sfalse;
}
} }
ptr S_bytevector_uncompress(ptr dest_bv, iptr d_start, iptr d_count, ptr S_bytevector_uncompress(ptr dest_bv, iptr d_start, iptr d_count,
ptr src_bv, iptr s_start, iptr s_count, ptr src_bv, iptr s_start, iptr s_count,
IBOOL as_gz) { INT compress_format) {
/* On error, an message-template string with ~s for the bytevector */ /* On error, an message-template string with ~s for the bytevector */
if (as_gz) { switch (compress_format) {
case COMPRESS_GZIP:
{
int r; int r;
uLongf destLen; uLongf destLen;
@ -890,7 +882,9 @@ ptr S_bytevector_uncompress(ptr dest_bv, iptr d_start, iptr d_count,
return Sstring("invalid data in source bytevector ~s"); return Sstring("invalid data in source bytevector ~s");
else else
return Sstring("internal error uncompressing ~s"); return Sstring("internal error uncompressing ~s");
} else { }
case COMPRESS_LZ4:
{
int r; int r;
if (!is_valid_lz4_length(d_count)) if (!is_valid_lz4_length(d_count))
@ -903,4 +897,7 @@ ptr S_bytevector_uncompress(ptr dest_bv, iptr d_start, iptr d_count,
else else
return Sstring("internal error uncompressing ~s"); return Sstring("internal error uncompressing ~s");
} }
default:
return Sstring("unepxected compress format ~s");
}
} }

106
c/scheme.c
View File

@ -585,17 +585,17 @@ static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IB
path = name; path = name;
if (fd != -1) { if (fd != -1) {
file = glzdopen(fd, "rb"); file = S_glzdopen_input(fd);
} else { } else {
#ifdef WIN32 #ifdef WIN32
expandedpath = S_malloc_wide_pathname(path); expandedpath = S_malloc_wide_pathname(path);
file = glzopen_w(expandedpath, "rb"); file = S_glzopen_input_w(expandedpath);
#else #else
expandedpath = S_malloc_pathname(path); expandedpath = S_malloc_pathname(path);
file = glzopen(expandedpath, "rb"); file = S_glzopen_input(expandedpath);
#endif #endif
/* assumption (seemingly true based on a glance at the source code): /* assumption (seemingly true based on a glance at the source code):
glzopen doesn't squirrel away a pointer to expandedpath. */ S_glzopen_input doesn't squirrel away a pointer to expandedpath. */
free(expandedpath); free(expandedpath);
} }
@ -611,14 +611,14 @@ static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IB
if (verbose) fprintf(stderr, "trying %s...opened\n", path); if (verbose) fprintf(stderr, "trying %s...opened\n", path);
/* check for magic number */ /* check for magic number */
if (glzgetc(file) != fasl_type_header || if (S_glzgetc(file) != fasl_type_header ||
glzgetc(file) != 0 || S_glzgetc(file) != 0 ||
glzgetc(file) != 0 || S_glzgetc(file) != 0 ||
glzgetc(file) != 0 || S_glzgetc(file) != 0 ||
glzgetc(file) != 'c' || S_glzgetc(file) != 'c' ||
glzgetc(file) != 'h' || S_glzgetc(file) != 'h' ||
glzgetc(file) != 'e' || S_glzgetc(file) != 'e' ||
glzgetc(file) != 'z') { S_glzgetc(file) != 'z') {
fprintf(stderr, "malformed fasl-object header in %s\n", path); fprintf(stderr, "malformed fasl-object header in %s\n", path);
S_abnormal_exit(); S_abnormal_exit();
} }
@ -626,7 +626,7 @@ static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IB
/* check version */ /* check version */
if (zget_uptr(file, &n) != 0) { if (zget_uptr(file, &n) != 0) {
fprintf(stderr, "unexpected end of file on %s\n", path); fprintf(stderr, "unexpected end of file on %s\n", path);
glzclose(file); S_glzclose(file);
S_abnormal_exit(); S_abnormal_exit();
} }
@ -634,21 +634,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)); fprintf(stderr, "%s is for Version %s; ", path, S_format_scheme_version(n));
/* use separate fprintf since S_format_scheme_version returns static string */ /* use separate fprintf since S_format_scheme_version returns static string */
fprintf(stderr, "need Version %s\n", S_format_scheme_version(scheme_version)); fprintf(stderr, "need Version %s\n", S_format_scheme_version(scheme_version));
glzclose(file); S_glzclose(file);
S_abnormal_exit(); S_abnormal_exit();
} }
/* check machine type */ /* check machine type */
if (zget_uptr(file, &n) != 0) { if (zget_uptr(file, &n) != 0) {
fprintf(stderr, "unexpected end of file on %s\n", path); fprintf(stderr, "unexpected end of file on %s\n", path);
glzclose(file); S_glzclose(file);
S_abnormal_exit(); S_abnormal_exit();
} }
if (n != machine_type) { if (n != machine_type) {
fprintf(stderr, "%s is for machine-type %s; need machine-type %s\n", path, 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_lookup_machine_type(n), S_lookup_machine_type(machine_type));
glzclose(file); S_glzclose(file);
S_abnormal_exit(); S_abnormal_exit();
} }
} else { } else {
@ -671,13 +671,13 @@ static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IB
#ifdef WIN32 #ifdef WIN32
expandedpath = S_malloc_wide_pathname(path); expandedpath = S_malloc_wide_pathname(path);
file = glzopen_w(expandedpath, "rb"); file = S_glzopen_input_w(expandedpath);
#else #else
expandedpath = S_malloc_pathname(path); expandedpath = S_malloc_pathname(path);
file = glzopen(expandedpath, "rb"); file = S_glzopen_input(expandedpath);
#endif #endif
/* assumption (seemingly true based on a glance at the source code): /* assumption (seemingly true based on a glance at the source code):
glzopen doesn't squirrel away a pointer to expandedpath. */ S_glzopen_input doesn't squirrel away a pointer to expandedpath. */
free(expandedpath); free(expandedpath);
if (!file) { if (!file) {
if (verbose) fprintf(stderr, "trying %s...cannot open\n", path); if (verbose) fprintf(stderr, "trying %s...cannot open\n", path);
@ -687,23 +687,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); if (verbose) fprintf(stderr, "trying %s...opened\n", path);
/* check for magic number */ /* check for magic number */
if (glzgetc(file) != fasl_type_header || if (S_glzgetc(file) != fasl_type_header ||
glzgetc(file) != 0 || S_glzgetc(file) != 0 ||
glzgetc(file) != 0 || S_glzgetc(file) != 0 ||
glzgetc(file) != 0 || S_glzgetc(file) != 0 ||
glzgetc(file) != 'c' || S_glzgetc(file) != 'c' ||
glzgetc(file) != 'h' || S_glzgetc(file) != 'h' ||
glzgetc(file) != 'e' || S_glzgetc(file) != 'e' ||
glzgetc(file) != 'z') { S_glzgetc(file) != 'z') {
if (verbose) fprintf(stderr, "malformed fasl-object header in %s\n", path); if (verbose) fprintf(stderr, "malformed fasl-object header in %s\n", path);
glzclose(file); S_glzclose(file);
continue; continue;
} }
/* check version */ /* check version */
if (zget_uptr(file, &n) != 0) { if (zget_uptr(file, &n) != 0) {
if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path); if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path);
glzclose(file); S_glzclose(file);
continue; continue;
} }
@ -713,14 +713,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 */ /* use separate fprintf since S_format_scheme_version returns static string */
fprintf(stderr, "need Version %s\n", S_format_scheme_version(scheme_version)); fprintf(stderr, "need Version %s\n", S_format_scheme_version(scheme_version));
} }
glzclose(file); S_glzclose(file);
continue; continue;
} }
/* check machine type */ /* check machine type */
if (zget_uptr(file, &n) != 0) { if (zget_uptr(file, &n) != 0) {
if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path); if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path);
glzclose(file); S_glzclose(file);
continue; continue;
} }
@ -728,7 +728,7 @@ static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IB
if (verbose) if (verbose)
fprintf(stderr, "%s is for machine-type %s; need machine-type %s\n", path, 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_lookup_machine_type(n), S_lookup_machine_type(machine_type));
glzclose(file); S_glzclose(file);
continue; continue;
} }
@ -738,56 +738,56 @@ 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 (verbose) fprintf(stderr, "version and machine type check\n");
if (glzgetc(file) != '(') { /* ) */ if (S_glzgetc(file) != '(') { /* ) */
fprintf(stderr, "malformed boot file %s\n", path); fprintf(stderr, "malformed boot file %s\n", path);
glzclose(file); S_glzclose(file);
S_abnormal_exit(); S_abnormal_exit();
} }
/* ( */ /* ( */
if ((c = glzgetc(file)) == ')') { if ((c = S_glzgetc(file)) == ')') {
if (boot_count != 0) { if (boot_count != 0) {
fprintf(stderr, "base boot file %s must come before other boot files\n", path); fprintf(stderr, "base boot file %s must come before other boot files\n", path);
glzclose(file); S_glzclose(file);
S_abnormal_exit(); S_abnormal_exit();
} }
} else { } else {
if (boot_count == 0) { if (boot_count == 0) {
for (;;) { for (;;) {
glzungetc(c, file); S_glzungetc(c, file);
/* try to load heap or boot file this boot file requires */ /* try to load heap or boot file this boot file requires */
if (zgetstr(file, buf, PATH_MAX) != 0) { if (zgetstr(file, buf, PATH_MAX) != 0) {
fprintf(stderr, "unexpected end of file on %s\n", path); fprintf(stderr, "unexpected end of file on %s\n", path);
glzclose(file); S_glzclose(file);
S_abnormal_exit(); S_abnormal_exit();
} }
if (find_boot(buf, ".boot", -1, 0)) break; if (find_boot(buf, ".boot", -1, 0)) break;
if ((c = glzgetc(file)) == ')') { if ((c = S_glzgetc(file)) == ')') {
char *sep; char *wastebuf[8]; char *sep; char *wastebuf[8];
fprintf(stderr, "cannot find subordinate boot file "); fprintf(stderr, "cannot find subordinate boot file ");
glzrewind(file); S_glzrewind(file);
(void) glzread(file, wastebuf, 8); /* magic number */ (void) S_glzread(file, wastebuf, 8); /* magic number */
(void) zget_uptr(file, &n); /* version */ (void) zget_uptr(file, &n); /* version */
(void) zget_uptr(file, &n); /* machine type */ (void) zget_uptr(file, &n); /* machine type */
(void) glzgetc(file); /* open paren */ (void) S_glzgetc(file); /* open paren */
for (sep = ""; ; sep = "or ") { for (sep = ""; ; sep = "or ") {
if ((c = glzgetc(file)) == ')') break; if ((c = S_glzgetc(file)) == ')') break;
glzungetc(c, file); S_glzungetc(c, file);
(void) zgetstr(file, buf, PATH_MAX); (void) zgetstr(file, buf, PATH_MAX);
fprintf(stderr, "%s%s.boot ", sep, buf); fprintf(stderr, "%s%s.boot ", sep, buf);
} }
fprintf(stderr, "required by %s\n", path); fprintf(stderr, "required by %s\n", path);
glzclose(file); S_glzclose(file);
S_abnormal_exit(); S_abnormal_exit();
} }
} }
} }
/* skip to end of header */ /* skip to end of header */
while ((c = glzgetc(file)) != ')') { while ((c = S_glzgetc(file)) != ')') {
if (c < 0) { if (c < 0) {
fprintf(stderr, "malformed boot file %s\n", path); fprintf(stderr, "malformed boot file %s\n", path);
glzclose(file); S_glzclose(file);
S_abnormal_exit(); S_abnormal_exit();
} }
} }
@ -808,11 +808,11 @@ static IBOOL find_boot(name, ext, fd, errorp) const char *name, *ext; int fd; IB
static uptr zget_uptr(glzFile file, uptr *pn) { static uptr zget_uptr(glzFile file, uptr *pn) {
uptr n, m; int c; octet k; uptr n, m; int c; octet k;
if ((c = glzgetc(file)) < 0) return -1; if ((c = S_glzgetc(file)) < 0) return -1;
k = (octet)c; k = (octet)c;
n = k >> 1; n = k >> 1;
while (k & 1) { while (k & 1) {
if ((c = glzgetc(file)) < 0) return -1; if ((c = S_glzgetc(file)) < 0) return -1;
k = (octet)c; k = (octet)c;
m = n << 7; m = n << 7;
if (m >> 7 != n) return -1; if (m >> 7 != n) return -1;
@ -826,9 +826,9 @@ static INT zgetstr(file, s, max) glzFile file; char *s; iptr max; {
ICHAR c; ICHAR c;
while (max-- > 0) { while (max-- > 0) {
if ((c = glzgetc(file)) < 0) return -1; if ((c = S_glzgetc(file)) < 0) return -1;
if (c == ' ' || c == ')') { if (c == ' ' || c == ')') {
if (c == ')') glzungetc(c, file); if (c == ')') S_glzungetc(c, file);
*s = 0; *s = 0;
return 0; return 0;
} }
@ -923,7 +923,7 @@ static void load(tc, n, base) ptr tc; iptr n; IBOOL base; {
} }
S_G.load_binary = Sfalse; S_G.load_binary = Sfalse;
glzclose(bd[n].file); S_glzclose(bd[n].file);
} }
/***************************************************************************/ /***************************************************************************/
@ -1137,6 +1137,8 @@ extern void Sbuild_heap(kernel, custom_init) const char *kernel; void (*custom_i
/* #scheme-init enables interrupts */ /* #scheme-init enables interrupts */
TRAP(tc) = (ptr)most_positive_fixnum; TRAP(tc) = (ptr)most_positive_fixnum;
DISABLECOUNT(tc) = Sfixnum(1); DISABLECOUNT(tc) = Sfixnum(1);
COMPRESSFORMAT(tc) = FIX(COMPRESS_LZ4);
COMPRESSLEVEL(tc) = FIX(COMPRESS_MEDIUM);
load(tc, i++, 1); load(tc, i++, 1);
S_boot_time = 0; S_boot_time = 0;

3
c/system.h
View File

@ -24,13 +24,14 @@
#include "version.h" #include "version.h"
#include <stdio.h> #include <stdio.h>
#include "compress-io.h"
#include <stddef.h> #include <stddef.h>
#include "thread.h" #include "thread.h"
#include "types.h" #include "types.h"
#include "compress-io.h"
#ifndef EXTERN #ifndef EXTERN
#define EXTERN extern #define EXTERN extern
#endif #endif

6
c/thread.c
View File

@ -121,6 +121,8 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; {
GUARDIANENTRIES(tc) = Snil; GUARDIANENTRIES(tc) = Snil;
LZ4OUTBUFFER(tc) = NULL;
tc_mutex_release() tc_mutex_release()
return thread; return thread;
@ -224,7 +226,9 @@ static IBOOL destroy_thread(tc) ptr tc; {
} }
} }
free((void *)THREADTC(thread)); if (LZ4OUTBUFFER(tc) != NULL) free(LZ4OUTBUFFER(tc));
free((void *)tc);
THREADTC(thread) = 0; /* mark it dead */ THREADTC(thread) = 0; /* mark it dead */
status = 1; status = 1;
break; break;

2
checkin
View File

@ -294,7 +294,7 @@ endif
delete: delete:
set tmpfiles = `(cd $W; find . -name zlib -prune -o -type f -print)` set tmpfiles = `(cd $W; find . -name zlib -prune -o -name lz4 -prune -o -type f -print)`
set files = () set files = ()
foreach x ($tmpfiles) foreach x ($tmpfiles)
set files = ($x $files) set files = ($x $files)

48
csug/io.stex
View File

@ -208,8 +208,10 @@ Section~\ref{TSPL:SECTOPENINGFILES} of {\TSPLFOUR}.
\item[\var{compressed}:] \item[\var{compressed}:]
An output file should be compressed when written; and a compressed input An output file should be compressed when written; and a compressed input
file should be decompressed when read. The compression format for output file should be decompressed when read. The compression format for output
is determined by the \scheme{compress-format} parameter, while the compression is determined by the \index{\scheme{compress-format}}\scheme{compress-format}
format on input is inferred. parameter, while the compression format on input is inferred.
The compression level, which is relevant only for output, is determined
by the \index{\scheme{compress-level}}\scheme{compress-level} parameter.
\item[\var{replace}:] \item[\var{replace}:]
For output files only, replace (remove and recreate) the existing file if For output files only, replace (remove and recreate) the existing file if
@ -975,8 +977,10 @@ will be compressed.
If the port is an input port, subsequent input will be decompressed If the port is an input port, subsequent input will be decompressed
if and only if the port is currently pointing at compressed data. if and only if the port is currently pointing at compressed data.
The compression format for output The compression format for output
is determined by the \scheme{compress-format} parameter, while the compression is determined by the \index{\scheme{compress-format}}\scheme{compress-format}
format on input is inferred. parameter, while the compression format on input is inferred.
The compression level, which is relevant only for output, is determined
by the \index{\scheme{compress-level}}\scheme{compress-level} parameter.
This procedure has no effect if the port is already set for compression. This procedure has no effect if the port is already set for compression.
%---------------------------------------------------------------------------- %----------------------------------------------------------------------------
@ -986,23 +990,41 @@ This procedure has no effect if the port is already set for compression.
\endnoskipentryheader \endnoskipentryheader
\noindent \noindent
\scheme{compress-format} is a parameter that determines the \scheme{compress-format} determines the
compression algorithm and format that is used for output. Currently, compression algorithm and format used for output. Currently,
the possible values of the parameter are \scheme{'lz4} (the default) the possible values of the parameter are the symbols \scheme{lz4} (the default)
and \scheme{'gzip}. and \scheme{gzip}.
The \scheme{'lz4} format uses the LZ4 compression library developed by The \scheme{lz4} format uses the LZ4 compression library developed by
Yann Collet. Yann Collet.
It is therefore compatible with the \scheme{lz4} program, which It is therefore compatible with the \scheme{lz4} program, which
means that \scheme{lz4} may be used to uncompress files produced means that \scheme{lz4} may be used to uncompress files produced
by {\ChezScheme} and visa versa. by {\ChezScheme} and visa versa.
The \scheme{'gzip} format uses the zlib compression library developed by The \scheme{gzip} format uses the zlib compression library developed by
Jean-loup Gailly and Mark Adler. Jean-loup Gailly and Mark Adler.
It is therefore compatible with the \scheme{gzip} program, which It is therefore compatible with the \scheme{gzip} program, which
means that \scheme{gzip} may be used to uncompress files produced means that \scheme{gzip} may be used to uncompress files produced
by {\ChezScheme} and visa versa. by {\ChezScheme} and visa versa.
Reading \scheme{lz4}-compressed data tends to be much faster than reading
\scheme{gzip}-compressed data, while \scheme{gzip}-compressed data tends to
be significantly smaller.
%----------------------------------------------------------------------------
\entryheader
\formdef{compress-level}{\categorythreadparameter}{compress-level}
\listlibraries
\endnoskipentryheader
\noindent
\scheme{compress-level} determines the amount of effort spent on
compression and is thus relevant only for output.
It can be set to one of the symbols \scheme{low},
\scheme{medium}, \scheme{high}, or \scheme{maximum}, which are
listed in order from shortest to longest expected compression time
and least to greatest expected effectiveness.
Its default value is \scheme{medium}.
\section{String Ports\label{SECTIOSTRINGPORTS}} \section{String Ports\label{SECTIOSTRINGPORTS}}
@ -1858,7 +1880,11 @@ The default behavior is to raise an exception.
The mutually exclusive \scheme{compressed} and The mutually exclusive \scheme{compressed} and
\scheme{uncompressed} options determine whether the output file is to \scheme{uncompressed} options determine whether the output file is to
be compressed. be compressed.
The compression format is determined by the \scheme{compress-format} parameter. 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.
Files are uncompressed by default, so the \scheme{uncompressed} Files are uncompressed by default, so the \scheme{uncompressed}
option is useful only as documentation. option is useful only as documentation.

7
csug/objects.stex
View File

@ -1179,7 +1179,12 @@ The result is the raw compressed data with a minimal header to record
the uncompressed size and the compression mode. The result does not include the uncompressed size and the compression mode. The result does not include
the header that is written by port-based compression using the the header that is written by port-based compression using the
\scheme{compressed} option. The compression format is determined by the \scheme{compressed} option. The compression format is determined by the
\scheme{compress-format} parameter. \index{\scheme{compress-format}}\scheme{compress-format}
parameter.
The compression level is fixed to some default determined by the
format; it is not affected by the
\index{\scheme{compress-level}}\scheme{compress-level}
parameter.
%---------------------------------------------------------------------------- %----------------------------------------------------------------------------

5
csug/system.stex
View File

@ -2471,6 +2471,11 @@ When this parameter is \scheme{#t}, the default, \scheme{compile-file},
\scheme{compile-program}, \scheme{compile-to-file}, \scheme{compile-program}, \scheme{compile-to-file},
\scheme{compile-whole-program}, and \scheme{strip-fasl-file} compress \scheme{compile-whole-program}, and \scheme{strip-fasl-file} compress
the object files they create. 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.
%---------------------------------------------------------------------------- %----------------------------------------------------------------------------

20
csug/threads.stex
View File

@ -208,6 +208,16 @@ continuation invocation, the mutex is reacquired.
Using \scheme{with-mutex} is generally more convenient and safer than using Using \scheme{with-mutex} is generally more convenient and safer than using
\scheme{mutex-acquire} and \scheme{mutex-release} directly. \scheme{mutex-acquire} and \scheme{mutex-release} directly.
%----------------------------------------------------------------------------
\entryheader
\formdef{mutex-name}{\categoryprocedure}{(mutex-name \var{mutex})}
\returns the name associated with \var{mutex}, if any; otherwise \scheme{#f}
\listlibraries
\endentryheader
\noindent
\var{mutex} must be a mutex.
\section{Conditions} \section{Conditions}
%---------------------------------------------------------------------------- %----------------------------------------------------------------------------
@ -284,6 +294,16 @@ condition identified by \var{cond}.
\scheme{condition-broadcast} releases all of the threads waiting for the \scheme{condition-broadcast} releases all of the threads waiting for the
condition identified by \var{cond}. condition identified by \var{cond}.
%----------------------------------------------------------------------------
\entryheader
\formdef{condition-name}{\categoryprocedure}{(condition-name \var{condition})}
\returns the name associated with \var{condition}, if any; otherwise \scheme{#f}
\listlibraries
\endentryheader
\noindent
\var{condition} must be a condition.
\section{Locks\label{SECTTHREADLOCKS}} \section{Locks\label{SECTTHREADLOCKS}}
\index{locks}% \index{locks}%

15
mats/bytevector.ms
View File

@ -11277,7 +11277,7 @@
(mat bytevector-compress (mat bytevector-compress
(parameters [compress-format 'gzip] [compress-format 'lz4]) (parameters [compress-format 'gzip 'lz4])
(error? (bytevector-compress 7)) (error? (bytevector-compress 7))
(error? (bytevector-compress "hello")) (error? (bytevector-compress "hello"))
(error? (bytevector-uncompress 7)) (error? (bytevector-uncompress 7))
@ -11300,19 +11300,6 @@
(error? (error?
;; Need at least 8 bytes for result size ;; Need at least 8 bytes for result size
(bytevector-uncompress '#vu8(0 0 0 0 0 0 255))) (bytevector-uncompress '#vu8(0 0 0 0 0 0 255)))
(error?
;; Fail if the uncompressed result is too big
(bytevector-uncompress (let ([bv (bytevector-compress (string->utf8 "hello"))])
(bytevector-u64-set! bv 0 (sub1 (bytevector-u64-ref bv 0 (endianness big))) (endianness big))
bv)))
(error?
;; Fail if the uncompressed result is too small
(bytevector-uncompress (let ([bv (bytevector-compress (string->utf8 "hello"))])
(bytevector-u64-set! bv 0 (add1 (bytevector-u64-ref bv 0 (endianness big))) (endianness big))
bv)))
(error?
;; Compressed data always starts with 0x78, so this one isn't valid:
(bytevector-uncompress '#vu8(0 0 0 0 0 0 0 255 1 2 3)))
(error? (error?
;; Claming a too-large size in the header should fail with a suitable message: ;; Claming a too-large size in the header should fail with a suitable message:
(bytevector-uncompress '#vu8(255 255 255 255 255 255 255 255 1 2 3))) (bytevector-uncompress '#vu8(255 255 255 255 255 255 255 255 1 2 3)))

59
mats/io.ms
View File

@ -2126,8 +2126,63 @@
(= q (custom-port-buffer-size))))) (= q (custom-port-buffer-size)))))
) )
(mat compress-parameters
(error? ; unsupported format
(compress-format 'foo))
(error? ; unsupported format
(compress-format "gzip"))
(eq? (compress-format) 'lz4)
(eq? (parameterize ([compress-format 'gzip]) (compress-format)) 'gzip)
(eq? (parameterize ([compress-format 'lz4]) (compress-format)) 'lz4)
(error? ; unsupported level
(compress-level 'foo))
(error? ; unsupported level
(compress-level 1))
(eq? (compress-level) 'medium)
(eq? (parameterize ([compress-level 'low]) (compress-level)) 'low)
(eq? (parameterize ([compress-level 'medium]) (compress-level)) 'medium)
(eq? (parameterize ([compress-level 'high]) (compress-level)) 'high)
(eq? (parameterize ([compress-level 'maximum]) (compress-level)) 'maximum)
(begin
(define (fnlength ifn) (call-with-port (open-file-input-port ifn) port-length))
(define (compress-file ifn ofn fmt lvl)
(call-with-port (open-file-input-port ifn)
(lambda (ip)
(call-with-port (parameterize ([compress-format fmt] [compress-level lvl])
(open-file-output-port ofn (file-options compressed replace)))
(lambda (op) (put-bytevector op (get-bytevector-all ip))))))
(fnlength ofn))
(define (compress-file-test fmt)
(let ([orig (fnlength "prettytest.ss")]
[low (compress-file "prettytest.ss" "testfile.ss" fmt 'low)]
[medium (compress-file "prettytest.ss" "testfile.ss" fmt 'medium)]
[high (compress-file "prettytest.ss" "testfile.ss" fmt 'high)]
[maximum (compress-file "prettytest.ss" "testfile.ss" fmt 'maximum)])
(define-syntax test1
(syntax-rules ()
[(_ level)
(unless (< level orig) (errorf #f "~s ~s did not compress" fmt 'level))]))
(define-syntax test2
(syntax-rules ()
[(_ level1 level2)
(unless (<= level2 level1) (errorf #f "~s ~s did worse than ~s" fmt 'level2 'level1))]))
(test1 low)
(test1 medium)
(test1 high)
(test1 maximum)
(test2 low medium)
(test2 medium high)
(test2 high maximum)
(unless (< maximum low) (errorf #f "~s maximum didn't do better than low" fmt))))
(compress-file-test 'lz4)
(compress-file-test 'gzip)
#t)
)
(mat compression (mat compression
(parameters [compress-format 'gzip] [compress-format 'lz4]) (parameters [compress-format 'gzip 'lz4] [compress-level 'low 'medium 'high 'maximum])
(and (memq (compress-format) '(gzip lz4)) #t)
(and (memq (compress-level) '(low medium high maximum)) #t)
(let () (let ()
(define cp (define cp
(lambda (src dst) (lambda (src dst)
@ -3072,7 +3127,7 @@
) )
(mat compression-textual (mat compression-textual
(parameters [compress-format 'gzip] [compress-format 'lz4]) (parameters [compress-format 'gzip 'lz4] [compress-level 'low 'medium 'high 'maximum])
(let () (let ()
(define cp (define cp
(lambda (src dst) (lambda (src dst)

14
mats/mat.ss
View File

@ -20,12 +20,16 @@
(define-syntax mat (define-syntax mat
(lambda (x) (lambda (x)
(syntax-case x (parameters) (syntax-case x (parameters)
[(_ x (parameters [param val] ...) e ...) [(_ x (parameters [param val ...] ...) e ...)
#'(for-each (lambda (p v) #'(let f ([p* (list param ...)] [v** (list (list val ...) ...)])
(if (null? p*)
(mat x e ...)
(let ([p (car p*)])
(for-each
(lambda (v)
(parameterize ([p v]) (parameterize ([p v])
(mat x e ...))) (f (cdr p*) (cdr v**))))
(list param ...) (car v**)))))]
(list val ...))]
[(_ x e ...) [(_ x e ...)
(with-syntax ([(source ...) (with-syntax ([(source ...)
(map (lambda (clause) (map (lambda (clause)

22
mats/root-experr-compile-0-f-f-f
View File

@ -3626,9 +3626,6 @@ bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress:
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector". bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()". bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)". bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: uncompressed #vu8(0 0 0 0 0 0 ...) is larger than expected size".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: uncompressed size 5 for #vu8(0 0 0 0 0 0 ...) is smaller than expected size 6".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>". bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector". bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector". bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
@ -3636,9 +3633,6 @@ bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress:
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector". bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()". bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)". bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: internal error uncompressing #vu8(128 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: uncompressed size 5 for #vu8(128 0 0 0 0 0 ...) is smaller than expected size 6".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>". bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
misc.mo:Expected error in mat compiler1: "variable i-am-not-bound is not bound". misc.mo:Expected error in mat compiler1: "variable i-am-not-bound is not bound".
misc.mo:Expected error in mat compiler1: "attempt to apply non-procedure oops". misc.mo:Expected error in mat compiler1: "attempt to apply non-procedure oops".
@ -6798,6 +6792,22 @@ io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: 0
io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: -15 is not a positive fixnum". io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: -15 is not a positive fixnum".
io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: <int> is not a positive fixnum". io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: <int> is not a positive fixnum".
io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: 1024.0 is not a positive fixnum". io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: 1024.0 is not a positive fixnum".
io.mo:Expected error in mat compress-parameters: "compress-format: foo is not a supported format".
io.mo:Expected error in mat compress-parameters: "compress-format: "gzip" is not a supported format".
io.mo:Expected error in mat compress-parameters: "compress-level: foo is not a supported level".
io.mo:Expected error in mat compress-parameters: "compress-level: 1 is not a supported level".
io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".
io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".
io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".
io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".
io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".
io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".
io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port". io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".
io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>". io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port". io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".

26
mats/root-experr-compile-2-f-f-f
View File

@ -3626,8 +3626,12 @@ bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress:
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector". bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()". bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)". bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: uncompressed #vu8(0 0 0 0 0 0 ...) is larger than expected size". bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: uncompressed size 5 for #vu8(0 0 0 0 0 0 ...) is smaller than expected size 6". bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)". bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>". bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
misc.mo:Expected error in mat compiler1: "variable i-am-not-bound is not bound". misc.mo:Expected error in mat compiler1: "variable i-am-not-bound is not bound".
@ -6788,6 +6792,24 @@ io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: 0
io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: -15 is not a positive fixnum". io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: -15 is not a positive fixnum".
io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: <int> is not a positive fixnum". io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: <int> is not a positive fixnum".
io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: 1024.0 is not a positive fixnum". io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: 1024.0 is not a positive fixnum".
io.mo:Expected error in mat compress-parameters: "compress-format: foo is not a supported format".
io.mo:Expected error in mat compress-parameters: "compress-format: "gzip" is not a supported format".
io.mo:Expected error in mat compress-parameters: "compress-level: foo is not a supported level".
io.mo:Expected error in mat compress-parameters: "compress-level: 1 is not a supported level".
io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".
io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".
io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".
io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".
io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".
io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".
io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".
io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port". io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".
io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>". io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
io.mo:Expected error in mat bytevector-input-port: "incorrect argument count in call (open-bytevector-input-port)". io.mo:Expected error in mat bytevector-input-port: "incorrect argument count in call (open-bytevector-input-port)".

25
release_notes/release_notes.stex
View File

@ -58,16 +58,29 @@ Online versions of both books can be found at
%----------------------------------------------------------------------------- %-----------------------------------------------------------------------------
\section{Functionality Changes}\label{section:functionality} \section{Functionality Changes}\label{section:functionality}
\subsection{Compression format (9.5.3)} \subsection{Compression format and level (9.5.3)}
The default format for compressed-file writing is now LZ4, while {\tt Support for LZ4 compression has been added.
LZ4 is now the default format when compressing files (including
object files produced by the compiler) and bytevectors, while {\tt
gzip} is still supported and can be enabled by setting gzip} is still supported and can be enabled by setting
\scheme{compress-format} to \scheme{'gzip}. Reading in compressed mode the new \scheme{compress-format} parameter to the symbol \scheme{gzip} instead of the
default \scheme{lz4}. Reading in compressed mode
infers the format, so reading {\tt gzip}-compressed files will still infers the format, so reading {\tt gzip}-compressed files will still
work without changing \scheme{compress-format}. Reading LZ4-format work without changing \scheme{compress-format}. Reading LZ4-format
files tends to be much faster than reading {\tt gzip}-format files, in files tends to be much faster than reading {\tt gzip}-format files,
most cases nearly eliminating the load-time cost of compressing while {\tt gzip}-compressed files tend to be smaller.
compiled files. In particular, object files created by the compiler now tend to be
larger but load more quickly.
The new \scheme{compress-level} parameter can be used to control
the amount of time spent on file compression (but not
bytevector compression).
It can be set to one of the symbols \scheme{low},
\scheme{medium}, \scheme{high}, and \scheme{maximum}, which are
listed in order from shortest to longest compression time and least
to greatest effectiveness.
The default value is \scheme{medium}.
\subsection{Mutexes and condition variables can have names (9.5.3)} \subsection{Mutexes and condition variables can have names (9.5.3)}

47
s/Mf-base
View File

@ -24,15 +24,23 @@ o = 3
# d is the debug level at which the system should be built # d is the debug level at which the system should be built
d = 0 d = 0
# cl (xcl) determines the commonization level # cl determines the commonization level
cl = (commonization-level) cl = (commonization-level)
# i determines whether inspector-information is generated: f for false, t for true # i determines whether inspector-information is generated: f for false, t for true
i = f i = f
# cp0 (xcp0) determines the number of cp0 (source optimizer) iterations run # cp0 determines the number of cp0 (source optimizer) iterations run
cp0 = 2 cp0 = 2
xcp0 = 2
# cc determines whether compiled files are compressed
cc = t
# xf determines the compression foramt
xf = (compress-format)
# xl determine the compression level
xl = (compress-level)
# p (xp) determines whether source profiling is enabled: f for false, t for true. # p (xp) determines whether source profiling is enabled: f for false, t for true.
p = f p = f
@ -214,6 +222,9 @@ clean: profileclean
'(optimize-level $o)'\ '(optimize-level $o)'\
'(debug-level $d)'\ '(debug-level $d)'\
'(commonization-level $(cl))'\ '(commonization-level $(cl))'\
'(compile-compressed #$(cc))'\
'(compress-format $(xf))'\
'(compress-level $(xl))'\
'(when #$p (compile-profile (quote source)))'\ '(when #$p (compile-profile (quote source)))'\
'(when #$(bp) (compile-profile (quote block)))'\ '(when #$(bp) (compile-profile (quote block)))'\
'(when #$(loadspd) (profile-load-data "${ProfileDumpSource}"))'\ '(when #$(loadspd) (profile-load-data "${ProfileDumpSource}"))'\
@ -238,6 +249,9 @@ clean: profileclean
'(optimize-level $o)'\ '(optimize-level $o)'\
'(debug-level $d)'\ '(debug-level $d)'\
'(commonization-level $(cl))'\ '(commonization-level $(cl))'\
'(compile-compressed #$(cc))'\
'(compress-format $(xf))'\
'(compress-level $(xl))'\
'(when #$p (compile-profile (quote source)))'\ '(when #$p (compile-profile (quote source)))'\
'(when #$(bp) (compile-profile (quote block)))'\ '(when #$(bp) (compile-profile (quote block)))'\
'(when #$(loadspd) (profile-load-data "${ProfileDumpSource}"))'\ '(when #$(loadspd) (profile-load-data "${ProfileDumpSource}"))'\
@ -265,6 +279,9 @@ clean: profileclean
'(optimize-level $o)'\ '(optimize-level $o)'\
'(debug-level $d)'\ '(debug-level $d)'\
'(commonization-level $(cl))'\ '(commonization-level $(cl))'\
'(compile-compressed #$(cc))'\
'(compress-format $(xf))'\
'(compress-level $(xl))'\
'(generate-inspector-information #$i)'\ '(generate-inspector-information #$i)'\
'(subset-mode (quote system))'\ '(subset-mode (quote system))'\
'(compile-file "$*.ss" "$*.so")'\ '(compile-file "$*.ss" "$*.so")'\
@ -275,6 +292,9 @@ clean: profileclean
'(optimize-level $o)'\ '(optimize-level $o)'\
'(debug-level $d)'\ '(debug-level $d)'\
'(commonization-level $(cl))'\ '(commonization-level $(cl))'\
'(compile-compressed #$(cc))'\
'(compress-format $(xf))'\
'(compress-level $(xl))'\
'(when #$(xp) (compile-profile (quote source)))'\ '(when #$(xp) (compile-profile (quote source)))'\
'(when #$(xbp) (compile-profile (quote block)))'\ '(when #$(xbp) (compile-profile (quote block)))'\
'(generate-inspector-information #$i)'\ '(generate-inspector-information #$i)'\
@ -344,6 +364,9 @@ cmacros.so: cmacros.ss machine.def layout.ss
'(optimize-level $o)'\ '(optimize-level $o)'\
'(debug-level $d)'\ '(debug-level $d)'\
'(commonization-level $(cl))'\ '(commonization-level $(cl))'\
'(compile-compressed #$(cc))'\
'(compress-format $(xf))'\
'(compress-level $(xl))'\
'(generate-inspector-information #$i)'\ '(generate-inspector-information #$i)'\
'(subset-mode (quote system))'\ '(subset-mode (quote system))'\
'(compile-file "$*.ss" "$*.so")'\ '(compile-file "$*.ss" "$*.so")'\
@ -356,6 +379,9 @@ priminfo.so: priminfo.ss primdata.ss cmacros.so
'(optimize-level $o)'\ '(optimize-level $o)'\
'(debug-level $d)'\ '(debug-level $d)'\
'(commonization-level $(cl))'\ '(commonization-level $(cl))'\
'(compile-compressed #$(cc))'\
'(compress-format $(xf))'\
'(compress-level $(xl))'\
'(generate-inspector-information #$i)'\ '(generate-inspector-information #$i)'\
'(subset-mode (quote system))'\ '(subset-mode (quote system))'\
'(compile-file "$*.ss" "$*.so")'\ '(compile-file "$*.ss" "$*.so")'\
@ -369,6 +395,9 @@ mkheader.so: mkheader.ss cmacros.so primvars.so env.so
'(optimize-level $o)'\ '(optimize-level $o)'\
'(debug-level $d)'\ '(debug-level $d)'\
'(commonization-level $(cl))'\ '(commonization-level $(cl))'\
'(compile-compressed #$(cc))'\
'(compress-format $(xf))'\
'(compress-level $(xl))'\
'(generate-inspector-information #$i)'\ '(generate-inspector-information #$i)'\
'(subset-mode (quote system))'\ '(subset-mode (quote system))'\
'(compile-file "$*.ss" "$*.so")'\ '(compile-file "$*.ss" "$*.so")'\
@ -381,6 +410,9 @@ nanopass.so: $(shell echo ../nanopass/nanopass/*) ../nanopass/nanopass.ss
'(optimize-level $o)'\ '(optimize-level $o)'\
'(debug-level $d)'\ '(debug-level $d)'\
'(commonization-level $(cl))'\ '(commonization-level $(cl))'\
'(compile-compressed #$(cc))'\
'(compress-format $(xf))'\
'(compress-level $(xl))'\
'(generate-inspector-information #$i)'\ '(generate-inspector-information #$i)'\
'(collect-trip-bytes (expt 2 24))'\ '(collect-trip-bytes (expt 2 24))'\
'(collect-request-handler (lambda () (collect 0 1)))'\ '(collect-request-handler (lambda () (collect 0 1)))'\
@ -404,6 +436,9 @@ script.all makescript:
'(optimize-level $o)'\ '(optimize-level $o)'\
'(debug-level $d)'\ '(debug-level $d)'\
'(commonization-level $(cl))'\ '(commonization-level $(cl))'\
'(compile-compressed #$(cc))'\
'(compress-format $(xf))'\
'(compress-level $(xl))'\
'(when #$p (compile-profile (quote source)))'\ '(when #$p (compile-profile (quote source)))'\
'(when #$(bp) (compile-profile (quote block)))'\ '(when #$(bp) (compile-profile (quote block)))'\
'(when #$(loadspd) (profile-load-data "${ProfileDumpSource}"))'\ '(when #$(loadspd) (profile-load-data "${ProfileDumpSource}"))'\
@ -440,6 +475,9 @@ script-static.all:
'(optimize-level $o)'\ '(optimize-level $o)'\
'(debug-level $d)'\ '(debug-level $d)'\
'(commonization-level $(cl))'\ '(commonization-level $(cl))'\
'(compile-compressed #$(cc))'\
'(compress-format $(xf))'\
'(compress-level $(xl))'\
'(when #$p (compile-profile (quote source)))'\ '(when #$p (compile-profile (quote source)))'\
'(when #$(bp) (compile-profile (quote block)))'\ '(when #$(bp) (compile-profile (quote block)))'\
'(generate-inspector-information #$i)'\ '(generate-inspector-information #$i)'\
@ -462,6 +500,9 @@ script-dynamic.all:
'(optimize-level $o)'\ '(optimize-level $o)'\
'(debug-level $d)'\ '(debug-level $d)'\
'(commonization-level $(cl))'\ '(commonization-level $(cl))'\
'(compile-compressed #$(cc))'\
'(compress-format $(xf))'\
'(compress-level $(xl))'\
'(when #$p (compile-profile (quote source)))'\ '(when #$p (compile-profile (quote source)))'\
'(when #$(bp) (compile-profile (quote block)))'\ '(when #$(bp) (compile-profile (quote block)))'\
'(generate-inspector-information #$i)'\ '(generate-inspector-information #$i)'\

38
s/back.ss
View File

@ -156,12 +156,38 @@
x))) x)))
(define-who compress-format (define-who compress-format
($make-thread-parameter (case-lambda
'lz4 [()
(lambda (x) (let ([x ($tc-field 'compress-format ($tc))])
(unless (or (eq? x 'lz4) (eq? x 'gzip)) (cond
($oops who "~s is not a supported format" x)) [(eqv? x (constant COMPRESS-GZIP)) 'gzip]
x))) [(eqv? x (constant COMPRESS-LZ4)) 'lz4]
[else ($oops who "unexpected $compress-format value ~s" x)]))]
[(x)
($tc-field 'compress-format ($tc)
(case x
[(gzip) (constant COMPRESS-GZIP)]
[(lz4) (constant COMPRESS-LZ4)]
[else ($oops who "~s is not a supported format" x)]))]))
(define-who compress-level
(case-lambda
[()
(let ([x ($tc-field 'compress-level ($tc))])
(cond
[(eqv? x (constant COMPRESS-LOW)) 'low]
[(eqv? x (constant COMPRESS-MEDIUM)) 'medium]
[(eqv? x (constant COMPRESS-HIGH)) 'high]
[(eqv? x (constant COMPRESS-MAX)) 'maximum]
[else ($oops who "unexpected $compress-level value ~s" x)]))]
[(x)
($tc-field 'compress-level ($tc)
(case x
[(low) (constant COMPRESS-LOW)]
[(medium) (constant COMPRESS-MEDIUM)]
[(high) (constant COMPRESS-HIGH)]
[(maximum) (constant COMPRESS-MAX)]
[else ($oops who "~s is not a supported level" x)]))]))
(define-who debug-level (define-who debug-level
($make-thread-parameter ($make-thread-parameter

43
s/bytevector.ss
View File

@ -1454,25 +1454,23 @@
) )
(let () (let ()
;; Store uncompressed size as u64, using high bit to indicate LZ4: ;; Store uncompressed size as u64, using low bits to indicate compression format:
(define uncompressed-length-length (ftype-sizeof integer-64)) (define uncompressed-length-length (ftype-sizeof integer-64))
;; Always big-endian, so that compressed data is portable. ;; Always big-endian, so that compressed data is portable.
;; It might be useful somehow that valid compressed data always starts
;; with a 0 or 128 byte; otherwise, the expected size would be unrealistically big.
(define uncompressed-length-endianness (endianness big)) (define uncompressed-length-endianness (endianness big))
(define $bytevector-compress-size (define $bytevector-compress-size
(foreign-procedure "(cs)bytevector_compress_size" (iptr boolean) uptr)) (foreign-procedure "(cs)bytevector_compress_size" (iptr int) uptr))
(define $bytevector-compress (define $bytevector-compress
(foreign-procedure "(cs)bytevector_compress" (scheme-object iptr iptr scheme-object iptr iptr boolean) scheme-object)) (foreign-procedure "(cs)bytevector_compress" (scheme-object iptr iptr scheme-object iptr iptr int) scheme-object))
(define $bytevector-uncompress (define $bytevector-uncompress
(foreign-procedure "(cs)bytevector_uncompress" (scheme-object iptr iptr scheme-object iptr iptr boolean) scheme-object)) (foreign-procedure "(cs)bytevector_uncompress" (scheme-object iptr iptr scheme-object iptr iptr int) scheme-object))
(set-who! bytevector-compress (set-who! bytevector-compress
(lambda (bv) (lambda (bv)
(unless (bytevector? bv) (not-a-bytevector who bv)) (unless (bytevector? bv) (not-a-bytevector who bv))
(let* ([as-gz? (eq? 'gzip (compress-format))] (let* ([fmt ($tc-field 'compress-format ($tc))]
[dest-max-len ($bytevector-compress-size (bytevector-length bv) as-gz?)] [dest-max-len ($bytevector-compress-size (bytevector-length bv) fmt)]
[dest-alloc-len (min (+ dest-max-len uncompressed-length-length) [dest-alloc-len (min (+ dest-max-len uncompressed-length-length)
;; In the unlikely event of a non-fixnum requested size... ;; In the unlikely event of a non-fixnum requested size...
(constant maximum-bytevector-length))] (constant maximum-bytevector-length))]
@ -1483,34 +1481,25 @@
bv bv
0 0
(bytevector-length bv) (bytevector-length bv)
as-gz?)]) fmt)])
(cond (cond
[(string? r) [(string? r)
($oops who r bv)] ($oops who r bv)]
[else [else
($bytevector-u64-set! dest-bv 0 (bytevector-length bv) uncompressed-length-endianness who) (let ([tag (bitwise-ior
(unless as-gz? (bytevector-u8-set! dest-bv 0 128)) ; set high bit for LZ4 (bitwise-arithmetic-shift-left (bytevector-length bv) (constant COMPRESS-FORMAT-BITS))
(bytevector-truncate! dest-bv (fx+ r uncompressed-length-length))]))))) fmt)])
($bytevector-u64-set! dest-bv 0 tag uncompressed-length-endianness who)
(bytevector-truncate! dest-bv (fx+ r uncompressed-length-length)))])))))
(set-who! bytevector-uncompress (set-who! bytevector-uncompress
(lambda (bv) (lambda (bv)
(unless (bytevector? bv) (not-a-bytevector who bv)) (unless (bytevector? bv) (not-a-bytevector who bv))
(unless (>= (bytevector-length bv) uncompressed-length-length) (unless (>= (bytevector-length bv) uncompressed-length-length)
($oops who "invalid data in source bytevector ~s" bv)) ($oops who "invalid data in source bytevector ~s" bv))
(let* ([as-gz? (not (fx= 128 (bytevector-u8-ref bv 0)))] (let* ([tag ($bytevector-u64-ref bv 0 uncompressed-length-endianness who)]
[dest-length (cond [fmt (logand tag (fx- (fxsll 1 (constant COMPRESS-FORMAT-BITS)) 1))]
[as-gz? [dest-length (bitwise-arithmetic-shift-right tag (constant COMPRESS-FORMAT-BITS))])
($bytevector-u64-ref bv 0 uncompressed-length-endianness who)]
;; Need to skip high bit; likely can skip first 4 bytes
[(and (fx= 0 (bytevector-u8-ref bv 1))
(fx= 0 (bytevector-u8-ref bv 2))
(fx= 0 (bytevector-u8-ref bv 3)))
($bytevector-u32-ref bv 4 uncompressed-length-endianness who)]
[else
;; Clear high bit the hard way
(+ ($bytevector-u32-ref bv 4 uncompressed-length-endianness who)
(let ([v ($bytevector-u32-ref bv 0 uncompressed-length-endianness who)])
((bitwise-arithmetic-shift-left (- v #x80000000) 32))))])])
(unless (and (fixnum? dest-length) (unless (and (fixnum? dest-length)
($fxu< dest-length (constant maximum-bytevector-length))) ($fxu< dest-length (constant maximum-bytevector-length)))
($oops who "bytevector ~s claims invalid uncompressed size ~s" bv dest-length)) ($oops who "bytevector ~s claims invalid uncompressed size ~s" bv dest-length))
@ -1521,7 +1510,7 @@
bv bv
uncompressed-length-length uncompressed-length-length
(fx- (bytevector-length bv) uncompressed-length-length) (fx- (bytevector-length bv) uncompressed-length-length)
as-gz?)]) fmt)])
(cond (cond
[(string? r) ($oops who r bv)] [(string? r) ($oops who r bv)]
[(fx= r dest-length) dest-bv] [(fx= r dest-length) dest-bv]

12
s/cmacros.ss
View File

@ -531,6 +531,15 @@
(define-constant SEOF -1) (define-constant SEOF -1)
(define-constant COMPRESS-GZIP 0)
(define-constant COMPRESS-LZ4 1)
(define-constant COMPRESS-FORMAT-BITS 3)
(define-constant COMPRESS-LOW 0)
(define-constant COMPRESS-MEDIUM 1)
(define-constant COMPRESS-HIGH 2)
(define-constant COMPRESS-MAX 3)
(define-constant SICONV-DUNNO 0) (define-constant SICONV-DUNNO 0)
(define-constant SICONV-INVALID 1) (define-constant SICONV-INVALID 1)
(define-constant SICONV-INCOMPLETE 2) (define-constant SICONV-INCOMPLETE 2)
@ -1371,6 +1380,9 @@
[ptr suppress-primitive-inlining] [ptr suppress-primitive-inlining]
[ptr default-record-equal-procedure] [ptr default-record-equal-procedure]
[ptr default-record-hash-procedure] [ptr default-record-hash-procedure]
[ptr compress-format]
[ptr compress-level]
[void* lz4-out-buffer]
[U64 instr-counter] [U64 instr-counter]
[U64 alloc-counter] [U64 alloc-counter]
[ptr parameters])) [ptr parameters]))

22
s/io.ss
View File

@ -264,7 +264,7 @@ implementation notes:
(foreign-procedure "(cs)new_open_output_fd" (foreign-procedure "(cs)new_open_output_fd"
(string int (string int
boolean boolean boolean boolean boolean boolean
boolean boolean boolean boolean boolean) boolean boolean boolean boolean)
scheme-object)) scheme-object))
(define $open-input/output-fd (define $open-input/output-fd
(foreign-procedure "(cs)new_open_input_output_fd" (foreign-procedure "(cs)new_open_input_output_fd"
@ -310,7 +310,7 @@ implementation notes:
(define $compress-input-fd (define $compress-input-fd
(foreign-procedure "(cs)compress_input_fd" (int integer-64) scheme-object)) (foreign-procedure "(cs)compress_input_fd" (int integer-64) scheme-object))
(define $compress-output-fd (define $compress-output-fd
(foreign-procedure "(cs)compress_output_fd" (int boolean) scheme-object)) (foreign-procedure "(cs)compress_output_fd" (int) scheme-object))
(module (clear-open-files register-open-file registered-open-file? unregister-open-file) (module (clear-open-files register-open-file registered-open-file? unregister-open-file)
(define open-files #f) (define open-files #f)
(define file-guardian) (define file-guardian)
@ -645,14 +645,17 @@ implementation notes:
(define binary-file-port-close-port (define binary-file-port-close-port
(lambda (who p) (lambda (who p)
(unregister-open-file p)
(let ([msg ($close-fd ($port-info p) (port-gz-mode p))])
(unless (eq? #t msg) (port-oops who p msg)))
(mark-port-closed! p)
(when (input-port? p) (when (input-port? p)
(set-port-eof! p #f) (set-port-eof! p #f)
(set-binary-port-input-size! p 0)) (set-binary-port-input-size! p 0))
(when (output-port? p) (set-binary-port-output-size! p 0)))) (when (output-port? p) (set-binary-port-output-size! p 0))
(unregister-open-file p)
; mark port closed before closing fd. if an interrupt occurs, we'd prefer
; that the fd's resources never be freed than to have an open port floating
; around with fd resources that have already been freed.
(mark-port-closed! p)
(let ([msg ($close-fd ($port-info p) (port-gz-mode p))])
(unless (eq? #t msg) (port-oops who p msg)))))
(define-syntax binary-file-port-port-position (define-syntax binary-file-port-port-position
(syntax-rules () (syntax-rules ()
@ -3185,7 +3188,7 @@ implementation notes:
; reposition to 'unread' any compressed data in the input buffer ; reposition to 'unread' any compressed data in the input buffer
(set-port-position! p fp) (set-port-position! p fp)
($compress-input-fd fd fp)) ($compress-input-fd fd fp))
($compress-output-fd fd (eq? (compress-format) 'gzip)))]) ($compress-output-fd fd))])
(when (string? gzfd) ($oops who "failed for ~s: ~(~a~)" p gzfd)) (when (string? gzfd) ($oops who "failed for ~s: ~(~a~)" p gzfd))
(unless (eqv? gzfd fd) ; uncompressed input port (unless (eqv? gzfd fd) ; uncompressed input port
(assert (box? gzfd)) (assert (box? gzfd))
@ -4091,8 +4094,7 @@ implementation notes:
(let ([fd (critical-section (let ([fd (critical-section
($open-output-fd filename perms ($open-output-fd filename perms
no-create no-fail no-truncate no-create no-fail no-truncate
append lock replace compressed append lock replace compressed))])
(and compressed (eq? (compress-format) 'gzip))))])
(when (pair? fd) (open-oops who filename options fd)) (when (pair? fd) (open-oops who filename options fd))
(open-binary-fd-output-port who filename fd #t b-mode lock compressed))))) (open-binary-fd-output-port who filename fd #t b-mode lock compressed)))))

1
s/primdata.ss
View File

@ -926,6 +926,7 @@
(compile-profile [sig [() -> (ptr)] [(ptr) -> (void)]] [flags unrestricted]) (compile-profile [sig [() -> (ptr)] [(ptr) -> (void)]] [flags unrestricted])
(compile-program-handler [sig [() -> (procedure)] [(procedure) -> (void)]] [flags]) (compile-program-handler [sig [() -> (procedure)] [(procedure) -> (void)]] [flags])
(compress-format [sig [() -> (symbol)] [(sub-symbol) -> (void)]] [flags]) (compress-format [sig [() -> (symbol)] [(sub-symbol) -> (void)]] [flags])
(compress-level [sig [() -> (symbol)] [(sub-symbol) -> (void)]] [flags])
(console-error-port [sig [() -> (textual-output-port)] [(textual-output-port) -> (void)]] [flags]) (console-error-port [sig [() -> (textual-output-port)] [(textual-output-port) -> (void)]] [flags])
(console-input-port [sig [() -> (textual-input-port)] [(textual-input-port) -> (void)]] [flags]) (console-input-port [sig [() -> (textual-input-port)] [(textual-input-port) -> (void)]] [flags])
(console-output-port [sig [() -> (textual-output-port)] [(textual-output-port) -> (void)]] [flags]) (console-output-port [sig [() -> (textual-output-port)] [(textual-output-port) -> (void)]] [flags])