cs: new vfasl writer to support cross compilation
Replace the vfasl writer (which was in C) with a new implementation (in Scheme). The main result is that the vfasl writer can be used in cross-build mode. Racket uses the vfasl format for its boot images, because they can load faster --- cutting the Chez Scheme plus boot files startup time in half, which saves about 40msec on a typical machine. That's not enough to matter for something like DrRacket, but it can matter for small Racket scripts. Formerly, cross builds disabled vfasl generation. A vfasl file is roughly an image of code and data as it will appear in memory, and a relatively fast linking step makes the image work in a running process. The old implementation was in C because it reused GC structures and code, treating fasl creation as copying objects into a vfasl image instead of a new generation. The new implementation is more like a fasl reader, loading objects into a vfasl image instead of the live heap. The two implementations are about the same amount of code and both involve a certain amount of repeated implementation (i.e., imitating a collection or fasl load), but the Scheme implementation is more flexible and works for cross compilation.
This commit is contained in:
Matthew Flatt
parent
a08a6b4904
commit
b7c0130a75
|
|
@ -338,7 +338,7 @@ RACKET_FOR_BOOTFILES = $(RACKET)
|
|||
RACKET_FOR_BUILD = $(RACKET)
|
||||
|
||||
# This branch name changes each time the pb boot files are updated:
|
||||
PB_BRANCH == circa-7.9.0.13-1
|
||||
PB_BRANCH == circa-7.9.0.14-2
|
||||
PB_REPO = https://github.com/racket/pb
|
||||
|
||||
# Alternative source for Chez Scheme boot files, normally set by
|
||||
|
|
|
|||
12
Makefile
12
Makefile
|
|
@ -47,7 +47,7 @@ RACKETCS_SUFFIX =
|
|||
RACKET =
|
||||
RACKET_FOR_BOOTFILES = $(RACKET)
|
||||
RACKET_FOR_BUILD = $(RACKET)
|
||||
PB_BRANCH = circa-7.9.0.13-1
|
||||
PB_BRANCH = circa-7.9.0.14-2
|
||||
PB_REPO = https://github.com/racket/pb
|
||||
EXTRA_REPOS_BASE =
|
||||
CS_CROSS_SUFFIX =
|
||||
|
|
@ -307,18 +307,18 @@ maybe-fetch-pb-as-is:
|
|||
echo done
|
||||
fetch-pb-from:
|
||||
mkdir -p racket/src/ChezScheme/boot
|
||||
if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-7.9.0.13-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.9.0.13-1:remotes/origin/circa-7.9.0.13-1 ; fi
|
||||
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.13-1
|
||||
if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q -b circa-7.9.0.14-2 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-7.9.0.14-2:remotes/origin/circa-7.9.0.14-2 ; fi
|
||||
cd racket/src/ChezScheme/boot/pb && git checkout -q circa-7.9.0.14-2
|
||||
pb-fetch:
|
||||
$(MAKE) fetch-pb EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" PB_REPO="$(PB_REPO)"
|
||||
pb-build:
|
||||
cd racket/src/ChezScheme && racket rktboot/main.rkt --machine pb
|
||||
pb-stage:
|
||||
cd racket/src/ChezScheme/boot/pb && git branch circa-7.9.0.13-1
|
||||
cd racket/src/ChezScheme/boot/pb && git checkout circa-7.9.0.13-1
|
||||
cd racket/src/ChezScheme/boot/pb && git branch circa-7.9.0.14-2
|
||||
cd racket/src/ChezScheme/boot/pb && git checkout circa-7.9.0.14-2
|
||||
cd racket/src/ChezScheme/boot/pb && git add . && git commit --amend -m "new build"
|
||||
pb-push:
|
||||
cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.9.0.13-1
|
||||
cd racket/src/ChezScheme/boot/pb && git push -u origin circa-7.9.0.14-2
|
||||
win-cs-base:
|
||||
IF "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-bc-then-cs-base SETUP_BOOT_MODE=--boot WIN32_BUILD_LEVEL=bc PLAIN_RACKET=racket\racketbc DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETBC_SUFFIX="$(RACKETBC_SUFFIX)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)"
|
||||
IF not "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-just-cs-base SETUP_BOOT_MODE=--chain DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)" RACKET_FOR_BUILD="$(RACKET_FOR_BUILD)"
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
|
||||
;; In the Racket source repo, this version should change only when
|
||||
;; "racket_version.h" changes:
|
||||
(define version "7.9.0.13")
|
||||
(define version "7.9.0.14")
|
||||
|
||||
(define deps `("racket-lib"
|
||||
["racket" #:version ,version]))
|
||||
|
|
|
|||
|
|
@ -25,15 +25,16 @@ take advantage of machines with multiple processors, cores, or
|
|||
hardware threads.
|
||||
|
||||
@margin-note{Currently, parallel support for places is enabled
|
||||
only for the 3m (main) and CS variants of Racket, and only
|
||||
only for the CS and 3m variants of Racket, and for 3m, only
|
||||
by default for Windows, Linux x86/x86_64, and Mac OS x86/x86_64. To
|
||||
enable support for other platforms, use @DFlag{enable-places} with
|
||||
enable support for other platforms with 3m, use @DFlag{enable-places} with
|
||||
@exec{configure} when building Racket. The @racket[place-enabled?]
|
||||
function reports whether places run in parallel.
|
||||
|
||||
Implementation and operating-system constraints may limit the
|
||||
scalability of places. For example, although places can perform
|
||||
garbage collections independently in the 3m variant, a garbage collection
|
||||
garbage collections in parallel in the CS variant or independently
|
||||
in the 3m variant, a garbage collection
|
||||
may need to manipulate a page table that is shared across all
|
||||
places, and that shared page table can be a bottleneck with enough
|
||||
places---perhaps around 8 or 16.}
|
||||
|
|
|
|||
|
|
@ -9,7 +9,8 @@ found in the "c" directory.
|
|||
|
||||
Some key files in "s":
|
||||
|
||||
* "cmacro.ss": object layouts and other global constants
|
||||
* "cmacro.ss": object layouts and other global constants, including
|
||||
constants that are needed by both the compiler and the kernel
|
||||
|
||||
* "syntax.ss": the macro expander
|
||||
|
||||
|
|
@ -141,6 +142,28 @@ Tests go in "mats/*...*.ms". In "*machine-type*/mats", you can use
|
|||
changing `7.ms`. Makefile variables like `o` control the way tests
|
||||
are run; for example, use `make o=3 7.mo` to test in unsafe mode.
|
||||
|
||||
# Compiled Files and Boot Files
|
||||
|
||||
A Scheme file conventionally uses the suffix ".ss" and it's compiled
|
||||
form uses the suffix ".so". The format of a compiled file is closely
|
||||
related to the fasl format that is exposed by `fasl-write` and
|
||||
`fasl-read`, but you can't compile Scheme code to some value that is
|
||||
written with `fasl-write`. Instead, `compile-file` and related
|
||||
functions directly generate compiled code in a fasled form that
|
||||
includes needed linking information.
|
||||
|
||||
A boot file, usually with the suffix ".boot", has the same format as a
|
||||
compiled file, but with an extra header that identifies it as a boot
|
||||
file and takes care of some singleton objects, such as `#!base-rtd`
|
||||
and the stub to invoke compiled code.
|
||||
|
||||
The vfasl format is used for the same purposes as the fasl format, but
|
||||
mostly for boot files. It is always platform-specific and its content
|
||||
is very close to the form that the content will take when loaded into
|
||||
memory. It can load especially quickly with streamlined linking and
|
||||
interning of symbols and record types, especially in uncompressed
|
||||
form. The build scripts do not convert boot files to vfasl format.
|
||||
|
||||
# Scheme Objects
|
||||
|
||||
A Scheme object is represented at run time by a pointer. The low bits
|
||||
|
|
@ -212,6 +235,13 @@ contain the value `type-inexactnum`. The `iptr` type for `type` means
|
|||
"a pointer-sized signed integer". The `ptr` type for `real` and `imag`
|
||||
means "pointer" or "Scheme object".
|
||||
|
||||
If you create a new type of object, then several pieces need to be
|
||||
updated: the garbage collector (in "mkgc.ss" and "gc.c"), the compiler
|
||||
to implement primitives that generate the kind of objects, the fasl
|
||||
writer (in "fasl.ss"), the fasl reader (in "fasl.c"), the fasl reader
|
||||
used by `strip-fasl-file` and `vfasl-convert-file` (in "strip.ss"),
|
||||
the vfasl writer (in "vfasl.ss"), and the inspector (in "inspect.ss").
|
||||
|
||||
# Functions and Calls
|
||||
|
||||
Scheme code does not use the C stack, except to the degree that it
|
||||
|
|
@ -1079,6 +1109,31 @@ The `asm-foreign-callable` function returns 4 values:
|
|||
Generate the code for a C return, including any teardown needed to
|
||||
balance `c-init`.
|
||||
|
||||
# Cross Compilation and Compile-Time Constants
|
||||
|
||||
When cross compiling, there are two notions of quantities/properties
|
||||
like the size of pointers or endianness: the host notion and the
|
||||
target platform's notion. A function like `(native-endianness)` always
|
||||
reports the host's notion. A constant like `(constant
|
||||
native-endianness)` refers to the target machine notion.
|
||||
|
||||
Cross compilation works by starting with a Chez Scheme that runs on
|
||||
the host machine and then re-compiling a subset of the Chez Scheme
|
||||
implementation to run on the host machine but with `constant` values
|
||||
suitable for the target machine. The recompiled parts are assembled
|
||||
into an `xpatch` file that can be loaded to replace functions like
|
||||
`compile-file` and `vfasl-convert-file` with ones that use the
|
||||
target-machine constants. Loading an `xpatch` file tends to make
|
||||
compilation or fasl operations for the host machine inaccessible, so a
|
||||
given Chez Scheme process is only good for targeting one particular
|
||||
platform.
|
||||
|
||||
When working on the compiler or fasl-related tools, take care to use
|
||||
the right notion of a quantity or property. If you need the host
|
||||
value, then there must be some function that provides the value. If
|
||||
you need the target machine's value, then it must be accessed using
|
||||
`constant`.
|
||||
|
||||
# Changing the Version Number
|
||||
|
||||
To change the version number:
|
||||
|
|
|
|||
|
|
@ -72,7 +72,6 @@ gc-011.o gc-par.o gc-ocd.o gc-oce.o: gc.c
|
|||
gc-011.o gc-ocd.o: ${Include}/gc-ocd.inc
|
||||
gc-oce.o: ${Include}/gc-oce.inc
|
||||
gc-par.o: ${Include}/gc-par.inc
|
||||
vfasl.o: ${Include}/vfasl.inc
|
||||
gcwrapper.o: ${Include}/heapcheck.inc
|
||||
|
||||
../zlib/zlib.h ../zlib/zconf.h: ../zlib/configure.log
|
||||
|
|
|
|||
|
|
@ -113,11 +113,11 @@ extern void S_phantom_bytevector_adjust PROTO((ptr ph, uptr new_sz));
|
|||
|
||||
/* fasl.c */
|
||||
extern void S_fasl_init PROTO((void));
|
||||
ptr S_fasl_read PROTO((INT fd, IFASLCODE situation, ptr path, ptr externals));
|
||||
ptr S_bv_fasl_read PROTO((ptr bv, int ty, uptr offset, uptr len, ptr path, ptr externals));
|
||||
ptr S_boot_read PROTO((INT fd, const char *path));
|
||||
char *S_format_scheme_version PROTO((uptr n));
|
||||
char *S_lookup_machine_type PROTO((uptr n));
|
||||
extern ptr S_fasl_read PROTO((INT fd, IFASLCODE situation, ptr path, ptr externals));
|
||||
extern ptr S_bv_fasl_read PROTO((ptr bv, int ty, uptr offset, uptr len, ptr path, ptr externals));
|
||||
extern ptr S_boot_read PROTO((INT fd, const char *path));
|
||||
extern char *S_format_scheme_version PROTO((uptr n));
|
||||
extern char *S_lookup_machine_type PROTO((uptr n));
|
||||
extern void S_set_code_obj PROTO((char *who, IFASLCODE typ, ptr p, iptr n,
|
||||
ptr x, iptr o));
|
||||
extern ptr S_get_code_obj PROTO((IFASLCODE typ, ptr p, iptr n, iptr o));
|
||||
|
|
@ -131,10 +131,8 @@ extern void S_swap_dounderflow_header_endian PROTO((ptr code));
|
|||
#endif
|
||||
|
||||
/* vfasl.c */
|
||||
extern ptr S_to_vfasl PROTO((ptr v));
|
||||
extern ptr S_vfasl PROTO((ptr bv, void *stream, iptr offset, iptr len));
|
||||
extern ptr S_vfasl_to PROTO((ptr v));
|
||||
extern IBOOL S_vfasl_can_combinep(ptr v);
|
||||
|
||||
/* flushcache.c */
|
||||
extern void S_record_code_mod PROTO((ptr tc, uptr addr, uptr bytes));
|
||||
|
|
@ -201,6 +199,8 @@ extern ptr S_intern4 PROTO((ptr sym));
|
|||
extern void S_intern_gensym PROTO((ptr g));
|
||||
extern void S_retrofit_nonprocedure_code PROTO((void));
|
||||
extern ptr S_mkstring PROTO((const string_char *s, iptr n));
|
||||
extern I32 S_symbol_hash32(ptr str);
|
||||
extern I64 S_symbol_hash64(ptr str);
|
||||
|
||||
/* io.c */
|
||||
extern IBOOL S_file_existsp PROTO((const char *inpath, IBOOL followp));
|
||||
|
|
|
|||
|
|
@ -14,6 +14,10 @@
|
|||
* limitations under the License.
|
||||
*/
|
||||
|
||||
/* The fasl writer is in "fasl.ss".
|
||||
There's a second fasl reader and writer in "strip.ss", so it has
|
||||
to be kept in sync with this one. */
|
||||
|
||||
/* fasl representation:
|
||||
*
|
||||
* <fasl-file> -> <fasl-group>*
|
||||
|
|
@ -52,6 +56,8 @@
|
|||
*
|
||||
* -> {bytevector}<uptr n><octet elt1>...<octet eltn>
|
||||
*
|
||||
* -> {stencil-vector}<uptr mask><octet elt1>...<octet eltn>
|
||||
*
|
||||
* -> {immediate}<uptr>
|
||||
*
|
||||
* -> {small-integer}<iptr>
|
||||
|
|
@ -115,6 +121,8 @@
|
|||
* ...
|
||||
* <faslreloc> # last relocation entry
|
||||
*
|
||||
* -> {begin}<va>...<val> # all but last is intended to be a {graph-def}
|
||||
*
|
||||
* <faslreloc> -> <byte type-etc> # bit 0: extended entry, bit 1: expect item offset, bit 2+: type
|
||||
* <uptr code-offset>
|
||||
* <uptr item-offset> # omitted if bit 1 of type-etc is 0
|
||||
|
|
@ -1545,19 +1553,27 @@ ptr S_get_code_obj(typ, p, n, o) IFASLCODE typ; iptr n, o; ptr p; {
|
|||
return (ptr)(item - o);
|
||||
}
|
||||
|
||||
|
||||
#ifdef PORTABLE_BYTECODE
|
||||
|
||||
/* Address pieces in a movz,movk,movk,movk sequence are upper 16 bits */
|
||||
#define ADDRESS_BITS_SHIFT 16
|
||||
#define ADDRESS_BITS_MASK ((U32)0xffff0000)
|
||||
#define ADDRESS_BITS_MASK ((U32)0xFFFF0000)
|
||||
#define DEST_REG_MASK 0xF00
|
||||
|
||||
static void pb_set_abs(void *address, uptr item) {
|
||||
((U32 *)address)[0] = ((((U32 *)address)[0] & ~ADDRESS_BITS_MASK) | ((item & 0xFFFF) << ADDRESS_BITS_SHIFT));
|
||||
((U32 *)address)[1] = ((((U32 *)address)[1] & ~ADDRESS_BITS_MASK) | (((item >> 16) & 0xFFFF) << ADDRESS_BITS_SHIFT));
|
||||
/* First word can have an arbitrary value due to vfasl offset
|
||||
storage, so get the target register from the end: */
|
||||
#if ptr_bytes == 8
|
||||
((U32 *)address)[2] = ((((U32 *)address)[2] & ~ADDRESS_BITS_MASK) | (((item >> 32) & 0xFFFF) << ADDRESS_BITS_SHIFT));
|
||||
((U32 *)address)[3] = ((((U32 *)address)[3] & ~ADDRESS_BITS_MASK) | (((item >> 48) & 0xFFFF) << ADDRESS_BITS_SHIFT));
|
||||
int dest_reg = ((U32 *)address)[3] & DEST_REG_MASK;
|
||||
#else
|
||||
int dest_reg = ((U32 *)address)[1] & DEST_REG_MASK;
|
||||
#endif
|
||||
|
||||
((U32 *)address)[0] = (pb_mov16_pb_zero_bits_pb_shift0 | dest_reg | ((item & 0xFFFF) << ADDRESS_BITS_SHIFT));
|
||||
((U32 *)address)[1] = (pb_mov16_pb_keep_bits_pb_shift1 | dest_reg | (((item >> 16) & 0xFFFF) << ADDRESS_BITS_SHIFT));
|
||||
#if ptr_bytes == 8
|
||||
((U32 *)address)[2] = (pb_mov16_pb_keep_bits_pb_shift2 | dest_reg | (((item >> 32) & 0xFFFF) << ADDRESS_BITS_SHIFT));
|
||||
((U32 *)address)[3] = (pb_mov16_pb_keep_bits_pb_shift3 | dest_reg | (((item >> 48) & 0xFFFF) << ADDRESS_BITS_SHIFT));
|
||||
#endif
|
||||
}
|
||||
|
||||
|
|
@ -1571,17 +1587,17 @@ static uptr pb_get_abs(void *address) {
|
|||
);
|
||||
}
|
||||
|
||||
#endif /* AARCH64 */
|
||||
#endif /* PORTABLE_BYTECODE */
|
||||
|
||||
#ifdef ARMV6
|
||||
static void arm32_set_abs(void *address, uptr item) {
|
||||
/* code generator produces ldrlit destreg, 0; brai 0; long 0 */
|
||||
/* we change long 0 => long item */
|
||||
*((U32 *)address + 2) = item;
|
||||
/* given address is at long 0, which we change to `item` */
|
||||
*((U32 *)address) = item;
|
||||
}
|
||||
|
||||
static uptr arm32_get_abs(void *address) {
|
||||
return *((U32 *)address + 2);
|
||||
return *((U32 *)address);
|
||||
}
|
||||
|
||||
#define MAKE_B(n) (0xEA000000 | (n))
|
||||
|
|
@ -1634,11 +1650,24 @@ static uptr arm32_get_jump(void *address) {
|
|||
#define ADDRESS_BITS_SHIFT 5
|
||||
#define ADDRESS_BITS_MASK ((U32)0x1fffe0)
|
||||
|
||||
/* Dest register in either movz or movk: */
|
||||
#define DEST_REG_MASK 0x1F
|
||||
|
||||
#define MOVZ_OPCODE 0xD2800000
|
||||
#define MOVK_OPCODE 0xF2800000
|
||||
#define SHIFT16_OPCODE 0x00200000
|
||||
#define SHIFT32_OPCODE 0x00400000
|
||||
#define SHIFT48_OPCODE 0x00600000
|
||||
|
||||
static void arm64_set_abs(void *address, uptr item) {
|
||||
((U32 *)address)[0] = ((((U32 *)address)[0] & ~ADDRESS_BITS_MASK) | ((item & 0xFFFF) << ADDRESS_BITS_SHIFT));
|
||||
((U32 *)address)[1] = ((((U32 *)address)[1] & ~ADDRESS_BITS_MASK) | (((item >> 16) & 0xFFFF) << ADDRESS_BITS_SHIFT));
|
||||
((U32 *)address)[2] = ((((U32 *)address)[2] & ~ADDRESS_BITS_MASK) | (((item >> 32) & 0xFFFF) << ADDRESS_BITS_SHIFT));
|
||||
((U32 *)address)[3] = ((((U32 *)address)[3] & ~ADDRESS_BITS_MASK) | (((item >> 48) & 0xFFFF) << ADDRESS_BITS_SHIFT));
|
||||
/* First word can have an arbitrary value due to vfasl offset
|
||||
storage, so get the target register from the end: */
|
||||
int dest_reg = ((U32 *)address)[3] & DEST_REG_MASK;
|
||||
|
||||
((U32 *)address)[0] = (MOVZ_OPCODE | dest_reg | ((item & 0xFFFF) << ADDRESS_BITS_SHIFT));
|
||||
((U32 *)address)[1] = (MOVK_OPCODE | SHIFT16_OPCODE | dest_reg | (((item >> 16) & 0xFFFF) << ADDRESS_BITS_SHIFT));
|
||||
((U32 *)address)[2] = (MOVK_OPCODE | SHIFT32_OPCODE | dest_reg | (((item >> 32) & 0xFFFF) << ADDRESS_BITS_SHIFT));
|
||||
((U32 *)address)[3] = (MOVK_OPCODE | SHIFT48_OPCODE | dest_reg | (((item >> 48) & 0xFFFF) << ADDRESS_BITS_SHIFT));
|
||||
}
|
||||
|
||||
static uptr arm64_get_abs(void *address) {
|
||||
|
|
@ -1655,21 +1684,26 @@ static uptr arm64_get_abs(void *address) {
|
|||
#define UPDATE_ADDIS(item, instr) (((instr) & ~0xFFFF) | (((item) >> 16) & 0xFFFF))
|
||||
#define UPDATE_ADDI(item, instr) (((instr) & ~0xFFFF) | ((item) & 0xFFFF))
|
||||
|
||||
#define MAKE_B(disp, callp) ((18 << 26) | (((disp) & 0xFFFFFF) << 2) | (callp))
|
||||
#define MAKE_ADDIS(item) ((15 << 26) | (((item) >> 16) & 0xFFFF))
|
||||
#define MAKE_ORI(item) ((24 << 26) | ((item) & 0xFFFF))
|
||||
#define MAKE_NOP ((24 << 26))
|
||||
#define MAKE_MTCTR ((31 << 26) | (9 << 16) | (467 << 1))
|
||||
#define MAKE_BCTR(callp) ((19 << 26) | (20 << 21) | (528 << 1) | (callp))
|
||||
#define MAKE_B(disp, callp) ((18 << 26) | (((disp) & 0xFFFFFF) << 2) | (callp))
|
||||
#define MAKE_ADDIS(item) ((15 << 26) | (((item) >> 16) & 0xFFFF))
|
||||
#define MAKE_ADDI(item) ((14 << 26) | ((item) & 0xFFFF))
|
||||
#define MAKE_ORI(item) ((24 << 26) | ((item) & 0xFFFF))
|
||||
#define MAKE_NOP ((24 << 26))
|
||||
#define MAKE_MTCTR ((31 << 26) | (9 << 16) | (467 << 1))
|
||||
#define MAKE_BCTR(callp) ((19 << 26) | (20 << 21) | (528 << 1) | (callp))
|
||||
|
||||
#define DEST_REG_MASK (0x1F << 21)
|
||||
|
||||
static void ppc32_set_abs(void *address, uptr item) {
|
||||
/* code generator produces addis destreg, %r0, 0 (hi) ; addi destreg, destreg, 0 (lo) */
|
||||
/* we change 0 (hi) => upper 16 bits of address */
|
||||
/* we change 0 (lo) => lower 16 bits of address */
|
||||
/* low part is signed: if negative, increment high part */
|
||||
/* but the first word may have been overritten for vfasl */
|
||||
int dest_reg = (*((U32 *)address + 1)) & DEST_REG_MASK;
|
||||
item = item + (item << 1 & 0x10000);
|
||||
*((U32 *)address + 0) = UPDATE_ADDIS(item, *((U32 *)address + 0));
|
||||
*((U32 *)address + 1) = UPDATE_ADDI(item, *((U32 *)address + 1));
|
||||
*((U32 *)address + 0) = dest_reg | MAKE_ADDIS(item);
|
||||
*((U32 *)address + 1) = dest_reg | dest_reg >> 5 | MAKE_ADDI(item);
|
||||
}
|
||||
|
||||
static uptr ppc32_get_abs(void *address) {
|
||||
|
|
|
|||
|
|
@ -106,36 +106,39 @@ void S_resize_oblist(void) {
|
|||
|
||||
#define MIX_HASH(hc) (hc += (hc << 10), hc ^= (hc >> 6))
|
||||
|
||||
#define SYM_HASH_LOOP(uptr, iptr, extract, mask) { \
|
||||
uptr h = (uptr)n + 401887359; \
|
||||
while (n--) { h += extract(*s++); MIX_HASH(h); } \
|
||||
return (iptr)h & mask; \
|
||||
}
|
||||
|
||||
#define identity_extract(x) x
|
||||
|
||||
static iptr hash(const unsigned char *s, iptr n) {
|
||||
uptr h = (uptr)n + 401887359;
|
||||
while (n--) { h += *s++; MIX_HASH(h); }
|
||||
return (iptr)h & most_positive_fixnum;
|
||||
SYM_HASH_LOOP(uptr, iptr, identity_extract, most_positive_fixnum);
|
||||
}
|
||||
|
||||
static iptr hash_sc(const string_char *s, iptr n) {
|
||||
uptr h = (uptr)n + 401887359;
|
||||
while (n--) { h += Schar_value(*s++); MIX_HASH(h); }
|
||||
return (iptr)h & most_positive_fixnum;
|
||||
SYM_HASH_LOOP(uptr, iptr, Schar_value, most_positive_fixnum);
|
||||
}
|
||||
|
||||
static iptr hash_uname(const string_char *s, iptr n) {
|
||||
/* attempting to get dissimilar hash codes for gensyms created in the same session */
|
||||
iptr i = n, h = 0; iptr pos = 1; int d, c;
|
||||
|
||||
while (i-- > 0) {
|
||||
if ((c = Schar_value(s[i])) == '-') {
|
||||
if (pos <= 10) break;
|
||||
return (h + 523658599) & most_positive_fixnum;
|
||||
}
|
||||
d = c - '0';
|
||||
if (d < 0 || d > 9) break;
|
||||
h += d * pos;
|
||||
pos *= 10;
|
||||
}
|
||||
|
||||
return hash_sc(s, n);
|
||||
}
|
||||
|
||||
/* on any platform, computes the value that is computed on a 32-bit platform,
|
||||
but needs to be `bitwise-and`ed with most_positive_fixnum */
|
||||
I32 S_symbol_hash32(ptr str) {
|
||||
const string_char *s = &STRIT(str, 0); iptr n = Sstring_length(str);
|
||||
SYM_HASH_LOOP(U32, I32, Schar_value, (I32)-1);
|
||||
}
|
||||
|
||||
/* like S_symbol_hash32 for the value that is computed on a 64-bit platform */
|
||||
I64 S_symbol_hash64(ptr str) {
|
||||
const string_char *s = &STRIT(str, 0); iptr n = Sstring_length(str);
|
||||
SYM_HASH_LOOP(U64, I64, Schar_value, (U64)-1);
|
||||
}
|
||||
|
||||
static ptr mkstring(const string_char *s, iptr n) {
|
||||
iptr i;
|
||||
ptr str = S_string(NULL, n);
|
||||
|
|
|
|||
|
|
@ -1678,6 +1678,8 @@ void S_prim5_init() {
|
|||
Sforeign_symbol("(cs)s_strings_to_gensym", (void *)s_strings_to_gensym);
|
||||
Sforeign_symbol("(cs)s_intern_gensym", (void *)S_intern_gensym);
|
||||
Sforeign_symbol("(cs)s_uninterned", (void *)S_uninterned);
|
||||
Sforeign_symbol("(cs)symbol_hash32", (void *)S_symbol_hash32);
|
||||
Sforeign_symbol("(cs)symbol_hash64", (void *)S_symbol_hash64);
|
||||
Sforeign_symbol("(cs)cputime", (void *)S_cputime);
|
||||
Sforeign_symbol("(cs)realtime", (void *)S_realtime);
|
||||
Sforeign_symbol("(cs)clock_gettime", (void *)S_clock_gettime);
|
||||
|
|
@ -1706,9 +1708,7 @@ void S_prim5_init() {
|
|||
Sforeign_symbol("(cs)getpid", (void *)s_getpid);
|
||||
Sforeign_symbol("(cs)fasl_read", (void *)S_fasl_read);
|
||||
Sforeign_symbol("(cs)bv_fasl_read", (void *)S_bv_fasl_read);
|
||||
Sforeign_symbol("(cs)to_vfasl", (void *)S_to_vfasl);
|
||||
Sforeign_symbol("(cs)vfasl_to", (void *)S_vfasl_to);
|
||||
Sforeign_symbol("(cs)vfasl_can_combinep", (void *)S_vfasl_can_combinep);
|
||||
Sforeign_symbol("(cs)s_decode_float", (void *)s_decode_float);
|
||||
|
||||
Sforeign_symbol("(cs)new_open_input_fd", (void *)S_new_open_input_fd);
|
||||
|
|
|
|||
|
|
@ -32,6 +32,7 @@ static void pstr PROTO((ptr x));
|
|||
static void psym PROTO((ptr x));
|
||||
static void pvec PROTO((ptr x));
|
||||
static void pfxvector PROTO((ptr x));
|
||||
static void pflvector PROTO((ptr x));
|
||||
static void pbytevector PROTO((ptr x));
|
||||
static void pflonum PROTO((ptr x));
|
||||
static void pflodat PROTO((double x));
|
||||
|
|
@ -54,6 +55,7 @@ void S_prin1(x) ptr x; {
|
|||
else if (Sexactnump(x)) pexactnum(x);
|
||||
else if (Svectorp(x)) pvec(x);
|
||||
else if (Sfxvectorp(x)) pfxvector(x);
|
||||
else if (Sflvectorp(x)) pflvector(x);
|
||||
else if (Sbytevectorp(x)) pbytevector(x);
|
||||
else if (Sboxp(x)) pbox(x);
|
||||
else if (Sprocedurep(x)) pclo(x);
|
||||
|
|
@ -159,12 +161,16 @@ static void pstr(x) ptr x; {
|
|||
}
|
||||
|
||||
static void display_string(x) ptr x; {
|
||||
iptr i, n = Sstring_length(x);
|
||||
|
||||
for (i = 0; i < n; i += 1) {
|
||||
int k = Sstring_ref(x, i);
|
||||
if (k >= 256) k = '?';
|
||||
putchar(k);
|
||||
if (!Sstringp(x)) {
|
||||
printf("#<garbage-string>");
|
||||
} else {
|
||||
iptr i, n = Sstring_length(x);
|
||||
|
||||
for (i = 0; i < n; i += 1) {
|
||||
int k = Sstring_ref(x, i);
|
||||
if (k >= 256) k = '?';
|
||||
putchar(k);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -227,6 +233,25 @@ static void pfxvector(x) ptr x; {
|
|||
putchar(')');
|
||||
}
|
||||
|
||||
static void pflvector(x) ptr x; {
|
||||
iptr n;
|
||||
|
||||
putchar('#');
|
||||
n = Sflvector_length(x);
|
||||
wrint(FIX(n));
|
||||
printf("vfl(");
|
||||
if (n != 0) {
|
||||
iptr i = 0;
|
||||
|
||||
while (1) {
|
||||
pflodat(Sflvector_ref(x, i));
|
||||
if (++i == n) break;
|
||||
putchar(' ');
|
||||
}
|
||||
}
|
||||
putchar(')');
|
||||
}
|
||||
|
||||
static void pbytevector(x) ptr x; {
|
||||
iptr n;
|
||||
|
||||
|
|
|
|||
|
|
@ -344,8 +344,11 @@ static void idiot_checks() {
|
|||
static ptr boot_call PROTO((ptr tc, ptr p, INT n));
|
||||
static void check_ap PROTO((ptr tc));
|
||||
|
||||
int boot_calls = 0;
|
||||
|
||||
/* arguments and ac0 set up */
|
||||
static ptr boot_call(tc, p, n) ptr tc; ptr p; INT n; {
|
||||
boot_calls++;
|
||||
AC1(tc) = p;
|
||||
CP(tc) = Svoid; /* don't have calling code object */
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -62,7 +62,7 @@ InstallLZ4Target=
|
|||
# no changes should be needed below this point #
|
||||
###############################################################################
|
||||
|
||||
Version=csv9.5.3.55
|
||||
Version=csv9.5.3.56
|
||||
Include=boot/$m
|
||||
PetiteBoot=boot/$m/petite.boot
|
||||
SchemeBoot=boot/$m/scheme.boot
|
||||
|
|
|
|||
|
|
@ -4927,7 +4927,11 @@
|
|||
(define immutable-objs (list (vector->immutable-vector '#(1 2 3))
|
||||
(string->immutable-string "abc")
|
||||
(bytevector->immutable-bytevector #vu8(1 2 3))
|
||||
(box-immutable 1)))
|
||||
(box-immutable 1)
|
||||
;; Not immutable, but we want to test strip:
|
||||
(fxvector 1 2 3)
|
||||
(flvector 1.5 2.5 3.5)
|
||||
(stencil-vector 6 'a 'b)))
|
||||
(define immutable-zero-objs (list (vector->immutable-vector '#())
|
||||
(string->immutable-string "")
|
||||
(bytevector->immutable-bytevector #vu8())
|
||||
|
|
|
|||
|
|
@ -395,6 +395,7 @@
|
|||
[(environment) *env '((a . b)) #f]
|
||||
[(eq-hashtable) *eq-hashtable *symbol-hashtable #f]
|
||||
[(exact-integer) (- (most-negative-fixnum) 1) 2.0 1/2 #f]
|
||||
[(exact-uinteger) (+ (most-positive-fixnum) 1) -10 2.0 1/2 #f]
|
||||
[(exception-state) (current-exception-state) 0 #f]
|
||||
[(eof/char) #\a 0 #f]
|
||||
[(eof/u8) 0 -1 (expt 2 8) "a" #f]
|
||||
|
|
|
|||
|
|
@ -402,7 +402,6 @@
|
|||
(eval `(mkgc-ocd.inc ,(path->string (build-path out-subdir "gc-ocd.inc"))))
|
||||
(eval `(mkgc-oce.inc ,(path->string (build-path out-subdir "gc-oce.inc"))))
|
||||
(eval `(mkgc-par.inc ,(path->string (build-path out-subdir "gc-par.inc"))))
|
||||
(eval `(mkvfasl.inc ,(path->string (build-path out-subdir "vfasl.inc"))))
|
||||
(eval `(mkheapcheck.inc ,(path->string (build-path out-subdir "heapcheck.inc"))))
|
||||
(plumber-flush-all (current-plumber))))
|
||||
|
||||
|
|
|
|||
|
|
@ -115,7 +115,6 @@ Cequates = ../boot/$m/equates.h
|
|||
Cgcocd = ../boot/$m/gc-ocd.inc
|
||||
Cgcoce = ../boot/$m/gc-oce.inc
|
||||
Cgcpar = ../boot/$m/gc-par.inc
|
||||
Cvfasl = ../boot/$m/vfasl.inc
|
||||
Cheapcheck = ../boot/$m/heapcheck.inc
|
||||
Revision = ../boot/$m/revision
|
||||
|
||||
|
|
@ -128,7 +127,7 @@ patch = patch
|
|||
patchobj = patch.patch cpnanopass.patch cprep.patch cpcheck.patch\
|
||||
cp0.patch cpvalid.patch cptypes.patch cpcommonize.patch cpletrec.patch\
|
||||
reloc.patch\
|
||||
compile.patch fasl.patch syntax.patch env.patch\
|
||||
compile.patch fasl.patch vfasl.patch syntax.patch env.patch\
|
||||
read.patch interpret.patch ftype.patch strip.patch\
|
||||
ubify.patch
|
||||
|
||||
|
|
@ -151,7 +150,7 @@ basesrc =\
|
|||
interpret.ss cprep.ss cpcheck.ss cp0.ss cpvalid.ss cptypes.ss cpcommonize.ss cpletrec.ss inspect.ss\
|
||||
enum.ss io.ss read.ss primvars.ss syntax.ss costctr.ss expeditor.ss\
|
||||
exceptions.ss pretty.ss env.ss\
|
||||
fasl.ss reloc.ss pdhtml.ss strip.ss ftype.ss back.ss
|
||||
fasl.ss vfasl.ss reloc.ss pdhtml.ss strip.ss ftype.ss back.ss
|
||||
|
||||
baseobj = ${basesrc:%.ss=%.$m}
|
||||
|
||||
|
|
@ -170,14 +169,14 @@ macroobj =\
|
|||
allsrc =\
|
||||
${basesrc} ${compilersrc} cmacros.ss ${archincludes} setup.ss debug.ss priminfo.ss primdata.ss layout.ss\
|
||||
base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss\
|
||||
np-languages.ss fxmap.ss
|
||||
np-languages.ss fxmap.ss strip-types.ss
|
||||
|
||||
# doit uses a different Scheme process to compile each target
|
||||
doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cgcpar} ${Cvfasl} ${Cheapcheck} ${Revision}
|
||||
doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cgcpar} ${Cheapcheck} ${Revision}
|
||||
|
||||
# all uses a single Scheme process to compile all targets. this is typically
|
||||
# faster when most of the targets need to be recompiled.
|
||||
all: bootall ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cgcpar} ${Cvfasl} ${Cheapcheck} ${Revision}
|
||||
all: bootall ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cgcpar} ${Cheapcheck} ${Revision}
|
||||
|
||||
# allx runs all up to three times and checks to see if the new boot file is the
|
||||
# same as the last, i.e., the system is properly bootstrapped.
|
||||
|
|
@ -364,7 +363,7 @@ resetbootlinks:
|
|||
| ${Scheme} -q
|
||||
|
||||
keepbootfiles:
|
||||
for x in `echo scheme.boot petite.boot scheme.h equates.h gc-oce.inc gc-ocd.inc gc-par.inc vfasl.inc heapcheck.inc` ; do\
|
||||
for x in `echo scheme.boot petite.boot scheme.h equates.h gc-oce.inc gc-ocd.inc gc-par.inc heapcheck.inc` ; do\
|
||||
if [ ! -h ../boot/$(m)/$$x ] ; then \
|
||||
mv -f ../boot/$(m)/$$x ../../boot/$(m)/$$x ;\
|
||||
elif [ "${upupupbootdir}" != "../../.." ] ; then \
|
||||
|
|
@ -593,11 +592,15 @@ ${patch}: ${patchobj}
|
|||
${asm} ${obj} mkheader.so: ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss ${patchfile}
|
||||
primvars.so setup.so mkheader.so env.so: cmacros.so priminfo.so primref.ss
|
||||
setup.so: debug.ss
|
||||
strip.so: strip-types.ss
|
||||
vfasl.so: strip-types.ss
|
||||
|
||||
${patchobj}: ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss env.ss
|
||||
${patchobj}: ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss strip-types.ss env.ss
|
||||
cpnanopass.$m cpnanopass.patch: nanopass.so np-languages.ss fxmap.ss ${archincludes}
|
||||
cptypes.$m: fxmap.ss
|
||||
5_4.$m: ../unicode/unicode-char-cases.ss ../unicode/unicode-charinfo.ss
|
||||
strip.$m: strip-types.ss
|
||||
vfasl.$m: strip-types.ss
|
||||
|
||||
${Cheader}: mkheader.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss
|
||||
(if [ -r ${Cheader} ]; then mv -f ${Cheader} ${Cheader}.bak; fi)
|
||||
|
|
@ -644,15 +647,6 @@ ${Cgcpar}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.s
|
|||
then mv -f ${Cgcpar}.bak ${Cgcpar};\
|
||||
else rm -f ${Cgcpar}.bak; fi)
|
||||
|
||||
${Cvfasl}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss
|
||||
(if [ -r ${Cvfasl} ]; then mv -f ${Cvfasl} ${Cvfasl}.bak; fi)
|
||||
echo '(reset-handler abort)'\
|
||||
'(mkvfasl.inc "${Cvfasl}")' |\
|
||||
${Scheme} -q ${macroobj} mkheader.so mkgc.so
|
||||
(if `cmp -s ${Cvfasl} ${Cvfasl}.bak`;\
|
||||
then mv -f ${Cvfasl}.bak ${Cvfasl};\
|
||||
else rm -f ${Cvfasl}.bak; fi)
|
||||
|
||||
${Cheapcheck}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss
|
||||
(if [ -r ${Cheapcheck} ]; then mv -f ${Cheapcheck} ${Cheapcheck}.bak; fi)
|
||||
echo '(reset-handler abort)'\
|
||||
|
|
@ -685,7 +679,6 @@ reset:
|
|||
$(MAKE) reset-one FILE=gc-oce.inc
|
||||
$(MAKE) reset-one FILE=gc-ocd.inc
|
||||
$(MAKE) reset-one FILE=gc-par.inc
|
||||
$(MAKE) reset-one FILE=vfasl.inc
|
||||
$(MAKE) reset-one FILE=heapcheck.inc
|
||||
|
||||
.PHONY: reset-one
|
||||
|
|
|
|||
|
|
@ -357,7 +357,7 @@
|
|||
;; ---------------------------------------------------------------------
|
||||
;; Version and machine types:
|
||||
|
||||
(define-constant scheme-version #x09050337)
|
||||
(define-constant scheme-version #x09050338)
|
||||
|
||||
(define-syntax define-machine-types
|
||||
(lambda (x)
|
||||
|
|
@ -420,6 +420,12 @@
|
|||
(define-constant ptr-bytes (/ (constant ptr-bits) 8)) ; size in bytes
|
||||
(define-constant log2-ptr-bytes (log2 (constant ptr-bytes)))
|
||||
|
||||
(define-constant double-bytes 8)
|
||||
|
||||
(define-constant byte-bytes 1)
|
||||
(define-constant byte-bits 8)
|
||||
(define-constant log2-byte-bits 3)
|
||||
|
||||
;;; ordinary types must be no more than 8 bits long
|
||||
(define-constant ordinary-type-bits 8) ; smallest addressable unit
|
||||
|
||||
|
|
@ -2185,6 +2191,68 @@
|
|||
(define-constant time-collector-cpu 5)
|
||||
(define-constant time-collector-real 6)
|
||||
|
||||
;; ---------------------------------------------------------------------
|
||||
;; vfasl
|
||||
|
||||
;; For vfasl images: Similar to allocation spaces, but not all
|
||||
;; allocation spaces are represented, and these spaces are more
|
||||
;; fine-grained in some cases:
|
||||
(define-enumerated-constants
|
||||
vspace-symbol
|
||||
vspace-rtd
|
||||
vspace-closure
|
||||
vspace-impure
|
||||
vspace-pure-typed
|
||||
vspace-impure-record
|
||||
;; rest rest are at then end to make the pointer bitmap
|
||||
;; end with zeros (that can be dropped):
|
||||
vspace-code
|
||||
vspace-data
|
||||
vspace-reloc ;; can be dropped after direct to static generation
|
||||
vspaces-count)
|
||||
|
||||
(define-constant vspaces-offsets-count (- (constant vspaces-count) 1))
|
||||
|
||||
(define-primitive-structure-disps vfasl-header typemod
|
||||
([uptr data-size]
|
||||
[uptr table-size]
|
||||
|
||||
[uptr result-offset]
|
||||
|
||||
;; first starting offset is 0, so skip it in this array:
|
||||
[uptr vspace-rel-offsets (constant vspaces-offsets-count)]
|
||||
|
||||
[uptr symref-count]
|
||||
[uptr rtdref-count]
|
||||
[uptr singletonref-count]))
|
||||
|
||||
(define-enumerated-constants
|
||||
singleton-not-a-singleton
|
||||
singleton-null-string
|
||||
singleton-null-vector
|
||||
singleton-null-fxvector
|
||||
singleton-null-flvector
|
||||
singleton-null-bytevector
|
||||
singleton-null-immutable-string
|
||||
singleton-null-immutable-vector
|
||||
singleton-null-immutable-bytevector
|
||||
singleton-eq
|
||||
singleton-eqv
|
||||
singleton-equal
|
||||
singleton-symbol=?
|
||||
singleton-symbol-symbol
|
||||
singleton-symbol-ht-rtd)
|
||||
|
||||
(define-constant vfasl-reloc-tag-bits 3)
|
||||
|
||||
(define-enumerated-constants
|
||||
vfasl-reloc-not-a-tag
|
||||
vfasl-reloc-c-entry-tag
|
||||
vfasl-reloc-library-entry-tag
|
||||
vfasl-reloc-library-entry-code-tag
|
||||
vfasl-reloc-symbol-tag
|
||||
vfasl-reloc-singleton-tag)
|
||||
|
||||
;; ---------------------------------------------------------------------
|
||||
;; General helpers for the compiler and runtime implementation:
|
||||
|
||||
|
|
|
|||
|
|
@ -150,19 +150,16 @@
|
|||
[(arm32)
|
||||
(record-case c
|
||||
[(arm32-abs) (n x)
|
||||
; on ARMV7 would be 8: 4-byte movi, 4-byte movt
|
||||
(let ([a1 (fx- a 12)]) ; 4-byte ldr, 4-byte bra, 4-byte value
|
||||
(let ([a1 (fx- a 4)]) ; [4-byte ldr, 4-byte bra,] 4-byte value
|
||||
(let ([x* (cons (mkcode x) x*)])
|
||||
(let ([r ($reloc (constant reloc-arm32-abs) n (fx- a1 ra))])
|
||||
(mkc0 (cdr c*) a (cons r r*) a1 x*))))]
|
||||
[(arm32-call) (n x)
|
||||
; on ARMV7 would be 12: 4-byte movi, 4-byte movt, 4-byte blx
|
||||
(let ([a1 (fx- a 16)]) ; 4-byte ldr, 4-byte bra, 4-byte value, 4-byte blx
|
||||
(let ([x* (cons (mkcode x) x*)])
|
||||
(let ([r ($reloc (constant reloc-arm32-call) n (fx- a1 ra))])
|
||||
(mkc0 (cdr c*) a (cons r r*) a1 x*))))]
|
||||
[(arm32-jump) (n x)
|
||||
; on ARMV7 would be 12: 4-byte movi, 4-byte movt, 4-byte bx
|
||||
(let ([a1 (fx- a 16)]) ; 4-byte ldr, 4-byte bra, 4-byte value, 4-byte bx
|
||||
(let ([x* (cons (mkcode x) x*)])
|
||||
(let ([r ($reloc (constant reloc-arm32-jump) n (fx- a1 ra))])
|
||||
|
|
@ -411,17 +408,14 @@
|
|||
[(arm32)
|
||||
(record-case c
|
||||
[(arm32-abs) (n x)
|
||||
; on ARMV7 would be 8: 4-byte movi, 4-byte movt
|
||||
(let ([a1 (fx- a 12)]) ; 4-byte ldr, 4-byte bra, 4-byte value
|
||||
(let ([a1 (fx- a 4)]) ; [4-byte ldr, 4-byte bra,] 4-byte value
|
||||
(let ([r ($reloc (constant reloc-arm32-abs) n (fx- a1 ra))])
|
||||
(prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))]
|
||||
[(arm32-call) (n x)
|
||||
; on ARMV7 would be 12: 4-byte movi, 4-byte movt, 4-byte blx
|
||||
(let ([a1 (fx- a 16)]) ; 4-byte ldr, 4-byte bra, 4-byte value, 4-byte blx
|
||||
(let ([r ($reloc (constant reloc-arm32-call) n (fx- a1 ra))])
|
||||
(prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))]
|
||||
[(arm32-jump) (n x)
|
||||
; on ARMV7 would be 12: 4-byte movi, 4-byte movt, 4-byte bx
|
||||
(let ([a1 (fx- a 16)]) ; 4-byte ldr, 4-byte bra, 4-byte value, 4-byte bx
|
||||
(let ([r ($reloc (constant reloc-arm32-jump) n (fx- a1 ra))])
|
||||
(prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))]
|
||||
|
|
@ -1829,43 +1823,8 @@
|
|||
; create boot loader (invoke) for entry into Scheme from C
|
||||
(lambda (out machine . bootfiles)
|
||||
(do-make-boot-header who out machine bootfiles)))
|
||||
|
||||
(set-who! vfasl-convert-file
|
||||
(let ([->vfasl (foreign-procedure "(cs)to_vfasl" (scheme-object) scheme-object)]
|
||||
[vfasl-can-combine? (foreign-procedure "(cs)vfasl_can_combinep" (scheme-object) boolean)])
|
||||
(lambda (in-file out-file bootfile*)
|
||||
(let ([op ($open-file-output-port who out-file (file-options replace))])
|
||||
(on-reset (delete-file out-file #f)
|
||||
(on-reset (close-port op)
|
||||
(when bootfile*
|
||||
(emit-boot-header op (constant machine-type-name) bootfile*))
|
||||
(emit-header op (constant scheme-version) (constant machine-type))
|
||||
(let ([ip ($open-file-input-port who in-file (file-options compressed))])
|
||||
(on-reset (close-port ip)
|
||||
(let* ([write-out (lambda (x)
|
||||
(let ([bv (->vfasl x)])
|
||||
($write-fasl-bytevectors op (list bv) (bytevector-length bv)
|
||||
(constant fasl-type-visit-revisit) (constant fasl-type-vfasl))))]
|
||||
[write-out-accum (lambda (accum)
|
||||
(unless (null? accum)
|
||||
(if (null? (cdr accum))
|
||||
(write-out (car accum))
|
||||
(write-out (list->vector (reverse accum))))))])
|
||||
(let loop ([accum '()])
|
||||
(let ([x (fasl-read ip)])
|
||||
(cond
|
||||
[(eof-object? x)
|
||||
(write-out-accum accum)]
|
||||
[(not (vfasl-can-combine? x))
|
||||
(write-out-accum accum)
|
||||
(write-out x)
|
||||
(loop '())]
|
||||
[(vector? x)
|
||||
(loop (append (reverse (vector->list x)) accum))]
|
||||
[else
|
||||
(loop (cons x accum))]))))
|
||||
(close-port ip)))
|
||||
(close-port op)))))))
|
||||
|
||||
(set! $emit-boot-header emit-boot-header)
|
||||
)
|
||||
|
||||
(set-who! $write-fasl-bytevectors
|
||||
|
|
|
|||
|
|
@ -548,7 +548,7 @@
|
|||
arg-offset fp-offset rextra* rfpextra*)
|
||||
(if (eq? (syntax->datum (car other-type*)) 'fp)
|
||||
(f (cdr other*) (cdr other-type*) (cons fp-offset rtc-disp*)
|
||||
arg-offset (fx+ fp-offset 8) rextra* (cons other rfpextra*))
|
||||
arg-offset (fx+ fp-offset (constant double-bytes)) rextra* (cons other rfpextra*))
|
||||
(f (cdr other*) (cdr other-type*) (cons arg-offset rtc-disp*)
|
||||
(fx+ arg-offset (constant ptr-bytes)) fp-offset (cons other rextra*) rfpextra*))))))]
|
||||
[_ (syntax-error x "missing or out-of-order required registers")])]
|
||||
|
|
|
|||
|
|
@ -148,10 +148,16 @@
|
|||
(put-bytevector p (constant fasl-header))
|
||||
(put-uptr p version)
|
||||
(put-uptr p mtype)
|
||||
(put-u8 p (char->integer #\()) ; )
|
||||
(put-u8 p (char->integer #\())
|
||||
(let f ([bootfiles bootfiles] [sep? #f])
|
||||
(unless (null? bootfiles)
|
||||
(when sep? (put-u8 p (char->integer #\space)))
|
||||
(put-str p (car bootfiles))
|
||||
(f (cdr bootfiles) #t))) ; (
|
||||
(cond
|
||||
[(string? (car bootfiles))
|
||||
(when sep? (put-u8 p (char->integer #\space)))
|
||||
(put-str p (car bootfiles))
|
||||
(f (cdr bootfiles) #t)]
|
||||
[else
|
||||
;; strip produces dependenices as a sequence of bytes
|
||||
(put-u8 p (car bootfiles))
|
||||
(f (cdr bootfiles) #f)])))
|
||||
(put-u8 p (char->integer #\)))]))
|
||||
|
|
|
|||
|
|
@ -13,6 +13,9 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
;; The fasl reader is "fasl.c", which includes an overview of the fasl
|
||||
;; format.
|
||||
|
||||
(let ()
|
||||
(define-record-type target
|
||||
(nongenerative #{target dchg2hp5v3cck8ge283luo-1})
|
||||
|
|
|
|||
|
|
@ -25,8 +25,6 @@
|
|||
;; - self-test : check immediate pointers only for self references
|
||||
;; - size : immediate size, so does not recur
|
||||
;; - measure : recurs for reachable size
|
||||
;; - vfasl-copy
|
||||
;; - vfasl-sweep
|
||||
;; - check
|
||||
|
||||
;; For the specification, there are a few declaration forms described
|
||||
|
|
@ -71,7 +69,6 @@
|
|||
;; Primitive actions/declarations, must be used as statements in roughly
|
||||
;; this order (but there are exceptions to the order):
|
||||
;; - (space <space>) : target for copy; works as a constraint for other modes
|
||||
;; - (vspace <vspace>) : target for vfasl
|
||||
;; - (size <size> [<scale>]) : size for copy; skips rest in size mode
|
||||
;; - (mark <flag>) : in mark mode, skips rest except counting;
|
||||
;; possible <flags>:
|
||||
|
|
@ -106,7 +103,6 @@
|
|||
;; an identifier or a Parenthe-C expression. The meaning of a plain
|
||||
;; identifier depends on the nonterminal:
|
||||
;; - <space> : should be a `space-...` from cmacro
|
||||
;; - <vspace> : should be a `vspace_...`
|
||||
;; - <size> : should be a constant from cmacro
|
||||
;; - <field> : accessor from cmacro, implicitly applied to `_` and `_copy_`
|
||||
|
||||
|
|
@ -151,7 +147,7 @@
|
|||
;;
|
||||
;; Built-in variables:
|
||||
;; - _ : object being copied, swept, etc.
|
||||
;; - _copy_ : target in copy or vfasl mode, same as _ otherwise
|
||||
;; - _copy_ : target in copy mode, same as _ otherwise
|
||||
;; - _size_ : size of the current object, but only in parallel mode
|
||||
;; - _tf_ : type word
|
||||
;; - _tg_ : target generation
|
||||
|
|
@ -168,7 +164,6 @@
|
|||
(case-space
|
||||
[space-ephemeron
|
||||
(space space-ephemeron)
|
||||
(vfasl-fail "ephemeron")
|
||||
(size size-ephemeron)
|
||||
(copy pair-car)
|
||||
(copy pair-cdr)
|
||||
|
|
@ -186,7 +181,6 @@
|
|||
(count countof-ephemeron)]
|
||||
[space-weakpair
|
||||
(space space-weakpair)
|
||||
(vfasl-fail "weakpair")
|
||||
(case-mode
|
||||
[(check) (trace pair-car)]
|
||||
[else])
|
||||
|
|
@ -195,7 +189,6 @@
|
|||
countof-weakpair)]
|
||||
[else
|
||||
(space space-impure)
|
||||
(vspace vspace_impure)
|
||||
(try-double-pair trace pair-car
|
||||
trace pair-cdr
|
||||
countof-pair)])]
|
||||
|
|
@ -214,7 +207,6 @@
|
|||
(space (cond
|
||||
[(and-counts (is_counting_root si _)) space-count-pure]
|
||||
[else space-continuation]))
|
||||
(vfasl-fail "closure")
|
||||
(size size-continuation)
|
||||
(case-mode
|
||||
[self-test]
|
||||
|
|
@ -282,10 +274,6 @@
|
|||
space-closure]
|
||||
[off
|
||||
space-pure])])]))
|
||||
(vspace vspace_closure)
|
||||
(when-vfasl
|
||||
(when (& (code-type code) (<< code-flag-mutable-closure code-flags-offset))
|
||||
(vfasl-fail "mutable closure")))
|
||||
(define len : uptr (code-closure-length code))
|
||||
(size (size_closure len))
|
||||
(when-mark
|
||||
|
|
@ -311,20 +299,18 @@
|
|||
|
||||
[symbol
|
||||
(space space-symbol)
|
||||
(vspace vspace_symbol)
|
||||
(size size-symbol)
|
||||
(mark one-bit)
|
||||
(trace/define symbol-value val :vfasl-as (FIX (vfasl_symbol_to_index vfi _)))
|
||||
(trace/define symbol-value val)
|
||||
(trace-local-symcode symbol-pvalue val)
|
||||
(trace-nonself/vfasl-as-nil symbol-plist)
|
||||
(trace-nonself symbol-plist)
|
||||
(trace-nonself symbol-name)
|
||||
(trace-nonself/vfasl-as-nil symbol-splist)
|
||||
(trace-nonself symbol-splist)
|
||||
(trace-nonself symbol-hash)
|
||||
(count countof-symbol)]
|
||||
|
||||
[flonum
|
||||
(space space-data)
|
||||
(vspace vspace_data)
|
||||
(size size-flonum)
|
||||
(mark)
|
||||
(copy-flonum flonum-data)
|
||||
|
|
@ -372,19 +358,12 @@
|
|||
space-pure-typed-object]
|
||||
[else
|
||||
space-impure-record])]))
|
||||
(vspace (cond
|
||||
[(is_rtd rtd vfi) vspace_rtd]
|
||||
[(== (record-type-mpm rtd) (FIX 0)) vspace_pure_typed]
|
||||
[else vspace_impure_record]))
|
||||
(vfasl-check-parent-rtd rtd)
|
||||
(define len : uptr (UNFIX (record-type-size rtd)))
|
||||
(size (size_record_inst len))
|
||||
(mark counting-root)
|
||||
(trace-record rtd len)
|
||||
(vfasl-set-base-rtd)
|
||||
(pad (when (or-vfasl
|
||||
(\|\| (== p_spc space-pure) (\|\| (== p_spc space-impure)
|
||||
(and-counts (== p_spc space-count-impure)))))
|
||||
(pad (when (\|\| (== p_spc space-pure) (\|\| (== p_spc space-impure)
|
||||
(and-counts (== p_spc space-count-impure))))
|
||||
(let* ([ua_size : uptr (unaligned_size_record_inst len)])
|
||||
(when (!= p_sz ua_size)
|
||||
(set! (* (cast ptr* (TO_VOIDP (+ (cast uptr (UNTYPE _copy_ type_typed_object)) ua_size))))
|
||||
|
|
@ -404,7 +383,6 @@
|
|||
(cond
|
||||
[_backreferences?_ space-impure-typed-object]
|
||||
[else space-impure])]))
|
||||
(vspace vspace_impure)
|
||||
(define len : uptr (Svector_length _))
|
||||
(size (size_vector len))
|
||||
(mark)
|
||||
|
|
@ -421,7 +399,6 @@
|
|||
(cond
|
||||
[_backreferences?_ space-impure-typed-object]
|
||||
[else space-impure]))
|
||||
(vspace vspace_impure)
|
||||
(define len : uptr (Sstencil_vector_length _))
|
||||
(size (size_stencil_vector len))
|
||||
(mark within-segment) ; see assertion
|
||||
|
|
@ -434,7 +411,6 @@
|
|||
|
||||
[string
|
||||
(space space-data)
|
||||
(vspace vspace_data)
|
||||
(define sz : uptr (size_string (Sstring_length _)))
|
||||
(size (just sz))
|
||||
(mark)
|
||||
|
|
@ -443,7 +419,6 @@
|
|||
|
||||
[fxvector
|
||||
(space space-data)
|
||||
(vspace vspace_data)
|
||||
(define sz : uptr (size_fxvector (Sfxvector_length _)))
|
||||
(size (just sz))
|
||||
(mark)
|
||||
|
|
@ -452,7 +427,6 @@
|
|||
|
||||
[flvector
|
||||
(space space-data)
|
||||
(vspace vspace_data)
|
||||
(define sz : uptr (size_flvector (Sflvector_length _)))
|
||||
(size (just sz))
|
||||
(mark)
|
||||
|
|
@ -461,7 +435,6 @@
|
|||
|
||||
[bytevector
|
||||
(space space-data)
|
||||
(vspace vspace_data)
|
||||
(define sz : uptr (size_bytevector (Sbytevector_length _)))
|
||||
(size (just sz))
|
||||
(mark)
|
||||
|
|
@ -473,7 +446,6 @@
|
|||
(cond
|
||||
[_backreferences?_ space-impure-typed-object]
|
||||
[else space-impure]))
|
||||
(vfasl-fail "tlc")
|
||||
(size size-tlc)
|
||||
(mark)
|
||||
(copy-type tlc-type)
|
||||
|
|
@ -493,7 +465,6 @@
|
|||
(cond
|
||||
[_backreferences?_ space-impure-typed-object]
|
||||
[else space-impure])]))
|
||||
(vspace vspace_impure)
|
||||
(size size-box)
|
||||
(mark)
|
||||
(copy-type box-type)
|
||||
|
|
@ -504,7 +475,6 @@
|
|||
(space (case-flag parallel?
|
||||
[on space-pure]
|
||||
[off space-data]))
|
||||
(vspace vspace_impure) ; would be better if we had pure, but these are rare
|
||||
(size size-ratnum)
|
||||
(copy-type ratnum-type)
|
||||
(trace-nonparallel-now ratnum-numerator)
|
||||
|
|
@ -513,14 +483,12 @@
|
|||
[on (pad (set! (ratnum-pad _copy_) 0))]
|
||||
[off])
|
||||
(mark)
|
||||
(vfasl-pad-word)
|
||||
(count countof-ratnum)]
|
||||
|
||||
[exactnum
|
||||
(space (case-flag parallel?
|
||||
[on space-pure]
|
||||
[off space-data]))
|
||||
(vspace vspace_impure) ; same rationale as ratnum
|
||||
(size size-exactnum)
|
||||
(copy-type exactnum-type)
|
||||
(trace-nonparallel-now exactnum-real)
|
||||
|
|
@ -529,12 +497,10 @@
|
|||
[on (pad (set! (exactnum-pad _copy_) 0))]
|
||||
[off])
|
||||
(mark)
|
||||
(vfasl-pad-word)
|
||||
(count countof-exactnum)]
|
||||
|
||||
[inexactnum
|
||||
(space space-data)
|
||||
(vspace vspace_data)
|
||||
(size size-inexactnum)
|
||||
(mark)
|
||||
(copy-type inexactnum-type)
|
||||
|
|
@ -544,7 +510,6 @@
|
|||
|
||||
[bignum
|
||||
(space space-data)
|
||||
(vspace vspace_data)
|
||||
(define sz : uptr (size_bignum (BIGLEN _)))
|
||||
(size (just sz))
|
||||
(mark)
|
||||
|
|
@ -553,7 +518,6 @@
|
|||
|
||||
[port
|
||||
(space space-port)
|
||||
(vfasl-fail "port")
|
||||
(size size-port)
|
||||
(mark one-bit)
|
||||
(copy-type port-type)
|
||||
|
|
@ -568,7 +532,6 @@
|
|||
|
||||
[code
|
||||
(space space-code)
|
||||
(vspace vspace_code)
|
||||
(define len : uptr (code-length _)) ; in bytes
|
||||
(size (size_code len))
|
||||
(mark one-bit)
|
||||
|
|
@ -588,7 +551,6 @@
|
|||
(space (cond
|
||||
[(and-counts (is_counting_root si _)) space-count-pure]
|
||||
[else space-pure-typed-object]))
|
||||
(vfasl-fail "thread")
|
||||
(size size-thread)
|
||||
(mark one-bit)
|
||||
(case-mode
|
||||
|
|
@ -601,7 +563,6 @@
|
|||
|
||||
[rtd-counts
|
||||
(space space-data)
|
||||
(vfasl-as-false "rtd-counts") ; prune counts, since GC will recreate as needed
|
||||
(size size-rtd-counts)
|
||||
(mark)
|
||||
(copy-bytes rtd-counts-type size_rtd_counts)
|
||||
|
|
@ -609,7 +570,6 @@
|
|||
|
||||
[phantom
|
||||
(space space-data)
|
||||
(vfasl-fail "phantom")
|
||||
(size size-phantom)
|
||||
(mark)
|
||||
(copy-type phantom-type)
|
||||
|
|
@ -640,13 +600,6 @@
|
|||
[else
|
||||
(trace-pure field)]))
|
||||
|
||||
(define-trace-macro (trace-nonself/vfasl-as-nil field)
|
||||
(case-mode
|
||||
[vfasl-copy
|
||||
(set! (field _copy_) Snil)]
|
||||
[else
|
||||
(trace-nonself field)]))
|
||||
|
||||
(define-trace-macro (trace-nonparallel-now field)
|
||||
(case-flag parallel?
|
||||
[on (trace-pure field)]
|
||||
|
|
@ -714,34 +667,24 @@
|
|||
|
||||
(define-trace-macro (trace-code-early code)
|
||||
(unless-code-relocated
|
||||
(case-mode
|
||||
[(vfasl-sweep)
|
||||
;; Special relocation handling for code in a closure:
|
||||
(set! code (vfasl_relocate_code vfi code))]
|
||||
[else
|
||||
;; In parallel mode, the `code` pointer may or may not have been
|
||||
;; forwarded. In that case, we may misinterpret the forward mmarker
|
||||
;; as a code type with flags, but it's ok, because the flags will
|
||||
;; only be set for static-generation objects
|
||||
(case-flag parallel?
|
||||
[on (case-mode
|
||||
[(sweep sweep-in-old)
|
||||
(trace-pure-code (just code))]
|
||||
[else])]
|
||||
[off (trace-early (just code))])])))
|
||||
;; In parallel mode, the `code` pointer may or may not have been
|
||||
;; forwarded. In that case, we may misinterpret the forward mmarker
|
||||
;; as a code type with flags, but it's ok, because the flags will
|
||||
;; only be set for static-generation objects
|
||||
(case-flag parallel?
|
||||
[on (case-mode
|
||||
[(sweep sweep-in-old)
|
||||
(trace-pure-code (just code))]
|
||||
[else])]
|
||||
[off (trace-early (just code))])))
|
||||
|
||||
(define-trace-macro (copy-clos-code code)
|
||||
(case-mode
|
||||
[(copy vfasl-copy)
|
||||
[(copy)
|
||||
(SETCLOSCODE _copy_ code)]
|
||||
[(sweep sweep-in-old)
|
||||
(unless-code-relocated
|
||||
(SETCLOSCODE _copy_ code))]
|
||||
[(vfasl-sweep)
|
||||
;; Make the code pointer relative to the base address.
|
||||
;; It's turned back absolute when loading from vfasl
|
||||
(define rel_code : ptr (cast ptr (ptr_diff code (-> vfi base_addr))))
|
||||
(SETCLOSCODE p rel_code)]
|
||||
[else]))
|
||||
|
||||
(define-trace-macro (copy-stack-length continuation-stack-length continuation-stack-clength)
|
||||
|
|
@ -760,15 +703,13 @@
|
|||
[else
|
||||
(copy continuation-stack-length)]))
|
||||
|
||||
(define-trace-macro (trace/define ref val :vfasl-as vfasl-val)
|
||||
(define-trace-macro (trace/define ref val)
|
||||
(case-mode
|
||||
[(copy measure)
|
||||
(trace ref)]
|
||||
[(sweep sweep-in-old)
|
||||
(trace ref) ; can't trace `val` directly, because we need an impure relocate
|
||||
(define val : ptr (ref _))]
|
||||
[vfasl-copy
|
||||
(set! (ref _copy_) vfasl-val)]
|
||||
[else]))
|
||||
|
||||
(define-trace-macro (trace-symcode symbol-pvalue val)
|
||||
|
|
@ -782,8 +723,6 @@
|
|||
[off (trace-pure (just code))])
|
||||
(INITSYMCODE _ code)]
|
||||
[measure]
|
||||
[vfasl-copy
|
||||
(set! (symbol-pvalue _copy_) Snil)]
|
||||
[else
|
||||
(copy symbol-pvalue)]))
|
||||
|
||||
|
|
@ -833,7 +772,7 @@
|
|||
|
||||
(define-trace-macro (trace-record trd len)
|
||||
(case-mode
|
||||
[(copy vfasl-copy)
|
||||
[(copy)
|
||||
(copy-bytes record-data (- len ptr_bytes))]
|
||||
[else
|
||||
;; record-type descriptor was forwarded already
|
||||
|
|
@ -910,37 +849,6 @@
|
|||
(trace-pure (record-type-pm rtd))
|
||||
(set! num (record-type-pm rtd)))
|
||||
|
||||
(define-trace-macro (vfasl-check-parent-rtd rtd)
|
||||
(case-mode
|
||||
[(vfasl-copy)
|
||||
(when (is_rtd rtd vfi)
|
||||
(when (!= _ S_G.base_rtd)
|
||||
;; Make sure rtd's type is registered firs, but
|
||||
;; discard the relocated pointer (leaving to sweep)
|
||||
(cast void (vfasl_relocate_help vfi rtd)))
|
||||
;; Need parent before child
|
||||
(vfasl_relocate_parents vfi (record-type-parent _)))]
|
||||
[(vfasl-sweep)
|
||||
;; Don't need to save fields of base-rtd
|
||||
(when (== _ (-> vfi base_rtd))
|
||||
(let* ([pp : ptr* (& (record-data _ 0))]
|
||||
[ppend : ptr* (- (cast ptr* (TO_VOIDP (+ (cast uptr (TO_PTR pp)) (UNFIX (record-type-size rtd))))) 1)])
|
||||
(while
|
||||
:? (< pp ppend)
|
||||
(set! (* pp) Snil)
|
||||
(set! pp += 1))
|
||||
(return (size_record_inst (UNFIX (record-type-size rtd))))))
|
||||
;; Relocation of rtd fields was deferred
|
||||
(vfasl_relocate vfi (& (record-type _)))]
|
||||
[else]))
|
||||
|
||||
(define-trace-macro (vfasl-set-base-rtd)
|
||||
(case-mode
|
||||
[(vfasl-copy)
|
||||
(when (== _ S_G.base_rtd)
|
||||
(set! (-> vfi base_rtd) _copy_))]
|
||||
[else]))
|
||||
|
||||
(define-trace-macro (count-record rtd)
|
||||
(case-mode
|
||||
[(copy mark)
|
||||
|
|
@ -1157,7 +1065,7 @@
|
|||
|
||||
(define-trace-macro (trace-code len)
|
||||
(case-mode
|
||||
[(copy vfasl-copy)
|
||||
[(copy)
|
||||
(copy-bytes code-data len)]
|
||||
[else
|
||||
(define t : ptr (code-reloc _))
|
||||
|
|
@ -1167,13 +1075,6 @@
|
|||
(define oldco : ptr (cond
|
||||
[t (reloc-table-code t)]
|
||||
[else 0]))
|
||||
(case-mode
|
||||
[vfasl-sweep
|
||||
(let* ([r_sz : uptr (size_reloc_table m)]
|
||||
[new_t : ptr (vfasl_find_room vfi vspace_reloc typemod r_sz)])
|
||||
(memcpy_aligned (TO_VOIDP new_t) (TO_VOIDP t) r_sz)
|
||||
(set! t new_t))]
|
||||
[else])
|
||||
(define a : iptr 0)
|
||||
(define n : iptr 0)
|
||||
(while
|
||||
|
|
@ -1193,16 +1094,10 @@
|
|||
(set! code_off (RELOC_CODE_OFFSET entry))])
|
||||
(set! a (+ a code_off))
|
||||
(let* ([obj : ptr (S_get_code_obj (RELOC_TYPE entry) oldco a item_off)])
|
||||
(case-mode
|
||||
[vfasl-sweep
|
||||
(set! obj (vfasl_encode_relocation vfi obj))]
|
||||
[else
|
||||
(trace-pure (just obj))])
|
||||
(trace-pure (just obj))
|
||||
(case-mode
|
||||
[sweep
|
||||
(S_set_code_obj "gc" (RELOC_TYPE entry) _ a obj item_off)]
|
||||
[vfasl-sweep
|
||||
(S_set_code_obj "vfasl" (abs_reloc_variant (RELOC_TYPE entry)) _ a obj item_off)]
|
||||
[else]))))
|
||||
|
||||
(case-mode
|
||||
|
|
@ -1233,10 +1128,6 @@
|
|||
(set! (reloc-table-code t) _)
|
||||
(set! (code-reloc _) t)])
|
||||
(S_record_code_mod (-> _tgc_ tc) (cast uptr (TO_PTR (& (code-data _ 0)))) (cast uptr (code-length _)))]
|
||||
[vfasl-sweep
|
||||
;; no vfasl_register_pointer, since relink_code can handle it
|
||||
(set! (reloc-table-code t) (cast ptr (ptr_diff _ (-> vfi base_addr))))
|
||||
(set! (code-reloc _) (cast ptr (ptr_diff t (-> vfi base_addr))))]
|
||||
[else])]))
|
||||
|
||||
(define-trace-macro (check-bignum var)
|
||||
|
|
@ -1271,21 +1162,11 @@
|
|||
[on e]
|
||||
[off 1]))
|
||||
|
||||
(define-trace-macro (or-vfasl e)
|
||||
(case-mode
|
||||
[vfasl-copy 1]
|
||||
[else e]))
|
||||
|
||||
(define-trace-macro (and-purity-sensitive-mode e)
|
||||
(case-mode
|
||||
[(sweep sweep-in-old) e]
|
||||
[else 0]))
|
||||
|
||||
(define-trace-macro (when-vfasl e)
|
||||
(case-mode
|
||||
[(vfasl-copy vfasl-sweep) e]
|
||||
[else]))
|
||||
|
||||
(define-trace-macro (when-mark e)
|
||||
(case-mode
|
||||
[(mark) e]
|
||||
|
|
@ -1293,34 +1174,7 @@
|
|||
|
||||
(define-trace-macro (pad e)
|
||||
(case-mode
|
||||
[(copy vfasl-copy) e]
|
||||
[else]))
|
||||
|
||||
(define-trace-macro (vfasl-pad-word)
|
||||
(case-mode
|
||||
[(vfasl-copy)
|
||||
(set! (array-ref (cast ptr* (TO_VOIDP (UNTYPE _copy_ type_typed_object))) 3)
|
||||
0)]
|
||||
[else]))
|
||||
|
||||
(define-trace-macro (vfasl-fail what)
|
||||
(case-mode
|
||||
[(vfasl-copy vfasl-sweep)
|
||||
(vfasl_fail vfi what)
|
||||
(case-mode
|
||||
[vfasl-copy (return (cast ptr 0))]
|
||||
[vfasl-sweep (return 0)])
|
||||
(vspace #f)]
|
||||
[else]))
|
||||
|
||||
(define-trace-macro (vfasl-as-false what)
|
||||
(case-mode
|
||||
[(vfasl-copy)
|
||||
(return Sfalse)
|
||||
(vspace #f)]
|
||||
[(vfasl-sweep)
|
||||
(vfasl-fail what)
|
||||
(vspace #f)]
|
||||
[(copy) e]
|
||||
[else]))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -1460,8 +1314,7 @@
|
|||
(format "static ~a ~a(~aptr p~a)"
|
||||
(case (lookup 'mode config)
|
||||
[(copy mark) "IGEN"]
|
||||
[(vfasl-copy) "ptr"]
|
||||
[(size vfasl-sweep) "uptr"]
|
||||
[(size) "uptr"]
|
||||
[(self-test) "IBOOL"]
|
||||
[(sweep) (if (lookup 'as-dirty? config #f)
|
||||
"IGEN"
|
||||
|
|
@ -1471,12 +1324,10 @@
|
|||
name
|
||||
(case (lookup 'mode config)
|
||||
[(copy mark sweep sweep-in-old measure) "thread_gc *tgc, "]
|
||||
[(vfasl-copy vfasl-sweep)
|
||||
"vfasl_info *vfi, "]
|
||||
[else ""])
|
||||
(case (lookup 'mode config)
|
||||
[(copy) ", seginfo *si, ptr *dest"]
|
||||
[(mark vfasl-copy) ", seginfo *si"]
|
||||
[(mark) ", seginfo *si"]
|
||||
[(sweep)
|
||||
(cond
|
||||
[(lookup 'as-dirty? config #f) ", IGEN youngest"]
|
||||
|
|
@ -1553,17 +1404,6 @@
|
|||
(code-block
|
||||
(body)
|
||||
"return 0;")]
|
||||
[(vfasl-copy)
|
||||
(code-block
|
||||
"ptr new_p;"
|
||||
(body)
|
||||
"vfasl_register_forward(vfi, p, new_p);"
|
||||
"return new_p;")]
|
||||
[(vfasl-sweep)
|
||||
(code-block
|
||||
"uptr result_sz;"
|
||||
(body)
|
||||
"return result_sz;")]
|
||||
[else
|
||||
(body)]))))
|
||||
|
||||
|
|
@ -1629,7 +1469,7 @@
|
|||
(code-block
|
||||
(format "ISPC p_at_spc = ~a;"
|
||||
(case (lookup 'mode config)
|
||||
[(copy mark vfasl-copy) "si->space"]
|
||||
[(copy mark) "si->space"]
|
||||
[else "SPACE(p)"]))
|
||||
(let loop ([all-clauses all-clauses] [else? #f])
|
||||
(match all-clauses
|
||||
|
|
@ -1699,7 +1539,7 @@
|
|||
(relocate-statement 'pure "tmp_p" config)
|
||||
(format "~a = tmp_p;" (field-expression field config "new_p" #f)))]
|
||||
[(self-test) #f]
|
||||
[(measure vfasl-copy vfasl-sweep)
|
||||
[(measure)
|
||||
(statements (list `(trace ,field)) config)]
|
||||
[(mark)
|
||||
(relocate-statement 'pure (field-expression field config "p" #t) config)]
|
||||
|
|
@ -1735,14 +1575,12 @@
|
|||
(field-expression field config "new_p" #f)
|
||||
(field-expression field config "p" #f)))
|
||||
(statements (cdr l) config))]
|
||||
[(vfasl-copy)
|
||||
(statements (cons `(copy ,field) (cdr l)) config)]
|
||||
[else (statements (cdr l) config)])]
|
||||
[else
|
||||
(statements (cons `(copy ,field) (cdr l)) config)])]
|
||||
[`(copy-bytes ,offset ,len)
|
||||
(code (case (lookup 'mode config)
|
||||
[(copy vfasl-copy)
|
||||
[(copy)
|
||||
(format "memcpy_aligned(&~a, &~a, ~a);"
|
||||
(field-expression offset config "new_p" #t)
|
||||
(field-expression offset config "p" #t)
|
||||
|
|
@ -1751,7 +1589,7 @@
|
|||
(statements (cdr l) config))]
|
||||
[`(copy-type ,field)
|
||||
(case (lookup 'mode config)
|
||||
[(copy vfasl-copy)
|
||||
[(copy)
|
||||
(code
|
||||
(format "~a = ~a;"
|
||||
(field-expression field config "new_p" #f)
|
||||
|
|
@ -1770,11 +1608,11 @@
|
|||
config)]
|
||||
[`(trace-ptrs ,offset ,len ,purity)
|
||||
(case (lookup 'mode config)
|
||||
[(copy vfasl-copy)
|
||||
[(copy)
|
||||
(statements (cons `(copy-bytes ,offset (* ptr_bytes ,len))
|
||||
(cdr l))
|
||||
config)]
|
||||
[(sweep measure sweep-in-old vfasl-sweep check)
|
||||
[(sweep measure sweep-in-old check)
|
||||
(code
|
||||
(loop-over-pointers
|
||||
(field-expression offset config "p" #t)
|
||||
|
|
@ -1817,21 +1655,6 @@
|
|||
(cons `(known-space ,s) config)
|
||||
config))]
|
||||
[else (statements (cdr l) config)])]
|
||||
[`(vspace ,s)
|
||||
(case (lookup 'mode config)
|
||||
[(vfasl-copy)
|
||||
(cond
|
||||
[(not s) (code)]
|
||||
[else
|
||||
(code (code-indent "int p_vspc = "
|
||||
(expression s config #f #t)
|
||||
";")
|
||||
(statements (cdr l) (cons '(vspace-ready? #t) config)))])]
|
||||
[(vfasl-sweep)
|
||||
(cond
|
||||
[(not s) (code)]
|
||||
[else (statements (cdr l) config)])]
|
||||
[else (statements (cdr l) config)])]
|
||||
[`(size ,sz)
|
||||
(statements (cons `(size ,sz ,1) (cdr l)) config)]
|
||||
[`(size ,sz ,scale)
|
||||
|
|
@ -1854,25 +1677,18 @@
|
|||
config)]
|
||||
[rest
|
||||
(case mode
|
||||
[(copy vfasl-copy)
|
||||
(case mode
|
||||
[(copy) (unless (lookup 'space-ready? config #f)
|
||||
(error 'generate "size before space"))]
|
||||
[(vfasl-copy) (unless (lookup 'vspace-ready? config #f)
|
||||
(error 'generate "size before vspace for ~a/~a"
|
||||
(lookup 'basetype config)
|
||||
(lookup 'type config #f)))])
|
||||
[(copy)
|
||||
(unless (lookup 'space-ready? config #f)
|
||||
(error 'generate "size before space"))
|
||||
(hashtable-set! (lookup 'used config) 'p_sz #t)
|
||||
(code (format "~a, ~a, p_sz, new_p);"
|
||||
(case mode
|
||||
[(copy) "find_gc_room(tgc, p_spc, tg"]
|
||||
[(vfasl-copy) "FIND_ROOM(vfi, p_vspc"])
|
||||
"find_gc_room(tgc, p_spc, tg"
|
||||
(as-c 'type (lookup 'basetype config)))
|
||||
(statements (let ([extra (lookup 'copy-extra config #f)])
|
||||
(if extra
|
||||
(cons `(copy ,extra) (cdr l))
|
||||
(let* ([mode (lookup 'mode config)]
|
||||
[extra (and (memq mode '(copy vfasl-copy))
|
||||
[extra (and (memq mode '(copy))
|
||||
(lookup 'copy-extra-rtd config #f))])
|
||||
(if extra
|
||||
(cons `(set! (,extra _copy_)
|
||||
|
|
@ -1890,10 +1706,6 @@
|
|||
[(size)
|
||||
(hashtable-set! (lookup 'used config) 'p_sz #t)
|
||||
(code "return p_sz;")]
|
||||
[(vfasl-sweep)
|
||||
(hashtable-set! (lookup 'used config) 'p_sz #t)
|
||||
(code "result_sz = p_sz;"
|
||||
(statements (cdr l) config))]
|
||||
[(measure)
|
||||
(hashtable-set! (lookup 'used config) 'p_sz #t)
|
||||
(code "measure_total += p_sz;"
|
||||
|
|
@ -2069,7 +1881,7 @@
|
|||
(match a
|
||||
[`_ "p"]
|
||||
[`_copy_ (case (lookup 'mode config)
|
||||
[(copy vfasl-copy) "new_p"]
|
||||
[(copy) "new_p"]
|
||||
[else "p"])]
|
||||
[`_size_
|
||||
(cond
|
||||
|
|
@ -2205,12 +2017,10 @@
|
|||
(cond
|
||||
[(or (eq? mode 'sweep)
|
||||
(eq? mode 'sweep-in-old)
|
||||
(eq? mode 'vfasl-sweep)
|
||||
(and early? (or (eq? mode 'copy)
|
||||
(eq? mode 'mark))))
|
||||
(relocate-statement purity (field-expression field config "p" #t) config)]
|
||||
[(or (eq? mode 'copy)
|
||||
(eq? mode 'vfasl-copy))
|
||||
[(eq? mode 'copy)
|
||||
(copy-statement field config)]
|
||||
[(eq? mode 'measure)
|
||||
(measure-statement (field-expression field config "p" #f))]
|
||||
|
|
@ -2228,8 +2038,6 @@
|
|||
(define (relocate-statement purity e config)
|
||||
(define mode (lookup 'mode config))
|
||||
(case mode
|
||||
[(vfasl-sweep)
|
||||
(format "vfasl_relocate(vfi, &~a);" e)]
|
||||
[(sweep-in-old)
|
||||
(if (eq? purity 'pure)
|
||||
(format "relocate_pure(&~a);" e)
|
||||
|
|
@ -2257,7 +2065,7 @@
|
|||
(define (copy-statement field config)
|
||||
(define mode (lookup 'mode config))
|
||||
(case mode
|
||||
[(copy vfasl-copy)
|
||||
[(copy)
|
||||
(cond
|
||||
[(symbol? field)
|
||||
(unless (lookup 'copy-ready? config #f)
|
||||
|
|
@ -2686,16 +2494,6 @@
|
|||
(when measure?
|
||||
(print-code (generate "measure" `((mode measure))))))))
|
||||
|
||||
(define (gen-vfasl ofn)
|
||||
(guard
|
||||
(x [#t (raise x)])
|
||||
(parameterize ([current-output-port (open-output-file ofn 'replace)])
|
||||
(print-code (generate "copy"
|
||||
`((mode vfasl-copy))))
|
||||
(print-code (generate "sweep"
|
||||
`((mode vfasl-sweep)
|
||||
(return-size? #t)))))))
|
||||
|
||||
(define (gen-heapcheck ofn)
|
||||
(guard
|
||||
(x [#t (raise x)])
|
||||
|
|
@ -2713,5 +2511,4 @@
|
|||
(set! mkgc-ocd.inc (lambda (ofn) (gen-gc ofn #f #f #f)))
|
||||
(set! mkgc-oce.inc (lambda (ofn) (gen-gc ofn #t #t #f))) ; not currently parallel (but could be "parallel" for ownership preservation)
|
||||
(set! mkgc-par.inc (lambda (ofn) (gen-gc ofn #f #f #t)))
|
||||
(set! mkvfasl.inc (lambda (ofn) (gen-vfasl ofn)))
|
||||
(set! mkheapcheck.inc (lambda (ofn) (gen-heapcheck ofn))))
|
||||
|
|
|
|||
|
|
@ -45,6 +45,8 @@
|
|||
[(#\?) (cons #\p rest)]
|
||||
[(#\>) rest]
|
||||
[(#\*) (cons #\s rest)]
|
||||
[(#\=) (cons* #\e #\q #\l rest)]
|
||||
[(#\?) (cons #\p rest)]
|
||||
[else (cons x rest)]))
|
||||
'()
|
||||
(string->list (symbol->string x))))))
|
||||
|
|
@ -1153,6 +1155,14 @@
|
|||
(defref RPCOMPACTHEADERMASKANDSIZE rp-compact-header mask+size+mode)
|
||||
(defref RPCOMPACTHEADERTOPLINK rp-compact-header toplink)
|
||||
|
||||
(defref VFASLHEADER_DATA_SIZE vfasl-header data-size)
|
||||
(defref VFASLHEADER_TABLE_SIZE vfasl-header table-size)
|
||||
(defref VFASLHEADER_RESULT_OFFSET vfasl-header result-offset)
|
||||
(defref VFASLHEADER_VSPACE_REL_OFFSETS vfasl-header vspace-rel-offsets)
|
||||
(defref VFASLHEADER_SYMREF_COUNT vfasl-header symref-count)
|
||||
(defref VFASLHEADER_RTDREF_COUNT vfasl-header rtdref-count)
|
||||
(defref VFASLHEADER_SINGLETONREF_COUNT vfasl-header singletonref-count)
|
||||
|
||||
(nl)
|
||||
(comment "machine types")
|
||||
(pr "#define machine_type_names ")
|
||||
|
|
|
|||
|
|
@ -1926,6 +1926,7 @@
|
|||
($dofmt [flags single-valued])
|
||||
($do-wind [flags single-valued])
|
||||
($dynamic-closure-counts [flags single-valued alloc]) ; added for closure instrumentation
|
||||
($emit-boot-header [flags single-valued])
|
||||
($enum-set-members [flags single-valued])
|
||||
($eol-style? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
|
||||
($eq-hashtable-cells [flags single-valued discard])
|
||||
|
|
@ -1949,11 +1950,13 @@
|
|||
($expeditor [feature expeditor] [flags])
|
||||
($fasl-base-rtd [flags single-valued])
|
||||
($fasl-bld-graph [flags single-valued])
|
||||
($fasl-can-combine? [flags single-valued])
|
||||
($fasl-enter [flags single-valued])
|
||||
($fasl-file-equal? [sig [(pathname pathname) (pathname pathname ptr) -> (boolean)]] [flags discard])
|
||||
($fasl-out [flags single-valued])
|
||||
($fasl-start [flags single-valued])
|
||||
($fasl-table [flags single-valued])
|
||||
($fasl-to-vfasl [flags single-valued])
|
||||
($fasl-wrf-graph [flags single-valued])
|
||||
($filter-conv [flags single-valued])
|
||||
($filter-foreign-type [flags single-valued])
|
||||
|
|
|
|||
|
|
@ -1805,6 +1805,8 @@
|
|||
($oops '$thread-tc "~s is not a thread" thread))
|
||||
($thread-tc thread)))
|
||||
|
||||
)
|
||||
|
||||
(when-feature pthreads
|
||||
|
||||
(define $raw-collect-cond (lambda () ($raw-collect-cond)))
|
||||
|
|
@ -2036,7 +2038,7 @@
|
|||
(let ([thread (car (ts))])
|
||||
(lambda () thread)))
|
||||
))
|
||||
|
||||
(begin
|
||||
(let ()
|
||||
(define-syntax define-tc-parameter
|
||||
(lambda (x)
|
||||
|
|
|
|||
30
racket/src/ChezScheme/s/strip-types.ss
Normal file
30
racket/src/ChezScheme/s/strip-types.ss
Normal file
|
|
@ -0,0 +1,30 @@
|
|||
(define-datatype #{fasl striprur0zx3-fasl}
|
||||
(#{entry striprur0zx3-0} situation fasl)
|
||||
(#{header striprur0zx3-1} version machine dependencies)
|
||||
(#{pair striprur0zx3-2} vfasl)
|
||||
(#{tuple striprur0zx3-3} ty vfasl)
|
||||
(#{string striprur0zx3-4} ty string)
|
||||
(#{gensym striprur0zx30-5} pname uname)
|
||||
(#{vector striprur0zx3-6} ty vfasl)
|
||||
(#{fxvector striprur0zx3-7} viptr)
|
||||
(#{bytevector striprur0zx3-9} ty bv)
|
||||
(#{stencil-vector striprur0zx3-sv} mask vfasl)
|
||||
(#{record striprur0zx3-10} maybe-uid size nflds rtd pad-ty* fld*) ; maybe-uid => rtd
|
||||
(#{rtd-ref striprur0zx3-11} uid) ; field info not recorded
|
||||
(#{closure striprur0zx3-12} offset c)
|
||||
(#{flonum striprur0zx3-13} high low)
|
||||
(#{small-integer striprur0zx3-14} iptr)
|
||||
(#{large-integer striprur0zx3-15} sign vuptr)
|
||||
(#{eq-hashtable striprur0zx3-16} mutable? subtype minlen veclen vpfasl)
|
||||
(#{symbol-hashtable striprur0zx3-17} mutable? minlen equiv veclen vpfasl)
|
||||
(#{code striprur0zx3-18} flags free name arity-mask info pinfo* bytes m vreloc)
|
||||
(#{atom striprur0zx3-19} ty uptr)
|
||||
(#{reloc striprur0zx3-20} type-etc code-offset item-offset fasl)
|
||||
(#{indirect striprur0zx3-21} g i))
|
||||
|
||||
(define-datatype #{field stripfur0zx3-field}
|
||||
(#{ptr stripfur0zx3-0} fasl)
|
||||
(#{byte stripfur0zx3-1} n)
|
||||
(#{iptr stripfur0zx3-2} n)
|
||||
(#{single stripfur0zx3-3} n)
|
||||
(#{double stripfur0zx3-4} high low))
|
||||
|
|
@ -13,41 +13,17 @@
|
|||
;;; See the License for the specific language governing permissions and
|
||||
;;; limitations under the License.
|
||||
|
||||
;; The `strip-fasl-file` and related functions use a fasl reader and
|
||||
;; writer that are completely separate from the ones in "fasl.ss" and
|
||||
;; "fasl.c", so changes made in those places must be duplicated here.
|
||||
;; The vfasl writer uses this fasl reader.
|
||||
|
||||
(let ()
|
||||
; per file
|
||||
(define-threaded fasl-who)
|
||||
(define-threaded fasl-count)
|
||||
|
||||
(define-datatype fasl
|
||||
(entry situation fasl)
|
||||
(header version machine dependencies)
|
||||
(pair vfasl)
|
||||
(tuple ty vfasl)
|
||||
(string ty string)
|
||||
(gensym pname uname)
|
||||
(vector ty vfasl)
|
||||
(fxvector viptr)
|
||||
(flvector vfl)
|
||||
(bytevector ty bv)
|
||||
(record maybe-uid size nflds rtd pad-ty* fld*) ; maybe-uid => rtd
|
||||
(rtd-ref uid) ; field info not recorded
|
||||
(closure offset c)
|
||||
(flonum high low)
|
||||
(small-integer iptr)
|
||||
(large-integer sign vuptr)
|
||||
(eq-hashtable mutable? subtype minlen veclen vpfasl)
|
||||
(symbol-hashtable mutable? minlen equiv veclen vpfasl)
|
||||
(code flags free name arity-mask info pinfo* bytes m vreloc)
|
||||
(atom ty uptr)
|
||||
(reloc type-etc code-offset item-offset fasl)
|
||||
(indirect g i))
|
||||
|
||||
(define-datatype field
|
||||
(ptr fasl)
|
||||
(byte n)
|
||||
(iptr n)
|
||||
(single n)
|
||||
(double high low))
|
||||
(include "strip-types.ss")
|
||||
|
||||
(define follow-indirect
|
||||
(lambda (x)
|
||||
|
|
@ -217,10 +193,12 @@
|
|||
[(fasl-type-gensym)
|
||||
(let* ([pname (read-string p)] [uname (read-string p)])
|
||||
(fasl-gensym pname uname))]
|
||||
[(fasl-type-ratnum fasl-type-exactnum fasl-type-inexactnum fasl-type-weak-pair)
|
||||
[(fasl-type-ratnum fasl-type-exactnum fasl-type-inexactnum
|
||||
fasl-type-weak-pair fasl-type-ephemeron)
|
||||
(let ([first (read-fasl p g)])
|
||||
(fasl-tuple ty (vector first (read-fasl p g))))]
|
||||
[(fasl-type-vector fasl-type-immutable-vector) (fasl-vector ty (read-vfasl p g (read-uptr p)))]
|
||||
[(fasl-type-vector fasl-type-immutable-vector fasl-type-flvector)
|
||||
(fasl-vector ty (read-vfasl p g (read-uptr p)))]
|
||||
[(fasl-type-fxvector)
|
||||
(fasl-fxvector
|
||||
(let ([n (read-uptr p)])
|
||||
|
|
@ -228,14 +206,11 @@
|
|||
(do ([i 0 (fx+ i 1)])
|
||||
((fx= i n) v)
|
||||
(vector-set! v i (read-iptr p))))))]
|
||||
[(fasl-type-flvector)
|
||||
(let ([n (read-uptr p)])
|
||||
(let ([vfl (make-vector n)])
|
||||
(do ([i 0 (fx+ i 1)])
|
||||
((fx= i n) vfl)
|
||||
(vector-set! vfl i (read-fasl p g)))))]
|
||||
[(fasl-type-bytevector fasl-type-immutable-bytevector)
|
||||
(fasl-bytevector ty (read-bytevector p (read-uptr p)))]
|
||||
[(fasl-type-stencil-vector)
|
||||
(let ([mask (read-uptr p)])
|
||||
(fasl-stencil-vector mask (read-vfasl p g (bitwise-bit-count mask))))]
|
||||
[(fasl-type-base-rtd) (fasl-tuple ty '#())]
|
||||
[(fasl-type-rtd) (let* ([uid (read-fasl p g)]
|
||||
[size (read-uptr p)])
|
||||
|
|
@ -319,6 +294,14 @@
|
|||
(let ([n (read-uptr p)])
|
||||
(or (vector-ref g n)
|
||||
(fasl-indirect g n)))]
|
||||
[(fasl-type-begin)
|
||||
(let loop ([n (read-uptr p)])
|
||||
(if (fx= n 1)
|
||||
(read-fasl p g)
|
||||
(begin
|
||||
;; will set graph definitions:
|
||||
(read-fasl p g)
|
||||
(loop (fx- n 1)))))]
|
||||
[else (bogus "unexpected fasl code ~s in ~a" ty (port-name p))]))))
|
||||
|
||||
(define read-script-header
|
||||
|
|
@ -439,8 +422,8 @@
|
|||
[gensym (pname uname) (build-graph! x t void)]
|
||||
[vector (ty vfasl) (build-graph! x t (build-vfasl! vfasl))]
|
||||
[fxvector (viptr) (build-graph! x t void)]
|
||||
[flvector (vfl) (build-graph! x t void)]
|
||||
[bytevector (ty viptr) (build-graph! x t void)]
|
||||
[stencil-vector (mask vfasl) (build-graph! x t (build-vfasl! vfasl))]
|
||||
[record (maybe-uid size nflds rtd pad-ty* fld*)
|
||||
(if (and strip-source-annotations? (fasl-annotation? x))
|
||||
(build! (fasl-annotation-stripped x) t)
|
||||
|
|
@ -488,24 +471,35 @@
|
|||
|
||||
(include "fasl-helpers.ss")
|
||||
|
||||
(define write-entry
|
||||
(lambda (p x)
|
||||
(define handle-entry
|
||||
(lambda (x header-k entry-k)
|
||||
(fasl-case x
|
||||
[header (version machine dependencies)
|
||||
(emit-header p version machine dependencies)]
|
||||
(header-k (lambda (p) (emit-header p version machine dependencies)))]
|
||||
[entry (situation fasl)
|
||||
(let ([t (make-table)])
|
||||
(build! fasl t)
|
||||
(let-values ([(bv* size)
|
||||
(let-values ([(p extractor) ($open-bytevector-list-output-port)])
|
||||
(let ([n (table-count t)])
|
||||
(unless (fx= n 0)
|
||||
(put-u8 p (constant fasl-type-graph))
|
||||
(put-uptr p n)))
|
||||
(write-fasl p t fasl)
|
||||
(extractor))])
|
||||
($write-fasl-bytevectors p bv* size situation (constant fasl-type-fasl))))]
|
||||
[else (sorry! "unrecognized top-level fasl-record-type ~s" x)])))
|
||||
(entry-k situation fasl)]
|
||||
[else
|
||||
(sorry! "unrecognized top-level fasl-record-type ~s" x)])))
|
||||
|
||||
(define (write-one-entry p situation fasl)
|
||||
(let ([t (make-table)])
|
||||
(build! fasl t)
|
||||
(let-values ([(bv* size)
|
||||
(let-values ([(p extractor) ($open-bytevector-list-output-port)])
|
||||
(let ([n (table-count t)])
|
||||
(unless (fx= n 0)
|
||||
(put-u8 p (constant fasl-type-graph))
|
||||
(put-uptr p n)))
|
||||
(write-fasl p t fasl)
|
||||
(extractor))])
|
||||
($write-fasl-bytevectors p bv* size situation (constant fasl-type-fasl)))))
|
||||
|
||||
(define write-entry
|
||||
(lambda (p x)
|
||||
(handle-entry
|
||||
x
|
||||
(lambda (write-k) (write-k p))
|
||||
(lambda (situation fasl) (write-one-entry p situation fasl)))))
|
||||
|
||||
(define write-graph
|
||||
(lambda (p t x th)
|
||||
|
|
@ -560,18 +554,18 @@
|
|||
(put-u8 p (constant fasl-type-fxvector))
|
||||
(put-uptr p (vector-length viptr))
|
||||
(vector-for-each (lambda (iptr) (put-iptr p iptr)) viptr)))]
|
||||
[flvector (vfl)
|
||||
(write-graph p t x
|
||||
(lambda ()
|
||||
(put-u8 p (constant fasl-type-flvector))
|
||||
(put-uptr p (vector-length vfl))
|
||||
(vector-for-each (lambda (x) (write-fasl p t x)) vfl)))]
|
||||
[bytevector (ty bv)
|
||||
(write-graph p t x
|
||||
(lambda ()
|
||||
(put-u8 p ty)
|
||||
(put-uptr p (bytevector-length bv))
|
||||
(put-bytevector p bv)))]
|
||||
[stencil-vector (mask vfasl)
|
||||
(write-graph p t x
|
||||
(lambda ()
|
||||
(put-u8 p (constant fasl-type-stencil-vector))
|
||||
(put-uptr p mask)
|
||||
(vector-for-each (lambda (fasl) (write-fasl p t fasl)) vfasl)))]
|
||||
[record (maybe-uid size nflds rtd pad-ty* fld*)
|
||||
(if (and strip-source-annotations? (fasl-annotation? x))
|
||||
(write-fasl p t (fasl-annotation-stripped x))
|
||||
|
|
@ -771,6 +765,9 @@
|
|||
[(fasl-type-weak-pair)
|
||||
(weak-cons (describe (vector-ref vfasl 0))
|
||||
(describe (vector-ref vfasl 1)))]
|
||||
[(fasl-type-ephemeron)
|
||||
(ephemeron-cons (describe (vector-ref vfasl 0))
|
||||
(describe (vector-ref vfasl 1)))]
|
||||
[(fasl-type-base-rtd)
|
||||
#!base-rtd]
|
||||
[else
|
||||
|
|
@ -782,8 +779,8 @@
|
|||
[gensym (pname uname) (gensym pname uname)]
|
||||
[vector (ty vfasl) (vector-map describe vfasl)]
|
||||
[fxvector (viptr) viptr]
|
||||
[flvector (vfl) vfl]
|
||||
[bytevector (ty bv) bv]
|
||||
[stencil-vector (ty vfasl) (vector-map describe vfasl)]
|
||||
[record (maybe-uid size nflds rtd pad-ty* fld*)
|
||||
(vector 'RECORD
|
||||
(and maybe-uid (describe maybe-uid))
|
||||
|
|
@ -885,6 +882,25 @@
|
|||
(let ([ip ($open-file-input-port fasl-who ifn)])
|
||||
(on-reset (close-port ip)
|
||||
(read-and-strip-from-port ip ifn #f)))))
|
||||
(define convert-fasl-file
|
||||
(lambda (who ifn ofn options write)
|
||||
(unless (string? ifn) ($oops who "~s is not a string" ifn))
|
||||
(unless (string? ofn) ($oops who "~s is not a string" ofn))
|
||||
(unless (and (enum-set? options) (enum-set-subset? options $fasl-strip-options))
|
||||
($oops who "~s is not a fasl-strip-options object" options))
|
||||
(fluid-let ([strip-inspector-information? (enum-set-subset? (fasl-strip-options inspector-source) options)]
|
||||
[strip-profile-information? (enum-set-subset? (fasl-strip-options profile-source) options)]
|
||||
[strip-source-annotations? (enum-set-subset? (fasl-strip-options source-annotations) options)]
|
||||
[strip-compile-time-information? (enum-set-subset? (fasl-strip-options compile-time-information) options)]
|
||||
[fasl-who who]
|
||||
[fasl-count 0])
|
||||
(let-values ([(script-header mode entry*) (read-and-strip-file ifn)])
|
||||
(let ([op ($open-file-output-port who ofn (file-options replace))])
|
||||
(on-reset (delete-file ofn #f)
|
||||
(on-reset (close-port op)
|
||||
(write script-header mode entry* op)
|
||||
(close-port op)
|
||||
(unless-feature windows (when mode (chmod ofn mode))))))))))
|
||||
(set-who! $describe-fasl-from-port
|
||||
(rec $describe-fasl-from-port
|
||||
(case-lambda
|
||||
|
|
@ -901,26 +917,60 @@
|
|||
(list (and script-header (describe script-header))
|
||||
(map describe entry*))))])))
|
||||
(set-who! strip-fasl-file
|
||||
(rec strip-fasl-file
|
||||
(lambda (ifn ofn options)
|
||||
(unless (string? ifn) ($oops who "~s is not a string" ifn))
|
||||
(unless (string? ofn) ($oops who "~s is not a string" ofn))
|
||||
(unless (and (enum-set? options) (enum-set-subset? options $fasl-strip-options))
|
||||
($oops who "~s is not a fasl-strip-options object" options))
|
||||
(fluid-let ([strip-inspector-information? (enum-set-subset? (fasl-strip-options inspector-source) options)]
|
||||
[strip-profile-information? (enum-set-subset? (fasl-strip-options profile-source) options)]
|
||||
[strip-source-annotations? (enum-set-subset? (fasl-strip-options source-annotations) options)]
|
||||
[strip-compile-time-information? (enum-set-subset? (fasl-strip-options compile-time-information) options)]
|
||||
[fasl-who who]
|
||||
[fasl-count 0])
|
||||
(let-values ([(script-header mode entry*) (read-and-strip-file ifn)])
|
||||
(let ([op ($open-file-output-port who ofn (file-options replace))])
|
||||
(on-reset (delete-file ofn #f)
|
||||
(on-reset (close-port op)
|
||||
(when script-header (put-bytevector op script-header))
|
||||
(for-each (lambda (entry) (write-entry op entry)) entry*)
|
||||
(close-port op)
|
||||
(unless-feature windows (when mode (chmod ofn mode)))))))))))))
|
||||
(lambda (ifn ofn options)
|
||||
(convert-fasl-file who ifn ofn options
|
||||
(lambda (script-header mode entry* op)
|
||||
(when script-header (put-bytevector op script-header))
|
||||
(for-each (lambda (entry) (write-entry op entry)) entry*)))))
|
||||
(set-who! vfasl-convert-file
|
||||
(lambda (ifn ofn bootfile*)
|
||||
(convert-fasl-file who ifn ofn (fasl-strip-options)
|
||||
(lambda (script-header mode entry* op)
|
||||
(when bootfile*
|
||||
($emit-boot-header op (constant machine-type-name) bootfile*))
|
||||
(let* ([write-out
|
||||
(lambda (x situation)
|
||||
(let ([bv ($fasl-to-vfasl x)])
|
||||
($write-fasl-bytevectors op (list bv) (bytevector-length bv)
|
||||
;; see "promoting" below:
|
||||
(constant fasl-type-visit-revisit)
|
||||
(constant fasl-type-vfasl))))]
|
||||
[write-out-accum (lambda (accum situation)
|
||||
(unless (null? accum)
|
||||
(if (null? (cdr accum))
|
||||
(write-out (car accum) situation)
|
||||
(write-out (fasl-vector (constant fasl-type-vector)
|
||||
(list->vector (reverse accum)))
|
||||
situation))))])
|
||||
(let loop ([ignore-header? #f] [accum '()] [accum-situation #f] [entry* entry*])
|
||||
(cond
|
||||
[(null? entry*)
|
||||
(write-out-accum accum accum-situation)]
|
||||
[else
|
||||
(handle-entry
|
||||
(car entry*)
|
||||
(lambda (write-k)
|
||||
(unless ignore-header?
|
||||
(write-k op))
|
||||
(loop #t accum accum-situation (cdr entry*)))
|
||||
(lambda (situation x)
|
||||
(cond
|
||||
[(vector? x)
|
||||
(loop #t
|
||||
(append (reverse (vector->list x)) accum)
|
||||
situation
|
||||
(cdr entry*))]
|
||||
[(or (not ($fasl-can-combine? x))
|
||||
;; improve sharing by promiting everyting to visit-revisit,
|
||||
;; instead of comparing situations
|
||||
#;
|
||||
(and accum-situation
|
||||
(not (eqv? accum-situation situation))))
|
||||
(write-out-accum accum accum-situation)
|
||||
(write-out x situation)
|
||||
(loop #t '() #f (cdr entry*))]
|
||||
[else
|
||||
(loop #t (cons x accum) situation (cdr entry*))])))])))))))))
|
||||
|
||||
(let ()
|
||||
; per file
|
||||
|
|
@ -995,8 +1045,8 @@
|
|||
(string=? x uname2))))]
|
||||
[vector (ty vfasl) (and (eqv? ty1 ty2) (vandmap fasl=? vfasl1 vfasl2))]
|
||||
[fxvector (viptr) (vandmap = viptr1 viptr2)]
|
||||
[flvector (vfl) (vandmap fasl=? vfl1 vfl2)]
|
||||
[bytevector (ty bv) (and (eqv? ty1 ty2) (bytevector=? bv1 bv2))]
|
||||
[stencil-vector (mask vfasl) (and (eqv? mask1 mask2) (vandmap fasl=? vfasl1 vfasl2))]
|
||||
[record (maybe-uid size nflds rtd pad-ty* fld*)
|
||||
(and (if maybe-uid1
|
||||
(and maybe-uid2 (fasl=? maybe-uid1 maybe-uid2))
|
||||
|
|
|
|||
1092
racket/src/ChezScheme/s/vfasl.ss
Normal file
1092
racket/src/ChezScheme/s/vfasl.ss
Normal file
File diff suppressed because it is too large
Load Diff
|
|
@ -220,13 +220,13 @@ raw_gracketcs: grmain.o boot.o $(BOOT_OBJ_DEPS)
|
|||
@POST_LINKER@ raw_gracketcs
|
||||
|
||||
petite-v.boot: $(SCHEME_TARGET_INC)/petite.boot
|
||||
$(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ @TT_CROSS_MODE@ $(SCHEME_TARGET_INC)/petite.boot petite-v.boot
|
||||
$(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ $(XPATCH@CROSS_MODE@) $(SCHEME_TARGET_INC)/petite.boot petite-v.boot
|
||||
|
||||
scheme-v.boot: $(SCHEME_TARGET_INC)/scheme.boot
|
||||
$(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ @TT_CROSS_MODE@ $(SCHEME_TARGET_INC)/scheme.boot scheme-v.boot petite
|
||||
$(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ $(XPATCH@CROSS_MODE@) $(SCHEME_TARGET_INC)/scheme.boot scheme-v.boot petite
|
||||
|
||||
racket-v.boot: racket.boot
|
||||
$(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ @TT_CROSS_MODE@ racket.boot racket-v.boot petite scheme
|
||||
$(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ $(XPATCH@CROSS_MODE@) racket.boot racket-v.boot petite scheme
|
||||
|
||||
# ----------------------------------------
|
||||
# Mac OS
|
||||
|
|
@ -273,9 +273,9 @@ $(RKTFW): $(BOOT_OBJ_DEPS) $(BOOT_FILES)
|
|||
rm -f Racket.framework/Racket
|
||||
ln -s Versions/$(FWVERSION)_CS/Racket Racket.framework/Racket
|
||||
mkdir -p Racket.framework/Versions/$(FWVERSION)_CS/boot
|
||||
$(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ @TT_CROSS_MODE@ $(SCHEME_TARGET_INC)/petite.boot $(FW_BOOT_DEST)/petite.boot
|
||||
$(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ @TT_CROSS_MODE@ $(SCHEME_TARGET_INC)/scheme.boot $(FW_BOOT_DEST)/scheme.boot petite
|
||||
$(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ @TT_CROSS_MODE@ racket.boot $(FW_BOOT_DEST)/racket.boot petite scheme
|
||||
$(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ $(XPATCH@CROSS_MODE@) $(SCHEME_TARGET_INC)/petite.boot $(FW_BOOT_DEST)/petite.boot
|
||||
$(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ $(XPATCH@CROSS_MODE@) $(SCHEME_TARGET_INC)/scheme.boot $(FW_BOOT_DEST)/scheme.boot petite
|
||||
$(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ $(XPATCH@CROSS_MODE@) racket.boot $(FW_BOOT_DEST)/racket.boot petite scheme
|
||||
|
||||
adjust-framework-boot-compress:
|
||||
$(BOOTSTRAP_RACKET) $(srcdir)/adjust-compress.rkt @BOOT_COMPRESS_COMP@ $(FW_BOOT_DEST)/petite.boot $(FW_BOOT_DEST)/scheme.boot $(FW_BOOT_DEST)/racket.boot
|
||||
|
|
|
|||
|
|
@ -25,7 +25,6 @@ check_pb equates.h
|
|||
check_pb gc-ocd.inc
|
||||
check_pb gc-oce.inc
|
||||
check_pb gc-par.inc
|
||||
check_pb vfasl.inc
|
||||
check_pb heapcheck.inc
|
||||
|
||||
check_mach()
|
||||
|
|
@ -46,5 +45,4 @@ check_mach equates.h
|
|||
check_mach gc-ocd.inc
|
||||
check_mach gc-oce.inc
|
||||
check_mach gc-par.inc
|
||||
check_mach vfasl.inc
|
||||
check_mach heapcheck.inc
|
||||
|
|
|
|||
|
|
@ -23,7 +23,6 @@ ready_mach equates.h
|
|||
ready_mach gc-ocd.inc
|
||||
ready_mach gc-oce.inc
|
||||
ready_mach gc-par.inc
|
||||
ready_mach vfasl.inc
|
||||
ready_mach heapcheck.inc
|
||||
|
||||
rm -f boot_pending
|
||||
|
|
|
|||
|
|
@ -26,4 +26,3 @@ ready_mach equates.h
|
|||
ready_mach gc-ocd.inc
|
||||
ready_mach gc-oce.inc
|
||||
ready_mach gc-par.inc
|
||||
ready_mach vfasl.inc
|
||||
|
|
|
|||
|
|
@ -1,5 +1,4 @@
|
|||
(fasl-compressed #f)
|
||||
(define compile-cross? #f)
|
||||
|
||||
(define-values (src dest deps)
|
||||
(let loop ([args (command-line-arguments)])
|
||||
|
|
@ -9,9 +8,10 @@
|
|||
(fasl-compressed #t)
|
||||
(loop (cdr args))]
|
||||
[(and (pair? args)
|
||||
(equal? (car args) "--cross"))
|
||||
(set! compile-cross? #t)
|
||||
(loop (cdr args))]
|
||||
(equal? (car args) "--xpatch")
|
||||
(pair? (cdr args)))
|
||||
(load (cadr args))
|
||||
(loop (cddr args))]
|
||||
[(null? args)
|
||||
(error 'to-vfasl "missing src argument")]
|
||||
[(null? (cdr args))
|
||||
|
|
@ -19,17 +19,4 @@
|
|||
[else
|
||||
(values (car args) (cadr args) (cddr args))])))
|
||||
|
||||
(cond
|
||||
[compile-cross?
|
||||
(printf "Cross-compile cannot convert to vfasl; leaving as-is\n")
|
||||
(let ([i (open-file-input-port src)]
|
||||
[o (open-file-output-port dest (file-options no-fail))])
|
||||
(let loop ()
|
||||
(define c (get-u8 i))
|
||||
(unless (eof-object? c)
|
||||
(put-u8 o c)
|
||||
(loop)))
|
||||
(close-port i)
|
||||
(close-port o))]
|
||||
[else
|
||||
(vfasl-convert-file src dest deps)])
|
||||
(vfasl-convert-file src dest deps)
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@
|
|||
#define MZSCHEME_VERSION_X 7
|
||||
#define MZSCHEME_VERSION_Y 9
|
||||
#define MZSCHEME_VERSION_Z 0
|
||||
#define MZSCHEME_VERSION_W 13
|
||||
#define MZSCHEME_VERSION_W 14
|
||||
|
||||
/* A level of indirection makes `#` work as needed: */
|
||||
#define AS_a_STR_HELPER(x) #x
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user