From e3929bcf51c767e2c43533b07b67d4261a8ca506 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 26 Jan 2022 16:36:38 -0700 Subject: [PATCH] Chez Scheme: add pbchunks support As of comment 4480e643da, Chez Scheme can support Racket CS on a platform where there's no native-code backend and where code generation beyond libffi's is disallowed. Then again, since interpreted mode is a factor of 20 slower, it's not so practical. This commit makes a no-native-backed Racket CS somewhat more practical by adding a "pbchunks" mode that compiles some bytecode to C. That compilation path makes sense for the static code that is built into the Racket CS executable, which includes the layers from Chez Scheme primitive through the Racker expander. This strategy is analogous to the "cify" mode of non-JIT Racket BC, which compiles the Racket macro expander to C. One difference between pbchunks and cify is that Racket BC's primitives are already implemented in C, so cify applies only to the expander's implementation. Compilation with pbchunks applies even to the implementation of Scheme primitives. (Neither applies to Racket-level code that is run via no-JIT Racket BC with cify or no-native-backend Racket CS with pbchunks.) That difference explains the relative performance I find on my machines for `racket -cl racket/base`: pure native interpreted cify/pbchunks Racket CS x1 x20 x4 Racket BC x1 x5 x1 The x4 is not great, but the end result is that building a Racket distirbution with pbchunks Racket CS feels at least practical, while pure interpreted Racket CS took longer than I was willing to wait. --- .makefile | 2 +- Makefile | 14 +- pkgs/base/info.rkt | 2 +- racket/src/ChezScheme/BUILDING | 2 +- racket/src/ChezScheme/IMPLEMENTATION.md | 86 +- racket/src/ChezScheme/c/Mf-base | 4 +- racket/src/ChezScheme/c/atomic.h | 6 +- racket/src/ChezScheme/c/externs.h | 2 +- racket/src/ChezScheme/c/fasl.c | 23 +- racket/src/ChezScheme/c/ffi.c | 2 +- racket/src/ChezScheme/c/pb.c | 862 +++---------- racket/src/ChezScheme/c/pb.h | 809 ++++++++++++ racket/src/ChezScheme/c/prim.c | 2 +- racket/src/ChezScheme/c/prim5.c | 48 +- racket/src/ChezScheme/c/segment.c | 6 +- racket/src/ChezScheme/c/thread.c | 8 +- racket/src/ChezScheme/c/types.h | 2 +- racket/src/ChezScheme/c/version.h | 15 +- racket/src/ChezScheme/configure | 57 +- racket/src/ChezScheme/csug/system.stex | 24 + racket/src/ChezScheme/makefiles/Mf-install.in | 2 +- racket/src/ChezScheme/rktboot/machine-def.rkt | 20 +- racket/src/ChezScheme/s/Mf-base | 6 +- racket/src/ChezScheme/s/cmacros.ss | 17 +- racket/src/ChezScheme/s/cptypes-lattice.ss | 14 +- racket/src/ChezScheme/s/mkheader.ss | 24 + racket/src/ChezScheme/s/pb.def | 6 +- racket/src/ChezScheme/s/pb.ss | 8 +- racket/src/ChezScheme/s/pbarch.def | 13 + racket/src/ChezScheme/s/pbchunk.ss | 1089 +++++++++++++++++ racket/src/ChezScheme/s/pbcommon.def | 4 +- racket/src/ChezScheme/s/pbcommon32.def | 5 + racket/src/ChezScheme/s/pbcommon64.def | 5 + racket/src/ChezScheme/s/primdata.ss | 2 + racket/src/ChezScheme/s/strip-types.ss | 23 + racket/src/ChezScheme/s/strip.ss | 33 +- racket/src/ChezScheme/s/tpb.def | 8 +- racket/src/ChezScheme/s/tpbarch.def | 13 + racket/src/ChezScheme/s/vfasl.ss | 59 +- racket/src/ChezScheme/workarea | 60 +- racket/src/README.txt | 22 +- racket/src/cs/c/Makefile.in | 168 ++- racket/src/cs/c/boot.c | 76 ++ racket/src/cs/c/configure | 33 +- racket/src/cs/c/configure.ac | 25 +- racket/src/cs/c/gen-system.rkt | 15 +- racket/src/cs/c/to-pbchunk.ss | 57 + racket/src/cs/rumble/system.ss | 28 +- racket/src/version/racket_version.h | 2 +- racket/src/worksp/csbuild.rkt | 1 + 50 files changed, 2907 insertions(+), 907 deletions(-) create mode 100644 racket/src/ChezScheme/c/pb.h create mode 100644 racket/src/ChezScheme/s/pbarch.def create mode 100644 racket/src/ChezScheme/s/pbchunk.ss create mode 100644 racket/src/ChezScheme/s/pbcommon32.def create mode 100644 racket/src/ChezScheme/s/pbcommon64.def create mode 100644 racket/src/ChezScheme/s/tpbarch.def create mode 100644 racket/src/cs/c/to-pbchunk.ss diff --git a/.makefile b/.makefile index 2a4f75e2b0b..4184b7b3dd4 100644 --- a/.makefile +++ b/.makefile @@ -344,7 +344,7 @@ RACKET_FOR_BOOTFILES = $(RACKET) RACKET_FOR_BUILD = $(RACKET) # This branch name changes each time the pb boot files are updated: -PB_BRANCH == circa-8.4.0.4-2 +PB_BRANCH == circa-8.4.0.5-1 PB_REPO = https://github.com/racket/pb # Set to empty for Git before v1.7.10: diff --git a/Makefile b/Makefile index 3752b01b82b..4b5bdc66a28 100644 --- a/Makefile +++ b/Makefile @@ -47,7 +47,7 @@ RACKETCS_SUFFIX = RACKET = RACKET_FOR_BOOTFILES = $(RACKET) RACKET_FOR_BUILD = $(RACKET) -PB_BRANCH = circa-8.4.0.4-2 +PB_BRANCH = circa-8.4.0.5-1 PB_REPO = https://github.com/racket/pb SINGLE_BRANCH_FLAG = --single-branch EXTRA_REPOS_BASE = @@ -310,19 +310,19 @@ 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 $(SINGLE_BRANCH_FLAG) -b circa-8.4.0.4-2 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-8.4.0.4-2:remotes/origin/circa-8.4.0.4-2 ; fi - cd racket/src/ChezScheme/boot/pb && git remote set-branches origin circa-8.4.0.4-2 - cd racket/src/ChezScheme/boot/pb && git checkout -q circa-8.4.0.4-2 + if [ ! -d racket/src/ChezScheme/boot/pb ] ; then git clone -q $(SINGLE_BRANCH_FLAG) -b circa-8.4.0.5-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-8.4.0.5-1:remotes/origin/circa-8.4.0.5-1 ; fi + cd racket/src/ChezScheme/boot/pb && git remote set-branches origin circa-8.4.0.5-1 + cd racket/src/ChezScheme/boot/pb && git checkout -q circa-8.4.0.5-1 pb-fetch: $(MAKE) fetch-pb EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" PB_REPO="$(PB_REPO)" SINGLE_BRANCH_FLAG="$(SINGLE_BRANCH_FLAG)" pb-build: cd racket/src/ChezScheme && racket rktboot/main.rkt --machine pb pb-stage: - cd racket/src/ChezScheme/boot/pb && git branch circa-8.4.0.4-2 - cd racket/src/ChezScheme/boot/pb && git checkout circa-8.4.0.4-2 + cd racket/src/ChezScheme/boot/pb && git branch circa-8.4.0.5-1 + cd racket/src/ChezScheme/boot/pb && git checkout circa-8.4.0.5-1 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-8.4.0.4-2 + cd racket/src/ChezScheme/boot/pb && git push -u origin circa-8.4.0.5-1 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)" diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 146f2fcfe77..a4cb1a568d4 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -14,7 +14,7 @@ ;; In the Racket source repo, this version should change only when ;; "racket_version.h" changes: -(define version "8.4.0.4") +(define version "8.4.0.5") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/racket/src/ChezScheme/BUILDING b/racket/src/ChezScheme/BUILDING index 8ecc499eeb0..889d49f9308 100644 --- a/racket/src/ChezScheme/BUILDING +++ b/racket/src/ChezScheme/BUILDING @@ -61,7 +61,7 @@ and then trying again with `./configure`. In the former case, you can use "auto.bootquick" instead of ".bootquick". If you plan to build on multiple different machines and you don't have -pbb bboot files, then it may be a good idea to generate pb boot files +pbb boot files, then it may be a good idea to generate pb boot files via Racket: racket rktboot/main.rkt --machine pb diff --git a/racket/src/ChezScheme/IMPLEMENTATION.md b/racket/src/ChezScheme/IMPLEMENTATION.md index 1712c311722..9c05f528e72 100644 --- a/racket/src/ChezScheme/IMPLEMENTATION.md +++ b/racket/src/ChezScheme/IMPLEMENTATION.md @@ -63,7 +63,7 @@ form. The build scripts do not convert boot files to vfasl format. Chez Scheme assigns a `machine-type` name to each platform it runs on. The `machine-type` name carries three pieces of information: - * *whether the system threaded*: A `t` indicates that it is, and an + * *whether the system threaded*: `t` indicates that it is, and an absence indicates that it's not threaded; * *the hardware platform*: `i3` for x86, `a6` for x86_64, `arm32` for @@ -74,16 +74,18 @@ The `machine-type` name carries three pieces of information: When you run "configure", it looks for boot and header files as the directory "boot/*machine-type*". (If it doesn't find them, then -configuration cannot continue.) +configuration cannot continue.) For information on `pb` machine types, +see "Portable Bytecode" below. The supported machine types are listed in "cmacros.ss" and reflected by a "boot/*machine-type*" directory for boot and headers files and a combination of "s/*kind*.def" files to describe the platform. There may also be a "s/Mf-*machine-type*" makefile to select relevant files in "s", a "c/Mf-*machine-type*" makefile for configration in "c", and -a "mats/Mf-*machine-type*" makefile to configure testing, but Unix -machine types are handled by Mf-unix and variables configured in the -"configure" and "workarea" scripts. +a "mats/Mf-*machine-type*" makefile to configure testing. Files for +Unix machine types can be generated from "s/unix.def" or "s/tunix.def" +and "c/Mf-unix" with variables configured by the "configure" and +"workarea" scripts. The "workarea" script in the root of the Chez Scheme project is used to generate a subdirectory with the appropriate contents to build for @@ -1269,6 +1271,80 @@ 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`. +# Portable Bytecode + +The "portable bytecode" virtual machine uses a 32-bit instruction set +that is intepreted by a loop defined in "c/pb.c", where many of the +instruction implementations are in "c/pb.h". The instruction set is +custom, but inspired by Arm64. Of course, since the instructions are +interpreted, it does not run nearly as fast a native code that Chez +Scheme normally generates, but it runs fast enough to be useful for +bootstraping a Chez Scheme build from one portable set of boot files. +The pb machine type is also potentially useful in a setting that +disallows code generation or where there's not yet a machine-code +backend for Chez Scheme. + +A `machine-type` name for a pb build follows a variant of the normal +conventions: + + * *whether the system threaded*: `t` indicates that it is threaded; + + * `pb`; + + * *word side*: `64`, `32`, or blank for basic; and + + * *endianness*: `l` for little-endian, `b` for big-endian, or blank + for basic. + +Compiled files (including boot files) for a basic pb build work on all +platforms, while compiled files for a non-basic pb build have a +specific word size and endianness for improved performance. Run +"configure" with `--pb` for a basic build, or run "configure" with +`--pbarch` for a non-basic build. + +A basic build can work on all platforms because it assumes a 64-bit +representation of Scheme values. On a 32-bit platform, the kernel is +compiled to use a 64-bit integer type for `ptr`, even though the high +half of a `ptr` value will always be zeros. The `TO_VOIDP` and +`TO_PTR` macros used in the kernel tell a C compiler that conversions +between 64-bit `ptr`s and (potentially) 32-bit pointers are +intentional. A basic build also avoids a compile-time assumption of +endianness, turning any such Scheme-level decisions into a run-time +branch. Bytecode instructions are stored as little endian in compiled +code for a basic build; on a big-endian machine, the kernel rewrites +instruction bytes to big-endian form while loading a fasl file, so the +interpreter can decode instructions in native order. + +For a non-basic build, fragments of static Scheme code can be turned +into C code to compile and plug back into the kernel. These fragments +are called *pbchunks*. The `pbchunk-convert-file` function takes +compiled Scheme code (as a boot or fasl file), generates C code for +the chunks, and generates revised compiled code that contains +references to the chunks via `pb-chunk` instructions. Calling the +registration function in the generated C code registers chunks with +the kernel as targets for `pb-chunk` instructions. Each chunk has a +static index, so the revised compiled Scheme code must be used with +exactly the C chunks that are generated at the same time; when +multiple sets of chunks are used together, each needs to be created +with non-overlapping index ranges. Orchestrating the generation of +chunk files and linking/loading them into a kernel executable is +currently outside the scope of the Chez Scheme build scripts. + +A `pb-chunk` instruction's payload is two integers: a 16-bit *index* +and an 8-bit *subindex*. The *index* selects a registered C chunk +function. The *subindex* is passed as the third argument to that +function. Meanwhile, the first two arguments to the chunk C function +are the machine state *ms* that lives in a thread context and the +address *ip* of the `pb-chunk` instruction. The pb virtual registers +are accessed via *ms*. The *ip* argument is useful for constructing +relative addresses, such as the address of code that contains a +relocatable reference. A C chunk function returns the address of pb +code to jump to. A chunk function might return an address of Scheme +function code to call that function, or it might return the address of +code to go back to running in interpreted mode for the same code +object where it started; that is, general jumps and bailing out of +chunk mode are implemented in the same way. + # Changing the Version Number To change the version number: diff --git a/racket/src/ChezScheme/c/Mf-base b/racket/src/ChezScheme/c/Mf-base index 6f631a7fedc..d97a9c823b7 100644 --- a/racket/src/ChezScheme/c/Mf-base +++ b/racket/src/ChezScheme/c/Mf-base @@ -44,7 +44,8 @@ kernelsrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-011.c gc- kernelobj=${kernelsrc:%.c=%.$o} ${mdobj} -kernelhdr=system.h types.h version.h globals.h externs.h segment.h atomic.h gc.c sort.h thread.h config.h compress-io.h itest.c nocurses.h popcount.h +kernelhdr=system.h types.h version.h globals.h externs.h segment.h atomic.h gc.c sort.h thread.h config.h \ + compress-io.h itest.c nocurses.h popcount.h pb.h mainsrc=main.c @@ -76,6 +77,7 @@ gc-011.o gc-ocd.o: ${Include}/gc-ocd.inc gc-oce.o: ${Include}/gc-oce.inc gc-par.o: ${Include}/gc-par.inc gcwrapper.o: ${Include}/heapcheck.inc +pb.o: pb.h ../zlib/zlib.h ../zlib/zconf.h: ../zlib/configure.log diff --git a/racket/src/ChezScheme/c/atomic.h b/racket/src/ChezScheme/c/atomic.h index 295b0f93c5f..4c61101f6b5 100644 --- a/racket/src/ChezScheme/c/atomic.h +++ b/racket/src/ChezScheme/c/atomic.h @@ -34,7 +34,7 @@ #endif #if !defined(PTHREADS) -# define CAS_ANY_FENCE(a, old, new) ((*(a) == (old)) ? (*(a) = (new), 1) : 0) +# define CAS_ANY_FENCE(a, old, new) ((*(ptr *)(a) == TO_PTR(old)) ? (*(ptr)(a) = TO_PTR(new), 1) : 0) #elif defined(__arm64__) || defined(__aarch64__) FORCEINLINE int CAS_LOAD_ACQUIRE(volatile void *addr, void *old_val, void *new_val) { long ret; @@ -97,7 +97,7 @@ FORCEINLINE int S_cas_any_fence(int load_acquire, volatile void *addr, void *old # define CAS_LOAD_ACQUIRE(a, old, new) S_cas_any_fence(1, a, old, new) # define CAS_STORE_RELEASE(a, old, new) S_cas_any_fence(0, a, old, new) #elif (__GNUC__ >= 5) || defined(__clang__) -# define CAS_ANY_FENCE(a, old, new) __sync_bool_compare_and_swap((ptr *)(a), (ptr)(old), (ptr)(new)) +# define CAS_ANY_FENCE(a, old, new) __sync_bool_compare_and_swap((ptr *)(a), TO_PTR(old), TO_PTR(new)) #elif defined(_MSC_VER) # if ptr_bits == 64 # define CAS_ANY_FENCE(a, old, new) (_InterlockedCompareExchange64((__int64 *)(a), (__int64)(new), (__int64)(old)) == (__int64)(old)) @@ -120,7 +120,7 @@ FORCEINLINE int S_cas_any_fence(volatile void *addr, void *old_val, void *new_va } # define CAS_ANY_FENCE(a, old, new) S_cas_any_fence(a, old, new) #else -# define CAS_ANY_FENCE(a, old, new) ((*(a) == (old)) ? (*(a) = (new), 1) : 0) +# define CAS_ANY_FENCE(a, old, new) ((*(ptr *)(a) == TO_PTR(old)) ? (*(ptr *)(a) = TO_PTR(new), 1) : 0) #endif #ifdef CAS_ANY_FENCE diff --git a/racket/src/ChezScheme/c/externs.h b/racket/src/ChezScheme/c/externs.h index 524f66edfbe..c05238ec9d2 100644 --- a/racket/src/ChezScheme/c/externs.h +++ b/racket/src/ChezScheme/c/externs.h @@ -127,7 +127,7 @@ extern int S_fasl_intern_rtd(ptr *x); #ifdef X86_64 extern void x86_64_set_popcount_present PROTO((ptr code)); #endif -#ifdef PORTABLE_BYTECODE_BIGENDIAN +#ifdef PORTABLE_BYTECODE_SWAPENDIAN extern void S_swap_dounderflow_header_endian PROTO((ptr code)); #endif diff --git a/racket/src/ChezScheme/c/fasl.c b/racket/src/ChezScheme/c/fasl.c index 9ef0a3e930a..f04f0b8bc1e 100644 --- a/racket/src/ChezScheme/c/fasl.c +++ b/racket/src/ChezScheme/c/fasl.c @@ -276,7 +276,7 @@ static U32 adjust_delay_inst PROTO((U32 delay_inst, U32 *old_call_addr, U32 *new static INT sparc64_set_lit_only PROTO((void *address, uptr item, I32 destreg)); static void sparc64_set_literal PROTO((void *address, uptr item)); #endif /* SPARC64 */ -#ifdef PORTABLE_BYTECODE_BIGENDIAN +#ifdef PORTABLE_BYTECODE_SWAPENDIAN static void swap_code_endian(octet *code, uptr len); #endif @@ -1071,7 +1071,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) { S_G.profile_counters = Scons(S_weak_cons(co, pinfos), S_G.profile_counters); } code_bytesin((octet *)&CODEIT(co, 0), n, f); -#ifdef PORTABLE_BYTECODE_BIGENDIAN +#ifdef PORTABLE_BYTECODE_SWAPENDIAN swap_code_endian((octet *)&CODEIT(co, 0), n); #endif m = uptrin(f); @@ -1984,7 +1984,7 @@ static void sparc64_set_literal(address, item) void *address; uptr item; { } #endif /* SPARC64 */ -#ifdef PORTABLE_BYTECODE_BIGENDIAN +#ifdef PORTABLE_BYTECODE_SWAPENDIAN typedef struct { octet *code; uptr size; @@ -2028,6 +2028,13 @@ static void swap_code_endian(octet *code, uptr len) octet b = code[1]; octet c = code[2]; octet d = code[3]; +#if fasl_endianness_is_little + octet le_a = a, le_b = b, le_c = c, le_d = d; +# define le_tag_offset -8 +#else + octet le_a = d, le_b = c, le_c = b, le_d = a; +# define le_tag_offset -1 +#endif code[0] = d; code[1] = c; code[2] = b; @@ -2036,9 +2043,9 @@ static void swap_code_endian(octet *code, uptr len) code += 4; len -= 4; - if (a == pb_adr) { + if (le_a == pb_adr) { /* delta can be negative for a mvlet-error reinstall of the return address */ - iptr delta = (((iptr)d << (ptr_bits - 8)) >> (ptr_bits - 20)) + ((iptr)c << 4) + (b >> 4); + iptr delta = 4*((((iptr)le_d << (ptr_bits - 8)) >> (ptr_bits - 20)) + ((iptr)le_c << 4) + (le_b >> 4)); if (delta > 0) { /* after a few more instructions, we'll hit a header where 64-bit values needs to be @@ -2049,15 +2056,13 @@ static void swap_code_endian(octet *code, uptr len) if ((uptr)delta > len) S_error_abort("swap endian: delta goes past end"); - if (delta & 0x3) - S_error_abort("swap endian: delta is not a multiple of 4"); - if (after_rpheader[-8] & 0x1) + if (after_rpheader[le_tag_offset] & 0x1) header_size = size_rp_compact_header; else header_size = size_rp_header; rpheader = after_rpheader - header_size; - + if (rpheader_stack_pos == rpheader_stack_size) { int new_size = (2 * rpheader_stack_size) + 16; rpheader_t *new_stack; diff --git a/racket/src/ChezScheme/c/ffi.c b/racket/src/ChezScheme/c/ffi.c index 6f376f80031..1b6f7964243 100644 --- a/racket/src/ChezScheme/c/ffi.c +++ b/racket/src/ChezScheme/c/ffi.c @@ -355,7 +355,7 @@ void S_ffi_call(ptr types, ptr proc, ptr *arena) { ffi_cif *cif = make_cif(types); iptr len = Svector_length(types), i; iptr n_args = len - ARG_TYPE_START_INDEX; - void *rvalue, **args = TO_VOIDP((uptr)TO_PTR(arena) + (n_args * 8)); + void *rvalue, **args = TO_VOIDP((uptr)TO_PTR(arena) + ((n_args+1) * 8)); if (Svector_ref(types, RET_IS_ARG_INDEX) != Sfalse) { rvalue = TO_VOIDP(*arena); diff --git a/racket/src/ChezScheme/c/pb.c b/racket/src/ChezScheme/c/pb.c index 33d884156bc..0006c350a32 100644 --- a/racket/src/ChezScheme/c/pb.c +++ b/racket/src/ChezScheme/c/pb.c @@ -2,71 +2,30 @@ #include #include -/* Interpreter for portable bytecode. See "pb.ss". */ +/* Interpreter for portable bytecode. See also "pb.ss", while + instruction implementations are mostly in "pb.h" */ +#include "pb.h" -typedef uint32_t instruction_t; +typedef uptr (*chunk_t)(machine_state *ms, uptr, int); -#define INSTR_op(instr) ((instr) & 0xFF) +static chunk_t *chunks; +static int num_chunks; -#define INSTR_d_dest(instr) (((instr) >> 8) & 0xF) +void S_machine_init() { } -#define INSTR_dr_dest(instr) INSTR_d_dest(instr) -#define INSTR_dr_reg(instr) (((instr) >> 16) & 0xF) - -#define INSTR_di_dest(instr) INSTR_d_dest(instr) -#define INSTR_di_imm(instr) (((int32_t)(instr)) >> 16) -#define INSTR_di_imm_unsigned(instr) ((instr) >> 16) - -#define INSTR_adr_dest(instr) INSTR_di_dest(instr) -#define INSTR_adr_imm(instr) (((int32_t)(instr)) >> 12) - -#define INSTR_drr_dest(instr) INSTR_d_dest(instr) -#define INSTR_drr_reg1(instr) (((instr) >> 12) & 0xF) -#define INSTR_drr_reg2(instr) (((instr) >> 16) & 0xF) - -#define INSTR_dri_dest(instr) INSTR_d_dest(instr) -#define INSTR_dri_reg(instr) (((instr) >> 12) & 0xF) -#define INSTR_dri_imm(instr) (((int32_t)(instr)) >> 16) - -#define INSTR_i_imm(instr) (((int32_t)(instr)) >> 8) - -#define SHIFT_MASK(v) ((v) & (ptr_bits-1)) - -#define regs (&PBREGS(tc, 0)) -#define fpregs (&PBFPREGS(tc, 0)) -#define call_arena (&PBCALLARENA(tc, 0)) /* scratch space for libffi-based foreign calls, - somewhat analogous to the C stack */ - -enum { - Cretval = 9, - Carg1 = 9, - Carg2, - Carg3, - Carg4, - Carg5, - Carg6, - Carg7 -}; - -enum { - Cfpretval = 1, - Cfparg1 = 1, - Cfparg2, - Cfparg3, - Cfparg4, - Cfparg5, - Cfparg6 -}; - -void S_machine_init() {} - -#define SIGN_FLIP(r, a, b) ((~((a ^ b) | (r ^ ~b))) >> (ptr_bits-1)) +void Sregister_pbchunks(void **add_chunks, int start_index, int end_index) { + if (num_chunks < end_index) { + void *new_chunks = malloc(sizeof(void*) * end_index); + if (chunks) { + memcpy(new_chunks, chunks, num_chunks * sizeof(void*)); + free(chunks); + } + chunks = new_chunks; + num_chunks = end_index; + } -#if (__GNUC__ >= 5) || defined(__clang__) -# define USE_OVERFLOW_INTRINSICS 1 -#else -# define USE_OVERFLOW_INTRINSICS 0 -#endif + memcpy((void **)chunks + start_index, add_chunks, (end_index - start_index) * sizeof(void*)); +} #if 0 # define TRACE(print, record) print @@ -80,7 +39,10 @@ static instruction_t *call_from; static void *call_to; # define TRACE(print, record) /* empty */ #endif +#define COMMON_INSTR(x) x: do_ ## x(instr); break; + void S_pb_interp(ptr tc, void *bytecode) { + machine_state * RESTRICT_PTR ms = (machine_state *)&PBREGS(tc, 0); /* assumes fields are together in `tc` */ instruction_t *ip = (instruction_t *)bytecode, *next_ip, instr; int flag = 0; @@ -95,577 +57,133 @@ void S_pb_interp(ptr tc, void *bytecode) { switch(INSTR_op(instr)) { case pb_link: /* same as pb_mov16_pb_zero_bits_pb_shift0, but with a promise - of collowing pb_mov16_pb_keep_bits_pb_shift1... with the same + of following pb_mov16_pb_keep_bits_pb_shift1... with the same destination */ - regs[INSTR_di_dest(instr)] = ((uptr)INSTR_di_imm_unsigned(instr) - | ((uptr)INSTR_di_imm_unsigned(ip[1]) << 16) -#if ptr_bits == 64 - | ((uptr)INSTR_di_imm_unsigned(ip[2]) << 32) - | ((uptr)INSTR_di_imm_unsigned(ip[3]) << 48) -#endif - ); + regs[INSTR_di_dest(instr)] = decode_relocation(instr, ip); #if ptr_bits == 64 next_ip = ip + 4; #else next_ip = ip + 2; #endif break; - case pb_mov16_pb_zero_bits_pb_shift0: - regs[INSTR_di_dest(instr)] = (uptr)INSTR_di_imm_unsigned(instr); - break; - case pb_mov16_pb_zero_bits_pb_shift1: - regs[INSTR_di_dest(instr)] = (uptr)INSTR_di_imm_unsigned(instr) << 16; - break; - case pb_mov16_pb_zero_bits_pb_shift2: -#if ptr_bits == 64 - regs[INSTR_di_dest(instr)] = (uptr)INSTR_di_imm_unsigned(instr) << 32; -#else - regs[INSTR_di_dest(instr)] = 0; -#endif - break; - case pb_mov16_pb_zero_bits_pb_shift3: -#if ptr_bits == 64 - regs[INSTR_di_dest(instr)] = (uptr)INSTR_di_imm_unsigned(instr) << 48; -#else - regs[INSTR_di_dest(instr)] = 0; -#endif - break; - case pb_mov16_pb_keep_bits_pb_shift0: - regs[INSTR_di_dest(instr)] |= (uptr)INSTR_di_imm_unsigned(instr); - break; - case pb_mov16_pb_keep_bits_pb_shift1: - regs[INSTR_di_dest(instr)] |= (uptr)INSTR_di_imm_unsigned(instr) << 16; - break; - case pb_mov16_pb_keep_bits_pb_shift2: -#if ptr_bits == 64 - regs[INSTR_di_dest(instr)] |= (uptr)INSTR_di_imm_unsigned(instr) << 32; -#endif - break; - case pb_mov16_pb_keep_bits_pb_shift3: -#if ptr_bits == 64 - regs[INSTR_di_dest(instr)] |= (uptr)INSTR_di_imm_unsigned(instr) << 48; -#endif - break; - case pb_mov_pb_i_i: - regs[INSTR_dr_dest(instr)] = regs[INSTR_dr_reg(instr)]; - break; - case pb_mov_pb_d_d: - fpregs[INSTR_dr_dest(instr)] = fpregs[INSTR_dr_reg(instr)]; - break; - case pb_mov_pb_i_d: - fpregs[INSTR_dr_dest(instr)] = (double)(iptr)regs[INSTR_dr_reg(instr)]; - break; - case pb_mov_pb_d_i: - regs[INSTR_dr_dest(instr)] = (iptr)fpregs[INSTR_dr_reg(instr)]; - break; + case COMMON_INSTR(pb_mov16_pb_zero_bits_pb_shift0) + case COMMON_INSTR(pb_mov16_pb_zero_bits_pb_shift1) + case COMMON_INSTR(pb_mov16_pb_zero_bits_pb_shift2) + case COMMON_INSTR(pb_mov16_pb_zero_bits_pb_shift3) + case COMMON_INSTR(pb_mov16_pb_keep_bits_pb_shift0) + case COMMON_INSTR(pb_mov16_pb_keep_bits_pb_shift1) + case COMMON_INSTR(pb_mov16_pb_keep_bits_pb_shift2) + case COMMON_INSTR(pb_mov16_pb_keep_bits_pb_shift3) + case COMMON_INSTR(pb_mov_pb_i_i) + case COMMON_INSTR(pb_mov_pb_d_d) + case COMMON_INSTR(pb_mov_pb_i_d) + case COMMON_INSTR(pb_mov_pb_d_i) #if ptr_bits == 64 - case pb_mov_pb_i_bits_d_bits: - memcpy(&fpregs[INSTR_dr_dest(instr)], ®s[INSTR_dr_reg(instr)], sizeof(double)); - break; - case pb_mov_pb_d_bits_i_bits: - memcpy(®s[INSTR_dr_dest(instr)], &fpregs[INSTR_dr_reg(instr)], sizeof(double)); - break; + case COMMON_INSTR(pb_mov_pb_i_bits_d_bits) + case COMMON_INSTR(pb_mov_pb_d_bits_i_bits) #else - case pb_mov_pb_i_i_bits_d_bits: - { - uint64_t d; - d = regs[INSTR_drr_reg1(instr)] | ((uint64_t)regs[INSTR_drr_reg2(instr)] << 32); - memcpy(&fpregs[INSTR_drr_dest(instr)], &d, sizeof(double)); - } - break; - case pb_mov_pb_d_lo_bits_i_bits: - { - uint64_t d; - memcpy(&d, &fpregs[INSTR_dr_reg(instr)], sizeof(double)); - regs[INSTR_dr_dest(instr)] = d; - } - break; - case pb_mov_pb_d_hi_bits_i_bits: - { - uint64_t d; - memcpy(&d, &fpregs[INSTR_dr_reg(instr)], sizeof(double)); - d >>= 32; - regs[INSTR_dr_dest(instr)] = d; - } - break; + case COMMON_INSTR(pb_mov_pb_i_i_bits_d_bits) + case COMMON_INSTR(pb_mov_pb_d_lo_bits_i_bits) + case COMMON_INSTR(pb_mov_pb_d_hi_bits_i_bits) #endif - case pb_mov_pb_s_d: - { - float f; -#ifdef PORTABLE_BYTECODE_BIGENDIAN - memcpy(&f, (char *)&fpregs[INSTR_dr_reg(instr)] + 4, sizeof(float)); -#else - memcpy(&f, &fpregs[INSTR_dr_reg(instr)], sizeof(float)); -#endif - fpregs[INSTR_dr_dest(instr)] = f; - } - break; - case pb_mov_pb_d_s: - { - float f; - f = fpregs[INSTR_dr_reg(instr)]; -#ifdef PORTABLE_BYTECODE_BIGENDIAN - memcpy((char *)&fpregs[INSTR_dr_dest(instr)] + 4, &f, sizeof(float)); -#else - memcpy(&fpregs[INSTR_dr_dest(instr)], &f, sizeof(float)); -#endif - } - break; - case pb_mov_pb_d_s_d: - { - float f; - f = fpregs[INSTR_dr_reg(instr)]; - fpregs[INSTR_dr_dest(instr)] = (double)f; - } - break; - case pb_bin_op_pb_no_signal_pb_add_pb_register: - regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]; - break; - case pb_bin_op_pb_no_signal_pb_add_pb_immediate: - regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] + (uptr)INSTR_dri_imm(instr); - break; - case pb_bin_op_pb_no_signal_pb_sub_pb_register: - regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] - regs[INSTR_drr_reg2(instr)]; - break; - case pb_bin_op_pb_no_signal_pb_sub_pb_immediate: - regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] - (uptr)INSTR_dri_imm(instr); - break; - case pb_bin_op_pb_no_signal_pb_mul_pb_register: - regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] * regs[INSTR_drr_reg2(instr)]; - break; - case pb_bin_op_pb_no_signal_pb_mul_pb_immediate: - regs[INSTR_dri_dest(instr)] = (uptr)regs[INSTR_dri_reg(instr)] * (uptr)INSTR_dri_imm(instr); - break; - case pb_bin_op_pb_no_signal_pb_div_pb_register: - regs[INSTR_drr_dest(instr)] = (iptr)regs[INSTR_drr_reg1(instr)] / (iptr)regs[INSTR_drr_reg2(instr)]; - break; - case pb_bin_op_pb_no_signal_pb_div_pb_immediate: - regs[INSTR_dri_dest(instr)] = (iptr)regs[INSTR_dri_reg(instr)] / (iptr)INSTR_dri_imm(instr); - break; - case pb_bin_op_pb_no_signal_pb_and_pb_register: - regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] & regs[INSTR_drr_reg2(instr)]; - break; - case pb_bin_op_pb_no_signal_pb_and_pb_immediate: - regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] & (uptr)INSTR_dri_imm(instr); - break; - case pb_bin_op_pb_no_signal_pb_ior_pb_register: - regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] | regs[INSTR_drr_reg2(instr)]; - break; - case pb_bin_op_pb_no_signal_pb_ior_pb_immediate: - regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] | (uptr)INSTR_dri_imm(instr); - break; - case pb_bin_op_pb_no_signal_pb_xor_pb_register: - regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] ^ regs[INSTR_drr_reg2(instr)]; - break; - case pb_bin_op_pb_no_signal_pb_xor_pb_immediate: - regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] ^ (uptr)INSTR_dri_imm(instr); - break; - case pb_bin_op_pb_no_signal_pb_lsl_pb_register: - regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] << SHIFT_MASK(regs[INSTR_drr_reg2(instr)]); - break; - case pb_bin_op_pb_no_signal_pb_lsl_pb_immediate: - regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] << SHIFT_MASK(INSTR_dri_imm(instr)); - break; - case pb_bin_op_pb_no_signal_pb_lsr_pb_register: - regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] >> SHIFT_MASK(regs[INSTR_drr_reg2(instr)]); - break; - case pb_bin_op_pb_no_signal_pb_lsr_pb_immediate: - regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] >> SHIFT_MASK(INSTR_dri_imm(instr)); - break; - case pb_bin_op_pb_no_signal_pb_asr_pb_register: - regs[INSTR_drr_dest(instr)] = (iptr)regs[INSTR_drr_reg1(instr)] >> SHIFT_MASK(regs[INSTR_drr_reg2(instr)]); - break; - case pb_bin_op_pb_no_signal_pb_asr_pb_immediate: - regs[INSTR_dri_dest(instr)] = (iptr)regs[INSTR_dri_reg(instr)] >> SHIFT_MASK(INSTR_dri_imm(instr)); - break; - case pb_bin_op_pb_no_signal_pb_lslo_pb_register: -#ifdef PORTABLE_BYTECODE_BIGENDIAN - regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] >> regs[INSTR_drr_reg2(instr)]; -#else - regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] << regs[INSTR_drr_reg2(instr)]; -#endif - break; - case pb_bin_op_pb_no_signal_pb_lslo_pb_immediate: -#ifdef PORTABLE_BYTECODE_BIGENDIAN - regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] >> INSTR_dri_imm(instr); -#else - regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] << INSTR_dri_imm(instr); -#endif - break; - case pb_bin_op_pb_signal_pb_add_pb_register: - { -#if USE_OVERFLOW_INTRINSICS - iptr a = (iptr)regs[INSTR_drr_reg1(instr)]; - iptr b = (iptr)regs[INSTR_drr_reg2(instr)]; - iptr r; - flag = __builtin_add_overflow(a, b, &r); - regs[INSTR_drr_dest(instr)] = (uptr)r; -#else - uptr a = regs[INSTR_drr_reg1(instr)]; - uptr b = regs[INSTR_drr_reg2(instr)]; - uptr r = a + b; - regs[INSTR_drr_dest(instr)] = r; - flag = SIGN_FLIP(r, a, b); -#endif - } - break; - case pb_bin_op_pb_signal_pb_add_pb_immediate: - { -#if USE_OVERFLOW_INTRINSICS - iptr a = (iptr)regs[INSTR_dri_reg(instr)]; - iptr b = INSTR_dri_imm(instr); - iptr r; - flag = __builtin_add_overflow(a, b, &r); - regs[INSTR_drr_dest(instr)] = (uptr)r; -#else - uptr a = regs[INSTR_dri_reg(instr)]; - uptr b = (uptr)INSTR_dri_imm(instr); - uptr r = a + b; - regs[INSTR_dri_dest(instr)] = r; - flag = SIGN_FLIP(r, a, b); -#endif - } - break; - case pb_bin_op_pb_signal_pb_sub_pb_register: - { -#if USE_OVERFLOW_INTRINSICS - iptr a = (iptr)regs[INSTR_drr_reg1(instr)]; - iptr b = (iptr)regs[INSTR_drr_reg2(instr)]; - iptr r; - flag = __builtin_sub_overflow(a, b, &r); - regs[INSTR_drr_dest(instr)] = (uptr)r; -#else - uptr a = regs[INSTR_drr_reg1(instr)]; - uptr b = regs[INSTR_drr_reg2(instr)]; - uptr r = a - b; - regs[INSTR_drr_dest(instr)] = r; - flag = SIGN_FLIP(r, a, ~b); -#endif - } - break; - case pb_bin_op_pb_signal_pb_sub_pb_immediate: - { -#if USE_OVERFLOW_INTRINSICS - iptr a = (iptr)regs[INSTR_dri_reg(instr)]; - iptr b = INSTR_dri_imm(instr); - iptr r; - flag = __builtin_sub_overflow(a, b, &r); - regs[INSTR_drr_dest(instr)] = (uptr)r; -#else - uptr a = regs[INSTR_dri_reg(instr)]; - uptr b = (uptr)INSTR_dri_imm(instr); - uptr r = a - b; - regs[INSTR_dri_dest(instr)] = r; - flag = SIGN_FLIP(r, a, ~b); -#endif - } - break; - case pb_bin_op_pb_signal_pb_mul_pb_register: - { -#if USE_OVERFLOW_INTRINSICS - iptr a = (iptr)regs[INSTR_drr_reg1(instr)]; - iptr b = (iptr)regs[INSTR_drr_reg2(instr)]; - iptr r; - flag = __builtin_mul_overflow(a, b, &r); - regs[INSTR_drr_dest(instr)] = (uptr)r; -#else - uptr a = regs[INSTR_drr_reg1(instr)]; - uptr b = regs[INSTR_drr_reg2(instr)]; - uptr r = a * b; - regs[INSTR_drr_dest(instr)] = r; - if (b != 0) { - if (b == (uptr)-1) - flag = (a != r * (uptr)-1); - else - flag = ((iptr)a != (iptr)r / (iptr)b); - } else - flag = 0; -#endif - } - break; - case pb_bin_op_pb_signal_pb_mul_pb_immediate: - { -#if USE_OVERFLOW_INTRINSICS - iptr a = (iptr)regs[INSTR_dri_reg(instr)]; - iptr b = INSTR_dri_imm(instr); - iptr r; - flag = __builtin_mul_overflow(a, b, &r); - regs[INSTR_drr_dest(instr)] = (uptr)r; -#else - uptr a = regs[INSTR_dri_reg(instr)]; - uptr b = (uptr)INSTR_dri_imm(instr); - uptr r = a * b; - regs[INSTR_dri_dest(instr)] = r; - if (b != 0) { - if (b == (uptr)-1) - flag = (a != r * (uptr)-1); - else - flag = ((iptr)a != (iptr)r / (iptr)b); - } else - flag = 0; -#endif - } - break; - case pb_bin_op_pb_signal_pb_subz_pb_register: - { - iptr r = regs[INSTR_drr_reg1(instr)] - regs[INSTR_drr_reg2(instr)]; - regs[INSTR_drr_dest(instr)] = r; - flag = (r == 0); - } - break; - case pb_bin_op_pb_signal_pb_subz_pb_immediate: - { - iptr r = regs[INSTR_dri_reg(instr)] - (uptr)INSTR_dri_imm(instr); - regs[INSTR_dri_dest(instr)] = r; - flag = (r == 0); - } - break; - case pb_bin_op_pb_signal_pb_subp_pb_register: - { - iptr r = regs[INSTR_drr_reg1(instr)] - regs[INSTR_drr_reg2(instr)]; - regs[INSTR_drr_dest(instr)] = r; - flag = (r > 0); - } - break; - case pb_bin_op_pb_signal_pb_subp_pb_immediate: - { - iptr r = regs[INSTR_dri_reg(instr)] - (uptr)INSTR_dri_imm(instr); - regs[INSTR_dri_dest(instr)] = r; - flag = (r > 0); - } - break; - case pb_cmp_op_pb_eq_pb_register: - flag = regs[INSTR_dr_dest(instr)] == regs[INSTR_dr_reg(instr)]; - break; - case pb_cmp_op_pb_eq_pb_immediate: - flag = regs[INSTR_di_dest(instr)] == (uptr)INSTR_di_imm(instr); - break; - case pb_cmp_op_pb_lt_pb_register: - flag = (iptr)regs[INSTR_dr_dest(instr)] < (iptr)regs[INSTR_dr_reg(instr)]; - break; - case pb_cmp_op_pb_lt_pb_immediate: - flag = (iptr)regs[INSTR_di_dest(instr)] < (iptr)INSTR_di_imm(instr); - break; - case pb_cmp_op_pb_gt_pb_register: - flag = (iptr)regs[INSTR_dr_dest(instr)] > (iptr)regs[INSTR_dr_reg(instr)]; - break; - case pb_cmp_op_pb_gt_pb_immediate: - flag = (iptr)regs[INSTR_di_dest(instr)] > (iptr)INSTR_di_imm(instr); - break; - case pb_cmp_op_pb_le_pb_register: - flag = (iptr)regs[INSTR_dr_dest(instr)] <= (iptr)regs[INSTR_dr_reg(instr)]; - break; - case pb_cmp_op_pb_le_pb_immediate: - flag = (iptr)regs[INSTR_di_dest(instr)] <= (iptr)INSTR_di_imm(instr); - break; - case pb_cmp_op_pb_ge_pb_register: - flag = (iptr)regs[INSTR_dr_dest(instr)] >= (iptr)regs[INSTR_dr_reg(instr)]; - break; - case pb_cmp_op_pb_ge_pb_immediate: - flag = (iptr)regs[INSTR_di_dest(instr)] >= (iptr)INSTR_di_imm(instr); - break; - case pb_cmp_op_pb_ab_pb_register: - flag = regs[INSTR_dr_dest(instr)] > regs[INSTR_dr_reg(instr)]; - break; - case pb_cmp_op_pb_ab_pb_immediate: - flag = regs[INSTR_di_dest(instr)] > (uptr)INSTR_di_imm(instr); - break; - case pb_cmp_op_pb_bl_pb_register: - flag = regs[INSTR_dr_dest(instr)] < regs[INSTR_dr_reg(instr)]; - break; - case pb_cmp_op_pb_bl_pb_immediate: - flag = regs[INSTR_di_dest(instr)] < (uptr)INSTR_di_imm(instr); - break; - case pb_cmp_op_pb_cs_pb_register: - flag = ((regs[INSTR_dr_dest(instr)] & regs[INSTR_dr_reg(instr)]) != 0); - break; - case pb_cmp_op_pb_cs_pb_immediate: - flag = ((regs[INSTR_di_dest(instr)] & (uptr)INSTR_di_imm(instr)) != 0); - break; - case pb_cmp_op_pb_cc_pb_register: - flag = ((regs[INSTR_dr_dest(instr)] & regs[INSTR_dr_reg(instr)]) == 0); - break; - case pb_cmp_op_pb_cc_pb_immediate: - flag = ((regs[INSTR_di_dest(instr)] & (uptr)INSTR_di_imm(instr)) == 0); - break; - case pb_fp_bin_op_pb_add_pb_register: - fpregs[INSTR_drr_dest(instr)] = fpregs[INSTR_drr_reg1(instr)] + fpregs[INSTR_drr_reg2(instr)]; - break; - case pb_fp_bin_op_pb_sub_pb_register: - fpregs[INSTR_drr_dest(instr)] = fpregs[INSTR_drr_reg1(instr)] - fpregs[INSTR_drr_reg2(instr)]; - break; - case pb_fp_bin_op_pb_mul_pb_register: - fpregs[INSTR_drr_dest(instr)] = fpregs[INSTR_drr_reg1(instr)] * fpregs[INSTR_drr_reg2(instr)]; - break; - case pb_fp_bin_op_pb_div_pb_register: - fpregs[INSTR_drr_dest(instr)] = fpregs[INSTR_drr_reg1(instr)] / fpregs[INSTR_drr_reg2(instr)]; - break; - case pb_un_op_pb_not_pb_register: - regs[INSTR_dr_dest(instr)] = ~(regs[INSTR_dr_reg(instr)]); - break; - case pb_un_op_pb_not_pb_immediate: - regs[INSTR_di_dest(instr)] = ~((uptr)(iptr)INSTR_di_imm(instr)); - break; - case pb_fp_un_op_pb_sqrt_pb_register: - fpregs[INSTR_dr_dest(instr)] = sqrt(fpregs[INSTR_dr_reg(instr)]); - break; - case pb_fp_cmp_op_pb_eq_pb_register: - flag = fpregs[INSTR_dr_dest(instr)] == fpregs[INSTR_dr_reg(instr)]; - break; - case pb_fp_cmp_op_pb_lt_pb_register: - flag = fpregs[INSTR_dr_dest(instr)] < fpregs[INSTR_dr_reg(instr)]; - break; - case pb_fp_cmp_op_pb_le_pb_register: - flag = fpregs[INSTR_dr_dest(instr)] <= fpregs[INSTR_dr_reg(instr)]; - break; - case pb_rev_op_pb_int16_pb_register: -#if ptr_bits == 64 - regs[INSTR_dr_dest(instr)] = ((uptr)((iptr)(regs[INSTR_dr_reg(instr)] << 56) >> 48) - | ((regs[INSTR_dr_reg(instr)] & 0xFF00) >> 8)); -#else - regs[INSTR_dr_dest(instr)] = ((uptr)((iptr)(regs[INSTR_dr_reg(instr)] << 24) >> 16) - | ((regs[INSTR_dr_reg(instr)] & 0xFF00) >> 8)); -#endif - break; - case pb_rev_op_pb_uint16_pb_register: - regs[INSTR_dr_dest(instr)] = (((regs[INSTR_dr_reg(instr)] & 0x00FF) << 8) - | ((regs[INSTR_dr_reg(instr)] & 0xFF00) >> 8)); - break; - case pb_rev_op_pb_int32_pb_register: -#if ptr_bits == 64 - regs[INSTR_dr_dest(instr)] = ((uptr)((iptr)(regs[INSTR_dr_reg(instr)] << 56) >> 32) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0xFF000000) >> 24) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00FF0000) >> 8) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000FF00) << 8)); -#else - regs[INSTR_dr_dest(instr)] = ((regs[INSTR_dr_reg(instr)] << 24) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0xFF000000) >> 24) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00FF0000) >> 8) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000FF00) << 8)); -#endif - break; - case pb_rev_op_pb_uint32_pb_register: - regs[INSTR_dr_dest(instr)] = (((regs[INSTR_dr_reg(instr)] & (uptr)0x000000FF) << 24) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0xFF000000) >> 24) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00FF0000) >> 8) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000FF00) << 8)); - break; - case pb_rev_op_pb_int64_pb_register: -#if ptr_bits == 64 - regs[INSTR_dr_dest(instr)] = (((regs[INSTR_dr_reg(instr)] & (uptr)0x00000000000000FF) << 56) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0x000000000000FF00) << 40) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000000000FF0000) << 24) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00000000FF000000) << 8) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0x000000FF00000000) >> 8) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000FF0000000000) >> 24) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00FF000000000000) >> 40) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0xFF00000000000000) >> 56)); -#else - regs[INSTR_dr_dest(instr)] = (((regs[INSTR_dr_reg(instr)] & (uptr)0x000000FF) << 24) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0xFF000000) >> 24) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00FF0000) >> 8) - | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000FF00) << 8)); -#endif - break; - case pb_ld_op_pb_int8_pb_register: - regs[INSTR_drr_dest(instr)] = *(int8_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); - break; - case pb_ld_op_pb_int8_pb_immediate: -#if defined(__arm__) - /* Complicated load to avoid an internal compiler error from an old gcc on Raspbian: */ - { - int8_t v; - memcpy(&v, TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)), sizeof(int8_t)); - regs[INSTR_dri_dest(instr)] = v; - } -#else - regs[INSTR_dri_dest(instr)] = *(int8_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); -#endif - break; - case pb_ld_op_pb_uint8_pb_register: - regs[INSTR_drr_dest(instr)] = *(uint8_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); - break; - case pb_ld_op_pb_uint8_pb_immediate: - regs[INSTR_dri_dest(instr)] = *(uint8_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); - break; - case pb_ld_op_pb_int16_pb_register: - regs[INSTR_drr_dest(instr)] = *(int16_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); - break; - case pb_ld_op_pb_int16_pb_immediate: - regs[INSTR_dri_dest(instr)] = *(int16_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); - break; - case pb_ld_op_pb_uint16_pb_register: - regs[INSTR_drr_dest(instr)] = *(uint16_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); - break; - case pb_ld_op_pb_uint16_pb_immediate: - regs[INSTR_dri_dest(instr)] = *(uint16_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); - break; - case pb_ld_op_pb_int32_pb_register: - regs[INSTR_drr_dest(instr)] = *(int32_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); - break; - case pb_ld_op_pb_int32_pb_immediate: - regs[INSTR_dri_dest(instr)] = *(int32_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); - break; - case pb_ld_op_pb_uint32_pb_register: - regs[INSTR_drr_dest(instr)] = *(uint32_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); - break; - case pb_ld_op_pb_uint32_pb_immediate: - regs[INSTR_dri_dest(instr)] = *(uint32_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); - break; - case pb_ld_op_pb_int64_pb_register: - regs[INSTR_drr_dest(instr)] = *(uptr *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); - break; - case pb_ld_op_pb_int64_pb_immediate: - regs[INSTR_dri_dest(instr)] = *(uptr *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); - break; - case pb_ld_op_pb_double_pb_register: - fpregs[INSTR_drr_dest(instr)] = *(double *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); - break; - case pb_ld_op_pb_double_pb_immediate: - fpregs[INSTR_dri_dest(instr)] = *(double *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); - break; - case pb_ld_op_pb_single_pb_register: - fpregs[INSTR_drr_dest(instr)] = *(float *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); - break; - case pb_ld_op_pb_single_pb_immediate: - fpregs[INSTR_dri_dest(instr)] = *(float *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); - break; - case pb_st_op_pb_int8_pb_register: - *(char *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = (char)regs[INSTR_drr_dest(instr)]; - break; - case pb_st_op_pb_int8_pb_immediate: - *(char *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = (char)regs[INSTR_dri_dest(instr)]; - break; - case pb_st_op_pb_int16_pb_register: - *(short *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = (short)regs[INSTR_drr_dest(instr)]; - break; - case pb_st_op_pb_int16_pb_immediate: - *(short *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = (short)regs[INSTR_dri_dest(instr)]; - break; - case pb_st_op_pb_int32_pb_register: - *(int *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = (int)regs[INSTR_drr_dest(instr)]; - break; - case pb_st_op_pb_int32_pb_immediate: - *(int *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = (int)regs[INSTR_dri_dest(instr)]; - break; - case pb_st_op_pb_int64_pb_register: - *(uptr *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = regs[INSTR_drr_dest(instr)]; - break; - case pb_st_op_pb_int64_pb_immediate: - *(uptr *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = regs[INSTR_dri_dest(instr)]; - break; - case pb_st_op_pb_double_pb_register: - *(double *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = fpregs[INSTR_drr_dest(instr)]; - break; - case pb_st_op_pb_double_pb_immediate: - *(double *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = fpregs[INSTR_dri_dest(instr)]; - break; - case pb_st_op_pb_single_pb_register: - *(float *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = fpregs[INSTR_drr_dest(instr)]; - break; - case pb_st_op_pb_single_pb_immediate: - *(float *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = fpregs[INSTR_dri_dest(instr)]; - break; + case COMMON_INSTR(pb_mov_pb_s_d) + case COMMON_INSTR(pb_mov_pb_d_s) + case COMMON_INSTR(pb_mov_pb_d_s_d) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_add_pb_register) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_add_pb_immediate) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_sub_pb_register) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_sub_pb_immediate) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_mul_pb_register) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_mul_pb_immediate) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_div_pb_register) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_div_pb_immediate) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_and_pb_register) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_and_pb_immediate) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_ior_pb_register) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_ior_pb_immediate) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_xor_pb_register) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_xor_pb_immediate) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_lsl_pb_register) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_lsl_pb_immediate) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_lsr_pb_register) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_lsr_pb_immediate) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_asr_pb_register) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_asr_pb_immediate) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_lslo_pb_register) + case COMMON_INSTR(pb_bin_op_pb_no_signal_pb_lslo_pb_immediate) + case COMMON_INSTR(pb_bin_op_pb_signal_pb_add_pb_register) + case COMMON_INSTR(pb_bin_op_pb_signal_pb_add_pb_immediate) + case COMMON_INSTR(pb_bin_op_pb_signal_pb_sub_pb_register) + case COMMON_INSTR(pb_bin_op_pb_signal_pb_sub_pb_immediate) + case COMMON_INSTR(pb_bin_op_pb_signal_pb_mul_pb_register) + case COMMON_INSTR(pb_bin_op_pb_signal_pb_mul_pb_immediate) + case COMMON_INSTR(pb_bin_op_pb_signal_pb_subz_pb_register) + case COMMON_INSTR(pb_bin_op_pb_signal_pb_subz_pb_immediate) + case COMMON_INSTR(pb_bin_op_pb_signal_pb_subp_pb_register) + case COMMON_INSTR(pb_bin_op_pb_signal_pb_subp_pb_immediate) + case COMMON_INSTR(pb_cmp_op_pb_eq_pb_register) + case COMMON_INSTR(pb_cmp_op_pb_eq_pb_immediate) + case COMMON_INSTR(pb_cmp_op_pb_lt_pb_register) + case COMMON_INSTR(pb_cmp_op_pb_lt_pb_immediate) + case COMMON_INSTR(pb_cmp_op_pb_gt_pb_register) + case COMMON_INSTR(pb_cmp_op_pb_gt_pb_immediate) + case COMMON_INSTR(pb_cmp_op_pb_le_pb_register) + case COMMON_INSTR(pb_cmp_op_pb_le_pb_immediate) + case COMMON_INSTR(pb_cmp_op_pb_ge_pb_register) + case COMMON_INSTR(pb_cmp_op_pb_ge_pb_immediate) + case COMMON_INSTR(pb_cmp_op_pb_ab_pb_register) + case COMMON_INSTR(pb_cmp_op_pb_ab_pb_immediate) + case COMMON_INSTR(pb_cmp_op_pb_bl_pb_register) + case COMMON_INSTR(pb_cmp_op_pb_bl_pb_immediate) + case COMMON_INSTR(pb_cmp_op_pb_cs_pb_register) + case COMMON_INSTR(pb_cmp_op_pb_cs_pb_immediate) + case COMMON_INSTR(pb_cmp_op_pb_cc_pb_register) + case COMMON_INSTR(pb_cmp_op_pb_cc_pb_immediate) + case COMMON_INSTR(pb_fp_bin_op_pb_add_pb_register) + case COMMON_INSTR(pb_fp_bin_op_pb_sub_pb_register) + case COMMON_INSTR(pb_fp_bin_op_pb_mul_pb_register) + case COMMON_INSTR(pb_fp_bin_op_pb_div_pb_register) + case COMMON_INSTR(pb_un_op_pb_not_pb_register) + case COMMON_INSTR(pb_un_op_pb_not_pb_immediate) + case COMMON_INSTR(pb_fp_un_op_pb_sqrt_pb_register) + case COMMON_INSTR(pb_fp_cmp_op_pb_eq_pb_register) + case COMMON_INSTR(pb_fp_cmp_op_pb_lt_pb_register) + case COMMON_INSTR(pb_fp_cmp_op_pb_le_pb_register) + case COMMON_INSTR(pb_rev_op_pb_int16_pb_register) + case COMMON_INSTR(pb_rev_op_pb_uint16_pb_register) + case COMMON_INSTR(pb_rev_op_pb_int32_pb_register) + case COMMON_INSTR(pb_rev_op_pb_uint32_pb_register) + case COMMON_INSTR(pb_rev_op_pb_int64_pb_register) + case COMMON_INSTR(pb_ld_op_pb_int8_pb_register) + case COMMON_INSTR(pb_ld_op_pb_int8_pb_immediate) + case COMMON_INSTR(pb_ld_op_pb_uint8_pb_register) + case COMMON_INSTR(pb_ld_op_pb_uint8_pb_immediate) + case COMMON_INSTR(pb_ld_op_pb_int16_pb_register) + case COMMON_INSTR(pb_ld_op_pb_int16_pb_immediate) + case COMMON_INSTR(pb_ld_op_pb_uint16_pb_register) + case COMMON_INSTR(pb_ld_op_pb_uint16_pb_immediate) + case COMMON_INSTR(pb_ld_op_pb_int32_pb_register) + case COMMON_INSTR(pb_ld_op_pb_int32_pb_immediate) + case COMMON_INSTR(pb_ld_op_pb_uint32_pb_register) + case COMMON_INSTR(pb_ld_op_pb_uint32_pb_immediate) + case COMMON_INSTR(pb_ld_op_pb_int64_pb_register) + case COMMON_INSTR(pb_ld_op_pb_int64_pb_immediate) + case COMMON_INSTR(pb_ld_op_pb_double_pb_register) + case COMMON_INSTR(pb_ld_op_pb_double_pb_immediate) + case COMMON_INSTR(pb_ld_op_pb_single_pb_register) + case COMMON_INSTR(pb_ld_op_pb_single_pb_immediate) + case COMMON_INSTR(pb_st_op_pb_int8_pb_register) + case COMMON_INSTR(pb_st_op_pb_int8_pb_immediate) + case COMMON_INSTR(pb_st_op_pb_int16_pb_register) + case COMMON_INSTR(pb_st_op_pb_int16_pb_immediate) + case COMMON_INSTR(pb_st_op_pb_int32_pb_register) + case COMMON_INSTR(pb_st_op_pb_int32_pb_immediate) + case COMMON_INSTR(pb_st_op_pb_int64_pb_register) + case COMMON_INSTR(pb_st_op_pb_int64_pb_immediate) + case COMMON_INSTR(pb_st_op_pb_double_pb_register) + case COMMON_INSTR(pb_st_op_pb_double_pb_immediate) + case COMMON_INSTR(pb_st_op_pb_single_pb_register) + case COMMON_INSTR(pb_st_op_pb_single_pb_immediate) case pb_b_op_pb_fals_pb_register: if (!flag) { next_ip = (instruction_t *)TO_VOIDP(regs[INSTR_dr_reg(instr)]); @@ -699,11 +217,11 @@ void S_pb_interp(ptr tc, void *bytecode) { TRACE(printf("jump %p -> %p\n", ip, next_ip), { jump_from = ip; jump_to = next_ip; }); break; case pb_bs_op_pb_register: - next_ip = (instruction_t *)TO_VOIDP(*(uptr *)TO_VOIDP(regs[INSTR_dr_dest(instr)] + regs[INSTR_dr_reg(instr)])); + next_ip = (instruction_t *)TO_VOIDP(pb_bs_op_pb_register_addr(instr)); TRACE(printf("jump %p -> %p\n", ip, next_ip), { jump_from = ip; jump_to = next_ip; }); break; case pb_bs_op_pb_immediate: - next_ip = (instruction_t *)TO_VOIDP(*(uptr *)TO_VOIDP(regs[INSTR_di_dest(instr)] + INSTR_di_imm(instr))); + next_ip = (instruction_t *)TO_VOIDP(pb_bs_op_pb_immediate_addr(instr)); TRACE(printf("jump %p -> %p\n", ip, next_ip), { jump_from = ip; jump_to = next_ip; }); break; case pb_return: @@ -753,6 +271,9 @@ void S_pb_interp(ptr tc, void *bytecode) { case pb_call_void_int32_int32: ((pb_void_int32_int32_t)proc)(regs[Carg1], regs[Carg2]); break; + case pb_call_void_uint32_uint32: + ((pb_void_uint32_uint32_t)proc)(regs[Carg1], regs[Carg2]); + break; case pb_call_void_uptr_uptr: ((pb_void_uptr_uptr_t)proc)(regs[Carg1], regs[Carg2]); break; @@ -943,87 +464,20 @@ void S_pb_interp(ptr tc, void *bytecode) { } } break; - case pb_inc_pb_register: - { - uptr addr = regs[INSTR_dr_dest(instr)]; - uptr old_r = *(uptr *)TO_VOIDP(addr); - uptr r = old_r + regs[INSTR_dr_reg(instr)]; -# if defined(PTHREADS) - if (!CAS_ANY_FENCE(TO_VOIDP(addr), TO_VOIDP(old_r), TO_VOIDP(r))) - next_ip = ip; -# else - *(uptr *)TO_VOIDP(addr) = r; -# endif - flag = (r == 0); - } - break; - case pb_inc_pb_immediate: - { - uptr addr = regs[INSTR_dr_dest(instr)]; - uptr old_r = *(uptr *)TO_VOIDP(addr); - uptr r = old_r + INSTR_di_imm(instr); -# if defined(PTHREADS) - if (!CAS_ANY_FENCE(TO_VOIDP(addr), TO_VOIDP(old_r), TO_VOIDP(r))) - next_ip = ip; -# else - *(uptr *)TO_VOIDP(addr) = r; -# endif - flag = (r == 0); - } - break; - case pb_lock: - { - uptr *l = TO_VOIDP(regs[INSTR_d_dest(instr)]); -# if defined(PTHREADS) - flag = CAS_ANY_FENCE(l, TO_VOIDP(0), TO_VOIDP(1)); -# else - if (*l == 0) { - *l = 1; - flag = 1; - } else - flag = 0; -# endif - } - break; - case pb_cas: - { - uptr *l = TO_VOIDP(regs[INSTR_drr_dest(instr)]); - uptr old = regs[INSTR_drr_reg1(instr)]; - uptr new = regs[INSTR_drr_reg2(instr)]; -# if defined(PTHREADS) - flag = CAS_ANY_FENCE(l, TO_VOIDP(old), TO_VOIDP(new)); -# else - if (*l == old) { - *l = new; - flag = 1; - } else - flag = 0; -# endif - } - break; - case pb_fence_pb_fence_store_store: - STORE_FENCE(); - break; - case pb_fence_pb_fence_acquire: - ACQUIRE_FENCE(); - break; - case pb_fence_pb_fence_release: - RELEASE_FENCE(); - break; - case pb_call_arena_in: - *(ptr *)((uptr)TO_PTR(call_arena) + INSTR_di_imm(instr)) = regs[INSTR_di_dest(instr)]; - break; - case pb_fp_call_arena_in: - *(double *)((uptr)TO_PTR(call_arena) + INSTR_di_imm(instr)) = fpregs[INSTR_di_dest(instr)]; - break; - case pb_call_arena_out: - regs[INSTR_di_dest(instr)] = *(ptr *)((uptr)TO_PTR(call_arena) + INSTR_di_imm(instr)); - break; - case pb_fp_call_arena_out: - fpregs[INSTR_di_dest(instr)] = *(double *)((uptr)TO_PTR(call_arena) + INSTR_di_imm(instr)); - break; - case pb_stack_call: - S_ffi_call(regs[INSTR_dr_reg(instr)], regs[INSTR_dr_dest(instr)], (ptr *)call_arena); + case COMMON_INSTR(pb_inc_pb_register) + case COMMON_INSTR(pb_inc_pb_immediate) + case COMMON_INSTR(pb_lock) + case COMMON_INSTR(pb_cas) + case COMMON_INSTR(pb_fence_pb_fence_store_store) + case COMMON_INSTR(pb_fence_pb_fence_acquire) + case COMMON_INSTR(pb_fence_pb_fence_release) + case COMMON_INSTR(pb_call_arena_in) + case COMMON_INSTR(pb_fp_call_arena_in) + case COMMON_INSTR(pb_call_arena_out) + case COMMON_INSTR(pb_fp_call_arena_out) + case COMMON_INSTR(pb_stack_call) + case pb_chunk: + next_ip = TO_VOIDP((chunks[INSTR_ii_high(instr)])(ms, TO_PTR(ip), INSTR_ii_low(instr))); break; default: S_error_abort("illegal pb instruction"); diff --git a/racket/src/ChezScheme/c/pb.h b/racket/src/ChezScheme/c/pb.h new file mode 100644 index 00000000000..c27184d88a7 --- /dev/null +++ b/racket/src/ChezScheme/c/pb.h @@ -0,0 +1,809 @@ +/* Interpreter for portable bytecode. See "pb.ss". */ + +/* Machine state is in the thread context: */ +typedef struct machine_state { + ptr machine_regs[pb_reg_count]; + double machine_fpregs[pb_fpreg_count]; + /* scratch space for libffi-based foreign calls, + somewhat analogous to the C stack: */ + ptr machine_call_arena[pb_call_arena_size]; +} machine_state; + +#define regs (ms->machine_regs) +#define fpregs (ms->machine_fpregs) +#define call_arena (ms->machine_call_arena) + +/* The flag register doesn't have to be in the thread context, because + it set and then used only in the next instruction. */ + +/* All instructions are 32 bits wide: */ +typedef uint32_t instruction_t; + +#define INSTR_op(instr) ((instr) & 0xFF) + +#define INSTR_d_dest(instr) (((instr) >> 8) & 0xF) + +#define INSTR_dr_dest(instr) INSTR_d_dest(instr) +#define INSTR_dr_reg(instr) (((instr) >> 16) & 0xF) + +#define INSTR_di_dest(instr) INSTR_d_dest(instr) +#define INSTR_di_imm(instr) (((int32_t)(instr)) >> 16) +#define INSTR_di_imm_unsigned(instr) ((instr) >> 16) + +#define INSTR_adr_dest(instr) INSTR_di_dest(instr) +#define INSTR_adr_imm(instr) (((int32_t)(instr)) >> 12) + +#define INSTR_drr_dest(instr) INSTR_d_dest(instr) +#define INSTR_drr_reg1(instr) (((instr) >> 12) & 0xF) +#define INSTR_drr_reg2(instr) (((instr) >> 16) & 0xF) + +#define INSTR_dri_dest(instr) INSTR_d_dest(instr) +#define INSTR_dri_reg(instr) (((instr) >> 12) & 0xF) +#define INSTR_dri_imm(instr) (((int32_t)(instr)) >> 16) + +#define INSTR_i_imm(instr) (((int32_t)(instr)) >> 8) + +#define INSTR_ii_low(instr) (((instr) >> 8) & 0xFF) +#define INSTR_ii_high(instr) ((instr) >> 16) + +#define SHIFT_MASK(v) ((v) & (ptr_bits-1)) + +enum { + Cretval = 9, + Carg1 = 9, + Carg2, + Carg3, + Carg4, + Carg5, + Carg6, + Carg7 +}; + +enum { + Cfpretval = 1, + Cfparg1 = 1, + Cfparg2, + Cfparg3, + Cfparg4, + Cfparg5, + Cfparg6 +}; + +#define SIGN_FLIP(r, a, b) ((~((a ^ b) | (r ^ ~b))) >> (ptr_bits-1)) + +#if (__GNUC__ >= 5) || defined(__clang__) +# define USE_OVERFLOW_INTRINSICS 1 +#else +# define USE_OVERFLOW_INTRINSICS 0 +#endif + +/* Use `machine_state * RESTRICT_PTR`, because machine registers won't + be modified in any way other than through the machine-state pointer */ + +#if (__GNUC__ >= 4) || defined(__clang__) +# define RESTRICT_PTR __restrict__ +#endif + +#ifdef _MSC_VER +# define RESTRICT_PTR __restrict +#endif + +#ifndef RESTRICT_PTR +/* `restrict` is available in C99 and later */ +# define RESTRICT_PTR restrict +#endif + +/* ********************************************************************** */ +/* Implementations for instructions that can be used either within the + interpreter loop or within a generated chunk. */ + +#define do_pb_mov16_pb_zero_bits_pb_shift0(instr) \ + regs[INSTR_di_dest(instr)] = (uptr)INSTR_di_imm_unsigned(instr) + +#define do_pb_mov16_pb_zero_bits_pb_shift1(instr) \ + regs[INSTR_di_dest(instr)] = (uptr)INSTR_di_imm_unsigned(instr) << 16 + +#if ptr_bits == 64 +# define do_pb_mov16_pb_zero_bits_pb_shift2(instr) \ + regs[INSTR_di_dest(instr)] = (uptr)INSTR_di_imm_unsigned(instr) << 32 +#else +# define do_pb_mov16_pb_zero_bits_pb_shift2(instr) \ + regs[INSTR_di_dest(instr)] = 0 +#endif + +#if ptr_bits == 64 +# define do_pb_mov16_pb_zero_bits_pb_shift3(instr) \ + regs[INSTR_di_dest(instr)] = (uptr)INSTR_di_imm_unsigned(instr) << 48 +#else +# define do_pb_mov16_pb_zero_bits_pb_shift3(instr) \ + regs[INSTR_di_dest(instr)] = 0 +#endif + +#define do_pb_mov16_pb_keep_bits_pb_shift0(instr) \ + regs[INSTR_di_dest(instr)] |= (uptr)INSTR_di_imm_unsigned(instr) + +#define do_pb_mov16_pb_keep_bits_pb_shift1(instr) \ + regs[INSTR_di_dest(instr)] |= (uptr)INSTR_di_imm_unsigned(instr) << 16 + +#if ptr_bits == 64 +# define do_pb_mov16_pb_keep_bits_pb_shift2(instr) \ + regs[INSTR_di_dest(instr)] |= (uptr)INSTR_di_imm_unsigned(instr) << 32 +#else +# define do_pb_mov16_pb_keep_bits_pb_shift2(instr) \ + do { } while (0) +#endif + +#if ptr_bits == 64 +# define do_pb_mov16_pb_keep_bits_pb_shift3(instr) \ + regs[INSTR_di_dest(instr)] |= (uptr)INSTR_di_imm_unsigned(instr) << 48 +#else +# define do_pb_mov16_pb_keep_bits_pb_shift3(instr) \ + do { } while (0) +#endif + +#define do_pb_mov_pb_i_i(instr) \ + regs[INSTR_dr_dest(instr)] = regs[INSTR_dr_reg(instr)] + +#define do_pb_mov_pb_d_d(instr) \ + fpregs[INSTR_dr_dest(instr)] = fpregs[INSTR_dr_reg(instr)] + +#define do_pb_mov_pb_i_d(instr) \ + fpregs[INSTR_dr_dest(instr)] = (double)(iptr)regs[INSTR_dr_reg(instr)] + +#define do_pb_mov_pb_d_i(instr) \ + regs[INSTR_dr_dest(instr)] = (iptr)fpregs[INSTR_dr_reg(instr)] + +#if ptr_bits == 64 +# define do_pb_mov_pb_i_bits_d_bits(instr) \ + memcpy(&fpregs[INSTR_dr_dest(instr)], ®s[INSTR_dr_reg(instr)], sizeof(double)) +# define do_pb_mov_pb_d_bits_i_bits(instr) \ + memcpy(®s[INSTR_dr_dest(instr)], &fpregs[INSTR_dr_reg(instr)], sizeof(double)) +#else +# define do_pb_mov_pb_i_i_bits_d_bits(instr) \ + do { \ + uint64_t d; \ + d = regs[INSTR_drr_reg1(instr)] | ((uint64_t)regs[INSTR_drr_reg2(instr)] << 32); \ + memcpy(&fpregs[INSTR_drr_dest(instr)], &d, sizeof(double)); \ + } while (0) +# define do_pb_mov_pb_d_lo_bits_i_bits(instr) \ + do { \ + uint64_t d; \ + memcpy(&d, &fpregs[INSTR_dr_reg(instr)], sizeof(double)); \ + regs[INSTR_dr_dest(instr)] = d; \ + } while (0) +#define do_pb_mov_pb_d_hi_bits_i_bits(instr) \ + do { \ + uint64_t d; \ + memcpy(&d, &fpregs[INSTR_dr_reg(instr)], sizeof(double)); \ + d >>= 32; \ + regs[INSTR_dr_dest(instr)] = d; \ + } while (0) +#endif + +#ifdef PORTABLE_BYTECODE_BIGENDIAN +# define FP_REG_FLOAT_START(p) ((char *)&(p) + 4) +#else +# define FP_REG_FLOAT_START(p) &(p) +#endif + +#define do_pb_mov_pb_s_d(instr) \ + do { \ + float f; \ + memcpy(&f, FP_REG_FLOAT_START(fpregs[INSTR_dr_reg(instr)]), sizeof(float)); \ + fpregs[INSTR_dr_dest(instr)] = f; \ + } while (0) + +#define do_pb_mov_pb_d_s(instr) \ + do { \ + float f; \ + f = fpregs[INSTR_dr_reg(instr)]; \ + memcpy(FP_REG_FLOAT_START(fpregs[INSTR_dr_dest(instr)]), &f, sizeof(float)); \ + } while (0) + +#define do_pb_mov_pb_d_s_d(instr) \ + do { \ + float f; \ + f = fpregs[INSTR_dr_reg(instr)]; \ + fpregs[INSTR_dr_dest(instr)] = (double)f; \ + } while (0) + +#define do_pb_bin_op_pb_no_signal_pb_add_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)] + +#define do_pb_bin_op_pb_no_signal_pb_add_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] + (uptr)INSTR_dri_imm(instr) + +#define do_pb_bin_op_pb_no_signal_pb_sub_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] - regs[INSTR_drr_reg2(instr)] + +#define do_pb_bin_op_pb_no_signal_pb_sub_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] - (uptr)INSTR_dri_imm(instr) + +#define do_pb_bin_op_pb_no_signal_pb_mul_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] * regs[INSTR_drr_reg2(instr)] + +#define do_pb_bin_op_pb_no_signal_pb_mul_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = (uptr)regs[INSTR_dri_reg(instr)] * (uptr)INSTR_dri_imm(instr) + +#define do_pb_bin_op_pb_no_signal_pb_div_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = (iptr)regs[INSTR_drr_reg1(instr)] / (iptr)regs[INSTR_drr_reg2(instr)] + +#define do_pb_bin_op_pb_no_signal_pb_div_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = (iptr)regs[INSTR_dri_reg(instr)] / (iptr)INSTR_dri_imm(instr) + +#define do_pb_bin_op_pb_no_signal_pb_and_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] & regs[INSTR_drr_reg2(instr)] + +#define do_pb_bin_op_pb_no_signal_pb_and_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] & (uptr)INSTR_dri_imm(instr) + +#define do_pb_bin_op_pb_no_signal_pb_ior_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] | regs[INSTR_drr_reg2(instr)] + +#define do_pb_bin_op_pb_no_signal_pb_ior_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] | (uptr)INSTR_dri_imm(instr) + +#define do_pb_bin_op_pb_no_signal_pb_xor_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] ^ regs[INSTR_drr_reg2(instr)] + +#define do_pb_bin_op_pb_no_signal_pb_xor_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] ^ (uptr)INSTR_dri_imm(instr) + +#define do_pb_bin_op_pb_no_signal_pb_lsl_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] << SHIFT_MASK(regs[INSTR_drr_reg2(instr)]) + +#define do_pb_bin_op_pb_no_signal_pb_lsl_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] << SHIFT_MASK(INSTR_dri_imm(instr)) + +#define do_pb_bin_op_pb_no_signal_pb_lsr_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] >> SHIFT_MASK(regs[INSTR_drr_reg2(instr)]) + +#define do_pb_bin_op_pb_no_signal_pb_lsr_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] >> SHIFT_MASK(INSTR_dri_imm(instr)) + +#define do_pb_bin_op_pb_no_signal_pb_asr_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = (iptr)regs[INSTR_drr_reg1(instr)] >> SHIFT_MASK(regs[INSTR_drr_reg2(instr)]) + +#define do_pb_bin_op_pb_no_signal_pb_asr_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = (iptr)regs[INSTR_dri_reg(instr)] >> SHIFT_MASK(INSTR_dri_imm(instr)) + +#ifdef PORTABLE_BYTECODE_BIGENDIAN +# define do_pb_bin_op_pb_no_signal_pb_lslo_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] >> regs[INSTR_drr_reg2(instr)] +#else +# define do_pb_bin_op_pb_no_signal_pb_lslo_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] << regs[INSTR_drr_reg2(instr)] +#endif + +#ifdef PORTABLE_BYTECODE_BIGENDIAN +# define do_pb_bin_op_pb_no_signal_pb_lslo_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] >> INSTR_dri_imm(instr) +#else +# define do_pb_bin_op_pb_no_signal_pb_lslo_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] << INSTR_dri_imm(instr); +#endif + +#if USE_OVERFLOW_INTRINSICS +# define do_pb_bin_op_pb_signal_pb_add_pb_register(instr) \ + do { \ + iptr a = (iptr)regs[INSTR_drr_reg1(instr)]; \ + iptr b = (iptr)regs[INSTR_drr_reg2(instr)]; \ + iptr r; \ + flag = __builtin_add_overflow(a, b, &r); \ + regs[INSTR_drr_dest(instr)] = (uptr)r; \ + } while (0) +#else +# define do_pb_bin_op_pb_signal_pb_add_pb_register(instr) \ + do { \ + uptr a = regs[INSTR_drr_reg1(instr)]; \ + uptr b = regs[INSTR_drr_reg2(instr)]; \ + uptr r = a + b; \ + regs[INSTR_drr_dest(instr)] = r; \ + flag = SIGN_FLIP(r, a, b); \ + } while (0) +#endif + +#if USE_OVERFLOW_INTRINSICS +# define do_pb_bin_op_pb_signal_pb_add_pb_immediate(instr) \ + do { \ + iptr a = (iptr)regs[INSTR_dri_reg(instr)]; \ + iptr b = INSTR_dri_imm(instr); \ + iptr r; \ + flag = __builtin_add_overflow(a, b, &r); \ + regs[INSTR_drr_dest(instr)] = (uptr)r; \ + } while (0) +#else +# define do_pb_bin_op_pb_signal_pb_add_pb_immediate(instr) \ + do { \ + uptr a = regs[INSTR_dri_reg(instr)]; \ + uptr b = (uptr)INSTR_dri_imm(instr); \ + uptr r = a + b; \ + regs[INSTR_dri_dest(instr)] = r; \ + flag = SIGN_FLIP(r, a, b); \ + } while (0) +#endif + +#if USE_OVERFLOW_INTRINSICS +#define do_pb_bin_op_pb_signal_pb_sub_pb_register(instr) \ + do { \ + iptr a = (iptr)regs[INSTR_drr_reg1(instr)]; \ + iptr b = (iptr)regs[INSTR_drr_reg2(instr)]; \ + iptr r; \ + flag = __builtin_sub_overflow(a, b, &r); \ + regs[INSTR_drr_dest(instr)] = (uptr)r; \ + } while (0) +#else +#define do_pb_bin_op_pb_signal_pb_sub_pb_register(instr) \ + do { \ + uptr a = regs[INSTR_drr_reg1(instr)]; \ + uptr b = regs[INSTR_drr_reg2(instr)]; \ + uptr r = a - b; \ + regs[INSTR_drr_dest(instr)] = r; \ + flag = SIGN_FLIP(r, a, ~b); \ + } while (0) +#endif + +#if USE_OVERFLOW_INTRINSICS +# define do_pb_bin_op_pb_signal_pb_sub_pb_immediate(instr) \ + do { \ + iptr a = (iptr)regs[INSTR_dri_reg(instr)]; \ + iptr b = INSTR_dri_imm(instr); \ + iptr r; \ + flag = __builtin_sub_overflow(a, b, &r); \ + regs[INSTR_drr_dest(instr)] = (uptr)r; \ + } while (0) +#else +# define do_pb_bin_op_pb_signal_pb_sub_pb_immediate(instr) \ + do { \ + uptr a = regs[INSTR_dri_reg(instr)]; \ + uptr b = (uptr)INSTR_dri_imm(instr); \ + uptr r = a - b; \ + regs[INSTR_dri_dest(instr)] = r; \ + flag = SIGN_FLIP(r, a, ~b); \ + } while (0) +#endif + +#if USE_OVERFLOW_INTRINSICS +#define do_pb_bin_op_pb_signal_pb_mul_pb_register(instr) \ + do { \ + iptr a = (iptr)regs[INSTR_drr_reg1(instr)]; \ + iptr b = (iptr)regs[INSTR_drr_reg2(instr)]; \ + iptr r; \ + flag = __builtin_mul_overflow(a, b, &r); \ + regs[INSTR_drr_dest(instr)] = (uptr)r; \ + } while (0) +#else +#define do_pb_bin_op_pb_signal_pb_mul_pb_register(instr) \ + do { \ + uptr a = regs[INSTR_drr_reg1(instr)]; \ + uptr b = regs[INSTR_drr_reg2(instr)]; \ + uptr r = a * b; \ + regs[INSTR_drr_dest(instr)] = r; \ + if (b != 0) { \ + if (b == (uptr)-1) \ + flag = (a != r * (uptr)-1); \ + else \ + flag = ((iptr)a != (iptr)r / (iptr)b); \ + } else \ + flag = 0; \ + } while (0) +#endif + +#if USE_OVERFLOW_INTRINSICS +# define do_pb_bin_op_pb_signal_pb_mul_pb_immediate(instr) \ + do { \ + iptr a = (iptr)regs[INSTR_dri_reg(instr)]; \ + iptr b = INSTR_dri_imm(instr); \ + iptr r; \ + flag = __builtin_mul_overflow(a, b, &r); \ + regs[INSTR_drr_dest(instr)] = (uptr)r; \ + } while (0) +#else +# define do_pb_bin_op_pb_signal_pb_mul_pb_immediate(instr) \ + do { \ + uptr a = regs[INSTR_dri_reg(instr)]; \ + uptr b = (uptr)INSTR_dri_imm(instr); \ + uptr r = a * b; \ + regs[INSTR_dri_dest(instr)] = r; \ + if (b != 0) { \ + if (b == (uptr)-1) \ + flag = (a != r * (uptr)-1); \ + else \ + flag = ((iptr)a != (iptr)r / (iptr)b); \ + } else \ + flag = 0; \ + } while (0) +#endif + +#define do_pb_bin_op_pb_signal_pb_subz_pb_register(instr) \ + do { \ + iptr r = regs[INSTR_drr_reg1(instr)] - regs[INSTR_drr_reg2(instr)]; \ + regs[INSTR_drr_dest(instr)] = r; \ + flag = (r == 0); \ + } while (0) + +#define do_pb_bin_op_pb_signal_pb_subz_pb_immediate(instr) \ + do { \ + iptr r = regs[INSTR_dri_reg(instr)] - (uptr)INSTR_dri_imm(instr); \ + regs[INSTR_dri_dest(instr)] = r; \ + flag = (r == 0); \ + } while (0) + +#define do_pb_bin_op_pb_signal_pb_subp_pb_register(instr) \ + do { \ + iptr r = regs[INSTR_drr_reg1(instr)] - regs[INSTR_drr_reg2(instr)]; \ + regs[INSTR_drr_dest(instr)] = r; \ + flag = (r > 0); \ + } while (0) + +#define do_pb_bin_op_pb_signal_pb_subp_pb_immediate(instr) \ + do { \ + iptr r = regs[INSTR_dri_reg(instr)] - (uptr)INSTR_dri_imm(instr); \ + regs[INSTR_dri_dest(instr)] = r; \ + flag = (r > 0); \ + } while (0) + +#define do_pb_cmp_op_pb_eq_pb_register(instr) \ + flag = regs[INSTR_dr_dest(instr)] == regs[INSTR_dr_reg(instr)] + +#define do_pb_cmp_op_pb_eq_pb_immediate(instr) \ + flag = regs[INSTR_di_dest(instr)] == (uptr)INSTR_di_imm(instr) + +#define do_pb_cmp_op_pb_lt_pb_register(instr) \ + flag = (iptr)regs[INSTR_dr_dest(instr)] < (iptr)regs[INSTR_dr_reg(instr)] + +#define do_pb_cmp_op_pb_lt_pb_immediate(instr) \ + flag = (iptr)regs[INSTR_di_dest(instr)] < (iptr)INSTR_di_imm(instr) + +#define do_pb_cmp_op_pb_gt_pb_register(instr) \ + flag = (iptr)regs[INSTR_dr_dest(instr)] > (iptr)regs[INSTR_dr_reg(instr)] + +#define do_pb_cmp_op_pb_gt_pb_immediate(instr) \ + flag = (iptr)regs[INSTR_di_dest(instr)] > (iptr)INSTR_di_imm(instr) + +#define do_pb_cmp_op_pb_le_pb_register(instr) \ + flag = (iptr)regs[INSTR_dr_dest(instr)] <= (iptr)regs[INSTR_dr_reg(instr)] + +#define do_pb_cmp_op_pb_le_pb_immediate(instr) \ + flag = (iptr)regs[INSTR_di_dest(instr)] <= (iptr)INSTR_di_imm(instr) + +#define do_pb_cmp_op_pb_ge_pb_register(instr) \ + flag = (iptr)regs[INSTR_dr_dest(instr)] >= (iptr)regs[INSTR_dr_reg(instr)] + +#define do_pb_cmp_op_pb_ge_pb_immediate(instr) \ + flag = (iptr)regs[INSTR_di_dest(instr)] >= (iptr)INSTR_di_imm(instr) + +#define do_pb_cmp_op_pb_ab_pb_register(instr) \ + flag = regs[INSTR_dr_dest(instr)] > regs[INSTR_dr_reg(instr)] + +#define do_pb_cmp_op_pb_ab_pb_immediate(instr) \ + flag = regs[INSTR_di_dest(instr)] > (uptr)INSTR_di_imm(instr) + +#define do_pb_cmp_op_pb_bl_pb_register(instr) \ + flag = regs[INSTR_dr_dest(instr)] < regs[INSTR_dr_reg(instr)] + +#define do_pb_cmp_op_pb_bl_pb_immediate(instr) \ + flag = regs[INSTR_di_dest(instr)] < (uptr)INSTR_di_imm(instr) + +#define do_pb_cmp_op_pb_cs_pb_register(instr) \ + flag = ((regs[INSTR_dr_dest(instr)] & regs[INSTR_dr_reg(instr)]) != 0) + +#define do_pb_cmp_op_pb_cs_pb_immediate(instr) \ + flag = ((regs[INSTR_di_dest(instr)] & (uptr)INSTR_di_imm(instr)) != 0) + +#define do_pb_cmp_op_pb_cc_pb_register(instr) \ + flag = ((regs[INSTR_dr_dest(instr)] & regs[INSTR_dr_reg(instr)]) == 0) + +#define do_pb_cmp_op_pb_cc_pb_immediate(instr) \ + flag = ((regs[INSTR_di_dest(instr)] & (uptr)INSTR_di_imm(instr)) == 0) + +#define do_pb_fp_bin_op_pb_add_pb_register(instr) \ + fpregs[INSTR_drr_dest(instr)] = fpregs[INSTR_drr_reg1(instr)] + fpregs[INSTR_drr_reg2(instr)] + +#define do_pb_fp_bin_op_pb_sub_pb_register(instr) \ + fpregs[INSTR_drr_dest(instr)] = fpregs[INSTR_drr_reg1(instr)] - fpregs[INSTR_drr_reg2(instr)] + +#define do_pb_fp_bin_op_pb_mul_pb_register(instr) \ + fpregs[INSTR_drr_dest(instr)] = fpregs[INSTR_drr_reg1(instr)] * fpregs[INSTR_drr_reg2(instr)] + +#define do_pb_fp_bin_op_pb_div_pb_register(instr) \ + fpregs[INSTR_drr_dest(instr)] = fpregs[INSTR_drr_reg1(instr)] / fpregs[INSTR_drr_reg2(instr)] + +#define do_pb_un_op_pb_not_pb_register(instr) \ + regs[INSTR_dr_dest(instr)] = ~(regs[INSTR_dr_reg(instr)]) + +#define do_pb_un_op_pb_not_pb_immediate(instr) \ + regs[INSTR_di_dest(instr)] = ~((uptr)(iptr)INSTR_di_imm(instr)) + +#define do_pb_fp_un_op_pb_sqrt_pb_register(instr) \ + fpregs[INSTR_dr_dest(instr)] = sqrt(fpregs[INSTR_dr_reg(instr)]) + +#define do_pb_fp_cmp_op_pb_eq_pb_register(instr) \ + flag = fpregs[INSTR_dr_dest(instr)] == fpregs[INSTR_dr_reg(instr)] + +#define do_pb_fp_cmp_op_pb_lt_pb_register(instr) \ + flag = fpregs[INSTR_dr_dest(instr)] < fpregs[INSTR_dr_reg(instr)] + +#define do_pb_fp_cmp_op_pb_le_pb_register(instr) \ + flag = fpregs[INSTR_dr_dest(instr)] <= fpregs[INSTR_dr_reg(instr)] + +#if ptr_bits == 64 +#define do_pb_rev_op_pb_int16_pb_register(instr) \ + regs[INSTR_dr_dest(instr)] = ((uptr)((iptr)(regs[INSTR_dr_reg(instr)] << 56) >> 48) \ + | ((regs[INSTR_dr_reg(instr)] & 0xFF00) >> 8)) +#else +#define do_pb_rev_op_pb_int16_pb_register(instr) \ + regs[INSTR_dr_dest(instr)] = ((uptr)((iptr)(regs[INSTR_dr_reg(instr)] << 24) >> 16) \ + | ((regs[INSTR_dr_reg(instr)] & 0xFF00) >> 8)) +#endif + +#define do_pb_rev_op_pb_uint16_pb_register(instr) \ + regs[INSTR_dr_dest(instr)] = (((regs[INSTR_dr_reg(instr)] & 0x00FF) << 8) \ + | ((regs[INSTR_dr_reg(instr)] & 0xFF00) >> 8)) + +#if ptr_bits == 64 +# define do_pb_rev_op_pb_int32_pb_register(instr) \ + regs[INSTR_dr_dest(instr)] = ((uptr)((iptr)(regs[INSTR_dr_reg(instr)] << 56) >> 32) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0xFF000000) >> 24) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00FF0000) >> 8) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000FF00) << 8)) +#else +# define do_pb_rev_op_pb_int32_pb_register(instr) \ + regs[INSTR_dr_dest(instr)] = ((regs[INSTR_dr_reg(instr)] << 24) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0xFF000000) >> 24) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00FF0000) >> 8) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000FF00) << 8)) +#endif + +#define do_pb_rev_op_pb_uint32_pb_register(instr) \ + regs[INSTR_dr_dest(instr)] = (((regs[INSTR_dr_reg(instr)] & (uptr)0x000000FF) << 24) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0xFF000000) >> 24) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00FF0000) >> 8) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000FF00) << 8)) + +#if ptr_bits == 64 +# define do_pb_rev_op_pb_int64_pb_register(instr) \ + regs[INSTR_dr_dest(instr)] = (((regs[INSTR_dr_reg(instr)] & (uptr)0x00000000000000FF) << 56) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x000000000000FF00) << 40) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000000000FF0000) << 24) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00000000FF000000) << 8) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x000000FF00000000) >> 8) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000FF0000000000) >> 24) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00FF000000000000) >> 40) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0xFF00000000000000) >> 56)) +#else +# define do_pb_rev_op_pb_int64_pb_register(instr) \ + regs[INSTR_dr_dest(instr)] = (((regs[INSTR_dr_reg(instr)] & (uptr)0x000000FF) << 24) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0xFF000000) >> 24) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00FF0000) >> 8) \ + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000FF00) << 8)) +#endif + +#define do_pb_ld_op_pb_int8_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = *(int8_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) + +#if defined(__arm__) +/* Complicated load to avoid an internal compiler error from an old gcc on Raspbian: */ +# define do_pb_ld_op_pb_int8_pb_immediate(instr) \ + do { \ + int8_t v; \ + memcpy(&v, TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)), sizeof(int8_t)); \ + regs[INSTR_dri_dest(instr)] = v; \ + } while (0) +#else +# define do_pb_ld_op_pb_int8_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = *(int8_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) +#endif + +#define do_pb_ld_op_pb_uint8_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = *(uint8_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) + +#define do_pb_ld_op_pb_uint8_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = *(uint8_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) + +#define do_pb_ld_op_pb_int16_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = *(int16_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) + +#define do_pb_ld_op_pb_int16_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = *(int16_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) + +#define do_pb_ld_op_pb_uint16_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = *(uint16_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) + +#define do_pb_ld_op_pb_uint16_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = *(uint16_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) + +#define do_pb_ld_op_pb_int32_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = *(int32_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) + +#define do_pb_ld_op_pb_int32_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = *(int32_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) + +#define do_pb_ld_op_pb_uint32_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = *(uint32_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) + +#define do_pb_ld_op_pb_uint32_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = *(uint32_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) + +#define do_pb_ld_op_pb_int64_pb_register(instr) \ + regs[INSTR_drr_dest(instr)] = *(uptr *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) + +#define do_pb_ld_op_pb_int64_pb_immediate(instr) \ + regs[INSTR_dri_dest(instr)] = *(uptr *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) + +#define do_pb_ld_op_pb_double_pb_register(instr) \ + fpregs[INSTR_drr_dest(instr)] = *(double *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) + +#define do_pb_ld_op_pb_double_pb_immediate(instr) \ + fpregs[INSTR_dri_dest(instr)] = *(double *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) + +#define do_pb_ld_op_pb_single_pb_register(instr) \ + fpregs[INSTR_drr_dest(instr)] = *(float *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) + +#define do_pb_ld_op_pb_single_pb_immediate(instr) \ + fpregs[INSTR_dri_dest(instr)] = *(float *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) + +#define do_pb_st_op_pb_int8_pb_register(instr) \ + *(char *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = (char)regs[INSTR_drr_dest(instr)] + +#define do_pb_st_op_pb_int8_pb_immediate(instr) \ + *(char *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = (char)regs[INSTR_dri_dest(instr)] + +#define do_pb_st_op_pb_int16_pb_register(instr) \ + *(short *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = (short)regs[INSTR_drr_dest(instr)] + +#define do_pb_st_op_pb_int16_pb_immediate(instr) \ + *(short *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = (short)regs[INSTR_dri_dest(instr)] + +#define do_pb_st_op_pb_int32_pb_register(instr) \ + *(int *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = (int)regs[INSTR_drr_dest(instr)] + +#define do_pb_st_op_pb_int32_pb_immediate(instr) \ + *(int *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = (int)regs[INSTR_dri_dest(instr)] + +#define do_pb_st_op_pb_int64_pb_register(instr) \ + *(uptr *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = regs[INSTR_drr_dest(instr)] + +#define do_pb_st_op_pb_int64_pb_immediate(instr) \ + *(uptr *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = regs[INSTR_dri_dest(instr)] + +#define do_pb_st_op_pb_double_pb_register(instr) \ + *(double *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = fpregs[INSTR_drr_dest(instr)] + +#define do_pb_st_op_pb_double_pb_immediate(instr) \ + *(double *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = fpregs[INSTR_dri_dest(instr)] + +#define do_pb_st_op_pb_single_pb_register(instr) \ + *(float *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = fpregs[INSTR_drr_dest(instr)] + +#define do_pb_st_op_pb_single_pb_immediate(instr) \ + *(float *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = fpregs[INSTR_dri_dest(instr)] + +#if defined(PTHREADS) +# define CAS_ANY_FENCE_SEQOK(addr, old_r, r) \ + CAS_ANY_FENCE(TO_VOIDP(addr), TO_VOIDP(old_r), TO_VOIDP(r)) +#else +# define CAS_ANY_FENCE_SEQOK(addr, old_r, r) \ + (*(uptr *)TO_VOIDP(addr) = r, 1) +#endif + +#define do_pb_inc_pb_register(instr) \ + do { \ + uptr addr = regs[INSTR_dr_dest(instr)]; \ + while (1) { \ + uptr old_r = *(uptr *)TO_VOIDP(addr); \ + uptr r = old_r + regs[INSTR_dr_reg(instr)]; \ + if (CAS_ANY_FENCE_SEQOK(addr, old_r, r)) { \ + flag = (r == 0); \ + break; \ + } \ + } \ + } while (0) + +#define do_pb_inc_pb_immediate(instr) \ + do { \ + uptr addr = regs[INSTR_di_dest(instr)]; \ + while (1) { \ + uptr old_r = *(uptr *)TO_VOIDP(addr); \ + uptr r = old_r + INSTR_di_imm(instr); \ + if (CAS_ANY_FENCE_SEQOK(addr, old_r, r)) { \ + flag = (r == 0); \ + break; \ + } \ + } \ + } while (0) + +#if defined(PTHREADS) +# define do_pb_lock(instr) \ + do { \ + uptr *l = TO_VOIDP(regs[INSTR_d_dest(instr)]); \ + flag = CAS_ANY_FENCE(l, TO_VOIDP(0), TO_VOIDP(1)); \ + } while (0) +#else +# define do_pb_lock(instr) \ + do { \ + uptr *l = TO_VOIDP(regs[INSTR_d_dest(instr)]); \ + if (*l == 0) { \ + *l = 1; \ + flag = 1; \ + } else \ + flag = 0; \ + } while (0) +#endif + +#if defined(PTHREADS) +# define do_pb_cas(instr) \ + do { \ + uptr *l = TO_VOIDP(regs[INSTR_drr_dest(instr)]); \ + uptr old = regs[INSTR_drr_reg1(instr)]; \ + uptr new = regs[INSTR_drr_reg2(instr)]; \ + flag = CAS_ANY_FENCE(l, TO_VOIDP(old), TO_VOIDP(new)); \ + } while (0) +#else +#define do_pb_cas(instr) \ + do { \ + uptr *l = TO_VOIDP(regs[INSTR_drr_dest(instr)]); \ + uptr old = regs[INSTR_drr_reg1(instr)]; \ + uptr new = regs[INSTR_drr_reg2(instr)]; \ + if (*l == old) { \ + *l = new; \ + flag = 1; \ + } else \ + flag = 0; \ + } while (0) +#endif + +#define do_pb_fence_pb_fence_store_store(instr) \ + STORE_FENCE() + +#define do_pb_fence_pb_fence_acquire(instr) \ + ACQUIRE_FENCE() + +#define do_pb_fence_pb_fence_release(instr) \ + RELEASE_FENCE() + +#define do_pb_call_arena_in(instr) \ + *(ptr *)TO_VOIDP(((uptr)TO_PTR(call_arena) + INSTR_di_imm(instr))) = regs[INSTR_di_dest(instr)] + +#define do_pb_fp_call_arena_in(instr) \ + *(double *)TO_VOIDP(((uptr)TO_PTR(call_arena) + INSTR_di_imm(instr))) = fpregs[INSTR_di_dest(instr)] + +#define do_pb_call_arena_out(instr) \ + regs[INSTR_di_dest(instr)] = *(ptr *)TO_VOIDP((uptr)TO_PTR(call_arena) + INSTR_di_imm(instr)) + +#define do_pb_fp_call_arena_out(instr) \ + fpregs[INSTR_di_dest(instr)] = *(double *)TO_VOIDP((uptr)TO_PTR(call_arena) + INSTR_di_imm(instr)) + +#define do_pb_stack_call(instr) \ + S_ffi_call(regs[INSTR_dr_reg(instr)], regs[INSTR_dr_dest(instr)], (ptr *)call_arena) + +#define pb_bs_op_pb_register_addr(instr) \ + (*(uptr *)TO_VOIDP(regs[INSTR_dr_dest(instr)] + regs[INSTR_dr_reg(instr)])) + +#define pb_bs_op_pb_immediate_addr(instr) \ + (*(uptr *)TO_VOIDP(regs[INSTR_di_dest(instr)] + INSTR_di_imm(instr))) + +#if ptr_bits == 64 +# define decode_relocation(instr, ip) \ + ((uptr)INSTR_di_imm_unsigned(instr) \ + | ((uptr)INSTR_di_imm_unsigned((ip)[1]) << 16) \ + | ((uptr)INSTR_di_imm_unsigned((ip)[2]) << 32) \ + | ((uptr)INSTR_di_imm_unsigned((ip)[3]) << 48)) +#else +# define decode_relocation(instr, ip) \ + ((uptr)INSTR_di_imm_unsigned(instr) \ + | ((uptr)INSTR_di_imm_unsigned((ip)[1]) << 16)) +#endif + +/* ********************************************************************** */ +/* Support for generated chunks */ + +#define load_from_relocation(dest, ip) \ + regs[dest] = decode_relocation(((instruction_t *)TO_VOIDP(ip))[0], (instruction_t *)TO_VOIDP(ip)) + +#define load_code_relative(dest, ip) \ + regs[dest] = ip + +#define code_rel(start_i, i) ((i)-(start_i)) + +#define MACHINE_STATE machine_state * RESTRICT_PTR diff --git a/racket/src/ChezScheme/c/prim.c b/racket/src/ChezScheme/c/prim.c index f50300d67fb..7aa4b955019 100644 --- a/racket/src/ChezScheme/c/prim.c +++ b/racket/src/ChezScheme/c/prim.c @@ -45,7 +45,7 @@ static void install_library_entry(n, x) ptr n, x; { if (n == FIX(library_cpu_features)) x86_64_set_popcount_present(x); #endif -#ifdef PORTABLE_BYTECODE_BIGENDIAN +#ifdef PORTABLE_BYTECODE_SWAPENDIAN if (n == FIX(library_dounderflow)) S_swap_dounderflow_header_endian(CLOSCODE(x)); #endif diff --git a/racket/src/ChezScheme/c/prim5.c b/racket/src/ChezScheme/c/prim5.c index bde80442ce2..f2138bd60f9 100644 --- a/racket/src/ChezScheme/c/prim5.c +++ b/racket/src/ChezScheme/c/prim5.c @@ -99,10 +99,13 @@ static ptr s_get_reloc PROTO((ptr co, IBOOL with_offsets)); static s_thread_rv_t s_backdoor_thread_start PROTO((void *p)); static iptr s_backdoor_thread PROTO((ptr p)); static ptr s_threads PROTO((void)); -static void s_mutex_acquire PROTO((scheme_mutex_t *m)); -static ptr s_mutex_acquire_noblock PROTO((scheme_mutex_t *m)); -static void s_condition_broadcast PROTO((s_thread_cond_t *c)); -static void s_condition_signal PROTO((s_thread_cond_t *c)); +static void s_mutex_acquire PROTO((ptr m)); +static ptr s_mutex_acquire_noblock PROTO((ptr m)); +static void s_mutex_release PROTO((ptr m)); +static void s_condition_broadcast PROTO((ptr c)); +static void s_condition_signal PROTO((ptr c)); +static void s_condition_free PROTO((ptr c)); +static IBOOL s_condition_wait PROTO((ptr c, ptr m, ptr t)); static void s_thread_preserve_ownership PROTO((ptr tc)); #endif static void s_byte_copy(ptr src, iptr srcoff, ptr dst, iptr dstoff, iptr cnt); @@ -1540,12 +1543,12 @@ static s_thread_rv_t s_backdoor_thread_start(p) void *p; { display("backdoor thread started\n") (void) Sactivate_thread(); display("thread activated\n") - Scall0((ptr)Sunbox(p)); + Scall0((ptr)Sunbox(TO_PTR(p))); (void) Sdeactivate_thread(); display("thread deactivated\n") (void) Sactivate_thread(); display("thread reeactivated\n") - Scall0((ptr)Sunbox(p)); + Scall0((ptr)Sunbox(TO_PTR(p))); Sdestroy_thread(); display("thread destroyed\n") s_thread_return; @@ -1553,7 +1556,7 @@ static s_thread_rv_t s_backdoor_thread_start(p) void *p; { static iptr s_backdoor_thread(p) ptr p; { display("creating thread\n"); - return s_thread_create(s_backdoor_thread_start, (void *)p); + return s_thread_create(s_backdoor_thread_start, TO_VOIDP(p)); } static ptr s_threads() { @@ -1564,7 +1567,8 @@ static ptr s_threads() { return ts; } -static void s_mutex_acquire(m) scheme_mutex_t *m; { +static void s_mutex_acquire(m_p) ptr m_p; { + scheme_mutex_t *m = TO_VOIDP(m_p); ptr tc = get_thread_context(); if (m == &S_tc_mutex) { @@ -1583,18 +1587,34 @@ static void s_mutex_acquire(m) scheme_mutex_t *m; { } } -static ptr s_mutex_acquire_noblock(m) scheme_mutex_t *m; { +static ptr s_mutex_acquire_noblock(m_p) ptr m_p; { + scheme_mutex_t *m = TO_VOIDP(m_p); return S_mutex_tryacquire(m) == 0 ? Strue : Sfalse; } -static void s_condition_broadcast(s_thread_cond_t *c) { +static void s_mutex_release(ptr m) { + return S_mutex_release(TO_VOIDP(m)); +} + +static void s_condition_broadcast(ptr c_p) { + s_thread_cond_t *c = TO_VOIDP(c_p); s_thread_cond_broadcast(c); } -static void s_condition_signal(s_thread_cond_t *c) { +static void s_condition_signal(ptr c_p) { + s_thread_cond_t *c = TO_VOIDP(c_p); s_thread_cond_signal(c); } +static void s_condition_free(ptr c) { + return S_condition_free(TO_VOIDP(c)); +} + +static IBOOL s_condition_wait(ptr c, ptr m, ptr t) { + return S_condition_wait(TO_VOIDP(c), TO_VOIDP(m), t); +} + + /* called with tc mutex held */ static void s_thread_preserve_ownership(ptr tc) { if (!THREAD_GC(tc)->preserve_ownership) { @@ -1675,13 +1695,13 @@ void S_prim5_init() { Sforeign_symbol("(cs)backdoor_thread", (void *)s_backdoor_thread); Sforeign_symbol("(cs)threads", (void *)s_threads); Sforeign_symbol("(cs)mutex_acquire", (void *)s_mutex_acquire); - Sforeign_symbol("(cs)mutex_release", (void *)S_mutex_release); + Sforeign_symbol("(cs)mutex_release", (void *)s_mutex_release); Sforeign_symbol("(cs)mutex_acquire_noblock", (void *)s_mutex_acquire_noblock); Sforeign_symbol("(cs)make_condition", (void *)S_make_condition); - Sforeign_symbol("(cs)condition_free", (void *)S_condition_free); + Sforeign_symbol("(cs)condition_free", (void *)s_condition_free); Sforeign_symbol("(cs)condition_broadcast", (void *)s_condition_broadcast); Sforeign_symbol("(cs)condition_signal", (void *)s_condition_signal); - Sforeign_symbol("(cs)condition_wait", (void *)S_condition_wait); + Sforeign_symbol("(cs)condition_wait", (void *)s_condition_wait); Sforeign_symbol("(cs)thread_preserve_ownership", (void *)s_thread_preserve_ownership); #endif Sforeign_symbol("(cs)s_addr_in_heap", (void *)s_addr_in_heap); diff --git a/racket/src/ChezScheme/c/segment.c b/racket/src/ChezScheme/c/segment.c index 20e85c05f9a..21a41d3ac42 100644 --- a/racket/src/ChezScheme/c/segment.c +++ b/racket/src/ChezScheme/c/segment.c @@ -152,7 +152,11 @@ void S_freemem(void *addr, iptr bytes, UNUSED IBOOL for_code) { #if defined(USE_MMAP) #include #ifndef MAP_ANONYMOUS -#define MAP_ANONYMOUS MAP_ANON +# define MAP_ANONYMOUS MAP_ANON +#endif +#ifdef PORTABLE_BYTECODE +# undef S_PROT_CODE +# define S_PROT_CODE (PROT_WRITE | PROT_READ) #endif void *S_getmem(iptr bytes, IBOOL zerofill, IBOOL for_code) { void *addr; diff --git a/racket/src/ChezScheme/c/thread.c b/racket/src/ChezScheme/c/thread.c index 31e01c31d18..53790cc7e03 100644 --- a/racket/src/ChezScheme/c/thread.c +++ b/racket/src/ChezScheme/c/thread.c @@ -254,7 +254,7 @@ static IBOOL destroy_thread(tc) ptr tc; { alloc_mutex_acquire(); /* process remembered set before dropping allocation area */ - S_scan_dirty((ptr *)EAP(tc), (ptr *)REAL_EAP(tc)); + S_scan_dirty((ptr *)TO_VOIDP(EAP(tc)), (ptr *)TO_VOIDP(REAL_EAP(tc))); /* close off thread-local allocation */ S_thread_start_code_write(tc, static_generation, 0, NULL, 0); @@ -309,7 +309,7 @@ static IBOOL destroy_thread(tc) ptr tc; { THREAD_GC(tc)->next = free_thread_gcs; free_thread_gcs = THREAD_GC(tc); - free((void *)tc); + free(TO_VOIDP(tc)); THREADTC(thread) = 0; /* mark it dead */ status = 1; @@ -340,7 +340,7 @@ ptr S_fork_thread(thunk) ptr thunk; { } static s_thread_rv_t start_thread(p) void *p; { - ptr tc = (ptr)p; ptr cp; + ptr tc = TO_PTR(p); ptr cp; s_thread_setspecific(S_tc_key, TO_VOIDP(tc)); @@ -502,7 +502,7 @@ static inline int s_thread_cond_timedwait(s_thread_cond_t *cond, s_thread_mutex_ #endif /* FEATURE_WINDOWS */ -#define Srecord_ref(x,i) (((ptr *)((uptr)(x)+record_data_disp))[i]) +#define Srecord_ref(x,i) (((ptr *)TO_VOIDP(((uptr)(x)+record_data_disp)))[i]) IBOOL S_condition_wait(c, m, t) s_thread_cond_t *c; scheme_mutex_t *m; ptr t; { ptr tc = get_thread_context(); diff --git a/racket/src/ChezScheme/c/types.h b/racket/src/ChezScheme/c/types.h index 9cbc02f53dc..47baa572003 100644 --- a/racket/src/ChezScheme/c/types.h +++ b/racket/src/ChezScheme/c/types.h @@ -362,7 +362,7 @@ typedef struct { s_thread_mutex_t pmutex; } scheme_mutex_t; -#define get_thread_context() (ptr)s_thread_getspecific(S_tc_key) +#define get_thread_context() TO_PTR(s_thread_getspecific(S_tc_key)) /* deactivate thread prepares the thread for a possible collection. if it's the last active thread, it signals one of the threads waiting on the collect condition, if any, so that a collection diff --git a/racket/src/ChezScheme/c/version.h b/racket/src/ChezScheme/c/version.h index cf64a58d281..d5cefd881b1 100644 --- a/racket/src/ChezScheme/c/version.h +++ b/racket/src/ChezScheme/c/version.h @@ -35,8 +35,17 @@ # define FLUSHCACHE #endif -#if ((machine_type == machine_type_pb) || (machine_type == machine_type_tpb)) +#ifdef PORTABLE_BYTECODE # undef FLUSHCACHE +# ifdef PORTABLE_BYTECODE_BIGENDIAN +# if fasl_endianness_is_little +# define PORTABLE_BYTECODE_SWAPENDIAN +# endif +# else +# if fasl_endianness_is_big +# define PORTABLE_BYTECODE_SWAPENDIAN +# endif +# endif #else # undef PORTABLE_BYTECODE_BIGENDIAN #endif @@ -423,6 +432,10 @@ typedef char tputsputcchar; # define WRITE write #endif +#ifdef PORTABLE_BYTECODE +# undef WRITE_XOR_EXECUTE_CODE +#endif + #ifndef S_PROT_CODE # ifdef WRITE_XOR_EXECUTE_CODE # define S_PROT_CODE (PROT_WRITE | PROT_READ) diff --git a/racket/src/ChezScheme/configure b/racket/src/ChezScheme/configure index 850de1ec696..577d6cdf383 100755 --- a/racket/src/ChezScheme/configure +++ b/racket/src/ChezScheme/configure @@ -41,6 +41,7 @@ machs=$machs$sep2$last m="" w="" pb=no +pbarch=no threads=yes nothreads=no libffi=no @@ -84,6 +85,7 @@ Kernel=KernelLib installkerneltarget=installkernellib installzlibtarget=installzlib installlz4target=installlz4 +pbendian=l # On WSL, set OS to "Windows_NT" to create a Windows # build instead of a Linux (on Windows) build: @@ -135,6 +137,7 @@ case "${CONFIG_UNAME}" in elif uname -a | egrep 'Power' > /dev/null 2>&1 ; then m64=ppc32osx tm64=tppc32osx + pbendian=b default_warning_flags="" fi installprefix=/usr/local @@ -172,6 +175,7 @@ if [ "$unixsuffix" != "" ] ; then elif uname -a | egrep 'power|ppc' > /dev/null 2>&1 ; then m32=ppc32${unixsuffix} tm32=tppc32${unixsuffix} + pbendian=b elif uname -a | egrep 'armv|aarch64' > /dev/null 2>&1 ; then m32=arm32${unixsuffix} m64=arm64${unixsuffix} @@ -206,6 +210,9 @@ while [ $# != 0 ] ; do --pb) pb=yes ;; + --pbarch) + pbarch=yes + ;; --installprefix=*) installprefix=`echo $1 | sed -e 's/^--installprefix=//'` ;; @@ -343,19 +350,18 @@ while [ $# != 0 ] ; do shift done -if [ "$m" = "pb" ] ; then - echo "Don't select pb using -m or --machine, because pb needs the" - echo " machine as the kernel host machine. Instead, use --pb to select" - echo " a pb (portable bytecode) build." - exit 1 +if [ $pbarch = yes ] ; then + pb=yes fi -if [ "$m" = "tpb" ] ; then - echo "Don't select tpb using -m or --machine, because tpb needs the" - echo " machine as the kernel host machine. Instead, use --pb plus" - echo " --threads to select a tpb (threaded portable bytecode) build." - exit 1 -fi +case "$m" in + *pb*) + echo "Don't select pb using -m or --machine, because pb needs the" + echo " machine as the kernel host machine. Instead, use --pb or --pbarch" + echo " to select a pb (portable bytecode) build." + exit 1 + ;; +esac if [ "$bits" = "" ] ; then if uname -a | egrep 'amd64|x86_64|aarch64|arm64|ppc64|powerpc64' > /dev/null 2>&1 ; then @@ -366,11 +372,15 @@ if [ "$bits" = "" ] ; then fi if [ "$threads" = "" ] ; then - if [ "$pb" = "yes" ] ; then - threads=no - else - threads=yes - fi + if [ "$pb" = "yes" ] ; then + if [ "$pbarch" = "yes" ] ; then + threads=yes + else + threads=no + fi + else + threads=yes + fi fi if [ $bits = 64 ] ; then @@ -383,12 +393,13 @@ if [ "$m" = "" ] ; then machine_supplied=no if [ $pb = yes ] ; then m=pb + if [ $threads = yes ] ; then m=t$m ; fi if [ $bits = 64 ] ; then mpbhost=$m64 ; else mpbhost=$m32 ; fi flagsm=$mpbhost if [ "$mpbhost" = "" ] ; then echo "Could not infer current machine type." echo "" - echo "Event for a pb build, a machine type is needed to select C compiler" + echo "Even for a pb build, a machine type is needed to select C compiler" echo "and linker flags. You can use" echo " $0 --pb -m=" echo "to specify the available machine type, but since it wasn't inferred," @@ -407,10 +418,11 @@ else flagsm=$m fi -if [ $threads = yes ] ; then - if [ $m = pb ] ; then - m=tpb - fi +if [ $pbarch = yes ] ; then + m=pb$bits$pbendian + if [ $threads = yes ] ; then + m=t$m + fi fi if [ "$w" = "" ] ; then @@ -441,6 +453,7 @@ if [ "$help" = "yes" ]; then echo " --nothreads specify non-threaded version ($nothreads)" echo " --32|--64 specify 32/64-bit version ($bits)" echo " --pb specify pb (portable bytecode) version" + echo " --pbarch specify pb with host word and endianness" echo " --disable-x11 disable X11 support" echo " --disable-curses disable [n]curses support" echo " --disable-iconv disable iconv support" @@ -568,7 +581,7 @@ fi # architecture-specific for Mf-unix case "${muni}" in - pb) + pb*) Cpu=PORTABLE_BYTECODE mdarchsrc=pb ;; diff --git a/racket/src/ChezScheme/csug/system.stex b/racket/src/ChezScheme/csug/system.stex index 7a13a7599ba..d6577d68781 100644 --- a/racket/src/ChezScheme/csug/system.stex +++ b/racket/src/ChezScheme/csug/system.stex @@ -1786,6 +1786,7 @@ as part of a binary-only package. \listlibraries \endentryheader +\noindent This parameter can be set to \scheme{#f} or to a symbol. The realm of a procedure (or, more precisely, a procedure's code object) is accessible though the inspector. @@ -1797,11 +1798,34 @@ accessible though the inspector. \listlibraries \endentryheader +\noindent Converts a compiled file to one that may load more quickly, especially in the case of a boot file. The converted file is a boot file if \var{base-boots} is a list of strings, otherwise \var{base-boots} must be \scheme{#f} to create a non-boot file. +%---------------------------------------------------------------------------- +\entryheader +\formdef{pbchunk-convert-file}{\categoryprocedure}{(pbchunk-convert-file \var{in-path} \var{out-path} \var{c-paths} \var{c-names} \var{start-index})} +\returns ending index as a nonnegative exact integer +\listlibraries +\endentryheader + +\noindent +Converts a compiled file \var{in-path} for a \scheme{pb} machine +variant to a compiled file \var{out-path} that uses C chunk +functions written to the files in \var{c-paths}, where \var{c-paths} +is a nonempty list of file names. Chunk code is distributed across the +files to avoid making a single, over-large source C file. The +\var{c-names} list provides a list of function names, one for each +output file in \var{c-paths}, where each function name is defined as a +function of no arguments to register the file's chunks with the +system. This registration must be performed before the converted +cmopiled code is run. Every set of chunks registered in this way must +use a distinct index range, where \var{start-index} provides the +starting index for this set, and the result value is one more than the +index of the last chunk written to the \var{c-paths} sources. + %---------------------------------------------------------------------------- \entryheader diff --git a/racket/src/ChezScheme/makefiles/Mf-install.in b/racket/src/ChezScheme/makefiles/Mf-install.in index 9f354f8e707..189aefa8294 100644 --- a/racket/src/ChezScheme/makefiles/Mf-install.in +++ b/racket/src/ChezScheme/makefiles/Mf-install.in @@ -62,7 +62,7 @@ InstallLZ4Target= # no changes should be needed below this point # ############################################################################### -Version=csv9.5.7.5 +Version=csv9.5.7.6 Include=boot/$m PetiteBoot=boot/$m/petite.boot SchemeBoot=boot/$m/scheme.boot diff --git a/racket/src/ChezScheme/rktboot/machine-def.rkt b/racket/src/ChezScheme/rktboot/machine-def.rkt index 572a4e7e263..67cb10e0bf7 100644 --- a/racket/src/ChezScheme/rktboot/machine-def.rkt +++ b/racket/src/ChezScheme/rktboot/machine-def.rkt @@ -11,8 +11,11 @@ (cond [(file-exists? (build-path* dir def)) (open-input-file (build-path* dir def))] [else - ;; synthesize a default ".def" file from "[t]unix.def" - (define def (if (regexp-match? #rx"^t" target-machine) "tunix.def" "unix.def")) + ;; synthesize a default ".def" file from "[t]unix.def" or "[t]pbarch.def" + (define def (string-append + (if (regexp-match? #rx"^t" target-machine) "t" "") + (if (regexp-match? #rx"pb" target-machine) "pbarch" "unix") + ".def")) (let* ([s (file->string (build-path* dir def))] [s (regexp-replace* #rx"[$][(]M[)]" s target-machine)] [s (regexp-replace* #rx"[$][(]March[)]" s @@ -22,7 +25,18 @@ [(regexp-match? #rx"^t?arm32" target-machine) "arm32"] [(regexp-match? #rx"^t?arm64" target-machine) "arm64"] [(regexp-match? #rx"^t?ppc32" target-machine) "ppc32"] - [else (error "machine.def: cannto infer architecture")]))]) + [(regexp-match? #rx"^t?pb" target-machine) "pb"] + [else (error "machine.def: cannot infer architecture")]))] + [s (regexp-replace* #rx"[$][(]Mend[)]" s + (cond + [(regexp-match? #rx"l$" target-machine) "little"] + [(regexp-match? #rx"b$" target-machine) "big"] + [else "?"]))] + [s (regexp-replace* #rx"[$][(]Mword[)]" s + (cond + [(regexp-match? #rx"32" target-machine) "32"] + [(regexp-match? #rx"64" target-machine) "64"] + [else "?"]))]) (open-input-string s))])] [else (open-input-file (build-path* dir filename))])) diff --git a/racket/src/ChezScheme/s/Mf-base b/racket/src/ChezScheme/s/Mf-base index cc6178c9732..db2843e6ff0 100644 --- a/racket/src/ChezScheme/s/Mf-base +++ b/racket/src/ChezScheme/s/Mf-base @@ -127,7 +127,7 @@ patch = patch patchobj = patch.patch cpnanopass.patch cpprim.patch cprep.patch cpcheck.patch\ cp0.patch cpvalid.patch cptypes.patch cpcommonize.patch cpletrec.patch\ reloc.patch\ - compile.patch fasl.patch vfasl.patch syntax.patch env.patch\ + compile.patch fasl.patch vfasl.patch pbchunk.patch syntax.patch env.patch\ read.patch interpret.patch ftype.patch strip.patch\ ubify.patch back.patch @@ -150,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 vfasl.ss reloc.ss pdhtml.ss strip.ss ftype.ss back.ss + fasl.ss vfasl.ss pbchunk.ss reloc.ss pdhtml.ss strip.ss ftype.ss back.ss baseobj = ${basesrc:%.ss=%.$m} @@ -597,6 +597,7 @@ 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 +pbchunk.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 strip-types.ss env.ss fxmap.ss cptypes-lattice.ss cpnanopass.$m cpnanopass.patch cpnanopass.so cpprim.$m cpprim.patch: nanopass.so np-languages.ss np-register.ss np-info.ss np-help.ss ${archincludes} @@ -604,6 +605,7 @@ cptypes.$m: fxmap.ss cptypes-lattice.ss 5_4.$m: ../unicode/unicode-char-cases.ss ../unicode/unicode-charinfo.ss strip.$m: strip-types.ss vfasl.$m: strip-types.ss +pbchunk.$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) diff --git a/racket/src/ChezScheme/s/cmacros.ss b/racket/src/ChezScheme/s/cmacros.ss index 8102ccb9992..1e4d1ca95f2 100644 --- a/racket/src/ChezScheme/s/cmacros.ss +++ b/racket/src/ChezScheme/s/cmacros.ss @@ -357,7 +357,7 @@ ;; --------------------------------------------------------------------- ;; Version and machine types: -(define-constant scheme-version #x09050705) +(define-constant scheme-version #x09050706) (define-syntax define-machine-types (lambda (x) @@ -376,7 +376,10 @@ (define-machine-types any pb tpb - pb32 tpb32 + pb64l tpb64l + pb64b tpb64b + pb32l tpb32l + pb32b tpb32b i3le ti3le i3nt ti3nt i3fb ti3fb @@ -413,8 +416,8 @@ (define-constant machine-type-name (cdr (assv (constant machine-type) (constant machine-type-alist)))) (define-constant fasl-endianness - (constant-case architecture - [(pb) 'little] + (constant-case native-endianness + [(unknown) 'little] ; determines generic pb fasl endianness [else (constant native-endianness)])) ;; --------------------------------------------------------------------- @@ -1627,7 +1630,7 @@ [ptr DSTBV] [ptr SRCBV] [double fpregs (constant asm-fpreg-max)] - [uptr pb-regs (constant pb-reg-count)] + [uptr pb-regs (constant pb-reg-count)] ; "pb.c" assumes that `pb-regs` through `pb-call-arena` are together [double pb-fpregs (constant pb-fpreg-count)] [uptr pb-call-arena (constant pb-call-arena-size)] [xptr gc-data])) @@ -3222,7 +3225,7 @@ ;; Some instructions have size variants, always combined ;; with register- and immediate-argument possibilties ;; -- although some combinations may be unimplemented - ;; or not make sense, such as immediate-arrgument operations + ;; or not make sense, such as immediate-argument operations ;; on double-precision floating-point numbers (define-pb-enum pb-sizes << pb-argument-types pb-int8 @@ -3329,6 +3332,7 @@ [pb-fp-call-arena-in] [pb-fp-call-arena-out] [pb-stack-call] [pb-fence pb-fences] + [pb-chunk] ; dispatch to C-implemented chunks [pb-link]) ; used by linker ;; Only foreign procedures that match specific prototypes are @@ -3363,6 +3367,7 @@ [void uptr uint32] [void int32 uptr] [void int32 int32] + [void uint32 uint32] [void uptr uptr] [void int32 void*] [void uptr void*] diff --git a/racket/src/ChezScheme/s/cptypes-lattice.ss b/racket/src/ChezScheme/s/cptypes-lattice.ss index 63b8a1e085e..da5da07d6c9 100644 --- a/racket/src/ChezScheme/s/cptypes-lattice.ss +++ b/racket/src/ChezScheme/s/cptypes-lattice.ss @@ -165,7 +165,7 @@ (define $fixmediate-pred (make-pred-or immediate-pred 'fixnum 'bottom)) (define maybe-fixnum-pred (make-pred-or false-rec 'fixnum 'bottom)) (define eof/fixnum-pred (make-pred-or eof-rec 'fixnum 'bottom)) - (define maybe-exact-integer-pred (make-pred-or false-rec 'fixnum 'bottom)) + (define maybe-exact-integer-pred (make-pred-or false-rec 'exact-integer 'bottom)) (define maybe-flonum-pred (make-pred-or false-rec 'flonum 'bottom)) (define maybe-number-pred (make-pred-or false-rec 'number 'bottom)) (define maybe-symbol-pred (make-pred-or false-rec 'symbol 'bottom)) @@ -545,9 +545,9 @@ (cond [(check-constant-eqv? x dy) y] - [(fixnum? dy) + [(target-fixnum? dy) (union/fixnum x)] - [(bignum? dy) + [(target-bignum? dy) (union/bignum x)] [(exact-integer? dy) (union/exact-integer x)] @@ -700,7 +700,7 @@ (define (intersect/fixnum x check? y) (cond - [(and check? (check-constant-is? x fixnum?)) + [(and check? (check-constant-is? x target-fixnum?)) x] [(or (eq? x 'fixnum) (eq? x 'exact-integer) @@ -712,7 +712,7 @@ (define (intersect/bignum x check? y) (cond - [(and check? (check-constant-is? x bignum?)) + [(and check? (check-constant-is? x target-bignum?)) x] [(or (eq? x 'bignum) (eq? x 'exact-integer) @@ -790,9 +790,9 @@ (cond [(check-constant-eqv? x dy) x] - [(fixnum? dy) + [(target-fixnum? dy) (intersect/fixnum x #f y)] - [(bignum? dy) + [(target-bignum? dy) (intersect/bignum x #f y)] [(exact-integer? dy) (intersect/exact-integer x #f y)] diff --git a/racket/src/ChezScheme/s/mkheader.ss b/racket/src/ChezScheme/s/mkheader.ss index a006ba11ca5..1564e0e09de 100644 --- a/racket/src/ChezScheme/s/mkheader.ss +++ b/racket/src/ChezScheme/s/mkheader.ss @@ -452,6 +452,10 @@ (export "int" "Sscheme_program" "(const char *, int, const char *[])") (export "void" "Sscheme_deinit" "(void)") (export "void" "Sscheme_register_signal_registerer" "(void (*f)(int))") + (constant-case architecture + [(pb) + (export "void" "Sregister_pbchunks" "(void **, int, int)")] + [else (void)]) (when-feature pthreads (nl) (comment "Thread support.") @@ -978,6 +982,26 @@ (print-field-disps "symbol_hashtable" (let () (include "hashtable-types.ss") (record-type-descriptor symbol-ht))) (print-field-disps "code_info" (let () (include "types.ss") (record-type-descriptor code-info)))) + (nl) + (comment "derived endianness") + (case (constant native-endianness) + [(little) + (def "native_endianness_is_little" 1) + (def "native_endianness_is_big" 0)] + [(big) + (def "native_endianness_is_little" 0) + (def "native_endianness_is_big" 1)] + [else + (def "native_endianness_is_little" 0) + (def "native_endianness_is_big" 0)]) + (case (constant fasl-endianness) + [(little) + (def "fasl_endianness_is_little" 1) + (def "fasl_endianness_is_big" 0)] + [else + (def "fasl_endianness_is_little" 0) + (def "fasl_endianness_is_big" 1)]) + (nl) (comment "predicates") (deftypep "Simmediatep" ($ mask-immediate) ($ type-immediate)) diff --git a/racket/src/ChezScheme/s/pb.def b/racket/src/ChezScheme/s/pb.def index 6d8dca02057..fd3503e9fe5 100644 --- a/racket/src/ChezScheme/s/pb.def +++ b/racket/src/ChezScheme/s/pb.def @@ -2,11 +2,7 @@ (features) (define-constant architecture 'pb) -(define-constant ptr-bits 64) - -(define-constant typedef-ptr "uint64_t") ; not "void *" -(define-constant typedef-iptr "int64_t") -(define-constant typedef-uptr "uint64_t") +(include "pbcommon64.def") (include "pbcommon.def") (include "default.def") diff --git a/racket/src/ChezScheme/s/pb.ss b/racket/src/ChezScheme/s/pb.ss index c2950f265f7..9005d8713db 100644 --- a/racket/src/ChezScheme/s/pb.ss +++ b/racket/src/ChezScheme/s/pb.ss @@ -1811,7 +1811,7 @@ (values (lambda (lvalue) `(set! ,lvalue ,%Cretval)) (list %Cretval))]))] [get-prototype - (lambda (type* must?) + (lambda (type*) (let* ([prototype (map (lambda (type) (nanopass-case (Ltype Type) type @@ -1845,14 +1845,14 @@ [(fp-fixnum) 'uptr] [(fp-u8*) 'void*] [(fp-void) 'void] - [else (if must? + [else (if (eq? (subset-mode) 'system) (sorry! who "unhandled type in prototype ~s" type) #f)])) type*)] [a (assoc prototype prototypes)]) (cond [(not a) - (when must? + (when (eq? (subset-mode) 'system) (sorry! who "unsupported prototype ~a" prototype)) #f] [else (cdr a)])))]) @@ -1860,7 +1860,7 @@ (let* ([arg-type* (info-foreign-arg-type* info)] [result-type (info-foreign-result-type info)]) (let ([prototype (and (not (adjust-active? info)) - (get-prototype (cons result-type arg-type*) #f))]) + (get-prototype (cons result-type arg-type*)))]) (cond [prototype (let-values ([(locs arg-live*) (do-args/reg arg-type*)] diff --git a/racket/src/ChezScheme/s/pbarch.def b/racket/src/ChezScheme/s/pbarch.def new file mode 100644 index 00000000000..8fd4f96ead3 --- /dev/null +++ b/racket/src/ChezScheme/s/pbarch.def @@ -0,0 +1,13 @@ +;; This template is turned into a machine-specific ".def" file +;; by the `workarea` script + +(define-constant machine-type (constant machine-type-$(M))) +(features iconv expeditor pbchunk) + +(define-constant architecture 'pb) + +(define-constant-default native-endianness '$(Mend)) + +(include "pbcommon$(Mword).def") +(include "pbcommon.def") +(include "default.def") diff --git a/racket/src/ChezScheme/s/pbchunk.ss b/racket/src/ChezScheme/s/pbchunk.ss new file mode 100644 index 00000000000..88915549e5b --- /dev/null +++ b/racket/src/ChezScheme/s/pbchunk.ss @@ -0,0 +1,1089 @@ +;; pbchunk conversion uses the fasl parser from "strip.ss"; it mutates +;; code in the parsed structure to generate references to C chunks +;; that implement a shadow version of a chunk of bytecode instructions, +;; and then the printer of "strip.ss" is used to write the updated +;; fasl content + +(if-feature pbchunk + +(let () + +(include "strip-types.ss") + +;; configuration, but `#t` is not practial for the boot files +(define one-chunklet-per-chunk? #f) + +;; state for the chunk writer: +(define-record-type chunk-info + (fields (mutable counter) + seen + code-op) + (nongenerative)) + +;; A chunklet represents a potential entry point into a code +;; object. It may have a prefix before the entry point that +;; is not generated as in C. A code object can have multiple +(define-record-type chunklet + (fields i ; code offset for this start of this chunklet + start-i ; code offset for the entry point (= end-i if there's no entry) + end-i ; code offset aftet the end of this chunklet + uses-flag? ; does the chunklet involve def-use pair of the branch flag + mode ; #f or 'continue-only, where the latter means no entry here + relocs ; list of offset + headers ; list of (cons offset size) + labels) ; list of `label`s + (nongenerative)) + +;; A label within a chunklet, especially for interior branches +(define-record-type label + (fields to ; the label offset + min-from ; earliest offset that jumps here + max-from ; latest offset that jumps here + all-from) ; all offsets that jump here + (nongenerative)) + +(define (fasl-pbchunk! who c-ofns reg-proc-names start-index entry* handle-entry finish-fasl-update) + ;; first print everything to a string port, and then we + ;; break up the string port into separate files + (let-values ([(0-op get) (open-string-output-port)]) + (let* ([seen-table (make-eq-hashtable)] + [end-index + (let loop ([entry* entry*] [index start-index]) + (cond + [(null? entry*) + index] + [else + (handle-entry + (car entry*) + (lambda (write-k) + (loop (cdr entry*) index)) + (lambda (situation x) + (loop (cdr entry*) + (search-pbchunk! x 0-op index seen-table))))]))] + [per-file (fxquotient (fx+ (fx- end-index start-index) + (fx- (length c-ofns) 1)) + (length c-ofns))] + [ip (open-string-input-port (get))]) + ;; before continuing, write out updated fasl: + (finish-fasl-update) + (let () + ;; at this point, chunks are in in `0-op`/`ip`, so extract lines and + ;; farm them out to the destination files; + ;; start by opening all the destinations: + (define (call-with-all-files k) + (let p-loop ([todo-c-ofns c-ofns] + [rev-c-ops '()]) + (cond + [(pair? todo-c-ofns) + (let* ([c-ofn (car todo-c-ofns)] + [c-op ($open-file-output-port who c-ofn (file-options replace) + (buffer-mode block) + (native-transcoder))]) + (on-reset + (delete-file c-ofn #f) + (on-reset + (close-port c-op) + (fprintf c-op "#include \"system.h\"\n") + (fprintf c-op "#include \n") + (fprintf c-op "#include \"pb.h\"\n") + (p-loop (cdr todo-c-ofns) (cons c-op rev-c-ops)))))] + [else (k (reverse rev-c-ops))]))) + ;; helper to write out chunk registration: + (define (write-registration c-op reg-proc-name start-index index) + (newline c-op) + (fprintf c-op "static void *~a_chunks[~a] = {\n" reg-proc-name (fx- index start-index)) + (let loop ([i start-index]) + (unless (fx= i index) + (fprintf c-op " chunk_~a~a\n" + i + (if (fx= (fx+ i 1) index) "" ",")) + (loop (fx+ i 1)))) + (fprintf c-op "};\n\n") + (fprintf c-op "void ~a() {\n" reg-proc-name) + (fprintf c-op " Sregister_pbchunks(~a_chunks, ~a, ~a);\n" + reg-proc-name start-index index) + (fprintf c-op "}\n")) + ;; helper to recognize chunk starts: + (define (chunk-start-line? line) + (let ([chunk-start-str "static uptr chunk_"]) + (and (fx> (string-length line) (string-length chunk-start-str)) + (let loop ([i 0]) + (or (fx= i (string-length chunk-start-str)) + (and (eqv? (string-ref line i) + (string-ref chunk-start-str i)) + (loop (fx+ i 1)))))))) + ;; now loop to read lines and redirect: + (call-with-all-files + (lambda (c-ops) + (let c-loop ([c-ops c-ops] + [reg-proc-names reg-proc-names] + [index start-index] + [line (get-line ip)]) + (unless (null? c-ops) + (let ([c-op (car c-ops)]) + (let chunk-loop ([fuel per-file] [n 0] [line line]) + (cond + [(or (eof-object? line) + (and (fxzero? fuel) + (chunk-start-line? line))) + (write-registration c-op (car reg-proc-names) index (fx+ index n)) + (close-port c-op) + (c-loop (cdr c-ops) + (cdr reg-proc-names) + (fx+ index n) + line)] + [else + (put-string c-op line) + (newline c-op) + (let ([next-line (get-line ip)]) + (cond + [(chunk-start-line? line) + (chunk-loop (fx- fuel 1) (fx+ n 1) next-line)] + [else + (chunk-loop fuel n next-line)]))]))))))) + ;; fies written; return index after last chunk + end-index)))) + +;; The main pbchunk handler: takes a fasl object in "strip.ss" form, +;; find code objects inside, and potentially generates chunks and updates +;; the code object with references to chunks. Takes the number of +;; chunks previously written and returns the total number written after. +(define (search-pbchunk! v code-op start-index seen-table) + (let ([ci (make-chunk-info start-index + seen-table + code-op)]) + (chunk! v ci) + (chunk-info-counter ci))) + +(define (chunk! v ci) + (unless (eq-hashtable-ref (chunk-info-seen ci) v #f) + (eq-hashtable-set! (chunk-info-seen ci) v #t) + (do-chunk! v ci))) + +(define (chunk-vector! vec ci) + (vector-for-each (lambda (e) (chunk! e ci)) vec)) + +(define (do-chunk! v ci) + (fasl-case* v + [(pair vec) + (chunk-vector! vec ci)] + [(tuple ty vec) + (constant-case* ty + [(fasl-type-box fasl-type-immutable-box) + (chunk! (vector-ref vec 0) ci)] + [(fasl-type-weak-pair) + ($oops 'chunk "weak pair not supported")] + [(fasl-type-ephemeron) + ($oops 'chunk "ephemeron pair not supported")] + [else (void)])] + [(vector ty vec) + (constant-case* ty + [(fasl-type-vector fasl-type-immutable-vector) + (chunk-vector! vec ci)] + [else (void)])] + [(stencil-vector mask vec) + (chunk-vector! vec ci)] + [(record maybe-uid size nflds rtd pad-ty* fld*) + (for-each (lambda (fld) + (field-case fld [ptr (elem) (chunk! elem ci)] [else (void)])) + fld*)] + [(closure offset c) + (chunk! c ci)] + [(code flags free name arity-mask info pinfo* bytes m vreloc) + (chunk-code! name bytes vreloc ci) + (chunk-vector! vreloc ci)] + [(reloc type-etc code-offset item-offset elem) + (chunk! elem ci)] + [(symbol-hashtable mutable? minlen subtype veclen vpfasl) + (vector-for-each (lambda (p) + (chunk! (car p) ci) + (chunk! (cdr p) ci)) + vpfasl)] + [(indirect g i) (chunk! (vector-ref g i) ci)] + [else + ;; nothing else contains references that can reach code + (void)])) + +(define min-chunk-len 3) +(define instr-bytes 4) +(define reloc-instrs 4) + +(define (instr-op instr) (bitwise-and instr #xFF)) + +(define (instr-d-dest instr) (bitwise-and (bitwise-arithmetic-shift-right instr 8) #xF)) + +(define (instr-dr-dest instr) (instr-d-dest instr)) +(define (instr-dr-reg instr) (bitwise-and (bitwise-arithmetic-shift-right instr 16) #xF)) + +(define (instr-di-dest instr) (instr-d-dest instr)) +(define (instr-di-imm instr) (bitwise-arithmetic-shift-right instr 16)) +(define (instr-di-imm/unsigned instr) (bitwise-and (bitwise-arithmetic-shift-right instr 16) #xFFFFFF)) + +(define (instr-adr-dest instr) (instr-di-dest instr)) +(define (instr-adr-imm instr) (bitwise-arithmetic-shift-right instr 12)) + +(define (instr-drr-dest instr) (instr-d-dest instr)) +(define (instr-drr-reg1 instr) (bitwise-and (bitwise-arithmetic-shift-right instr 12) #xF)) +(define (instr-drr-reg2 instr) (bitwise-and (bitwise-arithmetic-shift-right instr 16) #xF)) + +(define (instr-dri-dest instr) (instr-d-dest instr)) +(define (instr-dri-reg1 instr) (bitwise-and (bitwise-arithmetic-shift-right instr 12) #xF)) +(define (instr-dri-imm instr) (bitwise-arithmetic-shift-right instr 16)) + +(define (instr-i-imm instr) (bitwise-arithmetic-shift-right instr 8)) + +(define (make-chunk-instr index sub-index) + (unless (eqv? index (bitwise-and index #xFFFF)) + ($oops 'pbchunk "chunk index ~a is too large" index)) + (unless (eqv? sub-index (bitwise-and sub-index #xFF)) + ($oops 'pbchunk "chunk sub-index ~a is too large" sub-index)) + (bitwise-ior (constant pb-chunk) + (bitwise-arithmetic-shift-left sub-index 8) + (bitwise-arithmetic-shift-left index 16))) +(define MAX-SUB-INDEXES 256) + +;; expands to a binary search for the right case +(define-syntax (instruction-case stx) + (syntax-case stx () + [(_ instr emit [op . shape] ...) + (let ([vec (make-vector 256 0)] + [emits (list->vector #'(($oops 'chunk "unrecognized instruction ~s" instr) + (emit op . shape) ...))]) + (let loop ([ops (datum (op ...))] [pos 1]) + (unless (null? ops) + (vector-set! vec (lookup-constant (car ops)) pos) + (loop (cdr ops) (fx+ pos 1)))) + #`(let ([pos (vector-ref '#,vec (instr-op instr))]) + #,(let loop ([start 0] [end (vector-length emits)]) + (cond + [(fx= (fx+ start 1) end) + (vector-ref emits start)] + [else + (let ([mid (quotient (+ start end) 2)]) + #`(if (fx>= pos #,mid) + #,(loop mid end) + #,(loop start mid)))]))))])) + +;; di = destination register and immediate +;; dr = destination register and immediate +;; etc. +;; .../x = not handled, so return to interpret +;; .../u = unsigned immediate +;; .../f = sets flag +;; .../b = branch, uses flag deending on branch kind +;; .../c = foreign call +(define-syntax (instruction-cases stx) + (syntax-case stx () + [(_ instr emit) + #'(instruction-case + instr emit + ;; every instruction implemented in "pb.c" needs to be here, + ;; except for the `pb-chunk` instruction + [pb-mov16-pb-zero-bits-pb-shift0 di/u] + [pb-mov16-pb-zero-bits-pb-shift1 di/u] + [pb-mov16-pb-zero-bits-pb-shift2 di/u] + [pb-mov16-pb-zero-bits-pb-shift3 di/u] + [pb-mov16-pb-keep-bits-pb-shift0 di/u] + [pb-mov16-pb-keep-bits-pb-shift1 di/u] + [pb-mov16-pb-keep-bits-pb-shift2 di/u] + [pb-mov16-pb-keep-bits-pb-shift3 di/u] + [pb-mov-pb-i->i dr] + [pb-mov-pb-d->d dr] + [pb-mov-pb-i->d dr] + [pb-mov-pb-d->i dr] + [pb-mov-pb-s->d dr] + [pb-mov-pb-d->s dr] + [pb-mov-pb-d->s->d dr] + [pb-mov-pb-i-bits->d-bits dr] + [pb-mov-pb-d-bits->i-bits dr] + [pb-mov-pb-i-i-bits->d-bits dr] + [pb-mov-pb-d-lo-bits->i-bits dr] + [pb-mov-pb-d-hi-bits->i-bits dr] + [pb-bin-op-pb-no-signal-pb-add-pb-register drr] + [pb-bin-op-pb-no-signal-pb-add-pb-immediate dri] + [pb-bin-op-pb-no-signal-pb-sub-pb-register drr] + [pb-bin-op-pb-no-signal-pb-sub-pb-immediate dri] + [pb-bin-op-pb-no-signal-pb-mul-pb-register drr] + [pb-bin-op-pb-no-signal-pb-mul-pb-immediate dri] + [pb-bin-op-pb-no-signal-pb-div-pb-register drr] + [pb-bin-op-pb-no-signal-pb-div-pb-immediate dri] + [pb-bin-op-pb-no-signal-pb-and-pb-register drr] + [pb-bin-op-pb-no-signal-pb-and-pb-immediate dri] + [pb-bin-op-pb-no-signal-pb-ior-pb-register drr] + [pb-bin-op-pb-no-signal-pb-ior-pb-immediate dri] + [pb-bin-op-pb-no-signal-pb-xor-pb-register drr] + [pb-bin-op-pb-no-signal-pb-xor-pb-immediate dri] + [pb-bin-op-pb-no-signal-pb-lsl-pb-register drr] + [pb-bin-op-pb-no-signal-pb-lsl-pb-immediate dri] + [pb-bin-op-pb-no-signal-pb-lsr-pb-register drr] + [pb-bin-op-pb-no-signal-pb-lsr-pb-immediate dri] + [pb-bin-op-pb-no-signal-pb-asr-pb-register drr] + [pb-bin-op-pb-no-signal-pb-asr-pb-immediate dri] + [pb-bin-op-pb-no-signal-pb-lslo-pb-register drr] + [pb-bin-op-pb-no-signal-pb-lslo-pb-immediate dri] + [pb-bin-op-pb-signal-pb-add-pb-register drr/f] + [pb-bin-op-pb-signal-pb-add-pb-immediate dri/f] + [pb-bin-op-pb-signal-pb-sub-pb-register drr/f] + [pb-bin-op-pb-signal-pb-sub-pb-immediate dri/f] + [pb-bin-op-pb-signal-pb-mul-pb-register drr/f] + [pb-bin-op-pb-signal-pb-mul-pb-immediate dri/f] + [pb-bin-op-pb-signal-pb-subz-pb-register drr/f] + [pb-bin-op-pb-signal-pb-subz-pb-immediate dri/f] + [pb-bin-op-pb-signal-pb-subp-pb-register drr/f] + [pb-bin-op-pb-signal-pb-subp-pb-immediate dri/f] + [pb-cmp-op-pb-eq-pb-register dr/f] + [pb-cmp-op-pb-eq-pb-immediate di/f] + [pb-cmp-op-pb-lt-pb-register dr/f] + [pb-cmp-op-pb-lt-pb-immediate di/f] + [pb-cmp-op-pb-gt-pb-register dr/f] + [pb-cmp-op-pb-gt-pb-immediate di/f] + [pb-cmp-op-pb-le-pb-register dr/f] + [pb-cmp-op-pb-le-pb-immediate di/f] + [pb-cmp-op-pb-ge-pb-register dr/f] + [pb-cmp-op-pb-ge-pb-immediate di/f] + [pb-cmp-op-pb-ab-pb-register dr/f] + [pb-cmp-op-pb-ab-pb-immediate di/f] + [pb-cmp-op-pb-bl-pb-register dr/f] + [pb-cmp-op-pb-bl-pb-immediate di/f] + [pb-cmp-op-pb-cs-pb-register dr/f] + [pb-cmp-op-pb-cs-pb-immediate di/f] + [pb-cmp-op-pb-cc-pb-register dr/f] + [pb-cmp-op-pb-cc-pb-immediate di/f] + [pb-fp-bin-op-pb-add-pb-register drr] + [pb-fp-bin-op-pb-sub-pb-register drr] + [pb-fp-bin-op-pb-mul-pb-register drr] + [pb-fp-bin-op-pb-div-pb-register drr] + [pb-un-op-pb-not-pb-register dr] + [pb-un-op-pb-not-pb-immediate di] + [pb-fp-un-op-pb-sqrt-pb-register dr] + [pb-fp-cmp-op-pb-eq-pb-register dr/f] + [pb-fp-cmp-op-pb-lt-pb-register dr/f] + [pb-fp-cmp-op-pb-le-pb-register dr/f] + [pb-rev-op-pb-int16-pb-register dr] + [pb-rev-op-pb-uint16-pb-register dr] + [pb-rev-op-pb-int32-pb-register dr] + [pb-rev-op-pb-uint32-pb-register dr] + [pb-rev-op-pb-int64-pb-register dr] + [pb-ld-op-pb-int8-pb-register drr] + [pb-ld-op-pb-int8-pb-immediate dri] + [pb-ld-op-pb-uint8-pb-register drr] + [pb-ld-op-pb-uint8-pb-immediate dri] + [pb-ld-op-pb-int16-pb-register drr] + [pb-ld-op-pb-int16-pb-immediate dri] + [pb-ld-op-pb-uint16-pb-register drr] + [pb-ld-op-pb-uint16-pb-immediate dri] + [pb-ld-op-pb-int32-pb-register drr] + [pb-ld-op-pb-int32-pb-immediate dri] + [pb-ld-op-pb-uint32-pb-register drr] + [pb-ld-op-pb-uint32-pb-immediate dri] + [pb-ld-op-pb-int64-pb-register drr] + [pb-ld-op-pb-int64-pb-immediate dri] + [pb-ld-op-pb-double-pb-register drr] + [pb-ld-op-pb-double-pb-immediate dri] + [pb-ld-op-pb-single-pb-register drr] + [pb-ld-op-pb-single-pb-immediate dri] + [pb-st-op-pb-int8-pb-register drr] + [pb-st-op-pb-int8-pb-immediate dri] + [pb-st-op-pb-int16-pb-register drr] + [pb-st-op-pb-int16-pb-immediate dri] + [pb-st-op-pb-int32-pb-register drr] + [pb-st-op-pb-int32-pb-immediate dri] + [pb-st-op-pb-int64-pb-register drr] + [pb-st-op-pb-int64-pb-immediate dri] + [pb-st-op-pb-double-pb-register drr] + [pb-st-op-pb-double-pb-immediate dri] + [pb-st-op-pb-single-pb-register drr] + [pb-st-op-pb-single-pb-immediate dri] + [pb-b-op-pb-fals-pb-register r/b "if (!flag) "] + [pb-b-op-pb-fals-pb-immediate i/b "if (!flag) "] + [pb-b-op-pb-true-pb-register r/b "if (flag) "] + [pb-b-op-pb-true-pb-immediate i/b "if (flag) "] + [pb-b-op-pb-always-pb-register r/b ""] + [pb-b-op-pb-always-pb-immediate i/b ""] + [pb-b*-op-pb-register dr/b] + [pb-b*-op-pb-immediate di/b] + [pb-return n/x] + [pb-adr adr] + [pb-interp r/x] + [pb-call dri/c] + [pb-inc-pb-register dr/f] + [pb-inc-pb-immediate di/f] + [pb-lock r/f] + [pb-cas drr/f] + [pb-fence-pb-fence-store-store n] + [pb-fence-pb-fence-acquire n] + [pb-fence-pb-fence-release n] + [pb-call-arena-in n] + [pb-fp-call-arena-in n] + [pb-call-arena-out n] + [pb-fp-call-arena-out n] + [pb-stack-call dr])])) + +(define (advance l sel i) + (let loop ([l l]) + (cond + [(null? l) '()] + [(fx>= (sel (car l)) i) l] + [else (loop (cdr l))]))) + +(define (advance-relocs relocs i) + (advance relocs values i)) + +(define (advance-headers headers i) + (advance headers car i)) + +(define (advance-labels labels i) + (advance labels label-to i)) + +(define (ensure-label i labels) + (cond + [(and (pair? labels) + (fx= i (label-to (car labels)) i)) + (let ([l (car labels)]) + (cons (make-label i + (fxmin i (label-min-from l)) + (fxmax i (label-max-from l)) + (cons i (label-all-from l))) + (cdr labels)))] + [else + (cons (make-label i i i (list i)) + labels)])) + +(define (sort-and-combine-labels labels) + (let ([labels (sort (lambda (a b) (< (label-to a) (label-to b))) labels)]) + (let remove-dups ([labels labels]) + (cond + [(null? labels) '()] + [(null? (cdr labels)) labels] + [else + (let ([a (car labels)] + [b (cadr labels)]) + (if (fx= (label-to a) (label-to b)) + (remove-dups (cons (make-label (label-to a) + (fxmin (label-min-from a) + (label-min-from b)) + (fxmax (label-max-from a) + (label-max-from b)) + (append (label-all-from a) + (label-all-from b))) + (cddr labels))) + (cons a (remove-dups (cdr labels)))))])))) + +(define (empty-chunklet? c) + (or (fx= (chunklet-start-i c) + (chunklet-end-i c)) + (eq? 'continue-only (chunklet-mode c)))) + +;; Found a code object, maybe generate a chunk +(define (chunk-code! name bv vreloc ci) + (let ([len (bytevector-length bv)] + [o (chunk-info-code-op ci)] + [relocs (let loop ([off 0] [rels (vector->list vreloc)]) + (cond + [(null? rels) '()] + [else + (fasl-case* (car rels) + [(reloc type-etc code-offset item-offset elem) + (let ([off (+ off code-offset)]) + (cons (fx- off (constant code-data-disp)) + (loop off (cdr rels))))] + [else '()])]))] + [name (extract-name name)]) + (fprintf o "\n/* code ~a */\n" name) + (unless (equal? name "winder-dummy") ; hack to avoid special rp header in dounderflow + (let ([chunklets + ;; use `select-instruction-range` to partition the code into chunklets + (let-values ([(headers labels) (gather-targets bv len)]) + (let loop ([i 0] [relocs relocs] [headers headers] [labels labels]) + (cond + [(fx= i len) '()] + [else + (let-values ([(start-i end-i uses-flag? mode) + (select-instruction-range bv i len relocs headers labels)]) + (when (fx= i end-i) + ($oops 'chunk-code "failed to make progress at ~a out of ~a" i len)) + (let ([mode (if (fx< (fx- end-i start-i) + (fx* min-chunk-len instr-bytes)) + ;; the chunk would be too small to save us any time, so don't bother; + ;; a threshold greater than 1 also avoids code that wouldn't even + ;; use `ms` or `ip`: + 'continue-only + mode)]) + (cons (make-chunklet i start-i end-i uses-flag? mode relocs headers labels) + (loop end-i + (advance-relocs relocs end-i) + (advance-headers headers end-i) + (advance-labels labels end-i)))))])))] + [index (chunk-info-counter ci)]) + ;; We can either generate each chunklet as its own chunk + ;; function or generate one chunk function with multiple + ;; chunklets + (let ([count (fold-left (lambda (sum c) (if (empty-chunklet? c) sum (fx+ 1 sum))) + 0 + chunklets)]) + (cond + [(fx> count 256) + ;; this many chunklets suggests that compilation is not productive, + ;; so just show the disassembly + (fprintf o "/* (too many entry points) */\n") + (let ([all-chunklets chunklets]) + (let loop ([chunklets chunklets]) + (unless (null? chunklets) + (let ([c (car chunklets)]) + (emit-chunklet o bv + (chunklet-i c) 0 + (chunklet-relocs c) (chunklet-headers c) '() + (chunklet-end-i c) ; => treat as empty + (chunklet-end-i c) + all-chunklets + ;; fallthrough? + #t) + (loop (cdr chunklets))))))] + [(or one-chunklet-per-chunk? + ;; also use this more if there's 0 or 1 chunklets to emit, + ;; or more than `MAX-SUB-INDEXES`: + (let () + (or (fx< count 2) + (fx> count MAX-SUB-INDEXES)))) + (let loop ([chunklets chunklets] [index index]) + (cond + [(null? chunklets) + (chunk-info-counter-set! ci index)] + [else + (let ([c (car chunklets)]) + ;; generate a non-empty chunk as its own function + (unless (empty-chunklet? c) + (emit-chunk-header o index #f (chunklet-uses-flag? c))) + (emit-chunklet o bv + (chunklet-i c) (chunklet-start-i c) + (chunklet-relocs c) (chunklet-headers c) (chunklet-labels c) + (if (eq? 'continue-only (chunklet-mode c)) + (chunklet-end-i c) + (chunklet-start-i c)) + (chunklet-end-i c) + (list c) ; `goto` branches contrained to this chunklet + ;; fallthrough? + (empty-chunklet? c)) + (unless (empty-chunklet? c) + (emit-chunk-footer o) + (bytevector-u32-set! bv (chunklet-start-i c) (make-chunk-instr index 0) (endianness little))) + (loop (cdr chunklets) (if (empty-chunklet? c) index (fx+ index 1))))]))] + [else + ;; one chunk for the whole code object, where multiple entry points are + ;; supported by a sub-index + (emit-chunk-header o index #t (ormap chunklet-uses-flag? chunklets)) + (chunk-info-counter-set! ci (fx+ 1 index)) + ;; dispatch to label on entry via sub-index + (fprintf o " switch (sub_index) {\n") + ;; dispatch to a chunklet + (let loop ([chunklets chunklets] [sub-index 0]) + (unless (null? chunklets) + (let ([c (car chunklets)]) + (cond + [(empty-chunklet? c) (loop (cdr chunklets) sub-index)] + [else + (fprintf o " case ~a:~a ip -= 0x~x; goto label_~x;\n" + sub-index + (if (andmap empty-chunklet? (cdr chunklets)) + " default:" + "") + (chunklet-start-i c) + (chunklet-start-i c)) + (loop (cdr chunklets) (fx+ 1 sub-index))])))) + (fprintf o " }\n") + (let ([all-chunklets chunklets]) + (let loop ([chunklets chunklets] [sub-index 0]) + (unless (null? chunklets) + (let ([c (car chunklets)]) + ;; emit a chunklet within the function + (emit-chunklet o bv + (chunklet-i c) 0 + (chunklet-relocs c) (chunklet-headers c) + (if (empty-chunklet? c) + (chunklet-labels c) + (ensure-label (chunklet-start-i c) (chunklet-labels c))) + (chunklet-start-i c) (chunklet-end-i c) + all-chunklets ; `goto` branches allowed across chunklets + ;; fallthrough? + (and (pair? (cdr chunklets)) + (fx= (chunklet-end-i c) + (chunklet-start-i (cadr chunklets))))) + (unless (empty-chunklet? c) + (bytevector-u32-set! bv (chunklet-start-i c) (make-chunk-instr index sub-index) (endianness little))) + (loop (cdr chunklets) (if (empty-chunklet? c) sub-index (fx+ 1 sub-index))))))) + (emit-chunk-footer o)])))))) + +;; Find all branch targets in the code object +(define (gather-targets bv len) + (let loop ([i 0] [headers '()] [labels '()]) + (cond + [(fx= i len) (values '() (sort-and-combine-labels labels))] + [(and (pair? headers) + (fx= i (caar headers))) + (let ([size (cdar headers)]) + (let ([i (+ i size)]) + (let-values ([(rest-headers labels) (loop i (cdr headers) labels)]) + (values (cons (car headers) rest-headers) + labels))))] + [else + (let ([instr (bytevector-s32-ref bv i (endianness little))] + [uinstr (bytevector-u32-ref bv i (endianness little))]) + (define (next) + (loop (fx+ i instr-bytes) headers labels)) + + (define (next/add-label new-label) + (loop (fx+ i instr-bytes) headers (cons new-label labels))) + + (define (next/adr) + (let ([delta (fx* instr-bytes (instr-adr-imm instr))]) + (cond + [(> delta 0) + (let* ([after (fx+ i instr-bytes delta)] + [size (if (fx= 1 (fxand 1 (bytevector-u8-ref bv (fx- after 8)))) + (constant size-rp-compact-header) + (constant size-rp-header))] + [start (fx- after size)] + [header (cons start size)]) + (loop (fx+ i instr-bytes) + ;; insert keeping headers sorted + (let loop ([headers headers]) + (cond + [(null? headers) (list header)] + [(fx<= start (caar headers)) (cons header headers)] + [else (cons (car headers) (loop (cdr headers)))])) + labels))] + [else (next)]))) + + (define (next-branch) + (let* ([delta (instr-i-imm instr)] + [target-label (fx+ i instr-bytes delta)]) + (next/add-label (make-label target-label i i (list i))))) + + (define-syntax (dispatch stx) + (syntax-case stx (i/b adr) + [(_ op i/b test) #'(next-branch)] + [(_ op adr) #'(next/adr)] + [else #'(next)])) + + (instruction-cases instr dispatch))]))) + +;; Select next chunklet within a code object +(define (select-instruction-range bv i len relocs headers labels) + (let loop ([i i] [relocs relocs] [headers headers] [labels labels] [start-i #f] + [flag-ready? #f] [uses-flag? #f]) + (cond + [(fx= i len) (values (or start-i i) i uses-flag? #f)] + [(and (pair? headers) + (fx= i (caar headers))) + (cond + [start-i + ;; we want to start a new chunk after the header, so end this one + (values start-i i uses-flag? #f)] + [else + (let* ([size (cdar headers)] + [i (+ i size)]) + (loop i + (advance-relocs relocs i) + (cdr headers) + labels + start-i + #f + uses-flag?))])] + [(and (pair? labels) + (fx= i (label-to (car labels)))) + ;; we want to stop at this label if it's a target outside the range + ;; that we're trying to build + (cond + [(< (label-min-from (car labels)) (or start-i i)) + ;; target from jump before this chunk + (if start-i + (values start-i i uses-flag? #f) + (loop i relocs headers (cdr labels) #f #f uses-flag?))] + [(< (label-max-from (car labels)) i) + ;; always a forward jump within this chunk + (loop i relocs headers (cdr labels) start-i #f uses-flag?)] + [else + ;; some backward jump exists, but tenatively assume that + ;; it's within the chunk, then check; + ;; WARNING: this makes overall chunking not linear-time, but + ;; it's probably ok in practice + (let-values ([(maybe-start-i end-i maybe-uses-flag? mode) + (loop i relocs headers (cdr labels) start-i #f uses-flag?)]) + (cond + [(fx>= maybe-start-i i) + ;; chunk here or starts later, anyway + (values maybe-start-i end-i maybe-uses-flag? mode)] + [(fx< (label-max-from (car labels)) end-i) + ;; backward jumps stay within chunk + (values maybe-start-i end-i maybe-uses-flag? mode)] + [else + ;; not within chunk + (values start-i i uses-flag? #f)]))])] + [(and (pair? relocs) + (fx= i (car relocs))) + ;; can't start a chunk at a relocation, since the relocation + ;; bytecode can't be rewritten, but can continue through a + ;; relocation load + (let ([next-i (fx+ i (fx* reloc-instrs instr-bytes))]) + (cond + [start-i + (loop next-i (cdr relocs) headers labels start-i #f uses-flag?)] + [else + (values i next-i uses-flag? 'continue-only)]))] + [else + ;; if the instruction always has to trampoline back, then the instruction + ;; after can start a chunk to resume + (let ([instr (bytevector-s32-ref bv i (endianness little))]) + (define (check-flag) + (unless flag-ready? + ($oops 'pbchunk "branch not immediately after signal at 0x~x" i))) + (define (keep now-uses-flag?) + (when now-uses-flag? (check-flag)) + (loop (fx+ i instr-bytes) relocs headers labels (or start-i i) #f (or uses-flag? + now-uses-flag?))) + (define (keep-signalling) + (loop (fx+ i instr-bytes) relocs headers labels (or start-i i) #t uses-flag?)) + (define (stop-before) + (if start-i + (values start-i i uses-flag? #f) + (loop (fx+ i instr-bytes) relocs headers labels #f #f uses-flag?))) + (define (stop-after) + (values (or start-i i) (fx+ i instr-bytes) uses-flag? #f)) + (define-syntax (dispatch stx) + (syntax-case stx (dri/x r/x n/x r/b i/b r/f dr/b di/b + dr/f di/f drr/f dri/f) + [(_ op dri/x) #'(stop-before)] + [(_ op r/x) #'(stop-before)] + [(_ op n/x) #'(stop-before)] + [(_ op r/b "") #'(stop-after)] + [(_ op i/b "") #'(keep #f)] + [(_ op r/b . _) #'(keep #t)] + [(_ op i/b . _) #'(keep #t)] + [(_ op r/f) #'(keep-signalling)] + [(_ op dr/b) #'(stop-after)] + [(_ op di/b) #'(stop-after)] + [(_ op dr/f) #'(keep-signalling)] + [(_ op di/f) #'(keep-signalling)] + [(_ op drr/f) #'(keep-signalling)] + [(_ op dri/f) #'(keep-signalling)] + [_ #'(keep #f)])) + (instruction-cases instr dispatch))]))) + +(define (emit-chunk-header o index sub-index? uses-flag?) + (fprintf o "static uptr chunk_~a(MACHINE_STATE ms, uptr ip~a) {\n" + index + (if sub-index? ", int sub_index" "")) + (when uses-flag? + (fprintf o " int flag;\n"))) + +(define (emit-chunk-footer o) + (fprintf o "}\n")) + +;; just show decoded instructions from `i` until `start-i`, then +;; generate a chunk function from `start-i` to `end-i` +(define (emit-chunklet o bv i base-i relocs headers labels start-i end-i chunklets fallthrough?) + (define (in-chunk? target) + (ormap (lambda (c) + (and (fx>= target (chunklet-start-i c)) + (fx< target (chunklet-end-i c)))) + chunklets)) + (let loop ([i i] [relocs relocs] [headers headers] [labels labels]) + (cond + [(and (pair? headers) + (fx= i (caar headers))) + (cond + [(fx>= i start-i) + (unless (fx= i end-i) ($oops 'emit-chunk "should have ended at header ~a/~a" i end-i))] + [else + (let ([size (cdar headers)]) + (fprintf o "/* data: ~a bytes */\n" size) + (let ([i (fx+ i size)]) + (loop i + (advance-relocs relocs i) + (cdr headers) + labels)))])] + [(fx= i end-i) + (unless fallthrough? + (fprintf o " return ip+code_rel(0x~x, 0x~x);\n" base-i i))] + [(and (pair? labels) + (fx= i (label-to (car labels)))) + (when (fx>= i start-i) + (let ([a (car labels)]) + (when (ormap in-chunk? (label-all-from a)) + (fprintf o "label_~x:\n" i)))) + (loop i relocs headers (cdr labels))] + [else + (let ([instr (bytevector-s32-ref bv i (endianness little))] + [uinstr (bytevector-u32-ref bv i (endianness little))]) + (define (next) + (loop (fx+ i instr-bytes) relocs headers labels)) + + (define (done) + (next)) + + (define (pre) + (string-append + (format "/* 0x~x */ " i) + (if (>= i start-i) " " "/* "))) + (define (post) + (if (>= i start-i) " " " */ ")) + + (define (emit-do _op) + (fprintf o "~ado_~a(0x~x);~a" (pre) _op uinstr (post))) + + (define (emit-return) + (fprintf o "~areturn ip+code_rel(0x~x, 0x~x);~a" (pre) base-i i (post))) + + (define (r-form _op) + (emit-do _op) + (fprintf o "/* ~a */\n" + (instr-dr-reg instr)) + (next)) + + (define (dr-form _op) + (emit-do _op) + (fprintf o " /* r~a <- r~a */\n" + (instr-dr-dest instr) + (instr-dr-reg instr)) + (next)) + + (define (di-form _op di-imm) + (emit-do _op) + (fprintf o "/* r~a <- 0x~x */\n" + (instr-di-dest instr) + di-imm) + (next)) + + (define (drr-form _op) + (emit-do _op) + (fprintf o "/* r~a <- r~a, r~a */\n" + (instr-drr-dest instr) + (instr-drr-reg1 instr) + (instr-drr-reg2 instr)) + (next)) + + (define (dri-form _op) + (emit-do _op) + (fprintf o "/* r~a <- r~a, 0x~x */\n" + (instr-dri-dest instr) + (instr-dri-reg1 instr) + (instr-dri-imm instr)) + (next)) + + (define (n-form _op) + (emit-do _op) + (fprintf o "\n") + (next)) + + (define (call-form _op) + (emit-foreign-call o instr) + (next)) + + (define-syntax (emit stx) + (with-syntax ([_op (syntax-case stx () + [(_ op . _) + (datum->syntax #'op + (list->string + (fold-right (lambda (x rest) + (case x + [(#\-) (cons #\_ rest)] + [(#\>) rest] + [(#\*) (cons #\s rest)] + [else (cons x rest)])) + '() + (string->list (symbol->string (syntax->datum #'op))))))])]) + (syntax-case stx (di/u + di di/f dr dr/f + drr dri drr/f dri/f dri/c + dri/x r r/f r/x i r/b i/b dr/b di/b n n/x adr) + [(_ op di/u) #'(di-form '_op (instr-di-imm/unsigned instr))] + [(_ op di) #'(di-form '_op (instr-di-imm instr))] + [(_ op di/f) #'(di-form '_op (instr-di-imm instr))] + [(_ op dr) #'(dr-form '_op)] + [(_ op dr/f) #'(dr-form '_op)] + [(_ op drr) #'(drr-form '_op)] + [(_ op drr/f) #'(drr-form '_op)] + [(_ op dri) #'(dri-form '_op)] + [(_ op dri/f) #'(dri-form '_op)] + [(_ op dri/c) #'(call-form '_op)] + [(_ op dri/x) + #'(begin + (emit-return) + (fprintf o "/* ~a: r~a <- r~a, 0x~x */\n" + '_op + (instr-dri-dest instr) + (instr-dri-reg1 instr) + (instr-dri-imm instr)) + (done))] + [(_ op r) #'(r-form '_op)] + [(_ op r/f) #'(r-form '_op)] + [(_ op r/x) + #'(begin + (emit-return) + (fprintf o "/* ~a: ~a */\n" + '_op + (instr-dr-reg instr)) + (done))] + [(_ op i) + #'(begin + (emit-do '_op) + (fprintf o "/* 0x~x */\n" + (instr-i-imm instr)) + (next))] + [(_ op r/b test) + #'(begin + (fprintf o "~a~areturn regs[~a];~a/* ~a */\n" + (pre) + test + (instr-dr-reg instr) + (post) + '_op) + (if (equal? test "") + (done) + (next)))] + [(_ op i/b test) + #'(let* ([delta (instr-i-imm instr)] + [target-label (fx+ i instr-bytes delta)]) + (cond + [(in-chunk? target-label) + (fprintf o "~a~agoto label_~x;~a/* ~a: 0x~x */\n" + (pre) + test + target-label + (post) + '_op + delta) + (next)] + [else + (fprintf o "~a~areturn ip+code_rel(0x~x, 0x~x);~a/* ~a: 0x~x */\n" + (pre) + test + base-i + target-label + (post) + '_op + delta) + (if (equal? test "") + (done) + (next))]))] + [(_ op dr/b) + #'(begin + (fprintf o "~areturn ~a_addr(0x~x);~a/* r~a + r~a */\n" + (pre) + '_op + uinstr + (post) + (instr-dr-dest instr) + (instr-dr-reg instr)) + (done))] + [(_ op di/b) + #'(let* ([delta (instr-i-imm instr)] + [target-label (fx+ i instr-bytes delta)]) + (fprintf o "~areturn ~a_addr(0x~x);~a/* r~a + 0x~x */\n" + (pre) + '_op + uinstr + (post) + (instr-di-dest instr) + (instr-di-imm instr)) + (done))] + [(_ op n) #'(n-form '_op)] + [(_ op n/x) + #'(begin + (emit-return) + (fprintf o "/* ~a */\n" '_op) + (done))] + [(_ op adr) + #'(let ([delta (fx+ i instr-bytes (fx* instr-bytes (instr-adr-imm instr)))]) + (fprintf o "~aload_code_relative(~a, ip+code_rel(0x~x, ~a));~a\n" + (pre) + (instr-adr-dest instr) + base-i + (if (fx< delta 0) + (format "-0x~x" (fx- delta)) + (format "0x~x" delta)) + (post)) + (next))]))) + + (cond + [(and (pair? relocs) + (= i (car relocs))) + (let ([dest (instr-di-dest instr)]) + (fprintf o "~aload_from_relocation(~a, ip+code_rel(0x~x, 0x~x));~a\n" + (pre) + dest + base-i + i + (post))) + (loop (fx+ i (fx* reloc-instrs instr-bytes)) (cdr relocs) headers labels)] + [else + (instruction-cases instr emit)]))]))) + +(define (emit-foreign-call o instr) + (let* ([proto-index (instr-dri-imm instr)] + [proto (ormap (lambda (p) (and (eqv? (cdr p) proto-index) (car p))) + (constant pb-prototype-table))]) + (unless proto ($oops 'pbchunk "could not find foreign-call prototype")) + (fprintf o " ") + (case (car proto) + [(void) (void)] + [(double) (fprintf o "fpregs[Cfpretval] = ")] + [(void*) (fprintf o "regs[Cretval] = TO_PTR(")] + [else (fprintf o "regs[Cretval] = ")]) + (fprintf o "((pb~a_t)TO_VOIDP(regs[~a]))(" + (apply string-append + (map (lambda (t) + (string-append + "_" + (list->string + (fold-right (lambda (x rest) + (case x + [(#\-) (cons #\_ rest)] + [(#\*) (cons #\s rest)] + [else (cons x rest)])) + '() + (string->list (symbol->string t)))))) + proto)) + (instr-dri-dest instr)) + (let loop ([proto (cdr proto)] [int 1] [fp 1]) + (unless (null? proto) + (unless (and (fx= int 1) (fx= fp 1)) + (fprintf o ", ")) + (case (car proto) + [(double) + (fprintf o "fpregs[Cfparg~a]" fp) + (loop (cdr proto) int (fx+ fp 1))] + [(void*) + (fprintf o "TO_VOIDP(regs[Carg~a])" int) + (loop (cdr proto) (fx+ int 1) fp)] + [else + (fprintf o "regs[Carg~a]" int) + (loop (cdr proto) (fx+ int 1) fp)]))) + (case (car proto) + [(void*) (fprintf o ")")] ; close `TO_PTR` + [else (void)]) + (fprintf o "); /* pb_call ~a */\n" proto-index))) + +(define (extract-name name) + (fasl-case* name + [(string ty string) (list->string + (let loop ([l (string->list string)]) + (cond + [(null? l) '()] + [(and (eqv? #\* (car l)) + (pair? (cdr l)) + (eqv? #\/ (cadr l))) + ;; mangle to avoid "*/" in name + (cons* (car l) #\space (loop (cdr l)))] + [else (cons (car l) (loop (cdr l)))])))] + [(indirect g i) (extract-name (vector-ref g i))] + [else "???"])) + +(set! $fasl-pbchunk! fasl-pbchunk!) + +) + +;; else not `pbchunk` feature: +(set-who! $fasl-pbchunk! + (lambda args + ($oops 'pbchunk-convert-file "not supported for this machine configuration")))) diff --git a/racket/src/ChezScheme/s/pbcommon.def b/racket/src/ChezScheme/s/pbcommon.def index 4209fb5bd96..ff00c054faa 100644 --- a/racket/src/ChezScheme/s/pbcommon.def +++ b/racket/src/ChezScheme/s/pbcommon.def @@ -1,3 +1,5 @@ +(define-constant architecture 'pb) + (define-constant typedef-i8 "int8_t") (define-constant typedef-u8 "uint8_t") (define-constant typedef-i16 "int16_t") @@ -15,7 +17,7 @@ (define-constant max-float-alignment 8) (define-constant max-integer-alignment 8) -(define-constant native-endianness 'unknown) +(define-constant-default native-endianness 'unknown) (define-constant unaligned-floats #f) (define-constant unaligned-integers #f) diff --git a/racket/src/ChezScheme/s/pbcommon32.def b/racket/src/ChezScheme/s/pbcommon32.def new file mode 100644 index 00000000000..f3506b4c044 --- /dev/null +++ b/racket/src/ChezScheme/s/pbcommon32.def @@ -0,0 +1,5 @@ +(define-constant ptr-bits 32) + +(define-constant typedef-ptr "uint32_t") ; not "void *" +(define-constant typedef-iptr "int32_t") +(define-constant typedef-uptr "uint32_t") diff --git a/racket/src/ChezScheme/s/pbcommon64.def b/racket/src/ChezScheme/s/pbcommon64.def new file mode 100644 index 00000000000..b0d7e535333 --- /dev/null +++ b/racket/src/ChezScheme/s/pbcommon64.def @@ -0,0 +1,5 @@ +(define-constant-default ptr-bits 64) + +(define-constant-default typedef-ptr "uint64_t") ; not "void *" +(define-constant-default typedef-iptr "int64_t") +(define-constant-default typedef-uptr "uint64_t") diff --git a/racket/src/ChezScheme/s/primdata.ss b/racket/src/ChezScheme/s/primdata.ss index 8ff566d3b97..60c90696e2a 100644 --- a/racket/src/ChezScheme/s/primdata.ss +++ b/racket/src/ChezScheme/s/primdata.ss @@ -1571,6 +1571,7 @@ (path-parent [sig [(pathname) -> (pathname)]] [flags true #;cp02]) (path-rest [sig [(pathname) -> (pathname)]] [flags true #;cp02]) (path-root [sig [(pathname) -> (pathname)]] [flags true #;cp02]) + (pbchunk-convert-file [sig [(ptr ptr ptr ptr ufixnum) -> (ufixnum)]] [flags]) (phantom-bytevector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (phantom-bytevector-length [sig [(phantom-bytevector) -> (uptr)]] [flags true]) (port-bol? [sig [(textual-output-port) -> (boolean)]] [flags discard]) @@ -1966,6 +1967,7 @@ ($fasl-base-rtd [flags single-valued]) ($fasl-bld-graph [flags single-valued]) ($fasl-can-combine? [flags single-valued]) + ($fasl-pbchunk! [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]) diff --git a/racket/src/ChezScheme/s/strip-types.ss b/racket/src/ChezScheme/s/strip-types.ss index 094a70d79af..e0186de0a29 100644 --- a/racket/src/ChezScheme/s/strip-types.ss +++ b/racket/src/ChezScheme/s/strip-types.ss @@ -28,3 +28,26 @@ (#{iptr stripfur0zx3-2} n) (#{single stripfur0zx3-3} n) (#{double stripfur0zx3-4} high low)) + + +;; cooperates better with auto-indent than `fasl-case`: +(define-syntax (fasl-case* stx) + (syntax-case stx (else) + [(_ target [(op fld ...) body ...] ... [else e-body ...]) + #'(fasl-case target [op (fld ...) body ...] ... [else e-body ...])] + [(_ target [(op fld ...) body ...] ...) + #'(fasl-case target [op (fld ...) body ...] ...)])) + +;; reverse quoting convention compared to `constant-case`: +(define-syntax (constant-case* stx) + (syntax-case stx (else) + [(_ target [(const ...) body ...] ... [else e-body ...]) + (with-syntax ([((val ...) ...) + (map (lambda (consts) + (map (lambda (const) + (lookup-constant const)) + consts)) + (datum ((const ...) ...)))]) + #'(case target [(val ...) body ...] ... [else e-body ...]))] + [(_ target [(const ...) body ...] ...) + #'(constant-case* target [(const ...) body ...] ... [else ($oops 'constant-case* "no matching case ~s" 'target)])])) diff --git a/racket/src/ChezScheme/s/strip.ss b/racket/src/ChezScheme/s/strip.ss index cb4ceb48ba9..fd8b40d8ccd 100644 --- a/racket/src/ChezScheme/s/strip.ss +++ b/racket/src/ChezScheme/s/strip.ss @@ -898,9 +898,10 @@ (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)))))))))) + (let ([result (write script-header mode entry* op)]) + (close-port op) + (unless-feature windows (when mode (chmod ofn mode))) + result)))))))) (set-who! $describe-fasl-from-port (rec $describe-fasl-from-port (case-lambda @@ -922,6 +923,32 @@ (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! pbchunk-convert-file + (lambda (ifn ofn c-ofns reg-proc-names start-index) + (unless (string? ifn) ($oops who "~s is not a string" ifn)) + (unless (string? ofn) ($oops who "~s is not a string" ofn)) + (unless (and (pair? c-ofns) (list? c-ofns) (andmap string? c-ofns)) + ($oops who "~s is not a nonempty list of strings" c-ofns)) + (unless (and (pair? reg-proc-names) (list? reg-proc-names) (andmap string? reg-proc-names)) + ($oops who "~s is not a nonempty list of strings" reg-proc-names)) + (unless (and (fixnum? start-index) (fx>= start-index 0)) + ($oops who "~s is not a nonnegative fixnum" start-index)) + (unless (fx= (length c-ofns) (length reg-proc-names)) + ($oops who "length of file-name list ~s does not match the length of function-name list ~s" + c-ofns + reg-proc-names)) + (convert-fasl-file who ifn ofn (fasl-strip-options) + (lambda (script-header mode entry* op) + ($fasl-pbchunk! + who + c-ofns + reg-proc-names + start-index + entry* + handle-entry + (lambda () + (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) diff --git a/racket/src/ChezScheme/s/tpb.def b/racket/src/ChezScheme/s/tpb.def index a30a8b4bd5b..ee353068328 100644 --- a/racket/src/ChezScheme/s/tpb.def +++ b/racket/src/ChezScheme/s/tpb.def @@ -1,12 +1,8 @@ (define-constant machine-type (constant machine-type-tpb)) -(features iconv expeditor pthreads) +(features pthreads) (define-constant architecture 'pb) -(define-constant ptr-bits 64) - -(define-constant typedef-ptr "uint64_t") ; not "void *" -(define-constant typedef-iptr "int64_t") -(define-constant typedef-uptr "uint64_t") +(include "pbcommon64.def") (include "pbcommon.def") (include "default.def") diff --git a/racket/src/ChezScheme/s/tpbarch.def b/racket/src/ChezScheme/s/tpbarch.def new file mode 100644 index 00000000000..70fa18a87f5 --- /dev/null +++ b/racket/src/ChezScheme/s/tpbarch.def @@ -0,0 +1,13 @@ +;; This template is turned into a machine-specific ".def" file +;; by the `workarea` script + +(define-constant machine-type (constant machine-type-$(M))) +(features iconv expeditor pthreads pbchunk) + +(define-constant architecture 'pb) + +(define-constant-default native-endianness '$(Mend)) + +(include "pbcommon$(Mword).def") +(include "pbcommon.def") +(include "default.def") diff --git a/racket/src/ChezScheme/s/vfasl.ss b/racket/src/ChezScheme/s/vfasl.ss index a10093e1fa2..f4686b37e1a 100644 --- a/racket/src/ChezScheme/s/vfasl.ss +++ b/racket/src/ChezScheme/s/vfasl.ss @@ -1,41 +1,10 @@ -;; vfasl conversion uses the - +;; vfasl conversion uses the fasl parser from "strip.ss"; it creates +;; an image of the memory that fasl_in from "fasl.c" would create (let () (include "strip-types.ss") -;; cooperates better with auto-indent than `fasl-case`: -(define-syntax (fasl-case* stx) - (syntax-case stx (else) - [(_ target [(op fld ...) body ...] ... [else e-body ...]) - #'(fasl-case target [op (fld ...) body ...] ... [else e-body ...])] - [(_ target [(op fld ...) body ...] ...) - #'(fasl-case target [op (fld ...) body ...] ...)])) - -;; reverse quoting convention compared to `constant-case`: -(define-syntax (constant-case* stx) - (syntax-case stx (else) - [(_ target [(const ...) body ...] ... [else e-body ...]) - (with-syntax ([((val ...) ...) - (map (lambda (consts) - (map (lambda (const) - (lookup-constant const)) - consts)) - (datum ((const ...) ...)))]) - #'(case target [(val ...) body ...] ... [else e-body ...]))] - [(_ target [(const ...) body ...] ...) - #'(constant-case* target [(const ...) body ...] ... [else ($oops 'constant-case* "no matching case ~s" 'target)])])) - -(define-syntax (target-endianness stx) - (constant-case native-endianness - [(big) #'(quote big)] - [(little) #'(quote little)] - [(unknown) - ;; FIXME: need to know the target endianness, as - ;; opposed to the host machine's endianness at compile time - #'(native-endianness)])) - ;; ************************************************************ ;; Encode-time data structures */ @@ -109,8 +78,12 @@ #f)) ; installs-library-entry? -;; Creates a vfasl image for the fasl content `v` (as read by "strip.ss") +;; Creates a vfasl image for the fasl content `v` (as read by "strip.ss"). +;; The target endianness must be statically known. (define (to-vfasl v) + (constant-case native-endianness + [(unknown) ($oops 'vfasl "cannot vfasl with unknown endianness")] + [else (void)]) (let ([v (ensure-reference v)] [vfi (new-vfasl-info)]) ;; First pass: determine sizes @@ -360,8 +333,8 @@ (case-lambda [(bv i uptr) (constant-case ptr-bytes - [(4) (bytevector-u32-set! bv i uptr (target-endianness))] - [(8) (bytevector-u64-set! bv i uptr (target-endianness))])] + [(4) (bytevector-u32-set! bv i uptr (constant native-endianness))] + [(8) (bytevector-u64-set! bv i uptr (constant native-endianness))])] [(p delta uptr vfi) (let-values ([(bv offset) (vptr->bytevector+offset p delta vfi)]) (set-uptr! bv offset uptr))])) @@ -371,8 +344,8 @@ (case-lambda [(bv i) (constant-case ptr-bytes - [(4) (bytevector-u32-ref bv i (target-endianness))] - [(8) (bytevector-u64-ref bv i (target-endianness))])] + [(4) (bytevector-u32-ref bv i (constant native-endianness))] + [(8) (bytevector-u64-ref bv i (constant native-endianness))])] [(p delta vfi) (let-values ([(bv offset) (vptr->bytevector+offset p delta vfi)]) (ref-uptr bv offset))])) @@ -382,8 +355,8 @@ (case-lambda [(bv i uptr) (constant-case ptr-bytes - [(4) (bytevector-s32-set! bv i uptr (target-endianness))] - [(8) (bytevector-s64-set! bv i uptr (target-endianness))])] + [(4) (bytevector-s32-set! bv i uptr (constant native-endianness))] + [(8) (bytevector-s64-set! bv i uptr (constant native-endianness))])] [(p delta uptr vfi) (let-values ([(bv offset) (vptr->bytevector+offset p delta vfi)]) (set-iptr! bv offset uptr))])) @@ -392,7 +365,7 @@ (define set-double! (case-lambda [(bv i dbl) - (bytevector-ieee-double-set! bv i dbl (target-endianness))] + (bytevector-ieee-double-set! bv i dbl (constant native-endianness))] [(p delta dbl vfi) (let-values ([(bv offset) (vptr->bytevector+offset p delta vfi)]) (set-double! bv offset dbl))])) @@ -404,7 +377,7 @@ (let ([n (bitwise-ior (bitwise-arithmetic-shift-left (char->integer char) (constant char-data-offset)) (constant type-char))]) (constant-case string-char-bytes - [(4) (bytevector-u32-set! bv i n (target-endianness))]))] + [(4) (bytevector-u32-set! bv i n (constant native-endianness))]))] [(p delta char vfi) (let-values ([(bv offset) (vptr->bytevector+offset p delta vfi)]) (set-char! bv offset char))])) @@ -424,7 +397,7 @@ (case-lambda [(bv i bigit) (constant-case bigit-bytes - [(4) (bytevector-u32-set! bv i bigit (target-endianness))])] + [(4) (bytevector-u32-set! bv i bigit (constant native-endianness))])] [(p delta bigit vfi) (let-values ([(bv offset) (vptr->bytevector+offset p delta vfi)]) (set-bigit! bv offset bigit))])) diff --git a/racket/src/ChezScheme/workarea b/racket/src/ChezScheme/workarea index 22762c0247d..df031fdd7f8 100755 --- a/racket/src/ChezScheme/workarea +++ b/racket/src/ChezScheme/workarea @@ -41,7 +41,7 @@ fi Muni="" case "$M" in - pb) Mhost=$Mpbhost ;; + pb*|tpb*) Mhost=$Mpbhost ;; *) Mhost=$M ;; esac @@ -76,7 +76,16 @@ case "$Mhost" in ppc32nb) ;; ppc32osx) ;; arm64osx) ;; + pb) ;; + pb64l) ;; + pb64b) ;; + pb32l) ;; + pb32b) ;; tpb) ;; + tpb64l) ;; + tpb64b) ;; + tpb32l) ;; + tpb32b) ;; ta6fb) ;; ta6le) ;; ta6nb) ;; @@ -145,9 +154,28 @@ case "$Muni" in March=ppc32 archincludes=ppc32.ss ;; - pb) + pb*) March=pb archincludes=pb.ss + Mword=64 + case "$Muni" in + *64l) + Mword=64 + Mend=little + ;; + *64b) + Mword=64 + Mend=big + ;; + *32l) + Mword=32 + Mend=little + ;; + *32b) + Mword=32 + Mend=big + ;; + esac ;; *) March="" @@ -280,24 +308,38 @@ fi if [ -e "$srcdir"/s/$M.def ] ; then (cd $W/s; workln "$upupsrcdir"/s/$M.def $M.def) else - # synthesize generic Unix .def file + # synthesize generic Unix or pb .def file if [ -h $W/s/$M.def ] ; then rm $W/s/$M.def fi - if [ "$M" = "$Muni" ] ; then - Munix=unix + if [ "$March" = "pb" ] ; then + if [ "$M" = "$Muni" ] ; then + Mpb=pbarch + else + Mpb=tpbarch + fi + sed -e 's/$(M)/'$M'/g'\ + -e 's/$(March)/'$March'/g'\ + -e 's/$(Mword)/'$Mword'/g'\ + -e 's/$(Mend)/'$Mend'/g'\ + "$srcdir"/s/${Mpb}.def > $W/s/$M.def else - Munix=tunix + if [ "$M" = "$Muni" ] ; then + Munix=unix + else + Munix=tunix + fi + sed -e 's/$(M)/'$M'/g'\ + -e 's/$(March)/'$March'/g'\ + "$srcdir"/s/${Munix}.def > $W/s/$M.def fi - sed -e 's/$(M)/'$M'/g'\ - -e 's/$(March)/'$March'/g'\ - "$srcdir"/s/${Munix}.def > $W/s/$M.def fi (cd $W/s; forceworkln2 $M.def machine.def) if [ "$March" != "" ] ; then (cd $W/s; workln "$upupsrcdir"/s/$March.def $March.def) if [ "$March" = "pb" ] ; then (cd $W/s; workln "$upupsrcdir"/s/pbcommon.def pbcommon.def) + (cd $W/s; workln "$upupsrcdir"/s/pbcommon$Mword.def pbcommon$Mword.def) fi fi if [ "$Mos" != "" ] ; then diff --git a/racket/src/README.txt b/racket/src/README.txt index 5b63069d403..0c0d272f5fb 100644 --- a/racket/src/README.txt +++ b/racket/src/README.txt @@ -306,7 +306,8 @@ but note the following: * The Racket build creates a framework, "Racket.framework", which is installed into "racket/lib". This framework is used by the `racket` - executable that goes into "racket/bin". + executable that goes into "racket/bin" unless the `--enable-embedfw` + flag is used. * The GRacket build creates a GUI-executable variant of the Racket executable. The GRacket build process also downloads (from github) @@ -476,6 +477,25 @@ When building BC for iOS, you may need to add `--disable-cify` for inheriting the build machine's disposition. +======================================================================== + Compiling without run-time code generation +======================================================================== + +Racket programs and expressions are normally compiled to machine code +either at run time (when `eval` is used or when Racket BC JIT-compiles +bytecode) or in advance (when compiling to ".zo" files using Racket +CS). Interpreted modes are available --- but slower, of course: + + * Racket CS: configure with `--enable-pb`, which uses a bytecode + virtual machine instead of native code. By default, core functions + are compiled to some extent via C; use `--disable-pbchunk` to + disable even that compilation. + + * Racket BC: configure with `--disable-jit`, or run Racket with the + `-j` flag. On some supported platforms (such as AArch64), Racket BC + lacks JIT support and always uses interpreted mode. + + ======================================================================== Modifying Racket ======================================================================== diff --git a/racket/src/cs/c/Makefile.in b/racket/src/cs/c/Makefile.in index 4404454fbfd..5ce2ada626a 100644 --- a/racket/src/cs/c/Makefile.in +++ b/racket/src/cs/c/Makefile.in @@ -16,6 +16,7 @@ SCHEME = $(SCHEME_BIN) -B $(SCHEME_INC)/petite.boot -B $(SCHEME_INC)/scheme.boot TARGET_MACH = @TARGET_MACH@ SCHEME_TARGET_INC = $(SCHEME_WORKAREA)/$(TARGET_MACH)/boot/$(TARGET_MACH) +KERNEL_TARGET_MACH = @KERNEL_TARGET_MACH@ CC = @CC@ BASE_CFLAGS = @CFLAGS@ @CPPFLAGS@ @@ -231,8 +232,28 @@ OWN_LZ4_LIB = $(SCHEME_TARGET_INC)/../../lz4/lib/liblz4.a SCHEME_LIB_DEPS = $(SCHEME_TARGET_INC)/libkernel.a @Z_LIB_DEP@ @LZ4_LIB_DEP@ SCHEME_LIBS = $(SCHEME_TARGET_INC)/libkernel.a @Z_LIB@ @LZ4_LIB@ -BOOT_OBJ_DEPS = boot.o $(SCHEME_LIB_DEPS) rktio/librktio.a -BOOT_OBJS = boot.o $(SCHEME_LIBS) rktio/librktio.a +PETITE_BOOT_plain = $(SCHEME_TARGET_INC)/petite.boot +PETITE_BOOT_pbchunk = petite-pbchunk.boot +PETITE_BOOT_IN = $(PETITE_BOOT_@PBCHUNK_MODE@) + +SCHEME_BOOT_plain = $(SCHEME_TARGET_INC)/scheme.boot +SCHEME_BOOT_pbchunk = scheme-pbchunk.boot +SCHEME_BOOT_IN = $(SCHEME_BOOT_@PBCHUNK_MODE@) + +RACKET_BOOT_plain = racket.boot +RACKET_BOOT_pbchunk = racket-pbchunk.boot +RACKET_BOOT_IN = $(RACKET_BOOT_@PBCHUNK_MODE@) + +BOOT_EXTRA_OBJS_plain = +BOOT_EXTRA_OBJS_pbchunk = petite0.o petite1.o petite2.o petite3.o petite4.o \ + petite5.o petite6.o petite7.o petite8.o petite9.o \ + scheme0.o scheme1.o scheme2.o scheme3.o scheme4.o \ + scheme5.o scheme6.o scheme7.o scheme8.o scheme9.o \ + racket0.o racket1.o racket2.o racket3.o racket4.o \ + racket5.o racket6.o racket7.o racket8.o racket9.o + +BOOT_OBJ_DEPS = boot.o $(SCHEME_LIB_DEPS) rktio/librktio.a $(BOOT_EXTRA_OBJS_@PBCHUNK_MODE@) +BOOT_OBJS = boot.o $(SCHEME_LIBS) rktio/librktio.a $(BOOT_EXTRA_OBJS_@PBCHUNK_MODE@) raw_racketcs@NOT_OSX@: main.o boot.o $(BOOT_OBJ_DEPS) $(CC) $(CFLAGS) -o raw_racketcs main.o $(BOOT_OBJS) $(LDFLAGS) $(LIBS) $(LINK_DYNAMIC) @@ -242,14 +263,14 @@ raw_gracketcs: grmain.o boot.o $(BOOT_OBJ_DEPS) $(CC) $(CFLAGS) -o raw_gracketcs grmain.o $(BOOT_OBJS) $(LDFLAGS) $(LIBS) $(LINK_DYNAMIC) @POST_LINKER@ raw_gracketcs -petite-v.boot: $(SCHEME_TARGET_INC)/petite.boot - $(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ $(XPATCH@CROSS_MODE@) $(SCHEME_TARGET_INC)/petite.boot petite-v.boot +petite-v.boot: $(PETITE_BOOT_IN) + $(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ $(XPATCH@CROSS_MODE@) $(PETITE_BOOT_IN) petite-v.boot -scheme-v.boot: $(SCHEME_TARGET_INC)/scheme.boot - $(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ $(XPATCH@CROSS_MODE@) $(SCHEME_TARGET_INC)/scheme.boot scheme-v.boot petite +scheme-v.boot: $(SCHEME_BOOT_IN) + $(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ $(XPATCH@CROSS_MODE@) $(SCHEME_BOOT_IN) scheme-v.boot petite -racket-v.boot: racket.boot - $(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ $(XPATCH@CROSS_MODE@) racket.boot racket-v.boot petite scheme +racket-v.boot: $(RACKET_BOOT_IN) + $(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ $(XPATCH@CROSS_MODE@) $(RACKET_BOOT_IN) racket-v.boot petite scheme # ---------------------------------------- # Mac OS @@ -287,7 +308,7 @@ $(GRACKET_BIN): grmain.o $(RKTFW) $(GRAPPSKEL) $(GRAPPSKEL): $(srcdir)/../../mac/osx_appl.rkt $(srcdir)/../../version/racket_version.h $(srcdir)/../../mac/icon/GRacket.icns $(BOOTSTRAP_RACKET) $(srcdir)/../../mac/osx_appl.rkt $(srcdir)/../.. "CS" -BOOT_FILES = $(SCHEME_TARGET_INC)/petite.boot $(SCHEME_TARGET_INC)/scheme.boot racket.boot +BOOT_FILES = $(PETITE_BOOT_IN) $(SCHEME_BOOT_IN) $(RACKET_BOOT_IN) FW_BOOT_DEST = Racket.framework/Versions/$(FWVERSION)_CS/boot $(RKTFW): $(BOOT_OBJ_DEPS) $(BOOT_FILES) @@ -296,9 +317,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@ $(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 + $(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ $(XPATCH@CROSS_MODE@) $(PETITE_BOOT_IN) $(FW_BOOT_DEST)/petite.boot + $(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ $(XPATCH@CROSS_MODE@) $(SCHEME_BOOT_IN) $(FW_BOOT_DEST)/scheme.boot petite + $(SCHEME) --script $(srcdir)/to-vfasl.ss @BOOT_COMPRESS_COMP@ $(XPATCH@CROSS_MODE@) $(RACKET_BOOT_IN) $(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 @@ -351,7 +372,7 @@ raw_racketcs.exe: main.o MemoryModule.o rres.o raw_gracketcs.exe: grmain.o MemoryModule.o grres.o $(CC) $(CFLAGS) -mwindows -o raw_gracketcs.exe grmain.o MemoryModule.o grres.o $(LDFLAGS) -$(RAW_RKT_DLL): boot.o $(BOOT_OBJ_DEPS) libres.o +$(RAW_RKT_DLL): $(BOOT_OBJ_DEPS) libres.o $(CC) $(CFLAGS) --shared -o $(RAW_RKT_DLL) $(BOOT_OBJS) libres.o $(LDFLAGS) rktio/librktio.a -static-libgcc $(LIBS) MemoryModule.o: $(srcdir)/../../start/MemoryModule.c @@ -434,6 +455,9 @@ DEF_COLLECTS_DIR@MINGW@ = DEF_CONFIG_DIR@MINGW@ = DEF_C_DIRS = $(DEF_COLLECTS_DIR) $(DEF_CONFIG_DIR) +BOOT_DEFS_plain = +BOOT_DEFS_pbchunk = -DPBCHUNK_REGISTER + MAIN_DEPS = $(srcdir)/main.c $(srcdir)/boot.h cs_config.h \ $(srcdir)/../../start/config.inc \ $(srcdir)/../../start/self_exe.inc @@ -445,7 +469,7 @@ grmain.o: $(srcdir)/grmain.c $(MAIN_DEPS) $(srcdir)/../../start/gui_filter.inc $(CC) $(CFLAGS) $(DEF_C_DIRS) -c -o grmain.o $(srcdir)/grmain.c boot.o: $(srcdir)/boot.c $(srcdir)/../../rktio/rktio.inc $(srcdir)/boot.h - $(CC) $(CFLAGS) -c -o boot.o $(srcdir)/boot.c + $(CC) $(CFLAGS) $(BOOT_DEFS_@PBCHUNK_MODE@) -c -o boot.o $(srcdir)/boot.c starter@NOT_MINGW@: $(srcdir)/../../start/ustart.c $(srcdir)/../../start/self_exe.inc $(CC) $(CFLAGS) $(LDFLAGS) -o starter $(srcdir)/../../start/ustart.c @@ -466,6 +490,120 @@ libracketcs.a: $(SCHEME_LIB_DEPS) rktio/librktio.a boot.o repack-no-install-libs: $(NOOP) +# ---------------------------------------- +# pbchunk mode + +# The "to-pbchunk.ss" script generates revised boot files as well as +# petiteN.c, schemeN.c, and racketN.c, where those C files much be +# linked and "boot.c" needs to initialize them + +PBCHUNK_IN = $(PETITE_BOOT_plain) $(SCHEME_BOOT_plain) $(RACKET_BOOT_plain) + +# Using `%` in place of `.` in `PBCHUNK_OUT` makes it work as a target +# where a command produces multiple files at the same time +PBCHUNK_OUT = petite-pbchunk%boot scheme-pbchunk%boot racket-pbchunk%boot \ + petite0%c petite1%c petite2%c petite3%c petite4%c \ + petite5%c petite6%c petite7%c petite8%c petite9%c \ + scheme0%c scheme1%c scheme2%c scheme3%c scheme4%c \ + scheme5%c scheme6%c scheme7%c scheme8%c scheme9%c \ + racket0%c racket1%c racket2%c racket3%c racket4%c \ + racket5%c racket6%c racket7%c racket8%c racket9%c + +$(PBCHUNK_OUT): $(PBCHUNK_IN) + $(SCHEME) --script $(srcdir)/to-pbchunk.ss @BOOT_COMPRESS_COMP@ $(XPATCH@CROSS_MODE@) $(PBCHUNK_IN) + +PBCHUNK_CFLAGS=$(CFLAGS) -DPORTABLE_BYTECODE -I$(SCHEME_WORKAREA)/$(TARGET_MACH)/boot/$(TARGET_MACH) -I$(SCHEME_WORKAREA)/$(TARGET_MACH)/c + +petite0.o: petite0.c + $(CC) $(PBCHUNK_CFLAGS) -c -o petite0.o petite0.c + +petite1.o: petite1.c + $(CC) $(PBCHUNK_CFLAGS) -c -o petite1.o petite1.c + +petite2.o: petite2.c + $(CC) $(PBCHUNK_CFLAGS) -c -o petite2.o petite2.c + +petite3.o: petite3.c + $(CC) $(PBCHUNK_CFLAGS) -c -o petite3.o petite3.c + +petite4.o: petite4.c + $(CC) $(PBCHUNK_CFLAGS) -c -o petite4.o petite4.c + +petite5.o: petite5.c + $(CC) $(PBCHUNK_CFLAGS) -c -o petite5.o petite5.c + +petite6.o: petite6.c + $(CC) $(PBCHUNK_CFLAGS) -c -o petite6.o petite6.c + +petite7.o: petite7.c + $(CC) $(PBCHUNK_CFLAGS) -c -o petite7.o petite7.c + +petite8.o: petite8.c + $(CC) $(PBCHUNK_CFLAGS) -c -o petite8.o petite8.c + +petite9.o: petite9.c + $(CC) $(PBCHUNK_CFLAGS) -c -o petite9.o petite9.c + +scheme0.o: scheme0.c + $(CC) $(PBCHUNK_CFLAGS) -c -o scheme0.o scheme0.c + +scheme1.o: scheme1.c + $(CC) $(PBCHUNK_CFLAGS) -c -o scheme1.o scheme1.c + +scheme2.o: scheme2.c + $(CC) $(PBCHUNK_CFLAGS) -c -o scheme2.o scheme2.c + +scheme3.o: scheme3.c + $(CC) $(PBCHUNK_CFLAGS) -c -o scheme3.o scheme3.c + +scheme4.o: scheme4.c + $(CC) $(PBCHUNK_CFLAGS) -c -o scheme4.o scheme4.c + +scheme5.o: scheme5.c + $(CC) $(PBCHUNK_CFLAGS) -c -o scheme5.o scheme5.c + +scheme6.o: scheme6.c + $(CC) $(PBCHUNK_CFLAGS) -c -o scheme6.o scheme6.c + +scheme7.o: scheme7.c + $(CC) $(PBCHUNK_CFLAGS) -c -o scheme7.o scheme7.c + +scheme8.o: scheme8.c + $(CC) $(PBCHUNK_CFLAGS) -c -o scheme8.o scheme8.c + +scheme9.o: scheme9.c + $(CC) $(PBCHUNK_CFLAGS) -c -o scheme9.o scheme9.c + +racket0.o: racket0.c + $(CC) $(PBCHUNK_CFLAGS) -c -o racket0.o racket0.c + +racket1.o: racket1.c + $(CC) $(PBCHUNK_CFLAGS) -c -o racket1.o racket1.c + +racket2.o: racket2.c + $(CC) $(PBCHUNK_CFLAGS) -c -o racket2.o racket2.c + +racket3.o: racket3.c + $(CC) $(PBCHUNK_CFLAGS) -c -o racket3.o racket3.c + +racket4.o: racket4.c + $(CC) $(PBCHUNK_CFLAGS) -c -o racket4.o racket4.c + +racket5.o: racket5.c + $(CC) $(PBCHUNK_CFLAGS) -c -o racket5.o racket5.c + +racket6.o: racket6.c + $(CC) $(PBCHUNK_CFLAGS) -c -o racket6.o racket6.c + +racket7.o: racket7.c + $(CC) $(PBCHUNK_CFLAGS) -c -o racket7.o racket7.c + +racket8.o: racket8.c + $(CC) $(PBCHUNK_CFLAGS) -c -o racket8.o racket8.c + +racket9.o: racket9.c + $(CC) $(PBCHUNK_CFLAGS) -c -o racket9.o racket9.c + # ---------------------------------------- # Install @@ -533,7 +671,7 @@ common-install: SYSTEM_RKTD = $(DESTDIR)$(libpltdir)/system$(CS_INSTALLED).rktd system-install: - $(RACKET) -cu "$(srcdir)/gen-system.rkt" $(SYSTEM_RKTD) $(TARGET_MACH) @CROSS_COMPILE_TARGET_KIND@ "$(srcdir)" "@PLT_CS_SLSP_SUFFIX@" + $(RACKET) -cu "$(srcdir)/gen-system.rkt" $(SYSTEM_RKTD) $(TARGET_MACH) $(KERNEL_TARGET_MACH) @CROSS_COMPILE_TARGET_KIND@ "$(srcdir)" "@PLT_CS_SLSP_SUFFIX@" include-install: $(ICP) $(srcdir)/api.h "$(DESTDIR)$(includepltdir)/racketcs.h" diff --git a/racket/src/cs/c/boot.c b/racket/src/cs/c/boot.c index 5d7c98a7128..96ad830aa87 100644 --- a/racket/src/cs/c/boot.c +++ b/racket/src/cs/c/boot.c @@ -21,6 +21,10 @@ #include "boot.h" #include "api.h" +#ifdef PBCHUNK_REGISTER +static void register_pbchunks(); +#endif + #define RACKET_AS_BOOT #if defined(_MSC_VER) || defined(__MINGW32__) @@ -122,6 +126,10 @@ void racket_boot(racket_boot_arguments_t *ba) Sscheme_init(NULL); +#ifdef PBCHUNK_REGISTER + register_pbchunks(); +#endif + if ((ba->argc == 4) && !strcmp(ba->argv[0], "--cross-server")) cross_server = 1; @@ -233,6 +241,74 @@ void racket_boot(racket_boot_arguments_t *ba) /* **************************************** */ +#ifdef PBCHUNK_REGISTER +extern void register_petite0_pbchunks(); +extern void register_petite1_pbchunks(); +extern void register_petite2_pbchunks(); +extern void register_petite3_pbchunks(); +extern void register_petite4_pbchunks(); +extern void register_petite5_pbchunks(); +extern void register_petite6_pbchunks(); +extern void register_petite7_pbchunks(); +extern void register_petite8_pbchunks(); +extern void register_petite9_pbchunks(); +extern void register_scheme0_pbchunks(); +extern void register_scheme1_pbchunks(); +extern void register_scheme2_pbchunks(); +extern void register_scheme3_pbchunks(); +extern void register_scheme4_pbchunks(); +extern void register_scheme5_pbchunks(); +extern void register_scheme6_pbchunks(); +extern void register_scheme7_pbchunks(); +extern void register_scheme8_pbchunks(); +extern void register_scheme9_pbchunks(); +extern void register_racket0_pbchunks(); +extern void register_racket1_pbchunks(); +extern void register_racket2_pbchunks(); +extern void register_racket3_pbchunks(); +extern void register_racket4_pbchunks(); +extern void register_racket5_pbchunks(); +extern void register_racket6_pbchunks(); +extern void register_racket7_pbchunks(); +extern void register_racket8_pbchunks(); +extern void register_racket9_pbchunks(); + +static void register_pbchunks() { + register_petite0_pbchunks(); + register_petite1_pbchunks(); + register_petite2_pbchunks(); + register_petite3_pbchunks(); + register_petite4_pbchunks(); + register_petite5_pbchunks(); + register_petite6_pbchunks(); + register_petite7_pbchunks(); + register_petite8_pbchunks(); + register_petite9_pbchunks(); + register_scheme0_pbchunks(); + register_scheme1_pbchunks(); + register_scheme2_pbchunks(); + register_scheme3_pbchunks(); + register_scheme4_pbchunks(); + register_scheme5_pbchunks(); + register_scheme6_pbchunks(); + register_scheme7_pbchunks(); + register_scheme8_pbchunks(); + register_scheme9_pbchunks(); + register_racket0_pbchunks(); + register_racket1_pbchunks(); + register_racket2_pbchunks(); + register_racket3_pbchunks(); + register_racket4_pbchunks(); + register_racket5_pbchunks(); + register_racket6_pbchunks(); + register_racket7_pbchunks(); + register_racket8_pbchunks(); + register_racket9_pbchunks(); +} +#endif + +/* **************************************** */ + enum { EMBEDDED_ENTRY_APPLY, EMBEDDED_ENTRY_PRIMITIVE_LOOKUP, diff --git a/racket/src/cs/c/configure b/racket/src/cs/c/configure index 0d3e52be7f9..72b5d33cf06 100755 --- a/racket/src/cs/c/configure +++ b/racket/src/cs/c/configure @@ -628,6 +628,7 @@ INSTALL_LIBS_ENABLE INSTALL_SETUP_RACKET_FLAGS INSTALL_SETUP_FLAGS RUN_RACKET +PBCHUNK_MODE CS_HOST_WORKAREA_PREFIX CROSS_COMPILE_TARGET_KIND COMP_SUBDIR_CONFIGURE_ARGS @@ -659,6 +660,7 @@ TT_CROSS_MODE T_CROSS_MODE CROSS_MODE DIFF_MACH +KERNEL_TARGET_MACH TARGET_MACH MACH SCHEME_DIR @@ -800,6 +802,7 @@ enable_scheme enable_mach enable_target enable_pb +enable_pbchunk enable_portable enable_natipkg enable_sdk @@ -1454,6 +1457,7 @@ Optional Features: --enable-mach= use Chez Scheme machine type --enable-target= cross-build for Chez Scheme machine type --enable-pb build for platform without native-code backend + --enable-pbchunk enable C chunks for pb boot (enabled by default) --enable-portable prefer portable to host-specific --enable-natipkg add "-natipkg" to library subpath --enable-sdk= use Mac OS 10.4 SDK directory @@ -2645,6 +2649,11 @@ if test "${enable_pb+set}" = set; then : enableval=$enable_pb; fi +# Check whether --enable-pbchunk was given. +if test "${enable_pbchunk+set}" = set; then : + enableval=$enable_pbchunk; +fi + # Check whether --enable-portable was given. if test "${enable_portable+set}" = set; then : @@ -2879,6 +2888,7 @@ show_explicitly_set "${enable_scheme}" "Chez Scheme build directory" show_explicitly_set "${enable_mach}" "machine type" show_explicitly_set "${enable_target}" "cross-build machine type" show_explicitly_set "${enable_pb}" "pb machine type" +show_explicitly_disabled "${enable_pbchunk}" "pbchunk" show_explicitly_enabled "${enable_portable}" "portable" show_explicitly_enabled "${enable_natipkg}" "Adding \"-natipkg\" suffix to library subpath" @@ -3301,6 +3311,8 @@ cs_auto_flags=--disable-auto-flags COPY_NEW_CFLAGS_TO_CPPFLAGS=no +PBCHUNK_MODE=plain + ###### Autoconfigure ####### if test "${enable_ios}" != "" ; then @@ -4631,22 +4643,28 @@ fi case "$MACH_HOST_CPU" in x86_64) MACH="${thread_prefix}a6${MACH_OS}" + pb_machine_name="${thread_prefix}pb64l" ;; x86|i*86) MACH="${thread_prefix}i3${MACH_OS}" + pb_machine_name="${thread_prefix}pb32l" ;; aarch64*|arm64*) MACH="${thread_prefix}arm64${MACH_OS}" + pb_machine_name="${thread_prefix}pb64l" ;; arm*) MACH="${thread_prefix}arm32${MACH_OS}" + pb_machine_name="${thread_prefix}pb32l" ;; powerpc64*) MACH="" + pb_machine_name="${thread_prefix}pb64b" # MACH="${thread_prefix}ppc64${MACH_OS}" ;; power*) MACH="${thread_prefix}ppc32${MACH_OS}" + pb_machine_name="${thread_prefix}pb32b" ;; esac @@ -5813,10 +5831,17 @@ KERNEL_TARGET_MACH="${TARGET_MACH}" if test "${enable_pb}" = "yes" ; then enable_libffi=yes enable_foreign=yes - CONFIG_MAIN_SCHEME_MODE="--pb --threads --enable-libffi" - TARGET_MACH=tpb + CONFIG_MAIN_SCHEME_MODE="--pbarch --enable-libffi" + TARGET_MACH=${pb_machine_name} if test "${CROSS_MODE}" != "cross" ; then - MACH=tpb + MACH=${pb_machine_name} + fi + if test "${CONFIGURE_RACKET_SO_COMPILE}" = "" ; then + CONFIGURE_RACKET_SO_COMPILE="env" + fi + CONFIGURE_RACKET_SO_COMPILE="${CONFIGURE_RACKET_SO_COMPILE} PLT_CS_MACHINE_TYPE=${KERNEL_TARGET_MACH}" + if test "${enable_pbchunk}" != "no" ; then + PBCHUNK_MODE=pbchunk fi else CONFIG_MAIN_SCHEME_MODE="" @@ -6124,6 +6149,8 @@ SCHEME_CROSS_CONFIG_ARGS="--machine=${KERNEL_TARGET_MACH} --disable-x11 ${cs_aut + + diff --git a/racket/src/cs/c/configure.ac b/racket/src/cs/c/configure.ac index 727b662a2b1..65baa12b0fc 100644 --- a/racket/src/cs/c/configure.ac +++ b/racket/src/cs/c/configure.ac @@ -27,6 +27,7 @@ AC_ARG_ENABLE(scheme, [ --enable-scheme= use as host's build AC_ARG_ENABLE(mach, [ --enable-mach= use Chez Scheme machine type ]) AC_ARG_ENABLE(target, [ --enable-target= cross-build for Chez Scheme machine type ]) AC_ARG_ENABLE(pb, [ --enable-pb build for platform without native-code backend]) +AC_ARG_ENABLE(pbchunk, [ --enable-pbchunk enable C chunks for pb boot (enabled by default)]) m4_include(../ac/portable_arg.m4) m4_include(../ac/natipkg_arg.m4) m4_include(../ac/sdk_arg.m4) @@ -86,6 +87,7 @@ show_explicitly_set "${enable_scheme}" "Chez Scheme build directory" show_explicitly_set "${enable_mach}" "machine type" show_explicitly_set "${enable_target}" "cross-build machine type" show_explicitly_set "${enable_pb}" "pb machine type" +show_explicitly_disabled "${enable_pbchunk}" "pbchunk" m4_include(../ac/portable_show.m4) m4_include(../ac/natipkg_show.m4) show_explicitly_enabled "${enable_libz}" "Installed libz" @@ -182,6 +184,8 @@ cs_auto_flags=--disable-auto-flags COPY_NEW_CFLAGS_TO_CPPFLAGS=no +PBCHUNK_MODE=plain + ###### Autoconfigure ####### m4_include(../ac/sdk_ios.m4) @@ -383,22 +387,28 @@ fi case "$MACH_HOST_CPU" in x86_64) MACH="${thread_prefix}a6${MACH_OS}" + pb_machine_name="${thread_prefix}pb64l" ;; x86|i*86) MACH="${thread_prefix}i3${MACH_OS}" + pb_machine_name="${thread_prefix}pb32l" ;; aarch64*|arm64*) MACH="${thread_prefix}arm64${MACH_OS}" + pb_machine_name="${thread_prefix}pb64l" ;; arm*) MACH="${thread_prefix}arm32${MACH_OS}" + pb_machine_name="${thread_prefix}pb32l" ;; powerpc64*) MACH="" + pb_machine_name="${thread_prefix}pb64b" # MACH="${thread_prefix}ppc64${MACH_OS}" ;; power*) MACH="${thread_prefix}ppc32${MACH_OS}" + pb_machine_name="${thread_prefix}pb32b" ;; esac @@ -702,10 +712,17 @@ KERNEL_TARGET_MACH="${TARGET_MACH}" if test "${enable_pb}" = "yes" ; then enable_libffi=yes enable_foreign=yes - CONFIG_MAIN_SCHEME_MODE="--pb --threads --enable-libffi" - TARGET_MACH=tpb + CONFIG_MAIN_SCHEME_MODE="--pbarch --enable-libffi" + TARGET_MACH=${pb_machine_name} if test "${CROSS_MODE}" != "cross" ; then - MACH=tpb + MACH=${pb_machine_name} + fi + if test "${CONFIGURE_RACKET_SO_COMPILE}" = "" ; then + CONFIGURE_RACKET_SO_COMPILE="env" + fi + CONFIGURE_RACKET_SO_COMPILE="${CONFIGURE_RACKET_SO_COMPILE} PLT_CS_MACHINE_TYPE=${KERNEL_TARGET_MACH}" + if test "${enable_pbchunk}" != "no" ; then + PBCHUNK_MODE=pbchunk fi else CONFIG_MAIN_SCHEME_MODE="" @@ -850,6 +867,7 @@ AC_SUBST(BOOTFILE_RACKET) AC_SUBST(SCHEME_DIR) AC_SUBST(MACH) AC_SUBST(TARGET_MACH) +AC_SUBST(KERNEL_TARGET_MACH) AC_SUBST(DIFF_MACH) AC_SUBST(CROSS_MODE) AC_SUBST(T_CROSS_MODE) @@ -881,6 +899,7 @@ AC_SUBST(ENABLE_OR_DISABLE_WPO) AC_SUBST(COMP_SUBDIR_CONFIGURE_ARGS) AC_SUBST(CROSS_COMPILE_TARGET_KIND) AC_SUBST(CS_HOST_WORKAREA_PREFIX) +AC_SUBST(PBCHUNK_MODE) AC_SUBST(RUN_RACKET) AC_SUBST(INSTALL_SETUP_FLAGS) AC_SUBST(INSTALL_SETUP_RACKET_FLAGS) diff --git a/racket/src/cs/c/gen-system.rkt b/racket/src/cs/c/gen-system.rkt index 2bd74f6b491..bd80f5442a7 100644 --- a/racket/src/cs/c/gen-system.rkt +++ b/racket/src/cs/c/gen-system.rkt @@ -1,10 +1,11 @@ (module gen-system '#%kernel - ;; Command-line argument: + ;; Command-line argument: - (define-values (machine) (string->symbol (vector-ref (current-command-line-arguments) 1))) - (define-values (srcdir) (vector-ref (current-command-line-arguments) 3)) - (define-values (slsp-suffix) (vector-ref (current-command-line-arguments) 4)) + (define-values (target-machine) (string->symbol (vector-ref (current-command-line-arguments) 1))) + (define-values (machine) (string->symbol (vector-ref (current-command-line-arguments) 2))) + (define-values (srcdir) (vector-ref (current-command-line-arguments) 4)) + (define-values (slsp-suffix) (vector-ref (current-command-line-arguments) 5)) (define-values (definitions) (call-with-input-file @@ -34,7 +35,9 @@ (define-values (parse-cond) (lambda (e) - (if (matches? e '(case (machine-type) . _)) + (if (if (matches? e '(case (machine-type) . _)) + #t + (matches? e '(case (reflect-machine-type) . _))) (letrec-values ([(loop) (lambda (l) (if (null? l) @@ -132,7 +135,7 @@ (system-type 'fs-change)) 'target-machine (if (equal? "any" (vector-ref (current-command-line-arguments) 2)) #f - machine))) + target-machine))) (call-with-output-file (vector-ref (current-command-line-arguments) 0) diff --git a/racket/src/cs/c/to-pbchunk.ss b/racket/src/cs/c/to-pbchunk.ss new file mode 100644 index 00000000000..99962350c15 --- /dev/null +++ b/racket/src/cs/c/to-pbchunk.ss @@ -0,0 +1,57 @@ +(define compressed? #f) + +(define-values (petite.boot scheme.boot racket.boot) + (let loop ([args (command-line-arguments)]) + (cond + [(and (pair? args) + (equal? (car args) "--compress")) + (set! compressed? #t) + (loop (cdr args))] + [(and (pair? args) + (equal? (car args) "--xpatch") + (pair? (cdr args))) + (load (cadr args)) + (loop (cddr args))] + [(null? args) + (error 'to-vfasl "missing petite.boot argument")] + [(null? (cdr args)) + (error 'to-vfasl "missing scheme.boot argument")] + [(null? (cddr args)) + (error 'to-vfasl "missing racket.boot argument")] + [(not (null? (cdddr args))) + (error 'to-vfasl "extra arguments")] + [else + (values (car args) (cadr args) (caddr args))]))) + +(fasl-compressed compressed?) + +(define (many fmt) + (map (lambda (i) + (format fmt i)) + (iota 10))) + +(define (generate in.boot out.boot c~a reg~a start-index) + (printf "Converting ~a to ~a and ~a\n" in.boot out.boot c~a) + (flush-output-port) + (time + (pbchunk-convert-file in.boot + out.boot + (many c~a) + (many reg~a) + start-index))) + +(define post-petite-index (generate petite.boot + "petite-pbchunk.boot" + "petite~a.c" + "register_petite~a_pbchunks" + 0)) +(define post-scheme-index (generate scheme.boot + "scheme-pbchunk.boot" + "scheme~a.c" + "register_scheme~a_pbchunks" + post-petite-index)) +(define post-racket-index (generate racket.boot + "racket-pbchunk.boot" + "racket~a.c" + "register_racket~a_pbchunks" + post-scheme-index)) diff --git a/racket/src/cs/rumble/system.ss b/racket/src/cs/rumble/system.ss index 2e83e51fb4a..7d5a7e35976 100644 --- a/racket/src/cs/rumble/system.ss +++ b/racket/src/cs/rumble/system.ss @@ -17,15 +17,25 @@ ;; Definitons like `os-symbol` are also parsed by "../c/gen-system.rkt" +(define-syntax (reflect-machine-type stx) + (case (#%$target-machine) + [(pb tpb + pb64l tpb64l pb64b tpb64b + pb32l tpb32l pb32b tpb32b) + (let ([s (getenv "PLT_CS_MACHINE_TYPE")]) + (unless s (error 'machine-type "need PLT_CS_MACHINE_TYPE")) + #`(quote #,(#%datum->syntax #'here (string->symbol s))))] + [else #'(machine-type)])) + (define os-symbol - (case (machine-type) + (case (reflect-machine-type) [(a6osx ta6osx i3osx ti3osx arm64osx tarm64osx ppc32osx tppc32osx) (if unix-style-macos? 'unix 'macosx)] [(a6nt ta6nt i3nt ti3nt) 'windows] [else 'unix])) (define os*-symbol - (case (machine-type) + (case (reflect-machine-type) [(a6osx ta6osx i3osx ti3osx arm64osx tarm64osx @@ -52,11 +62,10 @@ 'netbsd] [(a6s2 ta6s2 i3s2 ti3s2) 'solaris] [(i3qnx) 'qnx] - [(pb tpb pb32 tpb32) 'generic] [else (error 'system-type "internal error: unknown operating system")])) (define arch-symbol - (case (machine-type) + (case (reflect-machine-type) [(a6osx ta6osx a6nt ta6nt a6le ta6le @@ -91,11 +100,10 @@ ppc32ob tppc32ob ppc32nb tppc32nb) 'ppc] - [(pb tpb pb32 tpb32) 'pb] [else (error 'system-type "internal error: unknown architecture")])) (define link-symbol - (case (machine-type) + (case (reflect-machine-type) [(a6osx ta6osx i3osx ti3osx arm64osx tarm64osx) (if unix-style-macos? 'static @@ -106,13 +114,13 @@ 'static)])) (define so-suffix-bytes - (case (machine-type) + (case (reflect-machine-type) [(a6osx ta6osx i3osx ti3osx arm64osx tarm64osx ppc32osx tppc32osx) (string->utf8 ".dylib")] [(a6nt ta6nt i3nt ti3nt) (string->utf8 ".dll")] [else (string->utf8 ".so")])) (define so-mode - (case (machine-type) + (case (reflect-machine-type) [(arm64osx tarm64osx) 'global] [else 'local])) @@ -159,13 +167,13 @@ mode)])]))) (define (system-path-convention-type) - (case (machine-type) + (case (reflect-machine-type) [(a6nt ta6nt i3nt ti3nt) 'windows] [else 'unix])) (define system-library-subpath-string (string-append - (case (machine-type) + (case (reflect-machine-type) [(a6nt ta6nt) "win32\\x86_64"] [(i3nt ti3nt) "win32\\i386"] [else (string-append (symbol->string arch-symbol) diff --git a/racket/src/version/racket_version.h b/racket/src/version/racket_version.h index 9c8653ceb9c..1109b7efe33 100644 --- a/racket/src/version/racket_version.h +++ b/racket/src/version/racket_version.h @@ -16,7 +16,7 @@ #define MZSCHEME_VERSION_X 8 #define MZSCHEME_VERSION_Y 4 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 4 +#define MZSCHEME_VERSION_W 5 /* A level of indirection makes `#` work as needed: */ #define AS_a_STR_HELPER(x) #x diff --git a/racket/src/worksp/csbuild.rkt b/racket/src/worksp/csbuild.rkt index b6a7f72c509..d3f5ff3ab8e 100644 --- a/racket/src/worksp/csbuild.rkt +++ b/racket/src/worksp/csbuild.rkt @@ -317,6 +317,7 @@ "../cs/c/gen-system.rkt" (format "../../lib/system~a.rktd" cs-suffix) machine + machine "machine" "../cs/c" "")